From 10a14397e7295f79bb65ff505e52895f4864270a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?H=C3=A9cate=20Moonlight?= Date: Wed, 24 May 2023 09:32:24 +0200 Subject: [PATCH 1/3] Format the codebase with Fourmolu --- Cabal-syntax/Setup.hs | 1 + Cabal-syntax/src/Distribution/Backpack.hs | 184 +- .../src/Distribution/CabalSpecVersion.hs | 157 +- .../src/Distribution/Compat/Binary.hs | 10 +- .../src/Distribution/Compat/CharParsing.hs | 97 +- Cabal-syntax/src/Distribution/Compat/DList.hs | 27 +- .../src/Distribution/Compat/Exception.hs | 15 +- Cabal-syntax/src/Distribution/Compat/Graph.hs | 296 +- Cabal-syntax/src/Distribution/Compat/Lens.hs | 116 +- .../src/Distribution/Compat/MonadFail.hs | 3 +- .../src/Distribution/Compat/Newtype.hs | 46 +- .../src/Distribution/Compat/NonEmptySet.hs | 92 +- .../src/Distribution/Compat/Parsing.hs | 90 +- .../src/Distribution/Compat/Prelude.hs | 285 +- .../src/Distribution/Compat/Semigroup.hs | 69 +- .../src/Distribution/Compat/Typeable.hs | 11 +- Cabal-syntax/src/Distribution/Compiler.hs | 158 +- Cabal-syntax/src/Distribution/FieldGrammar.hs | 71 +- .../src/Distribution/FieldGrammar/Class.hs | 359 +- .../Distribution/FieldGrammar/FieldDescrs.hs | 150 +- .../src/Distribution/FieldGrammar/Newtypes.hs | 381 +- .../src/Distribution/FieldGrammar/Parsec.hs | 570 +- .../src/Distribution/FieldGrammar/Pretty.hs | 178 +- Cabal-syntax/src/Distribution/Fields.hs | 65 +- .../src/Distribution/Fields/ConfVar.hs | 166 +- Cabal-syntax/src/Distribution/Fields/Field.hs | 102 +- .../src/Distribution/Fields/LexerMonad.hs | 161 +- .../src/Distribution/Fields/ParseResult.hs | 142 +- .../src/Distribution/Fields/Parser.hs | 241 +- .../src/Distribution/Fields/Pretty.hs | 159 +- .../src/Distribution/InstalledPackageInfo.hs | 95 +- Cabal-syntax/src/Distribution/License.hs | 223 +- Cabal-syntax/src/Distribution/ModuleName.hs | 75 +- Cabal-syntax/src/Distribution/Package.hs | 42 +- .../src/Distribution/PackageDescription.hs | 105 +- .../PackageDescription/Configuration.hs | 637 +- .../PackageDescription/FieldGrammar.hs | 1107 +-- .../Distribution/PackageDescription/Parsec.hs | 1034 +-- .../PackageDescription/PrettyPrint.hs | 239 +- .../Distribution/PackageDescription/Quirks.hs | 652 +- .../Distribution/PackageDescription/Utils.hs | 16 +- Cabal-syntax/src/Distribution/Parsec.hs | 542 +- Cabal-syntax/src/Distribution/Parsec/Error.hs | 15 +- .../Distribution/Parsec/FieldLineStream.hs | 108 +- .../src/Distribution/Parsec/Position.hs | 26 +- .../src/Distribution/Parsec/Warning.hs | 93 +- Cabal-syntax/src/Distribution/Pretty.hs | 98 +- Cabal-syntax/src/Distribution/SPDX.hs | 61 +- Cabal-syntax/src/Distribution/SPDX/License.hs | 31 +- .../Distribution/SPDX/LicenseExpression.hs | 170 +- .../Distribution/SPDX/LicenseListVersion.hs | 22 +- .../src/Distribution/SPDX/LicenseReference.hs | 76 +- Cabal-syntax/src/Distribution/System.hs | 291 +- Cabal-syntax/src/Distribution/Text.hs | 3 +- .../src/Distribution/Types/AbiDependency.hs | 31 +- .../src/Distribution/Types/AbiHash.hs | 16 +- .../src/Distribution/Types/Benchmark.hs | 82 +- .../src/Distribution/Types/Benchmark/Lens.hs | 20 +- .../Distribution/Types/BenchmarkInterface.hs | 43 +- .../src/Distribution/Types/BenchmarkType.hs | 40 +- .../src/Distribution/Types/BuildInfo.hs | 459 +- .../src/Distribution/Types/BuildInfo/Lens.hs | 491 +- .../src/Distribution/Types/BuildType.hs | 48 +- .../src/Distribution/Types/Component.hs | 112 +- .../src/Distribution/Types/ComponentId.hs | 17 +- .../src/Distribution/Types/ComponentName.hs | 100 +- .../Types/ComponentRequestedSpec.hs | 69 +- .../src/Distribution/Types/CondTree.hs | 138 +- .../src/Distribution/Types/Condition.hs | 142 +- .../src/Distribution/Types/ConfVar.hs | 24 +- .../src/Distribution/Types/Dependency.hs | 117 +- .../src/Distribution/Types/DependencyMap.hs | 48 +- .../src/Distribution/Types/ExeDependency.hs | 39 +- .../src/Distribution/Types/Executable.hs | 68 +- .../src/Distribution/Types/Executable/Lens.hs | 22 +- .../src/Distribution/Types/ExecutableScope.hs | 36 +- .../src/Distribution/Types/ExposedModule.hs | 41 +- Cabal-syntax/src/Distribution/Types/Flag.hs | 207 +- .../src/Distribution/Types/ForeignLib.hs | 208 +- .../src/Distribution/Types/ForeignLib/Lens.hs | 32 +- .../Distribution/Types/ForeignLibOption.hs | 28 +- .../src/Distribution/Types/ForeignLibType.hs | 52 +- .../Types/GenericPackageDescription.hs | 115 +- .../Types/GenericPackageDescription/Lens.hs | 99 +- .../src/Distribution/Types/HookedBuildInfo.hs | 6 +- .../src/Distribution/Types/IncludeRenaming.hs | 72 +- .../Types/InstalledPackageInfo.hs | 259 +- .../InstalledPackageInfo/FieldGrammar.hs | 295 +- .../Types/InstalledPackageInfo/Lens.hs | 116 +- .../Distribution/Types/LegacyExeDependency.hs | 40 +- Cabal-syntax/src/Distribution/Types/Lens.hs | 26 +- .../src/Distribution/Types/Library.hs | 90 +- .../src/Distribution/Types/Library/Lens.hs | 32 +- .../src/Distribution/Types/LibraryName.hs | 49 +- .../Distribution/Types/LibraryVisibility.hs | 39 +- Cabal-syntax/src/Distribution/Types/Mixin.hs | 68 +- Cabal-syntax/src/Distribution/Types/Module.hs | 32 +- .../src/Distribution/Types/ModuleReexport.hs | 50 +- .../src/Distribution/Types/ModuleRenaming.hs | 147 +- .../src/Distribution/Types/MungedPackageId.hs | 42 +- .../Distribution/Types/MungedPackageName.hs | 63 +- .../Distribution/Types/PackageDescription.hs | 448 +- .../Types/PackageDescription/Lens.hs | 204 +- .../src/Distribution/Types/PackageId.hs | 45 +- .../src/Distribution/Types/PackageId/Lens.hs | 16 +- .../src/Distribution/Types/PackageName.hs | 19 +- .../Types/PackageVersionConstraint.hs | 39 +- .../Distribution/Types/PkgconfigDependency.hs | 28 +- .../src/Distribution/Types/PkgconfigName.hs | 32 +- .../Distribution/Types/PkgconfigVersion.hs | 60 +- .../Types/PkgconfigVersionRange.hs | 167 +- .../src/Distribution/Types/SetupBuildInfo.hs | 35 +- .../Distribution/Types/SetupBuildInfo/Lens.hs | 14 +- .../src/Distribution/Types/SourceRepo.hs | 128 +- .../src/Distribution/Types/SourceRepo/Lens.hs | 28 +- .../src/Distribution/Types/TestSuite.hs | 99 +- .../src/Distribution/Types/TestSuite/Lens.hs | 20 +- .../Distribution/Types/TestSuiteInterface.hs | 51 +- .../src/Distribution/Types/TestType.hs | 52 +- Cabal-syntax/src/Distribution/Types/UnitId.hs | 35 +- .../Distribution/Types/UnqualComponentName.hs | 26 +- .../src/Distribution/Types/Version.hs | 247 +- .../src/Distribution/Types/VersionInterval.hs | 186 +- .../Types/VersionInterval/Legacy.hs | 343 +- .../src/Distribution/Types/VersionRange.hs | 193 +- .../Types/VersionRange/Internal.hs | 571 +- Cabal-syntax/src/Distribution/Utils/Base62.hs | 16 +- .../src/Distribution/Utils/Generic.hs | 436 +- Cabal-syntax/src/Distribution/Utils/MD5.hs | 56 +- Cabal-syntax/src/Distribution/Utils/Path.hs | 54 +- .../src/Distribution/Utils/ShortText.hs | 47 +- Cabal-syntax/src/Distribution/Utils/String.hs | 122 +- .../src/Distribution/Utils/Structured.hs | 322 +- Cabal-syntax/src/Distribution/Version.hs | 189 +- .../src/Language/Haskell/Extension.hs | 1088 ++- Cabal/Setup.hs | 1 + .../Distribution/Backpack/ComponentsGraph.hs | 94 +- Cabal/src/Distribution/Backpack/Configure.hs | 577 +- .../Backpack/ConfiguredComponent.hs | 429 +- .../Distribution/Backpack/DescribeUnitId.hs | 51 +- Cabal/src/Distribution/Backpack/FullUnitId.hs | 25 +- Cabal/src/Distribution/Backpack/Id.hs | 155 +- .../Distribution/Backpack/LinkedComponent.hs | 478 +- Cabal/src/Distribution/Backpack/MixLink.hs | 300 +- Cabal/src/Distribution/Backpack/ModSubst.hs | 44 +- .../src/Distribution/Backpack/ModuleScope.hs | 101 +- .../src/Distribution/Backpack/ModuleShape.hs | 41 +- .../Backpack/PreExistingComponent.hs | 75 +- .../Distribution/Backpack/PreModuleShape.hs | 36 +- .../Distribution/Backpack/ReadyComponent.hs | 506 +- Cabal/src/Distribution/Backpack/UnifyM.hs | 581 +- Cabal/src/Distribution/Compat/Async.hs | 78 +- Cabal/src/Distribution/Compat/CopyFile.hs | 30 +- Cabal/src/Distribution/Compat/Directory.hs | 9 +- Cabal/src/Distribution/Compat/Environment.hs | 11 +- Cabal/src/Distribution/Compat/FilePath.hs | 9 +- .../Distribution/Compat/GetShortPathName.hs | 10 +- .../Distribution/Compat/Internal/TempFile.hs | 31 +- .../Distribution/Compat/Prelude/Internal.hs | 6 +- Cabal/src/Distribution/Compat/Process.hs | 16 +- Cabal/src/Distribution/Compat/ResponseFile.hs | 8 +- Cabal/src/Distribution/Compat/SnocList.hs | 19 +- Cabal/src/Distribution/Compat/Stack.hs | 32 +- Cabal/src/Distribution/Compat/Time.hs | 49 +- Cabal/src/Distribution/GetOpt.hs | 347 +- Cabal/src/Distribution/Lex.hs | 46 +- Cabal/src/Distribution/Make.hs | 86 +- .../Distribution/PackageDescription/Check.hs | 4057 ++++++----- Cabal/src/Distribution/ReadE.hs | 48 +- Cabal/src/Distribution/Simple.hs | 997 +-- Cabal/src/Distribution/Simple/Bench.hs | 186 +- Cabal/src/Distribution/Simple/Build.hs | 1217 ++-- Cabal/src/Distribution/Simple/Build/Macros.hs | 112 +- .../Simple/Build/PackageInfoModule.hs | 36 +- .../Simple/Build/PackageInfoModule/Z.hs | 22 +- .../Distribution/Simple/Build/PathsModule.hs | 186 +- Cabal/src/Distribution/Simple/BuildPaths.hs | 234 +- Cabal/src/Distribution/Simple/BuildTarget.hs | 1187 ++-- .../Distribution/Simple/BuildToolDepends.hs | 50 +- Cabal/src/Distribution/Simple/CCompiler.hs | 118 +- Cabal/src/Distribution/Simple/Command.hs | 914 +-- Cabal/src/Distribution/Simple/Compiler.hs | 409 +- Cabal/src/Distribution/Simple/Configure.hs | 3519 ++++++---- .../Distribution/Simple/ConfigureScript.hs | 185 +- Cabal/src/Distribution/Simple/Flag.hs | 71 +- Cabal/src/Distribution/Simple/GHC.hs | 2971 ++++---- .../Simple/GHC/EnvironmentParser.hs | 54 +- Cabal/src/Distribution/Simple/GHC/ImplInfo.hs | 162 +- Cabal/src/Distribution/Simple/GHC/Internal.hs | 1156 ++-- Cabal/src/Distribution/Simple/GHCJS.hs | 2459 ++++--- Cabal/src/Distribution/Simple/Glob.hs | 212 +- Cabal/src/Distribution/Simple/Haddock.hs | 1695 +++-- Cabal/src/Distribution/Simple/HaskellSuite.hs | 197 +- Cabal/src/Distribution/Simple/Hpc.hs | 261 +- Cabal/src/Distribution/Simple/Install.hs | 383 +- Cabal/src/Distribution/Simple/InstallDirs.hs | 511 +- .../Simple/InstallDirs/Internal.hs | 225 +- .../src/Distribution/Simple/LocalBuildInfo.hs | 497 +- .../Distribution/Simple/PackageDescription.hs | 125 +- Cabal/src/Distribution/Simple/PackageIndex.hs | 698 +- Cabal/src/Distribution/Simple/PreProcess.hs | 1310 ++-- .../Distribution/Simple/PreProcess/Unlit.hs | 194 +- Cabal/src/Distribution/Simple/Program.hs | 241 +- Cabal/src/Distribution/Simple/Program/Ar.hs | 295 +- .../Distribution/Simple/Program/Builtin.hs | 495 +- Cabal/src/Distribution/Simple/Program/Db.hs | 494 +- Cabal/src/Distribution/Simple/Program/Find.hs | 115 +- Cabal/src/Distribution/Simple/Program/GHC.hs | 1333 ++-- .../src/Distribution/Simple/Program/HcPkg.hs | 586 +- Cabal/src/Distribution/Simple/Program/Hpc.hs | 157 +- .../Distribution/Simple/Program/Internal.hs | 43 +- Cabal/src/Distribution/Simple/Program/Ld.hs | 96 +- .../Simple/Program/ResponseFile.hs | 36 +- Cabal/src/Distribution/Simple/Program/Run.hs | 353 +- .../src/Distribution/Simple/Program/Script.hs | 160 +- .../src/Distribution/Simple/Program/Strip.hs | 76 +- .../src/Distribution/Simple/Program/Types.hs | 214 +- Cabal/src/Distribution/Simple/Register.hs | 877 ++- Cabal/src/Distribution/Simple/Setup.hs | 153 +- .../Distribution/Simple/Setup/Benchmark.hs | 127 +- Cabal/src/Distribution/Simple/Setup/Build.hs | 177 +- Cabal/src/Distribution/Simple/Setup/Clean.hs | 84 +- Cabal/src/Distribution/Simple/Setup/Common.hs | 342 +- Cabal/src/Distribution/Simple/Setup/Config.hs | 1445 ++-- Cabal/src/Distribution/Simple/Setup/Copy.hs | 161 +- Cabal/src/Distribution/Simple/Setup/Global.hs | 122 +- .../src/Distribution/Simple/Setup/Haddock.hs | 969 +-- .../src/Distribution/Simple/Setup/Hscolour.hs | 190 +- .../src/Distribution/Simple/Setup/Install.hs | 170 +- .../src/Distribution/Simple/Setup/Register.hs | 241 +- Cabal/src/Distribution/Simple/Setup/Repl.hs | 233 +- Cabal/src/Distribution/Simple/Setup/SDist.hs | 115 +- Cabal/src/Distribution/Simple/Setup/Test.hs | 313 +- .../src/Distribution/Simple/ShowBuildInfo.hs | 118 +- Cabal/src/Distribution/Simple/SrcDist.hs | 677 +- Cabal/src/Distribution/Simple/Test.hs | 219 +- Cabal/src/Distribution/Simple/Test/ExeV10.hs | 333 +- Cabal/src/Distribution/Simple/Test/LibV09.hs | 418 +- Cabal/src/Distribution/Simple/Test/Log.hs | 201 +- Cabal/src/Distribution/Simple/UHC.hs | 371 +- Cabal/src/Distribution/Simple/UserHooks.hs | 287 +- Cabal/src/Distribution/Simple/Utils.hs | 1536 +++-- Cabal/src/Distribution/TestSuite.hs | 139 +- Cabal/src/Distribution/Types/AnnotatedId.hs | 28 +- .../Distribution/Types/ComponentInclude.hs | 30 +- .../Types/ComponentLocalBuildInfo.hs | 193 +- Cabal/src/Distribution/Types/DumpBuildInfo.hs | 5 +- .../src/Distribution/Types/GivenComponent.hs | 19 +- .../src/Distribution/Types/LocalBuildInfo.hs | 352 +- Cabal/src/Distribution/Types/TargetInfo.hs | 37 +- Cabal/src/Distribution/Utils/IOData.hs | 92 +- Cabal/src/Distribution/Utils/Json.hs | 71 +- Cabal/src/Distribution/Utils/LogProgress.hs | 76 +- Cabal/src/Distribution/Utils/MapAccum.hs | 22 +- Cabal/src/Distribution/Utils/NubList.hs | 53 +- Cabal/src/Distribution/Utils/Progress.hs | 47 +- Cabal/src/Distribution/Utils/UnionFind.hs | 90 +- Cabal/src/Distribution/Verbosity.hs | 243 +- Cabal/src/Distribution/Verbosity/Internal.hs | 26 +- Cabal/src/Distribution/ZinzaPrelude.hs | 45 +- cabal-install/Setup.hs | 1 + cabal-install/main/Main.hs | 2 +- .../Client/BuildReports/Anonymous.hs | 167 +- .../Distribution/Client/BuildReports/Lens.hs | 36 +- .../Client/BuildReports/Storage.hs | 270 +- .../Distribution/Client/BuildReports/Types.hs | 160 +- .../Client/BuildReports/Upload.hs | 53 +- .../src/Distribution/Client/Check.hs | 156 +- .../src/Distribution/Client/CmdBench.hs | 394 +- .../src/Distribution/Client/CmdBuild.hs | 285 +- .../src/Distribution/Client/CmdClean.hs | 249 +- .../src/Distribution/Client/CmdConfigure.hs | 231 +- .../Distribution/Client/CmdErrorMessages.hs | 573 +- .../src/Distribution/Client/CmdExec.hs | 299 +- .../src/Distribution/Client/CmdFreeze.hs | 337 +- .../src/Distribution/Client/CmdHaddock.hs | 362 +- .../Distribution/Client/CmdHaddockProject.hs | 618 +- .../src/Distribution/Client/CmdInstall.hs | 1397 ++-- .../Client/CmdInstall/ClientInstallFlags.hs | 126 +- .../CmdInstall/ClientInstallTargetSelector.hs | 72 +- .../src/Distribution/Client/CmdLegacy.hs | 163 +- .../src/Distribution/Client/CmdListBin.hs | 495 +- .../src/Distribution/Client/CmdOutdated.hs | 518 +- .../src/Distribution/Client/CmdRepl.hs | 633 +- .../src/Distribution/Client/CmdRun.hs | 662 +- .../src/Distribution/Client/CmdSdist.hs | 535 +- .../src/Distribution/Client/CmdTest.hs | 406 +- .../src/Distribution/Client/CmdUpdate.hs | 348 +- .../Distribution/Client/Compat/Directory.hs | 13 +- .../Client/Compat/ExecutablePath.hs | 6 +- .../src/Distribution/Client/Compat/Orphans.hs | 36 +- .../src/Distribution/Client/Compat/Prelude.hs | 5 +- .../Distribution/Client/Compat/Semaphore.hs | 89 +- .../src/Distribution/Client/Config.hs | 2367 ++++--- .../src/Distribution/Client/Configure.hs | 835 ++- .../src/Distribution/Client/Dependency.hs | 1519 ++-- .../Distribution/Client/Dependency/Types.hs | 72 +- .../src/Distribution/Client/DistDirLayout.hs | 350 +- .../src/Distribution/Client/Fetch.hs | 380 +- .../src/Distribution/Client/FetchUtils.hs | 439 +- .../src/Distribution/Client/FileMonitor.hs | 1333 ++-- .../src/Distribution/Client/Freeze.hs | 440 +- .../src/Distribution/Client/GZipUtils.hs | 15 +- .../src/Distribution/Client/GenBounds.hs | 220 +- cabal-install/src/Distribution/Client/Get.hs | 473 +- cabal-install/src/Distribution/Client/Glob.hs | 260 +- .../src/Distribution/Client/GlobalFlags.hs | 459 +- .../src/Distribution/Client/Haddock.hs | 107 +- .../src/Distribution/Client/HashValue.hs | 45 +- .../src/Distribution/Client/HttpUtils.hs | 1376 ++-- .../src/Distribution/Client/IndexUtils.hs | 1400 ++-- .../Client/IndexUtils/ActiveRepos.hs | 181 +- .../Client/IndexUtils/IndexState.hs | 101 +- .../Client/IndexUtils/Timestamp.hs | 168 +- cabal-install/src/Distribution/Client/Init.hs | 50 +- .../src/Distribution/Client/Init/Defaults.hs | 213 +- .../Distribution/Client/Init/FileCreators.hs | 261 +- .../Client/Init/FlagExtractors.hs | 193 +- .../src/Distribution/Client/Init/Format.hs | 546 +- .../Client/Init/Interactive/Command.hs | 419 +- .../src/Distribution/Client/Init/Licenses.hs | 52 +- .../Client/Init/NonInteractive/Command.hs | 327 +- .../Client/Init/NonInteractive/Heuristics.hs | 109 +- .../src/Distribution/Client/Init/Prompt.hs | 183 +- .../src/Distribution/Client/Init/Simple.hs | 234 +- .../src/Distribution/Client/Init/Types.hs | 599 +- .../src/Distribution/Client/Init/Utils.hs | 257 +- .../src/Distribution/Client/Install.hs | 2992 ++++---- .../src/Distribution/Client/InstallPlan.hs | 1177 ++-- .../src/Distribution/Client/InstallSymlink.hs | 411 +- .../src/Distribution/Client/JobControl.hs | 130 +- cabal-install/src/Distribution/Client/List.hs | 1051 +-- cabal-install/src/Distribution/Client/Main.hs | 1436 ++-- .../src/Distribution/Client/Manpage.hs | 211 +- .../src/Distribution/Client/ManpageFlags.hs | 38 +- cabal-install/src/Distribution/Client/Nix.hs | 97 +- .../Distribution/Client/NixStyleOptions.hs | 169 +- .../src/Distribution/Client/PackageHash.hs | 417 +- .../src/Distribution/Client/ParseUtils.hs | 365 +- .../Distribution/Client/ProjectBuilding.hs | 2323 ++++--- .../Client/ProjectBuilding/Types.hs | 237 +- .../src/Distribution/Client/ProjectConfig.hs | 2067 +++--- .../Client/ProjectConfig/Legacy.hs | 2913 ++++---- .../Client/ProjectConfig/Types.hs | 612 +- .../src/Distribution/Client/ProjectFlags.hs | 128 +- .../Client/ProjectOrchestration.hs | 1843 ++--- .../Distribution/Client/ProjectPlanOutput.hs | 1308 ++-- .../Distribution/Client/ProjectPlanning.hs | 6101 +++++++++-------- .../Client/ProjectPlanning/Types.hs | 1039 ++- .../src/Distribution/Client/RebuildMonad.hs | 281 +- .../src/Distribution/Client/Reconfigure.hs | 254 +- cabal-install/src/Distribution/Client/Run.hs | 205 +- .../src/Distribution/Client/Sandbox.hs | 126 +- .../Client/Sandbox/PackageEnvironment.hs | 413 +- .../src/Distribution/Client/SavedFlags.hs | 47 +- .../src/Distribution/Client/ScriptUtils.hs | 429 +- .../src/Distribution/Client/Security/DNS.hs | 29 +- .../src/Distribution/Client/Security/HTTP.hs | 152 +- .../src/Distribution/Client/Setup.hs | 4840 +++++++------ .../src/Distribution/Client/SetupWrapper.hs | 1451 ++-- .../src/Distribution/Client/Signal.hs | 4 +- .../Distribution/Client/SolverInstallPlan.hs | 442 +- .../src/Distribution/Client/SourceFiles.hs | 207 +- .../src/Distribution/Client/SrcDist.hs | 128 +- .../src/Distribution/Client/Store.hs | 168 +- cabal-install/src/Distribution/Client/Tar.hs | 107 +- .../src/Distribution/Client/TargetProblem.hs | 77 +- .../src/Distribution/Client/TargetSelector.hs | 2522 +++---- .../src/Distribution/Client/Targets.hs | 933 +-- .../src/Distribution/Client/Types.hs | 36 +- .../Distribution/Client/Types/AllowNewer.hs | 211 +- .../Distribution/Client/Types/BuildResults.hs | 51 +- .../Distribution/Client/Types/ConfiguredId.hs | 49 +- .../Client/Types/ConfiguredPackage.hs | 67 +- .../Distribution/Client/Types/Credentials.hs | 12 +- .../Client/Types/InstallMethod.hs | 25 +- .../Client/Types/OverwritePolicy.hs | 29 +- .../Client/Types/PackageLocation.hs | 40 +- .../Client/Types/PackageSpecifier.hs | 62 +- .../Distribution/Client/Types/ReadyPackage.hs | 34 +- .../src/Distribution/Client/Types/Repo.hs | 178 +- .../src/Distribution/Client/Types/RepoName.hs | 24 +- .../Client/Types/SourcePackageDb.hs | 25 +- .../Distribution/Client/Types/SourceRepo.hs | 113 +- .../Types/WriteGhcEnvironmentFilesPolicy.hs | 9 +- .../src/Distribution/Client/Upload.hs | 413 +- .../src/Distribution/Client/Utils.hs | 376 +- .../src/Distribution/Client/Utils/Json.hs | 139 +- .../src/Distribution/Client/Utils/Parsec.hs | 91 +- cabal-install/src/Distribution/Client/VCS.hs | 963 +-- .../src/Distribution/Client/Version.hs | 3 +- .../Distribution/Client/Win32SelfUpgrade.hs | 68 +- .../src/Distribution/Deprecated/ParseUtils.hs | 423 +- .../src/Distribution/Deprecated/ReadP.hs | 308 +- .../Deprecated/ViewAsFieldDescr.hs | 126 +- cabal-install/tests/IntegrationTests2.hs | 1 + .../build/ignore-project/Setup.hs | 1 + .../build/setup-custom1/Setup.hs | 1 + .../build/setup-custom2/Setup.hs | 1 + .../build/setup-simple/Setup.hs | 1 + cabal-install/tests/LongTests.hs | 51 +- cabal-install/tests/MemoryUsageTests.hs | 8 +- cabal-install/tests/UnitTests.hs | 119 +- .../Distribution/Client/ArbitraryInstances.hs | 382 +- .../Distribution/Client/BuildReport.hs | 22 +- .../Distribution/Client/Configure.hs | 186 +- .../Distribution/Client/Described.hs | 23 +- .../Distribution/Client/DescribedInstances.hs | 512 +- .../Distribution/Client/FetchUtils.hs | 51 +- .../Distribution/Client/FileMonitor.hs | 422 +- .../Distribution/Client/GZipUtils.hs | 59 +- .../UnitTests/Distribution/Client/Get.hs | 341 +- .../UnitTests/Distribution/Client/Glob.hs | 155 +- .../Distribution/Client/IndexUtils.hs | 113 +- .../Client/IndexUtils/Timestamp.hs | 37 +- .../UnitTests/Distribution/Client/Init.hs | 47 +- .../Distribution/Client/Init/FileCreators.hs | 110 +- .../Distribution/Client/Init/Golden.hs | 457 +- .../Distribution/Client/Init/Interactive.hs | 1992 +++--- .../Client/Init/NonInteractive.hs | 2795 ++++---- .../Distribution/Client/Init/Simple.hs | 241 +- .../Distribution/Client/Init/Utils.hs | 108 +- .../Distribution/Client/InstallPlan.hs | 308 +- .../Distribution/Client/JobControl.hs | 130 +- .../Distribution/Client/ProjectConfig.hs | 1283 ++-- .../Distribution/Client/ProjectPlanning.hs | 13 +- .../UnitTests/Distribution/Client/Store.hs | 154 +- .../UnitTests/Distribution/Client/Tar.hs | 97 +- .../UnitTests/Distribution/Client/Targets.hs | 141 +- .../Distribution/Client/TreeDiffInstances.hs | 6 +- .../Distribution/Client/UserConfig.hs | 124 +- .../UnitTests/Distribution/Client/VCS.hs | 1020 +-- .../Distribution/Solver/Modular/Builder.hs | 11 +- .../Distribution/Solver/Modular/DSL.hs | 1039 +-- .../Solver/Modular/DSL/TestCaseUtils.hs | 316 +- .../Solver/Modular/MemoryUsage.hs | 114 +- .../Distribution/Solver/Modular/QuickCheck.hs | 599 +- .../Solver/Modular/QuickCheck/Utils.hs | 14 +- .../Distribution/Solver/Modular/RetryLog.hs | 69 +- .../Distribution/Solver/Modular/Solver.hs | 2706 ++++---- .../Solver/Modular/WeightedPSQ.hs | 64 +- .../Solver/Types/OptionalStanza.hs | 36 +- cabal-install/tests/UnitTests/Options.hs | 44 +- cabal-install/tests/UnitTests/TempTestDir.hs | 59 +- 444 files changed, 84401 insertions(+), 68646 deletions(-) diff --git a/Cabal-syntax/Setup.hs b/Cabal-syntax/Setup.hs index b55cb169539..00bfe1fe441 100644 --- a/Cabal-syntax/Setup.hs +++ b/Cabal-syntax/Setup.hs @@ -1,3 +1,4 @@ import Distribution.Simple + main :: IO () main = defaultMain diff --git a/Cabal-syntax/src/Distribution/Backpack.hs b/Cabal-syntax/src/Distribution/Backpack.hs index 2a2837ae7e6..b30028bc41c 100644 --- a/Cabal-syntax/src/Distribution/Backpack.hs +++ b/Cabal-syntax/src/Distribution/Backpack.hs @@ -1,51 +1,50 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} -- | This module defines the core data types for Backpack. For more -- details, see: -- -- - -module Distribution.Backpack ( - -- * OpenUnitId - OpenUnitId(..), - openUnitIdFreeHoles, - mkOpenUnitId, +module Distribution.Backpack + ( -- * OpenUnitId + OpenUnitId (..) + , openUnitIdFreeHoles + , mkOpenUnitId -- * DefUnitId - DefUnitId, - unDefUnitId, - mkDefUnitId, + , DefUnitId + , unDefUnitId + , mkDefUnitId -- * OpenModule - OpenModule(..), - openModuleFreeHoles, + , OpenModule (..) + , openModuleFreeHoles -- * OpenModuleSubst - OpenModuleSubst, - dispOpenModuleSubst, - dispOpenModuleSubstEntry, - parsecOpenModuleSubst, - parsecOpenModuleSubstEntry, - openModuleSubstFreeHoles, + , OpenModuleSubst + , dispOpenModuleSubst + , dispOpenModuleSubstEntry + , parsecOpenModuleSubst + , parsecOpenModuleSubstEntry + , openModuleSubstFreeHoles -- * Conversions to 'UnitId' - abstractUnitId, - hashModuleSubst, -) where + , abstractUnitId + , hashModuleSubst + ) where import Distribution.Compat.Prelude hiding (mod) import Distribution.Parsec import Distribution.Pretty +import Text.PrettyPrint (hcat) import Prelude () -import Text.PrettyPrint (hcat) import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp +import qualified Text.PrettyPrint as Disp import Distribution.ModuleName import Distribution.Types.ComponentId @@ -81,52 +80,53 @@ import qualified Data.Set as Set -- -- For more details see the Backpack spec -- --- - data OpenUnitId - -- | Identifies a component which may have some unfilled holes; + = -- | Identifies a component which may have some unfilled holes; -- specifying its 'ComponentId' and its 'OpenModuleSubst'. -- TODO: Invariant that 'OpenModuleSubst' is non-empty? -- See also the Text instance. - = IndefFullUnitId ComponentId OpenModuleSubst - -- | Identifies a fully instantiated component, which has + IndefFullUnitId ComponentId OpenModuleSubst + | -- | Identifies a fully instantiated component, which has -- been compiled and abbreviated as a hash. The embedded 'UnitId' -- MUST NOT be for an indefinite component; an 'OpenUnitId' -- is guaranteed not to have any holes. - | DefiniteUnitId DefUnitId + DefiniteUnitId DefUnitId deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) + -- TODO: cache holes? instance Binary OpenUnitId instance Structured OpenUnitId instance NFData OpenUnitId where - rnf (IndefFullUnitId cid subst) = rnf cid `seq` rnf subst - rnf (DefiniteUnitId uid) = rnf uid + rnf (IndefFullUnitId cid subst) = rnf cid `seq` rnf subst + rnf (DefiniteUnitId uid) = rnf uid instance Pretty OpenUnitId where - pretty (IndefFullUnitId cid insts) - -- TODO: arguably a smart constructor to enforce invariant would be - -- better - | Map.null insts = pretty cid - | otherwise = pretty cid <<>> Disp.brackets (dispOpenModuleSubst insts) - pretty (DefiniteUnitId uid) = pretty uid + pretty (IndefFullUnitId cid insts) + -- TODO: arguably a smart constructor to enforce invariant would be + -- better + | Map.null insts = pretty cid + | otherwise = pretty cid <<>> Disp.brackets (dispOpenModuleSubst insts) + pretty (DefiniteUnitId uid) = pretty uid -- | -- -- >>> eitherParsec "foobar" :: Either String OpenUnitId ---Right (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "foobar"})) +-- Right (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "foobar"})) -- -- >>> eitherParsec "foo[Str=text-1.2.3:Data.Text.Text]" :: Either String OpenUnitId -- Right (IndefFullUnitId (ComponentId "foo") (fromList [(ModuleName "Str",OpenModule (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "text-1.2.3"})) (ModuleName "Data.Text.Text"))])) --- instance Parsec OpenUnitId where - parsec = P.try parseOpenUnitId <|> fmap DefiniteUnitId parsec - where - parseOpenUnitId = do - cid <- parsec - insts <- P.between (P.char '[') (P.char ']') - parsecOpenModuleSubst - return (IndefFullUnitId cid insts) + parsec = P.try parseOpenUnitId <|> fmap DefiniteUnitId parsec + where + parseOpenUnitId = do + cid <- parsec + insts <- + P.between + (P.char '[') + (P.char ']') + parsecOpenModuleSubst + return (IndefFullUnitId cid insts) -- | Get the set of holes ('ModuleVar') embedded in a 'UnitId'. openUnitIdFreeHoles :: OpenUnitId -> Set ModuleName @@ -137,9 +137,9 @@ openUnitIdFreeHoles _ = Set.empty -- is if the instantiation is provided. mkOpenUnitId :: UnitId -> ComponentId -> OpenModuleSubst -> OpenUnitId mkOpenUnitId uid cid insts = - if Set.null (openModuleSubstFreeHoles insts) - then DefiniteUnitId (unsafeMkDefUnitId uid) -- invariant holds! - else IndefFullUnitId cid insts + if Set.null (openModuleSubstFreeHoles insts) + then DefiniteUnitId (unsafeMkDefUnitId uid) -- invariant holds! + else IndefFullUnitId cid insts ----------------------------------------------------------------------- -- DefUnitId @@ -148,9 +148,12 @@ mkOpenUnitId uid cid insts = -- with no holes. mkDefUnitId :: ComponentId -> Map ModuleName Module -> DefUnitId mkDefUnitId cid insts = - unsafeMkDefUnitId (mkUnitId - (unComponentId cid ++ maybe "" ("+"++) (hashModuleSubst insts))) - -- impose invariant! + unsafeMkDefUnitId + ( mkUnitId + (unComponentId cid ++ maybe "" ("+" ++) (hashModuleSubst insts)) + ) + +-- impose invariant! ----------------------------------------------------------------------- -- OpenModule @@ -160,42 +163,41 @@ mkDefUnitId cid insts = -- hole that needs to be filled in. Substitutions are over -- module variables. data OpenModule - = OpenModule OpenUnitId ModuleName - | OpenModuleVar ModuleName + = OpenModule OpenUnitId ModuleName + | OpenModuleVar ModuleName deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) instance Binary OpenModule instance Structured OpenModule instance NFData OpenModule where - rnf (OpenModule uid mod_name) = rnf uid `seq` rnf mod_name - rnf (OpenModuleVar mod_name) = rnf mod_name + rnf (OpenModule uid mod_name) = rnf uid `seq` rnf mod_name + rnf (OpenModuleVar mod_name) = rnf mod_name instance Pretty OpenModule where - pretty (OpenModule uid mod_name) = - hcat [pretty uid, Disp.text ":", pretty mod_name] - pretty (OpenModuleVar mod_name) = - hcat [Disp.char '<', pretty mod_name, Disp.char '>'] + pretty (OpenModule uid mod_name) = + hcat [pretty uid, Disp.text ":", pretty mod_name] + pretty (OpenModuleVar mod_name) = + hcat [Disp.char '<', pretty mod_name, Disp.char '>'] -- | -- -- >>> eitherParsec "Includes2-0.1.0.0-inplace-mysql:Database.MySQL" :: Either String OpenModule -- Right (OpenModule (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "Includes2-0.1.0.0-inplace-mysql"})) (ModuleName "Database.MySQL")) --- instance Parsec OpenModule where - parsec = parsecModuleVar <|> parsecOpenModule - where - parsecOpenModule = do - uid <- parsec - _ <- P.char ':' - mod_name <- parsec - return (OpenModule uid mod_name) - - parsecModuleVar = do - _ <- P.char '<' - mod_name <- parsec - _ <- P.char '>' - return (OpenModuleVar mod_name) + parsec = parsecModuleVar <|> parsecOpenModule + where + parsecOpenModule = do + uid <- parsec + _ <- P.char ':' + mod_name <- parsec + return (OpenModule uid mod_name) + + parsecModuleVar = do + _ <- P.char '<' + mod_name <- parsec + _ <- P.char '>' + return (OpenModuleVar mod_name) -- | Get the set of holes ('ModuleVar') embedded in a 'Module'. openModuleFreeHoles :: OpenModule -> Set ModuleName @@ -214,8 +216,8 @@ type OpenModuleSubst = Map ModuleName OpenModule -- | Pretty-print the entries of a module substitution, suitable -- for embedding into a 'OpenUnitId' or passing to GHC via @--instantiate-with@. dispOpenModuleSubst :: OpenModuleSubst -> Disp.Doc -dispOpenModuleSubst subst - = Disp.hcat +dispOpenModuleSubst subst = + Disp.hcat . Disp.punctuate Disp.comma $ map dispOpenModuleSubstEntry (Map.toAscList subst) @@ -227,19 +229,21 @@ dispOpenModuleSubstEntry (k, v) = pretty k <<>> Disp.char '=' <<>> pretty v -- -- @since 2.2 parsecOpenModuleSubst :: CabalParsing m => m OpenModuleSubst -parsecOpenModuleSubst = fmap Map.fromList - . flip P.sepBy (P.char ',') - $ parsecOpenModuleSubstEntry +parsecOpenModuleSubst = + fmap Map.fromList + . flip P.sepBy (P.char ',') + $ parsecOpenModuleSubstEntry -- | Inverse to 'dispModSubstEntry'. -- -- @since 2.2 parsecOpenModuleSubstEntry :: CabalParsing m => m (ModuleName, OpenModule) parsecOpenModuleSubstEntry = - do k <- parsec - _ <- P.char '=' - v <- parsec - return (k, v) + do + k <- parsec + _ <- P.char '=' + v <- parsec + return (k, v) -- | Get the set of holes ('ModuleVar') embedded in a 'OpenModuleSubst'. -- This is NOT the domain of the substitution. @@ -265,5 +269,7 @@ hashModuleSubst subst | Map.null subst = Nothing | otherwise = Just . hashToBase62 $ - concat [ prettyShow mod_name ++ "=" ++ prettyShow m ++ "\n" - | (mod_name, m) <- Map.toList subst] + concat + [ prettyShow mod_name ++ "=" ++ prettyShow m ++ "\n" + | (mod_name, m) <- Map.toList subst + ] diff --git a/Cabal-syntax/src/Distribution/CabalSpecVersion.hs b/Cabal-syntax/src/Distribution/CabalSpecVersion.hs index a307bb4b0f3..6290fa9166e 100644 --- a/Cabal-syntax/src/Distribution/CabalSpecVersion.hs +++ b/Cabal-syntax/src/Distribution/CabalSpecVersion.hs @@ -1,36 +1,38 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} + module Distribution.CabalSpecVersion where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -- | Different Cabal-the-spec versions. -- -- We branch based on this at least in the parser. --- data CabalSpecVersion - = CabalSpecV1_0 -- ^ this is older than 'CabalSpecV1_2' - | CabalSpecV1_2 -- ^ new syntax (sections) - | CabalSpecV1_4 - | CabalSpecV1_6 - | CabalSpecV1_8 - | CabalSpecV1_10 - | CabalSpecV1_12 - -- 1.16 -- 1.14: no changes - | CabalSpecV1_18 - | CabalSpecV1_20 - | CabalSpecV1_22 - | CabalSpecV1_24 - | CabalSpecV2_0 - | CabalSpecV2_2 - | CabalSpecV2_4 - | CabalSpecV3_0 - -- 3.2: no changes - | CabalSpecV3_4 - | CabalSpecV3_6 - | CabalSpecV3_8 - -- 3.10: no changes + = -- | this is older than 'CabalSpecV1_2' + CabalSpecV1_0 + | -- | new syntax (sections) + CabalSpecV1_2 + | CabalSpecV1_4 + | CabalSpecV1_6 + | CabalSpecV1_8 + | CabalSpecV1_10 + | CabalSpecV1_12 + | -- 1.16 -- 1.14: no changes + CabalSpecV1_18 + | CabalSpecV1_20 + | CabalSpecV1_22 + | CabalSpecV1_24 + | CabalSpecV2_0 + | CabalSpecV2_2 + | CabalSpecV2_4 + | CabalSpecV3_0 + | -- 3.2: no changes + CabalSpecV3_4 + | CabalSpecV3_6 + | CabalSpecV3_8 + -- 3.10: no changes deriving (Eq, Ord, Show, Read, Enum, Bounded, Typeable, Data, Generic) instance Binary CabalSpecVersion @@ -41,24 +43,24 @@ instance NFData CabalSpecVersion where rnf = genericRnf -- -- @since 3.0.0.0 showCabalSpecVersion :: CabalSpecVersion -> String -showCabalSpecVersion CabalSpecV3_8 = "3.8" -showCabalSpecVersion CabalSpecV3_6 = "3.6" -showCabalSpecVersion CabalSpecV3_4 = "3.4" -showCabalSpecVersion CabalSpecV3_0 = "3.0" -showCabalSpecVersion CabalSpecV2_4 = "2.4" -showCabalSpecVersion CabalSpecV2_2 = "2.2" -showCabalSpecVersion CabalSpecV2_0 = "2.0" +showCabalSpecVersion CabalSpecV3_8 = "3.8" +showCabalSpecVersion CabalSpecV3_6 = "3.6" +showCabalSpecVersion CabalSpecV3_4 = "3.4" +showCabalSpecVersion CabalSpecV3_0 = "3.0" +showCabalSpecVersion CabalSpecV2_4 = "2.4" +showCabalSpecVersion CabalSpecV2_2 = "2.2" +showCabalSpecVersion CabalSpecV2_0 = "2.0" showCabalSpecVersion CabalSpecV1_24 = "1.24" showCabalSpecVersion CabalSpecV1_22 = "1.22" showCabalSpecVersion CabalSpecV1_20 = "1.20" showCabalSpecVersion CabalSpecV1_18 = "1.18" showCabalSpecVersion CabalSpecV1_12 = "1.12" showCabalSpecVersion CabalSpecV1_10 = "1.10" -showCabalSpecVersion CabalSpecV1_8 = "1.8" -showCabalSpecVersion CabalSpecV1_6 = "1.6" -showCabalSpecVersion CabalSpecV1_4 = "1.4" -showCabalSpecVersion CabalSpecV1_2 = "1.2" -showCabalSpecVersion CabalSpecV1_0 = "1.0" +showCabalSpecVersion CabalSpecV1_8 = "1.8" +showCabalSpecVersion CabalSpecV1_6 = "1.6" +showCabalSpecVersion CabalSpecV1_4 = "1.4" +showCabalSpecVersion CabalSpecV1_2 = "1.2" +showCabalSpecVersion CabalSpecV1_0 = "1.0" cabalSpecLatest :: CabalSpecVersion cabalSpecLatest = CabalSpecV3_8 @@ -66,49 +68,48 @@ cabalSpecLatest = CabalSpecV3_8 -- | Parse 'CabalSpecVersion' from version digits. -- -- It may fail if for recent versions the version is not exact. --- cabalSpecFromVersionDigits :: [Int] -> Maybe CabalSpecVersion cabalSpecFromVersionDigits v - | v == [3,8] = Just CabalSpecV3_8 - | v == [3,6] = Just CabalSpecV3_6 - | v == [3,4] = Just CabalSpecV3_4 - | v == [3,0] = Just CabalSpecV3_0 - | v == [2,4] = Just CabalSpecV2_4 - | v == [2,2] = Just CabalSpecV2_2 - | v == [2,0] = Just CabalSpecV2_0 - | v >= [1,25] = Nothing - | v >= [1,23] = Just CabalSpecV1_24 - | v >= [1,21] = Just CabalSpecV1_22 - | v >= [1,19] = Just CabalSpecV1_20 - | v >= [1,17] = Just CabalSpecV1_18 - | v >= [1,11] = Just CabalSpecV1_12 - | v >= [1,9] = Just CabalSpecV1_10 - | v >= [1,7] = Just CabalSpecV1_8 - | v >= [1,5] = Just CabalSpecV1_6 - | v >= [1,3] = Just CabalSpecV1_4 - | v >= [1,1] = Just CabalSpecV1_2 - | otherwise = Just CabalSpecV1_0 + | v == [3, 8] = Just CabalSpecV3_8 + | v == [3, 6] = Just CabalSpecV3_6 + | v == [3, 4] = Just CabalSpecV3_4 + | v == [3, 0] = Just CabalSpecV3_0 + | v == [2, 4] = Just CabalSpecV2_4 + | v == [2, 2] = Just CabalSpecV2_2 + | v == [2, 0] = Just CabalSpecV2_0 + | v >= [1, 25] = Nothing + | v >= [1, 23] = Just CabalSpecV1_24 + | v >= [1, 21] = Just CabalSpecV1_22 + | v >= [1, 19] = Just CabalSpecV1_20 + | v >= [1, 17] = Just CabalSpecV1_18 + | v >= [1, 11] = Just CabalSpecV1_12 + | v >= [1, 9] = Just CabalSpecV1_10 + | v >= [1, 7] = Just CabalSpecV1_8 + | v >= [1, 5] = Just CabalSpecV1_6 + | v >= [1, 3] = Just CabalSpecV1_4 + | v >= [1, 1] = Just CabalSpecV1_2 + | otherwise = Just CabalSpecV1_0 -- | @since 3.4.0.0 cabalSpecToVersionDigits :: CabalSpecVersion -> [Int] -cabalSpecToVersionDigits CabalSpecV3_8 = [3,8] -cabalSpecToVersionDigits CabalSpecV3_6 = [3,6] -cabalSpecToVersionDigits CabalSpecV3_4 = [3,4] -cabalSpecToVersionDigits CabalSpecV3_0 = [3,0] -cabalSpecToVersionDigits CabalSpecV2_4 = [2,4] -cabalSpecToVersionDigits CabalSpecV2_2 = [2,2] -cabalSpecToVersionDigits CabalSpecV2_0 = [2,0] -cabalSpecToVersionDigits CabalSpecV1_24 = [1,24] -cabalSpecToVersionDigits CabalSpecV1_22 = [1,22] -cabalSpecToVersionDigits CabalSpecV1_20 = [1,20] -cabalSpecToVersionDigits CabalSpecV1_18 = [1,18] -cabalSpecToVersionDigits CabalSpecV1_12 = [1,12] -cabalSpecToVersionDigits CabalSpecV1_10 = [1,10] -cabalSpecToVersionDigits CabalSpecV1_8 = [1,8] -cabalSpecToVersionDigits CabalSpecV1_6 = [1,6] -cabalSpecToVersionDigits CabalSpecV1_4 = [1,4] -cabalSpecToVersionDigits CabalSpecV1_2 = [1,2] -cabalSpecToVersionDigits CabalSpecV1_0 = [1,0] +cabalSpecToVersionDigits CabalSpecV3_8 = [3, 8] +cabalSpecToVersionDigits CabalSpecV3_6 = [3, 6] +cabalSpecToVersionDigits CabalSpecV3_4 = [3, 4] +cabalSpecToVersionDigits CabalSpecV3_0 = [3, 0] +cabalSpecToVersionDigits CabalSpecV2_4 = [2, 4] +cabalSpecToVersionDigits CabalSpecV2_2 = [2, 2] +cabalSpecToVersionDigits CabalSpecV2_0 = [2, 0] +cabalSpecToVersionDigits CabalSpecV1_24 = [1, 24] +cabalSpecToVersionDigits CabalSpecV1_22 = [1, 22] +cabalSpecToVersionDigits CabalSpecV1_20 = [1, 20] +cabalSpecToVersionDigits CabalSpecV1_18 = [1, 18] +cabalSpecToVersionDigits CabalSpecV1_12 = [1, 12] +cabalSpecToVersionDigits CabalSpecV1_10 = [1, 10] +cabalSpecToVersionDigits CabalSpecV1_8 = [1, 8] +cabalSpecToVersionDigits CabalSpecV1_6 = [1, 6] +cabalSpecToVersionDigits CabalSpecV1_4 = [1, 4] +cabalSpecToVersionDigits CabalSpecV1_2 = [1, 2] +cabalSpecToVersionDigits CabalSpecV1_0 = [1, 0] -- | What is the minimum Cabal library version which knows how handle -- this spec version. @@ -124,20 +125,20 @@ cabalSpecToVersionDigits CabalSpecV1_0 = [1,0] -- -- @since 3.4.0.0 cabalSpecMinimumLibraryVersion :: CabalSpecVersion -> [Int] -cabalSpecMinimumLibraryVersion CabalSpecV1_0 = [1,0] +cabalSpecMinimumLibraryVersion CabalSpecV1_0 = [1, 0] cabalSpecMinimumLibraryVersion csv = case cabalSpecToVersionDigits (pred csv) of - [x,y] -> [x, y+1] - xs -> xs + [x, y] -> [x, y + 1] + xs -> xs specHasCommonStanzas :: CabalSpecVersion -> HasCommonStanzas specHasCommonStanzas v = - if v >= CabalSpecV2_2 + if v >= CabalSpecV2_2 then HasCommonStanzas else NoCommonStanzas specHasElif :: CabalSpecVersion -> HasElif specHasElif v = - if v >= CabalSpecV2_2 + if v >= CabalSpecV2_2 then HasElif else NoElif diff --git a/Cabal-syntax/src/Distribution/Compat/Binary.hs b/Cabal-syntax/src/Distribution/Compat/Binary.hs index 919d72bebe5..8849fc13b10 100644 --- a/Cabal-syntax/src/Distribution/Compat/Binary.hs +++ b/Cabal-syntax/src/Distribution/Compat/Binary.hs @@ -2,10 +2,10 @@ {-# LANGUAGE PatternSynonyms #-} module Distribution.Compat.Binary - ( decodeOrFailIO - , decodeFileOrFail' - , module Data.Binary - ) where + ( decodeOrFailIO + , decodeFileOrFail' + , module Data.Binary + ) where import Control.Exception (ErrorCall (..), catch, evaluate) import Data.ByteString.Lazy (ByteString) @@ -18,6 +18,6 @@ decodeFileOrFail' f = either (Left . snd) Right `fmap` decodeFileOrFail f decodeOrFailIO :: Binary a => ByteString -> IO (Either String a) decodeOrFailIO bs = - catch (evaluate (decode bs) >>= return . Right) handler + catch (evaluate (decode bs) >>= return . Right) handler where handler (ErrorCallWithLocation str _) = return $ Left str diff --git a/Cabal-syntax/src/Distribution/Compat/CharParsing.hs b/Cabal-syntax/src/Distribution/Compat/CharParsing.hs index ebe77119249..3f0d44b0a0a 100644 --- a/Cabal-syntax/src/Distribution/Compat/CharParsing.hs +++ b/Cabal-syntax/src/Distribution/Compat/CharParsing.hs @@ -1,8 +1,12 @@ -{-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fspec-constr -fspec-constr-count=8 #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Compat.CharParsing -- Copyright : (c) Edward Kmett 2011 @@ -15,28 +19,27 @@ -- Parsers for character streams -- -- Originally in @parsers@ package. --- ------------------------------------------------------------------------------ module Distribution.Compat.CharParsing - ( - -- * Combinators - oneOf -- :: CharParsing m => [Char] -> m Char - , noneOf -- :: CharParsing m => [Char] -> m Char - , spaces -- :: CharParsing m => m () - , space -- :: CharParsing m => m Char - , newline -- :: CharParsing m => m Char - , tab -- :: CharParsing m => m Char - , upper -- :: CharParsing m => m Char - , lower -- :: CharParsing m => m Char - , alphaNum -- :: CharParsing m => m Char - , letter -- :: CharParsing m => m Char - , digit -- :: CharParsing m => m Char - , hexDigit -- :: CharParsing m => m Char - , octDigit -- :: CharParsing m => m Char + ( -- * Combinators + oneOf -- :: CharParsing m => [Char] -> m Char + , noneOf -- :: CharParsing m => [Char] -> m Char + , spaces -- :: CharParsing m => m () + , space -- :: CharParsing m => m Char + , newline -- :: CharParsing m => m Char + , tab -- :: CharParsing m => m Char + , upper -- :: CharParsing m => m Char + , lower -- :: CharParsing m => m Char + , alphaNum -- :: CharParsing m => m Char + , letter -- :: CharParsing m => m Char + , digit -- :: CharParsing m => m Char + , hexDigit -- :: CharParsing m => m Char + , octDigit -- :: CharParsing m => m Char , satisfyRange -- :: CharParsing m => Char -> Char -> m Char - -- * Class - , CharParsing(..) - -- * Cabal additions + + -- * Class + , CharParsing (..) + + -- * Cabal additions , integral , signedIntegral , munch1 @@ -45,18 +48,18 @@ module Distribution.Compat.CharParsing , module Distribution.Compat.Parsing ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Identity (IdentityT (..)) +import Control.Monad.Trans.RWS.Lazy as Lazy +import Control.Monad.Trans.RWS.Strict as Strict +import Control.Monad.Trans.Reader (ReaderT (..)) import Control.Monad.Trans.State.Lazy as Lazy import Control.Monad.Trans.State.Strict as Strict import Control.Monad.Trans.Writer.Lazy as Lazy import Control.Monad.Trans.Writer.Strict as Strict -import Control.Monad.Trans.RWS.Lazy as Lazy -import Control.Monad.Trans.RWS.Strict as Strict -import Control.Monad.Trans.Reader (ReaderT (..)) -import Control.Monad.Trans.Identity (IdentityT (..)) import Data.Char import Data.Text (Text, unpack) @@ -194,13 +197,13 @@ class Parsing m => CharParsing m where instance (CharParsing m, MonadPlus m) => CharParsing (Lazy.StateT s m) where satisfy = lift . satisfy {-# INLINE satisfy #-} - char = lift . char + char = lift . char {-# INLINE char #-} notChar = lift . notChar {-# INLINE notChar #-} anyChar = lift anyChar {-# INLINE anyChar #-} - string = lift . string + string = lift . string {-# INLINE string #-} text = lift . text {-# INLINE text #-} @@ -208,13 +211,13 @@ instance (CharParsing m, MonadPlus m) => CharParsing (Lazy.StateT s m) where instance (CharParsing m, MonadPlus m) => CharParsing (Strict.StateT s m) where satisfy = lift . satisfy {-# INLINE satisfy #-} - char = lift . char + char = lift . char {-# INLINE char #-} notChar = lift . notChar {-# INLINE notChar #-} anyChar = lift anyChar {-# INLINE anyChar #-} - string = lift . string + string = lift . string {-# INLINE string #-} text = lift . text {-# INLINE text #-} @@ -222,13 +225,13 @@ instance (CharParsing m, MonadPlus m) => CharParsing (Strict.StateT s m) where instance (CharParsing m, MonadPlus m) => CharParsing (ReaderT e m) where satisfy = lift . satisfy {-# INLINE satisfy #-} - char = lift . char + char = lift . char {-# INLINE char #-} notChar = lift . notChar {-# INLINE notChar #-} anyChar = lift anyChar {-# INLINE anyChar #-} - string = lift . string + string = lift . string {-# INLINE string #-} text = lift . text {-# INLINE text #-} @@ -236,13 +239,13 @@ instance (CharParsing m, MonadPlus m) => CharParsing (ReaderT e m) where instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.WriterT w m) where satisfy = lift . satisfy {-# INLINE satisfy #-} - char = lift . char + char = lift . char {-# INLINE char #-} notChar = lift . notChar {-# INLINE notChar #-} anyChar = lift anyChar {-# INLINE anyChar #-} - string = lift . string + string = lift . string {-# INLINE string #-} text = lift . text {-# INLINE text #-} @@ -250,13 +253,13 @@ instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.WriterT w instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.WriterT w m) where satisfy = lift . satisfy {-# INLINE satisfy #-} - char = lift . char + char = lift . char {-# INLINE char #-} notChar = lift . notChar {-# INLINE notChar #-} anyChar = lift anyChar {-# INLINE anyChar #-} - string = lift . string + string = lift . string {-# INLINE string #-} text = lift . text {-# INLINE text #-} @@ -264,13 +267,13 @@ instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.WriterT w m instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.RWST r w s m) where satisfy = lift . satisfy {-# INLINE satisfy #-} - char = lift . char + char = lift . char {-# INLINE char #-} notChar = lift . notChar {-# INLINE notChar #-} anyChar = lift anyChar {-# INLINE anyChar #-} - string = lift . string + string = lift . string {-# INLINE string #-} text = lift . text {-# INLINE text #-} @@ -278,13 +281,13 @@ instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.RWST r w s instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.RWST r w s m) where satisfy = lift . satisfy {-# INLINE satisfy #-} - char = lift . char + char = lift . char {-# INLINE char #-} notChar = lift . notChar {-# INLINE notChar #-} anyChar = lift anyChar {-# INLINE anyChar #-} - string = lift . string + string = lift . string {-# INLINE string #-} text = lift . text {-# INLINE text #-} @@ -292,23 +295,23 @@ instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.RWST r w instance (CharParsing m, MonadPlus m) => CharParsing (IdentityT m) where satisfy = lift . satisfy {-# INLINE satisfy #-} - char = lift . char + char = lift . char {-# INLINE char #-} notChar = lift . notChar {-# INLINE notChar #-} anyChar = lift anyChar {-# INLINE anyChar #-} - string = lift . string + string = lift . string {-# INLINE string #-} text = lift . text {-# INLINE text #-} instance Parsec.Stream s m Char => CharParsing (Parsec.ParsecT s u m) where - satisfy = Parsec.satisfy - char = Parsec.char + satisfy = Parsec.satisfy + char = Parsec.char notChar c = Parsec.satisfy (/= c) - anyChar = Parsec.anyChar - string = Parsec.string + anyChar = Parsec.anyChar + string = Parsec.string ------------------------------------------------------------------------------- -- Our additions @@ -329,7 +332,7 @@ integral = toNumber <$> some d "integral" f '7' = 7 f '8' = 8 f '9' = 9 - f _ = error "panic! integral" + f _ = error "panic! integral" {-# INLINE integral #-} -- | Accepts negative (starting with @-@) and positive (without sign) integral diff --git a/Cabal-syntax/src/Distribution/Compat/DList.hs b/Cabal-syntax/src/Distribution/Compat/DList.hs index 29cd1bb73c1..e4168debf09 100644 --- a/Cabal-syntax/src/Distribution/Compat/DList.hs +++ b/Cabal-syntax/src/Distribution/Compat/DList.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Compat.DList -- Copyright : (c) Ben Gamari 2015-2019 @@ -9,18 +10,18 @@ -- Portability : portable -- -- A very simple difference list. -module Distribution.Compat.DList ( - DList, - runDList, - empty, - singleton, - fromList, - toList, - snoc, -) where - +module Distribution.Compat.DList + ( DList + , runDList + , empty + , singleton + , fromList + , toList + , snoc + ) where + +import Distribution.Compat.Prelude hiding (empty, toList) import Prelude () -import Distribution.Compat.Prelude hiding (toList, empty) -- | Difference list. newtype DList a = DList ([a] -> [a]) @@ -30,7 +31,7 @@ runDList (DList run) = run [] -- | Make 'DList' containing single element. singleton :: a -> DList a -singleton a = DList (a:) +singleton a = DList (a :) -- | @since 3.4.0.0 empty :: DList a @@ -46,7 +47,7 @@ snoc :: DList a -> a -> DList a snoc xs x = xs <> singleton x instance Monoid (DList a) where - mempty = empty + mempty = empty mappend = (<>) instance Semigroup (DList a) where diff --git a/Cabal-syntax/src/Distribution/Compat/Exception.hs b/Cabal-syntax/src/Distribution/Compat/Exception.hs index f274c35cd32..e2a9419e5a5 100644 --- a/Cabal-syntax/src/Distribution/Compat/Exception.hs +++ b/Cabal-syntax/src/Distribution/Compat/Exception.hs @@ -1,14 +1,15 @@ {-# LANGUAGE CPP #-} -module Distribution.Compat.Exception ( - catchIO, - catchExit, - tryIO, - displayException, + +module Distribution.Compat.Exception + ( catchIO + , catchExit + , tryIO + , displayException ) where -import System.Exit -import qualified Control.Exception as Exception import Control.Exception (displayException) +import qualified Control.Exception as Exception +import System.Exit -- | Try 'IOException'. tryIO :: IO a -> IO (Either Exception.IOException a) diff --git a/Cabal-syntax/src/Distribution/Compat/Graph.hs b/Cabal-syntax/src/Distribution/Compat/Graph.hs index 248c021585d..c01f3162b2d 100644 --- a/Cabal-syntax/src/Distribution/Compat/Graph.hs +++ b/Cabal-syntax/src/Distribution/Compat/Graph.hs @@ -1,12 +1,16 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Compat.Graph -- Copyright : (c) Edward Z. Yang 2016 @@ -38,81 +42,87 @@ -- vertices of a graph using 'broken' (and should, e.g., to ensure that -- a closure of a graph is well-formed.) It's possible to take a closed -- subset of a broken graph and get a well-formed graph. --- ------------------------------------------------------------------------------ +module Distribution.Compat.Graph + ( -- * Graph type + Graph + , IsNode (..) -module Distribution.Compat.Graph ( - -- * Graph type - Graph, - IsNode(..), -- * Query - null, - size, - member, - lookup, + , null + , size + , member + , lookup + -- * Construction - empty, - insert, - deleteKey, - deleteLookup, + , empty + , insert + , deleteKey + , deleteLookup + -- * Combine - unionLeft, - unionRight, + , unionLeft + , unionRight + -- * Graph algorithms - stronglyConnComp, - SCC(..), - cycles, - broken, - neighbors, - revNeighbors, - closure, - revClosure, - topSort, - revTopSort, + , stronglyConnComp + , SCC (..) + , cycles + , broken + , neighbors + , revNeighbors + , closure + , revClosure + , topSort + , revTopSort + -- * Conversions + -- ** Maps - toMap, + , toMap + -- ** Lists - fromDistinctList, - toList, - keys, + , fromDistinctList + , toList + , keys + -- ** Sets - keysSet, + , keysSet + -- ** Graphs - toGraph, + , toGraph + -- * Node type - Node(..), - nodeValue, -) where + , Node (..) + , nodeValue + ) where import Distribution.Compat.Prelude hiding (empty, lookup, null, toList) import Prelude () -import Data.Array ((!)) -import Data.Graph (SCC (..)) +import Data.Array ((!)) +import Data.Graph (SCC (..)) import Distribution.Utils.Structured (Structure (..), Structured (..)) -import qualified Data.Array as Array -import qualified Data.Foldable as Foldable -import qualified Data.Graph as G -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Data.Tree as Tree +import qualified Data.Array as Array +import qualified Data.Foldable as Foldable +import qualified Data.Graph as G +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Tree as Tree import qualified Distribution.Compat.Prelude as Prelude -- | A graph of nodes @a@. The nodes are expected to have instance -- of class 'IsNode'. -data Graph a - = Graph { - graphMap :: !(Map (Key a) a), - -- Lazily cached graph representation - graphForward :: G.Graph, - graphAdjoint :: G.Graph, - graphVertexToNode :: G.Vertex -> a, - graphKeyToVertex :: Key a -> Maybe G.Vertex, - graphBroken :: [(a, [Key a])] - } - deriving (Typeable) +data Graph a = Graph + { graphMap :: !(Map (Key a) a) + , -- Lazily cached graph representation + graphForward :: G.Graph + , graphAdjoint :: G.Graph + , graphVertexToNode :: G.Vertex -> a + , graphKeyToVertex :: Key a -> Maybe G.Vertex + , graphBroken :: [(a, [Key a])] + } + deriving (Typeable) -- NB: Not a Functor! (or Traversable), because you need -- to restrict Key a ~ Key b. We provide our own mapping @@ -122,50 +132,51 @@ data Graph a -- Map representation. instance Show a => Show (Graph a) where - show = show . toList + show = show . toList instance (IsNode a, Read a, Show (Key a)) => Read (Graph a) where - readsPrec d s = map (\(a,r) -> (fromDistinctList a, r)) (readsPrec d s) + readsPrec d s = map (\(a, r) -> (fromDistinctList a, r)) (readsPrec d s) instance (IsNode a, Binary a, Show (Key a)) => Binary (Graph a) where - put x = put (toList x) - get = fmap fromDistinctList get + put x = put (toList x) + get = fmap fromDistinctList get instance Structured a => Structured (Graph a) where - structure p = Nominal (typeRep p) 0 "Graph" [structure (Proxy :: Proxy a)] + structure p = Nominal (typeRep p) 0 "Graph" [structure (Proxy :: Proxy a)] instance (Eq (Key a), Eq a) => Eq (Graph a) where - g1 == g2 = graphMap g1 == graphMap g2 + g1 == g2 = graphMap g1 == graphMap g2 instance Foldable.Foldable Graph where - fold = Foldable.fold . graphMap - foldr f z = Foldable.foldr f z . graphMap - foldl f z = Foldable.foldl f z . graphMap - foldMap f = Foldable.foldMap f . graphMap - foldl' f z = Foldable.foldl' f z . graphMap - foldr' f z = Foldable.foldr' f z . graphMap + fold = Foldable.fold . graphMap + foldr f z = Foldable.foldr f z . graphMap + foldl f z = Foldable.foldl f z . graphMap + foldMap f = Foldable.foldMap f . graphMap + foldl' f z = Foldable.foldl' f z . graphMap + foldr' f z = Foldable.foldr' f z . graphMap #ifdef MIN_VERSION_base #if MIN_VERSION_base(4,8,0) - length = Foldable.length . graphMap - null = Foldable.null . graphMap - toList = Foldable.toList . graphMap - elem x = Foldable.elem x . graphMap - maximum = Foldable.maximum . graphMap - minimum = Foldable.minimum . graphMap - sum = Foldable.sum . graphMap - product = Foldable.product . graphMap + length = Foldable.length . graphMap + null = Foldable.null . graphMap + toList = Foldable.toList . graphMap + elem x = Foldable.elem x . graphMap + maximum = Foldable.maximum . graphMap + minimum = Foldable.minimum . graphMap + sum = Foldable.sum . graphMap + product = Foldable.product . graphMap #endif #endif instance (NFData a, NFData (Key a)) => NFData (Graph a) where - rnf Graph { - graphMap = m, - graphForward = gf, - graphAdjoint = ga, - graphVertexToNode = vtn, - graphKeyToVertex = ktv, - graphBroken = b - } = gf `seq` ga `seq` vtn `seq` ktv `seq` b `seq` rnf m + rnf + Graph + { graphMap = m + , graphForward = gf + , graphAdjoint = ga + , graphVertexToNode = vtn + , graphKeyToVertex = ktv + , graphBroken = b + } = gf `seq` ga `seq` vtn `seq` ktv `seq` b `seq` rnf m -- TODO: Data instance? @@ -174,32 +185,32 @@ instance (NFData a, NFData (Key a)) => NFData (Graph a) where -- type @'Key' a@; given a node we can determine its key ('nodeKey') -- and the keys of its neighbors ('nodeNeighbors'). class Ord (Key a) => IsNode a where - type Key a - nodeKey :: a -> Key a - nodeNeighbors :: a -> [Key a] + type Key a + nodeKey :: a -> Key a + nodeNeighbors :: a -> [Key a] instance (IsNode a, IsNode b, Key a ~ Key b) => IsNode (Either a b) where - type Key (Either a b) = Key a - nodeKey (Left x) = nodeKey x - nodeKey (Right x) = nodeKey x - nodeNeighbors (Left x) = nodeNeighbors x - nodeNeighbors (Right x) = nodeNeighbors x + type Key (Either a b) = Key a + nodeKey (Left x) = nodeKey x + nodeKey (Right x) = nodeKey x + nodeNeighbors (Left x) = nodeNeighbors x + nodeNeighbors (Right x) = nodeNeighbors x -- | A simple, trivial data type which admits an 'IsNode' instance. data Node k a = N a k [k] - deriving (Show, Eq) + deriving (Show, Eq) -- | Get the value from a 'Node'. nodeValue :: Node k a -> a nodeValue (N a _ _) = a instance Functor (Node k) where - fmap f (N a k ks) = N (f a) k ks + fmap f (N a k ks) = N (f a) k ks instance Ord k => IsNode (Node k a) where - type Key (Node k a) = k - nodeKey (N _ k _) = k - nodeNeighbors (N _ _ ks) = ks + type Key (Node k a) = k + nodeKey (N _ k _) = k + nodeNeighbors (N _ _ ks) = ks -- TODO: Maybe introduce a typeclass for items which just -- keys (so, Key associated type, and nodeKey method). But @@ -241,8 +252,8 @@ deleteKey k g = fromMap (Map.delete k (toMap g)) -- value if it existed. deleteLookup :: IsNode a => Key a -> Graph a -> (Maybe a, Graph a) deleteLookup k g = - let (r, m') = Map.updateLookupWithKey (\_ _ -> Nothing) k (toMap g) - in (r, fromMap m') + let (r, m') = Map.updateLookupWithKey (\_ _ -> Nothing) k (toMap g) + in (r, fromMap m') -- Combining @@ -266,18 +277,20 @@ stronglyConnComp g = map decode forest where forest = G.scc (graphForward g) decode (Tree.Node v []) - | mentions_itself v = CyclicSCC [graphVertexToNode g v] - | otherwise = AcyclicSCC (graphVertexToNode g v) + | mentions_itself v = CyclicSCC [graphVertexToNode g v] + | otherwise = AcyclicSCC (graphVertexToNode g v) decode other = CyclicSCC (dec other []) - where dec (Tree.Node v ts) vs - = graphVertexToNode g v : foldr dec vs ts + where + dec (Tree.Node v ts) vs = + graphVertexToNode g v : foldr dec vs ts mentions_itself v = v `elem` (graphForward g ! v) + -- Implementation copied from 'stronglyConnCompR' in 'Data.Graph'. -- | /Ω(V + E)/. Compute the cycles of a graph. -- Requires amortized construction of graph. cycles :: Graph a -> [[a]] -cycles g = [ vs | CyclicSCC vs <- stronglyConnComp g ] +cycles g = [vs | CyclicSCC vs <- stronglyConnComp g] -- | /O(1)/. Return a list of nodes paired with their broken -- neighbors (i.e., neighbor keys which are not in the graph). @@ -289,15 +302,15 @@ broken g = graphBroken g -- Requires amortized construction of graph. neighbors :: Graph a -> Key a -> Maybe [a] neighbors g k = do - v <- graphKeyToVertex g k - return (map (graphVertexToNode g) (graphForward g ! v)) + v <- graphKeyToVertex g k + return (map (graphVertexToNode g) (graphForward g ! v)) -- | Lookup the immediate reverse neighbors from a key in the graph. -- Requires amortized construction of graph. revNeighbors :: Graph a -> Key a -> Maybe [a] revNeighbors g k = do - v <- graphKeyToVertex g k - return (map (graphVertexToNode g) (graphAdjoint g ! v)) + v <- graphKeyToVertex g k + return (map (graphVertexToNode g) (graphAdjoint g ! v)) -- | Compute the subgraph which is the closure of some set of keys. -- Returns @Nothing@ if one (or more) keys are not present in @@ -305,8 +318,8 @@ revNeighbors g k = do -- Requires amortized construction of graph. closure :: Graph a -> [Key a] -> Maybe [a] closure g ks = do - vs <- traverse (graphKeyToVertex g) ks - return (decodeVertexForest g (G.dfs (graphForward g) vs)) + vs <- traverse (graphKeyToVertex g) ks + return (decodeVertexForest g (G.dfs (graphForward g) vs)) -- | Compute the reverse closure of a graph from some set -- of keys. Returns @Nothing@ if one (or more) keys are not present in @@ -314,8 +327,8 @@ closure g ks = do -- Requires amortized construction of graph. revClosure :: Graph a -> [Key a] -> Maybe [a] revClosure g ks = do - vs <- traverse (graphKeyToVertex g) ks - return (decodeVertexForest g (G.dfs (graphAdjoint g) vs)) + vs <- traverse (graphKeyToVertex g) ks + return (decodeVertexForest g (G.dfs (graphAdjoint g) vs)) flattenForest :: Tree.Forest a -> [a] flattenForest = concatMap Tree.flatten @@ -342,44 +355,49 @@ revTopSort g = map (graphVertexToNode g) $ G.topSort (graphAdjoint g) -- instead. The values of the map are assumed to already -- be in WHNF. fromMap :: IsNode a => Map (Key a) a -> Graph a -fromMap m - = Graph { graphMap = m - -- These are lazily computed! - , graphForward = g - , graphAdjoint = G.transposeG g - , graphVertexToNode = vertex_to_node - , graphKeyToVertex = key_to_vertex - , graphBroken = broke - } +fromMap m = + Graph + { graphMap = m + , -- These are lazily computed! + graphForward = g + , graphAdjoint = G.transposeG g + , graphVertexToNode = vertex_to_node + , graphKeyToVertex = key_to_vertex + , graphBroken = broke + } where try_key_to_vertex k = maybe (Left k) Right (key_to_vertex k) - (brokenEdges, edges) - = unzip - $ [ partitionEithers (map try_key_to_vertex (nodeNeighbors n)) - | n <- ns ] + (brokenEdges, edges) = + unzip $ + [ partitionEithers (map try_key_to_vertex (nodeNeighbors n)) + | n <- ns + ] broke = filter (not . Prelude.null . snd) (zip ns brokenEdges) g = Array.listArray bounds edges - ns = Map.elems m -- sorted ascending - vertices = zip (map nodeKey ns) [0..] - vertex_map = Map.fromAscList vertices + ns = Map.elems m -- sorted ascending + vertices = zip (map nodeKey ns) [0 ..] + vertex_map = Map.fromAscList vertices key_to_vertex k = Map.lookup k vertex_map vertex_to_node vertex = nodeTable ! vertex - nodeTable = Array.listArray bounds ns + nodeTable = Array.listArray bounds ns bounds = (0, Map.size m - 1) -- | /O(V log V)/. Convert a list of nodes (with distinct keys) into a graph. fromDistinctList :: (IsNode a, Show (Key a)) => [a] -> Graph a -fromDistinctList = fromMap - . Map.fromListWith (\_ -> duplicateError) - . map (\n -> n `seq` (nodeKey n, n)) +fromDistinctList = + fromMap + . Map.fromListWith (\_ -> duplicateError) + . map (\n -> n `seq` (nodeKey n, n)) where - duplicateError n = error $ "Graph.fromDistinctList: duplicate key: " - ++ show (nodeKey n) + duplicateError n = + error $ + "Graph.fromDistinctList: duplicate key: " + ++ show (nodeKey n) -- Map-like operations diff --git a/Cabal-syntax/src/Distribution/Compat/Lens.hs b/Cabal-syntax/src/Distribution/Compat/Lens.hs index 2320ab978a3..d31c9198889 100644 --- a/Cabal-syntax/src/Distribution/Compat/Lens.hs +++ b/Cabal-syntax/src/Distribution/Compat/Lens.hs @@ -1,78 +1,95 @@ {-# LANGUAGE RankNTypes #-} + -- | This module provides very basic lens functionality, without extra dependencies. -- -- For the documentation of the combinators see package. -- This module uses the same vocabulary. -module Distribution.Compat.Lens ( - -- * Types - Lens, - Lens', - Traversal, - Traversal', +module Distribution.Compat.Lens + ( -- * Types + Lens + , Lens' + , Traversal + , Traversal' + -- ** LensLike - LensLike, - LensLike', + , LensLike + , LensLike' + -- ** rank-1 types - Getting, - AGetter, - ASetter, - ALens, - ALens', + , Getting + , AGetter + , ASetter + , ALens + , ALens' + -- * Getter - view, - use, - getting, + , view + , use + , getting + -- * Setter - set, - over, + , set + , over + -- * Fold - toDListOf, - toListOf, - toSetOf, + , toDListOf + , toListOf + , toSetOf + -- * Lens - cloneLens, - aview, + , cloneLens + , aview + -- * Common lenses - _1, _2, + , _1 + , _2 + -- * Operators - (&), - (^.), - (.~), (?~), (%~), - (.=), (?=), (%=), - (^#), - (#~), (#%~), + , (&) + , (^.) + , (.~) + , (?~) + , (%~) + , (.=) + , (?=) + , (%=) + , (^#) + , (#~) + , (#%~) + -- * Internal Comonads - Pretext (..), + , Pretext (..) + -- * Cabal developer info -- $development - ) where + ) where -import Prelude() import Distribution.Compat.Prelude +import Prelude () import Control.Monad.State.Class (MonadState (..), gets, modify) -import qualified Distribution.Compat.DList as DList import qualified Data.Set as Set +import qualified Distribution.Compat.DList as DList ------------------------------------------------------------------------------- -- Types ------------------------------------------------------------------------------- -type LensLike f s t a b = (a -> f b) -> s -> f t -type LensLike' f s a = (a -> f a) -> s -> f s +type LensLike f s t a b = (a -> f b) -> s -> f t +type LensLike' f s a = (a -> f a) -> s -> f s -type Lens s t a b = forall f. Functor f => LensLike f s t a b +type Lens s t a b = forall f. Functor f => LensLike f s t a b type Traversal s t a b = forall f. Applicative f => LensLike f s t a b -type Lens' s a = Lens s s a a +type Lens' s a = Lens s s a a type Traversal' s a = Traversal s s a a type Getting r s a = LensLike (Const r) s s a a -type AGetter s a = LensLike (Const a) s s a a -- this doesn't exist in 'lens' -type ASetter s t a b = LensLike Identity s t a b -type ALens s t a b = LensLike (Pretext a b) s t a b +type AGetter s a = LensLike (Const a) s s a a -- this doesn't exist in 'lens' +type ASetter s t a b = LensLike Identity s t a b +type ALens s t a b = LensLike (Pretext a b) s t a b type ALens' s a = ALens s s a a @@ -80,7 +97,7 @@ type ALens' s a = ALens s s a a -- Getter ------------------------------------------------------------------------------- -view :: Getting a s a -> s -> a +view :: Getting a s a -> s -> a view l s = getConst (l Const s) {-# INLINE view #-} @@ -100,7 +117,7 @@ getting k f = Const . getConst . f . k -- Setter ------------------------------------------------------------------------------- -set :: ASetter s t a b -> b -> s -> t +set :: ASetter s t a b -> b -> s -> t set l x = over l (const x) over :: ASetter s t a b -> (a -> b) -> s -> t @@ -116,7 +133,7 @@ toDListOf l s = getConst (l (\x -> Const (DList.singleton x)) s) toListOf :: Getting (DList.DList a) s a -> s -> [a] toListOf l = DList.runDList . toDListOf l -toSetOf :: Getting (Set.Set a) s a -> s -> Set.Set a +toSetOf :: Getting (Set.Set a) s a -> s -> Set.Set a toSetOf l s = getConst (l (\x -> Const (Set.singleton x)) s) ------------------------------------------------------------------------------- @@ -124,7 +141,7 @@ toSetOf l s = getConst (l (\x -> Const (Set.singleton x)) s) ------------------------------------------------------------------------------- aview :: ALens s t a b -> s -> a -aview l = pretextPos . l pretextSell +aview l = pretextPos . l pretextSell {-# INLINE aview #-} {- @@ -136,10 +153,10 @@ lens sa sbt afb s = sbt s <$> afb (sa s) -- Common ------------------------------------------------------------------------------- -_1 :: Lens (a, c) (b, c) a b +_1 :: Lens (a, c) (b, c) a b _1 f (a, c) = flip (,) c <$> f a -_2 :: Lens (c, a) (c, b) a b +_2 :: Lens (c, a) (c, b) a b _2 f (c, a) = (,) c <$> f a ------------------------------------------------------------------------------- @@ -150,6 +167,7 @@ _2 f (c, a) = (,) c <$> f a (&) :: a -> (a -> b) -> b (&) = flip ($) {-# INLINE (&) #-} + infixl 1 & infixl 8 ^., ^# @@ -221,10 +239,10 @@ cloneLens l f s = runPretext (l pretextSell s) f ------------------------------------------------------------------------------- -- | @lens@ variant is also parametrised by profunctor. -data Pretext a b t = Pretext { runPretext :: forall f. Functor f => (a -> f b) -> f t } +data Pretext a b t = Pretext {runPretext :: forall f. Functor f => (a -> f b) -> f t} instance Functor (Pretext a b) where - fmap f (Pretext pretext) = Pretext (\afb -> fmap f (pretext afb)) + fmap f (Pretext pretext) = Pretext (\afb -> fmap f (pretext afb)) ------------------------------------------------------------------------------- -- Documentation diff --git a/Cabal-syntax/src/Distribution/Compat/MonadFail.hs b/Cabal-syntax/src/Distribution/Compat/MonadFail.hs index f4da211a43d..3516aef7e77 100644 --- a/Cabal-syntax/src/Distribution/Compat/MonadFail.hs +++ b/Cabal-syntax/src/Distribution/Compat/MonadFail.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} -- | Compatibility layer for "Control.Monad.Fail" -module Distribution.Compat.MonadFail ( Control.Monad.Fail.MonadFail(fail) ) where +module Distribution.Compat.MonadFail (Control.Monad.Fail.MonadFail (fail)) where + import Control.Monad.Fail diff --git a/Cabal-syntax/src/Distribution/Compat/Newtype.hs b/Cabal-syntax/src/Distribution/Compat/Newtype.hs index 904e2e5d4b3..00da1e83542 100644 --- a/Cabal-syntax/src/Distribution/Compat/Newtype.hs +++ b/Cabal-syntax/src/Distribution/Compat/Newtype.hs @@ -1,20 +1,21 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} + -- | Per Conor McBride, the 'Newtype' typeclass represents the packing and -- unpacking of a newtype, and allows you to operate under that newtype with -- functions such as 'ala'. -module Distribution.Compat.Newtype ( - Newtype (..), - ala, - alaf, - pack', - unpack', - ) where +module Distribution.Compat.Newtype + ( Newtype (..) + , ala + , alaf + , pack' + , unpack' + ) where import Data.Functor.Identity (Identity (..)) -import Data.Monoid (Sum (..), Product (..), Endo (..)) +import Data.Monoid (Endo (..), Product (..), Sum (..)) #if MIN_VERSION_base(4,7,0) import Data.Coerce (coerce, Coercible) @@ -36,25 +37,26 @@ import Unsafe.Coerce (unsafeCoerce) -- Another approach would be to use @TypeFamilies@ (and possibly -- compute inner type using "GHC.Generics"), but we think @FunctionalDependencies@ -- version gives cleaner type signatures. --- +{- FOURMOLU_DISABLE -} class Newtype o n | n -> o where - pack :: o -> n + pack :: o -> n #if MIN_VERSION_base(4,7,0) - default pack :: Coercible o n => o -> n - pack = coerce + default pack :: Coercible o n => o -> n + pack = coerce #else - default pack :: o -> n - pack = unsafeCoerce + default pack :: o -> n + pack = unsafeCoerce #endif - unpack :: n -> o + unpack :: n -> o #if MIN_VERSION_base(4,7,0) - default unpack :: Coercible n o => n -> o - unpack = coerce + default unpack :: Coercible n o => n -> o + unpack = coerce #else - default unpack :: n -> o - unpack = unsafeCoerce + default unpack :: n -> o + unpack = unsafeCoerce #endif +{- FOURMOLU_ENABLE -} instance Newtype a (Identity a) instance Newtype a (Sum a) diff --git a/Cabal-syntax/src/Distribution/Compat/NonEmptySet.hs b/Cabal-syntax/src/Distribution/Compat/NonEmptySet.hs index 54a4ecef5f2..034da7ee90c 100644 --- a/Cabal-syntax/src/Distribution/Compat/NonEmptySet.hs +++ b/Cabal-syntax/src/Distribution/Compat/NonEmptySet.hs @@ -1,36 +1,43 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -module Distribution.Compat.NonEmptySet ( - NonEmptySet, + +module Distribution.Compat.NonEmptySet + ( NonEmptySet + -- * Construction - singleton, + , singleton + -- * Insertion - insert, + , insert + -- * Deletion - delete, + , delete + -- * Conversions - toNonEmpty, - fromNonEmpty, - toList, - toSet, + , toNonEmpty + , fromNonEmpty + , toList + , toSet + -- * Query - member, + , member + -- * Map - map, -) where + , map + ) where import Prelude (Bool (..), Eq, Maybe (..), Ord (..), Read, Show (..), String, error, otherwise, return, showParen, showString, ($), (++), (.)) -import Control.DeepSeq (NFData (..)) -import Data.Data (Data) +import Control.DeepSeq (NFData (..)) +import Data.Data (Data) import Data.List.NonEmpty (NonEmpty (..)) -import Data.Semigroup (Semigroup (..)) -import Data.Typeable (Typeable) +import Data.Semigroup (Semigroup (..)) +import Data.Typeable (Typeable) import qualified Data.Foldable as F -import qualified Data.Set as Set +import qualified Data.Set as Set -import Distribution.Compat.Binary (Binary (..)) +import Distribution.Compat.Binary (Binary (..)) import Distribution.Utils.Structured #if MIN_VERSION_binary(0,6,0) @@ -48,40 +55,43 @@ newtype NonEmptySet a = NES (Set.Set a) ------------------------------------------------------------------------------- instance Show a => Show (NonEmptySet a) where - showsPrec d s = showParen (d > 10) - $ showString "fromNonEmpty " + showsPrec d s = + showParen (d > 10) $ + showString "fromNonEmpty " . showsPrec 11 (toNonEmpty s) +{- FOURMOLU_DISABLE -} instance Binary a => Binary (NonEmptySet a) where - put (NES s) = put s - get = do - xs <- get - if Set.null xs + put (NES s) = put s + get = do + xs <- get + if Set.null xs #if MIN_VERSION_binary(0,6,0) - then empty + then empty #else - then fail "NonEmptySet: empty" + then fail "NonEmptySet: empty" #endif - else return (NES xs) + else return (NES xs) +{- FOURMOLU_ENABLE -} instance Structured a => Structured (NonEmptySet a) where - structure = containerStructure + structure = containerStructure instance NFData a => NFData (NonEmptySet a) where - rnf (NES x) = rnf x + rnf (NES x) = rnf x -- | Note: there aren't @Monoid@ instance. instance Ord a => Semigroup (NonEmptySet a) where - NES x <> NES y = NES (Set.union x y) + NES x <> NES y = NES (Set.union x y) instance F.Foldable NonEmptySet where - foldMap f (NES s) = F.foldMap f s - foldr f z (NES s) = F.foldr f z s + foldMap f (NES s) = F.foldMap f s + foldr f z (NES s) = F.foldr f z s #if MIN_VERSION_base(4,8,0) - toList = toList - null _ = False - length (NES s) = F.length s + toList = toList + null _ = False + length (NES s) = F.length s #endif ------------------------------------------------------------------------------- @@ -104,8 +114,8 @@ insert x (NES xs) = NES (Set.insert x xs) delete :: Ord a => a -> NonEmptySet a -> Maybe (NonEmptySet a) delete x (NES xs) - | Set.null res = Nothing - | otherwise = Just (NES xs) + | Set.null res = Nothing + | otherwise = Just (NES xs) where res = Set.delete x xs @@ -118,8 +128,8 @@ fromNonEmpty (x :| xs) = NES (Set.fromList (x : xs)) toNonEmpty :: NonEmptySet a -> NonEmpty a toNonEmpty (NES s) = case Set.toList s of - [] -> panic "toNonEmpty" - x:xs -> x :| xs + [] -> panic "toNonEmpty" + x : xs -> x :| xs toList :: NonEmptySet a -> [a] toList (NES s) = Set.toList s @@ -138,6 +148,7 @@ member x (NES xs) = Set.member x xs -- Map ------------------------------------------------------------------------------- +{- FOURMOLU_DISABLE -} map :: ( Ord b #if !MIN_VERSION_containers(0,5,2) @@ -146,6 +157,7 @@ map ) => (a -> b) -> NonEmptySet a -> NonEmptySet b map f (NES x) = NES (Set.map f x) +{- FOURMOLU_ENABLE -} ------------------------------------------------------------------------------- -- Internal diff --git a/Cabal-syntax/src/Distribution/Compat/Parsing.hs b/Cabal-syntax/src/Distribution/Compat/Parsing.hs index cc4abd220a2..4cb8c9bca18 100644 --- a/Cabal-syntax/src/Distribution/Compat/Parsing.hs +++ b/Cabal-syntax/src/Distribution/Compat/Parsing.hs @@ -1,5 +1,10 @@ -{-# LANGUAGE GADTs, UndecidableInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Compat.Parsing -- Copyright : (c) Edward Kmett 2011-2012 @@ -12,18 +17,15 @@ -- Alternative parser combinators. -- -- Originally in @parsers@ package. --- ------------------------------------------------------------------------------ module Distribution.Compat.Parsing - ( - -- * Parsing Combinators + ( -- * Parsing Combinators choice , option , optional -- from Control.Applicative, parsec optionMaybe , skipOptional -- parsec optional , between - , some -- from Control.Applicative, parsec many1 - , many -- from Control.Applicative + , some -- from Control.Applicative, parsec many1 + , many -- from Control.Applicative , sepBy , sepByNonEmpty , sepEndByNonEmpty @@ -36,23 +38,24 @@ module Distribution.Compat.Parsing , chainl1 , chainr1 , manyTill - -- * Parsing Class - , Parsing(..) + + -- * Parsing Class + , Parsing (..) ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Control.Applicative ((<**>), optional) +import Control.Applicative (optional, (<**>)) import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Identity (IdentityT (..)) +import Control.Monad.Trans.RWS.Lazy as Lazy +import Control.Monad.Trans.RWS.Strict as Strict +import Control.Monad.Trans.Reader (ReaderT (..)) import Control.Monad.Trans.State.Lazy as Lazy import Control.Monad.Trans.State.Strict as Strict import Control.Monad.Trans.Writer.Lazy as Lazy import Control.Monad.Trans.Writer.Strict as Strict -import Control.Monad.Trans.RWS.Lazy as Lazy -import Control.Monad.Trans.RWS.Strict as Strict -import Control.Monad.Trans.Reader (ReaderT (..)) -import Control.Monad.Trans.Identity (IdentityT (..)) import Data.Foldable (asum) import qualified Data.List.NonEmpty as NE @@ -136,8 +139,9 @@ endBy p sep = many (p <* sep) -- equal to zero, the parser equals to @return []@. Returns a list of -- @n@ values returned by @p@. count :: Applicative m => Int -> m a -> m [a] -count n p | n <= 0 = pure [] - | otherwise = sequenceA (replicate n p) +count n p + | n <= 0 = pure [] + | otherwise = sequenceA (replicate n p) {-# INLINE count #-} -- | @chainr p op x@ parses /zero/ or more occurrences of @p@, @@ -174,9 +178,10 @@ chainl p op x = chainl1 p op <|> pure x -- > addop = (+) <$ symbol "+" -- > <|> (-) <$ symbol "-" chainl1 :: Alternative m => m a -> m (a -> a -> a) -> m a -chainl1 p op = scan where - scan = p <**> rst - rst = (\f y g x -> g (f x y)) <$> op <*> p <*> rst <|> pure id +chainl1 p op = scan + where + scan = p <**> rst + rst = (\f y g x -> g (f x y)) <$> op <*> p <*> rst <|> pure id {-# INLINE chainl1 #-} -- | @chainr1 p op x@ parses /one/ or more occurrences of @p@, @@ -184,9 +189,10 @@ chainl1 p op = scan where -- application of all functions returned by @op@ to the values returned -- by @p@. chainr1 :: Alternative m => m a -> m (a -> a -> a) -> m a -chainr1 p op = scan where - scan = p <**> rst - rst = (flip <$> op <*> scan) <|> pure id +chainr1 p op = scan + where + scan = p <**> rst + rst = (flip <$> op <*> scan) <|> pure id {-# INLINE chainr1 #-} -- | @manyTill p end@ applies parser @p@ /zero/ or more times until @@ -255,8 +261,8 @@ instance (Parsing m, MonadPlus m) => Parsing (Lazy.StateT s m) where {-# INLINE unexpected #-} eof = lift eof {-# INLINE eof #-} - notFollowedBy (Lazy.StateT m) = Lazy.StateT - $ \s -> notFollowedBy (fst <$> m s) >> return ((),s) + notFollowedBy (Lazy.StateT m) = Lazy.StateT $ + \s -> notFollowedBy (fst <$> m s) >> return ((), s) {-# INLINE notFollowedBy #-} instance (Parsing m, MonadPlus m) => Parsing (Strict.StateT s m) where @@ -268,8 +274,8 @@ instance (Parsing m, MonadPlus m) => Parsing (Strict.StateT s m) where {-# INLINE unexpected #-} eof = lift eof {-# INLINE eof #-} - notFollowedBy (Strict.StateT m) = Strict.StateT - $ \s -> notFollowedBy (fst <$> m s) >> return ((),s) + notFollowedBy (Strict.StateT m) = Strict.StateT $ + \s -> notFollowedBy (fst <$> m s) >> return ((), s) {-# INLINE notFollowedBy #-} instance (Parsing m, MonadPlus m) => Parsing (ReaderT e m) where @@ -295,8 +301,9 @@ instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Strict.WriterT w m) wher {-# INLINE unexpected #-} eof = lift eof {-# INLINE eof #-} - notFollowedBy (Strict.WriterT m) = Strict.WriterT - $ notFollowedBy (fst <$> m) >>= \x -> return (x, mempty) + notFollowedBy (Strict.WriterT m) = + Strict.WriterT $ + notFollowedBy (fst <$> m) >>= \x -> return (x, mempty) {-# INLINE notFollowedBy #-} instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Lazy.WriterT w m) where @@ -308,8 +315,9 @@ instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Lazy.WriterT w m) where {-# INLINE unexpected #-} eof = lift eof {-# INLINE eof #-} - notFollowedBy (Lazy.WriterT m) = Lazy.WriterT - $ notFollowedBy (fst <$> m) >>= \x -> return (x, mempty) + notFollowedBy (Lazy.WriterT m) = + Lazy.WriterT $ + notFollowedBy (fst <$> m) >>= \x -> return (x, mempty) {-# INLINE notFollowedBy #-} instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Lazy.RWST r w s m) where @@ -321,8 +329,8 @@ instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Lazy.RWST r w s m) where {-# INLINE unexpected #-} eof = lift eof {-# INLINE eof #-} - notFollowedBy (Lazy.RWST m) = Lazy.RWST - $ \r s -> notFollowedBy ((\(a,_,_) -> a) <$> m r s) >>= \x -> return (x, s, mempty) + notFollowedBy (Lazy.RWST m) = Lazy.RWST $ + \r s -> notFollowedBy ((\(a, _, _) -> a) <$> m r s) >>= \x -> return (x, s, mempty) {-# INLINE notFollowedBy #-} instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Strict.RWST r w s m) where @@ -334,8 +342,8 @@ instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Strict.RWST r w s m) whe {-# INLINE unexpected #-} eof = lift eof {-# INLINE eof #-} - notFollowedBy (Strict.RWST m) = Strict.RWST - $ \r s -> notFollowedBy ((\(a,_,_) -> a) <$> m r s) >>= \x -> return (x, s, mempty) + notFollowedBy (Strict.RWST m) = Strict.RWST $ + \r s -> notFollowedBy ((\(a, _, _) -> a) <$> m r s) >>= \x -> return (x, s, mempty) {-# INLINE notFollowedBy #-} instance (Parsing m, Monad m) => Parsing (IdentityT m) where @@ -353,10 +361,10 @@ instance (Parsing m, Monad m) => Parsing (IdentityT m) where {-# INLINE notFollowedBy #-} instance (Parsec.Stream s m t, Show t) => Parsing (Parsec.ParsecT s u m) where - try = Parsec.try - () = (Parsec.) - skipMany = Parsec.skipMany - skipSome = Parsec.skipMany1 - unexpected = Parsec.unexpected - eof = Parsec.eof + try = Parsec.try + () = (Parsec.) + skipMany = Parsec.skipMany + skipSome = Parsec.skipMany1 + unexpected = Parsec.unexpected + eof = Parsec.eof notFollowedBy = Parsec.notFollowedBy diff --git a/Cabal-syntax/src/Distribution/Compat/Prelude.hs b/Cabal-syntax/src/Distribution/Compat/Prelude.hs index 8c79d27d9a7..3ff51e2d8bb 100644 --- a/Cabal-syntax/src/Distribution/Compat/Prelude.hs +++ b/Cabal-syntax/src/Distribution/Compat/Prelude.hs @@ -1,134 +1,195 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{- FOURMOLU_DISABLE -} #ifdef MIN_VERSION_base #define MINVER_base_411 MIN_VERSION_base(4,11,0) #else #define MINVER_base_411 (__GLASGOW_HASKELL__ >= 804) #endif +{- FOURMOLU_ENABLE -} -- | This module does two things: -- -- * Acts as a compatibility layer, like @base-compat@. -- -- * Provides commonly used imports. -module Distribution.Compat.Prelude ( - -- * Prelude - -- - -- Prelude is re-exported, following is hidden: - module BasePrelude, +module Distribution.Compat.Prelude + ( -- * Prelude + + -- + -- Prelude is re-exported, following is hidden: + module BasePrelude -- * Common type-classes - Semigroup (..), - gmappend, gmempty, - Typeable, TypeRep, typeRep, - Data, - Generic, - NFData (..), genericRnf, - Binary (..), - Structured, - Alternative (..), - MonadPlus (..), - IsString (..), + , Semigroup (..) + , gmappend + , gmempty + , Typeable + , TypeRep + , typeRep + , Data + , Generic + , NFData (..) + , genericRnf + , Binary (..) + , Structured + , Alternative (..) + , MonadPlus (..) + , IsString (..) -- * Some types - Map, - Set, - NonEmptySet, - Identity (..), - Proxy (..), - Const (..), - Void, + , Map + , Set + , NonEmptySet + , Identity (..) + , Proxy (..) + , Const (..) + , Void -- * Data.Either - partitionEithers, + , partitionEithers -- * Data.Maybe - catMaybes, mapMaybe, - fromMaybe, - maybeToList, listToMaybe, - isNothing, isJust, + , catMaybes + , mapMaybe + , fromMaybe + , maybeToList + , listToMaybe + , isNothing + , isJust -- * Data.List - unfoldr, - isPrefixOf, isSuffixOf, - intercalate, intersperse, - sort, sortBy, - nub, nubBy, - partition, - dropWhileEnd, + , unfoldr + , isPrefixOf + , isSuffixOf + , intercalate + , intersperse + , sort + , sortBy + , nub + , nubBy + , partition + , dropWhileEnd -- * Data.List.NonEmpty - NonEmpty((:|)), nonEmpty, foldl1, foldr1, - head, tail, last, init, + , NonEmpty ((:|)) + , nonEmpty + , foldl1 + , foldr1 + , head + , tail + , last + , init -- * Data.Foldable - Foldable, foldMap, foldr, - null, length, - find, foldl', - traverse_, for_, - any, all, - toList, + , Foldable + , foldMap + , foldr + , null + , length + , find + , foldl' + , traverse_ + , for_ + , any + , all + , toList -- * Data.Traversable - Traversable, traverse, sequenceA, - for, + , Traversable + , traverse + , sequenceA + , for -- * Data.Function - on, + , on -- * Data.Ord - comparing, + , comparing -- * Control.Arrow - first, + , first -- * Control.Monad - liftM, liftM2, - unless, when, - ap, void, - foldM, filterM, - join, guard, + , liftM + , liftM2 + , unless + , when + , ap + , void + , foldM + , filterM + , join + , guard -- * Control.Exception - catch, throwIO, evaluate, - Exception (..), IOException, SomeException (..), - tryIO, catchIO, catchExit, + , catch + , throwIO + , evaluate + , Exception (..) + , IOException + , SomeException (..) + , tryIO + , catchIO + , catchExit -- * Control.DeepSeq - deepseq, force, + , deepseq + , force -- * Data.Char - isSpace, isDigit, isUpper, isAlpha, isAlphaNum, - chr, ord, - toLower, toUpper, + , isSpace + , isDigit + , isUpper + , isAlpha + , isAlphaNum + , chr + , ord + , toLower + , toUpper -- * Data.Void - absurd, vacuous, + , absurd + , vacuous -- * Data.Word & Data.Int - Word, - Word8, Word16, Word32, Word64, - Int8, Int16, Int32, Int64, + , Word + , Word8 + , Word16 + , Word32 + , Word64 + , Int8 + , Int16 + , Int32 + , Int64 -- * Text.PrettyPrint - (<<>>), (Disp.<+>), + , (<<>>) + , (Disp.<+>) -- * System.Exit - ExitCode (..), - exitWith, exitSuccess, exitFailure, + , ExitCode (..) + , exitWith + , exitSuccess + , exitFailure -- * Text.Read - readMaybe, + , readMaybe -- * Debug.Trace (as deprecated functions) - trace, traceShow, traceShowId, traceM, traceShowM - ) where + , trace + , traceShow + , traceShowId + , traceM + , traceShowM + ) where -- We also could hide few partial function +{- FOURMOLU_DISABLE -} import Prelude as BasePrelude hiding ( mapM, mapM_, sequence, null, length, foldr, any, all, head, tail, last, init -- partial functions @@ -144,57 +205,58 @@ import Prelude as BasePrelude hiding , Traversable, traverse, sequenceA , Foldable, foldMap ) +{- FOURMOLU_ENABLE -} -- AMP import Data.Foldable - ( Foldable(toList), - length, - null, - Foldable(foldMap, foldr), - all, - any, - find, - foldl', - for_, - traverse_ ) + ( Foldable (foldMap, foldr, toList) + , all + , any + , find + , foldl' + , for_ + , length + , null + , traverse_ + ) import Data.Traversable (Traversable (sequenceA, traverse), for) import qualified Data.Foldable -- Extra exports -import Control.Applicative (Alternative (..), Const(..)) -import Control.Arrow (first) -import Control.DeepSeq (NFData (..), deepseq, force) -import Control.Exception (Exception (..), IOException, SomeException (..), catch, evaluate, throwIO) -import Control.Monad (MonadPlus (..), ap, filterM, foldM, guard, join, liftM, liftM2, unless, void, when) -import Data.Char (chr, isAlpha, isAlphaNum, isDigit, isSpace, isUpper, ord, toLower, toUpper) -import Data.Data (Data) -import Data.Either (partitionEithers) -import Data.Function (on) -import Data.Functor.Identity (Identity (..)) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.List (dropWhileEnd, intercalate, intersperse, isPrefixOf, isSuffixOf, nub, nubBy, partition, sort, sortBy, unfoldr) -import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty, head, init, last, tail) -import Data.Map (Map) -import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybeToList) -import Data.Ord (comparing) -import Data.Proxy (Proxy (..)) -import Data.Set (Set) -import Data.String (IsString (..)) -import Data.Void (Void, absurd, vacuous) -import Data.Word (Word, Word16, Word32, Word64, Word8) -import Distribution.Compat.Binary (Binary (..)) +import Control.Applicative (Alternative (..), Const (..)) +import Control.Arrow (first) +import Control.DeepSeq (NFData (..), deepseq, force) +import Control.Exception (Exception (..), IOException, SomeException (..), catch, evaluate, throwIO) +import Control.Monad (MonadPlus (..), ap, filterM, foldM, guard, join, liftM, liftM2, unless, void, when) +import Data.Char (chr, isAlpha, isAlphaNum, isDigit, isSpace, isUpper, ord, toLower, toUpper) +import Data.Data (Data) +import Data.Either (partitionEithers) +import Data.Function (on) +import Data.Functor.Identity (Identity (..)) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.List (dropWhileEnd, intercalate, intersperse, isPrefixOf, isSuffixOf, nub, nubBy, partition, sort, sortBy, unfoldr) +import Data.List.NonEmpty (NonEmpty ((:|)), head, init, last, nonEmpty, tail) +import Data.Map (Map) +import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybeToList) +import Data.Ord (comparing) +import Data.Proxy (Proxy (..)) +import Data.Set (Set) +import Data.String (IsString (..)) +import Data.Void (Void, absurd, vacuous) +import Data.Word (Word, Word16, Word32, Word64, Word8) +import Distribution.Compat.Binary (Binary (..)) import Distribution.Compat.Semigroup (Semigroup (..), gmappend, gmempty) -import Distribution.Compat.Typeable (TypeRep, Typeable, typeRep) -import GHC.Generics ((:*:) ((:*:)), (:+:) (L1, R1), Generic, K1 (unK1), M1 (unM1), Rep (..), U1 (U1), V1) -import System.Exit (ExitCode (..), exitFailure, exitSuccess, exitWith) -import Text.Read (readMaybe) +import Distribution.Compat.Typeable (TypeRep, Typeable, typeRep) +import GHC.Generics (Generic, K1 (unK1), M1 (unM1), Rep (..), U1 (U1), V1, (:*:) ((:*:)), (:+:) (L1, R1)) +import System.Exit (ExitCode (..), exitFailure, exitSuccess, exitWith) +import Text.Read (readMaybe) import qualified Text.PrettyPrint as Disp import Distribution.Compat.Exception import Distribution.Compat.NonEmptySet (NonEmptySet) -import Distribution.Utils.Structured (Structured) +import Distribution.Utils.Structured (Structured) import qualified Debug.Trace @@ -243,7 +305,6 @@ instance (GNFData a, GNFData b) => GNFData (a :+: b) where grnf (R1 x) = grnf x {-# INLINEABLE grnf #-} - -- TODO: if we want foldr1/foldl1 to work on more than NonEmpty, we -- can define a local typeclass 'Foldable1', e.g. -- diff --git a/Cabal-syntax/src/Distribution/Compat/Semigroup.hs b/Cabal-syntax/src/Distribution/Compat/Semigroup.hs index 947eaa50e82..9db9f6ebe98 100644 --- a/Cabal-syntax/src/Distribution/Compat/Semigroup.hs +++ b/Cabal-syntax/src/Distribution/Compat/Semigroup.hs @@ -1,46 +1,44 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeOperators #-} -- | Compatibility layer for "Data.Semigroup" module Distribution.Compat.Semigroup - ( Semigroup((<>)) - , Mon.Monoid(..) - , All(..) - , Any(..) - - , First'(..) - , Last'(..) - - , Option'(..) - - , gmappend - , gmempty - ) where + ( Semigroup ((<>)) + , Mon.Monoid (..) + , All (..) + , Any (..) + , First' (..) + , Last' (..) + , Option' (..) + , gmappend + , gmempty + ) where +import Data.Typeable (Typeable) import Distribution.Compat.Binary (Binary) import Distribution.Utils.Structured (Structured) -import Data.Typeable (Typeable) import GHC.Generics + -- Data.Semigroup is available since GHC 8.0/base-4.9 in `base` -- for older GHC/base, it's provided by `semigroups` -import Data.Semigroup -import qualified Data.Monoid as Mon +import qualified Data.Monoid as Mon +import Data.Semigroup -- | A copy of 'Data.Semigroup.First'. -newtype First' a = First' { getFirst' :: a } +newtype First' a = First' {getFirst' :: a} deriving (Eq, Ord, Show) instance Semigroup (First' a) where a <> _ = a -- | A copy of 'Data.Semigroup.Last'. -newtype Last' a = Last' { getLast' :: a } +newtype Last' a = Last' {getLast' :: a} deriving (Eq, Ord, Read, Show, Generic, Binary, Typeable) instance Structured a => Structured (Last' a) @@ -53,15 +51,15 @@ instance Functor Last' where -- | A wrapper around 'Maybe', providing the 'Semigroup' and 'Monoid' instances -- implemented for 'Maybe' since @base-4.11@. -newtype Option' a = Option' { getOption' :: Maybe a } +newtype Option' a = Option' {getOption' :: Maybe a} deriving (Eq, Ord, Read, Show, Binary, Generic, Functor, Typeable) instance Structured a => Structured (Option' a) instance Semigroup a => Semigroup (Option' a) where Option' (Just a) <> Option' (Just b) = Option' (Just (a <> b)) - Option' Nothing <> b = b - a <> Option' Nothing = a + Option' Nothing <> b = b + a <> Option' Nothing = a instance Semigroup a => Monoid (Option' a) where mempty = Option' Nothing @@ -83,16 +81,16 @@ gmappend :: (Generic a, GSemigroup (Rep a)) => a -> a -> a gmappend x y = to (gmappend' (from x) (from y)) class GSemigroup f where - gmappend' :: f p -> f p -> f p + gmappend' :: f p -> f p -> f p instance Semigroup a => GSemigroup (K1 i a) where - gmappend' (K1 x) (K1 y) = K1 (x <> y) + gmappend' (K1 x) (K1 y) = K1 (x <> y) instance GSemigroup f => GSemigroup (M1 i c f) where - gmappend' (M1 x) (M1 y) = M1 (gmappend' x y) + gmappend' (M1 x) (M1 y) = M1 (gmappend' x y) instance (GSemigroup f, GSemigroup g) => GSemigroup (f :*: g) where - gmappend' (x1 :*: x2) (y1 :*: y2) = gmappend' x1 y1 :*: gmappend' x2 y2 + gmappend' (x1 :*: x2) (y1 :*: y2) = gmappend' x1 y1 :*: gmappend' x2 y2 -- | Generically generate a 'Monoid' 'mempty' for any product-like type -- implementing 'Generic'. @@ -102,18 +100,17 @@ instance (GSemigroup f, GSemigroup g) => GSemigroup (f :*: g) where -- @ -- 'gmappend' 'gmempty' a = a = 'gmappend' a 'gmempty' -- @ - gmempty :: (Generic a, GMonoid (Rep a)) => a gmempty = to gmempty' class GSemigroup f => GMonoid f where - gmempty' :: f p + gmempty' :: f p instance (Semigroup a, Monoid a) => GMonoid (K1 i a) where - gmempty' = K1 mempty + gmempty' = K1 mempty instance GMonoid f => GMonoid (M1 i c f) where - gmempty' = M1 gmempty' + gmempty' = M1 gmempty' instance (GMonoid f, GMonoid g) => GMonoid (f :*: g) where - gmempty' = gmempty' :*: gmempty' + gmempty' = gmempty' :*: gmempty' diff --git a/Cabal-syntax/src/Distribution/Compat/Typeable.hs b/Cabal-syntax/src/Distribution/Compat/Typeable.hs index 808d04472f6..161f868a823 100644 --- a/Cabal-syntax/src/Distribution/Compat/Typeable.hs +++ b/Cabal-syntax/src/Distribution/Compat/Typeable.hs @@ -1,10 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Compat.Typeable ( - Typeable, - TypeRep, - typeRep, - ) where + +module Distribution.Compat.Typeable + ( Typeable + , TypeRep + , typeRep + ) where #if MIN_VERSION_base(4,7,0) import Data.Typeable (Typeable, TypeRep, typeRep) diff --git a/Cabal-syntax/src/Distribution/Compiler.hs b/Cabal-syntax/src/Distribution/Compiler.hs index 4f6ce1b97e9..8fb3f88851e 100644 --- a/Cabal-syntax/src/Distribution/Compiler.hs +++ b/Cabal-syntax/src/Distribution/Compiler.hs @@ -1,10 +1,11 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Compiler -- Copyright : Isaac Jones 2003-2004 @@ -26,44 +27,54 @@ -- 'UserHooks' api, which would break all custom @Setup.hs@ files, so for the -- moment we just have to live with this deficiency. If you're interested, see -- ticket #57. - -module Distribution.Compiler ( - -- * Compiler flavor - CompilerFlavor(..), - buildCompilerId, - buildCompilerFlavor, - defaultCompilerFlavor, - classifyCompilerFlavor, - knownCompilerFlavors, - - -- * Per compiler flavor - PerCompilerFlavor (..), - perCompilerFlavorToList, - - -- * Compiler id - CompilerId(..), - - -- * Compiler info - CompilerInfo(..), - unknownCompilerInfo, - AbiTag(..), abiTagString +module Distribution.Compiler + ( -- * Compiler flavor + CompilerFlavor (..) + , buildCompilerId + , buildCompilerFlavor + , defaultCompilerFlavor + , classifyCompilerFlavor + , knownCompilerFlavors + + -- * Per compiler flavor + , PerCompilerFlavor (..) + , perCompilerFlavorToList + + -- * Compiler id + , CompilerId (..) + + -- * Compiler info + , CompilerInfo (..) + , unknownCompilerInfo + , AbiTag (..) + , abiTagString ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Language.Haskell.Extension import Distribution.Version (Version, mkVersion', nullVersion) -import qualified System.Info (compilerName, compilerVersion) +import qualified Distribution.Compat.CharParsing as P import Distribution.Parsec (Parsec (..)) import Distribution.Pretty (Pretty (..), prettyShow) -import qualified Distribution.Compat.CharParsing as P +import qualified System.Info (compilerName, compilerVersion) import qualified Text.PrettyPrint as Disp -data CompilerFlavor = - GHC | GHCJS | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC | Eta +data CompilerFlavor + = GHC + | GHCJS + | NHC + | YHC + | Hugs + | HBC + | Helium + | JHC + | LHC + | UHC + | Eta | HaskellSuite String -- string is the id of the actual compiler | OtherCompiler String deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) @@ -78,23 +89,25 @@ knownCompilerFlavors = instance Pretty CompilerFlavor where pretty (OtherCompiler name) = Disp.text name - pretty (HaskellSuite name) = Disp.text name - pretty NHC = Disp.text "nhc98" - pretty other = Disp.text (lowercase (show other)) + pretty (HaskellSuite name) = Disp.text name + pretty NHC = Disp.text "nhc98" + pretty other = Disp.text (lowercase (show other)) instance Parsec CompilerFlavor where - parsec = classifyCompilerFlavor <$> component - where - component = do - cs <- P.munch1 isAlphaNum - if all isDigit cs then fail "all digits compiler name" else return cs + parsec = classifyCompilerFlavor <$> component + where + component = do + cs <- P.munch1 isAlphaNum + if all isDigit cs then fail "all digits compiler name" else return cs classifyCompilerFlavor :: String -> CompilerFlavor classifyCompilerFlavor s = fromMaybe (OtherCompiler s) $ lookup (lowercase s) compilerMap where - compilerMap = [ (lowercase (prettyShow compiler), compiler) - | compiler <- knownCompilerFlavors ] + compilerMap = + [ (lowercase (prettyShow compiler), compiler) + | compiler <- knownCompilerFlavors + ] buildCompilerFlavor :: CompilerFlavor buildCompilerFlavor = classifyCompilerFlavor System.Info.compilerName @@ -110,11 +123,10 @@ buildCompilerId = CompilerId buildCompilerFlavor buildCompilerVersion -- -- However if it's not a recognised compiler then it's 'Nothing' and the user -- will have to specify which compiler they want. --- defaultCompilerFlavor :: Maybe CompilerFlavor defaultCompilerFlavor = case buildCompilerFlavor of OtherCompiler _ -> Nothing - _ -> Just buildCompilerFlavor + _ -> Just buildCompilerFlavor ------------------------------------------------------------------------------- -- Per compiler data @@ -123,10 +135,19 @@ defaultCompilerFlavor = case buildCompilerFlavor of -- | 'PerCompilerFlavor' carries only info per GHC and GHCJS -- -- Cabal parses only @ghc-options@ and @ghcjs-options@, others are omitted. --- data PerCompilerFlavor v = PerCompilerFlavor v v - deriving (Generic, Show, Read, Eq, Ord, Typeable, Data, Functor, Foldable - , Traversable) + deriving + ( Generic + , Show + , Read + , Eq + , Ord + , Typeable + , Data + , Functor + , Foldable + , Traversable + ) instance Binary a => Binary (PerCompilerFlavor a) instance Structured a => Structured (PerCompilerFlavor a) @@ -136,15 +157,19 @@ perCompilerFlavorToList :: PerCompilerFlavor v -> [(CompilerFlavor, v)] perCompilerFlavorToList (PerCompilerFlavor a b) = [(GHC, a), (GHCJS, b)] instance Semigroup a => Semigroup (PerCompilerFlavor a) where - PerCompilerFlavor a b <> PerCompilerFlavor a' b' = PerCompilerFlavor - (a <> a') (b <> b') + PerCompilerFlavor a b <> PerCompilerFlavor a' b' = + PerCompilerFlavor + (a <> a') + (b <> b') instance (Semigroup a, Monoid a) => Monoid (PerCompilerFlavor a) where - mempty = PerCompilerFlavor mempty mempty - mappend = (<>) + mempty = PerCompilerFlavor mempty mempty + mappend = (<>) -- ------------------------------------------------------------ + -- * Compiler Id + -- ------------------------------------------------------------ data CompilerId = CompilerId CompilerFlavor Version @@ -157,7 +182,7 @@ instance NFData CompilerId where rnf = genericRnf instance Pretty CompilerId where pretty (CompilerId f v) | v == nullVersion = pretty f - | otherwise = pretty f <<>> Disp.char '-' <<>> pretty v + | otherwise = pretty f <<>> Disp.char '-' <<>> pretty v instance Parsec CompilerId where parsec = do @@ -169,28 +194,29 @@ lowercase :: String -> String lowercase = map toLower -- ------------------------------------------------------------ + -- * Compiler Info + -- ------------------------------------------------------------ -- | Compiler information used for resolving configurations. Some -- fields can be set to Nothing to indicate that the information is -- unknown. - -data CompilerInfo = CompilerInfo { - compilerInfoId :: CompilerId, - -- ^ Compiler flavour and version. - compilerInfoAbiTag :: AbiTag, - -- ^ Tag for distinguishing incompatible ABI's on the same - -- architecture/os. - compilerInfoCompat :: Maybe [CompilerId], - -- ^ Other implementations that this compiler claims to be - -- compatible with, if known. - compilerInfoLanguages :: Maybe [Language], - -- ^ Supported language standards, if known. - compilerInfoExtensions :: Maybe [Extension] - -- ^ Supported extensions, if known. - } - deriving (Generic, Show, Read) +data CompilerInfo = CompilerInfo + { compilerInfoId :: CompilerId + -- ^ Compiler flavour and version. + , compilerInfoAbiTag :: AbiTag + -- ^ Tag for distinguishing incompatible ABI's on the same + -- architecture/os. + , compilerInfoCompat :: Maybe [CompilerId] + -- ^ Other implementations that this compiler claims to be + -- compatible with, if known. + , compilerInfoLanguages :: Maybe [Language] + -- ^ Supported language standards, if known. + , compilerInfoExtensions :: Maybe [Extension] + -- ^ Supported extensions, if known. + } + deriving (Generic, Show, Read) instance Binary CompilerInfo @@ -203,7 +229,7 @@ instance Binary AbiTag instance Structured AbiTag instance Pretty AbiTag where - pretty NoAbiTag = Disp.empty + pretty NoAbiTag = Disp.empty pretty (AbiTag tag) = Disp.text tag instance Parsec AbiTag where @@ -212,7 +238,7 @@ instance Parsec AbiTag where if null tag then return NoAbiTag else return (AbiTag tag) abiTagString :: AbiTag -> String -abiTagString NoAbiTag = "" +abiTagString NoAbiTag = "" abiTagString (AbiTag tag) = tag -- | Make a CompilerInfo of which only the known information is its CompilerId, diff --git a/Cabal-syntax/src/Distribution/FieldGrammar.hs b/Cabal-syntax/src/Distribution/FieldGrammar.hs index f75cea2a5e0..e41dd6350c2 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar.hs @@ -1,34 +1,38 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} + -- | This module provides a way to specify a grammar of @.cabal@ -like files. -module Distribution.FieldGrammar ( - -- * Field grammar type - FieldGrammar (..), - uniqueField, - optionalField, - optionalFieldDef, - monoidalField, +module Distribution.FieldGrammar + ( -- * Field grammar type + FieldGrammar (..) + , uniqueField + , optionalField + , optionalFieldDef + , monoidalField + -- * Concrete grammar implementations - ParsecFieldGrammar, - ParsecFieldGrammar', - parseFieldGrammar, - fieldGrammarKnownFieldList, - PrettyFieldGrammar, - PrettyFieldGrammar', - prettyFieldGrammar, + , ParsecFieldGrammar + , ParsecFieldGrammar' + , parseFieldGrammar + , fieldGrammarKnownFieldList + , PrettyFieldGrammar + , PrettyFieldGrammar' + , prettyFieldGrammar + -- * Auxiliary - (^^^), - Section(..), - Fields, - partitionFields, - takeFields, - runFieldParser, - runFieldParser', - defaultFreeTextFieldDefST, + , (^^^) + , Section (..) + , Fields + , partitionFields + , takeFields + , runFieldParser + , runFieldParser' + , defaultFreeTextFieldDefST + -- * Newtypes - module Distribution.FieldGrammar.Newtypes, - ) where + , module Distribution.FieldGrammar.Newtypes + ) where import Distribution.Compat.Prelude import Prelude () @@ -40,7 +44,7 @@ import Distribution.FieldGrammar.Newtypes import Distribution.FieldGrammar.Parsec import Distribution.FieldGrammar.Pretty import Distribution.Fields.Field -import Distribution.Utils.Generic (spanMaybe) +import Distribution.Utils.Generic (spanMaybe) type ParsecFieldGrammar' a = ParsecFieldGrammar a a type PrettyFieldGrammar' a = PrettyFieldGrammar a a @@ -66,17 +70,18 @@ partitionFields = finalize . foldl' f (PS mempty mempty mempty) where finalize :: PS ann -> (Fields ann, [[Section ann]]) finalize (PS fs s ss) - | null s = (fs, reverse ss) - | otherwise = (fs, reverse (reverse s : ss)) + | null s = (fs, reverse ss) + | otherwise = (fs, reverse (reverse s : ss)) f :: PS ann -> Field ann -> PS ann f (PS fs s ss) (Field (Name ann name) fss) = - PS (Map.insertWith (flip (++)) name [MkNamelessField ann fss] fs) [] ss' + PS (Map.insertWith (flip (++)) name [MkNamelessField ann fss] fs) [] ss' where - ss' | null s = ss - | otherwise = reverse s : ss + ss' + | null s = ss + | otherwise = reverse s : ss f (PS fs s ss) (Section name sargs sfields) = - PS fs (MkSection name sargs sfields : s) ss + PS fs (MkSection name sargs sfields : s) ss -- | Take all fields from the front. takeFields :: [Field ann] -> (Fields ann, [Field ann]) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs index 9d8dbf3a647..df8b69414f2 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs @@ -1,24 +1,25 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableSuperClasses #-} -module Distribution.FieldGrammar.Class ( - FieldGrammar (..), - uniqueField, - optionalField, - optionalFieldDef, - monoidalField, - defaultFreeTextFieldDefST, -) where + +module Distribution.FieldGrammar.Class + ( FieldGrammar (..) + , uniqueField + , optionalField + , optionalFieldDef + , monoidalField + , defaultFreeTextFieldDefST + ) where import Distribution.Compat.Lens import Distribution.Compat.Prelude import Prelude () -import Distribution.CabalSpecVersion (CabalSpecVersion) -import Distribution.Compat.Newtype (Newtype) +import Distribution.CabalSpecVersion (CabalSpecVersion) +import Distribution.Compat.Newtype (Newtype) import Distribution.FieldGrammar.Newtypes import Distribution.Fields.Field import Distribution.Utils.ShortText @@ -31,171 +32,213 @@ import Distribution.Utils.ShortText -- * @a@ type of the field. -- -- /Note:/ We'd like to have @forall s. Applicative (f s)@ context. --- class - ( c SpecVersion, c TestedWith, c SpecLicense, c Token, c Token', c FilePathNT - ) - => FieldGrammar c g | g -> c + ( c SpecVersion + , c TestedWith + , c SpecLicense + , c Token + , c Token' + , c FilePathNT + ) => + FieldGrammar c g + | g -> c where - -- | Unfocus, zoom out, /blur/ 'FieldGrammar'. - blurFieldGrammar :: ALens' a b -> g b d -> g a d - - -- | Field which should be defined, exactly once. - uniqueFieldAla - :: (c b, Newtype a b) - => FieldName -- ^ field name - -> (a -> b) -- ^ 'Newtype' pack - -> ALens' s a -- ^ lens into the field - -> g s a - - -- | Boolean field with a default value. - booleanFieldDef - :: FieldName -- ^ field name - -> ALens' s Bool -- ^ lens into the field - -> Bool -- ^ default - -> g s Bool - - -- | Optional field. - optionalFieldAla - :: (c b, Newtype a b) - => FieldName -- ^ field name - -> (a -> b) -- ^ 'pack' - -> ALens' s (Maybe a) -- ^ lens into the field - -> g s (Maybe a) - - -- | Optional field with default value. - optionalFieldDefAla - :: (c b, Newtype a b, Eq a) - => FieldName -- ^ field name - -> (a -> b) -- ^ 'Newtype' pack - -> ALens' s a -- ^ @'Lens'' s a@: lens into the field - -> a -- ^ default value - -> g s a - - -- | Free text field is essentially 'optionalFieldDefAla` with @""@ - -- as the default and "accept everything" parser. - -- - -- @since 3.0.0.0 - freeTextField - :: FieldName - -> ALens' s (Maybe String) -- ^ lens into the field - -> g s (Maybe String) - - -- | Free text field is essentially 'optionalFieldDefAla` with @""@ - -- as the default and "accept everything" parser. - -- - -- @since 3.0.0.0 - freeTextFieldDef - :: FieldName - -> ALens' s String -- ^ lens into the field - -> g s String - - -- | @since 3.2.0.0 - freeTextFieldDefST - :: FieldName - -> ALens' s ShortText -- ^ lens into the field - -> g s ShortText - - -- | Monoidal field. - -- - -- Values are combined with 'mappend'. - -- - -- /Note:/ 'optionalFieldAla' is a @monoidalField@ with 'Last' monoid. - -- - monoidalFieldAla - :: (c b, Monoid a, Newtype a b) - => FieldName -- ^ field name - -> (a -> b) -- ^ 'pack' - -> ALens' s a -- ^ lens into the field - -> g s a - - -- | Parser matching all fields with a name starting with a prefix. - prefixedFields - :: FieldName -- ^ field name prefix - -> ALens' s [(String, String)] -- ^ lens into the field - -> g s [(String, String)] - - -- | Known field, which we don't parse, nor pretty print. - knownField :: FieldName -> g s () - - -- | Field which is parsed but not pretty printed. - hiddenField :: g s a -> g s a - - -- | Deprecated since - deprecatedSince - :: CabalSpecVersion -- ^ version - -> String -- ^ deprecation message - -> g s a - -> g s a - - -- | Removed in. If we encounter removed field, parsing fails. - removedIn - :: CabalSpecVersion -- ^ version - -> String -- ^ removal message - -> g s a - -> g s a - - -- | Annotate field with since spec-version. - availableSince - :: CabalSpecVersion -- ^ spec version - -> a -- ^ default value - -> g s a - -> g s a - - -- | Annotate field with since spec-version. - -- This is used to recognise, but warn about the field. - -- It is used to process @other-extensions@ field. - -- - -- Default implementation is to not warn. - -- - -- @since 3.4.0.0 - availableSinceWarn - :: CabalSpecVersion -- ^ spec version - -> g s a - -> g s a - availableSinceWarn _ = id + -- | Unfocus, zoom out, /blur/ 'FieldGrammar'. + blurFieldGrammar :: ALens' a b -> g b d -> g a d + + -- | Field which should be defined, exactly once. + uniqueFieldAla + :: (c b, Newtype a b) + => FieldName + -- ^ field name + -> (a -> b) + -- ^ 'Newtype' pack + -> ALens' s a + -- ^ lens into the field + -> g s a + + -- | Boolean field with a default value. + booleanFieldDef + :: FieldName + -- ^ field name + -> ALens' s Bool + -- ^ lens into the field + -> Bool + -- ^ default + -> g s Bool + + -- | Optional field. + optionalFieldAla + :: (c b, Newtype a b) + => FieldName + -- ^ field name + -> (a -> b) + -- ^ 'pack' + -> ALens' s (Maybe a) + -- ^ lens into the field + -> g s (Maybe a) + + -- | Optional field with default value. + optionalFieldDefAla + :: (c b, Newtype a b, Eq a) + => FieldName + -- ^ field name + -> (a -> b) + -- ^ 'Newtype' pack + -> ALens' s a + -- ^ @'Lens'' s a@: lens into the field + -> a + -- ^ default value + -> g s a + + -- | Free text field is essentially 'optionalFieldDefAla` with @""@ + -- as the default and "accept everything" parser. + -- + -- @since 3.0.0.0 + freeTextField + :: FieldName + -> ALens' s (Maybe String) + -- ^ lens into the field + -> g s (Maybe String) + + -- | Free text field is essentially 'optionalFieldDefAla` with @""@ + -- as the default and "accept everything" parser. + -- + -- @since 3.0.0.0 + freeTextFieldDef + :: FieldName + -> ALens' s String + -- ^ lens into the field + -> g s String + + -- | @since 3.2.0.0 + freeTextFieldDefST + :: FieldName + -> ALens' s ShortText + -- ^ lens into the field + -> g s ShortText + + -- | Monoidal field. + -- + -- Values are combined with 'mappend'. + -- + -- /Note:/ 'optionalFieldAla' is a @monoidalField@ with 'Last' monoid. + monoidalFieldAla + :: (c b, Monoid a, Newtype a b) + => FieldName + -- ^ field name + -> (a -> b) + -- ^ 'pack' + -> ALens' s a + -- ^ lens into the field + -> g s a + + -- | Parser matching all fields with a name starting with a prefix. + prefixedFields + :: FieldName + -- ^ field name prefix + -> ALens' s [(String, String)] + -- ^ lens into the field + -> g s [(String, String)] + + -- | Known field, which we don't parse, nor pretty print. + knownField :: FieldName -> g s () + + -- | Field which is parsed but not pretty printed. + hiddenField :: g s a -> g s a + + -- | Deprecated since + deprecatedSince + :: CabalSpecVersion + -- ^ version + -> String + -- ^ deprecation message + -> g s a + -> g s a + + -- | Removed in. If we encounter removed field, parsing fails. + removedIn + :: CabalSpecVersion + -- ^ version + -> String + -- ^ removal message + -> g s a + -> g s a + + -- | Annotate field with since spec-version. + availableSince + :: CabalSpecVersion + -- ^ spec version + -> a + -- ^ default value + -> g s a + -> g s a + + -- | Annotate field with since spec-version. + -- This is used to recognise, but warn about the field. + -- It is used to process @other-extensions@ field. + -- + -- Default implementation is to not warn. + -- + -- @since 3.4.0.0 + availableSinceWarn + :: CabalSpecVersion + -- ^ spec version + -> g s a + -> g s a + availableSinceWarn _ = id -- | Field which can be defined at most once. uniqueField - :: (FieldGrammar c g, c (Identity a)) - => FieldName -- ^ field name - -> ALens' s a -- ^ lens into the field - -> g s a + :: (FieldGrammar c g, c (Identity a)) + => FieldName + -- ^ field name + -> ALens' s a + -- ^ lens into the field + -> g s a uniqueField fn l = uniqueFieldAla fn Identity l -- | Field which can be defined at most once. optionalField - :: (FieldGrammar c g, c (Identity a)) - => FieldName -- ^ field name - -> ALens' s (Maybe a) -- ^ lens into the field - -> g s (Maybe a) + :: (FieldGrammar c g, c (Identity a)) + => FieldName + -- ^ field name + -> ALens' s (Maybe a) + -- ^ lens into the field + -> g s (Maybe a) optionalField fn l = optionalFieldAla fn Identity l -- | Optional field with default value. optionalFieldDef - :: (FieldGrammar c g, Functor (g s), c (Identity a), Eq a) - => FieldName -- ^ field name - -> ALens' s a -- ^ @'Lens'' s a@: lens into the field - -> a -- ^ default value - -> g s a + :: (FieldGrammar c g, Functor (g s), c (Identity a), Eq a) + => FieldName + -- ^ field name + -> ALens' s a + -- ^ @'Lens'' s a@: lens into the field + -> a + -- ^ default value + -> g s a optionalFieldDef fn l x = optionalFieldDefAla fn Identity l x -- | Field which can be define multiple times, and the results are @mappend@ed. monoidalField - :: (FieldGrammar c g, c (Identity a), Monoid a) - => FieldName -- ^ field name - -> ALens' s a -- ^ lens into the field - -> g s a + :: (FieldGrammar c g, c (Identity a), Monoid a) + => FieldName + -- ^ field name + -> ALens' s a + -- ^ lens into the field + -> g s a monoidalField fn l = monoidalFieldAla fn Identity l -- | Default implementation for 'freeTextFieldDefST'. defaultFreeTextFieldDefST - :: (Functor (g s), FieldGrammar c g) - => FieldName - -> ALens' s ShortText -- ^ lens into the field - -> g s ShortText + :: (Functor (g s), FieldGrammar c g) + => FieldName + -> ALens' s ShortText + -- ^ lens into the field + -> g s ShortText defaultFreeTextFieldDefST fn l = - toShortText <$> freeTextFieldDef fn (cloneLens l . st) + toShortText <$> freeTextFieldDef fn (cloneLens l . st) where st :: Lens' ShortText String st f s = toShortText <$> f (fromShortText s) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/FieldDescrs.hs b/Cabal-syntax/src/Distribution/FieldGrammar/FieldDescrs.hs index efb6d368f95..e03ae749570 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/FieldDescrs.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/FieldDescrs.hs @@ -1,43 +1,44 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE UndecidableInstances #-} -module Distribution.FieldGrammar.FieldDescrs ( - FieldDescrs, - fieldDescrPretty, - fieldDescrParse, - fieldDescrsToList, - ) where +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} + +module Distribution.FieldGrammar.FieldDescrs + ( FieldDescrs + , fieldDescrPretty + , fieldDescrParse + , fieldDescrsToList + ) where import Distribution.Compat.Prelude import Prelude () -import Distribution.Compat.Lens (aview, cloneLens) -import Distribution.Utils.String (trim) +import Distribution.Compat.Lens (aview, cloneLens) import Distribution.Compat.Newtype import Distribution.FieldGrammar -import Distribution.Pretty (Pretty (..), showFreeText) +import Distribution.Pretty (Pretty (..), showFreeText) +import Distribution.Utils.String (trim) -import qualified Data.Map as Map +import qualified Data.Map as Map import qualified Distribution.Compat.CharParsing as C -import qualified Distribution.Fields as P -import qualified Distribution.Parsec as P -import qualified Text.PrettyPrint as Disp +import qualified Distribution.Fields as P +import qualified Distribution.Parsec as P +import qualified Text.PrettyPrint as Disp -- strict pair data SP s = SP - { pPretty :: !(s -> Disp.Doc) - , pParse :: !(forall m. P.CabalParsing m => s -> m s) - } + { pPretty :: !(s -> Disp.Doc) + , pParse :: !(forall m. P.CabalParsing m => s -> m s) + } -- | A collection of field parsers and pretty-printers. -newtype FieldDescrs s a = F { runF :: Map P.FieldName (SP s) } +newtype FieldDescrs s a = F {runF :: Map P.FieldName (SP s)} deriving (Functor) instance Applicative (FieldDescrs s) where - pure _ = F mempty - f <*> x = F (mappend (runF f) (runF x)) + pure _ = F mempty + f <*> x = F (mappend (runF f) (runF x)) singletonF :: P.FieldName -> (s -> Disp.Doc) -> (forall m. P.CabalParsing m => s -> m s) -> FieldDescrs s a singletonF fn f g = F $ Map.singleton fn (SP f g) @@ -51,54 +52,64 @@ fieldDescrParse :: P.CabalParsing m => FieldDescrs s a -> P.FieldName -> Maybe ( fieldDescrParse (F m) fn = (\f -> pParse f) <$> Map.lookup fn m fieldDescrsToList - :: P.CabalParsing m - => FieldDescrs s a - -> [(P.FieldName, s -> Disp.Doc, s -> m s)] -fieldDescrsToList = map mk . Map.toList . runF where + :: P.CabalParsing m + => FieldDescrs s a + -> [(P.FieldName, s -> Disp.Doc, s -> m s)] +fieldDescrsToList = map mk . Map.toList . runF + where mk (name, SP ppr parse) = (name, ppr, parse) -- | /Note:/ default values are printed. instance FieldGrammar ParsecPretty FieldDescrs where - blurFieldGrammar l (F m) = F (fmap blur m) where - blur (SP f g) = SP (f . aview l) (cloneLens l g) - - booleanFieldDef fn l _def = singletonF fn f g where - f s = Disp.text (show (aview l s)) - g s = cloneLens l (const P.parsec) s - -- Note: eta expansion is needed for RankNTypes type-checking to work. - - uniqueFieldAla fn _pack l = singletonF fn f g where - f s = pretty (pack' _pack (aview l s)) - g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s - - optionalFieldAla fn _pack l = singletonF fn f g where - f s = maybe mempty (pretty . pack' _pack) (aview l s) - g s = cloneLens l (const (Just . unpack' _pack <$> P.parsec)) s - - optionalFieldDefAla fn _pack l _def = singletonF fn f g where - f s = pretty (pack' _pack (aview l s)) - g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s - - freeTextField fn l = singletonF fn f g where - f s = maybe mempty showFreeText (aview l s) - g s = cloneLens l (const (Just <$> parsecFreeText)) s - - freeTextFieldDef fn l = singletonF fn f g where - f s = showFreeText (aview l s) - g s = cloneLens l (const parsecFreeText) s - - freeTextFieldDefST = defaultFreeTextFieldDefST - - monoidalFieldAla fn _pack l = singletonF fn f g where - f s = pretty (pack' _pack (aview l s)) - g s = cloneLens l (\x -> mappend x . unpack' _pack <$> P.parsec) s - - prefixedFields _fnPfx _l = F mempty - knownField _ = pure () - deprecatedSince _ _ x = x - removedIn _ _ x = x - availableSince _ _ = id - hiddenField _ = F mempty + blurFieldGrammar l (F m) = F (fmap blur m) + where + blur (SP f g) = SP (f . aview l) (cloneLens l g) + + booleanFieldDef fn l _def = singletonF fn f g + where + f s = Disp.text (show (aview l s)) + g s = cloneLens l (const P.parsec) s + + -- Note: eta expansion is needed for RankNTypes type-checking to work. + + uniqueFieldAla fn _pack l = singletonF fn f g + where + f s = pretty (pack' _pack (aview l s)) + g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s + + optionalFieldAla fn _pack l = singletonF fn f g + where + f s = maybe mempty (pretty . pack' _pack) (aview l s) + g s = cloneLens l (const (Just . unpack' _pack <$> P.parsec)) s + + optionalFieldDefAla fn _pack l _def = singletonF fn f g + where + f s = pretty (pack' _pack (aview l s)) + g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s + + freeTextField fn l = singletonF fn f g + where + f s = maybe mempty showFreeText (aview l s) + g s = cloneLens l (const (Just <$> parsecFreeText)) s + + freeTextFieldDef fn l = singletonF fn f g + where + f s = showFreeText (aview l s) + g s = cloneLens l (const parsecFreeText) s + + freeTextFieldDefST = defaultFreeTextFieldDefST + + monoidalFieldAla fn _pack l = singletonF fn f g + where + f s = pretty (pack' _pack (aview l s)) + g s = cloneLens l (\x -> mappend x . unpack' _pack <$> P.parsec) s + + prefixedFields _fnPfx _l = F mempty + knownField _ = pure () + deprecatedSince _ _ x = x + removedIn _ _ x = x + availableSince _ _ = id + hiddenField _ = F mempty parsecFreeText :: P.CabalParsing m => m String parsecFreeText = dropDotLines <$ C.spaces <*> many C.anyChar @@ -109,11 +120,10 @@ parsecFreeText = dropDotLines <$ C.spaces <*> many C.anyChar dropDotLines x = intercalate "\n" . map dotToEmpty . lines $ x dotToEmpty x | trim' x == "." = "" - dotToEmpty x = trim x + dotToEmpty x = trim x trim' :: String -> String trim' = dropWhileEnd (`elem` (" \t" :: String)) - -class (P.Parsec a, Pretty a) => ParsecPretty a +class (P.Parsec a, Pretty a) => ParsecPretty a instance (P.Parsec a, Pretty a) => ParsecPretty a diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs index 9ec51e7032c..f823d3d63e5 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs @@ -1,60 +1,77 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + -- | This module provides @newtype@ wrappers to be used with "Distribution.FieldGrammar". -module Distribution.FieldGrammar.Newtypes ( - -- * List - alaList, - alaList', +module Distribution.FieldGrammar.Newtypes + ( -- * List + alaList + , alaList' + -- ** Modifiers - CommaVCat (..), - CommaFSep (..), - VCat (..), - FSep (..), - NoCommaFSep (..), - Sep (..), + , CommaVCat (..) + , CommaFSep (..) + , VCat (..) + , FSep (..) + , NoCommaFSep (..) + , Sep (..) + -- ** Type - List, + , List + -- ** Set - alaSet, - alaSet', - Set', + , alaSet + , alaSet' + , Set' + -- ** NonEmpty - alaNonEmpty, - alaNonEmpty', - NonEmpty', + , alaNonEmpty + , alaNonEmpty' + , NonEmpty' + -- * Version & License - SpecVersion (..), - TestedWith (..), - SpecLicense (..), + , SpecVersion (..) + , TestedWith (..) + , SpecLicense (..) + -- * Identifiers - Token (..), - Token' (..), - MQuoted (..), - FilePathNT (..), - ) where + , Token (..) + , Token' (..) + , MQuoted (..) + , FilePathNT (..) + ) where import Distribution.Compat.Newtype import Distribution.Compat.Prelude import Prelude () import Distribution.CabalSpecVersion -import Distribution.Compiler (CompilerFlavor) -import Distribution.License (License) +import Distribution.Compiler (CompilerFlavor) +import Distribution.License (License) import Distribution.Parsec import Distribution.Pretty import Distribution.Version - (LowerBound (..), Version, VersionInterval (..), VersionRange, VersionRangeF (..), anyVersion, asVersionIntervals, cataVersionRange, mkVersion, - version0, versionNumbers) -import Text.PrettyPrint (Doc, comma, fsep, punctuate, text, vcat) - -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as Set + ( LowerBound (..) + , Version + , VersionInterval (..) + , VersionRange + , VersionRangeF (..) + , anyVersion + , asVersionIntervals + , cataVersionRange + , mkVersion + , version0 + , versionNumbers + ) +import Text.PrettyPrint (Doc, comma, fsep, punctuate, text, vcat) + +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as Set import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.SPDX as SPDX +import qualified Distribution.SPDX as SPDX -- | Vertical list with commas. Displayed with 'vcat' data CommaVCat = CommaVCat @@ -71,48 +88,48 @@ data FSep = FSep -- | Paragraph fill list without commas. Displayed with 'fsep'. data NoCommaFSep = NoCommaFSep -class Sep sep where - prettySep :: Proxy sep -> [Doc] -> Doc +class Sep sep where + prettySep :: Proxy sep -> [Doc] -> Doc - parseSep :: CabalParsing m => Proxy sep -> m a -> m [a] - parseSepNE :: CabalParsing m => Proxy sep -> m a -> m (NonEmpty a) + parseSep :: CabalParsing m => Proxy sep -> m a -> m [a] + parseSepNE :: CabalParsing m => Proxy sep -> m a -> m (NonEmpty a) instance Sep CommaVCat where - prettySep _ = vcat . punctuate comma - parseSep _ p = do - v <- askCabalSpecVersion - if v >= CabalSpecV2_2 then parsecLeadingCommaList p else parsecCommaList p - parseSepNE _ p = do - v <- askCabalSpecVersion - if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p + prettySep _ = vcat . punctuate comma + parseSep _ p = do + v <- askCabalSpecVersion + if v >= CabalSpecV2_2 then parsecLeadingCommaList p else parsecCommaList p + parseSepNE _ p = do + v <- askCabalSpecVersion + if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p instance Sep CommaFSep where - prettySep _ = fsep . punctuate comma - parseSep _ p = do - v <- askCabalSpecVersion - if v >= CabalSpecV2_2 then parsecLeadingCommaList p else parsecCommaList p - parseSepNE _ p = do - v <- askCabalSpecVersion - if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p + prettySep _ = fsep . punctuate comma + parseSep _ p = do + v <- askCabalSpecVersion + if v >= CabalSpecV2_2 then parsecLeadingCommaList p else parsecCommaList p + parseSepNE _ p = do + v <- askCabalSpecVersion + if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p instance Sep VCat where - prettySep _ = vcat - parseSep _ p = do - v <- askCabalSpecVersion - if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p - parseSepNE _ p = NE.some1 (p <* P.spaces) + prettySep _ = vcat + parseSep _ p = do + v <- askCabalSpecVersion + if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p + parseSepNE _ p = NE.some1 (p <* P.spaces) instance Sep FSep where - prettySep _ = fsep - parseSep _ p = do - v <- askCabalSpecVersion - if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p - parseSepNE _ p = NE.some1 (p <* P.spaces) + prettySep _ = fsep + parseSep _ p = do + v <- askCabalSpecVersion + if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p + parseSepNE _ p = NE.some1 (p <* P.spaces) instance Sep NoCommaFSep where - prettySep _ = fsep - parseSep _ p = many (p <* P.spaces) - parseSepNE _ p = NE.some1 (p <* P.spaces) + prettySep _ = fsep + parseSep _ p = many (p <* P.spaces) + parseSepNE _ p = NE.some1 (p <* P.spaces) -- | List separated with optional commas. Displayed with @sep@, arguments of -- type @a@ are parsed and pretty-printed as @b@. -newtype List sep b a = List { _getList :: [a] } +newtype List sep b a = List {_getList :: [a]} -- | 'alaList' and 'alaList'' are simply 'List', with additional phantom -- arguments to constrain the resulting type @@ -122,7 +139,6 @@ newtype List sep b a = List { _getList :: [a] } -- -- >>> :t alaList' FSep Token -- alaList' FSep Token :: [String] -> List FSep Token String --- alaList :: sep -> [a] -> List sep (Identity a) a alaList _ = List @@ -133,16 +149,17 @@ alaList' _ _ = List instance Newtype [a] (List sep wrapper a) instance (Newtype a b, Sep sep, Parsec b) => Parsec (List sep b a) where - parsec = pack . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec + parsec = pack . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec instance (Newtype a b, Sep sep, Pretty b) => Pretty (List sep b a) where - pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . unpack + pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . unpack -- + -- | Like 'List', but for 'Set'. -- -- @since 3.2.0.0 -newtype Set' sep b a = Set' { _getSet :: Set a } +newtype Set' sep b a = Set' {_getSet :: Set a} -- | 'alaSet' and 'alaSet'' are simply 'Set'' constructor, with additional phantom -- arguments to constrain the resulting type @@ -169,16 +186,17 @@ alaSet' _ _ = Set' instance Newtype (Set a) (Set' sep wrapper a) instance (Newtype a b, Ord a, Sep sep, Parsec b) => Parsec (Set' sep b a) where - parsec = pack . Set.fromList . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec + parsec = pack . Set.fromList . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec instance (Newtype a b, Sep sep, Pretty b) => Pretty (Set' sep b a) where - pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . Set.toList . unpack + pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . Set.toList . unpack -- + -- | Like 'List', but for 'NonEmpty'. -- -- @since 3.2.0.0 -newtype NonEmpty' sep b a = NonEmpty' { _getNonEmpty :: NonEmpty a } +newtype NonEmpty' sep b a = NonEmpty' {_getNonEmpty :: NonEmpty a} -- | 'alaNonEmpty' and 'alaNonEmpty'' are simply 'NonEmpty'' constructor, with additional phantom -- arguments to constrain the resulting type @@ -202,62 +220,62 @@ alaNonEmpty' _ _ = NonEmpty' instance Newtype (NonEmpty a) (NonEmpty' sep wrapper a) instance (Newtype a b, Sep sep, Parsec b) => Parsec (NonEmpty' sep b a) where - parsec = pack . fmap (unpack :: b -> a) <$> parseSepNE (Proxy :: Proxy sep) parsec + parsec = pack . fmap (unpack :: b -> a) <$> parseSepNE (Proxy :: Proxy sep) parsec instance (Newtype a b, Sep sep, Pretty b) => Pretty (NonEmpty' sep b a) where - pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . NE.toList . unpack + pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . NE.toList . unpack ------------------------------------------------------------------------------- -- Identifiers ------------------------------------------------------------------------------- -- | Haskell string or @[^ ,]+@ -newtype Token = Token { getToken :: String } +newtype Token = Token {getToken :: String} instance Newtype String Token instance Parsec Token where - parsec = pack <$> parsecToken + parsec = pack <$> parsecToken instance Pretty Token where - pretty = showToken . unpack + pretty = showToken . unpack -- | Haskell string or @[^ ]+@ -newtype Token' = Token' { getToken' :: String } +newtype Token' = Token' {getToken' :: String} instance Newtype String Token' instance Parsec Token' where - parsec = pack <$> parsecToken' + parsec = pack <$> parsecToken' instance Pretty Token' where - pretty = showToken . unpack + pretty = showToken . unpack -- | Either @"quoted"@ or @un-quoted@. -newtype MQuoted a = MQuoted { getMQuoted :: a } +newtype MQuoted a = MQuoted {getMQuoted :: a} instance Newtype a (MQuoted a) instance Parsec a => Parsec (MQuoted a) where - parsec = pack <$> parsecMaybeQuoted parsec + parsec = pack <$> parsecMaybeQuoted parsec -instance Pretty a => Pretty (MQuoted a) where - pretty = pretty . unpack +instance Pretty a => Pretty (MQuoted a) where + pretty = pretty . unpack -- | Filepath are parsed as 'Token'. -newtype FilePathNT = FilePathNT { getFilePathNT :: String } +newtype FilePathNT = FilePathNT {getFilePathNT :: String} instance Newtype String FilePathNT instance Parsec FilePathNT where - parsec = do - token <- parsecToken - if null token - then P.unexpected "empty FilePath" - else return (FilePathNT token) + parsec = do + token <- parsecToken + if null token + then P.unexpected "empty FilePath" + else return (FilePathNT token) instance Pretty FilePathNT where - pretty = showFilePath . unpack + pretty = showFilePath . unpack ------------------------------------------------------------------------------- -- SpecVersion @@ -275,119 +293,124 @@ instance Pretty FilePathNT where -- We have this newtype, as writing Parsec and Pretty instances -- for CabalSpecVersion would cause cycle in modules: -- Version -> CabalSpecVersion -> Parsec -> ... --- -newtype SpecVersion = SpecVersion { getSpecVersion :: CabalSpecVersion } +newtype SpecVersion = SpecVersion {getSpecVersion :: CabalSpecVersion} deriving (Eq, Show) -- instances needed for tests instance Newtype CabalSpecVersion SpecVersion instance Parsec SpecVersion where - parsec = do - e <- parsecSpecVersion - let ver :: Version - ver = either id specVersionFromRange e - - digits :: [Int] - digits = versionNumbers ver - - case cabalSpecFromVersionDigits digits of - Nothing -> fail $ "Unknown cabal spec version specified: " ++ prettyShow ver - Just csv -> do - -- Check some warnings: - case e of - -- example: cabal-version: 1.10 - -- should be cabal-version: >=1.10 - Left _v | csv < CabalSpecV1_12 -> parsecWarning PWTSpecVersion $ concat - [ "With 1.10 or earlier, the 'cabal-version' field must use " - , "range syntax rather than a simple version number. Use " - , "'cabal-version: >= " ++ prettyShow ver ++ "'." - ] - - -- example: cabal-version: >=1.12 - -- should be cabal-version: 1.12 - Right _vr | csv >= CabalSpecV1_12 -> parsecWarning PWTSpecVersion $ concat - [ "Packages with 'cabal-version: 1.12' or later should specify a " - , "specific version of the Cabal spec of the form " - , "'cabal-version: x.y'. " - , "Use 'cabal-version: " ++ prettyShow ver ++ "'." - ] - - -- example: cabal-version: >=1.10 && <1.12 - -- should be cabal-version: >=1.10 - Right vr | csv < CabalSpecV1_12 - , not (simpleSpecVersionRangeSyntax vr) -> parsecWarning PWTSpecVersion $ concat - [ "It is recommended that the 'cabal-version' field only specify a " - , "version range of the form '>= x.y' for older cabal versions. Use " - , "'cabal-version: >= " ++ prettyShow ver ++ "'. " - , "Tools based on Cabal 1.10 and later will ignore upper bounds." - ] - - -- otherwise no warnings - _ -> pure () - - return (pack csv) - where - parsecSpecVersion = Left <$> parsec <|> Right <$> range - - range = do - vr <- parsec - if specVersionFromRange vr >= mkVersion [2,1] - then fail "cabal-version higher than 2.2 cannot be specified as a range. See https://github.com/haskell/cabal/issues/4899" - else return vr - - specVersionFromRange :: VersionRange -> Version - specVersionFromRange versionRange = case asVersionIntervals versionRange of - [] -> version0 - VersionInterval (LowerBound version _) _ : _ -> version - - simpleSpecVersionRangeSyntax = cataVersionRange alg where - alg (OrLaterVersionF _) = True - alg _ = False - + parsec = do + e <- parsecSpecVersion + let ver :: Version + ver = either id specVersionFromRange e + + digits :: [Int] + digits = versionNumbers ver + + case cabalSpecFromVersionDigits digits of + Nothing -> fail $ "Unknown cabal spec version specified: " ++ prettyShow ver + Just csv -> do + -- Check some warnings: + case e of + -- example: cabal-version: 1.10 + -- should be cabal-version: >=1.10 + Left _v + | csv < CabalSpecV1_12 -> + parsecWarning PWTSpecVersion $ + concat + [ "With 1.10 or earlier, the 'cabal-version' field must use " + , "range syntax rather than a simple version number. Use " + , "'cabal-version: >= " ++ prettyShow ver ++ "'." + ] + -- example: cabal-version: >=1.12 + -- should be cabal-version: 1.12 + Right _vr + | csv >= CabalSpecV1_12 -> + parsecWarning PWTSpecVersion $ + concat + [ "Packages with 'cabal-version: 1.12' or later should specify a " + , "specific version of the Cabal spec of the form " + , "'cabal-version: x.y'. " + , "Use 'cabal-version: " ++ prettyShow ver ++ "'." + ] + -- example: cabal-version: >=1.10 && <1.12 + -- should be cabal-version: >=1.10 + Right vr + | csv < CabalSpecV1_12 + , not (simpleSpecVersionRangeSyntax vr) -> + parsecWarning PWTSpecVersion $ + concat + [ "It is recommended that the 'cabal-version' field only specify a " + , "version range of the form '>= x.y' for older cabal versions. Use " + , "'cabal-version: >= " ++ prettyShow ver ++ "'. " + , "Tools based on Cabal 1.10 and later will ignore upper bounds." + ] + -- otherwise no warnings + _ -> pure () + + return (pack csv) + where + parsecSpecVersion = Left <$> parsec <|> Right <$> range + + range = do + vr <- parsec + if specVersionFromRange vr >= mkVersion [2, 1] + then fail "cabal-version higher than 2.2 cannot be specified as a range. See https://github.com/haskell/cabal/issues/4899" + else return vr + + specVersionFromRange :: VersionRange -> Version + specVersionFromRange versionRange = case asVersionIntervals versionRange of + [] -> version0 + VersionInterval (LowerBound version _) _ : _ -> version + + simpleSpecVersionRangeSyntax = cataVersionRange alg + where + alg (OrLaterVersionF _) = True + alg _ = False instance Pretty SpecVersion where - pretty (SpecVersion csv) - | csv >= CabalSpecV1_12 = text (showCabalSpecVersion csv) - | otherwise = text ">=" <<>> text (showCabalSpecVersion csv) + pretty (SpecVersion csv) + | csv >= CabalSpecV1_12 = text (showCabalSpecVersion csv) + | otherwise = text ">=" <<>> text (showCabalSpecVersion csv) ------------------------------------------------------------------------------- -- SpecLicense ------------------------------------------------------------------------------- -- | SPDX License expression or legacy license -newtype SpecLicense = SpecLicense { getSpecLicense :: Either SPDX.License License } - deriving (Show, Eq) +newtype SpecLicense = SpecLicense {getSpecLicense :: Either SPDX.License License} + deriving (Show, Eq) instance Newtype (Either SPDX.License License) SpecLicense instance Parsec SpecLicense where - parsec = do - v <- askCabalSpecVersion - if v >= CabalSpecV2_2 - then SpecLicense . Left <$> parsec - else SpecLicense . Right <$> parsec + parsec = do + v <- askCabalSpecVersion + if v >= CabalSpecV2_2 + then SpecLicense . Left <$> parsec + else SpecLicense . Right <$> parsec instance Pretty SpecLicense where - pretty = either pretty pretty . unpack + pretty = either pretty pretty . unpack ------------------------------------------------------------------------------- -- TestedWith ------------------------------------------------------------------------------- -- | Version range or just version -newtype TestedWith = TestedWith { getTestedWith :: (CompilerFlavor, VersionRange) } +newtype TestedWith = TestedWith {getTestedWith :: (CompilerFlavor, VersionRange)} instance Newtype (CompilerFlavor, VersionRange) TestedWith instance Parsec TestedWith where - parsec = pack <$> parsecTestedWith + parsec = pack <$> parsecTestedWith instance Pretty TestedWith where - pretty x = case unpack x of - (compiler, vr) -> pretty compiler <+> pretty vr + pretty x = case unpack x of + (compiler, vr) -> pretty compiler <+> pretty vr parsecTestedWith :: CabalParsing m => m (CompilerFlavor, VersionRange) parsecTestedWith = do - name <- lexemeParsec - ver <- parsec <|> pure anyVersion - return (name, ver) + name <- lexemeParsec + ver <- parsec <|> pure anyVersion + return (name, ver) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index 77a94456acf..4721aa4ad08 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + -- | This module provides a 'FieldGrammarParser', one way to parse -- @.cabal@ -like files. -- @@ -50,34 +51,34 @@ -- We can parse 'Fields' like we parse @aeson@ objects, yet we use -- slightly higher-level API, so we can process unspecified fields, -- to report unknown fields and save custom @x-fields@. --- -module Distribution.FieldGrammar.Parsec ( - ParsecFieldGrammar, - parseFieldGrammar, - fieldGrammarKnownFieldList, +module Distribution.FieldGrammar.Parsec + ( ParsecFieldGrammar + , parseFieldGrammar + , fieldGrammarKnownFieldList + -- * Auxiliary - Fields, - NamelessField (..), - namelessFieldAnn, - Section (..), - runFieldParser, - runFieldParser', - fieldLinesToStream, - ) where + , Fields + , NamelessField (..) + , namelessFieldAnn + , Section (..) + , runFieldParser + , runFieldParser' + , fieldLinesToStream + ) where import Distribution.Compat.Newtype import Distribution.Compat.Prelude -import Distribution.Utils.Generic (fromUTF8BS) +import Distribution.Utils.Generic (fromUTF8BS) import Distribution.Utils.String (trim) import Prelude () -import qualified Data.ByteString as BS -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set +import qualified Data.ByteString as BS +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set import qualified Distribution.Utils.ShortText as ShortText -import qualified Text.Parsec as P -import qualified Text.Parsec.Error as P +import qualified Text.Parsec as P +import qualified Text.Parsec.Error as P import Distribution.CabalSpecVersion import Distribution.FieldGrammar.Class @@ -85,7 +86,7 @@ import Distribution.Fields.Field import Distribution.Fields.ParseResult import Distribution.Parsec import Distribution.Parsec.FieldLineStream -import Distribution.Parsec.Position (positionCol, positionRow) +import Distribution.Parsec.Position (positionCol, positionRow) ------------------------------------------------------------------------------- -- Auxiliary types @@ -109,238 +110,240 @@ data Section ann = MkSection !(Name ann) [SectionArg ann] [Field ann] ------------------------------------------------------------------------------- data ParsecFieldGrammar s a = ParsecFG - { fieldGrammarKnownFields :: !(Set FieldName) - , fieldGrammarKnownPrefixes :: !(Set FieldName) - , fieldGrammarParser :: !(CabalSpecVersion -> Fields Position -> ParseResult a) - } + { fieldGrammarKnownFields :: !(Set FieldName) + , fieldGrammarKnownPrefixes :: !(Set FieldName) + , fieldGrammarParser :: !(CabalSpecVersion -> Fields Position -> ParseResult a) + } deriving (Functor) parseFieldGrammar :: CabalSpecVersion -> Fields Position -> ParsecFieldGrammar s a -> ParseResult a parseFieldGrammar v fields grammar = do - for_ (Map.toList (Map.filterWithKey isUnknownField fields)) $ \(name, nfields) -> - for_ nfields $ \(MkNamelessField pos _) -> - parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name - -- TODO: fields allowed in this section - - -- parse - fieldGrammarParser grammar v fields + for_ (Map.toList (Map.filterWithKey isUnknownField fields)) $ \(name, nfields) -> + for_ nfields $ \(MkNamelessField pos _) -> + parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name + -- TODO: fields allowed in this section + -- parse + fieldGrammarParser grammar v fields where - isUnknownField k _ = not $ + isUnknownField k _ = + not $ k `Set.member` fieldGrammarKnownFields grammar - || any (`BS.isPrefixOf` k) (fieldGrammarKnownPrefixes grammar) + || any (`BS.isPrefixOf` k) (fieldGrammarKnownPrefixes grammar) fieldGrammarKnownFieldList :: ParsecFieldGrammar s a -> [FieldName] fieldGrammarKnownFieldList = Set.toList . fieldGrammarKnownFields instance Applicative (ParsecFieldGrammar s) where - pure x = ParsecFG mempty mempty (\_ _ -> pure x) - {-# INLINE pure #-} + pure x = ParsecFG mempty mempty (\_ _ -> pure x) + {-# INLINE pure #-} - ParsecFG f f' f'' <*> ParsecFG x x' x'' = ParsecFG - (mappend f x) - (mappend f' x') - (\v fields -> f'' v fields <*> x'' v fields) - {-# INLINE (<*>) #-} + ParsecFG f f' f'' <*> ParsecFG x x' x'' = + ParsecFG + (mappend f x) + (mappend f' x') + (\v fields -> f'' v fields <*> x'' v fields) + {-# INLINE (<*>) #-} warnMultipleSingularFields :: FieldName -> [NamelessField Position] -> ParseResult () warnMultipleSingularFields _ [] = pure () warnMultipleSingularFields fn (x : xs) = do - let pos = namelessFieldAnn x - poss = map namelessFieldAnn xs - parseWarning pos PWTMultipleSingularField $ - "The field " <> show fn <> " is specified more than once at positions " ++ intercalate ", " (map showPos (pos : poss)) + let pos = namelessFieldAnn x + poss = map namelessFieldAnn xs + parseWarning pos PWTMultipleSingularField $ + "The field " <> show fn <> " is specified more than once at positions " ++ intercalate ", " (map showPos (pos : poss)) instance FieldGrammar Parsec ParsecFieldGrammar where - blurFieldGrammar _ (ParsecFG s s' parser) = ParsecFG s s' parser - - uniqueFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser - where - parser v fields = case Map.lookup fn fields of - Nothing -> parseFatalFailure zeroPos $ show fn ++ " field missing" - Just [] -> parseFatalFailure zeroPos $ show fn ++ " field missing" - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) = - unpack' _pack <$> runFieldParser pos parsec v fls - - booleanFieldDef fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser - where - parser v fields = case Map.lookup fn fields of - Nothing -> pure def - Just [] -> pure def - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls - - optionalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser - where - parser v fields = case Map.lookup fn fields of - Nothing -> pure Nothing - Just [] -> pure Nothing - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) - | null fls = pure Nothing - | otherwise = Just . unpack' _pack <$> runFieldParser pos parsec v fls - - optionalFieldDefAla fn _pack _extract def = ParsecFG (Set.singleton fn) Set.empty parser - where - parser v fields = case Map.lookup fn fields of - Nothing -> pure def - Just [] -> pure def - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) - | null fls = pure def - | otherwise = unpack' _pack <$> runFieldParser pos parsec v fls - - freeTextField fn _ = ParsecFG (Set.singleton fn) Set.empty parser where - parser v fields = case Map.lookup fn fields of - Nothing -> pure Nothing - Just [] -> pure Nothing - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) - | null fls = pure Nothing - | v >= CabalSpecV3_0 = pure (Just (fieldlinesToFreeText3 pos fls)) - | otherwise = pure (Just (fieldlinesToFreeText fls)) - - freeTextFieldDef fn _ = ParsecFG (Set.singleton fn) Set.empty parser where - parser v fields = case Map.lookup fn fields of - Nothing -> pure "" - Just [] -> pure "" - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) - | null fls = pure "" - | v >= CabalSpecV3_0 = pure (fieldlinesToFreeText3 pos fls) - | otherwise = pure (fieldlinesToFreeText fls) - - -- freeTextFieldDefST = defaultFreeTextFieldDefST - freeTextFieldDefST fn _ = ParsecFG (Set.singleton fn) Set.empty parser where - parser v fields = case Map.lookup fn fields of - Nothing -> pure mempty - Just [] -> pure mempty - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) = case fls of - [] -> pure mempty - [FieldLine _ bs] -> pure (ShortText.unsafeFromUTF8BS bs) - _ | v >= CabalSpecV3_0 -> pure (ShortText.toShortText $ fieldlinesToFreeText3 pos fls) - | otherwise -> pure (ShortText.toShortText $ fieldlinesToFreeText fls) - - monoidalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser - where - parser v fields = case Map.lookup fn fields of - Nothing -> pure mempty - Just xs -> foldMap (unpack' _pack) <$> traverse (parseOne v) xs - - parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls - - prefixedFields fnPfx _extract = ParsecFG mempty (Set.singleton fnPfx) (\_ fs -> pure (parser fs)) - where - parser :: Fields Position -> [(String, String)] - parser values = reorder $ concatMap convert $ filter match $ Map.toList values - - match (fn, _) = fnPfx `BS.isPrefixOf` fn - convert (fn, fields) = - [ (pos, (fromUTF8BS fn, trim $ fromUTF8BS $ fieldlinesToBS fls)) - | MkNamelessField pos fls <- fields - ] - -- hack: recover the order of prefixed fields - reorder = map snd . sortBy (comparing fst) - - availableSince vs def (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' - where - parser' v values - | v >= vs = parser v values - | otherwise = do - let unknownFields = Map.intersection values $ Map.fromSet (const ()) names - for_ (Map.toList unknownFields) $ \(name, fields) -> - for_ fields $ \(MkNamelessField pos _) -> - parseWarning pos PWTUnknownField $ - "The field " <> show name <> " is available only since the Cabal specification version " ++ showCabalSpecVersion vs ++ ". This field will be ignored." - - pure def - - availableSinceWarn vs (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' - where - parser' v values - | v >= vs = parser v values - | otherwise = do - let unknownFields = Map.intersection values $ Map.fromSet (const ()) names - for_ (Map.toList unknownFields) $ \(name, fields) -> - for_ fields $ \(MkNamelessField pos _) -> - parseWarning pos PWTUnknownField $ - "The field " <> show name <> " is available only since the Cabal specification version " ++ showCabalSpecVersion vs ++ "." - - parser v values - - - -- todo we know about this field - deprecatedSince vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' - where - parser' v values - | v >= vs = do - let deprecatedFields = Map.intersection values $ Map.fromSet (const ()) names - for_ (Map.toList deprecatedFields) $ \(name, fields) -> - for_ fields $ \(MkNamelessField pos _) -> - parseWarning pos PWTDeprecatedField $ - "The field " <> show name <> " is deprecated in the Cabal specification version " ++ showCabalSpecVersion vs ++ ". " ++ msg - - parser v values - - | otherwise = parser v values - - removedIn vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' where - parser' v values - | v >= vs = do - let msg' = if null msg then "" else ' ' : msg - let unknownFields = Map.intersection values $ Map.fromSet (const ()) names - let namePos = - [ (name, pos) - | (name, fields) <- Map.toList unknownFields - , MkNamelessField pos _ <- fields - ] - - let makeMsg name = "The field " <> show name <> " is removed in the Cabal specification version " ++ showCabalSpecVersion vs ++ "." ++ msg' - - case namePos of - -- no fields => proceed (with empty values, to be sure) - [] -> parser v mempty - - -- if there's single field: fail fatally with it - ((name, pos) : rest) -> do - for_ rest $ \(name', pos') -> parseFailure pos' $ makeMsg name' - parseFatalFailure pos $ makeMsg name - - | otherwise = parser v values - - knownField fn = ParsecFG (Set.singleton fn) Set.empty (\_ _ -> pure ()) - - hiddenField = id + blurFieldGrammar _ (ParsecFG s s' parser) = ParsecFG s s' parser + + uniqueFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser + where + parser v fields = case Map.lookup fn fields of + Nothing -> parseFatalFailure zeroPos $ show fn ++ " field missing" + Just [] -> parseFatalFailure zeroPos $ show fn ++ " field missing" + Just [x] -> parseOne v x + Just xs@(_ : y : ys) -> do + warnMultipleSingularFields fn xs + NE.last <$> traverse (parseOne v) (y :| ys) + + parseOne v (MkNamelessField pos fls) = + unpack' _pack <$> runFieldParser pos parsec v fls + + booleanFieldDef fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser + where + parser v fields = case Map.lookup fn fields of + Nothing -> pure def + Just [] -> pure def + Just [x] -> parseOne v x + Just xs@(_ : y : ys) -> do + warnMultipleSingularFields fn xs + NE.last <$> traverse (parseOne v) (y :| ys) + + parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls + + optionalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser + where + parser v fields = case Map.lookup fn fields of + Nothing -> pure Nothing + Just [] -> pure Nothing + Just [x] -> parseOne v x + Just xs@(_ : y : ys) -> do + warnMultipleSingularFields fn xs + NE.last <$> traverse (parseOne v) (y :| ys) + + parseOne v (MkNamelessField pos fls) + | null fls = pure Nothing + | otherwise = Just . unpack' _pack <$> runFieldParser pos parsec v fls + + optionalFieldDefAla fn _pack _extract def = ParsecFG (Set.singleton fn) Set.empty parser + where + parser v fields = case Map.lookup fn fields of + Nothing -> pure def + Just [] -> pure def + Just [x] -> parseOne v x + Just xs@(_ : y : ys) -> do + warnMultipleSingularFields fn xs + NE.last <$> traverse (parseOne v) (y :| ys) + + parseOne v (MkNamelessField pos fls) + | null fls = pure def + | otherwise = unpack' _pack <$> runFieldParser pos parsec v fls + + freeTextField fn _ = ParsecFG (Set.singleton fn) Set.empty parser + where + parser v fields = case Map.lookup fn fields of + Nothing -> pure Nothing + Just [] -> pure Nothing + Just [x] -> parseOne v x + Just xs@(_ : y : ys) -> do + warnMultipleSingularFields fn xs + NE.last <$> traverse (parseOne v) (y :| ys) + + parseOne v (MkNamelessField pos fls) + | null fls = pure Nothing + | v >= CabalSpecV3_0 = pure (Just (fieldlinesToFreeText3 pos fls)) + | otherwise = pure (Just (fieldlinesToFreeText fls)) + + freeTextFieldDef fn _ = ParsecFG (Set.singleton fn) Set.empty parser + where + parser v fields = case Map.lookup fn fields of + Nothing -> pure "" + Just [] -> pure "" + Just [x] -> parseOne v x + Just xs@(_ : y : ys) -> do + warnMultipleSingularFields fn xs + NE.last <$> traverse (parseOne v) (y :| ys) + + parseOne v (MkNamelessField pos fls) + | null fls = pure "" + | v >= CabalSpecV3_0 = pure (fieldlinesToFreeText3 pos fls) + | otherwise = pure (fieldlinesToFreeText fls) + + -- freeTextFieldDefST = defaultFreeTextFieldDefST + freeTextFieldDefST fn _ = ParsecFG (Set.singleton fn) Set.empty parser + where + parser v fields = case Map.lookup fn fields of + Nothing -> pure mempty + Just [] -> pure mempty + Just [x] -> parseOne v x + Just xs@(_ : y : ys) -> do + warnMultipleSingularFields fn xs + NE.last <$> traverse (parseOne v) (y :| ys) + + parseOne v (MkNamelessField pos fls) = case fls of + [] -> pure mempty + [FieldLine _ bs] -> pure (ShortText.unsafeFromUTF8BS bs) + _ + | v >= CabalSpecV3_0 -> pure (ShortText.toShortText $ fieldlinesToFreeText3 pos fls) + | otherwise -> pure (ShortText.toShortText $ fieldlinesToFreeText fls) + + monoidalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser + where + parser v fields = case Map.lookup fn fields of + Nothing -> pure mempty + Just xs -> foldMap (unpack' _pack) <$> traverse (parseOne v) xs + + parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls + + prefixedFields fnPfx _extract = ParsecFG mempty (Set.singleton fnPfx) (\_ fs -> pure (parser fs)) + where + parser :: Fields Position -> [(String, String)] + parser values = reorder $ concatMap convert $ filter match $ Map.toList values + + match (fn, _) = fnPfx `BS.isPrefixOf` fn + convert (fn, fields) = + [ (pos, (fromUTF8BS fn, trim $ fromUTF8BS $ fieldlinesToBS fls)) + | MkNamelessField pos fls <- fields + ] + -- hack: recover the order of prefixed fields + reorder = map snd . sortBy (comparing fst) + + availableSince vs def (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' + where + parser' v values + | v >= vs = parser v values + | otherwise = do + let unknownFields = Map.intersection values $ Map.fromSet (const ()) names + for_ (Map.toList unknownFields) $ \(name, fields) -> + for_ fields $ \(MkNamelessField pos _) -> + parseWarning pos PWTUnknownField $ + "The field " <> show name <> " is available only since the Cabal specification version " ++ showCabalSpecVersion vs ++ ". This field will be ignored." + + pure def + + availableSinceWarn vs (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' + where + parser' v values + | v >= vs = parser v values + | otherwise = do + let unknownFields = Map.intersection values $ Map.fromSet (const ()) names + for_ (Map.toList unknownFields) $ \(name, fields) -> + for_ fields $ \(MkNamelessField pos _) -> + parseWarning pos PWTUnknownField $ + "The field " <> show name <> " is available only since the Cabal specification version " ++ showCabalSpecVersion vs ++ "." + + parser v values + + -- todo we know about this field + deprecatedSince vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' + where + parser' v values + | v >= vs = do + let deprecatedFields = Map.intersection values $ Map.fromSet (const ()) names + for_ (Map.toList deprecatedFields) $ \(name, fields) -> + for_ fields $ \(MkNamelessField pos _) -> + parseWarning pos PWTDeprecatedField $ + "The field " <> show name <> " is deprecated in the Cabal specification version " ++ showCabalSpecVersion vs ++ ". " ++ msg + + parser v values + | otherwise = parser v values + + removedIn vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' + where + parser' v values + | v >= vs = do + let msg' = if null msg then "" else ' ' : msg + let unknownFields = Map.intersection values $ Map.fromSet (const ()) names + let namePos = + [ (name, pos) + | (name, fields) <- Map.toList unknownFields + , MkNamelessField pos _ <- fields + ] + + let makeMsg name = "The field " <> show name <> " is removed in the Cabal specification version " ++ showCabalSpecVersion vs ++ "." ++ msg' + + case namePos of + -- no fields => proceed (with empty values, to be sure) + [] -> parser v mempty + -- if there's single field: fail fatally with it + ((name, pos) : rest) -> do + for_ rest $ \(name', pos') -> parseFailure pos' $ makeMsg name' + parseFatalFailure pos $ makeMsg name + | otherwise = parser v values + + knownField fn = ParsecFG (Set.singleton fn) Set.empty (\_ _ -> pure ()) + + hiddenField = id ------------------------------------------------------------------------------- -- Parsec @@ -348,26 +351,32 @@ instance FieldGrammar Parsec ParsecFieldGrammar where runFieldParser' :: [Position] -> ParsecParser a -> CabalSpecVersion -> FieldLineStream -> ParseResult a runFieldParser' inputPoss p v str = case P.runParser p' [] "" str of - Right (pok, ws) -> do - traverse_ (\(PWarning t pos w) -> parseWarning (mapPosition pos) t w) ws - pure pok - Left err -> do - let ppos = P.errorPos err - let epos = mapPosition $ Position (P.sourceLine ppos) (P.sourceColumn ppos) - - let msg = P.showErrorMessages - "or" "unknown parse error" "expecting" "unexpected" "end of input" - (P.errorMessages err) - parseFatalFailure epos $ msg ++ "\n" + Right (pok, ws) -> do + traverse_ (\(PWarning t pos w) -> parseWarning (mapPosition pos) t w) ws + pure pok + Left err -> do + let ppos = P.errorPos err + let epos = mapPosition $ Position (P.sourceLine ppos) (P.sourceColumn ppos) + + let msg = + P.showErrorMessages + "or" + "unknown parse error" + "expecting" + "unexpected" + "end of input" + (P.errorMessages err) + parseFatalFailure epos $ msg ++ "\n" where p' = (,) <$ P.spaces <*> unPP p v <* P.spaces <* P.eof <*> P.getState -- Positions start from 1:1, not 0:0 - mapPosition (Position prow pcol) = go (prow - 1) inputPoss where - go _ [] = zeroPos - go _ [Position row col] = Position row (col + pcol - 1) - go n (Position row col:_) | n <= 0 = Position row (col + pcol - 1) - go n (_:ps) = go (n - 1) ps + mapPosition (Position prow pcol) = go (prow - 1) inputPoss + where + go _ [] = zeroPos + go _ [Position row col] = Position row (col + pcol - 1) + go n (Position row col : _) | n <= 0 = Position row (col + pcol - 1) + go n (_ : ps) = go (n - 1) ps runFieldParser :: Position -> ParsecParser a -> CabalSpecVersion -> [FieldLine Position] -> ParseResult a runFieldParser pp p v ls = runFieldParser' poss p v (fieldLinesToStream ls) @@ -381,54 +390,55 @@ fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs) -- http://hackage.haskell.org/package/copilot-cbmc-0.1/copilot-cbmc.cabal fieldlinesToFreeText :: [FieldLine ann] -> String fieldlinesToFreeText [FieldLine _ "."] = "." -fieldlinesToFreeText fls = intercalate "\n" (map go fls) +fieldlinesToFreeText fls = intercalate "\n" (map go fls) where go (FieldLine _ bs) - | s == "." = "" - | otherwise = s + | s == "." = "" + | otherwise = s where s = trim (fromUTF8BS bs) fieldlinesToFreeText3 :: Position -> [FieldLine Position] -> String -fieldlinesToFreeText3 _ [] = "" -fieldlinesToFreeText3 _ [FieldLine _ bs] = fromUTF8BS bs +fieldlinesToFreeText3 _ [] = "" +fieldlinesToFreeText3 _ [FieldLine _ bs] = fromUTF8BS bs fieldlinesToFreeText3 pos (FieldLine pos1 bs1 : fls2@(FieldLine pos2 _ : _)) - -- if first line is on the same line with field name: - -- the indentation level is either - -- 1. the indentation of left most line in rest fields - -- 2. the indentation of the first line - -- whichever is leftmost - | positionRow pos == positionRow pos1 = concat - $ fromUTF8BS bs1 - : mealy (mk mcol1) pos1 fls2 - - -- otherwise, also indent the first line - | otherwise = concat - $ replicate (positionCol pos1 - mcol2) ' ' - : fromUTF8BS bs1 - : mealy (mk mcol2) pos1 fls2 - + -- if first line is on the same line with field name: + -- the indentation level is either + -- 1. the indentation of left most line in rest fields + -- 2. the indentation of the first line + -- whichever is leftmost + | positionRow pos == positionRow pos1 = + concat $ + fromUTF8BS bs1 + : mealy (mk mcol1) pos1 fls2 + -- otherwise, also indent the first line + | otherwise = + concat $ + replicate (positionCol pos1 - mcol2) ' ' + : fromUTF8BS bs1 + : mealy (mk mcol2) pos1 fls2 where mcol1 = foldl' (\a b -> min a $ positionCol $ fieldLineAnn b) (min (positionCol pos1) (positionCol pos2)) fls2 mcol2 = foldl' (\a b -> min a $ positionCol $ fieldLineAnn b) (positionCol pos1) fls2 mk :: Int -> Position -> FieldLine Position -> (Position, String) mk col p (FieldLine q bs) = - ( q - , replicate newlines '\n' + ( q + , replicate newlines '\n' ++ replicate indent ' ' ++ fromUTF8BS bs - ) + ) where newlines = positionRow q - positionRow p - indent = positionCol q - col + indent = positionCol q - col mealy :: (s -> a -> (s, b)) -> s -> [a] -> [b] -mealy f = go where +mealy f = go + where go _ [] = [] go s (x : xs) = let ~(s', y) = f s x in y : go s' xs fieldLinesToStream :: [FieldLine ann] -> FieldLineStream -fieldLinesToStream [] = fieldLineStreamEnd -fieldLinesToStream [FieldLine _ bs] = FLSLast bs +fieldLinesToStream [] = fieldLineStreamEnd +fieldLinesToStream [FieldLine _ bs] = FLSLast bs fieldLinesToStream (FieldLine _ bs : fs) = FLSCons bs (fieldLinesToStream fs) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs index fdd236b0e9e..a35d8f361f4 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -1,32 +1,33 @@ -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MultiParamTypeClasses #-} -module Distribution.FieldGrammar.Pretty ( - PrettyFieldGrammar, - prettyFieldGrammar, - ) where - -import Distribution.CabalSpecVersion -import Distribution.Compat.Lens -import Distribution.Compat.Newtype -import Distribution.Compat.Prelude -import Distribution.Fields.Field (FieldName) -import Distribution.Fields.Pretty (PrettyField (..)) -import Distribution.Pretty (Pretty (..), showFreeText, showFreeTextV3) -import Distribution.Utils.Generic (toUTF8BS) -import Prelude () -import Text.PrettyPrint (Doc) -import qualified Text.PrettyPrint as PP + +module Distribution.FieldGrammar.Pretty + ( PrettyFieldGrammar + , prettyFieldGrammar + ) where + +import Distribution.CabalSpecVersion +import Distribution.Compat.Lens +import Distribution.Compat.Newtype +import Distribution.Compat.Prelude +import Distribution.Fields.Field (FieldName) +import Distribution.Fields.Pretty (PrettyField (..)) +import Distribution.Pretty (Pretty (..), showFreeText, showFreeTextV3) +import Distribution.Utils.Generic (toUTF8BS) +import Text.PrettyPrint (Doc) +import qualified Text.PrettyPrint as PP +import Prelude () import Distribution.FieldGrammar.Class newtype PrettyFieldGrammar s a = PrettyFG - { fieldGrammarPretty :: CabalSpecVersion -> s -> [PrettyField ()] - } + { fieldGrammarPretty :: CabalSpecVersion -> s -> [PrettyField ()] + } deriving (Functor) instance Applicative (PrettyFieldGrammar s) where - pure _ = PrettyFG (\_ _ -> mempty) - PrettyFG f <*> PrettyFG x = PrettyFG (\v s -> f v s <> x v s) + pure _ = PrettyFG (\_ _ -> mempty) + PrettyFG f <*> PrettyFG x = PrettyFG (\v s -> f v s <> x v s) -- | We can use 'PrettyFieldGrammar' to pp print the @s@. -- @@ -35,70 +36,77 @@ prettyFieldGrammar :: CabalSpecVersion -> PrettyFieldGrammar s a -> s -> [Pretty prettyFieldGrammar = flip fieldGrammarPretty instance FieldGrammar Pretty PrettyFieldGrammar where - blurFieldGrammar f (PrettyFG pp) = PrettyFG (\v -> pp v . aview f) - - uniqueFieldAla fn _pack l = PrettyFG $ \_v s -> - ppField fn (pretty (pack' _pack (aview l s))) - - booleanFieldDef fn l def = PrettyFG pp - where - pp _v s - | b == def = mempty - | otherwise = ppField fn (PP.text (show b)) - where - b = aview l s - - optionalFieldAla fn _pack l = PrettyFG pp - where - pp v s = case aview l s of - Nothing -> mempty - Just a -> ppField fn (prettyVersioned v (pack' _pack a)) - - optionalFieldDefAla fn _pack l def = PrettyFG pp - where - pp v s - | x == def = mempty - | otherwise = ppField fn (prettyVersioned v (pack' _pack x)) - where - x = aview l s - - freeTextField fn l = PrettyFG pp where - pp v s = maybe mempty (ppField fn . showFT) (aview l s) where - showFT | v >= CabalSpecV3_0 = showFreeTextV3 - | otherwise = showFreeText - - -- it's ok to just show, as showFreeText of empty string is empty. - freeTextFieldDef fn l = PrettyFG pp where - pp v s = ppField fn (showFT (aview l s)) where - showFT | v >= CabalSpecV3_0 = showFreeTextV3 - | otherwise = showFreeText - - freeTextFieldDefST = defaultFreeTextFieldDefST - - monoidalFieldAla fn _pack l = PrettyFG pp - where - pp v s = ppField fn (prettyVersioned v (pack' _pack (aview l s))) - - prefixedFields _fnPfx l = PrettyFG (\_ -> pp . aview l) - where - pp xs = - -- always print the field, even its Doc is empty. - -- i.e. don't use ppField - [ PrettyField () (toUTF8BS n) $ PP.vcat $ map PP.text $ lines s - | (n, s) <- xs - -- fnPfx `isPrefixOf` n - ] - - knownField _ = pure () - deprecatedSince _ _ x = x - -- TODO: as PrettyFieldGrammar isn't aware of cabal-version: we output the field - -- this doesn't affect roundtrip as `removedIn` fields cannot be parsed - -- so invalid documents can be only manually constructed. - removedIn _ _ x = x - availableSince _ _ = id - hiddenField _ = PrettyFG (\_ -> mempty) + blurFieldGrammar f (PrettyFG pp) = PrettyFG (\v -> pp v . aview f) + + uniqueFieldAla fn _pack l = PrettyFG $ \_v s -> + ppField fn (pretty (pack' _pack (aview l s))) + + booleanFieldDef fn l def = PrettyFG pp + where + pp _v s + | b == def = mempty + | otherwise = ppField fn (PP.text (show b)) + where + b = aview l s + + optionalFieldAla fn _pack l = PrettyFG pp + where + pp v s = case aview l s of + Nothing -> mempty + Just a -> ppField fn (prettyVersioned v (pack' _pack a)) + + optionalFieldDefAla fn _pack l def = PrettyFG pp + where + pp v s + | x == def = mempty + | otherwise = ppField fn (prettyVersioned v (pack' _pack x)) + where + x = aview l s + + freeTextField fn l = PrettyFG pp + where + pp v s = maybe mempty (ppField fn . showFT) (aview l s) + where + showFT + | v >= CabalSpecV3_0 = showFreeTextV3 + | otherwise = showFreeText + + -- it's ok to just show, as showFreeText of empty string is empty. + freeTextFieldDef fn l = PrettyFG pp + where + pp v s = ppField fn (showFT (aview l s)) + where + showFT + | v >= CabalSpecV3_0 = showFreeTextV3 + | otherwise = showFreeText + + freeTextFieldDefST = defaultFreeTextFieldDefST + + monoidalFieldAla fn _pack l = PrettyFG pp + where + pp v s = ppField fn (prettyVersioned v (pack' _pack (aview l s))) + + prefixedFields _fnPfx l = PrettyFG (\_ -> pp . aview l) + where + pp xs = + -- always print the field, even its Doc is empty. + -- i.e. don't use ppField + [ PrettyField () (toUTF8BS n) $ PP.vcat $ map PP.text $ lines s + | (n, s) <- xs + -- fnPfx `isPrefixOf` n + ] + + knownField _ = pure () + deprecatedSince _ _ x = x + + -- TODO: as PrettyFieldGrammar isn't aware of cabal-version: we output the field + -- this doesn't affect roundtrip as `removedIn` fields cannot be parsed + -- so invalid documents can be only manually constructed. + removedIn _ _ x = x + availableSince _ _ = id + hiddenField _ = PrettyFG (\_ -> mempty) ppField :: FieldName -> Doc -> [PrettyField ()] ppField name fielddoc - | PP.isEmpty fielddoc = [] - | otherwise = [ PrettyField () name fielddoc ] + | PP.isEmpty fielddoc = [] + | otherwise = [PrettyField () name fielddoc] diff --git a/Cabal-syntax/src/Distribution/Fields.hs b/Cabal-syntax/src/Distribution/Fields.hs index 18b0aa6d92c..4688bf547d9 100644 --- a/Cabal-syntax/src/Distribution/Fields.hs +++ b/Cabal-syntax/src/Distribution/Fields.hs @@ -1,42 +1,49 @@ -- | Utilities to work with @.cabal@ like file structure. -module Distribution.Fields ( - -- * Types - Field(..), - Name(..), - FieldLine(..), - SectionArg(..), - FieldName, +module Distribution.Fields + ( -- * Types + Field (..) + , Name (..) + , FieldLine (..) + , SectionArg (..) + , FieldName + -- * Grammar and parsing - -- - -- See "Distribution.Fields.Parser" for grammar. - readFields, - readFields', + + -- + -- See "Distribution.Fields.Parser" for grammar. + , readFields + , readFields' + -- ** ParseResult - ParseResult, - runParseResult, - parseWarning, - parseWarnings, - parseFailure, - parseFatalFailure, + , ParseResult + , runParseResult + , parseWarning + , parseWarnings + , parseFailure + , parseFatalFailure + -- ** Warnings - PWarnType (..), - PWarning (..), - showPWarning, + , PWarnType (..) + , PWarning (..) + , showPWarning + -- ** Errors - PError (..), - showPError, + , PError (..) + , showPError + -- * Pretty printing - CommentPosition (..), - PrettyField (..), - showFields, + , CommentPosition (..) + , PrettyField (..) + , showFields + -- ** Transformation from Field - genericFromParsecFields, - fromParsecFields, - ) where + , genericFromParsecFields + , fromParsecFields + ) where import Distribution.Fields.Field -import Distribution.Fields.Parser import Distribution.Fields.ParseResult +import Distribution.Fields.Parser import Distribution.Fields.Pretty import Distribution.Parsec.Error import Distribution.Parsec.Warning diff --git a/Cabal-syntax/src/Distribution/Fields/ConfVar.hs b/Cabal-syntax/src/Distribution/Fields/ConfVar.hs index b045c3ef172..760e2335143 100644 --- a/Cabal-syntax/src/Distribution/Fields/ConfVar.hs +++ b/Cabal-syntax/src/Distribution/Fields/ConfVar.hs @@ -1,47 +1,64 @@ {-# LANGUAGE OverloadedStrings #-} + module Distribution.Fields.ConfVar (parseConditionConfVar, parseConditionConfVarFromClause) where -import Distribution.Compat.CharParsing (char, integral) +import Distribution.Compat.CharParsing (char, integral) import Distribution.Compat.Prelude -import Distribution.Fields.Field (SectionArg (..), Field(..)) +import Distribution.Fields.Field (Field (..), SectionArg (..)) import Distribution.Fields.ParseResult -import Distribution.Parsec (Parsec (..), Position (..), runParsecParser) +import Distribution.Fields.Parser (readFields) +import Distribution.Parsec (Parsec (..), Position (..), runParsecParser) import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS) import Distribution.Types.Condition -import Distribution.Types.ConfVar (ConfVar (..)) -import Distribution.Fields.Parser (readFields) +import Distribution.Types.ConfVar (ConfVar (..)) import Distribution.Version - (anyVersion, earlierVersion, intersectVersionRanges, laterVersion, majorBoundVersion, - mkVersion, noVersion, orEarlierVersion, orLaterVersion, thisVersion, unionVersionRanges, - withinVersion) + ( anyVersion + , earlierVersion + , intersectVersionRanges + , laterVersion + , majorBoundVersion + , mkVersion + , noVersion + , orEarlierVersion + , orLaterVersion + , thisVersion + , unionVersionRanges + , withinVersion + ) import Prelude () -import qualified Text.Parsec as P -import qualified Text.Parsec.Pos as P +import qualified Data.ByteString.Char8 as B8 +import qualified Text.Parsec as P import qualified Text.Parsec.Error as P -import qualified Data.ByteString.Char8 as B8 +import qualified Text.Parsec.Pos as P parseConditionConfVarFromClause :: B8.ByteString -> Either P.ParseError (Condition ConfVar) -parseConditionConfVarFromClause x = readFields x >>= \r -> case r of - (Section _ xs _ : _ ) -> P.runParser (parser <* P.eof) () "" xs - _ -> Left $ P.newErrorMessage (P.Message "No fields in clause") (P.initialPos "") +parseConditionConfVarFromClause x = + readFields x >>= \r -> case r of + (Section _ xs _ : _) -> P.runParser (parser <* P.eof) () "" xs + _ -> Left $ P.newErrorMessage (P.Message "No fields in clause") (P.initialPos "") -- | Parse @'Condition' 'ConfVar'@ from section arguments provided by parsec -- based outline parser. parseConditionConfVar :: [SectionArg Position] -> ParseResult (Condition ConfVar) parseConditionConfVar args = - -- The name of the input file is irrelevant, as we reformat the error message. - case P.runParser (parser <* P.eof) () "" args of - Right x -> pure x - Left err -> do - -- Mangle the position to the actual one - let ppos = P.errorPos err - let epos = Position (P.sourceLine ppos) (P.sourceColumn ppos) - let msg = P.showErrorMessages - "or" "unknown parse error" "expecting" "unexpected" "end of input" - (P.errorMessages err) - parseFailure epos msg - pure $ Lit True + -- The name of the input file is irrelevant, as we reformat the error message. + case P.runParser (parser <* P.eof) () "" args of + Right x -> pure x + Left err -> do + -- Mangle the position to the actual one + let ppos = P.errorPos err + let epos = Position (P.sourceLine ppos) (P.sourceColumn ppos) + let msg = + P.showErrorMessages + "or" + "unknown parse error" + "expecting" + "unexpected" + "end of input" + (P.errorMessages err) + parseFailure epos msg + pure $ Lit True type Parser = P.Parsec [SectionArg Position] () @@ -51,72 +68,77 @@ sepByNonEmpty p sep = (:|) <$> p <*> many (sep *> p) parser :: Parser (Condition ConfVar) parser = condOr where - condOr = sepByNonEmpty condAnd (oper "||") >>= return . foldl1 COr - condAnd = sepByNonEmpty cond (oper "&&") >>= return . foldl1 CAnd - cond = P.choice - [ boolLiteral, parens condOr, notCond, osCond, archCond, flagCond, implCond ] - - notCond = CNot <$ oper "!" <*> cond - - boolLiteral = Lit <$> boolLiteral' - osCond = Var . OS <$ string "os" <*> parens fromParsec - flagCond = Var . PackageFlag <$ string "flag" <*> parens fromParsec - archCond = Var . Arch <$ string "arch" <*> parens fromParsec - implCond = Var <$ string "impl" <*> parens implCond' - - implCond' = Impl + condOr = sepByNonEmpty condAnd (oper "||") >>= return . foldl1 COr + condAnd = sepByNonEmpty cond (oper "&&") >>= return . foldl1 CAnd + cond = + P.choice + [boolLiteral, parens condOr, notCond, osCond, archCond, flagCond, implCond] + + notCond = CNot <$ oper "!" <*> cond + + boolLiteral = Lit <$> boolLiteral' + osCond = Var . OS <$ string "os" <*> parens fromParsec + flagCond = Var . PackageFlag <$ string "flag" <*> parens fromParsec + archCond = Var . Arch <$ string "arch" <*> parens fromParsec + implCond = Var <$ string "impl" <*> parens implCond' + + implCond' = + Impl <$> fromParsec <*> P.option anyVersion versionRange version = fromParsec - versionStar = mkVersion <$> fromParsec' versionStar' <* oper "*" + versionStar = mkVersion <$> fromParsec' versionStar' <* oper "*" versionStar' = some (integral <* char '.') versionRange = expr where - expr = foldl1 unionVersionRanges <$> sepByNonEmpty term (oper "||") + expr = foldl1 unionVersionRanges <$> sepByNonEmpty term (oper "||") term = foldl1 intersectVersionRanges <$> sepByNonEmpty factor (oper "&&") - factor = P.choice - $ parens expr - : parseAnyVersion - : parseNoVersion - : parseWildcardRange - : map parseRangeOp rangeOps + factor = + P.choice $ + parens expr + : parseAnyVersion + : parseNoVersion + : parseWildcardRange + : map parseRangeOp rangeOps - parseAnyVersion = anyVersion <$ string "-any" - parseNoVersion = noVersion <$ string "-none" + parseAnyVersion = anyVersion <$ string "-any" + parseNoVersion = noVersion <$ string "-none" parseWildcardRange = P.try $ withinVersion <$ oper "==" <*> versionStar - parseRangeOp (s,f) = P.try (f <$ oper s <*> version) - rangeOps = [ ("<", earlierVersion), - ("<=", orEarlierVersion), - (">", laterVersion), - (">=", orLaterVersion), - ("^>=", majorBoundVersion), - ("==", thisVersion) ] + parseRangeOp (s, f) = P.try (f <$ oper s <*> version) + rangeOps = + [ ("<", earlierVersion) + , ("<=", orEarlierVersion) + , (">", laterVersion) + , (">=", orLaterVersion) + , ("^>=", majorBoundVersion) + , ("==", thisVersion) + ] -- Number token can have many dots in it: SecArgNum (Position 65 15) "7.6.1" identBS = tokenPrim $ \t -> case t of - SecArgName _ s -> Just s - _ -> Nothing + SecArgName _ s -> Just s + _ -> Nothing boolLiteral' = tokenPrim $ \t -> case t of - SecArgName _ s - | s == "True" -> Just True - | s == "true" -> Just True - | s == "False" -> Just False - | s == "false" -> Just False - _ -> Nothing + SecArgName _ s + | s == "True" -> Just True + | s == "true" -> Just True + | s == "False" -> Just False + | s == "false" -> Just False + _ -> Nothing string s = tokenPrim $ \t -> case t of - SecArgName _ s' | s == s' -> Just () - _ -> Nothing + SecArgName _ s' | s == s' -> Just () + _ -> Nothing oper o = tokenPrim $ \t -> case t of - SecArgOther _ o' | o == o' -> Just () - _ -> Nothing + SecArgOther _ o' | o == o' -> Just () + _ -> Nothing parens = P.between (oper "(") (oper ")") @@ -129,6 +151,6 @@ parser = condOr fromParsec = fromParsec' parsec fromParsec' p = do - bs <- identBS - let fls = fieldLineStreamFromBS bs - either (fail . show) pure (runParsecParser p "" fls) + bs <- identBS + let fls = fieldLineStreamFromBS bs + either (fail . show) pure (runParsecParser p "" fls) diff --git a/Cabal-syntax/src/Distribution/Fields/Field.hs b/Cabal-syntax/src/Distribution/Fields/Field.hs index 4c06342ed06..7f5b85809aa 100644 --- a/Cabal-syntax/src/Distribution/Fields/Field.hs +++ b/Cabal-syntax/src/Distribution/Fields/Field.hs @@ -1,39 +1,41 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} + -- | Cabal-like file AST types: 'Field', 'Section' etc -- -- These types are parametrized by an annotation. -module Distribution.Fields.Field ( - -- * Cabal file - Field (..), - fieldName, - fieldAnn, - fieldUniverse, - FieldLine (..), - fieldLineAnn, - fieldLineBS, - SectionArg (..), - sectionArgAnn, - -- * Name - FieldName, - Name (..), - mkName, - getName, - nameAnn, - -- * Conversions to String - sectionArgsToString, - fieldLinesToString, - ) where +module Distribution.Fields.Field + ( -- * Cabal file + Field (..) + , fieldName + , fieldAnn + , fieldUniverse + , FieldLine (..) + , fieldLineAnn + , fieldLineBS + , SectionArg (..) + , sectionArgAnn -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as B -import qualified Data.Char as Char -import Distribution.Compat.Prelude -import Distribution.Pretty (showTokenStr) -import Distribution.Utils.Generic (fromUTF8BS) -import Prelude () + -- * Name + , FieldName + , Name (..) + , mkName + , getName + , nameAnn + -- * Conversions to String + , sectionArgsToString + , fieldLinesToString + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.Char as Char +import Distribution.Compat.Prelude +import Distribution.Pretty (showTokenStr) +import Distribution.Utils.Generic (fromUTF8BS) +import Prelude () ------------------------------------------------------------------------------- -- Cabal file @@ -41,13 +43,13 @@ import Prelude () -- | A Cabal-like file consists of a series of fields (@foo: bar@) and sections (@library ...@). data Field ann - = Field !(Name ann) [FieldLine ann] - | Section !(Name ann) [SectionArg ann] [Field ann] + = Field !(Name ann) [FieldLine ann] + | Section !(Name ann) [SectionArg ann] [Field ann] deriving (Eq, Show, Functor, Foldable, Traversable) -- | Section of field name fieldName :: Field ann -> Name ann -fieldName (Field n _ ) = n +fieldName (Field n _) = n fieldName (Section n _ _) = n fieldAnn :: Field ann -> ann @@ -56,16 +58,15 @@ fieldAnn = nameAnn . fieldName -- | All transitive descendants of 'Field', including itself. -- -- /Note:/ the resulting list is never empty. --- fieldUniverse :: Field ann -> [Field ann] fieldUniverse f@(Section _ _ fs) = f : concatMap fieldUniverse fs -fieldUniverse f@(Field _ _) = [f] +fieldUniverse f@(Field _ _) = [f] -- | A line of text representing the value of a field from a Cabal file. -- A field may contain multiple lines. -- -- /Invariant:/ 'ByteString' has no newlines. -data FieldLine ann = FieldLine !ann !ByteString +data FieldLine ann = FieldLine !ann !ByteString deriving (Eq, Show, Functor, Foldable, Traversable) -- | @since 3.0.0.0 @@ -78,18 +79,18 @@ fieldLineBS (FieldLine _ bs) = bs -- | Section arguments, e.g. name of the library data SectionArg ann - = SecArgName !ann !ByteString - -- ^ identifier, or something which looks like number. Also many dot numbers, i.e. "7.6.3" - | SecArgStr !ann !ByteString - -- ^ quoted string - | SecArgOther !ann !ByteString - -- ^ everything else, mm. operators (e.g. in if-section conditionals) + = -- | identifier, or something which looks like number. Also many dot numbers, i.e. "7.6.3" + SecArgName !ann !ByteString + | -- | quoted string + SecArgStr !ann !ByteString + | -- | everything else, mm. operators (e.g. in if-section conditionals) + SecArgOther !ann !ByteString deriving (Eq, Show, Functor, Foldable, Traversable) -- | Extract annotation from 'SectionArg'. sectionArgAnn :: SectionArg ann -> ann -sectionArgAnn (SecArgName ann _) = ann -sectionArgAnn (SecArgStr ann _) = ann +sectionArgAnn (SecArgName ann _) = ann +sectionArgAnn (SecArgStr ann _) = ann sectionArgAnn (SecArgOther ann _) = ann ------------------------------------------------------------------------------- @@ -101,7 +102,7 @@ type FieldName = ByteString -- | A field name. -- -- /Invariant/: 'ByteString' is lower-case ASCII. -data Name ann = Name !ann !FieldName +data Name ann = Name !ann !FieldName deriving (Eq, Show, Functor, Foldable, Traversable) mkName :: ann -> FieldName -> Name ann @@ -121,10 +122,11 @@ nameAnn (Name ann _) = ann -- -- @since 3.6.0.0 sectionArgsToString :: [SectionArg ann] -> String -sectionArgsToString = unwords . map toStr where +sectionArgsToString = unwords . map toStr + where toStr :: SectionArg ann -> String - toStr (SecArgName _ bs) = showTokenStr (fromUTF8BS bs) - toStr (SecArgStr _ bs) = showTokenStr (fromUTF8BS bs) + toStr (SecArgName _ bs) = showTokenStr (fromUTF8BS bs) + toStr (SecArgStr _ bs) = showTokenStr (fromUTF8BS bs) toStr (SecArgOther _ bs) = fromUTF8BS bs -- | Convert @['FieldLine']@ into String. @@ -135,7 +137,7 @@ sectionArgsToString = unwords . map toStr where -- @since 3.6.0.0 fieldLinesToString :: [FieldLine ann] -> String fieldLinesToString = - -- intercalate to avoid trailing newline. - intercalate "\n" . map toStr + -- intercalate to avoid trailing newline. + intercalate "\n" . map toStr where toStr (FieldLine _ bs) = fromUTF8BS bs diff --git a/Cabal-syntax/src/Distribution/Fields/LexerMonad.hs b/Cabal-syntax/src/Distribution/Fields/LexerMonad.hs index ac414c18e31..4ad77d6d0e5 100644 --- a/Cabal-syntax/src/Distribution/Fields/LexerMonad.hs +++ b/Cabal-syntax/src/Distribution/Fields/LexerMonad.hs @@ -1,43 +1,39 @@ {-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Fields.LexerMonad -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -module Distribution.Fields.LexerMonad ( - InputStream, - LexState(..), - LexResult(..), - - Lex(..), - execLexer, - - getPos, - setPos, - adjustPos, - - getInput, - setInput, - - getStartCode, - setStartCode, - - LexWarning(..), - LexWarningType(..), - addWarning, - addWarningAt, - toPWarnings, - +module Distribution.Fields.LexerMonad + ( InputStream + , LexState (..) + , LexResult (..) + , Lex (..) + , execLexer + , getPos + , setPos + , adjustPos + , getInput + , setInput + , getStartCode + , setStartCode + , LexWarning (..) + , LexWarningType (..) + , addWarning + , addWarningAt + , toPWarnings ) where -import qualified Data.ByteString as B -import qualified Data.List.NonEmpty as NE -import Distribution.Compat.Prelude -import Distribution.Parsec.Position (Position (..), showPos) -import Distribution.Parsec.Warning (PWarnType (..), PWarning (..)) -import Prelude () +import qualified Data.ByteString as B +import qualified Data.List.NonEmpty as NE +import Distribution.Compat.Prelude +import Distribution.Parsec.Position (Position (..), showPos) +import Distribution.Parsec.Warning (PWarnType (..), PWarning (..)) +import Prelude () import qualified Data.Map.Strict as Map @@ -49,7 +45,7 @@ import qualified Data.Vector as V #endif -- simple state monad -newtype Lex a = Lex { unLex :: LexState -> LexResult a } +newtype Lex a = Lex {unLex :: LexState -> LexResult a} instance Functor Lex where fmap = liftM @@ -60,66 +56,83 @@ instance Applicative Lex where instance Monad Lex where return = pure - (>>=) = thenLex + (>>=) = thenLex data LexResult a = LexResult {-# UNPACK #-} !LexState a data LexWarningType - = LexWarningNBSP -- ^ Encountered non breaking space - | LexWarningBOM -- ^ BOM at the start of the cabal file - | LexWarningTab -- ^ Leading tags + = -- | Encountered non breaking space + LexWarningNBSP + | -- | BOM at the start of the cabal file + LexWarningBOM + | -- | Leading tags + LexWarningTab deriving (Eq, Ord, Show) -data LexWarning = LexWarning !LexWarningType - {-# UNPACK #-} !Position +data LexWarning + = LexWarning + !LexWarningType + {-# UNPACK #-} !Position deriving (Show) toPWarnings :: [LexWarning] -> [PWarning] -toPWarnings - = map (uncurry toWarning) +toPWarnings = + map (uncurry toWarning) . Map.toList . Map.fromListWith (<>) . map (\(LexWarning t p) -> (t, pure p)) where toWarning LexWarningBOM poss = - PWarning PWTLexBOM (NE.head poss) "Byte-order mark found at the beginning of the file" + PWarning PWTLexBOM (NE.head poss) "Byte-order mark found at the beginning of the file" toWarning LexWarningNBSP poss = - PWarning PWTLexNBSP (NE.head poss) $ "Non breaking spaces at " ++ intercalate ", " (NE.toList $ fmap showPos poss) + PWarning PWTLexNBSP (NE.head poss) $ "Non breaking spaces at " ++ intercalate ", " (NE.toList $ fmap showPos poss) toWarning LexWarningTab poss = - PWarning PWTLexTab (NE.head poss) $ "Tabs used as indentation at " ++ intercalate ", " (NE.toList $ fmap showPos poss) - -data LexState = LexState { - curPos :: {-# UNPACK #-} !Position, -- ^ position at current input location - curInput :: {-# UNPACK #-} !InputStream, -- ^ the current input - curCode :: {-# UNPACK #-} !StartCode, -- ^ lexer code - warnings :: [LexWarning] + PWarning PWTLexTab (NE.head poss) $ "Tabs used as indentation at " ++ intercalate ", " (NE.toList $ fmap showPos poss) + +{- FOURMOLU_DISABLE -} +data LexState = LexState + { curPos :: {-# UNPACK #-} !Position + -- ^ position at current input location + , curInput :: {-# UNPACK #-} !InputStream + -- ^ the current input + , curCode :: {-# UNPACK #-} !StartCode + -- ^ lexer code + , warnings :: [LexWarning] #ifdef CABAL_PARSEC_DEBUG - , dbgText :: V.Vector T.Text -- ^ input lines, to print pretty debug info + , dbgText :: V.Vector T.Text + -- ^ input lines, to print pretty debug info #endif - } --TODO: check if we should cache the first token - -- since it looks like parsec's uncons can be called many times on the same input + } +{- FOURMOLU_ENABLE -} -type StartCode = Int -- ^ An @alex@ lexer start code -type InputStream = B.ByteString +-- TODO: check if we should cache the first token +-- since it looks like parsec's uncons can be called many times on the same input +type StartCode = + Int + -- ^ An @alex@ lexer start code +type InputStream = B.ByteString -- | Execute the given lexer on the supplied input stream. +{- FOURMOLU_DISABLE -} execLexer :: Lex a -> InputStream -> ([LexWarning], a) execLexer (Lex lexer) input = - case lexer initialState of - LexResult LexState{ warnings = ws } result -> (ws, result) + case lexer initialState of + LexResult LexState{warnings = ws} result -> (ws, result) where - initialState = LexState - -- TODO: add 'startPosition' - { curPos = Position 1 1 - , curInput = input - , curCode = 0 - , warnings = [] + initialState = + LexState + { -- TODO: add 'startPosition' + curPos = Position 1 1 + , curInput = input + , curCode = 0 + , warnings = [] #ifdef CABAL_PARSEC_DEBUG - , dbgText = V.fromList . T.lines . T.decodeUtf8 $ input + , dbgText = V.fromList . T.lines . T.decodeUtf8 $ input #endif - } + } +{- FOURMOLU_ENABLE -} {-# INLINE returnLex #-} returnLex :: a -> Lex a @@ -130,32 +143,32 @@ thenLex :: Lex a -> (a -> Lex b) -> Lex b (Lex m) `thenLex` k = Lex $ \s -> case m s of LexResult s' a -> (unLex (k a)) s' setPos :: Position -> Lex () -setPos pos = Lex $ \s -> LexResult s{ curPos = pos } () +setPos pos = Lex $ \s -> LexResult s{curPos = pos} () getPos :: Lex Position -getPos = Lex $ \s@LexState{ curPos = pos } -> LexResult s pos +getPos = Lex $ \s@LexState{curPos = pos} -> LexResult s pos adjustPos :: (Position -> Position) -> Lex () -adjustPos f = Lex $ \s@LexState{ curPos = pos } -> LexResult s{ curPos = f pos } () +adjustPos f = Lex $ \s@LexState{curPos = pos} -> LexResult s{curPos = f pos} () getInput :: Lex InputStream -getInput = Lex $ \s@LexState{ curInput = i } -> LexResult s i +getInput = Lex $ \s@LexState{curInput = i} -> LexResult s i setInput :: InputStream -> Lex () -setInput i = Lex $ \s -> LexResult s{ curInput = i } () +setInput i = Lex $ \s -> LexResult s{curInput = i} () getStartCode :: Lex Int -getStartCode = Lex $ \s@LexState{ curCode = c } -> LexResult s c +getStartCode = Lex $ \s@LexState{curCode = c} -> LexResult s c setStartCode :: Int -> Lex () -setStartCode c = Lex $ \s -> LexResult s{ curCode = c } () +setStartCode c = Lex $ \s -> LexResult s{curCode = c} () -- | Add warning at the current position addWarning :: LexWarningType -> Lex () -addWarning wt = Lex $ \s@LexState{ curPos = pos, warnings = ws } -> - LexResult s{ warnings = LexWarning wt pos : ws } () +addWarning wt = Lex $ \s@LexState{curPos = pos, warnings = ws} -> + LexResult s{warnings = LexWarning wt pos : ws} () -- | Add warning at specific position addWarningAt :: Position -> LexWarningType -> Lex () -addWarningAt pos wt = Lex $ \s@LexState{ warnings = ws } -> - LexResult s{ warnings = LexWarning wt pos : ws } () +addWarningAt pos wt = Lex $ \s@LexState{warnings = ws} -> + LexResult s{warnings = LexWarning wt pos : ws} () diff --git a/Cabal-syntax/src/Distribution/Fields/ParseResult.hs b/Cabal-syntax/src/Distribution/Fields/ParseResult.hs index f300fc115f8..fb09254697e 100644 --- a/Cabal-syntax/src/Distribution/Fields/ParseResult.hs +++ b/Cabal-syntax/src/Distribution/Fields/ParseResult.hs @@ -1,27 +1,28 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes #-} + -- | A parse result type for parsers from AST to Haskell types. -module Distribution.Fields.ParseResult ( - ParseResult, - runParseResult, - recoverWith, - parseWarning, - parseWarnings, - parseFailure, - parseFatalFailure, - parseFatalFailure', - getCabalSpecVersion, - setCabalSpecVersion, - withoutWarnings, - ) where - -import Distribution.Parsec.Error (PError (..)) -import Distribution.Parsec.Position (Position (..), zeroPos) -import Distribution.Parsec.Warning (PWarnType (..), PWarning (..)) -import Distribution.Version (Version) -import Prelude () +module Distribution.Fields.ParseResult + ( ParseResult + , runParseResult + , recoverWith + , parseWarning + , parseWarnings + , parseFailure + , parseFatalFailure + , parseFatalFailure' + , getCabalSpecVersion + , setCabalSpecVersion + , withoutWarnings + ) where + +import Distribution.Parsec.Error (PError (..)) +import Distribution.Parsec.Position (Position (..), zeroPos) +import Distribution.Parsec.Warning (PWarnType (..), PWarning (..)) +import Distribution.Version (Version) +import Prelude () -- liftA2 is not in base <4.10, hence we need to only import it explicitly when we're on >=4.10 -- @@ -36,12 +37,13 @@ import Distribution.Compat.Prelude -- | A monad with failure and accumulating errors and warnings. newtype ParseResult a = PR - { unPR - :: forall r. PRState - -> (PRState -> r) -- failure, but we were able to recover a new-style spec-version declaration - -> (PRState -> a -> r) -- success - -> r - } + { unPR + :: forall r + . PRState + -> (PRState -> r) -- failure, but we were able to recover a new-style spec-version declaration + -> (PRState -> a -> r) -- success + -> r + } -- Note: we have version here, as we could get any version. data PRState = PRState ![PWarning] ![PError] !(Maybe Version) @@ -54,7 +56,7 @@ emptyPRState = PRState [] [] Nothing -- @since 3.4.0.0 withoutWarnings :: ParseResult a -> ParseResult a withoutWarnings m = PR $ \s failure success -> - unPR m s failure $ \ !s1 -> success (s1 `withWarningsOf` s) + unPR m s failure $ \ !s1 -> success (s1 `withWarningsOf` s) where withWarningsOf (PRState _ e v) (PRState w _ _) = PRState w e v @@ -64,99 +66,99 @@ withoutWarnings m = PR $ \s failure success -> runParseResult :: ParseResult a -> ([PWarning], Either (Maybe Version, NonEmpty PError) a) runParseResult pr = unPR pr emptyPRState failure success where - failure (PRState warns [] v) = (warns, Left (v, PError zeroPos "panic" :| [])) - failure (PRState warns (err:errs) v) = (warns, Left (v, err :| errs)) where - success (PRState warns [] _) x = (warns, Right x) + failure (PRState warns [] v) = (warns, Left (v, PError zeroPos "panic" :| [])) + failure (PRState warns (err : errs) v) = (warns, Left (v, err :| errs)) where + success (PRState warns [] _) x = (warns, Right x) -- If there are any errors, don't return the result - success (PRState warns (err:errs) v) _ = (warns, Left (v, err :| errs)) + success (PRState warns (err : errs) v) _ = (warns, Left (v, err :| errs)) instance Functor ParseResult where - fmap f (PR pr) = PR $ \ !s failure success -> - pr s failure $ \ !s' a -> - success s' (f a) - {-# INLINE fmap #-} + fmap f (PR pr) = PR $ \ !s failure success -> + pr s failure $ \ !s' a -> + success s' (f a) + {-# INLINE fmap #-} instance Applicative ParseResult where - pure x = PR $ \ !s _ success -> success s x - {-# INLINE pure #-} + pure x = PR $ \ !s _ success -> success s x + {-# INLINE pure #-} - f <*> x = PR $ \ !s0 failure success -> - unPR f s0 failure $ \ !s1 f' -> - unPR x s1 failure $ \ !s2 x' -> + f <*> x = PR $ \ !s0 failure success -> + unPR f s0 failure $ \ !s1 f' -> + unPR x s1 failure $ \ !s2 x' -> success s2 (f' x') - {-# INLINE (<*>) #-} + {-# INLINE (<*>) #-} - x *> y = PR $ \ !s0 failure success -> - unPR x s0 failure $ \ !s1 _ -> - unPR y s1 failure success - {-# INLINE (*>) #-} + x *> y = PR $ \ !s0 failure success -> + unPR x s0 failure $ \ !s1 _ -> + unPR y s1 failure success + {-# INLINE (*>) #-} - x <* y = PR $ \ !s0 failure success -> - unPR x s0 failure $ \ !s1 x' -> - unPR y s1 failure $ \ !s2 _ -> + x <* y = PR $ \ !s0 failure success -> + unPR x s0 failure $ \ !s1 x' -> + unPR y s1 failure $ \ !s2 _ -> success s2 x' - {-# INLINE (<*) #-} + {-# INLINE (<*) #-} #if MIN_VERSION_base(4,10,0) - liftA2 f x y = PR $ \ !s0 failure success -> - unPR x s0 failure $ \ !s1 x' -> - unPR y s1 failure $ \ !s2 y' -> - success s2 (f x' y') - {-# INLINE liftA2 #-} + liftA2 f x y = PR $ \ !s0 failure success -> + unPR x s0 failure $ \ !s1 x' -> + unPR y s1 failure $ \ !s2 y' -> + success s2 (f x' y') + {-# INLINE liftA2 #-} #endif instance Monad ParseResult where - return = pure - (>>) = (*>) + return = pure + (>>) = (*>) - m >>= k = PR $ \ !s failure success -> - unPR m s failure $ \ !s' a -> - unPR (k a) s' failure success - {-# INLINE (>>=) #-} + m >>= k = PR $ \ !s failure success -> + unPR m s failure $ \ !s' a -> + unPR (k a) s' failure success + {-# INLINE (>>=) #-} -- | "Recover" the parse result, so we can proceed parsing. -- 'runParseResult' will still result in 'Nothing', if there are recorded errors. recoverWith :: ParseResult a -> a -> ParseResult a recoverWith (PR pr) x = PR $ \ !s _failure success -> - pr s (\ !s' -> success s' x) success + pr s (\ !s' -> success s' x) success -- | Set cabal spec version. setCabalSpecVersion :: Maybe Version -> ParseResult () setCabalSpecVersion v = PR $ \(PRState warns errs _) _failure success -> - success (PRState warns errs v) () + success (PRState warns errs v) () -- | Get cabal spec version. getCabalSpecVersion :: ParseResult (Maybe Version) getCabalSpecVersion = PR $ \s@(PRState _ _ v) _failure success -> - success s v + success s v -- | Add a warning. This doesn't fail the parsing process. parseWarning :: Position -> PWarnType -> String -> ParseResult () parseWarning pos t msg = PR $ \(PRState warns errs v) _failure success -> - success (PRState (PWarning t pos msg : warns) errs v) () + success (PRState (PWarning t pos msg : warns) errs v) () -- | Add multiple warnings at once. parseWarnings :: [PWarning] -> ParseResult () parseWarnings newWarns = PR $ \(PRState warns errs v) _failure success -> - success (PRState (newWarns ++ warns) errs v) () + success (PRState (newWarns ++ warns) errs v) () -- | Add an error, but not fail the parser yet. -- -- For fatal failure use 'parseFatalFailure' parseFailure :: Position -> String -> ParseResult () parseFailure pos msg = PR $ \(PRState warns errs v) _failure success -> - success (PRState warns (PError pos msg : errs) v) () + success (PRState warns (PError pos msg : errs) v) () -- | Add an fatal error. parseFatalFailure :: Position -> String -> ParseResult a parseFatalFailure pos msg = PR $ \(PRState warns errs v) failure _success -> - failure (PRState warns (PError pos msg : errs) v) + failure (PRState warns (PError pos msg : errs) v) -- | A 'mzero'. parseFatalFailure' :: ParseResult a parseFatalFailure' = PR pr where pr (PRState warns [] v) failure _success = failure (PRState warns [err] v) - pr s failure _success = failure s + pr s failure _success = failure s err = PError zeroPos "Unknown fatal error" diff --git a/Cabal-syntax/src/Distribution/Fields/Parser.hs b/Cabal-syntax/src/Distribution/Fields/Parser.hs index 9061117b04e..46b65ab5ea0 100644 --- a/Cabal-syntax/src/Distribution/Fields/Parser.hs +++ b/Cabal-syntax/src/Distribution/Fields/Parser.hs @@ -1,45 +1,55 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Fields.Parser -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -module Distribution.Fields.Parser ( - -- * Types - Field(..), - Name(..), - FieldLine(..), - SectionArg(..), +{- FOURMOLU_DISABLE -} +module Distribution.Fields.Parser + ( -- * Types + Field (..) + , Name (..) + , FieldLine (..) + , SectionArg (..) + -- * Grammar and parsing -- $grammar - readFields, - readFields', + , readFields + , readFields' #ifdef CABAL_PARSEC_DEBUG + -- * Internal - parseFile, - parseStr, - parseBS, + , parseFile + , parseStr + , parseBS #endif - ) where - -import qualified Data.ByteString.Char8 as B8 -import Data.Functor.Identity -import Distribution.Compat.Prelude -import Distribution.Fields.Field -import Distribution.Fields.Lexer -import Distribution.Fields.LexerMonad - (LexResult (..), LexState (..), LexWarning (..), unLex) -import Distribution.Parsec.Position (Position (..)) -import Prelude () -import Text.Parsec.Combinator hiding (eof, notFollowedBy) -import Text.Parsec.Error -import Text.Parsec.Pos -import Text.Parsec.Prim hiding (many, (<|>)) + ) where +{- FOURMOLU_ENABLE -} + +import qualified Data.ByteString.Char8 as B8 +import Data.Functor.Identity +import Distribution.Compat.Prelude +import Distribution.Fields.Field +import Distribution.Fields.Lexer +import Distribution.Fields.LexerMonad + ( LexResult (..) + , LexState (..) + , LexWarning (..) + , unLex + ) +import Distribution.Parsec.Position (Position (..)) +import Text.Parsec.Combinator hiding (eof, notFollowedBy) +import Text.Parsec.Error +import Text.Parsec.Pos +import Text.Parsec.Prim hiding (many, (<|>)) +import Prelude () #ifdef CABAL_PARSEC_DEBUG import qualified Data.Text as T @@ -52,8 +62,10 @@ import qualified Data.Text.Encoding.Error as T data LexState' = LexState' !LexState (LToken, LexState') mkLexState' :: LexState -> LexState' -mkLexState' st = LexState' st - (case unLex lexToken st of LexResult st' tok -> (tok, mkLexState' st')) +mkLexState' st = + LexState' + st + (case unLex lexToken st of LexResult st' tok -> (tok, mkLexState' st')) type Parser a = ParsecT LexState' () Identity a @@ -61,19 +73,19 @@ instance Stream LexState' Identity LToken where uncons (LexState' _ (tok, st')) = case tok of L _ EOF -> return Nothing - _ -> return (Just (tok, st')) + _ -> return (Just (tok, st')) -- | Get lexer warnings accumulated so far getLexerWarnings :: Parser [LexWarning] getLexerWarnings = do - LexState' (LexState { warnings = ws }) _ <- getInput + LexState' (LexState{warnings = ws}) _ <- getInput return ws -- | Set Alex code i.e. the mode "state" lexer is in. setLexerMode :: Int -> Parser () setLexerMode code = do LexState' ls _ <- getInput - setInput $! mkLexState' ls { curCode = code } + setInput $! mkLexState' ls{curCode = code} getToken :: (Token -> Maybe a) -> Parser a getToken getTok = getTokenWithPos (\(L _ t) -> getTok t) @@ -86,16 +98,16 @@ getTokenWithPos getTok = tokenPrim (\(L _ t) -> describeToken t) updatePos getTo describeToken :: Token -> String describeToken t = case t of - TokSym s -> "symbol " ++ show s - TokStr s -> "string " ++ show s - TokOther s -> "operator " ++ show s - Indent _ -> "new line" - TokFieldLine _ -> "field content" - Colon -> "\":\"" - OpenBrace -> "\"{\"" - CloseBrace -> "\"}\"" --- SemiColon -> "\";\"" - EOF -> "end of file" + TokSym s -> "symbol " ++ show s + TokStr s -> "string " ++ show s + TokOther s -> "operator " ++ show s + Indent _ -> "new line" + TokFieldLine _ -> "field content" + Colon -> "\":\"" + OpenBrace -> "\"{\"" + CloseBrace -> "\"}\"" + -- SemiColon -> "\";\"" + EOF -> "end of file" LexicalError is -> "character in input " ++ show (B8.head is) tokSym :: Parser (Name Position) @@ -103,28 +115,26 @@ tokSym', tokStr, tokOther :: Parser (SectionArg Position) tokIndent :: Parser Int tokColon, tokOpenBrace, tokCloseBrace :: Parser () tokFieldLine :: Parser (FieldLine Position) - -tokSym = getTokenWithPos $ \t -> case t of L pos (TokSym x) -> Just (mkName pos x); _ -> Nothing -tokSym' = getTokenWithPos $ \t -> case t of L pos (TokSym x) -> Just (SecArgName pos x); _ -> Nothing -tokStr = getTokenWithPos $ \t -> case t of L pos (TokStr x) -> Just (SecArgStr pos x); _ -> Nothing -tokOther = getTokenWithPos $ \t -> case t of L pos (TokOther x) -> Just (SecArgOther pos x); _ -> Nothing -tokIndent = getToken $ \t -> case t of Indent x -> Just x; _ -> Nothing -tokColon = getToken $ \t -> case t of Colon -> Just (); _ -> Nothing -tokOpenBrace = getToken $ \t -> case t of OpenBrace -> Just (); _ -> Nothing +tokSym = getTokenWithPos $ \t -> case t of L pos (TokSym x) -> Just (mkName pos x); _ -> Nothing +tokSym' = getTokenWithPos $ \t -> case t of L pos (TokSym x) -> Just (SecArgName pos x); _ -> Nothing +tokStr = getTokenWithPos $ \t -> case t of L pos (TokStr x) -> Just (SecArgStr pos x); _ -> Nothing +tokOther = getTokenWithPos $ \t -> case t of L pos (TokOther x) -> Just (SecArgOther pos x); _ -> Nothing +tokIndent = getToken $ \t -> case t of Indent x -> Just x; _ -> Nothing +tokColon = getToken $ \t -> case t of Colon -> Just (); _ -> Nothing +tokOpenBrace = getToken $ \t -> case t of OpenBrace -> Just (); _ -> Nothing tokCloseBrace = getToken $ \t -> case t of CloseBrace -> Just (); _ -> Nothing -tokFieldLine = getTokenWithPos $ \t -> case t of L pos (TokFieldLine s) -> Just (FieldLine pos s); _ -> Nothing +tokFieldLine = getTokenWithPos $ \t -> case t of L pos (TokFieldLine s) -> Just (FieldLine pos s); _ -> Nothing colon, openBrace, closeBrace :: Parser () - sectionArg :: Parser (SectionArg Position) -sectionArg = tokSym' <|> tokStr <|> tokOther "section parameter" +sectionArg = tokSym' <|> tokStr <|> tokOther "section parameter" fieldSecName :: Parser (Name Position) -fieldSecName = tokSym "field or section name" +fieldSecName = tokSym "field or section name" -colon = tokColon "\":\"" -openBrace = tokOpenBrace "\"{\"" -closeBrace = tokCloseBrace "\"}\"" +colon = tokColon "\":\"" +openBrace = tokOpenBrace "\"{\"" +closeBrace = tokCloseBrace "\"}\"" fieldContent :: Parser (FieldLine Position) fieldContent = tokFieldLine "field contents" @@ -143,14 +153,12 @@ indentOfAtLeast (IndentLevel i) = try $ do guard (j >= i) "indentation of at least " ++ show i return (IndentLevel j) - newtype LexerMode = LexerMode Int inLexerMode :: LexerMode -> Parser p -> Parser p inLexerMode (LexerMode mode) p = do setLexerMode mode; x <- p; setLexerMode in_section; return x - ----------------------- -- Cabal file grammar -- @@ -207,9 +215,10 @@ inLexerMode (LexerMode mode) p = -- Top level of a file using cabal syntax -- cabalStyleFile :: Parser [Field Position] -cabalStyleFile = do es <- elements zeroIndentLevel - eof - return es +cabalStyleFile = do + es <- elements zeroIndentLevel + eof + return es -- Elements that live at the top level or inside a section, i.e. fields -- and sections content @@ -226,11 +235,15 @@ elements ilevel = many (element ilevel) -- | name elementInNonLayoutContext element :: IndentLevel -> Parser (Field Position) element ilevel = - (do ilevel' <- indentOfAtLeast ilevel - name <- fieldSecName - elementInLayoutContext (incIndentLevel ilevel') name) - <|> (do name <- fieldSecName - elementInNonLayoutContext name) + ( do + ilevel' <- indentOfAtLeast ilevel + name <- fieldSecName + elementInLayoutContext (incIndentLevel ilevel') name + ) + <|> ( do + name <- fieldSecName + elementInNonLayoutContext name + ) -- An element (field or section) that is valid in a layout context. -- In a layout context we can have fields and sections that themselves @@ -240,10 +253,12 @@ element ilevel = -- | arg* sectionLayoutOrBraces elementInLayoutContext :: IndentLevel -> Name Position -> Parser (Field Position) elementInLayoutContext ilevel name = - (do colon; fieldLayoutOrBraces ilevel name) - <|> (do args <- many sectionArg - elems <- sectionLayoutOrBraces ilevel - return (Section name args elems)) + (do colon; fieldLayoutOrBraces ilevel name) + <|> ( do + args <- many sectionArg + elems <- sectionLayoutOrBraces ilevel + return (Section name args elems) + ) -- An element (field or section) that is valid in a non-layout context. -- In a non-layout context we can have only have fields and sections that @@ -253,13 +268,15 @@ elementInLayoutContext ilevel name = -- | arg* '\\n'? '{' elements '\\n'? '}' elementInNonLayoutContext :: Name Position -> Parser (Field Position) elementInNonLayoutContext name = - (do colon; fieldInlineOrBraces name) - <|> (do args <- many sectionArg - openBrace - elems <- elements zeroIndentLevel - optional tokIndent - closeBrace - return (Section name args elems)) + (do colon; fieldInlineOrBraces name) + <|> ( do + args <- many sectionArg + openBrace + elems <- elements zeroIndentLevel + optional tokIndent + closeBrace + return (Section name args elems) + ) -- The body of a field, using either layout style or braces style. -- @@ -269,16 +286,16 @@ fieldLayoutOrBraces :: IndentLevel -> Name Position -> Parser (Field Position) fieldLayoutOrBraces ilevel name = braces <|> fieldLayout where braces = do - openBrace - ls <- inLexerMode (LexerMode in_field_braces) (many fieldContent) - closeBrace - return (Field name ls) + openBrace + ls <- inLexerMode (LexerMode in_field_braces) (many fieldContent) + closeBrace + return (Field name ls) fieldLayout = inLexerMode (LexerMode in_field_layout) $ do - l <- optionMaybe fieldContent - ls <- many (do _ <- indentOfAtLeast ilevel; fieldContent) - return $ case l of - Nothing -> Field name ls - Just l' -> Field name (l' : ls) + l <- optionMaybe fieldContent + ls <- many (do _ <- indentOfAtLeast ilevel; fieldContent) + return $ case l of + Nothing -> Field name ls + Just l' -> Field name (l' : ls) -- The body of a section, using either layout style or braces style. -- @@ -286,12 +303,14 @@ fieldLayoutOrBraces ilevel name = braces <|> fieldLayout -- | elements sectionLayoutOrBraces :: IndentLevel -> Parser [Field Position] sectionLayoutOrBraces ilevel = - (do openBrace - elems <- elements zeroIndentLevel - optional tokIndent - closeBrace - return elems) - <|> (elements ilevel) + ( do + openBrace + elems <- elements zeroIndentLevel + optional tokIndent + closeBrace + return elems + ) + <|> (elements ilevel) -- The body of a field, using either inline style or braces. -- @@ -299,13 +318,16 @@ sectionLayoutOrBraces ilevel = -- | content fieldInlineOrBraces :: Name Position -> Parser (Field Position) fieldInlineOrBraces name = - (do openBrace - ls <- inLexerMode (LexerMode in_field_braces) (many fieldContent) - closeBrace - return (Field name ls)) - <|> (do ls <- inLexerMode (LexerMode in_field_braces) (option [] (fmap (\l -> [l]) fieldContent)) - return (Field name ls)) - + ( do + openBrace + ls <- inLexerMode (LexerMode in_field_braces) (many fieldContent) + closeBrace + return (Field name ls) + ) + <|> ( do + ls <- inLexerMode (LexerMode in_field_braces) (option [] (fmap (\l -> [l]) fieldContent)) + return (Field name ls) + ) -- | Parse cabal style 'B8.ByteString' into list of 'Field's, i.e. the cabal AST. readFields :: B8.ByteString -> Either ParseError [Field Position] @@ -314,12 +336,12 @@ readFields s = fmap fst (readFields' s) -- | Like 'readFields' but also return lexer warnings readFields' :: B8.ByteString -> Either ParseError ([Field Position], [LexWarning]) readFields' s = do - parse parser "the input" lexSt + parse parser "the input" lexSt where parser = do - fields <- cabalStyleFile - ws <- getLexerWarnings - pure (fields, ws) + fields <- cabalStyleFile + ws <- getLexerWarnings + pure (fields, ws) lexSt = mkLexState' (mkLexState s) @@ -373,5 +395,8 @@ eof :: Parser () eof = notFollowedBy anyToken "end of file" where notFollowedBy :: Parser LToken -> Parser () - notFollowedBy p = try ( (do L _ t <- try p; unexpected (describeToken t)) - <|> return ()) + notFollowedBy p = + try + ( (do L _ t <- try p; unexpected (describeToken t)) + <|> return () + ) diff --git a/Cabal-syntax/src/Distribution/Fields/Pretty.hs b/Cabal-syntax/src/Distribution/Fields/Pretty.hs index dabea67b69b..58f54d2848c 100644 --- a/Cabal-syntax/src/Distribution/Fields/Pretty.hs +++ b/Cabal-syntax/src/Distribution/Fields/Pretty.hs @@ -1,37 +1,38 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE LambdaCase #-} + -- | Cabal-like file AST types: 'Field', 'Section' etc, -- -- This (intermediate) data type is used for pretty-printing. -- -- @since 3.0.0.0 --- -module Distribution.Fields.Pretty ( - -- * Fields - CommentPosition (..), - PrettyField (..), - showFields, - showFields', +module Distribution.Fields.Pretty + ( -- * Fields + CommentPosition (..) + , PrettyField (..) + , showFields + , showFields' + -- * Transformation from 'P.Field' - fromParsecFields, - genericFromParsecFields, - prettyFieldLines, - prettySectionArgs, - ) where + , fromParsecFields + , genericFromParsecFields + , prettyFieldLines + , prettySectionArgs + ) where import Distribution.Compat.Prelude -import Distribution.Pretty (showToken) +import Distribution.Pretty (showToken) import Prelude () -import Distribution.Fields.Field (FieldName) -import Distribution.Utils.Generic (fromUTF8BS) +import Distribution.Fields.Field (FieldName) +import Distribution.Utils.Generic (fromUTF8BS) import qualified Distribution.Fields.Parser as P -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS import qualified Text.PrettyPrint as PP -- | This type is used to discern when a comment block should go @@ -41,9 +42,9 @@ import qualified Text.PrettyPrint as PP data CommentPosition = CommentBefore [String] | CommentAfter [String] | NoComment data PrettyField ann - = PrettyField ann FieldName PP.Doc - | PrettySection ann FieldName [PP.Doc] [PrettyField ann] - | PrettyEmpty + = PrettyField ann FieldName PP.Doc + | PrettySection ann FieldName [PP.Doc] [PrettyField ann] + | PrettyEmpty deriving (Functor, Foldable, Traversable) -- | Prettyprint a list of fields. @@ -52,27 +53,27 @@ data PrettyField ann -- and properly prefixes (with @--@) to count as comments. -- This unsafety is left in place so one could generate empty lines -- between comment lines. --- showFields :: (ann -> CommentPosition) -> [PrettyField ann] -> String showFields rann = showFields' rann (const id) 4 -- | 'showFields' with user specified indentation. showFields' :: (ann -> CommentPosition) - -- ^ Convert an annotation to lined to precede the field or section. + -- ^ Convert an annotation to lined to precede the field or section. -> (ann -> [String] -> [String]) - -- ^ Post-process non-annotation produced lines. + -- ^ Post-process non-annotation produced lines. -> Int - -- ^ Indentation level. + -- ^ Indentation level. -> [PrettyField ann] - -- ^ Fields/sections to show. + -- ^ Fields/sections to show. -> String showFields' rann post n = unlines . renderFields (Opts rann indent post) where -- few hardcoded, "unrolled" variants. - indent | n == 4 = indent4 - | n == 2 = indent2 - | otherwise = (replicate (max n 1) ' ' ++) + indent + | n == 4 = indent4 + | n == 2 = indent2 + | otherwise = (replicate (max n 1) ' ' ++) indent4 :: String -> String indent4 [] = [] @@ -92,78 +93,80 @@ renderFields :: Opts ann -> [PrettyField ann] -> [String] renderFields opts fields = flattenBlocks blocks where len = maxNameLength 0 fields - blocks = filter (not . null . _contentsBlock) -- empty blocks cause extra newlines #8236 - $ map (renderField opts len) fields + blocks = + filter (not . null . _contentsBlock) $ -- empty blocks cause extra newlines #8236 + map (renderField opts len) fields - maxNameLength !acc [] = acc + maxNameLength !acc [] = acc maxNameLength !acc (PrettyField _ name _ : rest) = maxNameLength (max acc (BS.length name)) rest - maxNameLength !acc (PrettySection {} : rest) = maxNameLength acc rest + maxNameLength !acc (PrettySection{} : rest) = maxNameLength acc rest maxNameLength !acc (PrettyEmpty : rest) = maxNameLength acc rest -- | Block of lines with flags for optional blank lines before and after data Block = Block - { _beforeBlock :: Margin - , _afterBlock :: Margin + { _beforeBlock :: Margin + , _afterBlock :: Margin , _contentsBlock :: [String] } data Margin = Margin | NoMargin - deriving Eq + deriving (Eq) -- | Collapse margins, any margin = margin instance Semigroup Margin where - NoMargin <> NoMargin = NoMargin - _ <> _ = Margin + NoMargin <> NoMargin = NoMargin + _ <> _ = Margin flattenBlocks :: [Block] -> [String] -flattenBlocks = go0 where +flattenBlocks = go0 + where go0 [] = [] go0 (Block _before after strs : blocks) = strs ++ go after blocks go _surr' [] = [] - go surr' (Block before after strs : blocks) = ins $ strs ++ go after blocks where - ins | surr' <> before == Margin = ("" :) - | otherwise = id + go surr' (Block before after strs : blocks) = ins $ strs ++ go after blocks + where + ins + | surr' <> before == Margin = ("" :) + | otherwise = id renderField :: Opts ann -> Int -> PrettyField ann -> Block renderField (Opts rann indent post) fw (PrettyField ann name doc) = - Block before after content + Block before after content where content = case comments of CommentBefore cs -> cs ++ post ann lines' - CommentAfter cs -> post ann lines' ++ cs - NoComment -> post ann lines' + CommentAfter cs -> post ann lines' ++ cs + NoComment -> post ann lines' comments = rann ann before = case comments of CommentBefore [] -> NoMargin - CommentAfter [] -> NoMargin - NoComment -> NoMargin - _ -> Margin + CommentAfter [] -> NoMargin + NoComment -> NoMargin + _ -> Margin (lines', after) = case lines narrow of - [] -> ([ name' ++ ":" ], NoMargin) - [singleLine] | length singleLine < 60 - -> ([ name' ++ ": " ++ replicate (fw - length name') ' ' ++ narrow ], NoMargin) - _ -> ((name' ++ ":") : map indent (lines (PP.render doc)), Margin) + [] -> ([name' ++ ":"], NoMargin) + [singleLine] + | length singleLine < 60 -> + ([name' ++ ": " ++ replicate (fw - length name') ' ' ++ narrow], NoMargin) + _ -> ((name' ++ ":") : map indent (lines (PP.render doc)), Margin) name' = fromUTF8BS name narrow = PP.renderStyle narrowStyle doc narrowStyle :: PP.Style - narrowStyle = PP.style { PP.lineLength = PP.lineLength PP.style - fw } - -renderField opts@(Opts rann indent post) _ (PrettySection ann name args fields) = Block Margin Margin $ - + narrowStyle = PP.style{PP.lineLength = PP.lineLength PP.style - fw} +renderField opts@(Opts rann indent post) _ (PrettySection ann name args fields) = + Block Margin Margin $ attachComments - (post ann [ PP.render $ PP.hsep $ PP.text (fromUTF8BS name) : args ]) - ++ - map indent (renderFields opts fields) + (post ann [PP.render $ PP.hsep $ PP.text (fromUTF8BS name) : args]) + ++ map indent (renderFields opts fields) where attachComments content = case rann ann of CommentBefore cs -> cs ++ content - CommentAfter cs -> content ++ cs - NoComment -> content - + CommentAfter cs -> content ++ cs + NoComment -> content renderField _ _ PrettyEmpty = Block NoMargin NoMargin mempty ------------------------------------------------------------------------------- @@ -171,20 +174,24 @@ renderField _ _ PrettyEmpty = Block NoMargin NoMargin mempty ------------------------------------------------------------------------------- genericFromParsecFields - :: Applicative f - => (FieldName -> [P.FieldLine ann] -> f PP.Doc) -- ^ transform field contents - -> (FieldName -> [P.SectionArg ann] -> f [PP.Doc]) -- ^ transform section arguments - -> [P.Field ann] - -> f [PrettyField ann] -genericFromParsecFields f g = goMany where + :: Applicative f + => (FieldName -> [P.FieldLine ann] -> f PP.Doc) + -- ^ transform field contents + -> (FieldName -> [P.SectionArg ann] -> f [PP.Doc]) + -- ^ transform section arguments + -> [P.Field ann] + -> f [PrettyField ann] +genericFromParsecFields f g = goMany + where goMany = traverse go - go (P.Field (P.Name ann name) fls) = PrettyField ann name <$> f name fls + go (P.Field (P.Name ann name) fls) = PrettyField ann name <$> f name fls go (P.Section (P.Name ann name) secargs fs) = PrettySection ann name <$> g name secargs <*> goMany fs -- | Used in 'fromParsecFields'. prettyFieldLines :: FieldName -> [P.FieldLine ann] -> PP.Doc -prettyFieldLines _ fls = PP.vcat +prettyFieldLines _ fls = + PP.vcat [ PP.text $ fromUTF8BS bs | P.FieldLine _ bs <- fls ] @@ -192,15 +199,17 @@ prettyFieldLines _ fls = PP.vcat -- | Used in 'fromParsecFields'. prettySectionArgs :: FieldName -> [P.SectionArg ann] -> [PP.Doc] prettySectionArgs _ = map $ \case - P.SecArgName _ bs -> showToken $ fromUTF8BS bs - P.SecArgStr _ bs -> showToken $ fromUTF8BS bs - P.SecArgOther _ bs -> PP.text $ fromUTF8BS bs + P.SecArgName _ bs -> showToken $ fromUTF8BS bs + P.SecArgStr _ bs -> showToken $ fromUTF8BS bs + P.SecArgOther _ bs -> PP.text $ fromUTF8BS bs -- | Simple variant of 'genericFromParsecField' fromParsecFields :: [P.Field ann] -> [PrettyField ann] -fromParsecFields = runIdentity . genericFromParsecFields - (Identity .: prettyFieldLines) - (Identity .: prettySectionArgs) +fromParsecFields = + runIdentity + . genericFromParsecFields + (Identity .: prettyFieldLines) + (Identity .: prettySectionArgs) where (.:) :: (a -> b) -> (c -> d -> a) -> (c -> d -> b) (f .: g) x y = f (g x y) diff --git a/Cabal-syntax/src/Distribution/InstalledPackageInfo.hs b/Cabal-syntax/src/Distribution/InstalledPackageInfo.hs index 54a3fed6fc1..a84b8856efd 100644 --- a/Cabal-syntax/src/Distribution/InstalledPackageInfo.hs +++ b/Cabal-syntax/src/Distribution/InstalledPackageInfo.hs @@ -1,4 +1,7 @@ ----------------------------------------------------------------------------- + +-- This module is meant to be local-only to Distribution... + -- | -- Module : Distribution.InstalledPackageInfo -- Copyright : (c) The University of Glasgow 2004 @@ -21,43 +24,40 @@ -- about an installed package. There is a parser and pretty printer. The -- textual format is rather simpler than the @.cabal@ format: there are no -- sections, for example. - --- This module is meant to be local-only to Distribution... - -module Distribution.InstalledPackageInfo ( - InstalledPackageInfo(..), - installedComponentId, - installedOpenUnitId, - sourceComponentName, - requiredSignatures, - ExposedModule(..), - AbiDependency(..), - emptyInstalledPackageInfo, - parseInstalledPackageInfo, - showInstalledPackageInfo, - showFullInstalledPackageInfo, - showInstalledPackageInfoField, - showSimpleInstalledPackageInfoField, +module Distribution.InstalledPackageInfo + ( InstalledPackageInfo (..) + , installedComponentId + , installedOpenUnitId + , sourceComponentName + , requiredSignatures + , ExposedModule (..) + , AbiDependency (..) + , emptyInstalledPackageInfo + , parseInstalledPackageInfo + , showInstalledPackageInfo + , showFullInstalledPackageInfo + , showInstalledPackageInfoField + , showSimpleInstalledPackageInfoField ) where import Distribution.Compat.Prelude import Prelude () import Distribution.Backpack -import Distribution.CabalSpecVersion (cabalSpecLatest) +import Distribution.CabalSpecVersion (cabalSpecLatest) import Distribution.FieldGrammar import Distribution.FieldGrammar.FieldDescrs import Distribution.Fields.Pretty import Distribution.ModuleName -import Distribution.Package hiding (installedUnitId) +import Distribution.Package hiding (installedUnitId) import Distribution.Types.ComponentName -import Distribution.Utils.Generic (toUTF8BS) +import Distribution.Utils.Generic (toUTF8BS) import Data.ByteString (ByteString) -import qualified Data.Map as Map +import qualified Data.Map as Map import qualified Distribution.Fields as P -import qualified Text.PrettyPrint as Disp +import qualified Text.PrettyPrint as Disp import Distribution.Types.InstalledPackageInfo import Distribution.Types.InstalledPackageInfo.FieldGrammar @@ -67,9 +67,9 @@ import Distribution.Types.InstalledPackageInfo.FieldGrammar installedComponentId :: InstalledPackageInfo -> ComponentId installedComponentId ipi = - case unComponentId (installedComponentId_ ipi) of - "" -> mkComponentId (unUnitId (installedUnitId ipi)) - _ -> installedComponentId_ ipi + case unComponentId (installedComponentId_ ipi) of + "" -> mkComponentId (unUnitId (installedUnitId ipi)) + _ -> installedComponentId_ ipi -- | Get the indefinite unit identity representing this package. -- This IS NOT guaranteed to give you a substitution; for @@ -77,8 +77,8 @@ installedComponentId ipi = -- For indefinite libraries, however, you will correctly get -- an @OpenUnitId@ with the appropriate 'OpenModuleSubst'. installedOpenUnitId :: InstalledPackageInfo -> OpenUnitId -installedOpenUnitId ipi - = mkOpenUnitId (installedUnitId ipi) (installedComponentId ipi) (Map.fromList (instantiatedWith ipi)) +installedOpenUnitId ipi = + mkOpenUnitId (installedUnitId ipi) (installedComponentId ipi) (Map.fromList (instantiatedWith ipi)) -- | Returns the set of module names which need to be filled for -- an indefinite package, or the empty set if the package is definite. @@ -96,20 +96,23 @@ sourceComponentName = CLibName . sourceLibName -- | Return either errors, or IPI with list of warnings parseInstalledPackageInfo - :: ByteString - -> Either (NonEmpty String) ([String], InstalledPackageInfo) + :: ByteString + -> Either (NonEmpty String) ([String], InstalledPackageInfo) parseInstalledPackageInfo s = case P.readFields s of - Left err -> Left (show err :| []) - Right fs -> case partitionFields fs of - (fs', _) -> case P.runParseResult $ parseFieldGrammar cabalSpecLatest fs' ipiFieldGrammar of - (ws, Right x) -> x `deepseq` Right (ws', x) where - ws' = [ P.showPWarning "" w - | w@(P.PWarning wt _ _) <- ws - -- filter out warnings about experimental features - , wt /= P.PWTExperimental - ] - (_, Left (_, errs)) -> Left errs' where - errs' = fmap (P.showPError "") errs + Left err -> Left (show err :| []) + Right fs -> case partitionFields fs of + (fs', _) -> case P.runParseResult $ parseFieldGrammar cabalSpecLatest fs' ipiFieldGrammar of + (ws, Right x) -> x `deepseq` Right (ws', x) + where + ws' = + [ P.showPWarning "" w + | w@(P.PWarning wt _ _) <- ws + , -- filter out warnings about experimental features + wt /= P.PWTExperimental + ] + (_, Left (_, errs)) -> Left errs' + where + errs' = fmap (P.showPError "") errs -- ----------------------------------------------------------------------------- -- Pretty-printing @@ -119,7 +122,7 @@ parseInstalledPackageInfo s = case P.readFields s of -- @pkgRoot@ isn't printed, as ghc-pkg prints it manually (as GHC-8.4). showInstalledPackageInfo :: InstalledPackageInfo -> String showInstalledPackageInfo ipi = - showFullInstalledPackageInfo ipi { pkgRoot = Nothing } + showFullInstalledPackageInfo ipi{pkgRoot = Nothing} -- | The variant of 'showInstalledPackageInfo' which outputs @pkgroot@ field too. showFullInstalledPackageInfo :: InstalledPackageInfo -> String @@ -132,15 +135,15 @@ showFullInstalledPackageInfo = P.showFields (const NoComment) . prettyFieldGramm -- Just "maintainer: Tester" showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) showInstalledPackageInfoField fn = - fmap (\g -> Disp.render . ppField fn . g) $ fieldDescrPretty ipiFieldGrammar (toUTF8BS fn) + fmap (\g -> Disp.render . ppField fn . g) $ fieldDescrPretty ipiFieldGrammar (toUTF8BS fn) showSimpleInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) showSimpleInstalledPackageInfoField fn = - fmap (Disp.renderStyle myStyle .) $ fieldDescrPretty ipiFieldGrammar (toUTF8BS fn) + fmap (Disp.renderStyle myStyle .) $ fieldDescrPretty ipiFieldGrammar (toUTF8BS fn) where - myStyle = Disp.style { Disp.mode = Disp.LeftMode } + myStyle = Disp.style{Disp.mode = Disp.LeftMode} ppField :: String -> Disp.Doc -> Disp.Doc ppField name fielddoc - | Disp.isEmpty fielddoc = mempty - | otherwise = Disp.text name <<>> Disp.colon Disp.<+> fielddoc + | Disp.isEmpty fielddoc = mempty + | otherwise = Disp.text name <<>> Disp.colon Disp.<+> fielddoc diff --git a/Cabal-syntax/src/Distribution/License.hs b/Cabal-syntax/src/Distribution/License.hs index 51cac846037..f79ef6d0549 100644 --- a/Cabal-syntax/src/Distribution/License.hs +++ b/Cabal-syntax/src/Distribution/License.hs @@ -1,7 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.License -- Description : The License data type. @@ -41,12 +42,11 @@ -- intended for informational purposes only and in no way constitute legal -- advice. Please read the text of the licenses and consult a lawyer for any -- advice regarding software licensing. - -module Distribution.License ( - License(..), - knownLicenses, - licenseToSPDX, - licenseFromSPDX, +module Distribution.License + ( License (..) + , knownLicenses + , licenseToSPDX + , licenseFromSPDX ) where import Distribution.Compat.Prelude @@ -56,75 +56,61 @@ import Distribution.Parsec import Distribution.Pretty import Distribution.Version +import qualified Data.Map.Strict as Map import qualified Distribution.Compat.CharParsing as P -import qualified Data.Map.Strict as Map -import qualified Distribution.SPDX as SPDX -import qualified Text.PrettyPrint as Disp +import qualified Distribution.SPDX as SPDX +import qualified Text.PrettyPrint as Disp -- | Indicates the license under which a package's source code is released. -- Versions of the licenses not listed here will be rejected by Hackage and -- cause @cabal check@ to issue a warning. -data License = - -- TODO: * remove BSD4 +data License + = -- TODO: * remove BSD4 -- | GNU General Public License, -- or -- . GPL (Maybe Version) - - -- | . - | AGPL (Maybe Version) - - -- | GNU Lesser General Public License, + | -- | . + AGPL (Maybe Version) + | -- | GNU Lesser General Public License, -- or -- . - | LGPL (Maybe Version) - - -- | . - | BSD2 - - -- | . - | BSD3 - - -- | . + LGPL (Maybe Version) + | -- | . + BSD2 + | -- | . + BSD3 + | -- | . -- This license has not been approved by the OSI and is incompatible with -- the GNU GPL. It is provided for historical reasons and should be avoided. - | BSD4 - - -- | . - | MIT - - -- | - | ISC - - -- | . - | MPL Version - - -- | . - | Apache (Maybe Version) - - -- | The author of a package disclaims any copyright to its source code and + BSD4 + | -- | . + MIT + | -- | + ISC + | -- | . + MPL Version + | -- | . + Apache (Maybe Version) + | -- | The author of a package disclaims any copyright to its source code and -- dedicates it to the public domain. This is not a software license. Please -- note that it is not possible to dedicate works to the public domain in -- every jurisdiction, nor is a work that is in the public domain in one -- jurisdiction necessarily in the public domain elsewhere. - | PublicDomain - - -- | Explicitly 'All Rights Reserved', eg for proprietary software. The + PublicDomain + | -- | Explicitly 'All Rights Reserved', eg for proprietary software. The -- package may not be legally modified or redistributed by anyone but the -- rightsholder. - | AllRightsReserved - - -- | No license specified which legally defaults to 'All Rights Reserved'. + AllRightsReserved + | -- | No license specified which legally defaults to 'All Rights Reserved'. -- The package may not be legally modified or redistributed by anyone but -- the rightsholder. - | UnspecifiedLicense - - -- | Any other software license. - | OtherLicense - - -- | Indicates an erroneous license name. - | UnknownLicense String + UnspecifiedLicense + | -- | Any other software license. + OtherLicense + | -- | Indicates an erroneous license name. + UnknownLicense String deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) instance Binary License @@ -133,16 +119,29 @@ instance NFData License where rnf = genericRnf -- | The list of all currently recognised licenses. knownLicenses :: [License] -knownLicenses = [ GPL unversioned, GPL (version [2]), GPL (version [3]) - , LGPL unversioned, LGPL (version [2, 1]), LGPL (version [3]) - , AGPL unversioned, AGPL (version [3]) - , BSD2, BSD3, MIT, ISC - , MPL (mkVersion [2, 0]) - , Apache unversioned, Apache (version [2, 0]) - , PublicDomain, AllRightsReserved, OtherLicense] +knownLicenses = + [ GPL unversioned + , GPL (version [2]) + , GPL (version [3]) + , LGPL unversioned + , LGPL (version [2, 1]) + , LGPL (version [3]) + , AGPL unversioned + , AGPL (version [3]) + , BSD2 + , BSD3 + , MIT + , ISC + , MPL (mkVersion [2, 0]) + , Apache unversioned + , Apache (version [2, 0]) + , PublicDomain + , AllRightsReserved + , OtherLicense + ] where unversioned = Nothing - version = Just . mkVersion + version = Just . mkVersion -- | Convert old 'License' to SPDX 'SPDX.License'. -- Non-SPDX licenses are converted to 'SPDX.LicenseRef'. @@ -150,28 +149,28 @@ knownLicenses = [ GPL unversioned, GPL (version [2]), GPL (version [3]) -- @since 2.2.0.0 licenseToSPDX :: License -> SPDX.License licenseToSPDX l = case l of - GPL v | v == version [2] -> spdx SPDX.GPL_2_0_only - GPL v | v == version [3] -> spdx SPDX.GPL_3_0_only - LGPL v | v == version [2,1] -> spdx SPDX.LGPL_2_1_only - LGPL v | v == version [3] -> spdx SPDX.LGPL_3_0_only - AGPL v | v == version [3] -> spdx SPDX.AGPL_3_0_only - BSD2 -> spdx SPDX.BSD_2_Clause - BSD3 -> spdx SPDX.BSD_3_Clause - BSD4 -> spdx SPDX.BSD_4_Clause - MIT -> spdx SPDX.MIT - ISC -> spdx SPDX.ISC - MPL v | v == mkVersion [2,0] -> spdx SPDX.MPL_2_0 - Apache v | v == version [2,0] -> spdx SPDX.Apache_2_0 - AllRightsReserved -> SPDX.NONE - UnspecifiedLicense -> SPDX.NONE - OtherLicense -> ref (SPDX.mkLicenseRef' Nothing "OtherLicense") - PublicDomain -> ref (SPDX.mkLicenseRef' Nothing "PublicDomain") - UnknownLicense str -> ref (SPDX.mkLicenseRef' Nothing str) - _ -> ref (SPDX.mkLicenseRef' Nothing $ prettyShow l) + GPL v | v == version [2] -> spdx SPDX.GPL_2_0_only + GPL v | v == version [3] -> spdx SPDX.GPL_3_0_only + LGPL v | v == version [2, 1] -> spdx SPDX.LGPL_2_1_only + LGPL v | v == version [3] -> spdx SPDX.LGPL_3_0_only + AGPL v | v == version [3] -> spdx SPDX.AGPL_3_0_only + BSD2 -> spdx SPDX.BSD_2_Clause + BSD3 -> spdx SPDX.BSD_3_Clause + BSD4 -> spdx SPDX.BSD_4_Clause + MIT -> spdx SPDX.MIT + ISC -> spdx SPDX.ISC + MPL v | v == mkVersion [2, 0] -> spdx SPDX.MPL_2_0 + Apache v | v == version [2, 0] -> spdx SPDX.Apache_2_0 + AllRightsReserved -> SPDX.NONE + UnspecifiedLicense -> SPDX.NONE + OtherLicense -> ref (SPDX.mkLicenseRef' Nothing "OtherLicense") + PublicDomain -> ref (SPDX.mkLicenseRef' Nothing "PublicDomain") + UnknownLicense str -> ref (SPDX.mkLicenseRef' Nothing str) + _ -> ref (SPDX.mkLicenseRef' Nothing $ prettyShow l) where version = Just . mkVersion - spdx = SPDX.License . SPDX.simpleLicenseExpression - ref r = SPDX.License $ SPDX.ELicense (SPDX.ELicenseRef r) Nothing + spdx = SPDX.License . SPDX.simpleLicenseExpression + ref r = SPDX.License $ SPDX.ELicense (SPDX.ELicenseRef r) Nothing -- | Convert 'SPDX.License' to 'License', -- @@ -199,11 +198,13 @@ licenseToSPDX l = case l of licenseFromSPDX :: SPDX.License -> License licenseFromSPDX SPDX.NONE = AllRightsReserved licenseFromSPDX l = - fromMaybe (mungle $ prettyShow l) $ Map.lookup l m + fromMaybe (mungle $ prettyShow l) $ Map.lookup l m where m :: Map.Map SPDX.License License - m = Map.fromList $ filter (isSimple . fst ) $ - map (\x -> (licenseToSPDX x, x)) knownLicenses + m = + Map.fromList $ + filter (isSimple . fst) $ + map (\x -> (licenseToSPDX x, x)) knownLicenses isSimple (SPDX.License (SPDX.ELicense (SPDX.ELicenseId _) Nothing)) = True isSimple _ = False @@ -211,41 +212,43 @@ licenseFromSPDX l = mungle name = fromMaybe (UnknownLicense (mapMaybe mangle name)) (simpleParsec name) mangle c - | isAlphaNum c = Just c - | otherwise = Nothing + | isAlphaNum c = Just c + | otherwise = Nothing instance Pretty License where - pretty (GPL version) = Disp.text "GPL" <<>> dispOptVersion version - pretty (LGPL version) = Disp.text "LGPL" <<>> dispOptVersion version - pretty (AGPL version) = Disp.text "AGPL" <<>> dispOptVersion version - pretty (MPL version) = Disp.text "MPL" <<>> dispVersion version - pretty (Apache version) = Disp.text "Apache" <<>> dispOptVersion version + pretty (GPL version) = Disp.text "GPL" <<>> dispOptVersion version + pretty (LGPL version) = Disp.text "LGPL" <<>> dispOptVersion version + pretty (AGPL version) = Disp.text "AGPL" <<>> dispOptVersion version + pretty (MPL version) = Disp.text "MPL" <<>> dispVersion version + pretty (Apache version) = Disp.text "Apache" <<>> dispOptVersion version pretty (UnknownLicense other) = Disp.text other - pretty other = Disp.text (show other) + pretty other = Disp.text (show other) instance Parsec License where parsec = do - name <- P.munch1 isAlphaNum + name <- P.munch1 isAlphaNum version <- P.optional (P.char '-' *> parsec) return $! case (name, version :: Maybe Version) of - ("GPL", _ ) -> GPL version - ("LGPL", _ ) -> LGPL version - ("AGPL", _ ) -> AGPL version - ("BSD2", Nothing) -> BSD2 - ("BSD3", Nothing) -> BSD3 - ("BSD4", Nothing) -> BSD4 - ("ISC", Nothing) -> ISC - ("MIT", Nothing) -> MIT - ("MPL", Just version') -> MPL version' - ("Apache", _ ) -> Apache version - ("PublicDomain", Nothing) -> PublicDomain - ("AllRightsReserved", Nothing) -> AllRightsReserved - ("OtherLicense", Nothing) -> OtherLicense - _ -> UnknownLicense $ name ++ - maybe "" (('-':) . prettyShow) version + ("GPL", _) -> GPL version + ("LGPL", _) -> LGPL version + ("AGPL", _) -> AGPL version + ("BSD2", Nothing) -> BSD2 + ("BSD3", Nothing) -> BSD3 + ("BSD4", Nothing) -> BSD4 + ("ISC", Nothing) -> ISC + ("MIT", Nothing) -> MIT + ("MPL", Just version') -> MPL version' + ("Apache", _) -> Apache version + ("PublicDomain", Nothing) -> PublicDomain + ("AllRightsReserved", Nothing) -> AllRightsReserved + ("OtherLicense", Nothing) -> OtherLicense + _ -> + UnknownLicense $ + name + ++ maybe "" (('-' :) . prettyShow) version dispOptVersion :: Maybe Version -> Disp.Doc -dispOptVersion Nothing = Disp.empty +dispOptVersion Nothing = Disp.empty dispOptVersion (Just v) = dispVersion v dispVersion :: Version -> Disp.Doc diff --git a/Cabal-syntax/src/Distribution/ModuleName.hs b/Cabal-syntax/src/Distribution/ModuleName.hs index f23050f296a..90082d29f06 100644 --- a/Cabal-syntax/src/Distribution/ModuleName.hs +++ b/Cabal-syntax/src/Distribution/ModuleName.hs @@ -1,8 +1,10 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.ModuleName -- Copyright : Duncan Coutts 2008 @@ -12,16 +14,16 @@ -- Portability : portable -- -- Data type for Haskell module names. - -module Distribution.ModuleName ( - ModuleName, - fromString, - fromComponents, - components, - toFilePath, - main, - -- * Internal - validModuleComponent, +module Distribution.ModuleName + ( ModuleName + , fromString + , fromComponents + , components + , toFilePath + , main + + -- * Internal + , validModuleComponent ) where import Distribution.Compat.Prelude @@ -30,14 +32,13 @@ import Prelude () import Distribution.Parsec import Distribution.Pretty import Distribution.Utils.ShortText (ShortText, fromShortText, toShortText) -import System.FilePath (pathSeparator) +import System.FilePath (pathSeparator) import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.Compat.DList as DList -import qualified Text.PrettyPrint as Disp +import qualified Distribution.Compat.DList as DList +import qualified Text.PrettyPrint as Disp -- | A valid Haskell module name. --- newtype ModuleName = ModuleName ShortText deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) @@ -48,16 +49,17 @@ instance Binary ModuleName instance Structured ModuleName instance NFData ModuleName where - rnf (ModuleName ms) = rnf ms + rnf (ModuleName ms) = rnf ms instance Pretty ModuleName where pretty = Disp.text . unModuleName instance Parsec ModuleName where - parsec = parsecModuleName + parsec = parsecModuleName parsecModuleName :: forall m. CabalParsing m => m ModuleName -parsecModuleName = state0 DList.empty where +parsecModuleName = state0 DList.empty + where upper :: m Char !upper = P.satisfy isUpper @@ -69,34 +71,33 @@ parsecModuleName = state0 DList.empty where state0 :: DList.DList Char -> m ModuleName state0 acc = do - c <- upper - state1 (DList.snoc acc c) + c <- upper + state1 (DList.snoc acc c) state1 :: DList.DList Char -> m ModuleName state1 acc = state1' acc `alt` return (fromString (DList.toList acc)) state1' :: DList.DList Char -> m ModuleName state1' acc = do - c <- ch - case c of - '.' -> state0 (DList.snoc acc c) - _ -> state1 (DList.snoc acc c) + c <- ch + case c of + '.' -> state0 (DList.snoc acc c) + _ -> state1 (DList.snoc acc c) validModuleChar :: Char -> Bool validModuleChar c = isAlphaNum c || c == '_' || c == '\'' validModuleComponent :: String -> Bool -validModuleComponent [] = False -validModuleComponent (c:cs) = isUpper c && all validModuleChar cs +validModuleComponent [] = False +validModuleComponent (c : cs) = isUpper c && all validModuleChar cs -- | Construct a 'ModuleName' from a valid module name 'String'. -- -- This is just a convenience function intended for valid module strings. It is -- an error if it is used with a string that is not a valid module name. If you -- are parsing user input then use 'Distribution.Text.simpleParse' instead. --- instance IsString ModuleName where - fromString = ModuleName . toShortText + fromString = ModuleName . toShortText -- | Construct a 'ModuleName' from valid module components, i.e. parts -- separated by dots. @@ -105,27 +106,25 @@ fromComponents comps = fromString (intercalate "." comps) {-# DEPRECATED fromComponents "Exists for cabal-install only" #-} -- | The module name @Main@. --- main :: ModuleName main = ModuleName (fromString "Main") -- | The individual components of a hierarchical module name. For example -- -- > components (fromString "A.B.C") = ["A", "B", "C"] --- components :: ModuleName -> [String] components mn = split (unModuleName mn) where - split cs = case break (=='.') cs of - (chunk,[]) -> chunk : [] - (chunk,_:rest) -> chunk : split rest + split cs = case break (== '.') cs of + (chunk, []) -> chunk : [] + (chunk, _ : rest) -> chunk : split rest -- | Convert a module name to a file path, but without any file extension. -- For example: -- -- > toFilePath (fromString "A.B.C") = "A/B/C" --- toFilePath :: ModuleName -> FilePath -toFilePath = map f . unModuleName where +toFilePath = map f . unModuleName + where f '.' = pathSeparator - f c = c + f c = c diff --git a/Cabal-syntax/src/Distribution/Package.hs b/Cabal-syntax/src/Distribution/Package.hs index 6c2950b26f0..c4f20349391 100644 --- a/Cabal-syntax/src/Distribution/Package.hs +++ b/Cabal-syntax/src/Distribution/Package.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Package -- Copyright : Isaac Jones 2003-2004 @@ -15,7 +16,6 @@ -- 'PackageIdentifier's consist of a name and an exact version. It also defines -- a 'Dependency' data type. A dependency is a package name and a version -- range, like @\"foo >= 1.2 && < 2\"@. - module Distribution.Package ( module Distribution.Types.AbiHash , module Distribution.Types.ComponentId @@ -25,28 +25,33 @@ module Distribution.Package , module Distribution.Types.PackageName , module Distribution.Types.PkgconfigName , module Distribution.Types.Dependency - , Package(..), packageName, packageVersion - , HasMungedPackageId(..), mungedName', mungedVersion' - , HasUnitId(..) - , PackageInstalled(..) + , Package (..) + , packageName + , packageVersion + , HasMungedPackageId (..) + , mungedName' + , mungedVersion' + , HasUnitId (..) + , PackageInstalled (..) ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Version - ( Version ) + ( Version + ) import Distribution.Types.AbiHash import Distribution.Types.ComponentId import Distribution.Types.Dependency -import Distribution.Types.MungedPackageId -import Distribution.Types.PackageId -import Distribution.Types.UnitId import Distribution.Types.Module +import Distribution.Types.MungedPackageId import Distribution.Types.MungedPackageName +import Distribution.Types.PackageId import Distribution.Types.PackageName import Distribution.Types.PkgconfigName +import Distribution.Types.UnitId -- | Class of things that have a 'PackageIdentifier' -- @@ -57,15 +62,14 @@ import Distribution.Types.PkgconfigName -- Not all kinds of packages can be uniquely identified by a -- 'PackageIdentifier'. In particular, installed packages cannot, there may be -- many installed instances of the same source package. --- class Package pkg where - packageId :: pkg -> PackageIdentifier + packageId :: pkg -> PackageIdentifier -mungedName' :: HasMungedPackageId pkg => pkg -> MungedPackageName -mungedName' = mungedName . mungedId +mungedName' :: HasMungedPackageId pkg => pkg -> MungedPackageName +mungedName' = mungedName . mungedId mungedVersion' :: HasMungedPackageId munged => munged -> Version -mungedVersion' = mungedVersion . mungedId +mungedVersion' = mungedVersion . mungedId class HasMungedPackageId pkg where mungedId :: pkg -> MungedPackageId @@ -73,11 +77,11 @@ class HasMungedPackageId pkg where instance Package PackageIdentifier where packageId = id -packageName :: Package pkg => pkg -> PackageName -packageName = pkgName . packageId +packageName :: Package pkg => pkg -> PackageName +packageName = pkgName . packageId packageVersion :: Package pkg => pkg -> Version -packageVersion = pkgVersion . packageId +packageVersion = pkgVersion . packageId instance HasMungedPackageId MungedPackageId where mungedId = id @@ -92,5 +96,5 @@ class Package pkg => HasUnitId pkg where -- 'InstalledPackageInfo', but when we are doing install plans in Cabal install -- we may have other, installed package-like things which contain more metadata. -- Installed packages have exact dependencies 'installedDepends'. -class (HasUnitId pkg) => PackageInstalled pkg where +class HasUnitId pkg => PackageInstalled pkg where installedDepends :: pkg -> [UnitId] diff --git a/Cabal-syntax/src/Distribution/PackageDescription.hs b/Cabal-syntax/src/Distribution/PackageDescription.hs index 7da966e85b7..47d46673e5f 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.PackageDescription -- Copyright : Isaac Jones 2003-2005 @@ -9,67 +10,81 @@ -- -- Backwards compatibility reexport of most things you need to know -- about @.cabal@ files. +module Distribution.PackageDescription + ( -- * PD and GPD + module Distribution.Types.PackageDescription + , module Distribution.Types.GenericPackageDescription -module Distribution.PackageDescription ( - -- * PD and GPD - module Distribution.Types.PackageDescription, - module Distribution.Types.GenericPackageDescription, -- * Components - module Distribution.Types.ComponentName, + , module Distribution.Types.ComponentName + -- ** Library - module Distribution.Types.Library, - module Distribution.Types.LibraryName, - module Distribution.Types.LibraryVisibility, + , module Distribution.Types.Library + , module Distribution.Types.LibraryName + , module Distribution.Types.LibraryVisibility + -- ** Executable - module Distribution.Types.Executable, - module Distribution.Types.ExecutableScope, + , module Distribution.Types.Executable + , module Distribution.Types.ExecutableScope + -- ** TestSuite - module Distribution.Types.TestSuite, - module Distribution.Types.TestType, - module Distribution.Types.TestSuiteInterface, + , module Distribution.Types.TestSuite + , module Distribution.Types.TestType + , module Distribution.Types.TestSuiteInterface + -- ** Benchmark - module Distribution.Types.Benchmark, - module Distribution.Types.BenchmarkType, - module Distribution.Types.BenchmarkInterface, + , module Distribution.Types.Benchmark + , module Distribution.Types.BenchmarkType + , module Distribution.Types.BenchmarkInterface + -- ** Foreign library - module Distribution.Types.ForeignLib, - module Distribution.Types.ForeignLibType, - module Distribution.Types.ForeignLibOption, + , module Distribution.Types.ForeignLib + , module Distribution.Types.ForeignLibType + , module Distribution.Types.ForeignLibOption + -- * BuildInfo - module Distribution.Types.BuildType, - module Distribution.Types.BuildInfo, - module Distribution.Types.HookedBuildInfo, - module Distribution.Types.SetupBuildInfo, + , module Distribution.Types.BuildType + , module Distribution.Types.BuildInfo + , module Distribution.Types.HookedBuildInfo + , module Distribution.Types.SetupBuildInfo + -- * Flags - module Distribution.Types.Flag, + , module Distribution.Types.Flag + -- * Identifiers - module Distribution.Types.PackageId, - module Distribution.Types.PackageName, - module Distribution.Types.UnqualComponentName, + , module Distribution.Types.PackageId + , module Distribution.Types.PackageName + , module Distribution.Types.UnqualComponentName + -- * Pkgconfig - module Distribution.Types.PkgconfigName, - module Distribution.Types.PkgconfigVersion, - module Distribution.Types.PkgconfigVersionRange, + , module Distribution.Types.PkgconfigName + , module Distribution.Types.PkgconfigVersion + , module Distribution.Types.PkgconfigVersionRange + -- * Dependencies - module Distribution.Types.Dependency, - module Distribution.Types.ExeDependency, - module Distribution.Types.LegacyExeDependency, - module Distribution.Types.PkgconfigDependency, + , module Distribution.Types.Dependency + , module Distribution.Types.ExeDependency + , module Distribution.Types.LegacyExeDependency + , module Distribution.Types.PkgconfigDependency + -- * Condition trees - module Distribution.Types.CondTree, - module Distribution.Types.Condition, - module Distribution.Types.ConfVar, + , module Distribution.Types.CondTree + , module Distribution.Types.Condition + , module Distribution.Types.ConfVar + -- * Mixin - module Distribution.Types.IncludeRenaming, - module Distribution.Types.Mixin, - module Distribution.Types.ModuleReexport, - module Distribution.Types.ModuleRenaming, + , module Distribution.Types.IncludeRenaming + , module Distribution.Types.Mixin + , module Distribution.Types.ModuleReexport + , module Distribution.Types.ModuleRenaming + -- * Source repository - module Distribution.Types.SourceRepo, + , module Distribution.Types.SourceRepo ) where import Prelude () ---import Distribution.Compat.Prelude + +-- import Distribution.Compat.Prelude import Distribution.Types.Benchmark import Distribution.Types.BenchmarkInterface @@ -77,13 +92,13 @@ import Distribution.Types.BenchmarkType import Distribution.Types.BuildInfo import Distribution.Types.BuildType import Distribution.Types.ComponentName -import Distribution.Types.Condition import Distribution.Types.CondTree +import Distribution.Types.Condition import Distribution.Types.ConfVar import Distribution.Types.Dependency +import Distribution.Types.ExeDependency import Distribution.Types.Executable import Distribution.Types.ExecutableScope -import Distribution.Types.ExeDependency import Distribution.Types.Flag import Distribution.Types.ForeignLib import Distribution.Types.ForeignLibOption diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs b/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs index b9bb9dcb555..9a9ba2d7500 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs @@ -1,6 +1,8 @@ -- -fno-warn-deprecations for use of Map.foldWithKey {-# OPTIONS_GHC -fno-warn-deprecations #-} + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.PackageDescription.Configuration -- Copyright : Thomas Schilling, 2007 @@ -14,76 +16,78 @@ -- functions for converting 'GenericPackageDescription's down to -- 'PackageDescription's. It has code for working with the tree of conditions -- and resolving or flattening conditions. - -module Distribution.PackageDescription.Configuration ( - finalizePD, - flattenPackageDescription, - - -- Utils - parseCondition, - freeVars, - extractCondition, - extractConditions, - addBuildableCondition, - mapCondTree, - mapTreeData, - mapTreeConds, - mapTreeConstrs, - transformAllBuildInfos, - transformAllBuildDepends, - transformAllBuildDependsN, - simplifyWithSysParams +module Distribution.PackageDescription.Configuration + ( finalizePD + , flattenPackageDescription + -- Utils + , parseCondition + , freeVars + , extractCondition + , extractConditions + , addBuildableCondition + , mapCondTree + , mapTreeData + , mapTreeConds + , mapTreeConstrs + , transformAllBuildInfos + , transformAllBuildDepends + , transformAllBuildDependsN + , simplifyWithSysParams ) where import Distribution.Compat.Prelude import Prelude () -- lens -import qualified Distribution.Types.BuildInfo.Lens as L +import qualified Distribution.Types.BuildInfo.Lens as L import qualified Distribution.Types.GenericPackageDescription.Lens as L -import qualified Distribution.Types.PackageDescription.Lens as L -import qualified Distribution.Types.SetupBuildInfo.Lens as L - -import Distribution.Compat.CharParsing hiding (char) -import qualified Distribution.Compat.CharParsing as P -import Distribution.Compat.Lens -import Distribution.Compiler -import Distribution.PackageDescription -import Distribution.PackageDescription.Utils -import Distribution.Parsec -import Distribution.Pretty -import Distribution.System -import Distribution.Types.Component +import qualified Distribution.Types.PackageDescription.Lens as L +import qualified Distribution.Types.SetupBuildInfo.Lens as L + +import Distribution.Compat.CharParsing hiding (char) +import qualified Distribution.Compat.CharParsing as P +import Distribution.Compat.Lens +import Distribution.Compiler +import Distribution.PackageDescription +import Distribution.PackageDescription.Utils +import Distribution.Parsec +import Distribution.Pretty +import Distribution.System +import Distribution.Types.Component +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.DependencyMap +import Distribution.Types.PackageVersionConstraint +import Distribution.Utils.Generic import Distribution.Utils.Path -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.DependencyMap -import Distribution.Types.PackageVersionConstraint -import Distribution.Utils.Generic -import Distribution.Version +import Distribution.Version import qualified Data.Map.Lazy as Map -import Data.Tree (Tree (Node)) +import Data.Tree (Tree (Node)) ------------------------------------------------------------------------------ -- | Simplify a configuration condition using the OS and arch names. Returns -- the names of all the flags occurring in the condition. -simplifyWithSysParams :: OS -> Arch -> CompilerInfo -> Condition ConfVar - -> (Condition FlagName, [FlagName]) +simplifyWithSysParams + :: OS + -> Arch + -> CompilerInfo + -> Condition ConfVar + -> (Condition FlagName, [FlagName]) simplifyWithSysParams os arch cinfo cond = (cond', flags) where (cond', flags) = simplifyCondition cond interp - interp (OS os') = Right $ os' == os + interp (OS os') = Right $ os' == os interp (Arch arch') = Right $ arch' == arch interp (Impl comp vr) | matchImpl (compilerInfoId cinfo) = Right True | otherwise = case compilerInfoCompat cinfo of -- fixme: treat Nothing as unknown, rather than empty list once we -- support partial resolution of system parameters - Nothing -> Right False + Nothing -> Right False Just compat -> Right (any matchImpl compat) - where - matchImpl (CompilerId c v) = comp == c && v `withinRange` vr + where + matchImpl (CompilerId c v) = comp == c && v `withinRange` vr interp (PackageFlag f) = Left f -- TODO: Add instances and check @@ -107,27 +111,36 @@ simplifyWithSysParams os arch cinfo cond = (cond', flags) parseCondition :: CabalParsing m => m (Condition ConfVar) parseCondition = condOr where - condOr = sepByNonEmpty condAnd (oper "||") >>= return . foldl1 COr - condAnd = sepByNonEmpty cond (oper "&&")>>= return . foldl1 CAnd + condOr = sepByNonEmpty condAnd (oper "||") >>= return . foldl1 COr + condAnd = sepByNonEmpty cond (oper "&&") >>= return . foldl1 CAnd -- TODO: try? - cond = sp >> (boolLiteral <|> inparens condOr <|> notCond <|> osCond - <|> archCond <|> flagCond <|> implCond ) - inparens = between (P.char '(' >> sp) (sp >> P.char ')' >> sp) - notCond = P.char '!' >> sp >> cond >>= return . CNot - osCond = string "os" >> sp >> inparens osIdent >>= return . Var + cond = + sp + >> ( boolLiteral + <|> inparens condOr + <|> notCond + <|> osCond + <|> archCond + <|> flagCond + <|> implCond + ) + inparens = between (P.char '(' >> sp) (sp >> P.char ')' >> sp) + notCond = P.char '!' >> sp >> cond >>= return . CNot + osCond = string "os" >> sp >> inparens osIdent >>= return . Var archCond = string "arch" >> sp >> inparens archIdent >>= return . Var flagCond = string "flag" >> sp >> inparens flagIdent >>= return . Var implCond = string "impl" >> sp >> inparens implIdent >>= return . Var - boolLiteral = fmap Lit parsec - archIdent = fmap Arch parsec - osIdent = fmap OS parsec - flagIdent = fmap (PackageFlag . mkFlagName . lowercase) (munch1 isIdentChar) + boolLiteral = fmap Lit parsec + archIdent = fmap Arch parsec + osIdent = fmap OS parsec + flagIdent = fmap (PackageFlag . mkFlagName . lowercase) (munch1 isIdentChar) isIdentChar c = isAlphaNum c || c == '_' || c == '-' - oper s = sp >> string s >> sp - sp = spaces - implIdent = do i <- parsec - vr <- sp >> option anyVersion parsec - return $ Impl i vr + oper s = sp >> string s >> sp + sp = spaces + implIdent = do + i <- parsec + vr <- sp >> option anyVersion parsec + return $ Impl i vr ------------------------------------------------------------------------------ @@ -136,14 +149,13 @@ parseCondition = condOr data DepTestRslt d = DepOk | MissingDeps d instance Semigroup d => Monoid (DepTestRslt d) where - mempty = DepOk - mappend = (<>) + mempty = DepOk + mappend = (<>) instance Semigroup d => Semigroup (DepTestRslt d) where - DepOk <> x = x - x <> DepOk = x - (MissingDeps d) <> (MissingDeps d') = MissingDeps (d <> d') - + DepOk <> x = x + x <> DepOk = x + (MissingDeps d) <> (MissingDeps d') = MissingDeps (d <> d') -- | Try to find a flag assignment that satisfies the constraints of all trees. -- @@ -165,64 +177,75 @@ instance Semigroup d => Semigroup (DepTestRslt d) where -- -- This would require some sort of SAT solving, though, thus it's not -- implemented unless we really need it. --- -resolveWithFlags :: - [(FlagName,[Bool])] - -- ^ Domain for each flag name, will be tested in order. +resolveWithFlags + :: [(FlagName, [Bool])] + -- ^ Domain for each flag name, will be tested in order. -> ComponentRequestedSpec - -> OS -- ^ OS where the installed artifacts will run (host OS) - -> Arch -- ^ Arch where the installed artifacts will run (host Arch) - -> CompilerInfo -- ^ Compiler information - -> [PackageVersionConstraint] -- ^ Additional constraints + -> OS + -- ^ OS where the installed artifacts will run (host OS) + -> Arch + -- ^ Arch where the installed artifacts will run (host Arch) + -> CompilerInfo + -- ^ Compiler information + -> [PackageVersionConstraint] + -- ^ Additional constraints -> [CondTree ConfVar [Dependency] PDTagged] - -> ([Dependency] -> DepTestRslt [Dependency]) -- ^ Dependency test function. + -> ([Dependency] -> DepTestRslt [Dependency]) + -- ^ Dependency test function. -> Either [Dependency] (TargetSet PDTagged, FlagAssignment) - -- ^ Either the missing dependencies (error case), or a pair of - -- (set of build targets with dependencies, chosen flag assignments) + -- ^ Either the missing dependencies (error case), or a pair of + -- (set of build targets with dependencies, chosen flag assignments) resolveWithFlags dom enabled os arch impl constrs trees checkDeps = - either (Left . fromDepMapUnion) Right $ explore (build mempty dom) + either (Left . fromDepMapUnion) Right $ explore (build mempty dom) where -- simplify trees by (partially) evaluating all conditions and converting -- dependencies to dependency maps. simplifiedTrees :: [CondTree FlagName DependencyMap PDTagged] - simplifiedTrees = map ( mapTreeConstrs toDepMap -- convert to maps - . addBuildableConditionPDTagged - . mapTreeConds (fst . simplifyWithSysParams os arch impl)) - trees + simplifiedTrees = + map + ( mapTreeConstrs toDepMap -- convert to maps + . addBuildableConditionPDTagged + . mapTreeConds (fst . simplifyWithSysParams os arch impl) + ) + trees -- @explore@ searches a tree of assignments, backtracking whenever a flag -- introduces a dependency that cannot be satisfied. If there is no -- solution, @explore@ returns the union of all dependencies that caused -- it to backtrack. Since the tree is constructed lazily, we avoid some -- computation overhead in the successful case. - explore :: Tree FlagAssignment - -> Either DepMapUnion (TargetSet PDTagged, FlagAssignment) + explore + :: Tree FlagAssignment + -> Either DepMapUnion (TargetSet PDTagged, FlagAssignment) explore (Node flags ts) = - let targetSet = TargetSet $ flip map simplifiedTrees $ + let targetSet = + TargetSet $ + flip map simplifiedTrees $ -- apply additional constraints to all dependencies - first (`constrainBy` constrs) . - simplifyCondTree (env flags) - deps = overallDependencies enabled targetSet - in case checkDeps (fromDepMap deps) of - DepOk | null ts -> Right (targetSet, flags) - | otherwise -> tryAll $ map explore ts - MissingDeps mds -> Left (toDepMapUnion mds) + first (`constrainBy` constrs) + . simplifyCondTree (env flags) + deps = overallDependencies enabled targetSet + in case checkDeps (fromDepMap deps) of + DepOk + | null ts -> Right (targetSet, flags) + | otherwise -> tryAll $ map explore ts + MissingDeps mds -> Left (toDepMapUnion mds) -- Builds a tree of all possible flag assignments. Internal nodes -- have only partial assignments. build :: FlagAssignment -> [(FlagName, [Bool])] -> Tree FlagAssignment build assigned [] = Node assigned [] build assigned ((fn, vals) : unassigned) = - Node assigned $ map (\v -> build (insertFlagAssignment fn v assigned) unassigned) vals + Node assigned $ map (\v -> build (insertFlagAssignment fn v assigned) unassigned) vals tryAll :: [Either DepMapUnion a] -> Either DepMapUnion a tryAll = foldr mp mz -- special version of `mplus' for our local purposes mp :: Either DepMapUnion a -> Either DepMapUnion a -> Either DepMapUnion a - mp m@(Right _) _ = m - mp _ m@(Right _) = m - mp (Left xs) (Left ys) = Left (xs <> ys) + mp m@(Right _) _ = m + mp _ m@(Right _) = m + mp (Left xs) (Left ys) = Left (xs <> ys) -- `mzero' mz :: Either DepMapUnion a @@ -235,14 +258,16 @@ resolveWithFlags dom enabled os arch impl constrs trees checkDeps = -- conditional that is True when Buildable is True. If 'addBuildableCondition' -- can determine that Buildable is always True, it returns the input unchanged. -- If Buildable is always False, it returns the empty 'CondTree'. -addBuildableCondition :: (Eq v, Monoid a, Monoid c) => (a -> BuildInfo) - -> CondTree v c a - -> CondTree v c a +addBuildableCondition + :: (Eq v, Monoid a, Monoid c) + => (a -> BuildInfo) + -> CondTree v c a + -> CondTree v c a addBuildableCondition getInfo t = case extractCondition (buildable . getInfo) t of - Lit True -> t + Lit True -> t Lit False -> CondNode mempty mempty [] - c -> CondNode mempty mempty [condIfThen c t] + c -> CondNode mempty mempty [condIfThen c t] -- | This is a special version of 'addBuildableCondition' for the 'PDTagged' -- type. @@ -253,15 +278,15 @@ addBuildableCondition getInfo t = -- completely deleting components that are not buildable. -- -- See for more details. --- -addBuildableConditionPDTagged :: (Eq v, Monoid c) => - CondTree v c PDTagged - -> CondTree v c PDTagged +addBuildableConditionPDTagged + :: (Eq v, Monoid c) + => CondTree v c PDTagged + -> CondTree v c PDTagged addBuildableConditionPDTagged t = - case extractCondition (buildable . getInfo) t of - Lit True -> t - Lit False -> deleteConstraints t - c -> CondNode mempty mempty [condIfThenElse c t (deleteConstraints t)] + case extractCondition (buildable . getInfo) t of + Lit True -> t + Lit False -> deleteConstraints t + c -> CondNode mempty mempty [condIfThenElse c t (deleteConstraints t)] where deleteConstraints = mapTreeConstrs (const mempty) @@ -270,7 +295,6 @@ addBuildableConditionPDTagged t = getInfo (SubComp _ c) = componentBuildInfo c getInfo PDNull = mempty - -- Note: extracting buildable conditions. -- -------------------------------------- -- @@ -286,52 +310,52 @@ addBuildableConditionPDTagged t = -- | Extract conditions matched by the given predicate from all cond trees in a -- 'GenericPackageDescription'. -extractConditions :: (BuildInfo -> Bool) -> GenericPackageDescription - -> [Condition ConfVar] +extractConditions + :: (BuildInfo -> Bool) + -> GenericPackageDescription + -> [Condition ConfVar] extractConditions f gpkg = - concat [ - extractCondition (f . libBuildInfo) <$> maybeToList (condLibrary gpkg) - , extractCondition (f . libBuildInfo) . snd <$> condSubLibraries gpkg - , extractCondition (f . buildInfo) . snd <$> condExecutables gpkg - , extractCondition (f . testBuildInfo) . snd <$> condTestSuites gpkg - , extractCondition (f . benchmarkBuildInfo) . snd <$> condBenchmarks gpkg + concat + [ extractCondition (f . libBuildInfo) <$> maybeToList (condLibrary gpkg) + , extractCondition (f . libBuildInfo) . snd <$> condSubLibraries gpkg + , extractCondition (f . buildInfo) . snd <$> condExecutables gpkg + , extractCondition (f . testBuildInfo) . snd <$> condTestSuites gpkg + , extractCondition (f . benchmarkBuildInfo) . snd <$> condBenchmarks gpkg ] - -- | A map of package constraints that combines version ranges using 'unionVersionRanges'. -newtype DepMapUnion = DepMapUnion { unDepMapUnion :: Map PackageName (VersionRange, NonEmptySet LibraryName) } +newtype DepMapUnion = DepMapUnion {unDepMapUnion :: Map PackageName (VersionRange, NonEmptySet LibraryName)} instance Semigroup DepMapUnion where - DepMapUnion x <> DepMapUnion y = DepMapUnion $ - Map.unionWith unionVersionRanges' x y + DepMapUnion x <> DepMapUnion y = + DepMapUnion $ + Map.unionWith unionVersionRanges' x y unionVersionRanges' - :: (VersionRange, NonEmptySet LibraryName) - -> (VersionRange, NonEmptySet LibraryName) - -> (VersionRange, NonEmptySet LibraryName) + :: (VersionRange, NonEmptySet LibraryName) + -> (VersionRange, NonEmptySet LibraryName) + -> (VersionRange, NonEmptySet LibraryName) unionVersionRanges' (vr, cs) (vr', cs') = (unionVersionRanges vr vr', cs <> cs') toDepMapUnion :: [Dependency] -> DepMapUnion toDepMapUnion ds = - DepMapUnion $ Map.fromListWith unionVersionRanges' [ (p,(vr,cs)) | Dependency p vr cs <- ds ] - + DepMapUnion $ Map.fromListWith unionVersionRanges' [(p, (vr, cs)) | Dependency p vr cs <- ds] fromDepMapUnion :: DepMapUnion -> [Dependency] -fromDepMapUnion m = [ Dependency p vr cs | (p,(vr,cs)) <- Map.toList (unDepMapUnion m) ] +fromDepMapUnion m = [Dependency p vr cs | (p, (vr, cs)) <- Map.toList (unDepMapUnion m)] -freeVars :: CondTree ConfVar c a -> [FlagName] -freeVars t = [ f | PackageFlag f <- freeVars' t ] +freeVars :: CondTree ConfVar c a -> [FlagName] +freeVars t = [f | PackageFlag f <- freeVars' t] where freeVars' (CondNode _ _ ifs) = concatMap compfv ifs compfv (CondBranch c ct mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct condfv c = case c of - Var v -> [v] - Lit _ -> [] - CNot c' -> condfv c' - COr c1 c2 -> condfv c1 ++ condfv c2 + Var v -> [v] + Lit _ -> [] + CNot c' -> condfv c' + COr c1 c2 -> condfv c1 ++ condfv c2 CAnd c1 c2 -> condfv c1 ++ condfv c2 - ------------------------------------------------------------------------------ -- | A set of targets with their package dependencies @@ -347,55 +371,58 @@ overallDependencies enabled (TargetSet targets) = mconcat depss -- UGH. The embedded componentName in the 'Component's here is -- BLANK. I don't know whose fault this is but I'll use the tag -- instead. -- ezyang - removeDisabledSections (Lib _) = componentNameRequested - enabled - (CLibName LMainLibName) - removeDisabledSections (SubComp t c) - -- Do NOT use componentName - = componentNameRequested enabled - $ case c of - CLib _ -> CLibName (LSubLibName t) - CFLib _ -> CFLibName t - CExe _ -> CExeName t - CTest _ -> CTestName t - CBench _ -> CBenchName t - removeDisabledSections PDNull = True + removeDisabledSections (Lib _) = + componentNameRequested + enabled + (CLibName LMainLibName) + removeDisabledSections (SubComp t c) = + -- Do NOT use componentName + componentNameRequested enabled $ + case c of + CLib _ -> CLibName (LSubLibName t) + CFLib _ -> CFLibName t + CExe _ -> CExeName t + CTest _ -> CTestName t + CBench _ -> CBenchName t + removeDisabledSections PDNull = True -- | Collect up the targets in a TargetSet of tagged targets, storing the -- dependencies as we go. flattenTaggedTargets :: TargetSet PDTagged -> (Maybe Library, [(UnqualComponentName, Component)]) -flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets where - untag (depMap, pdTagged) accum = case (pdTagged, accum) of - (Lib _, (Just _, _)) -> userBug "Only one library expected" - (Lib l, (Nothing, comps)) -> (Just $ redoBD l, comps) - (SubComp n c, (mb_lib, comps)) - | any ((== n) . fst) comps -> - userBug $ "There exist several components with the same name: '" ++ prettyShow n ++ "'" - | otherwise -> (mb_lib, (n, redoBD c) : comps) - (PDNull, x) -> x -- actually this should not happen, but let's be liberal - where - redoBD :: L.HasBuildInfo a => a -> a - redoBD = set L.targetBuildDepends $ fromDepMap depMap +flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets + where + untag (depMap, pdTagged) accum = case (pdTagged, accum) of + (Lib _, (Just _, _)) -> userBug "Only one library expected" + (Lib l, (Nothing, comps)) -> (Just $ redoBD l, comps) + (SubComp n c, (mb_lib, comps)) + | any ((== n) . fst) comps -> + userBug $ "There exist several components with the same name: '" ++ prettyShow n ++ "'" + | otherwise -> (mb_lib, (n, redoBD c) : comps) + (PDNull, x) -> x -- actually this should not happen, but let's be liberal + where + redoBD :: L.HasBuildInfo a => a -> a + redoBD = set L.targetBuildDepends $ fromDepMap depMap ------------------------------------------------------------------------------ -- Convert GenericPackageDescription to PackageDescription -- -data PDTagged = Lib Library - | SubComp UnqualComponentName Component - | PDNull - deriving Show +data PDTagged + = Lib Library + | SubComp UnqualComponentName Component + | PDNull + deriving (Show) instance Monoid PDTagged where - mempty = PDNull - mappend = (<>) + mempty = PDNull + mappend = (<>) instance Semigroup PDTagged where - PDNull <> x = x - x <> PDNull = x - Lib l <> Lib l' = Lib (l <> l') - SubComp n x <> SubComp n' x' | n == n' = SubComp n (x <> x') - _ <> _ = cabalBug "Cannot combine incompatible tags" + PDNull <> x = x + x <> PDNull = x + Lib l <> Lib l' = Lib (l <> l') + SubComp n x <> SubComp n' x' | n == n' = SubComp n (x <> x') + _ <> _ = cabalBug "Cannot combine incompatible tags" -- | Create a package description with all configurations resolved. -- @@ -422,66 +449,87 @@ instance Semigroup PDTagged where -- Note that this drops any stanzas which have @buildable: False@. While -- this is arguably the right thing to do, it means we give bad error -- messages in some situations, see #3858. --- -finalizePD :: - FlagAssignment -- ^ Explicitly specified flag assignments +finalizePD + :: FlagAssignment + -- ^ Explicitly specified flag assignments -> ComponentRequestedSpec - -> (Dependency -> Bool) -- ^ Is a given dependency satisfiable from the set of - -- available packages? If this is unknown then use - -- True. - -> Platform -- ^ The 'Arch' and 'OS' - -> CompilerInfo -- ^ Compiler information - -> [PackageVersionConstraint] -- ^ Additional constraints + -> (Dependency -> Bool) + -- ^ Is a given dependency satisfiable from the set of + -- available packages? If this is unknown then use + -- True. + -> Platform + -- ^ The 'Arch' and 'OS' + -> CompilerInfo + -- ^ Compiler information + -> [PackageVersionConstraint] + -- ^ Additional constraints -> GenericPackageDescription - -> Either [Dependency] - (PackageDescription, FlagAssignment) - -- ^ Either missing dependencies or the resolved package - -- description along with the flag assignments chosen. -finalizePD userflags enabled satisfyDep - (Platform arch os) impl constraints - (GenericPackageDescription pkg _ver flags mb_lib0 sub_libs0 flibs0 exes0 tests0 bms0) = do - (targetSet, flagVals) <- - resolveWithFlags flagChoices enabled os arch impl constraints condTrees check - let - (mb_lib, comps) = flattenTaggedTargets targetSet - mb_lib' = fmap libFillInDefaults mb_lib - comps' = flip map comps $ \(n,c) -> foldComponent - (\l -> CLib (libFillInDefaults l) { libName = LSubLibName n - , libExposed = False }) - (\l -> CFLib (flibFillInDefaults l) { foreignLibName = n }) - (\e -> CExe (exeFillInDefaults e) { exeName = n }) - (\t -> CTest (testFillInDefaults t) { testName = n }) - (\b -> CBench (benchFillInDefaults b) { benchmarkName = n }) - c - (sub_libs', flibs', exes', tests', bms') = partitionComponents comps' - return ( pkg { library = mb_lib' - , subLibraries = sub_libs' - , foreignLibs = flibs' - , executables = exes' - , testSuites = tests' - , benchmarks = bms' - } - , flagVals ) - where - -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data - condTrees = maybeToList (fmap (mapTreeData Lib) mb_lib0) - ++ map (\(name,tree) -> mapTreeData (SubComp name . CLib) tree) sub_libs0 - ++ map (\(name,tree) -> mapTreeData (SubComp name . CFLib) tree) flibs0 - ++ map (\(name,tree) -> mapTreeData (SubComp name . CExe) tree) exes0 - ++ map (\(name,tree) -> mapTreeData (SubComp name . CTest) tree) tests0 - ++ map (\(name,tree) -> mapTreeData (SubComp name . CBench) tree) bms0 - - flagChoices = map (\(MkPackageFlag n _ d manual) -> (n, d2c manual n d)) flags - d2c manual n b = case lookupFlagAssignment n userflags of - Just val -> [val] - Nothing - | manual -> [b] - | otherwise -> [b, not b] - --flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices - check ds = let missingDeps = filter (not . satisfyDep) ds - in if null missingDeps - then DepOk - else MissingDeps missingDeps + -> Either + [Dependency] + (PackageDescription, FlagAssignment) + -- ^ Either missing dependencies or the resolved package + -- description along with the flag assignments chosen. +finalizePD + userflags + enabled + satisfyDep + (Platform arch os) + impl + constraints + (GenericPackageDescription pkg _ver flags mb_lib0 sub_libs0 flibs0 exes0 tests0 bms0) = do + (targetSet, flagVals) <- + resolveWithFlags flagChoices enabled os arch impl constraints condTrees check + let + (mb_lib, comps) = flattenTaggedTargets targetSet + mb_lib' = fmap libFillInDefaults mb_lib + comps' = flip map comps $ \(n, c) -> + foldComponent + ( \l -> + CLib + (libFillInDefaults l) + { libName = LSubLibName n + , libExposed = False + } + ) + (\l -> CFLib (flibFillInDefaults l){foreignLibName = n}) + (\e -> CExe (exeFillInDefaults e){exeName = n}) + (\t -> CTest (testFillInDefaults t){testName = n}) + (\b -> CBench (benchFillInDefaults b){benchmarkName = n}) + c + (sub_libs', flibs', exes', tests', bms') = partitionComponents comps' + return + ( pkg + { library = mb_lib' + , subLibraries = sub_libs' + , foreignLibs = flibs' + , executables = exes' + , testSuites = tests' + , benchmarks = bms' + } + , flagVals + ) + where + -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data + condTrees = + maybeToList (fmap (mapTreeData Lib) mb_lib0) + ++ map (\(name, tree) -> mapTreeData (SubComp name . CLib) tree) sub_libs0 + ++ map (\(name, tree) -> mapTreeData (SubComp name . CFLib) tree) flibs0 + ++ map (\(name, tree) -> mapTreeData (SubComp name . CExe) tree) exes0 + ++ map (\(name, tree) -> mapTreeData (SubComp name . CTest) tree) tests0 + ++ map (\(name, tree) -> mapTreeData (SubComp name . CBench) tree) bms0 + + flagChoices = map (\(MkPackageFlag n _ d manual) -> (n, d2c manual n d)) flags + d2c manual n b = case lookupFlagAssignment n userflags of + Just val -> [val] + Nothing + | manual -> [b] + | otherwise -> [b, not b] + -- flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices + check ds = + let missingDeps = filter (not . satisfyDep) ds + in if null missingDeps + then DepOk + else MissingDeps missingDeps {- let tst_p = (CondNode [1::Int] [Distribution.Package.Dependency "a" AnyVersion] []) @@ -509,31 +557,49 @@ resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribu flattenPackageDescription :: GenericPackageDescription -> PackageDescription flattenPackageDescription (GenericPackageDescription pkg _ _ mlib0 sub_libs0 flibs0 exes0 tests0 bms0) = - pkg { library = mlib - , subLibraries = reverse sub_libs - , foreignLibs = reverse flibs - , executables = reverse exes - , testSuites = reverse tests - , benchmarks = reverse bms - } - where - mlib = f <$> mlib0 - where f lib = (libFillInDefaults . fst . ignoreConditions $ lib) { libName = LMainLibName } - sub_libs = flattenLib <$> sub_libs0 - flibs = flattenFLib <$> flibs0 - exes = flattenExe <$> exes0 - tests = flattenTst <$> tests0 - bms = flattenBm <$> bms0 - flattenLib (n, t) = libFillInDefaults $ (fst $ ignoreConditions t) - { libName = LSubLibName n, libExposed = False } - flattenFLib (n, t) = flibFillInDefaults $ (fst $ ignoreConditions t) - { foreignLibName = n } - flattenExe (n, t) = exeFillInDefaults $ (fst $ ignoreConditions t) - { exeName = n } - flattenTst (n, t) = testFillInDefaults $ (fst $ ignoreConditions t) - { testName = n } - flattenBm (n, t) = benchFillInDefaults $ (fst $ ignoreConditions t) - { benchmarkName = n } + pkg + { library = mlib + , subLibraries = reverse sub_libs + , foreignLibs = reverse flibs + , executables = reverse exes + , testSuites = reverse tests + , benchmarks = reverse bms + } + where + mlib = f <$> mlib0 + where + f lib = (libFillInDefaults . fst . ignoreConditions $ lib){libName = LMainLibName} + sub_libs = flattenLib <$> sub_libs0 + flibs = flattenFLib <$> flibs0 + exes = flattenExe <$> exes0 + tests = flattenTst <$> tests0 + bms = flattenBm <$> bms0 + flattenLib (n, t) = + libFillInDefaults $ + (fst $ ignoreConditions t) + { libName = LSubLibName n + , libExposed = False + } + flattenFLib (n, t) = + flibFillInDefaults $ + (fst $ ignoreConditions t) + { foreignLibName = n + } + flattenExe (n, t) = + exeFillInDefaults $ + (fst $ ignoreConditions t) + { exeName = n + } + flattenTst (n, t) = + testFillInDefaults $ + (fst $ ignoreConditions t) + { testName = n + } + flattenBm (n, t) = + benchFillInDefaults $ + (fst $ ignoreConditions t) + { benchmarkName = n + } -- This is in fact rather a hack. The original version just overrode the -- default values, however, when adding conditions we had to switch to a @@ -543,59 +609,62 @@ flattenPackageDescription -- This is the cleanest way i could think of, that doesn't require -- changing all field parsing functions to return modifiers instead. libFillInDefaults :: Library -> Library -libFillInDefaults lib@(Library { libBuildInfo = bi }) = - lib { libBuildInfo = biFillInDefaults bi } +libFillInDefaults lib@(Library{libBuildInfo = bi}) = + lib{libBuildInfo = biFillInDefaults bi} flibFillInDefaults :: ForeignLib -> ForeignLib -flibFillInDefaults flib@(ForeignLib { foreignLibBuildInfo = bi }) = - flib { foreignLibBuildInfo = biFillInDefaults bi } +flibFillInDefaults flib@(ForeignLib{foreignLibBuildInfo = bi}) = + flib{foreignLibBuildInfo = biFillInDefaults bi} exeFillInDefaults :: Executable -> Executable -exeFillInDefaults exe@(Executable { buildInfo = bi }) = - exe { buildInfo = biFillInDefaults bi } +exeFillInDefaults exe@(Executable{buildInfo = bi}) = + exe{buildInfo = biFillInDefaults bi} testFillInDefaults :: TestSuite -> TestSuite -testFillInDefaults tst@(TestSuite { testBuildInfo = bi }) = - tst { testBuildInfo = biFillInDefaults bi } +testFillInDefaults tst@(TestSuite{testBuildInfo = bi}) = + tst{testBuildInfo = biFillInDefaults bi} benchFillInDefaults :: Benchmark -> Benchmark -benchFillInDefaults bm@(Benchmark { benchmarkBuildInfo = bi }) = - bm { benchmarkBuildInfo = biFillInDefaults bi } +benchFillInDefaults bm@(Benchmark{benchmarkBuildInfo = bi}) = + bm{benchmarkBuildInfo = biFillInDefaults bi} biFillInDefaults :: BuildInfo -> BuildInfo biFillInDefaults bi = - if null (hsSourceDirs bi) - then bi { hsSourceDirs = [sameDirectory] } + if null (hsSourceDirs bi) + then bi{hsSourceDirs = [sameDirectory]} else bi -- Walk a 'GenericPackageDescription' and apply @onBuildInfo@/@onSetupBuildInfo@ -- to all nested 'BuildInfo'/'SetupBuildInfo' values. -transformAllBuildInfos :: (BuildInfo -> BuildInfo) - -> (SetupBuildInfo -> SetupBuildInfo) - -> GenericPackageDescription - -> GenericPackageDescription +transformAllBuildInfos + :: (BuildInfo -> BuildInfo) + -> (SetupBuildInfo -> SetupBuildInfo) + -> GenericPackageDescription + -> GenericPackageDescription transformAllBuildInfos onBuildInfo onSetupBuildInfo = over L.traverseBuildInfos onBuildInfo - . over (L.packageDescription . L.setupBuildInfo . traverse) onSetupBuildInfo + . over (L.packageDescription . L.setupBuildInfo . traverse) onSetupBuildInfo -- | Walk a 'GenericPackageDescription' and apply @f@ to all nested -- @build-depends@ fields. -transformAllBuildDepends :: (Dependency -> Dependency) - -> GenericPackageDescription - -> GenericPackageDescription +transformAllBuildDepends + :: (Dependency -> Dependency) + -> GenericPackageDescription + -> GenericPackageDescription transformAllBuildDepends f = over (L.traverseBuildInfos . L.targetBuildDepends . traverse) f - . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends . traverse) f - -- cannot be point-free as normal because of higher rank - . over (\f' -> L.allCondTrees $ traverseCondTreeC f') (map f) + . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends . traverse) f + -- cannot be point-free as normal because of higher rank + . over (\f' -> L.allCondTrees $ traverseCondTreeC f') (map f) -- | Walk a 'GenericPackageDescription' and apply @f@ to all nested -- @build-depends@ fields. -transformAllBuildDependsN :: ([Dependency] -> [Dependency]) - -> GenericPackageDescription - -> GenericPackageDescription +transformAllBuildDependsN + :: ([Dependency] -> [Dependency]) + -> GenericPackageDescription + -> GenericPackageDescription transformAllBuildDependsN f = over (L.traverseBuildInfos . L.targetBuildDepends) f - . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends) f - -- cannot be point-free as normal because of higher rank - . over (\f' -> L.allCondTrees $ traverseCondTreeC f') f + . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends) f + -- cannot be point-free as normal because of higher rank + . over (\f' -> L.allCondTrees $ traverseCondTreeC f') f diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 471cf489791..c60040f8e34 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -1,57 +1,69 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} + -- | 'GenericPackageDescription' Field descriptions -module Distribution.PackageDescription.FieldGrammar ( - -- * Package description - packageDescriptionFieldGrammar, - CompatFilePath(..), - CompatLicenseFile(..), +module Distribution.PackageDescription.FieldGrammar + ( -- * Package description + packageDescriptionFieldGrammar + , CompatFilePath (..) + , CompatLicenseFile (..) + -- * Library - libraryFieldGrammar, + , libraryFieldGrammar + -- * Foreign library - foreignLibFieldGrammar, + , foreignLibFieldGrammar + -- * Executable - executableFieldGrammar, + , executableFieldGrammar + -- * Test suite - TestSuiteStanza (..), - testSuiteFieldGrammar, - validateTestSuite, - unvalidateTestSuite, + , TestSuiteStanza (..) + , testSuiteFieldGrammar + , validateTestSuite + , unvalidateTestSuite + -- ** Lenses - testStanzaTestType, - testStanzaMainIs, - testStanzaTestModule, - testStanzaBuildInfo, + , testStanzaTestType + , testStanzaMainIs + , testStanzaTestModule + , testStanzaBuildInfo + -- * Benchmark - BenchmarkStanza (..), - benchmarkFieldGrammar, - validateBenchmark, - unvalidateBenchmark, + , BenchmarkStanza (..) + , benchmarkFieldGrammar + , validateBenchmark + , unvalidateBenchmark + -- * Field grammars - formatDependencyList, - formatExposedModules, - formatExtraSourceFiles, - formatHsSourceDirs, - formatMixinList, - formatOtherExtensions, - formatOtherModules, + , formatDependencyList + , formatExposedModules + , formatExtraSourceFiles + , formatHsSourceDirs + , formatMixinList + , formatOtherExtensions + , formatOtherModules + -- ** Lenses - benchmarkStanzaBenchmarkType, - benchmarkStanzaMainIs, - benchmarkStanzaBenchmarkModule, - benchmarkStanzaBuildInfo, + , benchmarkStanzaBenchmarkType + , benchmarkStanzaMainIs + , benchmarkStanzaBenchmarkModule + , benchmarkStanzaBuildInfo + -- * Flag - flagFieldGrammar, + , flagFieldGrammar + -- * Source repository - sourceRepoFieldGrammar, + , sourceRepoFieldGrammar + -- * Setup build info - setupBInfoFieldGrammar, - -- * Component build info - buildInfoFieldGrammar, - ) where + , setupBInfoFieldGrammar + -- * Component build info + , buildInfoFieldGrammar + ) where import Distribution.Compat.Lens import Distribution.Compat.Prelude @@ -59,134 +71,141 @@ import Language.Haskell.Extension import Prelude () import Distribution.CabalSpecVersion -import Distribution.Compat.Newtype (Newtype, pack', unpack') -import Distribution.Compiler (CompilerFlavor (..), PerCompilerFlavor (..)) +import Distribution.Compat.Newtype (Newtype, pack', unpack') +import Distribution.Compiler (CompilerFlavor (..), PerCompilerFlavor (..)) import Distribution.FieldGrammar import Distribution.Fields -import Distribution.ModuleName (ModuleName) +import Distribution.ModuleName (ModuleName) import Distribution.Package import Distribution.PackageDescription import Distribution.Parsec -import Distribution.Pretty (Pretty (..), prettyShow, showToken) +import Distribution.Pretty (Pretty (..), prettyShow, showToken) import Distribution.Utils.Path -import Distribution.Version (Version, VersionRange) +import Distribution.Version (Version, VersionRange) -import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Char8 as BS8 import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.SPDX as SPDX -import qualified Distribution.Types.Lens as L +import qualified Distribution.SPDX as SPDX +import qualified Distribution.Types.Lens as L ------------------------------------------------------------------------------- -- PackageDescription ------------------------------------------------------------------------------- packageDescriptionFieldGrammar - :: ( FieldGrammar c g, Applicative (g PackageDescription), Applicative (g PackageIdentifier) - , c (Identity BuildType) - , c (Identity PackageName) - , c (Identity Version) - , c (List FSep FilePathNT String) - , c (List FSep CompatFilePath String) - , c (List FSep (Identity (SymbolicPath PackageDir LicenseFile)) (SymbolicPath PackageDir LicenseFile)) - , c (List FSep TestedWith (CompilerFlavor, VersionRange)) - , c (List VCat FilePathNT String) - , c FilePathNT - , c CompatLicenseFile - , c CompatFilePath - , c SpecLicense - , c SpecVersion - ) - => g PackageDescription PackageDescription -packageDescriptionFieldGrammar = PackageDescription - <$> optionalFieldDefAla "cabal-version" SpecVersion L.specVersion CabalSpecV1_0 + :: ( FieldGrammar c g + , Applicative (g PackageDescription) + , Applicative (g PackageIdentifier) + , c (Identity BuildType) + , c (Identity PackageName) + , c (Identity Version) + , c (List FSep FilePathNT String) + , c (List FSep CompatFilePath String) + , c (List FSep (Identity (SymbolicPath PackageDir LicenseFile)) (SymbolicPath PackageDir LicenseFile)) + , c (List FSep TestedWith (CompilerFlavor, VersionRange)) + , c (List VCat FilePathNT String) + , c FilePathNT + , c CompatLicenseFile + , c CompatFilePath + , c SpecLicense + , c SpecVersion + ) + => g PackageDescription PackageDescription +packageDescriptionFieldGrammar = + PackageDescription + <$> optionalFieldDefAla "cabal-version" SpecVersion L.specVersion CabalSpecV1_0 <*> blurFieldGrammar L.package packageIdentifierGrammar - <*> optionalFieldDefAla "license" SpecLicense L.licenseRaw (Left SPDX.NONE) + <*> optionalFieldDefAla "license" SpecLicense L.licenseRaw (Left SPDX.NONE) <*> licenseFilesGrammar - <*> freeTextFieldDefST "copyright" L.copyright - <*> freeTextFieldDefST "maintainer" L.maintainer - <*> freeTextFieldDefST "author" L.author - <*> freeTextFieldDefST "stability" L.stability - <*> monoidalFieldAla "tested-with" (alaList' FSep TestedWith) L.testedWith - <*> freeTextFieldDefST "homepage" L.homepage - <*> freeTextFieldDefST "package-url" L.pkgUrl - <*> freeTextFieldDefST "bug-reports" L.bugReports + <*> freeTextFieldDefST "copyright" L.copyright + <*> freeTextFieldDefST "maintainer" L.maintainer + <*> freeTextFieldDefST "author" L.author + <*> freeTextFieldDefST "stability" L.stability + <*> monoidalFieldAla "tested-with" (alaList' FSep TestedWith) L.testedWith + <*> freeTextFieldDefST "homepage" L.homepage + <*> freeTextFieldDefST "package-url" L.pkgUrl + <*> freeTextFieldDefST "bug-reports" L.bugReports <*> pure [] -- source-repos are stanza - <*> freeTextFieldDefST "synopsis" L.synopsis - <*> freeTextFieldDefST "description" L.description - <*> freeTextFieldDefST "category" L.category - <*> prefixedFields "x-" L.customFieldsPD - <*> optionalField "build-type" L.buildTypeRaw + <*> freeTextFieldDefST "synopsis" L.synopsis + <*> freeTextFieldDefST "description" L.description + <*> freeTextFieldDefST "category" L.category + <*> prefixedFields "x-" L.customFieldsPD + <*> optionalField "build-type" L.buildTypeRaw <*> pure Nothing -- custom-setup -- components - <*> pure Nothing -- lib - <*> pure [] -- sub libs - <*> pure [] -- executables - <*> pure [] -- foreign libs - <*> pure [] -- test suites - <*> pure [] -- benchmarks + <*> pure Nothing -- lib + <*> pure [] -- sub libs + <*> pure [] -- executables + <*> pure [] -- foreign libs + <*> pure [] -- test suites + <*> pure [] -- benchmarks -- * Files - <*> monoidalFieldAla "data-files" (alaList' VCat FilePathNT) L.dataFiles - <*> optionalFieldDefAla "data-dir" CompatFilePath L.dataDir "." - ^^^ fmap (\x -> if null x then "." else x) -- map empty directories to "." - <*> monoidalFieldAla "extra-source-files" formatExtraSourceFiles L.extraSrcFiles - <*> monoidalFieldAla "extra-tmp-files" (alaList' VCat FilePathNT) L.extraTmpFiles - <*> monoidalFieldAla "extra-doc-files" (alaList' VCat FilePathNT) L.extraDocFiles + <*> monoidalFieldAla "data-files" (alaList' VCat FilePathNT) L.dataFiles + <*> optionalFieldDefAla "data-dir" CompatFilePath L.dataDir "." + ^^^ fmap (\x -> if null x then "." else x) -- map empty directories to "." + <*> monoidalFieldAla "extra-source-files" formatExtraSourceFiles L.extraSrcFiles + <*> monoidalFieldAla "extra-tmp-files" (alaList' VCat FilePathNT) L.extraTmpFiles + <*> monoidalFieldAla "extra-doc-files" (alaList' VCat FilePathNT) L.extraDocFiles where - packageIdentifierGrammar = PackageIdentifier - <$> uniqueField "name" L.pkgName + packageIdentifierGrammar = + PackageIdentifier + <$> uniqueField "name" L.pkgName <*> uniqueField "version" L.pkgVersion - licenseFilesGrammar = (++) + licenseFilesGrammar = + (++) -- TODO: neither field is deprecated -- should we pretty print license-file if there's single license file -- and license-files when more - <$> monoidalFieldAla "license-file" CompatLicenseFile L.licenseFiles - <*> monoidalFieldAla "license-files" (alaList FSep) L.licenseFiles - ^^^ hiddenField + <$> monoidalFieldAla "license-file" CompatLicenseFile L.licenseFiles + <*> monoidalFieldAla "license-files" (alaList FSep) L.licenseFiles + ^^^ hiddenField ------------------------------------------------------------------------------- -- Library ------------------------------------------------------------------------------- libraryFieldGrammar - :: ( FieldGrammar c g, Applicative (g Library), Applicative (g BuildInfo) - , c (Identity LibraryVisibility) - , c (List CommaFSep (Identity ExeDependency) ExeDependency) - , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (List CommaVCat (Identity Dependency) Dependency) - , c (List CommaVCat (Identity Mixin) Mixin) - , c (List CommaVCat (Identity ModuleReexport) ModuleReexport) - , c (List FSep (MQuoted Extension) Extension) - , c (List FSep (MQuoted Language) Language) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (List NoCommaFSep Token' String) - , c (List VCat (MQuoted ModuleName) ModuleName) - , c (List VCat FilePathNT String) - , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) - , c (List VCat Token String) - , c (MQuoted Language) - ) - => LibraryName - -> g Library Library -libraryFieldGrammar n = Library n - <$> monoidalFieldAla "exposed-modules" formatExposedModules L.exposedModules - <*> monoidalFieldAla "reexported-modules" (alaList CommaVCat) L.reexportedModules - <*> monoidalFieldAla "signatures" (alaList' VCat MQuoted) L.signatures - ^^^ availableSince CabalSpecV2_0 [] - <*> booleanFieldDef "exposed" L.libExposed True + :: ( FieldGrammar c g + , Applicative (g Library) + , Applicative (g BuildInfo) + , c (Identity LibraryVisibility) + , c (List CommaFSep (Identity ExeDependency) ExeDependency) + , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + , c (List CommaVCat (Identity Dependency) Dependency) + , c (List CommaVCat (Identity Mixin) Mixin) + , c (List CommaVCat (Identity ModuleReexport) ModuleReexport) + , c (List FSep (MQuoted Extension) Extension) + , c (List FSep (MQuoted Language) Language) + , c (List FSep FilePathNT String) + , c (List FSep Token String) + , c (List NoCommaFSep Token' String) + , c (List VCat (MQuoted ModuleName) ModuleName) + , c (List VCat FilePathNT String) + , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) + , c (List VCat Token String) + , c (MQuoted Language) + ) + => LibraryName + -> g Library Library +libraryFieldGrammar n = + Library n + <$> monoidalFieldAla "exposed-modules" formatExposedModules L.exposedModules + <*> monoidalFieldAla "reexported-modules" (alaList CommaVCat) L.reexportedModules + <*> monoidalFieldAla "signatures" (alaList' VCat MQuoted) L.signatures + ^^^ availableSince CabalSpecV2_0 [] + <*> booleanFieldDef "exposed" L.libExposed True <*> visibilityField <*> blurFieldGrammar L.libBuildInfo buildInfoFieldGrammar where visibilityField = case n of - -- nameless/"main" libraries are public - LMainLibName -> pure LibraryVisibilityPublic - -- named libraries have the field - LSubLibName _ -> - optionalFieldDef "visibility" L.libVisibility LibraryVisibilityPrivate - ^^^ availableSince CabalSpecV3_0 LibraryVisibilityPrivate - + -- nameless/"main" libraries are public + LMainLibName -> pure LibraryVisibilityPublic + -- named libraries have the field + LSubLibName _ -> + optionalFieldDef "visibility" L.libVisibility LibraryVisibilityPrivate + ^^^ availableSince CabalSpecV3_0 LibraryVisibilityPrivate {-# SPECIALIZE libraryFieldGrammar :: LibraryName -> ParsecFieldGrammar' Library #-} {-# SPECIALIZE libraryFieldGrammar :: LibraryName -> PrettyFieldGrammar' Library #-} @@ -195,34 +214,39 @@ libraryFieldGrammar n = Library n ------------------------------------------------------------------------------- foreignLibFieldGrammar - :: ( FieldGrammar c g, Applicative (g ForeignLib), Applicative (g BuildInfo) - , c (Identity ForeignLibType) - , c (Identity LibVersionInfo) - , c (Identity Version) - , c (List CommaFSep (Identity ExeDependency) ExeDependency) - , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (List CommaVCat (Identity Dependency) Dependency) - , c (List CommaVCat (Identity Mixin) Mixin) - , c (List FSep (Identity ForeignLibOption) ForeignLibOption) - , c (List FSep (MQuoted Extension) Extension) - , c (List FSep (MQuoted Language) Language) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) - , c (List NoCommaFSep Token' String) - , c (List VCat (MQuoted ModuleName) ModuleName) - , c (List VCat FilePathNT String), c (List VCat Token String) - , c (MQuoted Language) - ) - => UnqualComponentName -> g ForeignLib ForeignLib -foreignLibFieldGrammar n = ForeignLib n - <$> optionalFieldDef "type" L.foreignLibType ForeignLibTypeUnknown - <*> monoidalFieldAla "options" (alaList FSep) L.foreignLibOptions + :: ( FieldGrammar c g + , Applicative (g ForeignLib) + , Applicative (g BuildInfo) + , c (Identity ForeignLibType) + , c (Identity LibVersionInfo) + , c (Identity Version) + , c (List CommaFSep (Identity ExeDependency) ExeDependency) + , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + , c (List CommaVCat (Identity Dependency) Dependency) + , c (List CommaVCat (Identity Mixin) Mixin) + , c (List FSep (Identity ForeignLibOption) ForeignLibOption) + , c (List FSep (MQuoted Extension) Extension) + , c (List FSep (MQuoted Language) Language) + , c (List FSep FilePathNT String) + , c (List FSep Token String) + , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) + , c (List NoCommaFSep Token' String) + , c (List VCat (MQuoted ModuleName) ModuleName) + , c (List VCat FilePathNT String) + , c (List VCat Token String) + , c (MQuoted Language) + ) + => UnqualComponentName + -> g ForeignLib ForeignLib +foreignLibFieldGrammar n = + ForeignLib n + <$> optionalFieldDef "type" L.foreignLibType ForeignLibTypeUnknown + <*> monoidalFieldAla "options" (alaList FSep) L.foreignLibOptions <*> blurFieldGrammar L.foreignLibBuildInfo buildInfoFieldGrammar - <*> optionalField "lib-version-info" L.foreignLibVersionInfo - <*> optionalField "lib-version-linux" L.foreignLibVersionLinux - <*> monoidalFieldAla "mod-def-file" (alaList' FSep FilePathNT) L.foreignLibModDefFile + <*> optionalField "lib-version-info" L.foreignLibVersionInfo + <*> optionalField "lib-version-linux" L.foreignLibVersionLinux + <*> monoidalFieldAla "mod-def-file" (alaList' FSep FilePathNT) L.foreignLibModDefFile {-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' ForeignLib #-} {-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> PrettyFieldGrammar' ForeignLib #-} @@ -231,30 +255,34 @@ foreignLibFieldGrammar n = ForeignLib n ------------------------------------------------------------------------------- executableFieldGrammar - :: ( FieldGrammar c g, Applicative (g Executable), Applicative (g BuildInfo) - , c (Identity ExecutableScope) - , c (List CommaFSep (Identity ExeDependency) ExeDependency) - , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (List CommaVCat (Identity Dependency) Dependency) - , c (List CommaVCat (Identity Mixin) Mixin) - , c (List FSep (MQuoted Extension) Extension) - , c (List FSep (MQuoted Language) Language) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) - , c (List NoCommaFSep Token' String) - , c (List VCat (MQuoted ModuleName) ModuleName) - , c (List VCat FilePathNT String) - , c (List VCat Token String) - , c (MQuoted Language) - ) - => UnqualComponentName -> g Executable Executable -executableFieldGrammar n = Executable n + :: ( FieldGrammar c g + , Applicative (g Executable) + , Applicative (g BuildInfo) + , c (Identity ExecutableScope) + , c (List CommaFSep (Identity ExeDependency) ExeDependency) + , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + , c (List CommaVCat (Identity Dependency) Dependency) + , c (List CommaVCat (Identity Mixin) Mixin) + , c (List FSep (MQuoted Extension) Extension) + , c (List FSep (MQuoted Language) Language) + , c (List FSep FilePathNT String) + , c (List FSep Token String) + , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) + , c (List NoCommaFSep Token' String) + , c (List VCat (MQuoted ModuleName) ModuleName) + , c (List VCat FilePathNT String) + , c (List VCat Token String) + , c (MQuoted Language) + ) + => UnqualComponentName + -> g Executable Executable +executableFieldGrammar n = + Executable n -- main-is is optional as conditional blocks don't have it <$> optionalFieldDefAla "main-is" FilePathNT L.modulePath "" - <*> optionalFieldDef "scope" L.exeScope ExecutablePublic - ^^^ availableSince CabalSpecV2_0 ExecutablePublic + <*> optionalFieldDef "scope" L.exeScope ExecutablePublic + ^^^ availableSince CabalSpecV2_0 ExecutablePublic <*> blurFieldGrammar L.buildInfo buildInfoFieldGrammar {-# SPECIALIZE executableFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' Executable #-} {-# SPECIALIZE executableFieldGrammar :: UnqualComponentName -> PrettyFieldGrammar' Executable #-} @@ -266,129 +294,147 @@ executableFieldGrammar n = Executable n -- | An intermediate type just used for parsing the test-suite stanza. -- After validation it is converted into the proper 'TestSuite' type. data TestSuiteStanza = TestSuiteStanza - { _testStanzaTestType :: Maybe TestType - , _testStanzaMainIs :: Maybe FilePath - , _testStanzaTestModule :: Maybe ModuleName - , _testStanzaBuildInfo :: BuildInfo - , _testStanzaCodeGenerators :: [String] - } + { _testStanzaTestType :: Maybe TestType + , _testStanzaMainIs :: Maybe FilePath + , _testStanzaTestModule :: Maybe ModuleName + , _testStanzaBuildInfo :: BuildInfo + , _testStanzaCodeGenerators :: [String] + } instance L.HasBuildInfo TestSuiteStanza where - buildInfo = testStanzaBuildInfo + buildInfo = testStanzaBuildInfo testStanzaTestType :: Lens' TestSuiteStanza (Maybe TestType) -testStanzaTestType f s = fmap (\x -> s { _testStanzaTestType = x }) (f (_testStanzaTestType s)) +testStanzaTestType f s = fmap (\x -> s{_testStanzaTestType = x}) (f (_testStanzaTestType s)) {-# INLINE testStanzaTestType #-} testStanzaMainIs :: Lens' TestSuiteStanza (Maybe FilePath) -testStanzaMainIs f s = fmap (\x -> s { _testStanzaMainIs = x }) (f (_testStanzaMainIs s)) +testStanzaMainIs f s = fmap (\x -> s{_testStanzaMainIs = x}) (f (_testStanzaMainIs s)) {-# INLINE testStanzaMainIs #-} testStanzaTestModule :: Lens' TestSuiteStanza (Maybe ModuleName) -testStanzaTestModule f s = fmap (\x -> s { _testStanzaTestModule = x }) (f (_testStanzaTestModule s)) +testStanzaTestModule f s = fmap (\x -> s{_testStanzaTestModule = x}) (f (_testStanzaTestModule s)) {-# INLINE testStanzaTestModule #-} testStanzaBuildInfo :: Lens' TestSuiteStanza BuildInfo -testStanzaBuildInfo f s = fmap (\x -> s { _testStanzaBuildInfo = x }) (f (_testStanzaBuildInfo s)) +testStanzaBuildInfo f s = fmap (\x -> s{_testStanzaBuildInfo = x}) (f (_testStanzaBuildInfo s)) {-# INLINE testStanzaBuildInfo #-} testStanzaCodeGenerators :: Lens' TestSuiteStanza [String] -testStanzaCodeGenerators f s = fmap (\x -> s { _testStanzaCodeGenerators = x }) (f (_testStanzaCodeGenerators s)) +testStanzaCodeGenerators f s = fmap (\x -> s{_testStanzaCodeGenerators = x}) (f (_testStanzaCodeGenerators s)) {-# INLINE testStanzaCodeGenerators #-} testSuiteFieldGrammar - :: ( FieldGrammar c g, Applicative (g TestSuiteStanza), Applicative (g BuildInfo) - , c (Identity ModuleName) - , c (Identity TestType) - , c (List CommaFSep (Identity ExeDependency) ExeDependency) - , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (List CommaFSep Token String) - , c (List CommaVCat (Identity Dependency) Dependency) - , c (List CommaVCat (Identity Mixin) Mixin) - , c (List FSep (MQuoted Extension) Extension) - , c (List FSep (MQuoted Language) Language) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (List NoCommaFSep Token' String) - , c (List VCat (MQuoted ModuleName) ModuleName) - , c (List VCat FilePathNT String) - , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) - , c (List VCat Token String) - , c (MQuoted Language) - ) - => g TestSuiteStanza TestSuiteStanza -testSuiteFieldGrammar = TestSuiteStanza - <$> optionalField "type" testStanzaTestType - <*> optionalFieldAla "main-is" FilePathNT testStanzaMainIs - <*> optionalField "test-module" testStanzaTestModule + :: ( FieldGrammar c g + , Applicative (g TestSuiteStanza) + , Applicative (g BuildInfo) + , c (Identity ModuleName) + , c (Identity TestType) + , c (List CommaFSep (Identity ExeDependency) ExeDependency) + , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + , c (List CommaFSep Token String) + , c (List CommaVCat (Identity Dependency) Dependency) + , c (List CommaVCat (Identity Mixin) Mixin) + , c (List FSep (MQuoted Extension) Extension) + , c (List FSep (MQuoted Language) Language) + , c (List FSep FilePathNT String) + , c (List FSep Token String) + , c (List NoCommaFSep Token' String) + , c (List VCat (MQuoted ModuleName) ModuleName) + , c (List VCat FilePathNT String) + , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) + , c (List VCat Token String) + , c (MQuoted Language) + ) + => g TestSuiteStanza TestSuiteStanza +testSuiteFieldGrammar = + TestSuiteStanza + <$> optionalField "type" testStanzaTestType + <*> optionalFieldAla "main-is" FilePathNT testStanzaMainIs + <*> optionalField "test-module" testStanzaTestModule <*> blurFieldGrammar testStanzaBuildInfo buildInfoFieldGrammar - <*> monoidalFieldAla "code-generators" (alaList' CommaFSep Token) testStanzaCodeGenerators - ^^^ availableSince CabalSpecV3_8 [] + <*> monoidalFieldAla "code-generators" (alaList' CommaFSep Token) testStanzaCodeGenerators + ^^^ availableSince CabalSpecV3_8 [] validateTestSuite :: CabalSpecVersion -> Position -> TestSuiteStanza -> ParseResult TestSuite validateTestSuite cabalSpecVersion pos stanza = case testSuiteType of - Nothing -> pure basicTestSuite - - Just tt@(TestTypeUnknown _ _) -> - pure basicTestSuite - { testInterface = TestSuiteUnsupported tt } - - Just tt | tt `notElem` knownTestTypes -> - pure basicTestSuite - { testInterface = TestSuiteUnsupported tt } - - Just tt@(TestTypeExe ver) -> case _testStanzaMainIs stanza of - Nothing -> do - parseFailure pos (missingField "main-is" tt) - pure emptyTestSuite - Just file -> do - when (isJust (_testStanzaTestModule stanza)) $ - parseWarning pos PWTExtraBenchmarkModule (extraField "test-module" tt) - pure basicTestSuite - { testInterface = TestSuiteExeV10 ver file } - - Just tt@(TestTypeLib ver) -> case _testStanzaTestModule stanza of - Nothing -> do - parseFailure pos (missingField "test-module" tt) - pure emptyTestSuite - Just module_ -> do - when (isJust (_testStanzaMainIs stanza)) $ - parseWarning pos PWTExtraMainIs (extraField "main-is" tt) - pure basicTestSuite - { testInterface = TestSuiteLibV09 ver module_ } - + Nothing -> pure basicTestSuite + Just tt@(TestTypeUnknown _ _) -> + pure + basicTestSuite + { testInterface = TestSuiteUnsupported tt + } + Just tt + | tt `notElem` knownTestTypes -> + pure + basicTestSuite + { testInterface = TestSuiteUnsupported tt + } + Just tt@(TestTypeExe ver) -> case _testStanzaMainIs stanza of + Nothing -> do + parseFailure pos (missingField "main-is" tt) + pure emptyTestSuite + Just file -> do + when (isJust (_testStanzaTestModule stanza)) $ + parseWarning pos PWTExtraBenchmarkModule (extraField "test-module" tt) + pure + basicTestSuite + { testInterface = TestSuiteExeV10 ver file + } + Just tt@(TestTypeLib ver) -> case _testStanzaTestModule stanza of + Nothing -> do + parseFailure pos (missingField "test-module" tt) + pure emptyTestSuite + Just module_ -> do + when (isJust (_testStanzaMainIs stanza)) $ + parseWarning pos PWTExtraMainIs (extraField "main-is" tt) + pure + basicTestSuite + { testInterface = TestSuiteLibV09 ver module_ + } where - testSuiteType = _testStanzaTestType stanza <|> do - guard (cabalSpecVersion >= CabalSpecV3_8) + testSuiteType = + _testStanzaTestType stanza + <|> do + guard (cabalSpecVersion >= CabalSpecV3_8) - testTypeExe <$ _testStanzaMainIs stanza + testTypeExe <$ _testStanzaMainIs stanza <|> testTypeLib <$ _testStanzaTestModule stanza - missingField name tt = "The '" ++ name ++ "' field is required for the " - ++ prettyShow tt ++ " test suite type." - - extraField name tt = "The '" ++ name ++ "' field is not used for the '" - ++ prettyShow tt ++ "' test suite type." + missingField name tt = + "The '" + ++ name + ++ "' field is required for the " + ++ prettyShow tt + ++ " test suite type." + + extraField name tt = + "The '" + ++ name + ++ "' field is not used for the '" + ++ prettyShow tt + ++ "' test suite type." basicTestSuite = - emptyTestSuite { - testBuildInfo = _testStanzaBuildInfo stanza - , testCodeGenerators = _testStanzaCodeGenerators stanza - } + emptyTestSuite + { testBuildInfo = _testStanzaBuildInfo stanza + , testCodeGenerators = _testStanzaCodeGenerators stanza + } unvalidateTestSuite :: TestSuite -> TestSuiteStanza -unvalidateTestSuite t = TestSuiteStanza - { _testStanzaTestType = ty - , _testStanzaMainIs = ma +unvalidateTestSuite t = + TestSuiteStanza + { _testStanzaTestType = ty + , _testStanzaMainIs = ma , _testStanzaTestModule = mo - , _testStanzaBuildInfo = testBuildInfo t + , _testStanzaBuildInfo = testBuildInfo t , _testStanzaCodeGenerators = testCodeGenerators t } where (ty, ma, mo) = case testInterface t of - TestSuiteExeV10 ver file -> (Just $ TestTypeExe ver, Just file, Nothing) - TestSuiteLibV09 ver modu -> (Just $ TestTypeLib ver, Nothing, Just modu) - _ -> (Nothing, Nothing, Nothing) + TestSuiteExeV10 ver file -> (Just $ TestTypeExe ver, Just file, Nothing) + TestSuiteLibV09 ver modu -> (Just $ TestTypeLib ver, Nothing, Just modu) + _ -> (Nothing, Nothing, Nothing) ------------------------------------------------------------------------------- -- Benchmark @@ -397,261 +443,290 @@ unvalidateTestSuite t = TestSuiteStanza -- | An intermediate type just used for parsing the benchmark stanza. -- After validation it is converted into the proper 'Benchmark' type. data BenchmarkStanza = BenchmarkStanza - { _benchmarkStanzaBenchmarkType :: Maybe BenchmarkType - , _benchmarkStanzaMainIs :: Maybe FilePath - , _benchmarkStanzaBenchmarkModule :: Maybe ModuleName - , _benchmarkStanzaBuildInfo :: BuildInfo - } + { _benchmarkStanzaBenchmarkType :: Maybe BenchmarkType + , _benchmarkStanzaMainIs :: Maybe FilePath + , _benchmarkStanzaBenchmarkModule :: Maybe ModuleName + , _benchmarkStanzaBuildInfo :: BuildInfo + } instance L.HasBuildInfo BenchmarkStanza where - buildInfo = benchmarkStanzaBuildInfo + buildInfo = benchmarkStanzaBuildInfo benchmarkStanzaBenchmarkType :: Lens' BenchmarkStanza (Maybe BenchmarkType) -benchmarkStanzaBenchmarkType f s = fmap (\x -> s { _benchmarkStanzaBenchmarkType = x }) (f (_benchmarkStanzaBenchmarkType s)) +benchmarkStanzaBenchmarkType f s = fmap (\x -> s{_benchmarkStanzaBenchmarkType = x}) (f (_benchmarkStanzaBenchmarkType s)) {-# INLINE benchmarkStanzaBenchmarkType #-} benchmarkStanzaMainIs :: Lens' BenchmarkStanza (Maybe FilePath) -benchmarkStanzaMainIs f s = fmap (\x -> s { _benchmarkStanzaMainIs = x }) (f (_benchmarkStanzaMainIs s)) +benchmarkStanzaMainIs f s = fmap (\x -> s{_benchmarkStanzaMainIs = x}) (f (_benchmarkStanzaMainIs s)) {-# INLINE benchmarkStanzaMainIs #-} benchmarkStanzaBenchmarkModule :: Lens' BenchmarkStanza (Maybe ModuleName) -benchmarkStanzaBenchmarkModule f s = fmap (\x -> s { _benchmarkStanzaBenchmarkModule = x }) (f (_benchmarkStanzaBenchmarkModule s)) +benchmarkStanzaBenchmarkModule f s = fmap (\x -> s{_benchmarkStanzaBenchmarkModule = x}) (f (_benchmarkStanzaBenchmarkModule s)) {-# INLINE benchmarkStanzaBenchmarkModule #-} benchmarkStanzaBuildInfo :: Lens' BenchmarkStanza BuildInfo -benchmarkStanzaBuildInfo f s = fmap (\x -> s { _benchmarkStanzaBuildInfo = x }) (f (_benchmarkStanzaBuildInfo s)) +benchmarkStanzaBuildInfo f s = fmap (\x -> s{_benchmarkStanzaBuildInfo = x}) (f (_benchmarkStanzaBuildInfo s)) {-# INLINE benchmarkStanzaBuildInfo #-} benchmarkFieldGrammar - :: ( FieldGrammar c g, Applicative (g BenchmarkStanza), Applicative (g BuildInfo) - , c (Identity BenchmarkType) - , c (Identity ModuleName) - , c (List CommaFSep (Identity ExeDependency) ExeDependency) - , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (List CommaVCat (Identity Dependency) Dependency) - , c (List CommaVCat (Identity Mixin) Mixin) - , c (List FSep (MQuoted Extension) Extension) - , c (List FSep (MQuoted Language) Language) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (List NoCommaFSep Token' String) - , c (List VCat (MQuoted ModuleName) ModuleName) - , c (List VCat FilePathNT String) - , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) - , c (List VCat Token String) - , c (MQuoted Language) - ) - => g BenchmarkStanza BenchmarkStanza -benchmarkFieldGrammar = BenchmarkStanza - <$> optionalField "type" benchmarkStanzaBenchmarkType - <*> optionalFieldAla "main-is" FilePathNT benchmarkStanzaMainIs - <*> optionalField "benchmark-module" benchmarkStanzaBenchmarkModule + :: ( FieldGrammar c g + , Applicative (g BenchmarkStanza) + , Applicative (g BuildInfo) + , c (Identity BenchmarkType) + , c (Identity ModuleName) + , c (List CommaFSep (Identity ExeDependency) ExeDependency) + , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + , c (List CommaVCat (Identity Dependency) Dependency) + , c (List CommaVCat (Identity Mixin) Mixin) + , c (List FSep (MQuoted Extension) Extension) + , c (List FSep (MQuoted Language) Language) + , c (List FSep FilePathNT String) + , c (List FSep Token String) + , c (List NoCommaFSep Token' String) + , c (List VCat (MQuoted ModuleName) ModuleName) + , c (List VCat FilePathNT String) + , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) + , c (List VCat Token String) + , c (MQuoted Language) + ) + => g BenchmarkStanza BenchmarkStanza +benchmarkFieldGrammar = + BenchmarkStanza + <$> optionalField "type" benchmarkStanzaBenchmarkType + <*> optionalFieldAla "main-is" FilePathNT benchmarkStanzaMainIs + <*> optionalField "benchmark-module" benchmarkStanzaBenchmarkModule <*> blurFieldGrammar benchmarkStanzaBuildInfo buildInfoFieldGrammar validateBenchmark :: CabalSpecVersion -> Position -> BenchmarkStanza -> ParseResult Benchmark validateBenchmark cabalSpecVersion pos stanza = case benchmarkStanzaType of - Nothing -> pure emptyBenchmark - { benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza } - - Just tt@(BenchmarkTypeUnknown _ _) -> pure emptyBenchmark - { benchmarkInterface = BenchmarkUnsupported tt - , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza + Nothing -> + pure + emptyBenchmark + { benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza } - - Just tt | tt `notElem` knownBenchmarkTypes -> pure emptyBenchmark + Just tt@(BenchmarkTypeUnknown _ _) -> + pure + emptyBenchmark { benchmarkInterface = BenchmarkUnsupported tt , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza } - - Just tt@(BenchmarkTypeExe ver) -> case _benchmarkStanzaMainIs stanza of - Nothing -> do - parseFailure pos (missingField "main-is" tt) - pure emptyBenchmark - Just file -> do - when (isJust (_benchmarkStanzaBenchmarkModule stanza)) $ - parseWarning pos PWTExtraBenchmarkModule (extraField "benchmark-module" tt) - pure emptyBenchmark - { benchmarkInterface = BenchmarkExeV10 ver file - , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza - } - + Just tt + | tt `notElem` knownBenchmarkTypes -> + pure + emptyBenchmark + { benchmarkInterface = BenchmarkUnsupported tt + , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza + } + Just tt@(BenchmarkTypeExe ver) -> case _benchmarkStanzaMainIs stanza of + Nothing -> do + parseFailure pos (missingField "main-is" tt) + pure emptyBenchmark + Just file -> do + when (isJust (_benchmarkStanzaBenchmarkModule stanza)) $ + parseWarning pos PWTExtraBenchmarkModule (extraField "benchmark-module" tt) + pure + emptyBenchmark + { benchmarkInterface = BenchmarkExeV10 ver file + , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza + } where - benchmarkStanzaType = _benchmarkStanzaBenchmarkType stanza <|> do + benchmarkStanzaType = + _benchmarkStanzaBenchmarkType stanza <|> do guard (cabalSpecVersion >= CabalSpecV3_8) benchmarkTypeExe <$ _benchmarkStanzaMainIs stanza - missingField name tt = "The '" ++ name ++ "' field is required for the " - ++ prettyShow tt ++ " benchmark type." + missingField name tt = + "The '" + ++ name + ++ "' field is required for the " + ++ prettyShow tt + ++ " benchmark type." - extraField name tt = "The '" ++ name ++ "' field is not used for the '" - ++ prettyShow tt ++ "' benchmark type." + extraField name tt = + "The '" + ++ name + ++ "' field is not used for the '" + ++ prettyShow tt + ++ "' benchmark type." unvalidateBenchmark :: Benchmark -> BenchmarkStanza -unvalidateBenchmark b = BenchmarkStanza - { _benchmarkStanzaBenchmarkType = ty - , _benchmarkStanzaMainIs = ma +unvalidateBenchmark b = + BenchmarkStanza + { _benchmarkStanzaBenchmarkType = ty + , _benchmarkStanzaMainIs = ma , _benchmarkStanzaBenchmarkModule = mo - , _benchmarkStanzaBuildInfo = benchmarkBuildInfo b + , _benchmarkStanzaBuildInfo = benchmarkBuildInfo b } where (ty, ma, mo) = case benchmarkInterface b of - BenchmarkExeV10 ver "" -> (Just $ BenchmarkTypeExe ver, Nothing, Nothing) - BenchmarkExeV10 ver ma' -> (Just $ BenchmarkTypeExe ver, Just ma', Nothing) - _ -> (Nothing, Nothing, Nothing) + BenchmarkExeV10 ver "" -> (Just $ BenchmarkTypeExe ver, Nothing, Nothing) + BenchmarkExeV10 ver ma' -> (Just $ BenchmarkTypeExe ver, Just ma', Nothing) + _ -> (Nothing, Nothing, Nothing) ------------------------------------------------------------------------------- -- Build info ------------------------------------------------------------------------------- buildInfoFieldGrammar - :: ( FieldGrammar c g, Applicative (g BuildInfo) - , c (List CommaFSep (Identity ExeDependency) ExeDependency) - , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (List CommaVCat (Identity Dependency) Dependency) - , c (List CommaVCat (Identity Mixin) Mixin) - , c (List FSep (MQuoted Extension) Extension) - , c (List FSep (MQuoted Language) Language) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (List NoCommaFSep Token' String) - , c (List VCat (MQuoted ModuleName) ModuleName) - , c (List VCat FilePathNT String) - , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) - , c (List VCat Token String) - , c (MQuoted Language) - ) - => g BuildInfo BuildInfo -buildInfoFieldGrammar = BuildInfo - <$> booleanFieldDef "buildable" L.buildable True - <*> monoidalFieldAla "build-tools" (alaList CommaFSep) L.buildTools - ^^^ deprecatedSince CabalSpecV2_0 - "Please use 'build-tool-depends' field" - ^^^ removedIn CabalSpecV3_0 - "Please use 'build-tool-depends' field." - <*> monoidalFieldAla "build-tool-depends" (alaList CommaFSep) L.buildToolDepends - -- {- ^^^ availableSince [2,0] [] -} - -- here, we explicitly want to recognise build-tool-depends for all Cabal files - -- as otherwise cabal new-build cannot really work. - -- - -- I.e. we don't want trigger unknown field warning - <*> monoidalFieldAla "cpp-options" (alaList' NoCommaFSep Token') L.cppOptions - <*> monoidalFieldAla "asm-options" (alaList' NoCommaFSep Token') L.asmOptions - ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "cmm-options" (alaList' NoCommaFSep Token') L.cmmOptions - ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "cc-options" (alaList' NoCommaFSep Token') L.ccOptions - <*> monoidalFieldAla "cxx-options" (alaList' NoCommaFSep Token') L.cxxOptions - ^^^ availableSince CabalSpecV2_2 [] - <*> monoidalFieldAla "ld-options" (alaList' NoCommaFSep Token') L.ldOptions - <*> monoidalFieldAla "hsc2hs-options" (alaList' NoCommaFSep Token') L.hsc2hsOptions - ^^^ availableSince CabalSpecV3_6 [] - <*> monoidalFieldAla "pkgconfig-depends" (alaList CommaFSep) L.pkgconfigDepends - <*> monoidalFieldAla "frameworks" (alaList' FSep Token) L.frameworks - <*> monoidalFieldAla "extra-framework-dirs" (alaList' FSep FilePathNT) L.extraFrameworkDirs - <*> monoidalFieldAla "asm-sources" (alaList' VCat FilePathNT) L.asmSources - ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "cmm-sources" (alaList' VCat FilePathNT) L.cmmSources - ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "c-sources" (alaList' VCat FilePathNT) L.cSources - <*> monoidalFieldAla "cxx-sources" (alaList' VCat FilePathNT) L.cxxSources - ^^^ availableSince CabalSpecV2_2 [] - <*> monoidalFieldAla "js-sources" (alaList' VCat FilePathNT) L.jsSources + :: ( FieldGrammar c g + , Applicative (g BuildInfo) + , c (List CommaFSep (Identity ExeDependency) ExeDependency) + , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + , c (List CommaVCat (Identity Dependency) Dependency) + , c (List CommaVCat (Identity Mixin) Mixin) + , c (List FSep (MQuoted Extension) Extension) + , c (List FSep (MQuoted Language) Language) + , c (List FSep FilePathNT String) + , c (List FSep Token String) + , c (List NoCommaFSep Token' String) + , c (List VCat (MQuoted ModuleName) ModuleName) + , c (List VCat FilePathNT String) + , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) + , c (List VCat Token String) + , c (MQuoted Language) + ) + => g BuildInfo BuildInfo +buildInfoFieldGrammar = + BuildInfo + <$> booleanFieldDef "buildable" L.buildable True + <*> monoidalFieldAla "build-tools" (alaList CommaFSep) L.buildTools + ^^^ deprecatedSince + CabalSpecV2_0 + "Please use 'build-tool-depends' field" + ^^^ removedIn + CabalSpecV3_0 + "Please use 'build-tool-depends' field." + <*> monoidalFieldAla "build-tool-depends" (alaList CommaFSep) L.buildToolDepends + -- {- ^^^ availableSince [2,0] [] -} + -- here, we explicitly want to recognise build-tool-depends for all Cabal files + -- as otherwise cabal new-build cannot really work. + -- + -- I.e. we don't want trigger unknown field warning + <*> monoidalFieldAla "cpp-options" (alaList' NoCommaFSep Token') L.cppOptions + <*> monoidalFieldAla "asm-options" (alaList' NoCommaFSep Token') L.asmOptions + ^^^ availableSince CabalSpecV3_0 [] + <*> monoidalFieldAla "cmm-options" (alaList' NoCommaFSep Token') L.cmmOptions + ^^^ availableSince CabalSpecV3_0 [] + <*> monoidalFieldAla "cc-options" (alaList' NoCommaFSep Token') L.ccOptions + <*> monoidalFieldAla "cxx-options" (alaList' NoCommaFSep Token') L.cxxOptions + ^^^ availableSince CabalSpecV2_2 [] + <*> monoidalFieldAla "ld-options" (alaList' NoCommaFSep Token') L.ldOptions + <*> monoidalFieldAla "hsc2hs-options" (alaList' NoCommaFSep Token') L.hsc2hsOptions + ^^^ availableSince CabalSpecV3_6 [] + <*> monoidalFieldAla "pkgconfig-depends" (alaList CommaFSep) L.pkgconfigDepends + <*> monoidalFieldAla "frameworks" (alaList' FSep Token) L.frameworks + <*> monoidalFieldAla "extra-framework-dirs" (alaList' FSep FilePathNT) L.extraFrameworkDirs + <*> monoidalFieldAla "asm-sources" (alaList' VCat FilePathNT) L.asmSources + ^^^ availableSince CabalSpecV3_0 [] + <*> monoidalFieldAla "cmm-sources" (alaList' VCat FilePathNT) L.cmmSources + ^^^ availableSince CabalSpecV3_0 [] + <*> monoidalFieldAla "c-sources" (alaList' VCat FilePathNT) L.cSources + <*> monoidalFieldAla "cxx-sources" (alaList' VCat FilePathNT) L.cxxSources + ^^^ availableSince CabalSpecV2_2 [] + <*> monoidalFieldAla "js-sources" (alaList' VCat FilePathNT) L.jsSources <*> hsSourceDirsGrammar - <*> monoidalFieldAla "other-modules" formatOtherModules L.otherModules - <*> monoidalFieldAla "virtual-modules" (alaList' VCat MQuoted) L.virtualModules - ^^^ availableSince CabalSpecV2_2 [] - <*> monoidalFieldAla "autogen-modules" (alaList' VCat MQuoted) L.autogenModules - ^^^ availableSince CabalSpecV2_0 [] - <*> optionalFieldAla "default-language" MQuoted L.defaultLanguage - ^^^ availableSince CabalSpecV1_10 Nothing - <*> monoidalFieldAla "other-languages" (alaList' FSep MQuoted) L.otherLanguages - ^^^ availableSince CabalSpecV1_10 [] - <*> monoidalFieldAla "default-extensions" (alaList' FSep MQuoted) L.defaultExtensions - ^^^ availableSince CabalSpecV1_10 [] - <*> monoidalFieldAla "other-extensions" formatOtherExtensions L.otherExtensions - ^^^ availableSinceWarn CabalSpecV1_10 - <*> monoidalFieldAla "extensions" (alaList' FSep MQuoted) L.oldExtensions - ^^^ deprecatedSince CabalSpecV1_12 - "Please use 'default-extensions' or 'other-extensions' fields." - ^^^ removedIn CabalSpecV3_0 - "Please use 'default-extensions' or 'other-extensions' fields." - <*> monoidalFieldAla "extra-libraries" (alaList' VCat Token) L.extraLibs - <*> monoidalFieldAla "extra-libraries-static" (alaList' VCat Token) L.extraLibsStatic - ^^^ availableSince CabalSpecV3_8 [] - <*> monoidalFieldAla "extra-ghci-libraries" (alaList' VCat Token) L.extraGHCiLibs - <*> monoidalFieldAla "extra-bundled-libraries" (alaList' VCat Token) L.extraBundledLibs - <*> monoidalFieldAla "extra-library-flavours" (alaList' VCat Token) L.extraLibFlavours + <*> monoidalFieldAla "other-modules" formatOtherModules L.otherModules + <*> monoidalFieldAla "virtual-modules" (alaList' VCat MQuoted) L.virtualModules + ^^^ availableSince CabalSpecV2_2 [] + <*> monoidalFieldAla "autogen-modules" (alaList' VCat MQuoted) L.autogenModules + ^^^ availableSince CabalSpecV2_0 [] + <*> optionalFieldAla "default-language" MQuoted L.defaultLanguage + ^^^ availableSince CabalSpecV1_10 Nothing + <*> monoidalFieldAla "other-languages" (alaList' FSep MQuoted) L.otherLanguages + ^^^ availableSince CabalSpecV1_10 [] + <*> monoidalFieldAla "default-extensions" (alaList' FSep MQuoted) L.defaultExtensions + ^^^ availableSince CabalSpecV1_10 [] + <*> monoidalFieldAla "other-extensions" formatOtherExtensions L.otherExtensions + ^^^ availableSinceWarn CabalSpecV1_10 + <*> monoidalFieldAla "extensions" (alaList' FSep MQuoted) L.oldExtensions + ^^^ deprecatedSince + CabalSpecV1_12 + "Please use 'default-extensions' or 'other-extensions' fields." + ^^^ removedIn + CabalSpecV3_0 + "Please use 'default-extensions' or 'other-extensions' fields." + <*> monoidalFieldAla "extra-libraries" (alaList' VCat Token) L.extraLibs + <*> monoidalFieldAla "extra-libraries-static" (alaList' VCat Token) L.extraLibsStatic + ^^^ availableSince CabalSpecV3_8 [] + <*> monoidalFieldAla "extra-ghci-libraries" (alaList' VCat Token) L.extraGHCiLibs + <*> monoidalFieldAla "extra-bundled-libraries" (alaList' VCat Token) L.extraBundledLibs + <*> monoidalFieldAla "extra-library-flavours" (alaList' VCat Token) L.extraLibFlavours <*> monoidalFieldAla "extra-dynamic-library-flavours" (alaList' VCat Token) L.extraDynLibFlavours - ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "extra-lib-dirs" (alaList' FSep FilePathNT) L.extraLibDirs - <*> monoidalFieldAla "extra-lib-dirs-static" (alaList' FSep FilePathNT) L.extraLibDirsStatic - ^^^ availableSince CabalSpecV3_8 [] - <*> monoidalFieldAla "include-dirs" (alaList' FSep FilePathNT) L.includeDirs - <*> monoidalFieldAla "includes" (alaList' FSep FilePathNT) L.includes - <*> monoidalFieldAla "autogen-includes" (alaList' FSep FilePathNT) L.autogenIncludes - ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "install-includes" (alaList' FSep FilePathNT) L.installIncludes + ^^^ availableSince CabalSpecV3_0 [] + <*> monoidalFieldAla "extra-lib-dirs" (alaList' FSep FilePathNT) L.extraLibDirs + <*> monoidalFieldAla "extra-lib-dirs-static" (alaList' FSep FilePathNT) L.extraLibDirsStatic + ^^^ availableSince CabalSpecV3_8 [] + <*> monoidalFieldAla "include-dirs" (alaList' FSep FilePathNT) L.includeDirs + <*> monoidalFieldAla "includes" (alaList' FSep FilePathNT) L.includes + <*> monoidalFieldAla "autogen-includes" (alaList' FSep FilePathNT) L.autogenIncludes + ^^^ availableSince CabalSpecV3_0 [] + <*> monoidalFieldAla "install-includes" (alaList' FSep FilePathNT) L.installIncludes <*> optionsFieldGrammar <*> profOptionsFieldGrammar <*> sharedOptionsFieldGrammar <*> pure mempty -- static-options ??? - <*> prefixedFields "x-" L.customFieldsBI - <*> monoidalFieldAla "build-depends" formatDependencyList L.targetBuildDepends - <*> monoidalFieldAla "mixins" formatMixinList L.mixins - ^^^ availableSince CabalSpecV2_0 [] + <*> prefixedFields "x-" L.customFieldsBI + <*> monoidalFieldAla "build-depends" formatDependencyList L.targetBuildDepends + <*> monoidalFieldAla "mixins" formatMixinList L.mixins + ^^^ availableSince CabalSpecV2_0 [] {-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfo #-} {-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfo #-} hsSourceDirsGrammar - :: ( FieldGrammar c g, Applicative (g BuildInfo) - , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) - ) - => g BuildInfo [SymbolicPath PackageDir SourceDir] -hsSourceDirsGrammar = (++) + :: ( FieldGrammar c g + , Applicative (g BuildInfo) + , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) + ) + => g BuildInfo [SymbolicPath PackageDir SourceDir] +hsSourceDirsGrammar = + (++) <$> monoidalFieldAla "hs-source-dirs" formatHsSourceDirs L.hsSourceDirs - <*> monoidalFieldAla "hs-source-dir" (alaList FSep) wrongLens - --- https://github.com/haskell/cabal/commit/49e3cdae3bdf21b017ccd42e66670ca402e22b44 - ^^^ deprecatedSince CabalSpecV1_2 "Please use 'hs-source-dirs'" - ^^^ removedIn CabalSpecV3_0 "Please use 'hs-source-dirs' field." + <*> monoidalFieldAla "hs-source-dir" (alaList FSep) wrongLens + --- https://github.com/haskell/cabal/commit/49e3cdae3bdf21b017ccd42e66670ca402e22b44 + ^^^ deprecatedSince CabalSpecV1_2 "Please use 'hs-source-dirs'" + ^^^ removedIn CabalSpecV3_0 "Please use 'hs-source-dirs' field." where -- TODO: make pretty printer aware of CabalSpecVersion wrongLens :: Functor f => LensLike' f BuildInfo [SymbolicPath PackageDir SourceDir] wrongLens f bi = (\fps -> set L.hsSourceDirs fps bi) <$> f [] optionsFieldGrammar - :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) - => g BuildInfo (PerCompilerFlavor [String]) -optionsFieldGrammar = PerCompilerFlavor - <$> monoidalFieldAla "ghc-options" (alaList' NoCommaFSep Token') (extract GHC) + :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) + => g BuildInfo (PerCompilerFlavor [String]) +optionsFieldGrammar = + PerCompilerFlavor + <$> monoidalFieldAla "ghc-options" (alaList' NoCommaFSep Token') (extract GHC) <*> monoidalFieldAla "ghcjs-options" (alaList' NoCommaFSep Token') (extract GHCJS) -- NOTE: Hugs, NHC and JHC are not supported anymore, but these -- fields are kept around so that we can still parse legacy .cabal -- files that have them. - <* knownField "jhc-options" - <* knownField "hugs-options" - <* knownField "nhc98-options" + <* knownField "jhc-options" + <* knownField "hugs-options" + <* knownField "nhc98-options" where extract :: CompilerFlavor -> ALens' BuildInfo [String] extract flavor = L.options . lookupLens flavor profOptionsFieldGrammar - :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) - => g BuildInfo (PerCompilerFlavor [String]) -profOptionsFieldGrammar = PerCompilerFlavor - <$> monoidalFieldAla "ghc-prof-options" (alaList' NoCommaFSep Token') (extract GHC) + :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) + => g BuildInfo (PerCompilerFlavor [String]) +profOptionsFieldGrammar = + PerCompilerFlavor + <$> monoidalFieldAla "ghc-prof-options" (alaList' NoCommaFSep Token') (extract GHC) <*> monoidalFieldAla "ghcjs-prof-options" (alaList' NoCommaFSep Token') (extract GHCJS) where extract :: CompilerFlavor -> ALens' BuildInfo [String] extract flavor = L.profOptions . lookupLens flavor sharedOptionsFieldGrammar - :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) - => g BuildInfo (PerCompilerFlavor [String]) -sharedOptionsFieldGrammar = PerCompilerFlavor - <$> monoidalFieldAla "ghc-shared-options" (alaList' NoCommaFSep Token') (extract GHC) + :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) + => g BuildInfo (PerCompilerFlavor [String]) +sharedOptionsFieldGrammar = + PerCompilerFlavor + <$> monoidalFieldAla "ghc-shared-options" (alaList' NoCommaFSep Token') (extract GHC) <*> monoidalFieldAla "ghcjs-shared-options" (alaList' NoCommaFSep Token') (extract GHCJS) where extract :: CompilerFlavor -> ALens' BuildInfo [String] @@ -659,21 +734,23 @@ sharedOptionsFieldGrammar = PerCompilerFlavor lookupLens :: (Functor f, Monoid v) => CompilerFlavor -> LensLike' f (PerCompilerFlavor v) v lookupLens k f p@(PerCompilerFlavor ghc ghcjs) - | k == GHC = (\n -> PerCompilerFlavor n ghcjs) <$> f ghc - | k == GHCJS = (\n -> PerCompilerFlavor ghc n) <$> f ghcjs - | otherwise = p <$ f mempty + | k == GHC = (\n -> PerCompilerFlavor n ghcjs) <$> f ghc + | k == GHCJS = (\n -> PerCompilerFlavor ghc n) <$> f ghcjs + | otherwise = p <$ f mempty ------------------------------------------------------------------------------- -- Flag ------------------------------------------------------------------------------- flagFieldGrammar - :: (FieldGrammar c g, Applicative (g PackageFlag)) - => FlagName -> g PackageFlag PackageFlag -flagFieldGrammar name = MkPackageFlag name - <$> freeTextFieldDef "description" L.flagDescription - <*> booleanFieldDef "default" L.flagDefault True - <*> booleanFieldDef "manual" L.flagManual False + :: (FieldGrammar c g, Applicative (g PackageFlag)) + => FlagName + -> g PackageFlag PackageFlag +flagFieldGrammar name = + MkPackageFlag name + <$> freeTextFieldDef "description" L.flagDescription + <*> booleanFieldDef "default" L.flagDefault True + <*> booleanFieldDef "manual" L.flagManual False {-# SPECIALIZE flagFieldGrammar :: FlagName -> ParsecFieldGrammar' PackageFlag #-} {-# SPECIALIZE flagFieldGrammar :: FlagName -> PrettyFieldGrammar' PackageFlag #-} @@ -682,15 +759,17 @@ flagFieldGrammar name = MkPackageFlag name ------------------------------------------------------------------------------- sourceRepoFieldGrammar - :: (FieldGrammar c g, Applicative (g SourceRepo), c (Identity RepoType), c Token, c FilePathNT) - => RepoKind -> g SourceRepo SourceRepo -sourceRepoFieldGrammar kind = SourceRepo kind - <$> optionalField "type" L.repoType - <*> freeTextField "location" L.repoLocation - <*> optionalFieldAla "module" Token L.repoModule - <*> optionalFieldAla "branch" Token L.repoBranch - <*> optionalFieldAla "tag" Token L.repoTag - <*> optionalFieldAla "subdir" FilePathNT L.repoSubdir + :: (FieldGrammar c g, Applicative (g SourceRepo), c (Identity RepoType), c Token, c FilePathNT) + => RepoKind + -> g SourceRepo SourceRepo +sourceRepoFieldGrammar kind = + SourceRepo kind + <$> optionalField "type" L.repoType + <*> freeTextField "location" L.repoLocation + <*> optionalFieldAla "module" Token L.repoModule + <*> optionalFieldAla "branch" Token L.repoBranch + <*> optionalFieldAla "tag" Token L.repoTag + <*> optionalFieldAla "subdir" FilePathNT L.repoSubdir {-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind -> ParsecFieldGrammar' SourceRepo #-} {-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind -> PrettyFieldGrammar' SourceRepo #-} @@ -699,9 +778,11 @@ sourceRepoFieldGrammar kind = SourceRepo kind ------------------------------------------------------------------------------- setupBInfoFieldGrammar - :: (FieldGrammar c g, Functor (g SetupBuildInfo), c (List CommaVCat (Identity Dependency) Dependency)) - => Bool -> g SetupBuildInfo SetupBuildInfo -setupBInfoFieldGrammar def = flip SetupBuildInfo def + :: (FieldGrammar c g, Functor (g SetupBuildInfo), c (List CommaVCat (Identity Dependency) Dependency)) + => Bool + -> g SetupBuildInfo SetupBuildInfo +setupBInfoFieldGrammar def = + flip SetupBuildInfo def <$> monoidalFieldAla "setup-depends" (alaList CommaVCat) L.setupDepends {-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> ParsecFieldGrammar' SetupBuildInfo #-} {-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> PrettyFieldGrammar' SetupBuildInfo #-} @@ -752,39 +833,38 @@ formatOtherModules = alaList' VCat MQuoted -- -- across Hackage to outrule them completely. -- I suspect some of them are generated (e.g. formatted) by machine. --- -newtype CompatFilePath = CompatFilePath { getCompatFilePath :: FilePath } -- TODO: Change to use SymPath +newtype CompatFilePath = CompatFilePath {getCompatFilePath :: FilePath} -- TODO: Change to use SymPath instance Newtype String CompatFilePath instance Parsec CompatFilePath where - parsec = do - token <- parsecToken - if null token - then do - parsecWarning PWTEmptyFilePath "empty FilePath" - return (CompatFilePath "") - else return (CompatFilePath token) + parsec = do + token <- parsecToken + if null token + then do + parsecWarning PWTEmptyFilePath "empty FilePath" + return (CompatFilePath "") + else return (CompatFilePath token) instance Pretty CompatFilePath where - pretty = showToken . getCompatFilePath + pretty = showToken . getCompatFilePath -newtype CompatLicenseFile = CompatLicenseFile { getCompatLicenseFile :: [SymbolicPath PackageDir LicenseFile] } +newtype CompatLicenseFile = CompatLicenseFile {getCompatLicenseFile :: [SymbolicPath PackageDir LicenseFile]} instance Newtype [SymbolicPath PackageDir LicenseFile] CompatLicenseFile -- TODO instance Parsec CompatLicenseFile where - parsec = emptyToken <|> CompatLicenseFile . unpack' (alaList FSep) <$> parsec - where - emptyToken = P.try $ do - token <- parsecToken - if null token - then return (CompatLicenseFile []) - else P.unexpected "non-empty-token" + parsec = emptyToken <|> CompatLicenseFile . unpack' (alaList FSep) <$> parsec + where + emptyToken = P.try $ do + token <- parsecToken + if null token + then return (CompatLicenseFile []) + else P.unexpected "non-empty-token" instance Pretty CompatLicenseFile where - pretty = pretty . pack' (alaList FSep) . getCompatLicenseFile + pretty = pretty . pack' (alaList FSep) . getCompatLicenseFile ------------------------------------------------------------------------------- -- vim syntax definitions @@ -792,33 +872,40 @@ instance Pretty CompatLicenseFile where -- | '_syntaxFieldNames' and '_syntaxExtensions' -- are for generating VIM syntax file definitions. --- _syntaxFieldNames :: IO () -_syntaxFieldNames = sequence_ +_syntaxFieldNames = + sequence_ [ BS8.putStrLn $ " \\ " <> n - | n <- nub $ sort $ mconcat - [ fieldGrammarKnownFieldList packageDescriptionFieldGrammar - , fieldGrammarKnownFieldList $ libraryFieldGrammar LMainLibName - , fieldGrammarKnownFieldList $ executableFieldGrammar "exe" - , fieldGrammarKnownFieldList $ foreignLibFieldGrammar "flib" - , fieldGrammarKnownFieldList testSuiteFieldGrammar - , fieldGrammarKnownFieldList benchmarkFieldGrammar - , fieldGrammarKnownFieldList $ flagFieldGrammar (error "flagname") - , fieldGrammarKnownFieldList $ sourceRepoFieldGrammar (error "repokind") - , fieldGrammarKnownFieldList $ setupBInfoFieldGrammar True - ] + | n <- + nub $ + sort $ + mconcat + [ fieldGrammarKnownFieldList packageDescriptionFieldGrammar + , fieldGrammarKnownFieldList $ libraryFieldGrammar LMainLibName + , fieldGrammarKnownFieldList $ executableFieldGrammar "exe" + , fieldGrammarKnownFieldList $ foreignLibFieldGrammar "flib" + , fieldGrammarKnownFieldList testSuiteFieldGrammar + , fieldGrammarKnownFieldList benchmarkFieldGrammar + , fieldGrammarKnownFieldList $ flagFieldGrammar (error "flagname") + , fieldGrammarKnownFieldList $ sourceRepoFieldGrammar (error "repokind") + , fieldGrammarKnownFieldList $ setupBInfoFieldGrammar True + ] ] _syntaxExtensions :: IO () -_syntaxExtensions = sequence_ +_syntaxExtensions = + sequence_ [ putStrLn $ " \\ " <> e - | e <- ["Safe","Trustworthy","Unsafe"] - ++ es - ++ map ("No"++) es + | e <- + ["Safe", "Trustworthy", "Unsafe"] + ++ es + ++ map ("No" ++) es ] where - es = nub $ sort + es = + nub $ + sort [ prettyShow e - | e <- [ minBound .. maxBound ] - , e `notElem` [Safe,Unsafe,Trustworthy] + | e <- [minBound .. maxBound] + , e `notElem` [Safe, Unsafe, Trustworthy] ] diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs index db8fc5d5e90..bee6965c127 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.PackageDescription.Parsec -- Copyright : Isaac Jones 2003-2005 @@ -13,92 +15,93 @@ -- Portability : portable -- -- This defined parsers and partial pretty printers for the @.cabal@ format. - -module Distribution.PackageDescription.Parsec ( - -- * Package descriptions - parseGenericPackageDescription, - parseGenericPackageDescriptionMaybe, +module Distribution.PackageDescription.Parsec + ( -- * Package descriptions + parseGenericPackageDescription + , parseGenericPackageDescriptionMaybe -- ** Parsing - ParseResult, - runParseResult, + , ParseResult + , runParseResult -- * New-style spec-version - scanSpecVersion, + , scanSpecVersion -- ** Supplementary build information - parseHookedBuildInfo, - ) where + , parseHookedBuildInfo + ) where import Distribution.Compat.Prelude import Prelude () -import Control.Monad.State.Strict (StateT, execStateT) -import Control.Monad.Trans.Class (lift) +import Control.Monad.State.Strict (StateT, execStateT) +import Control.Monad.Trans.Class (lift) import Distribution.CabalSpecVersion import Distribution.Compat.Lens import Distribution.FieldGrammar -import Distribution.FieldGrammar.Parsec (NamelessField (..)) -import Distribution.Fields.ConfVar (parseConditionConfVar) -import Distribution.Fields.Field (FieldName, getName) -import Distribution.Fields.LexerMonad (LexWarning, toPWarnings) -import Distribution.Fields.Parser +import Distribution.FieldGrammar.Parsec (NamelessField (..)) +import Distribution.Fields.ConfVar (parseConditionConfVar) +import Distribution.Fields.Field (FieldName, getName) +import Distribution.Fields.LexerMonad (LexWarning, toPWarnings) import Distribution.Fields.ParseResult +import Distribution.Fields.Parser import Distribution.PackageDescription import Distribution.PackageDescription.Configuration (freeVars, transformAllBuildInfos) import Distribution.PackageDescription.FieldGrammar -import Distribution.PackageDescription.Quirks (patchQuirks) -import Distribution.Parsec (parsec, simpleParsecBS) -import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS) -import Distribution.Parsec.Position (Position (..), zeroPos) -import Distribution.Parsec.Warning (PWarnType (..)) -import Distribution.Pretty (prettyShow) -import Distribution.Utils.Generic (breakMaybe, fromUTF8BS, toUTF8BS, unfoldrM, validateUTF8) -import Distribution.Version (Version, mkVersion, versionNumbers) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Distribution.Compat.Newtype as Newtype -import qualified Distribution.Compat.NonEmptySet as NES -import qualified Distribution.Types.BuildInfo.Lens as L -import qualified Distribution.Types.Executable.Lens as L -import qualified Distribution.Types.ForeignLib.Lens as L +import Distribution.PackageDescription.Quirks (patchQuirks) +import Distribution.Parsec (parsec, simpleParsecBS) +import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS) +import Distribution.Parsec.Position (Position (..), zeroPos) +import Distribution.Parsec.Warning (PWarnType (..)) +import Distribution.Pretty (prettyShow) +import Distribution.Utils.Generic (breakMaybe, fromUTF8BS, toUTF8BS, unfoldrM, validateUTF8) +import Distribution.Version (Version, mkVersion, versionNumbers) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Distribution.Compat.Newtype as Newtype +import qualified Distribution.Compat.NonEmptySet as NES +import qualified Distribution.Types.BuildInfo.Lens as L +import qualified Distribution.Types.Executable.Lens as L +import qualified Distribution.Types.ForeignLib.Lens as L import qualified Distribution.Types.GenericPackageDescription.Lens as L -import qualified Distribution.Types.PackageDescription.Lens as L -import qualified Distribution.Types.SetupBuildInfo.Lens as L -import qualified Text.Parsec as P +import qualified Distribution.Types.PackageDescription.Lens as L +import qualified Distribution.Types.SetupBuildInfo.Lens as L +import qualified Text.Parsec as P ------------------------------------------------------------------------------ + -- | Parses the given file into a 'GenericPackageDescription'. -- -- In Cabal 1.2 the syntax for package descriptions was changed to a format -- with sections and possibly indented property descriptions. --- parseGenericPackageDescription :: BS.ByteString -> ParseResult GenericPackageDescription parseGenericPackageDescription bs = do - -- set scanned version - setCabalSpecVersion ver - - csv <- case ver of - -- if we get too new version, fail right away - Just v -> case cabalSpecFromVersionDigits (versionNumbers v) of - Just csv -> return (Just csv) - Nothing -> parseFatalFailure zeroPos $ - "Unsupported cabal-version " ++ prettyShow v ++ ". See https://github.com/haskell/cabal/issues/4899." - _ -> pure Nothing - - case readFields' bs'' of - Right (fs, lexWarnings) -> do - when patched $ - parseWarning zeroPos PWTQuirkyCabalFile "Legacy cabal file" - -- UTF8 is validated in a prepass step, afterwards parsing is lenient. - parseGenericPackageDescription' csv lexWarnings invalidUtf8 fs - -- TODO: better marshalling of errors - Left perr -> parseFatalFailure pos (show perr) where - ppos = P.errorPos perr - pos = Position (P.sourceLine ppos) (P.sourceColumn ppos) + -- set scanned version + setCabalSpecVersion ver + + csv <- case ver of + -- if we get too new version, fail right away + Just v -> case cabalSpecFromVersionDigits (versionNumbers v) of + Just csv -> return (Just csv) + Nothing -> + parseFatalFailure zeroPos $ + "Unsupported cabal-version " ++ prettyShow v ++ ". See https://github.com/haskell/cabal/issues/4899." + _ -> pure Nothing + + case readFields' bs'' of + Right (fs, lexWarnings) -> do + when patched $ + parseWarning zeroPos PWTQuirkyCabalFile "Legacy cabal file" + -- UTF8 is validated in a prepass step, afterwards parsing is lenient. + parseGenericPackageDescription' csv lexWarnings invalidUtf8 fs + -- TODO: better marshalling of errors + Left perr -> parseFatalFailure pos (show perr) + where + ppos = P.errorPos perr + pos = Position (P.sourceLine ppos) (P.sourceColumn ppos) where (patched, bs') = patchQuirks bs ver = scanSpecVersion bs' @@ -107,14 +110,13 @@ parseGenericPackageDescription bs = do -- if there are invalid utf8 characters, we make the bytestring valid. bs'' = case invalidUtf8 of - Nothing -> bs' - Just _ -> toUTF8BS (fromUTF8BS bs') - + Nothing -> bs' + Just _ -> toUTF8BS (fromUTF8BS bs') -- | 'Maybe' variant of 'parseGenericPackageDescription' parseGenericPackageDescriptionMaybe :: BS.ByteString -> Maybe GenericPackageDescription parseGenericPackageDescriptionMaybe = - either (const Nothing) Just . snd . runParseResult . parseGenericPackageDescription + either (const Nothing) Just . snd . runParseResult . parseGenericPackageDescription fieldlinesToBS :: [FieldLine ann] -> BS.ByteString fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs) @@ -124,9 +126,9 @@ type SectionParser = StateT SectionS ParseResult -- | State of section parser data SectionS = SectionS - { _stateGpd :: !GenericPackageDescription - , _stateCommonStanzas :: !(Map String CondTreeBuildInfo) - } + { _stateGpd :: !GenericPackageDescription + , _stateCommonStanzas :: !(Map String CondTreeBuildInfo) + } stateGpd :: Lens' SectionS GenericPackageDescription stateGpd f (SectionS gpd cs) = (\x -> SectionS x cs) <$> f gpd @@ -139,69 +141,78 @@ stateCommonStanzas f (SectionS gpd cs) = SectionS gpd <$> f cs -- Note [Accumulating parser] -- -- This parser has two "states": + -- * first we parse fields of PackageDescription + -- * then we parse sections (libraries, executables, etc) parseGenericPackageDescription' - :: Maybe CabalSpecVersion - -> [LexWarning] - -> Maybe Int - -> [Field Position] - -> ParseResult GenericPackageDescription + :: Maybe CabalSpecVersion + -> [LexWarning] + -> Maybe Int + -> [Field Position] + -> ParseResult GenericPackageDescription parseGenericPackageDescription' scannedVer lexWarnings utf8WarnPos fs = do - parseWarnings (toPWarnings lexWarnings) - for_ utf8WarnPos $ \pos -> - parseWarning zeroPos PWTUTF $ "UTF8 encoding problem at byte offset " ++ show pos - let (syntax, fs') = sectionizeFields fs - let (fields, sectionFields) = takeFields fs' - - -- cabal-version - specVer <- case scannedVer of - Just v -> return v - Nothing -> case Map.lookup "cabal-version" fields >>= safeLast of - Nothing -> return CabalSpecV1_0 - Just (MkNamelessField pos fls) -> do - -- version will be parsed twice, therefore we parse without warnings. - v <- withoutWarnings $ - Newtype.unpack' SpecVersion <$> - -- Use version with || and && but before addition of ^>= and removal of -any - runFieldParser pos parsec CabalSpecV1_24 fls - - -- if it were at the beginning, scanner would found it - when (v >= CabalSpecV2_2) $ parseFailure pos $ - "cabal-version should be at the beginning of the file starting with spec version 2.2. " ++ - "See https://github.com/haskell/cabal/issues/4899" - - return v - - -- reset cabal version, it might not be set - let specVer' = mkVersion (cabalSpecToVersionDigits specVer) - setCabalSpecVersion (Just specVer') - - -- Package description - pd <- parseFieldGrammar specVer fields packageDescriptionFieldGrammar - - -- Check that scanned and parsed versions match. - unless (specVer == specVersion pd) $ parseFailure zeroPos $ - "Scanned and parsed cabal-versions don't match " ++ - prettyShow (SpecVersion specVer) ++ " /= " ++ prettyShow (SpecVersion (specVersion pd)) - - maybeWarnCabalVersion syntax pd - - -- Sections - let gpd = emptyGenericPackageDescription - & L.packageDescription .~ pd - gpd1 <- view stateGpd <$> execStateT (goSections specVer sectionFields) (SectionS gpd Map.empty) - - let gpd2 = postProcessInternalDeps specVer gpd1 - checkForUndefinedFlags gpd2 - checkForUndefinedCustomSetup gpd2 - -- See nothunks test, without this deepseq we get (at least): - -- Thunk in ThunkInfo {thunkContext = ["PackageIdentifier","PackageDescription","GenericPackageDescription"]} - -- - -- TODO: re-benchmark, whether `deepseq` is important (both cabal-benchmarks and solver-benchmarks) - -- TODO: remove the need for deepseq if `deepseq` in fact matters - -- NOTE: IIRC it does affect (maximal) memory usage, which causes less GC pressure - gpd2 `deepseq` return gpd2 + parseWarnings (toPWarnings lexWarnings) + for_ utf8WarnPos $ \pos -> + parseWarning zeroPos PWTUTF $ "UTF8 encoding problem at byte offset " ++ show pos + let (syntax, fs') = sectionizeFields fs + let (fields, sectionFields) = takeFields fs' + + -- cabal-version + specVer <- case scannedVer of + Just v -> return v + Nothing -> case Map.lookup "cabal-version" fields >>= safeLast of + Nothing -> return CabalSpecV1_0 + Just (MkNamelessField pos fls) -> do + -- version will be parsed twice, therefore we parse without warnings. + v <- + withoutWarnings $ + Newtype.unpack' SpecVersion + <$> + -- Use version with || and && but before addition of ^>= and removal of -any + runFieldParser pos parsec CabalSpecV1_24 fls + + -- if it were at the beginning, scanner would found it + when (v >= CabalSpecV2_2) $ + parseFailure pos $ + "cabal-version should be at the beginning of the file starting with spec version 2.2. " + ++ "See https://github.com/haskell/cabal/issues/4899" + + return v + + -- reset cabal version, it might not be set + let specVer' = mkVersion (cabalSpecToVersionDigits specVer) + setCabalSpecVersion (Just specVer') + + -- Package description + pd <- parseFieldGrammar specVer fields packageDescriptionFieldGrammar + + -- Check that scanned and parsed versions match. + unless (specVer == specVersion pd) $ + parseFailure zeroPos $ + "Scanned and parsed cabal-versions don't match " + ++ prettyShow (SpecVersion specVer) + ++ " /= " + ++ prettyShow (SpecVersion (specVersion pd)) + + maybeWarnCabalVersion syntax pd + + -- Sections + let gpd = + emptyGenericPackageDescription + & L.packageDescription .~ pd + gpd1 <- view stateGpd <$> execStateT (goSections specVer sectionFields) (SectionS gpd Map.empty) + + let gpd2 = postProcessInternalDeps specVer gpd1 + checkForUndefinedFlags gpd2 + checkForUndefinedCustomSetup gpd2 + -- See nothunks test, without this deepseq we get (at least): + -- Thunk in ThunkInfo {thunkContext = ["PackageIdentifier","PackageDescription","GenericPackageDescription"]} + -- + -- TODO: re-benchmark, whether `deepseq` is important (both cabal-benchmarks and solver-benchmarks) + -- TODO: remove the need for deepseq if `deepseq` in fact matters + -- NOTE: IIRC it does affect (maximal) memory usage, which causes less GC pressure + gpd2 `deepseq` return gpd2 where safeLast :: [a] -> Maybe a safeLast = listToMaybe . reverse @@ -211,28 +222,27 @@ parseGenericPackageDescription' scannedVer lexWarnings utf8WarnPos fs = do maybeWarnCabalVersion :: Syntax -> PackageDescription -> ParseResult () maybeWarnCabalVersion syntax pkg - | syntax == NewSyntax && specVersion pkg < newSyntaxVersion - = parseWarning zeroPos PWTNewSyntax $ - "A package using section syntax must specify at least\n" - ++ "'cabal-version: >= 1.2'." - + | syntax == NewSyntax && specVersion pkg < newSyntaxVersion = + parseWarning zeroPos PWTNewSyntax $ + "A package using section syntax must specify at least\n" + ++ "'cabal-version: >= 1.2'." maybeWarnCabalVersion syntax pkg - | syntax == OldSyntax && specVersion pkg >= newSyntaxVersion - = parseWarning zeroPos PWTOldSyntax $ - "A package using 'cabal-version: " - ++ prettyShow (SpecVersion (specVersion pkg)) - ++ "' must use section syntax. See the Cabal user guide for details." - + | syntax == OldSyntax && specVersion pkg >= newSyntaxVersion = + parseWarning zeroPos PWTOldSyntax $ + "A package using 'cabal-version: " + ++ prettyShow (SpecVersion (specVersion pkg)) + ++ "' must use section syntax. See the Cabal user guide for details." maybeWarnCabalVersion _ _ = return () goSections :: CabalSpecVersion -> [Field Position] -> SectionParser () goSections specVer = traverse_ process where process (Field (Name pos name) _) = - lift $ parseWarning pos PWTTrailingFields $ - "Ignoring trailing fields after sections: " ++ show name + lift $ + parseWarning pos PWTTrailingFields $ + "Ignoring trailing fields after sections: " ++ show name process (Section name args secFields) = - parseSection name args secFields + parseSection name args secFields snoc x xs = xs ++ [x] @@ -240,154 +250,164 @@ goSections specVer = traverse_ process -- we need signature, because this is polymorphic, but not-closed parseCondTree' - :: L.HasBuildInfo a - => ParsecFieldGrammar' a -- ^ grammar - -> (BuildInfo -> a) - -> Map String CondTreeBuildInfo -- ^ common stanzas - -> [Field Position] - -> ParseResult (CondTree ConfVar [Dependency] a) + :: L.HasBuildInfo a + => ParsecFieldGrammar' a + -- \^ grammar + -> (BuildInfo -> a) + -> Map String CondTreeBuildInfo + -- \^ common stanzas + -> [Field Position] + -> ParseResult (CondTree ConfVar [Dependency] a) parseCondTree' = parseCondTreeWithCommonStanzas specVer parseSection :: Name Position -> [SectionArg Position] -> [Field Position] -> SectionParser () parseSection (Name pos name) args fields - | hasCommonStanzas == NoCommonStanzas, name == "common" = lift $ do + | hasCommonStanzas == NoCommonStanzas + , name == "common" = lift $ do parseWarning pos PWTUnknownSection $ "Ignoring section: common. You should set cabal-version: 2.2 or larger to use common stanzas." - - | name == "common" = do - commonStanzas <- use stateCommonStanzas - name' <- lift $ parseCommonName pos args - biTree <- lift $ parseCondTree' buildInfoFieldGrammar id commonStanzas fields - - case Map.lookup name' commonStanzas of - Nothing -> stateCommonStanzas .= Map.insert name' biTree commonStanzas - Just _ -> lift $ parseFailure pos $ - "Duplicate common stanza: " ++ name' - - | name == "library" && null args = do - prev <- use $ stateGpd . L.condLibrary - when (isJust prev) $ lift $ parseFailure pos $ + | name == "common" = do + commonStanzas <- use stateCommonStanzas + name' <- lift $ parseCommonName pos args + biTree <- lift $ parseCondTree' buildInfoFieldGrammar id commonStanzas fields + + case Map.lookup name' commonStanzas of + Nothing -> stateCommonStanzas .= Map.insert name' biTree commonStanzas + Just _ -> + lift $ + parseFailure pos $ + "Duplicate common stanza: " ++ name' + | name == "library" && null args = do + prev <- use $ stateGpd . L.condLibrary + when (isJust prev) $ + lift $ + parseFailure pos $ "Multiple main libraries; have you forgotten to specify a name for an internal library?" - commonStanzas <- use stateCommonStanzas - let name'' = LMainLibName - lib <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas fields - -- - -- TODO check that not set - stateGpd . L.condLibrary ?= lib - - -- Sublibraries - -- TODO: check cabal-version - | name == "library" = do - commonStanzas <- use stateCommonStanzas - name' <- parseUnqualComponentName pos args - let name'' = LSubLibName name' - lib <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas fields - -- TODO check duplicate name here? - stateGpd . L.condSubLibraries %= snoc (name', lib) - - -- TODO: check cabal-version - | name == "foreign-library" = do - commonStanzas <- use stateCommonStanzas - name' <- parseUnqualComponentName pos args - flib <- lift $ parseCondTree' (foreignLibFieldGrammar name') (fromBuildInfo' name') commonStanzas fields - - let hasType ts = foreignLibType ts /= foreignLibType mempty - unless (onAllBranches hasType flib) $ lift $ parseFailure pos $ concat - [ "Foreign library " ++ show (prettyShow name') - , " is missing required field \"type\" or the field " - , "is not present in all conditional branches. The " - , "available test types are: " - , intercalate ", " (map prettyShow knownForeignLibTypes) - ] - - -- TODO check duplicate name here? - stateGpd . L.condForeignLibs %= snoc (name', flib) - - | name == "executable" = do - commonStanzas <- use stateCommonStanzas - name' <- parseUnqualComponentName pos args - exe <- lift $ parseCondTree' (executableFieldGrammar name') (fromBuildInfo' name') commonStanzas fields - -- TODO check duplicate name here? - stateGpd . L.condExecutables %= snoc (name', exe) - - | name == "test-suite" = do - commonStanzas <- use stateCommonStanzas - name' <- parseUnqualComponentName pos args - testStanza <- lift $ parseCondTree' testSuiteFieldGrammar (fromBuildInfo' name') commonStanzas fields - testSuite <- lift $ traverse (validateTestSuite specVer pos) testStanza - - let hasType ts = testInterface ts /= testInterface mempty - unless (onAllBranches hasType testSuite) $ lift $ parseFailure pos $ concat - [ "Test suite " ++ show (prettyShow name') - - , concat $ case specVer of - v | v >= CabalSpecV3_8 -> - [ " is missing required field \"main-is\" or the field " - , "is not present in all conditional branches." - ] - _ -> + commonStanzas <- use stateCommonStanzas + let name'' = LMainLibName + lib <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas fields + -- + -- TODO check that not set + stateGpd . L.condLibrary ?= lib + + -- Sublibraries + -- TODO: check cabal-version + | name == "library" = do + commonStanzas <- use stateCommonStanzas + name' <- parseUnqualComponentName pos args + let name'' = LSubLibName name' + lib <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas fields + -- TODO check duplicate name here? + stateGpd . L.condSubLibraries %= snoc (name', lib) + + -- TODO: check cabal-version + | name == "foreign-library" = do + commonStanzas <- use stateCommonStanzas + name' <- parseUnqualComponentName pos args + flib <- lift $ parseCondTree' (foreignLibFieldGrammar name') (fromBuildInfo' name') commonStanzas fields + + let hasType ts = foreignLibType ts /= foreignLibType mempty + unless (onAllBranches hasType flib) $ + lift $ + parseFailure pos $ + concat + [ "Foreign library " ++ show (prettyShow name') + , " is missing required field \"type\" or the field " + , "is not present in all conditional branches. The " + , "available test types are: " + , intercalate ", " (map prettyShow knownForeignLibTypes) + ] + + -- TODO check duplicate name here? + stateGpd . L.condForeignLibs %= snoc (name', flib) + | name == "executable" = do + commonStanzas <- use stateCommonStanzas + name' <- parseUnqualComponentName pos args + exe <- lift $ parseCondTree' (executableFieldGrammar name') (fromBuildInfo' name') commonStanzas fields + -- TODO check duplicate name here? + stateGpd . L.condExecutables %= snoc (name', exe) + | name == "test-suite" = do + commonStanzas <- use stateCommonStanzas + name' <- parseUnqualComponentName pos args + testStanza <- lift $ parseCondTree' testSuiteFieldGrammar (fromBuildInfo' name') commonStanzas fields + testSuite <- lift $ traverse (validateTestSuite specVer pos) testStanza + + let hasType ts = testInterface ts /= testInterface mempty + unless (onAllBranches hasType testSuite) $ + lift $ + parseFailure pos $ + concat + [ "Test suite " ++ show (prettyShow name') + , concat $ case specVer of + v + | v >= CabalSpecV3_8 -> + [ " is missing required field \"main-is\" or the field " + , "is not present in all conditional branches." + ] + _ -> [ " is missing required field \"type\" or the field " , "is not present in all conditional branches. The " , "available test types are: " , intercalate ", " (map prettyShow knownTestTypes) ] - ] - - -- TODO check duplicate name here? - stateGpd . L.condTestSuites %= snoc (name', testSuite) - - | name == "benchmark" = do - commonStanzas <- use stateCommonStanzas - name' <- parseUnqualComponentName pos args - benchStanza <- lift $ parseCondTree' benchmarkFieldGrammar (fromBuildInfo' name') commonStanzas fields - bench <- lift $ traverse (validateBenchmark specVer pos) benchStanza - - let hasType ts = benchmarkInterface ts /= benchmarkInterface mempty - unless (onAllBranches hasType bench) $ lift $ parseFailure pos $ concat - [ "Benchmark " ++ show (prettyShow name') - , concat $ case specVer of - v | v >= CabalSpecV3_8 -> - [ " is missing required field \"main-is\" or the field " - , "is not present in all conditional branches." - ] - _ -> + ] + + -- TODO check duplicate name here? + stateGpd . L.condTestSuites %= snoc (name', testSuite) + | name == "benchmark" = do + commonStanzas <- use stateCommonStanzas + name' <- parseUnqualComponentName pos args + benchStanza <- lift $ parseCondTree' benchmarkFieldGrammar (fromBuildInfo' name') commonStanzas fields + bench <- lift $ traverse (validateBenchmark specVer pos) benchStanza + + let hasType ts = benchmarkInterface ts /= benchmarkInterface mempty + unless (onAllBranches hasType bench) $ + lift $ + parseFailure pos $ + concat + [ "Benchmark " ++ show (prettyShow name') + , concat $ case specVer of + v + | v >= CabalSpecV3_8 -> + [ " is missing required field \"main-is\" or the field " + , "is not present in all conditional branches." + ] + _ -> [ " is missing required field \"type\" or the field " , "is not present in all conditional branches. The " , "available benchmark types are: " , intercalate ", " (map prettyShow knownBenchmarkTypes) ] - ] - - -- TODO check duplicate name here? - stateGpd . L.condBenchmarks %= snoc (name', bench) - - | name == "flag" = do - name' <- parseNameBS pos args - name'' <- lift $ runFieldParser' [pos] parsec specVer (fieldLineStreamFromBS name') `recoverWith` mkFlagName "" - flag <- lift $ parseFields specVer fields (flagFieldGrammar name'') - -- Check default flag - stateGpd . L.genPackageFlags %= snoc flag - - | name == "custom-setup" && null args = do - sbi <- lift $ parseFields specVer fields (setupBInfoFieldGrammar False) - stateGpd . L.packageDescription . L.setupBuildInfo ?= sbi - - | name == "source-repository" = do - kind <- lift $ case args of - [SecArgName spos secName] -> - runFieldParser' [spos] parsec specVer (fieldLineStreamFromBS secName) `recoverWith` RepoHead - [] -> do - parseFailure pos "'source-repository' requires exactly one argument" - pure RepoHead - _ -> do - parseFailure pos $ "Invalid source-repository kind " ++ show args - pure RepoHead - - sr <- lift $ parseFields specVer fields (sourceRepoFieldGrammar kind) - stateGpd . L.packageDescription . L.sourceRepos %= snoc sr - - | otherwise = lift $ - parseWarning pos PWTUnknownSection $ "Ignoring section: " ++ show name + ] + + -- TODO check duplicate name here? + stateGpd . L.condBenchmarks %= snoc (name', bench) + | name == "flag" = do + name' <- parseNameBS pos args + name'' <- lift $ runFieldParser' [pos] parsec specVer (fieldLineStreamFromBS name') `recoverWith` mkFlagName "" + flag <- lift $ parseFields specVer fields (flagFieldGrammar name'') + -- Check default flag + stateGpd . L.genPackageFlags %= snoc flag + | name == "custom-setup" && null args = do + sbi <- lift $ parseFields specVer fields (setupBInfoFieldGrammar False) + stateGpd . L.packageDescription . L.setupBuildInfo ?= sbi + | name == "source-repository" = do + kind <- lift $ case args of + [SecArgName spos secName] -> + runFieldParser' [spos] parsec specVer (fieldLineStreamFromBS secName) `recoverWith` RepoHead + [] -> do + parseFailure pos "'source-repository' requires exactly one argument" + pure RepoHead + _ -> do + parseFailure pos $ "Invalid source-repository kind " ++ show args + pure RepoHead + + sr <- lift $ parseFields specVer fields (sourceRepoFieldGrammar kind) + stateGpd . L.packageDescription . L.sourceRepos %= snoc sr + | otherwise = + lift $ + parseWarning pos PWTUnknownSection $ + "Ignoring section: " ++ show name parseName :: Position -> [SectionArg Position] -> SectionParser String parseName pos args = fromUTF8BS <$> parseNameBS pos args @@ -395,31 +415,31 @@ parseName pos args = fromUTF8BS <$> parseNameBS pos args parseNameBS :: Position -> [SectionArg Position] -> SectionParser BS.ByteString -- TODO: use strict parser parseNameBS pos args = case args of - [SecArgName _pos secName] -> - pure secName - [SecArgStr _pos secName] -> - pure secName - [] -> do - lift $ parseFailure pos "name required" - pure "" - _ -> do - -- TODO: pretty print args - lift $ parseFailure pos $ "Invalid name " ++ show args - pure "" + [SecArgName _pos secName] -> + pure secName + [SecArgStr _pos secName] -> + pure secName + [] -> do + lift $ parseFailure pos "name required" + pure "" + _ -> do + -- TODO: pretty print args + lift $ parseFailure pos $ "Invalid name " ++ show args + pure "" parseCommonName :: Position -> [SectionArg Position] -> ParseResult String parseCommonName pos args = case args of - [SecArgName _pos secName] -> - pure $ fromUTF8BS secName - [SecArgStr _pos secName] -> - pure $ fromUTF8BS secName - [] -> do - parseFailure pos $ "name required" - pure "" - _ -> do - -- TODO: pretty print args - parseFailure pos $ "Invalid name " ++ show args - pure "" + [SecArgName _pos secName] -> + pure $ fromUTF8BS secName + [SecArgStr _pos secName] -> + pure $ fromUTF8BS secName + [] -> do + parseFailure pos $ "name required" + pure "" + _ -> do + -- TODO: pretty print args + parseFailure pos $ "Invalid name " ++ show args + pure "" -- TODO: avoid conversion to 'String'. parseUnqualComponentName :: Position -> [SectionArg Position] -> SectionParser UnqualComponentName @@ -427,76 +447,83 @@ parseUnqualComponentName pos args = mkUnqualComponentName <$> parseName pos args -- | Parse a non-recursive list of fields. parseFields - :: CabalSpecVersion - -> [Field Position] -- ^ fields to be parsed - -> ParsecFieldGrammar' a - -> ParseResult a + :: CabalSpecVersion + -> [Field Position] + -- ^ fields to be parsed + -> ParsecFieldGrammar' a + -> ParseResult a parseFields v fields grammar = do - let (fs0, ss) = partitionFields fields - traverse_ (traverse_ warnInvalidSubsection) ss - parseFieldGrammar v fs0 grammar + let (fs0, ss) = partitionFields fields + traverse_ (traverse_ warnInvalidSubsection) ss + parseFieldGrammar v fs0 grammar warnInvalidSubsection :: Section Position -> ParseResult () warnInvalidSubsection (MkSection (Name pos name) _ _) = - void $ parseFailure pos $ "invalid subsection " ++ show name + void $ parseFailure pos $ "invalid subsection " ++ show name parseCondTree - :: forall a. L.HasBuildInfo a - => CabalSpecVersion - -> HasElif -- ^ accept @elif@ - -> ParsecFieldGrammar' a -- ^ grammar - -> Map String CondTreeBuildInfo -- ^ common stanzas - -> (BuildInfo -> a) -- ^ constructor from buildInfo - -> (a -> [Dependency]) -- ^ condition extractor - -> [Field Position] - -> ParseResult (CondTree ConfVar [Dependency] a) + :: forall a + . L.HasBuildInfo a + => CabalSpecVersion + -> HasElif + -- ^ accept @elif@ + -> ParsecFieldGrammar' a + -- ^ grammar + -> Map String CondTreeBuildInfo + -- ^ common stanzas + -> (BuildInfo -> a) + -- ^ constructor from buildInfo + -> (a -> [Dependency]) + -- ^ condition extractor + -> [Field Position] + -> ParseResult (CondTree ConfVar [Dependency] a) parseCondTree v hasElif grammar commonStanzas fromBuildInfo cond = go where go fields0 = do - (fields, endo) <- - if v >= CabalSpecV3_0 - then processImports v fromBuildInfo commonStanzas fields0 - else traverse (warnImport v) fields0 >>= \fields1 -> return (catMaybes fields1, id) + (fields, endo) <- + if v >= CabalSpecV3_0 + then processImports v fromBuildInfo commonStanzas fields0 + else traverse (warnImport v) fields0 >>= \fields1 -> return (catMaybes fields1, id) - let (fs, ss) = partitionFields fields - x <- parseFieldGrammar v fs grammar - branches <- concat <$> traverse parseIfs ss - return $ endo $ CondNode x (cond x) branches + let (fs, ss) = partitionFields fields + x <- parseFieldGrammar v fs grammar + branches <- concat <$> traverse parseIfs ss + return $ endo $ CondNode x (cond x) branches parseIfs :: [Section Position] -> ParseResult [CondBranch ConfVar [Dependency] a] parseIfs [] = return [] parseIfs (MkSection (Name _ name) test fields : sections) | name == "if" = do - test' <- parseConditionConfVar test - fields' <- go fields - (elseFields, sections') <- parseElseIfs sections - return (CondBranch test' fields' elseFields : sections') + test' <- parseConditionConfVar test + fields' <- go fields + (elseFields, sections') <- parseElseIfs sections + return (CondBranch test' fields' elseFields : sections') parseIfs (MkSection (Name pos name) _ _ : sections) = do - parseWarning pos PWTInvalidSubsection $ "invalid subsection " ++ show name - parseIfs sections + parseWarning pos PWTInvalidSubsection $ "invalid subsection " ++ show name + parseIfs sections parseElseIfs - :: [Section Position] - -> ParseResult (Maybe (CondTree ConfVar [Dependency] a), [CondBranch ConfVar [Dependency] a]) + :: [Section Position] + -> ParseResult (Maybe (CondTree ConfVar [Dependency] a), [CondBranch ConfVar [Dependency] a]) parseElseIfs [] = return (Nothing, []) parseElseIfs (MkSection (Name pos name) args fields : sections) | name == "else" = do - unless (null args) $ - parseFailure pos $ "`else` section has section arguments " ++ show args - elseFields <- go fields - sections' <- parseIfs sections - return (Just elseFields, sections') - - parseElseIfs (MkSection (Name _ name) test fields : sections) | hasElif == HasElif, name == "elif" = do - test' <- parseConditionConfVar test - fields' <- go fields - (elseFields, sections') <- parseElseIfs sections - -- we parse an empty 'Fields', to get empty value for a node - a <- parseFieldGrammar v mempty grammar - return (Just $ CondNode a (cond a) [CondBranch test' fields' elseFields], sections') - + unless (null args) $ + parseFailure pos $ + "`else` section has section arguments " ++ show args + elseFields <- go fields + sections' <- parseIfs sections + return (Just elseFields, sections') + parseElseIfs (MkSection (Name _ name) test fields : sections) + | hasElif == HasElif + , name == "elif" = do + test' <- parseConditionConfVar test + fields' <- go fields + (elseFields, sections') <- parseElseIfs sections + -- we parse an empty 'Fields', to get empty value for a node + a <- parseFieldGrammar v mempty grammar + return (Just $ CondNode a (cond a) [CondBranch test' fields' elseFields], sections') parseElseIfs (MkSection (Name pos name) _ _ : sections) | name == "elif" = do - parseWarning pos PWTInvalidSubsection $ "invalid subsection \"elif\". You should set cabal-version: 2.2 or larger to use elif-conditionals." - (,) Nothing <$> parseIfs sections - + parseWarning pos PWTInvalidSubsection $ "invalid subsection \"elif\". You should set cabal-version: 2.2 or larger to use elif-conditionals." + (,) Nothing <$> parseIfs sections parseElseIfs sections = (,) Nothing <$> parseIfs sections {- Note [Accumulating parser] @@ -507,15 +534,15 @@ In there parser, @'FieldDescr' a@ is transformed into @Map FieldName (a -> FieldParser a)@. The weird value is used because we accumulate structure of @a@ by folding over the fields. There are various reasons for that: -* Almost all fields are optional +\* Almost all fields are optional -* This is simple approach so declarative bi-directional format (parsing and +\* This is simple approach so declarative bi-directional format (parsing and printing) of structure could be specified (list of @'FieldDescr' a@) -* There are surface syntax fields corresponding to single field in the file: +\* There are surface syntax fields corresponding to single field in the file: @license-file@ and @license-files@ -* This is quite safe approach. +\* This is quite safe approach. When/if we re-implement the parser to support formatting preservging roundtrip with new AST, this all need to be rewritten. @@ -555,7 +582,6 @@ with new AST, this all need to be rewritten. -- The approach is simple, and have good properties: -- -- * Common stanzas are parsed exactly once, even if not-used. Thus we report errors in them. --- type CondTreeBuildInfo = CondTree ConfVar [Dependency] BuildInfo -- | Create @a@ from 'BuildInfo'. @@ -565,49 +591,57 @@ type CondTreeBuildInfo = CondTree ConfVar [Dependency] BuildInfo -- -- This takes name, as 'FieldGrammar's take names too. class L.HasBuildInfo a => FromBuildInfo a where - fromBuildInfo' :: UnqualComponentName -> BuildInfo -> a + fromBuildInfo' :: UnqualComponentName -> BuildInfo -> a libraryFromBuildInfo :: LibraryName -> BuildInfo -> Library -libraryFromBuildInfo n bi = emptyLibrary - { libName = n +libraryFromBuildInfo n bi = + emptyLibrary + { libName = n , libVisibility = case n of - LMainLibName -> LibraryVisibilityPublic + LMainLibName -> LibraryVisibilityPublic LSubLibName _ -> LibraryVisibilityPrivate - , libBuildInfo = bi + , libBuildInfo = bi } -instance FromBuildInfo BuildInfo where fromBuildInfo' _ = id +instance FromBuildInfo BuildInfo where fromBuildInfo' _ = id instance FromBuildInfo ForeignLib where fromBuildInfo' n bi = set L.foreignLibName n $ set L.buildInfo bi emptyForeignLib -instance FromBuildInfo Executable where fromBuildInfo' n bi = set L.exeName n $ set L.buildInfo bi emptyExecutable +instance FromBuildInfo Executable where fromBuildInfo' n bi = set L.exeName n $ set L.buildInfo bi emptyExecutable instance FromBuildInfo TestSuiteStanza where - fromBuildInfo' _ bi = TestSuiteStanza Nothing Nothing Nothing bi [] + fromBuildInfo' _ bi = TestSuiteStanza Nothing Nothing Nothing bi [] instance FromBuildInfo BenchmarkStanza where - fromBuildInfo' _ bi = BenchmarkStanza Nothing Nothing Nothing bi + fromBuildInfo' _ bi = BenchmarkStanza Nothing Nothing Nothing bi parseCondTreeWithCommonStanzas - :: forall a. L.HasBuildInfo a - => CabalSpecVersion - -> ParsecFieldGrammar' a -- ^ grammar - -> (BuildInfo -> a) -- ^ construct fromBuildInfo - -> Map String CondTreeBuildInfo -- ^ common stanzas - -> [Field Position] - -> ParseResult (CondTree ConfVar [Dependency] a) + :: forall a + . L.HasBuildInfo a + => CabalSpecVersion + -> ParsecFieldGrammar' a + -- ^ grammar + -> (BuildInfo -> a) + -- ^ construct fromBuildInfo + -> Map String CondTreeBuildInfo + -- ^ common stanzas + -> [Field Position] + -> ParseResult (CondTree ConfVar [Dependency] a) parseCondTreeWithCommonStanzas v grammar fromBuildInfo commonStanzas fields = do - (fields', endo) <- processImports v fromBuildInfo commonStanzas fields - x <- parseCondTree v hasElif grammar commonStanzas fromBuildInfo (view L.targetBuildDepends) fields' - return (endo x) + (fields', endo) <- processImports v fromBuildInfo commonStanzas fields + x <- parseCondTree v hasElif grammar commonStanzas fromBuildInfo (view L.targetBuildDepends) fields' + return (endo x) where hasElif = specHasElif v processImports - :: forall a. L.HasBuildInfo a - => CabalSpecVersion - -> (BuildInfo -> a) -- ^ construct fromBuildInfo - -> Map String CondTreeBuildInfo -- ^ common stanzas - -> [Field Position] - -> ParseResult ([Field Position], CondTree ConfVar [Dependency] a -> CondTree ConfVar [Dependency] a) + :: forall a + . L.HasBuildInfo a + => CabalSpecVersion + -> (BuildInfo -> a) + -- ^ construct fromBuildInfo + -> Map String CondTreeBuildInfo + -- ^ common stanzas + -> [Field Position] + -> ParseResult ([Field Position], CondTree ConfVar [Dependency] a -> CondTree ConfVar [Dependency] a) processImports v fromBuildInfo commonStanzas = go [] where hasCommonStanzas = specHasCommonStanzas v @@ -615,44 +649,46 @@ processImports v fromBuildInfo commonStanzas = go [] getList' :: List CommaFSep Token String -> [String] getList' = Newtype.unpack - go acc (Field (Name pos name) _ : fields) | name == "import", hasCommonStanzas == NoCommonStanzas = do - parseWarning pos PWTUnknownField "Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas" - go acc fields + go acc (Field (Name pos name) _ : fields) + | name == "import" + , hasCommonStanzas == NoCommonStanzas = do + parseWarning pos PWTUnknownField "Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas" + go acc fields -- supported: go acc (Field (Name pos name) fls : fields) | name == "import" = do - names <- getList' <$> runFieldParser pos parsec v fls - names' <- for names $ \commonName -> - case Map.lookup commonName commonStanzas of - Nothing -> do - parseFailure pos $ "Undefined common stanza imported: " ++ commonName - pure Nothing - Just commonTree -> - pure (Just commonTree) + names <- getList' <$> runFieldParser pos parsec v fls + names' <- for names $ \commonName -> + case Map.lookup commonName commonStanzas of + Nothing -> do + parseFailure pos $ "Undefined common stanza imported: " ++ commonName + pure Nothing + Just commonTree -> + pure (Just commonTree) - go (acc ++ catMaybes names') fields + go (acc ++ catMaybes names') fields -- parse actual CondTree go acc fields = do - fields' <- catMaybes <$> traverse (warnImport v) fields - pure $ (fields', \x -> foldr (mergeCommonStanza fromBuildInfo) x acc) + fields' <- catMaybes <$> traverse (warnImport v) fields + pure $ (fields', \x -> foldr (mergeCommonStanza fromBuildInfo) x acc) -- | Warn on "import" fields, also map to Maybe, so errorneous fields can be filtered warnImport :: CabalSpecVersion -> Field Position -> ParseResult (Maybe (Field Position)) -warnImport v (Field (Name pos name) _) | name == "import" = do - if specHasCommonStanzas v == NoCommonStanzas +warnImport v (Field (Name pos name) _) | name == "import" = do + if specHasCommonStanzas v == NoCommonStanzas then parseWarning pos PWTUnknownField "Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas" else parseWarning pos PWTUnknownField "Unknown field: import. Common stanza imports should be at the top of the enclosing section" - return Nothing + return Nothing warnImport _ f = pure (Just f) mergeCommonStanza - :: L.HasBuildInfo a - => (BuildInfo -> a) - -> CondTree ConfVar [Dependency] BuildInfo - -> CondTree ConfVar [Dependency] a - -> CondTree ConfVar [Dependency] a + :: L.HasBuildInfo a + => (BuildInfo -> a) + -> CondTree ConfVar [Dependency] BuildInfo + -> CondTree ConfVar [Dependency] a + -> CondTree ConfVar [Dependency] a mergeCommonStanza fromBuildInfo (CondNode bi _ bis) (CondNode x _ cs) = - CondNode x' (x' ^. L.targetBuildDepends) cs' + CondNode x' (x' ^. L.targetBuildDepends) cs' where -- new value is old value with buildInfo field _prepended_. x' = x & L.buildInfo %~ (bi <>) @@ -674,13 +710,14 @@ onAllBranches p = go mempty -- one need one to satisfy the property because the configure step uses -- 'mappend' to join together the results of flag resolution. go :: a -> CondTree v c a -> Bool - go acc ct = let acc' = acc `mappend` condTreeData ct - in p acc' || any (goBranch acc') (condTreeComponents ct) + go acc ct = + let acc' = acc `mappend` condTreeData ct + in p acc' || any (goBranch acc') (condTreeComponents ct) -- Both the 'true' and the 'false' block must satisfy the property. goBranch :: a -> CondBranch v c a -> Bool - goBranch _ (CondBranch _ _ Nothing) = False - goBranch acc (CondBranch _ t (Just e)) = go acc t && go acc e + goBranch _ (CondBranch _ _ Nothing) = False + goBranch acc (CondBranch _ t (Just e)) = go acc t && go acc e ------------------------------------------------------------------------------- -- Post parsing checks @@ -690,32 +727,32 @@ onAllBranches p = go mempty -- -- * don't use undefined flags (very bad) -- * define flags which are unused (just bad) --- checkForUndefinedFlags :: GenericPackageDescription -> ParseResult () checkForUndefinedFlags gpd = do - let definedFlags, usedFlags :: Set.Set FlagName - definedFlags = toSetOf (L.genPackageFlags . traverse . getting flagName) gpd - usedFlags = getConst $ L.allCondTrees f gpd - - -- Note: we can check for defined, but unused flags here too. - unless (usedFlags `Set.isSubsetOf` definedFlags) $ parseFailure zeroPos $ - "These flags are used without having been defined: " ++ - intercalate ", " [ unFlagName fn | fn <- Set.toList $ usedFlags `Set.difference` definedFlags ] + let definedFlags, usedFlags :: Set.Set FlagName + definedFlags = toSetOf (L.genPackageFlags . traverse . getting flagName) gpd + usedFlags = getConst $ L.allCondTrees f gpd + + -- Note: we can check for defined, but unused flags here too. + unless (usedFlags `Set.isSubsetOf` definedFlags) $ + parseFailure zeroPos $ + "These flags are used without having been defined: " + ++ intercalate ", " [unFlagName fn | fn <- Set.toList $ usedFlags `Set.difference` definedFlags] where f :: CondTree ConfVar c a -> Const (Set.Set FlagName) (CondTree ConfVar c a) f ct = Const (Set.fromList (freeVars ct)) -- | Since @cabal-version: 1.24@ one can specify @custom-setup@. -- Let us require it. --- checkForUndefinedCustomSetup :: GenericPackageDescription -> ParseResult () checkForUndefinedCustomSetup gpd = do - let pd = packageDescription gpd - let csv = specVersion pd + let pd = packageDescription gpd + let csv = specVersion pd - when (buildType pd == Custom && isNothing (setupBuildInfo pd)) $ - when (csv >= CabalSpecV1_24) $ parseFailure zeroPos $ - "Since cabal-version: 1.24 specifying custom-setup section is mandatory" + when (buildType pd == Custom && isNothing (setupBuildInfo pd)) $ + when (csv >= CabalSpecV1_24) $ + parseFailure zeroPos $ + "Since cabal-version: 1.24 specifying custom-setup section is mandatory" ------------------------------------------------------------------------------- -- Post processing of internal dependencies @@ -761,12 +798,12 @@ checkForUndefinedCustomSetup gpd = do postProcessInternalDeps :: CabalSpecVersion -> GenericPackageDescription -> GenericPackageDescription postProcessInternalDeps specVer gpd - | specVer >= CabalSpecV3_4 = gpd - | otherwise = transformAllBuildInfos transformBI transformSBI gpd + | specVer >= CabalSpecV3_4 = gpd + | otherwise = transformAllBuildInfos transformBI transformSBI gpd where transformBI :: BuildInfo -> BuildInfo - transformBI - = over L.targetBuildDepends (concatMap transformD) + transformBI = + over L.targetBuildDepends (concatMap transformD) . over L.mixins (map transformM) transformSBI :: SetupBuildInfo -> SetupBuildInfo @@ -774,31 +811,30 @@ postProcessInternalDeps specVer gpd transformD :: Dependency -> [Dependency] transformD (Dependency pn vr ln) - | uqn `Set.member` internalLibs - , LMainLibName `NES.member` ln - = case NES.delete LMainLibName ln of - Nothing -> [dep] + | uqn `Set.member` internalLibs + , LMainLibName `NES.member` ln = + case NES.delete LMainLibName ln of + Nothing -> [dep] Just ln' -> [dep, Dependency pn vr ln'] where uqn = packageNameToUnqualComponentName pn dep = Dependency thisPn vr (NES.singleton (LSubLibName uqn)) - transformD d = [d] transformM :: Mixin -> Mixin transformM (Mixin pn LMainLibName incl) - | uqn `Set.member` internalLibs - = mkMixin thisPn (LSubLibName uqn) incl + | uqn `Set.member` internalLibs = + mkMixin thisPn (LSubLibName uqn) incl where uqn = packageNameToUnqualComponentName pn - transformM m = m thisPn :: PackageName thisPn = pkgName (package (packageDescription gpd)) internalLibs :: Set UnqualComponentName - internalLibs = Set.fromList + internalLibs = + Set.fromList [ n | (n, _) <- condSubLibraries gpd ] @@ -823,15 +859,15 @@ postProcessInternalDeps specVer gpd -- section. sectionizeFields :: [Field ann] -> (Syntax, [Field ann]) sectionizeFields fs = case classifyFields fs of - Just fields -> (OldSyntax, convert fields) - Nothing -> (NewSyntax, fs) + Just fields -> (OldSyntax, convert fields) + Nothing -> (NewSyntax, fs) where -- return 'Just' if all fields are simple fields classifyFields :: [Field ann] -> Maybe [(Name ann, [FieldLine ann])] classifyFields = traverse f where f (Field name fieldlines) = Just (name, fieldlines) - f _ = Nothing + f _ = Nothing trim = BS.dropWhile isSpace' . BS.reverse . BS.dropWhile isSpace' . BS.reverse isSpace' = (== 32) @@ -844,30 +880,32 @@ sectionizeFields fs = case classifyFields fs of -- compatible, we still allow it as a global field in old-style -- package description files and translate it to a local field by -- adding it to every non-empty section - (hdr0, exes0) = break ((=="executable") . getName . fst) fields + (hdr0, exes0) = break ((== "executable") . getName . fst) fields (hdr, libfs0) = partition (not . (`elem` libFieldNames) . getName . fst) hdr0 - (deps, libfs) = partition ((== "build-depends") . getName . fst) - libfs0 + (deps, libfs) = + partition + ((== "build-depends") . getName . fst) + libfs0 exes = unfoldr toExe exes0 toExe [] = Nothing toExe ((Name pos n, ls) : r) | n == "executable" = let (efs, r') = break ((== "executable") . getName . fst) r - in Just (Section (Name pos "executable") [SecArgName pos $ trim $ fieldlinesToBS ls] (map toField $ deps ++ efs), r') + in Just (Section (Name pos "executable") [SecArgName pos $ trim $ fieldlinesToBS ls] (map toField $ deps ++ efs), r') toExe _ = error "unexpected input to 'toExe'" lib = case libfs of - [] -> [] - ((Name pos _, _) : _) -> - [Section (Name pos "library") [] (map toField $ deps ++ libfs)] - - in map toField hdr ++ lib ++ exes + [] -> [] + ((Name pos _, _) : _) -> + [Section (Name pos "library") [] (map toField $ deps ++ libfs)] + in + map toField hdr ++ lib ++ exes -- | See 'sectionizeFields'. data Syntax = OldSyntax | NewSyntax - deriving (Eq, Show) + deriving (Eq, Show) -- TODO: libFieldNames :: [FieldName] @@ -879,57 +917,57 @@ libFieldNames = fieldGrammarKnownFieldList (libraryFieldGrammar LMainLibName) parseHookedBuildInfo :: BS.ByteString -> ParseResult HookedBuildInfo parseHookedBuildInfo bs = case readFields' bs of - Right (fs, lexWarnings) -> do - parseHookedBuildInfo' lexWarnings fs - -- TODO: better marshalling of errors - Left perr -> parseFatalFailure zeroPos (show perr) + Right (fs, lexWarnings) -> do + parseHookedBuildInfo' lexWarnings fs + -- TODO: better marshalling of errors + Left perr -> parseFatalFailure zeroPos (show perr) parseHookedBuildInfo' - :: [LexWarning] - -> [Field Position] - -> ParseResult HookedBuildInfo + :: [LexWarning] + -> [Field Position] + -> ParseResult HookedBuildInfo parseHookedBuildInfo' lexWarnings fs = do - parseWarnings (toPWarnings lexWarnings) - (mLibFields, exes) <- stanzas fs - mLib <- parseLib mLibFields - biExes <- traverse parseExe exes - return (mLib, biExes) + parseWarnings (toPWarnings lexWarnings) + (mLibFields, exes) <- stanzas fs + mLib <- parseLib mLibFields + biExes <- traverse parseExe exes + return (mLib, biExes) where parseLib :: Fields Position -> ParseResult (Maybe BuildInfo) parseLib fields - | Map.null fields = pure Nothing - | otherwise = Just <$> parseFieldGrammar cabalSpecLatest fields buildInfoFieldGrammar + | Map.null fields = pure Nothing + | otherwise = Just <$> parseFieldGrammar cabalSpecLatest fields buildInfoFieldGrammar parseExe :: (UnqualComponentName, Fields Position) -> ParseResult (UnqualComponentName, BuildInfo) parseExe (n, fields) = do - bi <- parseFieldGrammar cabalSpecLatest fields buildInfoFieldGrammar - pure (n, bi) + bi <- parseFieldGrammar cabalSpecLatest fields buildInfoFieldGrammar + pure (n, bi) stanzas :: [Field Position] -> ParseResult (Fields Position, [(UnqualComponentName, Fields Position)]) stanzas fields = do - let (hdr0, exes0) = breakMaybe isExecutableField fields - hdr <- toFields hdr0 - exes <- unfoldrM (traverse toExe) exes0 - pure (hdr, exes) + let (hdr0, exes0) = breakMaybe isExecutableField fields + hdr <- toFields hdr0 + exes <- unfoldrM (traverse toExe) exes0 + pure (hdr, exes) toFields :: [Field Position] -> ParseResult (Fields Position) toFields fields = do - let (fields', ss) = partitionFields fields - traverse_ (traverse_ warnInvalidSubsection) ss - pure fields' + let (fields', ss) = partitionFields fields + traverse_ (traverse_ warnInvalidSubsection) ss + pure fields' toExe - :: ([FieldLine Position], [Field Position]) - -> ParseResult ((UnqualComponentName, Fields Position), Maybe ([FieldLine Position], [Field Position])) + :: ([FieldLine Position], [Field Position]) + -> ParseResult ((UnqualComponentName, Fields Position), Maybe ([FieldLine Position], [Field Position])) toExe (fss, fields) = do - name <- runFieldParser zeroPos parsec cabalSpecLatest fss - let (hdr0, rest) = breakMaybe isExecutableField fields - hdr <- toFields hdr0 - pure ((name, hdr), rest) + name <- runFieldParser zeroPos parsec cabalSpecLatest fss + let (hdr0, rest) = breakMaybe isExecutableField fields + hdr <- toFields hdr0 + pure ((name, hdr), rest) isExecutableField (Field (Name _ name) fss) - | name == "executable" = Just fss - | otherwise = Nothing + | name == "executable" = Just fss + | otherwise = Nothing isExecutableField _ = Nothing ------------------------------------------------------------------------------- @@ -952,29 +990,29 @@ parseHookedBuildInfo' lexWarnings fs = do -- DIGITP = %x31-39 -- WS = %20 -- @ --- scanSpecVersion :: BS.ByteString -> Maybe Version scanSpecVersion bs = do - fstline':_ <- pure (BS8.lines bs) - - -- parse - -- normalise: remove all whitespace, convert to lower-case - let fstline = BS.map toLowerW8 $ BS.filter (/= 0x20) fstline' - ["cabal-version",vers] <- pure (BS8.split ':' fstline) - - -- parse - -- - -- This is currently more tolerant regarding leading 0 digits. - -- - ver <- simpleParsecBS vers - guard $ case versionNumbers ver of - [_,_] -> True - [_,_,_] -> True - _ -> False - - pure ver + fstline' : _ <- pure (BS8.lines bs) + + -- parse + -- normalise: remove all whitespace, convert to lower-case + let fstline = BS.map toLowerW8 $ BS.filter (/= 0x20) fstline' + ["cabal-version", vers] <- pure (BS8.split ':' fstline) + + -- parse + -- + -- This is currently more tolerant regarding leading 0 digits. + -- + ver <- simpleParsecBS vers + guard $ case versionNumbers ver of + [_, _] -> True + [_, _, _] -> True + _ -> False + + pure ver where - -- | Translate ['A'..'Z'] to ['a'..'z'] + -- \| Translate ['A'..'Z'] to ['a'..'z'] toLowerW8 :: Word8 -> Word8 - toLowerW8 w | 0x40 < w && w < 0x5b = w+0x20 - | otherwise = w + toLowerW8 w + | 0x40 < w && w < 0x5b = w + 0x20 + | otherwise = w diff --git a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs index 4a2f5409695..b03b1b99ada 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs @@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.PackageDescription.PrettyPrint -- Copyright : Jürgen Nicklisch-Franken 2010 @@ -10,46 +14,52 @@ -- Portability : portable -- -- Pretty printing for cabal files --- ------------------------------------------------------------------------------ - -module Distribution.PackageDescription.PrettyPrint ( - -- * Generic package descriptions - writeGenericPackageDescription, - showGenericPackageDescription, - ppGenericPackageDescription, +module Distribution.PackageDescription.PrettyPrint + ( -- * Generic package descriptions + writeGenericPackageDescription + , showGenericPackageDescription + , ppGenericPackageDescription -- * Package descriptions - writePackageDescription, - showPackageDescription, + , writePackageDescription + , showPackageDescription - -- ** Supplementary build information - writeHookedBuildInfo, - showHookedBuildInfo, -) where + -- ** Supplementary build information + , writeHookedBuildInfo + , showHookedBuildInfo + ) where import Distribution.Compat.Prelude import Prelude () import Distribution.CabalSpecVersion -import Distribution.Fields.Pretty import Distribution.Compat.Lens +import Distribution.FieldGrammar (PrettyFieldGrammar', prettyFieldGrammar) +import Distribution.Fields.Pretty import Distribution.PackageDescription -import Distribution.Pretty -import Distribution.FieldGrammar (PrettyFieldGrammar', prettyFieldGrammar) import Distribution.PackageDescription.Configuration (transformAllBuildInfos) import Distribution.PackageDescription.FieldGrammar - (benchmarkFieldGrammar, buildInfoFieldGrammar, executableFieldGrammar, flagFieldGrammar, foreignLibFieldGrammar, libraryFieldGrammar, - packageDescriptionFieldGrammar, setupBInfoFieldGrammar, sourceRepoFieldGrammar, testSuiteFieldGrammar) -import Distribution.Utils.Generic (writeFileAtomic, writeUTF8File) + ( benchmarkFieldGrammar + , buildInfoFieldGrammar + , executableFieldGrammar + , flagFieldGrammar + , foreignLibFieldGrammar + , libraryFieldGrammar + , packageDescriptionFieldGrammar + , setupBInfoFieldGrammar + , sourceRepoFieldGrammar + , testSuiteFieldGrammar + ) +import Distribution.Pretty +import Distribution.Utils.Generic (writeFileAtomic, writeUTF8File) import qualified Distribution.PackageDescription.FieldGrammar as FG -import qualified Distribution.Types.BuildInfo.Lens as L -import qualified Distribution.Types.SetupBuildInfo.Lens as L +import qualified Distribution.Types.BuildInfo.Lens as L +import qualified Distribution.Types.SetupBuildInfo.Lens as L import Text.PrettyPrint (Doc, char, hsep, parens, text) -import qualified Data.ByteString.Lazy.Char8 as BS.Char8 +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Distribution.Compat.NonEmptySet as NES -- | Writes a .cabal file from a generic package description @@ -64,7 +74,8 @@ showGenericPackageDescription gpd = showFields (const NoComment) $ ppGenericPack -- | Convert a generic package description to 'PrettyField's. ppGenericPackageDescription :: CabalSpecVersion -> GenericPackageDescription -> [PrettyField ()] -ppGenericPackageDescription v gpd0 = concat +ppGenericPackageDescription v gpd0 = + concat [ ppPackageDescription v (packageDescription gpd) , ppSetupBInfo v (setupBuildInfo (packageDescription gpd)) , ppGenPackageFlags v (genPackageFlags gpd) @@ -78,17 +89,17 @@ ppGenericPackageDescription v gpd0 = concat where gpd = preProcessInternalDeps (specVersion (packageDescription gpd0)) gpd0 - ppPackageDescription :: CabalSpecVersion -> PackageDescription -> [PrettyField ()] ppPackageDescription v pd = - prettyFieldGrammar v packageDescriptionFieldGrammar pd + prettyFieldGrammar v packageDescriptionFieldGrammar pd ++ ppSourceRepos v (sourceRepos pd) ppSourceRepos :: CabalSpecVersion -> [SourceRepo] -> [PrettyField ()] ppSourceRepos = map . ppSourceRepo ppSourceRepo :: CabalSpecVersion -> SourceRepo -> PrettyField () -ppSourceRepo v repo = PrettySection () "source-repository" [pretty kind] $ +ppSourceRepo v repo = + PrettySection () "source-repository" [pretty kind] $ prettyFieldGrammar v (sourceRepoFieldGrammar kind) repo where kind = repoKind repo @@ -96,15 +107,18 @@ ppSourceRepo v repo = PrettySection () "source-repository" [pretty kind] $ ppSetupBInfo :: CabalSpecVersion -> Maybe SetupBuildInfo -> [PrettyField ()] ppSetupBInfo _ Nothing = mempty ppSetupBInfo v (Just sbi) - | defaultSetupDepends sbi = mempty - | otherwise = pure $ PrettySection () "custom-setup" [] $ - prettyFieldGrammar v (setupBInfoFieldGrammar False) sbi + | defaultSetupDepends sbi = mempty + | otherwise = + pure $ + PrettySection () "custom-setup" [] $ + prettyFieldGrammar v (setupBInfoFieldGrammar False) sbi ppGenPackageFlags :: CabalSpecVersion -> [PackageFlag] -> [PrettyField ()] ppGenPackageFlags = map . ppFlag ppFlag :: CabalSpecVersion -> PackageFlag -> PrettyField () -ppFlag v flag@(MkPackageFlag name _ _ _) = PrettySection () "flag" [ppFlagName name] $ +ppFlag v flag@(MkPackageFlag name _ _ _) = + PrettySection () "flag" [ppFlagName name] $ prettyFieldGrammar v (flagFieldGrammar name) flag ppCondTree2 :: CabalSpecVersion -> PrettyFieldGrammar' s -> CondTree ConfVar [Dependency] s -> [PrettyField ()] @@ -112,15 +126,14 @@ ppCondTree2 v grammar = go where -- TODO: recognise elif opportunities go (CondNode it _ ifs) = - prettyFieldGrammar v grammar it ++ - concatMap ppIf ifs + prettyFieldGrammar v grammar it + ++ concatMap ppIf ifs ppIf (CondBranch c thenTree Nothing) --- | isEmpty thenDoc = mempty - | otherwise = [ppIfCondition c thenDoc] + -- | isEmpty thenDoc = mempty + | otherwise = [ppIfCondition c thenDoc] where thenDoc = go thenTree - ppIf (CondBranch c thenTree (Just elseTree)) = -- See #6193 [ ppIfCondition c (go thenTree) @@ -129,60 +142,74 @@ ppCondTree2 v grammar = go ppCondLibrary :: CabalSpecVersion -> Maybe (CondTree ConfVar [Dependency] Library) -> [PrettyField ()] ppCondLibrary _ Nothing = mempty -ppCondLibrary v (Just condTree) = pure $ PrettySection () "library" [] $ - ppCondTree2 v (libraryFieldGrammar LMainLibName) condTree +ppCondLibrary v (Just condTree) = + pure $ + PrettySection () "library" [] $ + ppCondTree2 v (libraryFieldGrammar LMainLibName) condTree ppCondSubLibraries :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)] -> [PrettyField ()] ppCondSubLibraries v libs = - [ PrettySection () "library" [pretty n] - $ ppCondTree2 v (libraryFieldGrammar $ LSubLibName n) condTree - | (n, condTree) <- libs - ] + [ PrettySection () "library" [pretty n] $ + ppCondTree2 v (libraryFieldGrammar $ LSubLibName n) condTree + | (n, condTree) <- libs + ] ppCondForeignLibs :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)] -> [PrettyField ()] ppCondForeignLibs v flibs = - [ PrettySection () "foreign-library" [pretty n] - $ ppCondTree2 v (foreignLibFieldGrammar n) condTree - | (n, condTree) <- flibs - ] + [ PrettySection () "foreign-library" [pretty n] $ + ppCondTree2 v (foreignLibFieldGrammar n) condTree + | (n, condTree) <- flibs + ] ppCondExecutables :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] -> [PrettyField ()] ppCondExecutables v exes = - [ PrettySection () "executable" [pretty n] - $ ppCondTree2 v (executableFieldGrammar n) condTree - | (n, condTree) <- exes - ] + [ PrettySection () "executable" [pretty n] $ + ppCondTree2 v (executableFieldGrammar n) condTree + | (n, condTree) <- exes + ] ppCondTestSuites :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)] -> [PrettyField ()] ppCondTestSuites v suites = - [ PrettySection () "test-suite" [pretty n] - $ ppCondTree2 v testSuiteFieldGrammar (fmap FG.unvalidateTestSuite condTree) - | (n, condTree) <- suites - ] + [ PrettySection () "test-suite" [pretty n] $ + ppCondTree2 v testSuiteFieldGrammar (fmap FG.unvalidateTestSuite condTree) + | (n, condTree) <- suites + ] ppCondBenchmarks :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)] -> [PrettyField ()] ppCondBenchmarks v suites = - [ PrettySection () "benchmark" [pretty n] - $ ppCondTree2 v benchmarkFieldGrammar (fmap FG.unvalidateBenchmark condTree) - | (n, condTree) <- suites - ] + [ PrettySection () "benchmark" [pretty n] $ + ppCondTree2 v benchmarkFieldGrammar (fmap FG.unvalidateBenchmark condTree) + | (n, condTree) <- suites + ] ppCondition :: Condition ConfVar -> Doc -ppCondition (Var x) = ppConfVar x -ppCondition (Lit b) = text (show b) -ppCondition (CNot c) = char '!' <<>> (ppCondition c) -ppCondition (COr c1 c2) = parens (hsep [ppCondition c1, text "||" - <+> ppCondition c2]) -ppCondition (CAnd c1 c2) = parens (hsep [ppCondition c1, text "&&" - <+> ppCondition c2]) +ppCondition (Var x) = ppConfVar x +ppCondition (Lit b) = text (show b) +ppCondition (CNot c) = char '!' <<>> (ppCondition c) +ppCondition (COr c1 c2) = + parens + ( hsep + [ ppCondition c1 + , text "||" + <+> ppCondition c2 + ] + ) +ppCondition (CAnd c1 c2) = + parens + ( hsep + [ ppCondition c1 + , text "&&" + <+> ppCondition c2 + ] + ) ppConfVar :: ConfVar -> Doc -ppConfVar (OS os) = text "os" <<>> parens (pretty os) -ppConfVar (Arch arch) = text "arch" <<>> parens (pretty arch) +ppConfVar (OS os) = text "os" <<>> parens (pretty os) +ppConfVar (Arch arch) = text "arch" <<>> parens (pretty arch) ppConfVar (PackageFlag name) = text "flag" <<>> parens (ppFlagName name) -ppConfVar (Impl c v) = text "impl" <<>> parens (pretty c <+> pretty v) +ppConfVar (Impl c v) = text "impl" <<>> parens (pretty c <+> pretty v) ppFlagName :: FlagName -> Doc -ppFlagName = text . unFlagName +ppFlagName = text . unFlagName ppIfCondition :: Condition ConfVar -> [PrettyField ()] -> PrettyField () ppIfCondition c = PrettySection () "if" [ppCondition c] @@ -191,7 +218,7 @@ ppIfCondition c = PrettySection () "if" [ppCondition c] writePackageDescription :: FilePath -> PackageDescription -> IO () writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg) ---TODO: make this use section syntax +-- TODO: make this use section syntax -- add equivalent for GenericPackageDescription -- | @since 2.0.0.2 @@ -199,26 +226,28 @@ showPackageDescription :: PackageDescription -> String showPackageDescription = showGenericPackageDescription . pdToGpd pdToGpd :: PackageDescription -> GenericPackageDescription -pdToGpd pd = GenericPackageDescription +pdToGpd pd = + GenericPackageDescription { packageDescription = pd - , gpdScannedVersion = Nothing - , genPackageFlags = [] - , condLibrary = mkCondTree <$> library pd - , condSubLibraries = mkCondTreeL <$> subLibraries pd - , condForeignLibs = mkCondTree' foreignLibName <$> foreignLibs pd - , condExecutables = mkCondTree' exeName <$> executables pd - , condTestSuites = mkCondTree' testName <$> testSuites pd - , condBenchmarks = mkCondTree' benchmarkName <$> benchmarks pd + , gpdScannedVersion = Nothing + , genPackageFlags = [] + , condLibrary = mkCondTree <$> library pd + , condSubLibraries = mkCondTreeL <$> subLibraries pd + , condForeignLibs = mkCondTree' foreignLibName <$> foreignLibs pd + , condExecutables = mkCondTree' exeName <$> executables pd + , condTestSuites = mkCondTree' testName <$> testSuites pd + , condBenchmarks = mkCondTree' benchmarkName <$> benchmarks pd } where -- We set CondTree's [Dependency] to an empty list, as it -- is not pretty printed anyway. - mkCondTree x = CondNode x [] [] + mkCondTree x = CondNode x [] [] mkCondTreeL l = (fromMaybe (mkUnqualComponentName "") (libraryNameString (libName l)), CondNode l [] []) mkCondTree' - :: (a -> UnqualComponentName) - -> a -> (UnqualComponentName, CondTree ConfVar [Dependency] a) + :: (a -> UnqualComponentName) + -> a + -> (UnqualComponentName, CondTree ConfVar [Dependency] a) mkCondTree' f x = (f x, CondNode x [] []) ------------------------------------------------------------------------------- @@ -229,12 +258,12 @@ pdToGpd pd = GenericPackageDescription -- preProcessInternalDeps :: CabalSpecVersion -> GenericPackageDescription -> GenericPackageDescription preProcessInternalDeps specVer gpd - | specVer >= CabalSpecV3_4 = gpd - | otherwise = transformAllBuildInfos transformBI transformSBI gpd + | specVer >= CabalSpecV3_4 = gpd + | otherwise = transformAllBuildInfos transformBI transformSBI gpd where transformBI :: BuildInfo -> BuildInfo - transformBI - = over L.targetBuildDepends (concatMap transformD) + transformBI = + over L.targetBuildDepends (concatMap transformD) . over L.mixins (map transformM) transformSBI :: SetupBuildInfo -> SetupBuildInfo @@ -242,22 +271,21 @@ preProcessInternalDeps specVer gpd transformD :: Dependency -> [Dependency] transformD (Dependency pn vr ln) - | pn == thisPn - = if LMainLibName `NES.member` ln - then Dependency thisPn vr mainLibSet : sublibs - else sublibs + | pn == thisPn = + if LMainLibName `NES.member` ln + then Dependency thisPn vr mainLibSet : sublibs + else sublibs where sublibs = - [ Dependency (unqualComponentNameToPackageName uqn) vr mainLibSet - | LSubLibName uqn <- NES.toList ln - ] - + [ Dependency (unqualComponentNameToPackageName uqn) vr mainLibSet + | LSubLibName uqn <- NES.toList ln + ] transformD d = [d] transformM :: Mixin -> Mixin transformM (Mixin pn (LSubLibName uqn) inc) - | pn == thisPn - = mkMixin (unqualComponentNameToPackageName uqn) LMainLibName inc + | pn == thisPn = + mkMixin (unqualComponentNameToPackageName uqn) LMainLibName inc transformM m = m thisPn :: PackageName @@ -269,14 +297,17 @@ preProcessInternalDeps specVer gpd -- | @since 2.0.0.2 writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO () -writeHookedBuildInfo fpath = writeFileAtomic fpath . BS.Char8.pack - . showHookedBuildInfo +writeHookedBuildInfo fpath = + writeFileAtomic fpath + . BS.Char8.pack + . showHookedBuildInfo -- | @since 2.0.0.2 showHookedBuildInfo :: HookedBuildInfo -> String -showHookedBuildInfo (mb_lib_bi, ex_bis) = showFields (const NoComment) $ - maybe mempty (prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar) mb_lib_bi ++ - [ PrettySection () "executable:" [pretty name] - $ prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar bi - | (name, bi) <- ex_bis - ] +showHookedBuildInfo (mb_lib_bi, ex_bis) = + showFields (const NoComment) $ + maybe mempty (prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar) mb_lib_bi + ++ [ PrettySection () "executable:" [pretty name] $ + prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar bi + | (name, bi) <- ex_bis + ] diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Quirks.hs b/Cabal-syntax/src/Distribution/PackageDescription/Quirks.hs index f2edfb3a387..61b831354cd 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/Quirks.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/Quirks.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes #-} + -- | -- -- @since 2.2.0.0 @@ -7,11 +8,11 @@ module Distribution.PackageDescription.Quirks (patchQuirks) where import Distribution.Compat.Prelude import Distribution.Utils.MD5 -import GHC.Fingerprint (Fingerprint (..)) +import GHC.Fingerprint (Fingerprint (..)) import Prelude () import qualified Data.ByteString as BS -import qualified Data.Map as Map +import qualified Data.Map as Map -- | Patch legacy @.cabal@ file contents to allow parsec parser to accept -- all of Hackage. @@ -21,274 +22,330 @@ import qualified Data.Map as Map -- @since 2.2.0.0 patchQuirks :: BS.ByteString -> (Bool, BS.ByteString) patchQuirks bs = case Map.lookup (BS.take 256 bs, md5 bs) patches of - Nothing -> (False, bs) - Just (post, f) - | post /= md5 output -> (False, bs) - | otherwise -> (True, output) - where - output = f bs + Nothing -> (False, bs) + Just (post, f) + | post /= md5 output -> (False, bs) + | otherwise -> (True, output) + where + output = f bs -- | 'patches' contains first 256 bytes, pre- and post-fingerprints and a patch function. patches :: Map.Map (BS.ByteString, Fingerprint) (Fingerprint, BS.ByteString -> BS.ByteString) -patches = Map.fromList +patches = + Map.fromList -- http://hackage.haskell.org/package/unicode-transforms-0.3.3 -- other-modules: . -- ReadP assumed dot is empty line - [ mk "-- This file has been generated from package.yaml by hpack version 0.17.0.\n--\n-- see: https://github.com/sol/hpack\n\nname: unicode-transforms\nversion: 0.3.3\nsynopsis: Unicode normalization\ndescription: Fast Unic" - (Fingerprint 15958160436627155571 10318709190730872881) - (Fingerprint 11008465475756725834 13815629925116264363) - (bsRemove " other-modules:\n .\n") -- TODO: remove trailing \n to test structural-diff - -- http://hackage.haskell.org/package/DSTM-0.1.2 - -- http://hackage.haskell.org/package/DSTM-0.1.1 - -- http://hackage.haskell.org/package/DSTM-0.1 - -- Other Modules: no dash - -- ReadP parsed as section - , mk "Name: DSTM\nVersion: 0.1.2\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed " - (Fingerprint 6919263071548559054 9050746360708965827) - (Fingerprint 17015177514298962556 11943164891661867280) - (bsReplace "Other modules:" "-- ") - , mk "Name: DSTM\nVersion: 0.1.1\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed " - (Fingerprint 17313105789069667153 9610429408495338584) - (Fingerprint 17250946493484671738 17629939328766863497) - (bsReplace "Other modules:" "-- ") - , mk "Name: DSTM\nVersion: 0.1\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed sy" - (Fingerprint 10502599650530614586 16424112934471063115) - (Fingerprint 13562014713536696107 17899511905611879358) - (bsReplace "Other modules:" "-- ") - -- http://hackage.haskell.org/package/control-monad-exception-mtl-0.10.3 - , mk "name: control-monad-exception-mtl\nversion: 0.10.3\nCabal-Version: >= 1.10\nbuild-type: Simple\nlicense: PublicDomain\nauthor: Pepe Iborra\nmaintainer: pepeiborra@gmail.com\nhomepage: http://pepeiborra.github.com/control-monad-exception\nsynopsis: MTL instances f" - (Fingerprint 18274748422558568404 4043538769550834851) - (Fingerprint 11395257416101232635 4303318131190196308) - (bsReplace " default- extensions:" "unknown-section") - -- http://hackage.haskell.org/package/vacuum-opengl-0.0 - -- \DEL character - , mk "Name: vacuum-opengl\nVersion: 0.0\nSynopsis: Visualize live Haskell data structures using vacuum, graphviz and OpenGL.\nDescription: \DELVisualize live Haskell data structures using vacuum, graphviz and OpenGL.\n " - (Fingerprint 5946760521961682577 16933361639326309422) - (Fingerprint 14034745101467101555 14024175957788447824) - (bsRemove "\DEL") - , mk "Name: vacuum-opengl\nVersion: 0.0.1\nSynopsis: Visualize live Haskell data structures using vacuum, graphviz and OpenGL.\nDescription: \DELVisualize live Haskell data structures using vacuum, graphviz and OpenGL.\n " - (Fingerprint 10790950110330119503 1309560249972452700) - (Fingerprint 1565743557025952928 13645502325715033593) - (bsRemove "\DEL") - -- http://hackage.haskell.org/package/ixset-1.0.4 - -- {- comments -} - , mk "Name: ixset\nVersion: 1.0.4\nSynopsis: Efficient relational queries on Haskell sets.\nDescription:\n Create and query sets that are indexed by multiple indices.\nLicense: BSD3\nLicense-file: COPYING\nAut" - (Fingerprint 11886092342440414185 4150518943472101551) - (Fingerprint 5731367240051983879 17473925006273577821) - (bsRemoveStarting "{-") - -- : after section - -- http://hackage.haskell.org/package/ds-kanren - , mk "name: ds-kanren\nversion: 0.2.0.0\nsynopsis: A subset of the miniKanren language\ndescription:\n ds-kanren is an implementation of the language.\n .\n == What's in ds-kanren?\n .\n ['dis" - (Fingerprint 2804006762382336875 9677726932108735838) - (Fingerprint 9830506174094917897 12812107316777006473) - (bsReplace "Test-Suite test-unify:" "Test-Suite \"test-unify:\"" . bsReplace "Test-Suite test-list-ops:" "Test-Suite \"test-list-ops:\"") - , mk "name: ds-kanren\nversion: 0.2.0.1\nsynopsis: A subset of the miniKanren language\ndescription:\n ds-kanren is an implementation of the language.\n\nlicense: MIT\nlicense-file: " - (Fingerprint 9130259649220396193 2155671144384738932) - (Fingerprint 1847988234352024240 4597789823227580457) - (bsReplace "Test-Suite test-unify:" "Test-Suite \"test-unify:\"" . bsReplace "Test-Suite test-list-ops:" "Test-Suite \"test-list-ops:\"") - , mk "name: metric\nversion: 0.1.4\nsynopsis: Metric spaces.\nlicense: MIT\nlicense-file: LICENSE\nauthor: Vikram Verma\nmaintainer: me@vikramverma.com\ncategory: Data\nbuild-type:" - (Fingerprint 6150019278861565482 3066802658031228162) - (Fingerprint 9124826020564520548 15629704249829132420) - (bsReplace "test-suite metric-tests:" "test-suite \"metric-tests:\"") - , mk "name: metric\nversion: 0.2.0\nsynopsis: Metric spaces.\nlicense: MIT\nlicense-file: LICENSE\nauthor: Vikram Verma\nmaintainer: me@vikramverma.com\ncategory: Data\nbuild-type:" - (Fingerprint 4639805967994715694 7859317050376284551) - (Fingerprint 5566222290622325231 873197212916959151) - (bsReplace "test-suite metric-tests:" "test-suite \"metric-tests:\"") - , mk "name: phasechange\ncategory: Data\nversion: 0.1\nauthor: G\195\161bor Lehel\nmaintainer: G\195\161bor Lehel \nhomepage: http://github.com/glehel/phasechange\ncopyright: Copyright (C) 2012 G\195\161bor Lehel\nlicense: " - (Fingerprint 10546509771395401582 245508422312751943) - (Fingerprint 5169853482576003304 7247091607933993833) - (bsReplace "impl(ghc >= 7.4):" "erroneous-section" . bsReplace "impl(ghc >= 7.6):" "erroneous-section") - , mk "Name: smartword\nSynopsis: Web based flash card for Word Smart I and II vocabularies\nVersion: 0.0.0.5\nHomepage: http://kyagrd.dyndns.org/~kyagrd/project/smartword/\nCategory: Web,Education\nLicense: " - (Fingerprint 7803544783533485151 10807347873998191750) - (Fingerprint 1665635316718752601 16212378357991151549) - (bsReplace "build depends:" "--") - , mk "name: shelltestrunner\n-- sync with README.md, ANNOUNCE:\nversion: 1.3\ncategory: Testing\nsynopsis: A tool for testing command-line programs.\ndescription:\n shelltestrunner is a cross-platform tool for testing command-line\n program" - (Fingerprint 4403237110790078829 15392625961066653722) - (Fingerprint 10218887328390239431 4644205837817510221) - (bsReplace "other modules:" "--") - -- &&! - -- http://hackage.haskell.org/package/hblas-0.3.0.0 - , mk "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- " - (Fingerprint 8570120150072467041 18315524331351505945) - (Fingerprint 10838007242302656005 16026440017674974175) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- " - (Fingerprint 5262875856214215155 10846626274067555320) - (Fingerprint 3022954285783401045 13395975869915955260) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- " - (Fingerprint 54222628930951453 5526514916844166577) - (Fingerprint 1749630806887010665 8607076506606977549) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" - (Fingerprint 6817250511240350300 15278852712000783849) - (Fingerprint 15757717081429529536 15542551865099640223) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" - (Fingerprint 8310050400349211976 201317952074418615) - (Fingerprint 10283381191257209624 4231947623042413334) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" - (Fingerprint 7010988292906098371 11591884496857936132) - (Fingerprint 6158672440010710301 6419743768695725095) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further\r\n-- documentation, see http://haskell.org/cabal/users-guide/\r\n\r\n-- The name of the package.\r\nname: hblas\r\n\r\n-- The package version. See the Haskell package versioning policy (PVP)" - (Fingerprint 2076850805659055833 16615160726215879467) - (Fingerprint 10634706281258477722 5285812379517916984) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further\r\n-- documentation, see http://haskell.org/cabal/users-guide/\r\n\r\n-- The name of the package.\r\nname: hblas\r\n\r\n-- The package version. See the Haskell package versioning policy (PVP)" - (Fingerprint 11850020631622781099 11956481969231030830) - (Fingerprint 13702868780337762025 13383526367149067158) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" - (Fingerprint 13690322768477779172 19704059263540994) - (Fingerprint 11189374824645442376 8363528115442591078) - (bsReplace "&&!" "&& !") - -- flag used, but not defined - , mk "name: brainheck\nversion: 0.1.0.2\nsynopsis: Brainh*ck interpreter in haskell\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\nhomepage: https://gi" - (Fingerprint 6910727116443152200 15401634478524888973) - (Fingerprint 16551412117098094368 16260377389127603629) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: brainheck\r\nversion: 0.1.0.2\r\nx-revision: 1\r\nsynopsis: Brainh*ck interpreter in haskell\r\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage: " - (Fingerprint 14320987921316832277 10031098243571536929) - (Fingerprint 7959395602414037224 13279941216182213050) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: brainheck\r\nversion: 0.1.0.2\r\nx-revision: 2\r\nsynopsis: Brainh*ck interpreter in haskell\r\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage: " - (Fingerprint 3809078390223299128 10796026010775813741) - (Fingerprint 1127231189459220796 12088367524333209349) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: brainheck\r\nversion: 0.1.0.2\r\nx-revision: 3\r\nsynopsis: Brainh*ck interpreter in haskell\r\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage: " - (Fingerprint 13860013038089410950 12479824176801390651) - (Fingerprint 4687484721703340391 8013395164515771785) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: wordchoice\nversion: 0.1.0.1\nsynopsis: Get word counts and distributions\ndescription: A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho" - (Fingerprint 16215911397419608203 15594928482155652475) - (Fingerprint 15120681510314491047 2666192399775157359) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: wordchoice\r\nversion: 0.1.0.1\r\nx-revision: 1\r\nsynopsis: Get word counts and distributions\r\ndescription: A command line tool to compute the word distribution from various types of document, converting to te" - (Fingerprint 16593139224723441188 4052919014346212001) - (Fingerprint 3577381082410411593 11481899387780544641) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: wordchoice\nversion: 0.1.0.2\nsynopsis: Get word counts and distributions\ndescription: A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho" - (Fingerprint 9321301260802539374 1316392715016096607) - (Fingerprint 3784628652257760949 12662640594755291035) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: wordchoice\r\nversion: 0.1.0.2\r\nx-revision: 1\r\nsynopsis: Get word counts and distributions\r\ndescription: A command line tool to compute the word distribution from various types of document, converting to te" - (Fingerprint 2546901804824433337 2059732715322561176) - (Fingerprint 8082068680348326500 615008613291421947) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: wordchoice\nversion: 0.1.0.3\nsynopsis: Get word counts and distributions\ndescription: A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho" - (Fingerprint 2282380737467965407 12457554753171662424) - (Fingerprint 17324757216926991616 17172911843227482125) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: wordchoice\r\nversion: 0.1.0.3\r\nx-revision: 1\r\nsynopsis: Get word counts and distributions\r\ndescription: A command line tool to compute the word distribution from various types of document, converting to te" - (Fingerprint 12907988890480595481 11078473638628359710) - (Fingerprint 13246185333368731848 4663060731847518614) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: hw-prim-bits\nversion: 0.1.0.0\nsynopsis: Primitive support for bit manipulation\ndescription: Please see README.md\nhomepage: https://github.com/githubuser/hw-prim-bits#readme\nlicense: " - (Fingerprint 12386777729082870356 17414156731912743711) - (Fingerprint 3452290353395041602 14102887112483033720) - (bsReplace "flag(sse42)" "False") - , mk "name: hw-prim-bits\nversion: 0.1.0.1\nsynopsis: Primitive support for bit manipulation\ndescription: Please see README.md\nhomepage: https://github.com/githubuser/hw-prim-bits#readme\nlicen" - (Fingerprint 6870520675313101180 14553457351296240636) - (Fingerprint 12481021059537696455 14711088786769892762) - (bsReplace "flag(sse42)" "False") - -- leading zeros in version digits - -- https://github.com/haskell-infra/hackage-trustees/issues/128 - -- https://github.com/haskell/cabal/issues/5092 - -- https://github.com/haskell/cabal/issues/5138 - , mk "name: Sit\nversion: 0.2017.02.26\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Anonymous\nmaintainer: Anonymous\nhomepage: NONE\ncategory: Dependent" - (Fingerprint 8458530898096910998 3228538743646501413) - (Fingerprint 14470502514907936793 17514354054641875371) - (bsReplace "0.2017.02.26" "0.2017.2.26") - , mk "name: Sit\nversion: 0.2017.05.01\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Andreas Abel \nmaintainer: Andreas Abel \n" - (Fingerprint 1450130849535097473 11742099607098860444) - (Fingerprint 16679762943850814021 4253724355613883542) - (bsReplace "0.2017.05.01" "0.2017.5.1") - , mk "name: Sit\nversion: 0.2017.05.02\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Andreas Abel \nmaintainer: Andreas Abel \n" - (Fingerprint 297248532398492441 17322625167861324800) - (Fingerprint 634812045126693280 1755581866539318862) - (bsReplace "0.2017.05.02" "0.2017.5.2") - , mk "name: Sit\nversion: 0.2017.5.02\nx-revision: 1\n-- x-revision:1 see https://github.com/haskell-infra/hackage-trustees/issues/128\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: " - (Fingerprint 3697869560530373941 3942982281026987312) - (Fingerprint 14344526114710295386 16386400353475114712) - (bsReplace "0.2017.5.02" "0.2017.5.2") - , mk "name: MiniAgda\nversion: 0.2017.02.18\nbuild-type: Simple\ncabal-version: >= 1.22\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Andreas Abel and Karl Mehltretter\nmaintainer: Andreas Abel =1.8\nbuild-type: Simple\nlicense: GPL\nlicense-file: /home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt\ncopyright: GPL\nmaintainer: Ingolf Wagner \nstability: experimental\nhomepage: h" - (Fingerprint 9155400339287317061 14812953666990892802) - (Fingerprint 7687053346032173923 15384472501136606592) - (bsReplace "/home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt" "") - , mk "name: reheat\nversion: 0.1.5\ncabal-version: >=1.8\nbuild-type: Simple\nlicense: GPL\nlicense-file: /home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt\ncopyright: GPL\nmaintainer: Ingolf Wagner \nstability: experimental\nhomepage: h" - (Fingerprint 2984391146441073709 11728234882049907993) - (Fingerprint 12058479081855347701 14017937756688869826) - (bsReplace "/home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt" "") + [ mk + "-- This file has been generated from package.yaml by hpack version 0.17.0.\n--\n-- see: https://github.com/sol/hpack\n\nname: unicode-transforms\nversion: 0.3.3\nsynopsis: Unicode normalization\ndescription: Fast Unic" + (Fingerprint 15958160436627155571 10318709190730872881) + (Fingerprint 11008465475756725834 13815629925116264363) + (bsRemove " other-modules:\n .\n") -- TODO: remove trailing \n to test structural-diff + -- http://hackage.haskell.org/package/DSTM-0.1.2 + -- http://hackage.haskell.org/package/DSTM-0.1.1 + -- http://hackage.haskell.org/package/DSTM-0.1 + -- Other Modules: no dash + -- ReadP parsed as section + , mk + "Name: DSTM\nVersion: 0.1.2\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed " + (Fingerprint 6919263071548559054 9050746360708965827) + (Fingerprint 17015177514298962556 11943164891661867280) + (bsReplace "Other modules:" "-- ") + , mk + "Name: DSTM\nVersion: 0.1.1\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed " + (Fingerprint 17313105789069667153 9610429408495338584) + (Fingerprint 17250946493484671738 17629939328766863497) + (bsReplace "Other modules:" "-- ") + , mk + "Name: DSTM\nVersion: 0.1\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed sy" + (Fingerprint 10502599650530614586 16424112934471063115) + (Fingerprint 13562014713536696107 17899511905611879358) + (bsReplace "Other modules:" "-- ") + , -- http://hackage.haskell.org/package/control-monad-exception-mtl-0.10.3 + mk + "name: control-monad-exception-mtl\nversion: 0.10.3\nCabal-Version: >= 1.10\nbuild-type: Simple\nlicense: PublicDomain\nauthor: Pepe Iborra\nmaintainer: pepeiborra@gmail.com\nhomepage: http://pepeiborra.github.com/control-monad-exception\nsynopsis: MTL instances f" + (Fingerprint 18274748422558568404 4043538769550834851) + (Fingerprint 11395257416101232635 4303318131190196308) + (bsReplace " default- extensions:" "unknown-section") + , -- http://hackage.haskell.org/package/vacuum-opengl-0.0 + -- \DEL character + mk + "Name: vacuum-opengl\nVersion: 0.0\nSynopsis: Visualize live Haskell data structures using vacuum, graphviz and OpenGL.\nDescription: \DELVisualize live Haskell data structures using vacuum, graphviz and OpenGL.\n " + (Fingerprint 5946760521961682577 16933361639326309422) + (Fingerprint 14034745101467101555 14024175957788447824) + (bsRemove "\DEL") + , mk + "Name: vacuum-opengl\nVersion: 0.0.1\nSynopsis: Visualize live Haskell data structures using vacuum, graphviz and OpenGL.\nDescription: \DELVisualize live Haskell data structures using vacuum, graphviz and OpenGL.\n " + (Fingerprint 10790950110330119503 1309560249972452700) + (Fingerprint 1565743557025952928 13645502325715033593) + (bsRemove "\DEL") + , -- http://hackage.haskell.org/package/ixset-1.0.4 + -- {- comments -} + mk + "Name: ixset\nVersion: 1.0.4\nSynopsis: Efficient relational queries on Haskell sets.\nDescription:\n Create and query sets that are indexed by multiple indices.\nLicense: BSD3\nLicense-file: COPYING\nAut" + (Fingerprint 11886092342440414185 4150518943472101551) + (Fingerprint 5731367240051983879 17473925006273577821) + (bsRemoveStarting "{-") + , -- : after section + -- http://hackage.haskell.org/package/ds-kanren + mk + "name: ds-kanren\nversion: 0.2.0.0\nsynopsis: A subset of the miniKanren language\ndescription:\n ds-kanren is an implementation of the language.\n .\n == What's in ds-kanren?\n .\n ['dis" + (Fingerprint 2804006762382336875 9677726932108735838) + (Fingerprint 9830506174094917897 12812107316777006473) + (bsReplace "Test-Suite test-unify:" "Test-Suite \"test-unify:\"" . bsReplace "Test-Suite test-list-ops:" "Test-Suite \"test-list-ops:\"") + , mk + "name: ds-kanren\nversion: 0.2.0.1\nsynopsis: A subset of the miniKanren language\ndescription:\n ds-kanren is an implementation of the language.\n\nlicense: MIT\nlicense-file: " + (Fingerprint 9130259649220396193 2155671144384738932) + (Fingerprint 1847988234352024240 4597789823227580457) + (bsReplace "Test-Suite test-unify:" "Test-Suite \"test-unify:\"" . bsReplace "Test-Suite test-list-ops:" "Test-Suite \"test-list-ops:\"") + , mk + "name: metric\nversion: 0.1.4\nsynopsis: Metric spaces.\nlicense: MIT\nlicense-file: LICENSE\nauthor: Vikram Verma\nmaintainer: me@vikramverma.com\ncategory: Data\nbuild-type:" + (Fingerprint 6150019278861565482 3066802658031228162) + (Fingerprint 9124826020564520548 15629704249829132420) + (bsReplace "test-suite metric-tests:" "test-suite \"metric-tests:\"") + , mk + "name: metric\nversion: 0.2.0\nsynopsis: Metric spaces.\nlicense: MIT\nlicense-file: LICENSE\nauthor: Vikram Verma\nmaintainer: me@vikramverma.com\ncategory: Data\nbuild-type:" + (Fingerprint 4639805967994715694 7859317050376284551) + (Fingerprint 5566222290622325231 873197212916959151) + (bsReplace "test-suite metric-tests:" "test-suite \"metric-tests:\"") + , mk + "name: phasechange\ncategory: Data\nversion: 0.1\nauthor: G\195\161bor Lehel\nmaintainer: G\195\161bor Lehel \nhomepage: http://github.com/glehel/phasechange\ncopyright: Copyright (C) 2012 G\195\161bor Lehel\nlicense: " + (Fingerprint 10546509771395401582 245508422312751943) + (Fingerprint 5169853482576003304 7247091607933993833) + (bsReplace "impl(ghc >= 7.4):" "erroneous-section" . bsReplace "impl(ghc >= 7.6):" "erroneous-section") + , mk + "Name: smartword\nSynopsis: Web based flash card for Word Smart I and II vocabularies\nVersion: 0.0.0.5\nHomepage: http://kyagrd.dyndns.org/~kyagrd/project/smartword/\nCategory: Web,Education\nLicense: " + (Fingerprint 7803544783533485151 10807347873998191750) + (Fingerprint 1665635316718752601 16212378357991151549) + (bsReplace "build depends:" "--") + , mk + "name: shelltestrunner\n-- sync with README.md, ANNOUNCE:\nversion: 1.3\ncategory: Testing\nsynopsis: A tool for testing command-line programs.\ndescription:\n shelltestrunner is a cross-platform tool for testing command-line\n program" + (Fingerprint 4403237110790078829 15392625961066653722) + (Fingerprint 10218887328390239431 4644205837817510221) + (bsReplace "other modules:" "--") + , -- &&! + -- http://hackage.haskell.org/package/hblas-0.3.0.0 + mk + "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- " + (Fingerprint 8570120150072467041 18315524331351505945) + (Fingerprint 10838007242302656005 16026440017674974175) + (bsReplace "&&!" "&& !") + , mk + "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- " + (Fingerprint 5262875856214215155 10846626274067555320) + (Fingerprint 3022954285783401045 13395975869915955260) + (bsReplace "&&!" "&& !") + , mk + "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- " + (Fingerprint 54222628930951453 5526514916844166577) + (Fingerprint 1749630806887010665 8607076506606977549) + (bsReplace "&&!" "&& !") + , mk + "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" + (Fingerprint 6817250511240350300 15278852712000783849) + (Fingerprint 15757717081429529536 15542551865099640223) + (bsReplace "&&!" "&& !") + , mk + "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" + (Fingerprint 8310050400349211976 201317952074418615) + (Fingerprint 10283381191257209624 4231947623042413334) + (bsReplace "&&!" "&& !") + , mk + "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" + (Fingerprint 7010988292906098371 11591884496857936132) + (Fingerprint 6158672440010710301 6419743768695725095) + (bsReplace "&&!" "&& !") + , mk + "-- Initial hblas.cabal generated by cabal init. For further\r\n-- documentation, see http://haskell.org/cabal/users-guide/\r\n\r\n-- The name of the package.\r\nname: hblas\r\n\r\n-- The package version. See the Haskell package versioning policy (PVP)" + (Fingerprint 2076850805659055833 16615160726215879467) + (Fingerprint 10634706281258477722 5285812379517916984) + (bsReplace "&&!" "&& !") + , mk + "-- Initial hblas.cabal generated by cabal init. For further\r\n-- documentation, see http://haskell.org/cabal/users-guide/\r\n\r\n-- The name of the package.\r\nname: hblas\r\n\r\n-- The package version. See the Haskell package versioning policy (PVP)" + (Fingerprint 11850020631622781099 11956481969231030830) + (Fingerprint 13702868780337762025 13383526367149067158) + (bsReplace "&&!" "&& !") + , mk + "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" + (Fingerprint 13690322768477779172 19704059263540994) + (Fingerprint 11189374824645442376 8363528115442591078) + (bsReplace "&&!" "&& !") + , -- flag used, but not defined + mk + "name: brainheck\nversion: 0.1.0.2\nsynopsis: Brainh*ck interpreter in haskell\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\nhomepage: https://gi" + (Fingerprint 6910727116443152200 15401634478524888973) + (Fingerprint 16551412117098094368 16260377389127603629) + (bsReplace "flag(llvm-fast)" "False") + , mk + "name: brainheck\r\nversion: 0.1.0.2\r\nx-revision: 1\r\nsynopsis: Brainh*ck interpreter in haskell\r\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage: " + (Fingerprint 14320987921316832277 10031098243571536929) + (Fingerprint 7959395602414037224 13279941216182213050) + (bsReplace "flag(llvm-fast)" "False") + , mk + "name: brainheck\r\nversion: 0.1.0.2\r\nx-revision: 2\r\nsynopsis: Brainh*ck interpreter in haskell\r\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage: " + (Fingerprint 3809078390223299128 10796026010775813741) + (Fingerprint 1127231189459220796 12088367524333209349) + (bsReplace "flag(llvm-fast)" "False") + , mk + "name: brainheck\r\nversion: 0.1.0.2\r\nx-revision: 3\r\nsynopsis: Brainh*ck interpreter in haskell\r\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage: " + (Fingerprint 13860013038089410950 12479824176801390651) + (Fingerprint 4687484721703340391 8013395164515771785) + (bsReplace "flag(llvm-fast)" "False") + , mk + "name: wordchoice\nversion: 0.1.0.1\nsynopsis: Get word counts and distributions\ndescription: A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho" + (Fingerprint 16215911397419608203 15594928482155652475) + (Fingerprint 15120681510314491047 2666192399775157359) + (bsReplace "flag(llvm-fast)" "False") + , mk + "name: wordchoice\r\nversion: 0.1.0.1\r\nx-revision: 1\r\nsynopsis: Get word counts and distributions\r\ndescription: A command line tool to compute the word distribution from various types of document, converting to te" + (Fingerprint 16593139224723441188 4052919014346212001) + (Fingerprint 3577381082410411593 11481899387780544641) + (bsReplace "flag(llvm-fast)" "False") + , mk + "name: wordchoice\nversion: 0.1.0.2\nsynopsis: Get word counts and distributions\ndescription: A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho" + (Fingerprint 9321301260802539374 1316392715016096607) + (Fingerprint 3784628652257760949 12662640594755291035) + (bsReplace "flag(llvm-fast)" "False") + , mk + "name: wordchoice\r\nversion: 0.1.0.2\r\nx-revision: 1\r\nsynopsis: Get word counts and distributions\r\ndescription: A command line tool to compute the word distribution from various types of document, converting to te" + (Fingerprint 2546901804824433337 2059732715322561176) + (Fingerprint 8082068680348326500 615008613291421947) + (bsReplace "flag(llvm-fast)" "False") + , mk + "name: wordchoice\nversion: 0.1.0.3\nsynopsis: Get word counts and distributions\ndescription: A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho" + (Fingerprint 2282380737467965407 12457554753171662424) + (Fingerprint 17324757216926991616 17172911843227482125) + (bsReplace "flag(llvm-fast)" "False") + , mk + "name: wordchoice\r\nversion: 0.1.0.3\r\nx-revision: 1\r\nsynopsis: Get word counts and distributions\r\ndescription: A command line tool to compute the word distribution from various types of document, converting to te" + (Fingerprint 12907988890480595481 11078473638628359710) + (Fingerprint 13246185333368731848 4663060731847518614) + (bsReplace "flag(llvm-fast)" "False") + , mk + "name: hw-prim-bits\nversion: 0.1.0.0\nsynopsis: Primitive support for bit manipulation\ndescription: Please see README.md\nhomepage: https://github.com/githubuser/hw-prim-bits#readme\nlicense: " + (Fingerprint 12386777729082870356 17414156731912743711) + (Fingerprint 3452290353395041602 14102887112483033720) + (bsReplace "flag(sse42)" "False") + , mk + "name: hw-prim-bits\nversion: 0.1.0.1\nsynopsis: Primitive support for bit manipulation\ndescription: Please see README.md\nhomepage: https://github.com/githubuser/hw-prim-bits#readme\nlicen" + (Fingerprint 6870520675313101180 14553457351296240636) + (Fingerprint 12481021059537696455 14711088786769892762) + (bsReplace "flag(sse42)" "False") + , -- leading zeros in version digits + -- https://github.com/haskell-infra/hackage-trustees/issues/128 + -- https://github.com/haskell/cabal/issues/5092 + -- https://github.com/haskell/cabal/issues/5138 + mk + "name: Sit\nversion: 0.2017.02.26\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Anonymous\nmaintainer: Anonymous\nhomepage: NONE\ncategory: Dependent" + (Fingerprint 8458530898096910998 3228538743646501413) + (Fingerprint 14470502514907936793 17514354054641875371) + (bsReplace "0.2017.02.26" "0.2017.2.26") + , mk + "name: Sit\nversion: 0.2017.05.01\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Andreas Abel \nmaintainer: Andreas Abel \n" + (Fingerprint 1450130849535097473 11742099607098860444) + (Fingerprint 16679762943850814021 4253724355613883542) + (bsReplace "0.2017.05.01" "0.2017.5.1") + , mk + "name: Sit\nversion: 0.2017.05.02\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Andreas Abel \nmaintainer: Andreas Abel \n" + (Fingerprint 297248532398492441 17322625167861324800) + (Fingerprint 634812045126693280 1755581866539318862) + (bsReplace "0.2017.05.02" "0.2017.5.2") + , mk + "name: Sit\nversion: 0.2017.5.02\nx-revision: 1\n-- x-revision:1 see https://github.com/haskell-infra/hackage-trustees/issues/128\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: " + (Fingerprint 3697869560530373941 3942982281026987312) + (Fingerprint 14344526114710295386 16386400353475114712) + (bsReplace "0.2017.5.02" "0.2017.5.2") + , mk + "name: MiniAgda\nversion: 0.2017.02.18\nbuild-type: Simple\ncabal-version: >= 1.22\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Andreas Abel and Karl Mehltretter\nmaintainer: Andreas Abel =1.8\nbuild-type: Simple\nlicense: GPL\nlicense-file: /home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt\ncopyright: GPL\nmaintainer: Ingolf Wagner \nstability: experimental\nhomepage: h" + (Fingerprint 9155400339287317061 14812953666990892802) + (Fingerprint 7687053346032173923 15384472501136606592) + (bsReplace "/home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt" "") + , mk + "name: reheat\nversion: 0.1.5\ncabal-version: >=1.8\nbuild-type: Simple\nlicense: GPL\nlicense-file: /home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt\ncopyright: GPL\nmaintainer: Ingolf Wagner \nstability: experimental\nhomepage: h" + (Fingerprint 2984391146441073709 11728234882049907993) + (Fingerprint 12058479081855347701 14017937756688869826) + (bsReplace "/home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt" "") ] where mk a b c d = ((a, b), (c, d)) @@ -296,45 +353,52 @@ patches = Map.fromList -- | Helper to create entries in patches _makePatchKey :: FilePath -> (BS.ByteString -> BS.ByteString) -> IO () _makePatchKey fp transform = do - contents <- BS.readFile fp - let output = transform contents - let Fingerprint hi lo = md5 contents - let Fingerprint hi' lo' = md5 output - putStrLn - $ showString " , mk " - . shows (BS.take 256 contents) - . showString "\n (Fingerprint " - . shows hi - . showString " " - . shows lo - . showString ")\n (Fingerprint " - . shows hi' - . showString " " - . shows lo' - . showString ")" - $ "" + contents <- BS.readFile fp + let output = transform contents + let Fingerprint hi lo = md5 contents + let Fingerprint hi' lo' = md5 output + putStrLn + $ showString " , mk " + . shows (BS.take 256 contents) + . showString "\n (Fingerprint " + . shows hi + . showString " " + . shows lo + . showString ")\n (Fingerprint " + . shows hi' + . showString " " + . shows lo' + . showString ")" + $ "" ------------------------------------------------------------------------------- -- Patch helpers ------------------------------------------------------------------------------- bsRemove - :: BS.ByteString -- ^ needle - -> BS.ByteString -> BS.ByteString + :: BS.ByteString + -- ^ needle + -> BS.ByteString + -> BS.ByteString bsRemove needle haystack = case BS.breakSubstring needle haystack of - (h, t) -> BS.append h (BS.drop (BS.length needle) t) + (h, t) -> BS.append h (BS.drop (BS.length needle) t) bsReplace - :: BS.ByteString -- ^ needle - -> BS.ByteString -- ^ replacement - -> BS.ByteString -> BS.ByteString + :: BS.ByteString + -- ^ needle + -> BS.ByteString + -- ^ replacement + -> BS.ByteString + -> BS.ByteString bsReplace needle repl haystack = case BS.breakSubstring needle haystack of - (h, t) - | not (BS.null t) -> BS.append h (BS.append repl (BS.drop (BS.length needle) t)) - | otherwise -> haystack + (h, t) + | not (BS.null t) -> BS.append h (BS.append repl (BS.drop (BS.length needle) t)) + | otherwise -> haystack bsRemoveStarting - :: BS.ByteString -- ^ needle - -> BS.ByteString -> BS.ByteString + :: BS.ByteString + -- ^ needle + -> BS.ByteString + -> BS.ByteString bsRemoveStarting needle haystack = case BS.breakSubstring needle haystack of - (h, _) -> h + (h, _) -> h diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Utils.hs b/Cabal-syntax/src/Distribution/PackageDescription/Utils.hs index d814c87e422..27b993c9b61 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/Utils.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/Utils.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.PackageDescription.Utils -- @@ -6,9 +7,9 @@ -- Portability : portable -- -- Common utils used by modules under Distribution.PackageDescription.*. - -module Distribution.PackageDescription.Utils ( - cabalBug, userBug +module Distribution.PackageDescription.Utils + ( cabalBug + , userBug ) where -- ---------------------------------------------------------------------------- @@ -18,6 +19,9 @@ userBug :: String -> a userBug msg = error $ msg ++ ". This is a bug in your .cabal file." cabalBug :: String -> a -cabalBug msg = error $ msg ++ ". This is possibly a bug in Cabal.\n" - ++ "Please report it to the developers: " - ++ "https://github.com/haskell/cabal/issues/new" +cabalBug msg = + error $ + msg + ++ ". This is possibly a bug in Cabal.\n" + ++ "Please report it to the developers: " + ++ "https://github.com/haskell/cabal/issues/new" diff --git a/Cabal-syntax/src/Distribution/Parsec.hs b/Cabal-syntax/src/Distribution/Parsec.hs index 0df02ffa055..4c6e31e5aaa 100644 --- a/Cabal-syntax/src/Distribution/Parsec.hs +++ b/Cabal-syntax/src/Distribution/Parsec.hs @@ -1,69 +1,75 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Parsec ( - Parsec(..), - ParsecParser (..), - runParsecParser, - runParsecParser', - simpleParsec, - simpleParsecBS, - simpleParsec', - simpleParsecW', - lexemeParsec, - eitherParsec, - explicitEitherParsec, - explicitEitherParsec', + +module Distribution.Parsec + ( Parsec (..) + , ParsecParser (..) + , runParsecParser + , runParsecParser' + , simpleParsec + , simpleParsecBS + , simpleParsec' + , simpleParsecW' + , lexemeParsec + , eitherParsec + , explicitEitherParsec + , explicitEitherParsec' + -- * CabalParsing and diagnostics - CabalParsing (..), + , CabalParsing (..) + -- ** Warnings - PWarnType (..), - PWarning (..), - showPWarning, + , PWarnType (..) + , PWarning (..) + , showPWarning + -- ** Errors - PError (..), - showPError, + , PError (..) + , showPError + -- * Position - Position (..), - incPos, - retPos, - showPos, - zeroPos, + , Position (..) + , incPos + , retPos + , showPos + , zeroPos + -- * Utilities - parsecToken, - parsecToken', - parsecFilePath, - parsecQuoted, - parsecMaybeQuoted, - parsecCommaList, - parsecCommaNonEmpty, - parsecLeadingCommaList, - parsecLeadingCommaNonEmpty, - parsecOptCommaList, - parsecLeadingOptCommaList, - parsecStandard, - parsecUnqualComponentName, - ) where - -import Data.ByteString (ByteString) -import Data.Char (digitToInt, intToDigit) -import Data.List (transpose) + , parsecToken + , parsecToken' + , parsecFilePath + , parsecQuoted + , parsecMaybeQuoted + , parsecCommaList + , parsecCommaNonEmpty + , parsecLeadingCommaList + , parsecLeadingCommaNonEmpty + , parsecOptCommaList + , parsecLeadingOptCommaList + , parsecStandard + , parsecUnqualComponentName + ) where + +import Data.ByteString (ByteString) +import Data.Char (digitToInt, intToDigit) +import Data.List (transpose) import Distribution.CabalSpecVersion import Distribution.Compat.Prelude -import Distribution.Parsec.Error (PError (..), showPError) +import Distribution.Parsec.Error (PError (..), showPError) import Distribution.Parsec.FieldLineStream (FieldLineStream, fieldLineStreamFromBS, fieldLineStreamFromString) -import Distribution.Parsec.Position (Position (..), incPos, retPos, showPos, zeroPos) -import Distribution.Parsec.Warning (PWarnType (..), PWarning (..), showPWarning) -import Numeric (showIntAtBase) +import Distribution.Parsec.Position (Position (..), incPos, retPos, showPos, zeroPos) +import Distribution.Parsec.Warning (PWarnType (..), PWarning (..), showPWarning) +import Numeric (showIntAtBase) import Prelude () import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.Compat.DList as DList -import qualified Distribution.Compat.MonadFail as Fail -import qualified Text.Parsec as Parsec +import qualified Distribution.Compat.DList as DList +import qualified Distribution.Compat.MonadFail as Fail +import qualified Text.Parsec as Parsec ------------------------------------------------------------------------------- -- Class @@ -72,118 +78,118 @@ import qualified Text.Parsec as Parsec -- | Class for parsing with @parsec@. Mainly used for @.cabal@ file fields. -- -- For parsing @.cabal@ like file structure, see "Distribution.Fields". --- class Parsec a where - parsec :: CabalParsing m => m a + parsec :: CabalParsing m => m a -- | Parsing class which -- -- * can report Cabal parser warnings. -- -- * knows @cabal-version@ we work with --- class (P.CharParsing m, MonadPlus m, Fail.MonadFail m) => CabalParsing m where - parsecWarning :: PWarnType -> String -> m () + parsecWarning :: PWarnType -> String -> m () - parsecHaskellString :: m String - parsecHaskellString = stringLiteral + parsecHaskellString :: m String + parsecHaskellString = stringLiteral - askCabalSpecVersion :: m CabalSpecVersion + askCabalSpecVersion :: m CabalSpecVersion -- | 'parsec' /could/ consume trailing spaces, this function /will/ consume. lexemeParsec :: (CabalParsing m, Parsec a) => m a lexemeParsec = parsec <* P.spaces -newtype ParsecParser a = PP { unPP - :: CabalSpecVersion -> Parsec.Parsec FieldLineStream [PWarning] a - } +newtype ParsecParser a = PP + { unPP + :: CabalSpecVersion + -> Parsec.Parsec FieldLineStream [PWarning] a + } liftParsec :: Parsec.Parsec FieldLineStream [PWarning] a -> ParsecParser a liftParsec p = PP $ \_ -> p instance Functor ParsecParser where - fmap f p = PP $ \v -> fmap f (unPP p v) - {-# INLINE fmap #-} + fmap f p = PP $ \v -> fmap f (unPP p v) + {-# INLINE fmap #-} - x <$ p = PP $ \v -> x <$ unPP p v - {-# INLINE (<$) #-} + x <$ p = PP $ \v -> x <$ unPP p v + {-# INLINE (<$) #-} instance Applicative ParsecParser where - pure = liftParsec . pure - {-# INLINE pure #-} + pure = liftParsec . pure + {-# INLINE pure #-} - f <*> x = PP $ \v -> unPP f v <*> unPP x v - {-# INLINE (<*>) #-} - f *> x = PP $ \v -> unPP f v *> unPP x v - {-# INLINE (*>) #-} - f <* x = PP $ \v -> unPP f v <* unPP x v - {-# INLINE (<*) #-} + f <*> x = PP $ \v -> unPP f v <*> unPP x v + {-# INLINE (<*>) #-} + f *> x = PP $ \v -> unPP f v *> unPP x v + {-# INLINE (*>) #-} + f <* x = PP $ \v -> unPP f v <* unPP x v + {-# INLINE (<*) #-} instance Alternative ParsecParser where - empty = liftParsec empty + empty = liftParsec empty - a <|> b = PP $ \v -> unPP a v <|> unPP b v - {-# INLINE (<|>) #-} + a <|> b = PP $ \v -> unPP a v <|> unPP b v + {-# INLINE (<|>) #-} - many p = PP $ \v -> many (unPP p v) - {-# INLINE many #-} + many p = PP $ \v -> many (unPP p v) + {-# INLINE many #-} - some p = PP $ \v -> some (unPP p v) - {-# INLINE some #-} + some p = PP $ \v -> some (unPP p v) + {-# INLINE some #-} instance Monad ParsecParser where - return = pure + return = pure - m >>= k = PP $ \v -> unPP m v >>= \x -> unPP (k x) v - {-# INLINE (>>=) #-} - (>>) = (*>) - {-# INLINE (>>) #-} + m >>= k = PP $ \v -> unPP m v >>= \x -> unPP (k x) v + {-# INLINE (>>=) #-} + (>>) = (*>) + {-# INLINE (>>) #-} #if !(MIN_VERSION_base(4,13,0)) - fail = Fail.fail + fail = Fail.fail #endif instance MonadPlus ParsecParser where - mzero = empty - mplus = (<|>) + mzero = empty + mplus = (<|>) instance Fail.MonadFail ParsecParser where - fail = P.unexpected + fail = P.unexpected instance P.Parsing ParsecParser where - try p = PP $ \v -> P.try (unPP p v) - p d = PP $ \v -> unPP p v P. d - skipMany p = PP $ \v -> P.skipMany (unPP p v) - skipSome p = PP $ \v -> P.skipSome (unPP p v) - unexpected = liftParsec . P.unexpected - eof = liftParsec P.eof - notFollowedBy p = PP $ \v -> P.notFollowedBy (unPP p v) + try p = PP $ \v -> P.try (unPP p v) + p d = PP $ \v -> unPP p v P. d + skipMany p = PP $ \v -> P.skipMany (unPP p v) + skipSome p = PP $ \v -> P.skipSome (unPP p v) + unexpected = liftParsec . P.unexpected + eof = liftParsec P.eof + notFollowedBy p = PP $ \v -> P.notFollowedBy (unPP p v) instance P.CharParsing ParsecParser where - satisfy = liftParsec . P.satisfy - char = liftParsec . P.char - notChar = liftParsec . P.notChar - anyChar = liftParsec P.anyChar - string = liftParsec . P.string + satisfy = liftParsec . P.satisfy + char = liftParsec . P.char + notChar = liftParsec . P.notChar + anyChar = liftParsec P.anyChar + string = liftParsec . P.string instance CabalParsing ParsecParser where - parsecWarning t w = liftParsec $ do - spos <- Parsec.getPosition - Parsec.modifyState - (PWarning t (Position (Parsec.sourceLine spos) (Parsec.sourceColumn spos)) w :) - askCabalSpecVersion = PP pure + parsecWarning t w = liftParsec $ do + spos <- Parsec.getPosition + Parsec.modifyState + (PWarning t (Position (Parsec.sourceLine spos) (Parsec.sourceColumn spos)) w :) + askCabalSpecVersion = PP pure -- | Parse a 'String' with 'lexemeParsec'. simpleParsec :: Parsec a => String -> Maybe a -simpleParsec - = either (const Nothing) Just +simpleParsec = + either (const Nothing) Just . runParsecParser lexemeParsec "" . fieldLineStreamFromString -- | Like 'simpleParsec' but for 'ByteString' simpleParsecBS :: Parsec a => ByteString -> Maybe a -simpleParsecBS - = either (const Nothing) Just +simpleParsecBS = + either (const Nothing) Just . runParsecParser lexemeParsec "" . fieldLineStreamFromBS @@ -191,8 +197,8 @@ simpleParsecBS -- -- @since 3.4.0.0 simpleParsec' :: Parsec a => CabalSpecVersion -> String -> Maybe a -simpleParsec' spec - = either (const Nothing) Just +simpleParsec' spec = + either (const Nothing) Just . runParsecParser' spec lexemeParsec "" . fieldLineStreamFromString @@ -201,8 +207,8 @@ simpleParsec' spec -- -- @since 3.4.0.0 simpleParsecW' :: Parsec a => CabalSpecVersion -> String -> Maybe a -simpleParsecW' spec - = either (const Nothing) (\(x, ws) -> if null ws then Just x else Nothing) +simpleParsecW' spec = + either (const Nothing) (\(x, ws) -> if null ws then Just x else Nothing) . runParsecParser' spec ((,) <$> lexemeParsec <*> liftParsec Parsec.getState) "" . fieldLineStreamFromString @@ -212,8 +218,8 @@ eitherParsec = explicitEitherParsec parsec -- | Parse a 'String' with given 'ParsecParser'. Trailing whitespace is accepted. explicitEitherParsec :: ParsecParser a -> String -> Either String a -explicitEitherParsec parser - = either (Left . show) Right +explicitEitherParsec parser = + either (Left . show) Right . runParsecParser (parser <* P.spaces) "" . fieldLineStreamFromString @@ -221,10 +227,9 @@ explicitEitherParsec parser -- See 'explicitEitherParsec'. -- -- @since 3.4.0.0 --- explicitEitherParsec' :: CabalSpecVersion -> ParsecParser a -> String -> Either String a -explicitEitherParsec' spec parser - = either (Left . show) Right +explicitEitherParsec' spec parser = + either (Left . show) Right . runParsecParser' spec (parser <* P.spaces) "" . fieldLineStreamFromString @@ -235,44 +240,45 @@ runParsecParser = runParsecParser' cabalSpecLatest -- | Like 'runParsecParser' but lets specify 'CabalSpecVersion' used. -- -- @since 3.0.0.0 --- runParsecParser' :: CabalSpecVersion -> ParsecParser a -> FilePath -> FieldLineStream -> Either Parsec.ParseError a runParsecParser' v p n = Parsec.runParser (unPP p v <* P.eof) [] n instance Parsec a => Parsec (Identity a) where - parsec = Identity <$> parsec + parsec = Identity <$> parsec instance Parsec Bool where - parsec = P.munch1 isAlpha >>= postprocess - where - postprocess str - | str == "True" = pure True - | str == "False" = pure False - | lstr == "true" = parsecWarning PWTBoolCase caseWarning *> pure True - | lstr == "false" = parsecWarning PWTBoolCase caseWarning *> pure False - | otherwise = fail $ "Not a boolean: " ++ str - where - lstr = map toLower str - caseWarning = - "Boolean values are case sensitive, use 'True' or 'False'." + parsec = P.munch1 isAlpha >>= postprocess + where + postprocess str + | str == "True" = pure True + | str == "False" = pure False + | lstr == "true" = parsecWarning PWTBoolCase caseWarning *> pure True + | lstr == "false" = parsecWarning PWTBoolCase caseWarning *> pure False + | otherwise = fail $ "Not a boolean: " ++ str + where + lstr = map toLower str + caseWarning = + "Boolean values are case sensitive, use 'True' or 'False'." -- | @[^ ,]@ parsecToken :: CabalParsing m => m String -parsecToken = parsecHaskellString <|> ((P.munch1 (\x -> not (isSpace x) && x /= ',') P. "identifier" ) >>= checkNotDoubleDash) +parsecToken = parsecHaskellString <|> ((P.munch1 (\x -> not (isSpace x) && x /= ',') P. "identifier") >>= checkNotDoubleDash) -- | @[^ ]@ parsecToken' :: CabalParsing m => m String parsecToken' = parsecHaskellString <|> ((P.munch1 (not . isSpace) P. "token") >>= checkNotDoubleDash) -checkNotDoubleDash :: CabalParsing m => String -> m String +checkNotDoubleDash :: CabalParsing m => String -> m String checkNotDoubleDash s = do - when (s == "--") $ parsecWarning PWTDoubleDash $ unwords + when (s == "--") $ + parsecWarning PWTDoubleDash $ + unwords [ "Double-dash token found." , "Note: there are no end-of-line comments in .cabal files, only whole line comments." , "Use \"--\" (quoted double dash) to silence this warning, if you actually want -- token" ] - return s + return s parsecFilePath :: CabalParsing m => m FilePath parsecFilePath = parsecToken @@ -280,16 +286,17 @@ parsecFilePath = parsecToken -- | Parse a benchmark/test-suite types. parsecStandard :: (CabalParsing m, Parsec ver) => (ver -> String -> a) -> m a parsecStandard f = do - cs <- some $ P.try (component <* P.char '-') - ver <- parsec - let name = map toLower (intercalate "-" cs) - return $! f ver name + cs <- some $ P.try (component <* P.char '-') + ver <- parsec + let name = map toLower (intercalate "-" cs) + return $! f ver name where component = do cs <- P.munch1 isAlphaNum if all isDigit cs then fail "all digit component" else return cs - -- each component must contain an alphabetic character, to avoid - -- ambiguity in identifiers like foo-1 (the 1 is the version number). + +-- each component must contain an alphabetic character, to avoid +-- ambiguity in identifiers like foo-1 (the 1 is the version number). parsecCommaList :: CabalParsing m => m a -> m [a] parsecCommaList p = P.sepBy (p <* P.spaces) (P.char ',' *> P.spaces P. "comma") @@ -306,10 +313,10 @@ parsecCommaNonEmpty p = P.sepByNonEmpty (p <* P.spaces) (P.char ',' *> P.spaces -- @ parsecLeadingCommaList :: CabalParsing m => m a -> m [a] parsecLeadingCommaList p = do - c <- P.optional comma - case c of - Nothing -> toList <$> P.sepEndByNonEmpty lp comma <|> pure [] - Just _ -> toList <$> P.sepByNonEmpty lp comma + c <- P.optional comma + case c of + Nothing -> toList <$> P.sepEndByNonEmpty lp comma <|> pure [] + Just _ -> toList <$> P.sepByNonEmpty lp comma where lp = p <* P.spaces comma = P.char ',' *> P.spaces P. "comma" @@ -319,10 +326,10 @@ parsecLeadingCommaList p = do -- @since 3.4.0.0 parsecLeadingCommaNonEmpty :: CabalParsing m => m a -> m (NonEmpty a) parsecLeadingCommaNonEmpty p = do - c <- P.optional comma - case c of - Nothing -> P.sepEndByNonEmpty lp comma - Just _ -> P.sepByNonEmpty lp comma + c <- P.optional comma + case c of + Nothing -> P.sepEndByNonEmpty lp comma + Just _ -> P.sepByNonEmpty lp comma where lp = p <* P.spaces comma = P.char ',' *> P.spaces P. "comma" @@ -345,23 +352,22 @@ parsecOptCommaList p = P.sepBy (p <* P.spaces) (P.optional comma) -- @ -- -- @since 3.0.0.0 --- parsecLeadingOptCommaList :: CabalParsing m => m a -> m [a] parsecLeadingOptCommaList p = do - c <- P.optional comma - case c of - Nothing -> sepEndBy1Start <|> pure [] - Just _ -> toList <$> P.sepByNonEmpty lp comma + c <- P.optional comma + case c of + Nothing -> sepEndBy1Start <|> pure [] + Just _ -> toList <$> P.sepByNonEmpty lp comma where lp = p <* P.spaces comma = P.char ',' *> P.spaces P. "comma" sepEndBy1Start = do - x <- lp - c <- P.optional comma - case c of - Nothing -> (x :) <$> many lp - Just _ -> (x :) <$> P.sepEndBy lp comma + x <- lp + c <- P.optional comma + case c of + Nothing -> (x :) <$> many lp + Just _ -> (x :) <$> P.sepEndBy lp comma -- | Content isn't unquoted parsecQuoted :: CabalParsing m => m a -> m a @@ -372,7 +378,8 @@ parsecMaybeQuoted :: CabalParsing m => m a -> m a parsecMaybeQuoted p = parsecQuoted p <|> p parsecUnqualComponentName :: forall m. CabalParsing m => m String -parsecUnqualComponentName = state0 DList.empty where +parsecUnqualComponentName = state0 DList.empty + where -- -- using @kleene@ package we can easily see that -- we need only two states to recognize @@ -407,23 +414,25 @@ parsecUnqualComponentName = state0 DList.empty where state0 :: DList.DList Char -> m String state0 acc = do - c <- ch -- <|> fail ("Invalid component, after " ++ DList.toList acc) - case () of - _ | isDigit c -> state0 (DList.snoc acc c) - | isAlphaNum c -> state1 (DList.snoc acc c) - | c == '-' -> fail ("Empty component, after " ++ DList.toList acc) - | otherwise -> fail ("Internal error, after " ++ DList.toList acc) + c <- ch -- <|> fail ("Invalid component, after " ++ DList.toList acc) + case () of + _ + | isDigit c -> state0 (DList.snoc acc c) + | isAlphaNum c -> state1 (DList.snoc acc c) + | c == '-' -> fail ("Empty component, after " ++ DList.toList acc) + | otherwise -> fail ("Internal error, after " ++ DList.toList acc) state1 :: DList.DList Char -> m String state1 acc = state1' acc `alt` return (DList.toList acc) state1' :: DList.DList Char -> m String state1' acc = do - c <- ch - case () of - _ | isAlphaNum c -> state1 (DList.snoc acc c) - | c == '-' -> state0 (DList.snoc acc c) - | otherwise -> fail ("Internal error, after " ++ DList.toList acc) + c <- ch + case () of + _ + | isAlphaNum c -> state1 (DList.snoc acc c) + | c == '-' -> state0 (DList.snoc acc c) + | otherwise -> fail ("Internal error, after " ++ DList.toList acc) ch :: m Char !ch = P.satisfy (\c -> isAlphaNum c || c == '-') @@ -432,24 +441,29 @@ parsecUnqualComponentName = state0 DList.empty where !alt = (<|>) stringLiteral :: forall m. P.CharParsing m => m String -stringLiteral = lit where +stringLiteral = lit + where lit :: m String - lit = foldr (maybe id (:)) "" + lit = + foldr (maybe id (:)) "" <$> P.between (P.char '"') (P.char '"' P. "end of string") (many stringChar) P. "string" stringChar :: m (Maybe Char) - stringChar = Just <$> stringLetter - <|> stringEscape - P. "string character" + stringChar = + Just <$> stringLetter + <|> stringEscape + P. "string character" stringLetter :: m Char stringLetter = P.satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) stringEscape :: m (Maybe Char) - stringEscape = P.char '\\' *> esc where + stringEscape = P.char '\\' *> esc + where esc :: m (Maybe Char) - esc = Nothing <$ escapeGap + esc = + Nothing <$ escapeGap <|> Nothing <$ escapeEmpty <|> Just <$> escapeCode @@ -460,65 +474,103 @@ stringLiteral = lit where escapeCode :: forall m. P.CharParsing m => m Char escapeCode = (charEsc <|> charNum <|> charAscii <|> charControl) P. "escape code" where - charControl, charNum :: m Char - charControl = (\c -> toEnum (fromEnum c - fromEnum '@')) <$> (P.char '^' *> (P.upper <|> P.char '@')) - charNum = toEnum <$> num - where - num :: m Int - num = bounded 10 maxchar - <|> (P.char 'o' *> bounded 8 maxchar) - <|> (P.char 'x' *> bounded 16 maxchar) - maxchar = fromEnum (maxBound :: Char) - - bounded :: Int -> Int -> m Int - bounded base bnd = foldl' (\x d -> base * x + digitToInt d) 0 - <$> bounded' (take base thedigits) (map digitToInt $ showIntAtBase base intToDigit bnd "") - where - thedigits :: [m Char] - thedigits = map P.char ['0'..'9'] ++ map P.oneOf (transpose [['A'..'F'],['a'..'f']]) - - toomuch :: m a - toomuch = P.unexpected "out-of-range numeric escape sequence" - - bounded', bounded'' :: [m Char] -> [Int] -> m [Char] - bounded' dps@(zero:_) bds = P.skipSome zero *> ([] <$ P.notFollowedBy (P.choice dps) <|> bounded'' dps bds) - <|> bounded'' dps bds - bounded' [] _ = error "bounded called with base 0" - bounded'' dps [] = [] <$ P.notFollowedBy (P.choice dps) <|> toomuch - bounded'' dps (bd : bds) = let anyd :: m Char - anyd = P.choice dps - - nomore :: m () - nomore = P.notFollowedBy anyd <|> toomuch - - (low, ex, high) = case splitAt bd dps of - (low', ex' : high') -> (low', ex', high') - (_, _) -> error "escapeCode: Logic error" - in ((:) <$> P.choice low <*> atMost (length bds) anyd) <* nomore - <|> ((:) <$> ex <*> ([] <$ nomore <|> bounded'' dps bds)) - <|> if not (null bds) - then (:) <$> P.choice high <*> atMost (length bds - 1) anyd <* nomore - else empty - atMost n p | n <= 0 = pure [] - | otherwise = ((:) <$> p <*> atMost (n - 1) p) <|> pure [] - - charEsc :: m Char - charEsc = P.choice $ parseEsc <$> escMap - - parseEsc (c,code) = code <$ P.char c - escMap = zip "abfnrtv\\\"\'" "\a\b\f\n\r\t\v\\\"\'" - - charAscii :: m Char - charAscii = P.choice $ parseAscii <$> asciiMap - - parseAscii (asc,code) = P.try $ code <$ P.string asc - asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2) - ascii2codes, ascii3codes :: [String] - ascii2codes = [ "BS","HT","LF","VT","FF","CR","SO" - , "SI","EM","FS","GS","RS","US","SP"] - ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK" - ,"BEL","DLE","DC1","DC2","DC3","DC4","NAK" - ,"SYN","ETB","CAN","SUB","ESC","DEL"] - ascii2, ascii3 :: String - ascii2 = "\BS\HT\LF\VT\FF\CR\SO\SI\EM\FS\GS\RS\US\SP" - ascii3 = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK\BEL\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\SUB\ESC\DEL" + charControl, charNum :: m Char + charControl = (\c -> toEnum (fromEnum c - fromEnum '@')) <$> (P.char '^' *> (P.upper <|> P.char '@')) + charNum = toEnum <$> num + where + num :: m Int + num = + bounded 10 maxchar + <|> (P.char 'o' *> bounded 8 maxchar) + <|> (P.char 'x' *> bounded 16 maxchar) + maxchar = fromEnum (maxBound :: Char) + + bounded :: Int -> Int -> m Int + bounded base bnd = + foldl' (\x d -> base * x + digitToInt d) 0 + <$> bounded' (take base thedigits) (map digitToInt $ showIntAtBase base intToDigit bnd "") + where + thedigits :: [m Char] + thedigits = map P.char ['0' .. '9'] ++ map P.oneOf (transpose [['A' .. 'F'], ['a' .. 'f']]) + + toomuch :: m a + toomuch = P.unexpected "out-of-range numeric escape sequence" + + bounded', bounded'' :: [m Char] -> [Int] -> m [Char] + bounded' dps@(zero : _) bds = + P.skipSome zero *> ([] <$ P.notFollowedBy (P.choice dps) <|> bounded'' dps bds) + <|> bounded'' dps bds + bounded' [] _ = error "bounded called with base 0" + bounded'' dps [] = [] <$ P.notFollowedBy (P.choice dps) <|> toomuch + bounded'' dps (bd : bds) = + let anyd :: m Char + anyd = P.choice dps + + nomore :: m () + nomore = P.notFollowedBy anyd <|> toomuch + + (low, ex, high) = case splitAt bd dps of + (low', ex' : high') -> (low', ex', high') + (_, _) -> error "escapeCode: Logic error" + in ((:) <$> P.choice low <*> atMost (length bds) anyd) <* nomore + <|> ((:) <$> ex <*> ([] <$ nomore <|> bounded'' dps bds)) + <|> if not (null bds) + then (:) <$> P.choice high <*> atMost (length bds - 1) anyd <* nomore + else empty + atMost n p + | n <= 0 = pure [] + | otherwise = ((:) <$> p <*> atMost (n - 1) p) <|> pure [] + + charEsc :: m Char + charEsc = P.choice $ parseEsc <$> escMap + + parseEsc (c, code) = code <$ P.char c + escMap = zip "abfnrtv\\\"\'" "\a\b\f\n\r\t\v\\\"\'" + + charAscii :: m Char + charAscii = P.choice $ parseAscii <$> asciiMap + + parseAscii (asc, code) = P.try $ code <$ P.string asc + asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2) + ascii2codes, ascii3codes :: [String] + ascii2codes = + [ "BS" + , "HT" + , "LF" + , "VT" + , "FF" + , "CR" + , "SO" + , "SI" + , "EM" + , "FS" + , "GS" + , "RS" + , "US" + , "SP" + ] + ascii3codes = + [ "NUL" + , "SOH" + , "STX" + , "ETX" + , "EOT" + , "ENQ" + , "ACK" + , "BEL" + , "DLE" + , "DC1" + , "DC2" + , "DC3" + , "DC4" + , "NAK" + , "SYN" + , "ETB" + , "CAN" + , "SUB" + , "ESC" + , "DEL" + ] + ascii2, ascii3 :: String + ascii2 = "\BS\HT\LF\VT\FF\CR\SO\SI\EM\FS\GS\RS\US\SP" + ascii3 = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK\BEL\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\SUB\ESC\DEL" diff --git a/Cabal-syntax/src/Distribution/Parsec/Error.hs b/Cabal-syntax/src/Distribution/Parsec/Error.hs index 2e958de30ff..46114c3ea98 100644 --- a/Cabal-syntax/src/Distribution/Parsec/Error.hs +++ b/Cabal-syntax/src/Distribution/Parsec/Error.hs @@ -1,21 +1,22 @@ {-# LANGUAGE DeriveGeneric #-} -module Distribution.Parsec.Error ( - PError (..), - showPError, - ) where + +module Distribution.Parsec.Error + ( PError (..) + , showPError + ) where import Distribution.Compat.Prelude import Distribution.Parsec.Position +import System.FilePath (normalise) import Prelude () -import System.FilePath (normalise) -- | Parser error. data PError = PError Position String - deriving (Show, Generic) + deriving (Show, Generic) instance Binary PError instance NFData PError where rnf = genericRnf showPError :: FilePath -> PError -> String showPError fpath (PError pos msg) = - normalise fpath ++ ":" ++ showPos pos ++ ": " ++ msg + normalise fpath ++ ":" ++ showPos pos ++ ": " ++ msg diff --git a/Cabal-syntax/src/Distribution/Parsec/FieldLineStream.hs b/Cabal-syntax/src/Distribution/Parsec/FieldLineStream.hs index 670fa85f47b..2e9cc8e2475 100644 --- a/Cabal-syntax/src/Distribution/Parsec/FieldLineStream.hs +++ b/Cabal-syntax/src/Distribution/Parsec/FieldLineStream.hs @@ -1,29 +1,30 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall -Werror #-} -module Distribution.Parsec.FieldLineStream ( - FieldLineStream (..), - fieldLineStreamFromString, - fieldLineStreamFromBS, - fieldLineStreamEnd, - ) where + +module Distribution.Parsec.FieldLineStream + ( FieldLineStream (..) + , fieldLineStreamFromString + , fieldLineStreamFromBS + , fieldLineStreamEnd + ) where import Data.Bits -import Data.ByteString (ByteString) +import Data.ByteString (ByteString) import Distribution.Compat.Prelude -import Distribution.Utils.Generic (toUTF8BS) +import Distribution.Utils.Generic (toUTF8BS) import Prelude () import qualified Data.ByteString as BS -import qualified Text.Parsec as Parsec +import qualified Text.Parsec as Parsec -- | This is essentially a lazy bytestring, but chunks are glued with newline @\'\\n\'@. data FieldLineStream - = FLSLast !ByteString - | FLSCons {-# UNPACK #-} !ByteString FieldLineStream - deriving Show + = FLSLast !ByteString + | FLSCons {-# UNPACK #-} !ByteString FieldLineStream + deriving (Show) fieldLineStreamEnd :: FieldLineStream fieldLineStreamEnd = FLSLast mempty @@ -38,54 +39,55 @@ fieldLineStreamFromBS :: ByteString -> FieldLineStream fieldLineStreamFromBS = FLSLast instance Monad m => Parsec.Stream FieldLineStream m Char where - uncons (FLSLast bs) = return $ case BS.uncons bs of - Nothing -> Nothing - Just (c, bs') -> Just (unconsChar c bs' (\bs'' -> FLSLast bs'') fieldLineStreamEnd) - - uncons (FLSCons bs s) = return $ case BS.uncons bs of - -- as lines are glued with '\n', we return '\n' here! - Nothing -> Just ('\n', s) - Just (c, bs') -> Just (unconsChar c bs' (\bs'' -> FLSCons bs'' s) s) + uncons (FLSLast bs) = return $ case BS.uncons bs of + Nothing -> Nothing + Just (c, bs') -> Just (unconsChar c bs' (\bs'' -> FLSLast bs'') fieldLineStreamEnd) + uncons (FLSCons bs s) = return $ case BS.uncons bs of + -- as lines are glued with '\n', we return '\n' here! + Nothing -> Just ('\n', s) + Just (c, bs') -> Just (unconsChar c bs' (\bs'' -> FLSCons bs'' s) s) -- Based on implementation 'decodeStringUtf8' unconsChar :: forall a. Word8 -> ByteString -> (ByteString -> a) -> a -> (Char, a) unconsChar c0 bs0 f next - | c0 <= 0x7F = (chr (fromIntegral c0), f bs0) - | c0 <= 0xBF = (replacementChar, f bs0) - | c0 <= 0xDF = twoBytes - | c0 <= 0xEF = moreBytes 3 0x800 bs0 (fromIntegral $ c0 .&. 0xF) - | c0 <= 0xF7 = moreBytes 4 0x10000 bs0 (fromIntegral $ c0 .&. 0x7) - | c0 <= 0xFB = moreBytes 5 0x200000 bs0 (fromIntegral $ c0 .&. 0x3) - | c0 <= 0xFD = moreBytes 6 0x4000000 bs0 (fromIntegral $ c0 .&. 0x1) - | otherwise = error $ "not implemented " ++ show c0 + | c0 <= 0x7F = (chr (fromIntegral c0), f bs0) + | c0 <= 0xBF = (replacementChar, f bs0) + | c0 <= 0xDF = twoBytes + | c0 <= 0xEF = moreBytes 3 0x800 bs0 (fromIntegral $ c0 .&. 0xF) + | c0 <= 0xF7 = moreBytes 4 0x10000 bs0 (fromIntegral $ c0 .&. 0x7) + | c0 <= 0xFB = moreBytes 5 0x200000 bs0 (fromIntegral $ c0 .&. 0x3) + | c0 <= 0xFD = moreBytes 6 0x4000000 bs0 (fromIntegral $ c0 .&. 0x1) + | otherwise = error $ "not implemented " ++ show c0 where twoBytes = case BS.uncons bs0 of - Nothing -> (replacementChar, next) - Just (c1, bs1) - | c1 .&. 0xC0 == 0x80 -> - if d >= 0x80 - then (chr d, f bs1) - else (replacementChar, f bs1) - | otherwise -> (replacementChar, f bs1) - where - d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) .|. fromIntegral (c1 .&. 0x3F) + Nothing -> (replacementChar, next) + Just (c1, bs1) + | c1 .&. 0xC0 == 0x80 -> + if d >= 0x80 + then (chr d, f bs1) + else (replacementChar, f bs1) + | otherwise -> (replacementChar, f bs1) + where + d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) .|. fromIntegral (c1 .&. 0x3F) moreBytes :: Int -> Int -> ByteString -> Int -> (Char, a) moreBytes 1 overlong bs' acc - | overlong <= acc, acc <= 0x10FFFF, acc < 0xD800 || 0xDFFF < acc - = (chr acc, f bs') - | otherwise - = (replacementChar, f bs') - + | overlong <= acc + , acc <= 0x10FFFF + , acc < 0xD800 || 0xDFFF < acc = + (chr acc, f bs') + | otherwise = + (replacementChar, f bs') moreBytes byteCount overlong bs' acc = case BS.uncons bs' of - Nothing -> (replacementChar, f bs') - Just (cn, bs1) - | cn .&. 0xC0 == 0x80 -> moreBytes - (byteCount-1) - overlong - bs1 - ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F) - | otherwise -> (replacementChar, f bs1) + Nothing -> (replacementChar, f bs') + Just (cn, bs1) + | cn .&. 0xC0 == 0x80 -> + moreBytes + (byteCount - 1) + overlong + bs1 + ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F) + | otherwise -> (replacementChar, f bs1) replacementChar :: Char replacementChar = '\xfffd' diff --git a/Cabal-syntax/src/Distribution/Parsec/Position.hs b/Cabal-syntax/src/Distribution/Parsec/Position.hs index 5fe20fe3acd..892fc8b8fda 100644 --- a/Cabal-syntax/src/Distribution/Parsec/Position.hs +++ b/Cabal-syntax/src/Distribution/Parsec/Position.hs @@ -1,21 +1,23 @@ {-# LANGUAGE DeriveGeneric #-} -module Distribution.Parsec.Position ( - Position (..), - incPos, - retPos, - showPos, - zeroPos, - positionCol, - positionRow, - ) where + +module Distribution.Parsec.Position + ( Position (..) + , incPos + , retPos + , showPos + , zeroPos + , positionCol + , positionRow + ) where import Distribution.Compat.Prelude import Prelude () -- | 1-indexed row and column positions in a file. -data Position = Position - {-# UNPACK #-} !Int -- row - {-# UNPACK #-} !Int -- column +data Position + = Position + {-# UNPACK #-} !Int -- row + {-# UNPACK #-} !Int -- column deriving (Eq, Ord, Show, Generic) instance Binary Position diff --git a/Cabal-syntax/src/Distribution/Parsec/Warning.hs b/Cabal-syntax/src/Distribution/Parsec/Warning.hs index eedf5545cf7..88893e81d98 100644 --- a/Cabal-syntax/src/Distribution/Parsec/Warning.hs +++ b/Cabal-syntax/src/Distribution/Parsec/Warning.hs @@ -1,61 +1,76 @@ {-# LANGUAGE DeriveGeneric #-} -module Distribution.Parsec.Warning ( - PWarning (..), - PWarnType (..), - showPWarning, - ) where + +module Distribution.Parsec.Warning + ( PWarning (..) + , PWarnType (..) + , showPWarning + ) where import Distribution.Compat.Prelude import Distribution.Parsec.Position +import System.FilePath (normalise) import Prelude () -import System.FilePath (normalise) -- | Type of parser warning. We do classify warnings. -- -- Different application may decide not to show some, or have fatal behaviour on others data PWarnType - = PWTOther -- ^ Unclassified warning - | PWTUTF -- ^ Invalid UTF encoding - | PWTBoolCase -- ^ @true@ or @false@, not @True@ or @False@ - | PWTVersionTag -- ^ there are version with tags - | PWTNewSyntax -- ^ New syntax used, but no @cabal-version: >= 1.2@ specified - | PWTOldSyntax -- ^ Old syntax used, and @cabal-version >= 1.2@ specified - | PWTDeprecatedField - | PWTInvalidSubsection - | PWTUnknownField - | PWTUnknownSection - | PWTTrailingFields - | PWTExtraMainIs -- ^ extra main-is field - | PWTExtraTestModule -- ^ extra test-module field - | PWTExtraBenchmarkModule -- ^ extra benchmark-module field - | PWTLexNBSP - | PWTLexBOM - | PWTLexTab - | PWTQuirkyCabalFile -- ^ legacy cabal file that we know how to patch - | PWTDoubleDash -- ^ Double dash token, most likely it's a mistake - it's not a comment - | PWTMultipleSingularField -- ^ e.g. name or version should be specified only once. - | PWTBuildTypeDefault -- ^ Workaround for derive-package having build-type: Default. See . - - | PWTVersionOperator -- ^ Version operators used (without cabal-version: 1.8) - | PWTVersionWildcard -- ^ Version wildcard used (without cabal-version: 1.6) - - | PWTSpecVersion -- ^ Warnings about cabal-version format. - - | PWTEmptyFilePath -- ^ Empty filepath, i.e. literally "" - - | PWTExperimental -- ^ Experimental feature - deriving (Eq, Ord, Show, Enum, Bounded, Generic) + = -- | Unclassified warning + PWTOther + | -- | Invalid UTF encoding + PWTUTF + | -- | @true@ or @false@, not @True@ or @False@ + PWTBoolCase + | -- | there are version with tags + PWTVersionTag + | -- | New syntax used, but no @cabal-version: >= 1.2@ specified + PWTNewSyntax + | -- | Old syntax used, and @cabal-version >= 1.2@ specified + PWTOldSyntax + | PWTDeprecatedField + | PWTInvalidSubsection + | PWTUnknownField + | PWTUnknownSection + | PWTTrailingFields + | -- | extra main-is field + PWTExtraMainIs + | -- | extra test-module field + PWTExtraTestModule + | -- | extra benchmark-module field + PWTExtraBenchmarkModule + | PWTLexNBSP + | PWTLexBOM + | PWTLexTab + | -- | legacy cabal file that we know how to patch + PWTQuirkyCabalFile + | -- | Double dash token, most likely it's a mistake - it's not a comment + PWTDoubleDash + | -- | e.g. name or version should be specified only once. + PWTMultipleSingularField + | -- | Workaround for derive-package having build-type: Default. See . + PWTBuildTypeDefault + | -- | Version operators used (without cabal-version: 1.8) + PWTVersionOperator + | -- | Version wildcard used (without cabal-version: 1.6) + PWTVersionWildcard + | -- | Warnings about cabal-version format. + PWTSpecVersion + | -- | Empty filepath, i.e. literally "" + PWTEmptyFilePath + | -- | Experimental feature + PWTExperimental + deriving (Eq, Ord, Show, Enum, Bounded, Generic) instance Binary PWarnType instance NFData PWarnType where rnf = genericRnf -- | Parser warning. data PWarning = PWarning !PWarnType !Position String - deriving (Eq, Ord, Show, Generic) + deriving (Eq, Ord, Show, Generic) instance Binary PWarning instance NFData PWarning where rnf = genericRnf showPWarning :: FilePath -> PWarning -> String showPWarning fpath (PWarning _ pos msg) = - normalise fpath ++ ":" ++ showPos pos ++ ": " ++ msg + normalise fpath ++ ":" ++ showPos pos ++ ": " ++ msg diff --git a/Cabal-syntax/src/Distribution/Pretty.hs b/Cabal-syntax/src/Distribution/Pretty.hs index 1dfed5c8337..3ddb806d81b 100644 --- a/Cabal-syntax/src/Distribution/Pretty.hs +++ b/Cabal-syntax/src/Distribution/Pretty.hs @@ -1,17 +1,19 @@ -module Distribution.Pretty ( - Pretty (..), - prettyShow, - defaultStyle, - flatStyle, +module Distribution.Pretty + ( Pretty (..) + , prettyShow + , defaultStyle + , flatStyle + -- * Utilities - showFilePath, - showToken, - showTokenStr, - showFreeText, - showFreeTextV3, + , showFilePath + , showToken + , showTokenStr + , showFreeText + , showFreeTextV3 + -- * Deprecated - Separator, - ) where + , Separator + ) where import Distribution.CabalSpecVersion import Distribution.Compat.Prelude @@ -20,23 +22,23 @@ import Prelude () import qualified Text.PrettyPrint as PP class Pretty a where - pretty :: a -> PP.Doc + pretty :: a -> PP.Doc - prettyVersioned :: CabalSpecVersion -> a -> PP.Doc - prettyVersioned _ = pretty + prettyVersioned :: CabalSpecVersion -> a -> PP.Doc + prettyVersioned _ = pretty -- | @since 3.4.0.0 instance Pretty PP.Doc where - pretty = id + pretty = id instance Pretty Bool where - pretty = PP.text . show + pretty = PP.text . show instance Pretty Int where - pretty = PP.text . show + pretty = PP.text . show instance Pretty a => Pretty (Identity a) where - pretty = pretty . runIdentity + pretty = pretty . runIdentity prettyShow :: Pretty a => a -> String prettyShow = PP.renderStyle defaultStyle . pretty @@ -45,20 +47,29 @@ prettyShow = PP.renderStyle defaultStyle . pretty -- output. It has a fixed page width and adds line breaks -- automatically. defaultStyle :: PP.Style -defaultStyle = PP.Style { PP.mode = PP.PageMode - , PP.lineLength = 79 - , PP.ribbonsPerLine = 1.0 - } +defaultStyle = + PP.Style + { PP.mode = PP.PageMode + , PP.lineLength = 79 + , PP.ribbonsPerLine = 1.0 + } -- | A style for rendering all on one line. flatStyle :: PP.Style -flatStyle = PP.Style { PP.mode = PP.LeftMode - , PP.lineLength = err "lineLength" - , PP.ribbonsPerLine = err "ribbonsPerLine" - } +flatStyle = + PP.Style + { PP.mode = PP.LeftMode + , PP.lineLength = err "lineLength" + , PP.ribbonsPerLine = err "ribbonsPerLine" + } where - err x = error ("flatStyle: tried to access " ++ x ++ " in LeftMode. " ++ - "This should never happen and indicates a bug in Cabal.") + err x = + error + ( "flatStyle: tried to access " + ++ x + ++ " in LeftMode. " + ++ "This should never happen and indicates a bug in Cabal." + ) ------------------------------------------------------------------------------- -- Utilities @@ -75,21 +86,20 @@ showToken = PP.text . showTokenStr showTokenStr :: String -> String showTokenStr str - -- if token looks like a comment (starts with --), print it in quotes - | "--" `isPrefixOf` str = show str - -- also if token ends with a colon (e.g. executable name), print it in quotes - | ":" `isSuffixOf` str = show str - | not (any dodgy str) && not (null str) = str - | otherwise = show str + -- if token looks like a comment (starts with --), print it in quotes + | "--" `isPrefixOf` str = show str + -- also if token ends with a colon (e.g. executable name), print it in quotes + | ":" `isSuffixOf` str = show str + | not (any dodgy str) && not (null str) = str + | otherwise = show str where dodgy c = isSpace c || c == ',' - -- | Pretty-print free-format text, ensuring that it is vertically aligned, -- and with blank lines replaced by dots for correct re-parsing. showFreeText :: String -> PP.Doc showFreeText "" = mempty -showFreeText s = PP.vcat [ PP.text (if null l then "." else l) | l <- lines_ s ] +showFreeText s = PP.vcat [PP.text (if null l then "." else l) | l <- lines_ s] -- | Pretty-print free-format text. -- Since @cabal-version: 3.0@ we don't replace blank lines with dots. @@ -97,14 +107,14 @@ showFreeText s = PP.vcat [ PP.text (if null l then "." else l) | l <- lines_ s -- @since 3.0.0.0 showFreeTextV3 :: String -> PP.Doc showFreeTextV3 "" = mempty -showFreeTextV3 s = PP.vcat [ PP.text l | l <- lines_ s ] +showFreeTextV3 s = PP.vcat [PP.text l | l <- lines_ s] -- | 'lines_' breaks a string up into a list of strings at newline -- characters. The resulting strings do not contain newlines. -lines_ :: String -> [String] +lines_ :: String -> [String] lines_ [] = [""] -lines_ s = - let (l, s') = break (== '\n') s - in l : case s' of - [] -> [] - (_:s'') -> lines_ s'' +lines_ s = + let (l, s') = break (== '\n') s + in l : case s' of + [] -> [] + (_ : s'') -> lines_ s'' diff --git a/Cabal-syntax/src/Distribution/SPDX.hs b/Cabal-syntax/src/Distribution/SPDX.hs index f3f4fe284e2..a21c726fefe 100644 --- a/Cabal-syntax/src/Distribution/SPDX.hs +++ b/Cabal-syntax/src/Distribution/SPDX.hs @@ -1,40 +1,45 @@ -- | This module implements SPDX specification version 2.1 with a version 3.0 license list. -- -- Specification is available on -module Distribution.SPDX ( - -- * License - License (..), +module Distribution.SPDX + ( -- * License + License (..) + -- * License expression - LicenseExpression (..), - SimpleLicenseExpression (..), - simpleLicenseExpression, + , LicenseExpression (..) + , SimpleLicenseExpression (..) + , simpleLicenseExpression + -- * License identifier - LicenseId (..), - licenseId, - licenseName, - licenseIsOsiApproved, - mkLicenseId, - licenseIdList, + , LicenseId (..) + , licenseId + , licenseName + , licenseIsOsiApproved + , mkLicenseId + , licenseIdList + -- * License exception - LicenseExceptionId (..), - licenseExceptionId, - licenseExceptionName, - mkLicenseExceptionId, - licenseExceptionIdList, + , LicenseExceptionId (..) + , licenseExceptionId + , licenseExceptionName + , mkLicenseExceptionId + , licenseExceptionIdList + -- * License reference - LicenseRef, - licenseRef, - licenseDocumentRef, - mkLicenseRef, - mkLicenseRef', + , LicenseRef + , licenseRef + , licenseDocumentRef + , mkLicenseRef + , mkLicenseRef' + -- * License list version - LicenseListVersion (..), - cabalSpecVersionToSPDXListVersion, - ) where + , LicenseListVersion (..) + , cabalSpecVersionToSPDXListVersion + ) where -import Distribution.SPDX.LicenseExceptionId import Distribution.SPDX.License -import Distribution.SPDX.LicenseId +import Distribution.SPDX.LicenseExceptionId import Distribution.SPDX.LicenseExpression -import Distribution.SPDX.LicenseReference +import Distribution.SPDX.LicenseId import Distribution.SPDX.LicenseListVersion +import Distribution.SPDX.LicenseReference diff --git a/Cabal-syntax/src/Distribution/SPDX/License.hs b/Cabal-syntax/src/Distribution/SPDX/License.hs index c5ffbef5724..af271e9115a 100644 --- a/Cabal-syntax/src/Distribution/SPDX/License.hs +++ b/Cabal-syntax/src/Distribution/SPDX/License.hs @@ -1,14 +1,15 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -module Distribution.SPDX.License ( - License (..), - ) where -import Prelude () +module Distribution.SPDX.License + ( License (..) + ) where + import Distribution.Compat.Prelude +import Prelude () -import Distribution.Pretty import Distribution.Parsec +import Distribution.Pretty import Distribution.SPDX.LicenseExpression import qualified Distribution.Compat.CharParsing as P @@ -35,24 +36,23 @@ import qualified Text.PrettyPrint as Disp -- * @PublicDomain@ isn't covered. Consider using CC0. -- See -- for more information. --- data License - = NONE - -- ^ if the package contains no license information whatsoever; or - | License LicenseExpression - -- ^ A valid SPDX License Expression as defined in Appendix IV. + = -- | if the package contains no license information whatsoever; or + NONE + | -- | A valid SPDX License Expression as defined in Appendix IV. + License LicenseExpression deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) instance Binary License instance Structured License instance NFData License where - rnf NONE = () - rnf (License l) = rnf l + rnf NONE = () + rnf (License l) = rnf l instance Pretty License where - pretty NONE = Disp.text "NONE" - pretty (License l) = pretty l + pretty NONE = Disp.text "NONE" + pretty (License l) = pretty l -- | -- >>> eitherParsec "BSD-3-Clause AND MIT" :: Either String License @@ -60,6 +60,5 @@ instance Pretty License where -- -- >>> eitherParsec "NONE" :: Either String License -- Right NONE --- instance Parsec License where - parsec = NONE <$ P.try (P.string "NONE") <|> License <$> parsec + parsec = NONE <$ P.try (P.string "NONE") <|> License <$> parsec diff --git a/Cabal-syntax/src/Distribution/SPDX/LicenseExpression.hs b/Cabal-syntax/src/Distribution/SPDX/LicenseExpression.hs index a59e386e1f3..c77314746f8 100644 --- a/Cabal-syntax/src/Distribution/SPDX/LicenseExpression.hs +++ b/Cabal-syntax/src/Distribution/SPDX/LicenseExpression.hs @@ -1,10 +1,11 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.SPDX.LicenseExpression ( - LicenseExpression (..), - SimpleLicenseExpression (..), - simpleLicenseExpression, - ) where +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.SPDX.LicenseExpression + ( LicenseExpression (..) + , SimpleLicenseExpression (..) + , simpleLicenseExpression + ) where import Distribution.Compat.Prelude import Prelude () @@ -15,10 +16,10 @@ import Distribution.SPDX.LicenseExceptionId import Distribution.SPDX.LicenseId import Distribution.SPDX.LicenseListVersion import Distribution.SPDX.LicenseReference -import Distribution.Utils.Generic (isAsciiAlphaNum) +import Distribution.Utils.Generic (isAsciiAlphaNum) import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp +import qualified Text.PrettyPrint as Disp -- | SPDX License Expression. -- @@ -39,20 +40,20 @@ import qualified Text.PrettyPrint as Disp -- license expression = 1*1(simple expression / compound expression) -- @ data LicenseExpression - = ELicense !SimpleLicenseExpression !(Maybe LicenseExceptionId) - | EAnd !LicenseExpression !LicenseExpression - | EOr !LicenseExpression !LicenseExpression - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) + = ELicense !SimpleLicenseExpression !(Maybe LicenseExceptionId) + | EAnd !LicenseExpression !LicenseExpression + | EOr !LicenseExpression !LicenseExpression + deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) -- | Simple License Expressions. data SimpleLicenseExpression - = ELicenseId LicenseId - -- ^ An SPDX License List Short Form Identifier. For example: @GPL-2.0-only@ - | ELicenseIdPlus LicenseId - -- ^ An SPDX License List Short Form Identifier with a unary"+" operator suffix to represent the current version of the license or any later version. For example: @GPL-2.0+@ - | ELicenseRef LicenseRef - -- ^ A SPDX user defined license reference: For example: @LicenseRef-23@, @LicenseRef-MIT-Style-1@, or @DocumentRef-spdx-tool-1.2:LicenseRef-MIT-Style-2@ - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) + = -- | An SPDX License List Short Form Identifier. For example: @GPL-2.0-only@ + ELicenseId LicenseId + | -- | An SPDX License List Short Form Identifier with a unary"+" operator suffix to represent the current version of the license or any later version. For example: @GPL-2.0+@ + ELicenseIdPlus LicenseId + | -- | A SPDX user defined license reference: For example: @LicenseRef-23@, @LicenseRef-MIT-Style-1@, or @DocumentRef-spdx-tool-1.2:LicenseRef-MIT-Style-2@ + ELicenseRef LicenseRef + deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) simpleLicenseExpression :: LicenseId -> LicenseExpression simpleLicenseExpression i = ELicense (ELicenseId i) Nothing @@ -63,41 +64,42 @@ instance Structured SimpleLicenseExpression instance Structured LicenseExpression instance Pretty LicenseExpression where - pretty = go 0 - where - go :: Int -> LicenseExpression -> Disp.Doc - go _ (ELicense lic exc) = - let doc = pretty lic - in maybe id (\e d -> d <+> Disp.text "WITH" <+> pretty e) exc doc - go d (EAnd e1 e2) = parens (d < 0) $ go 0 e1 <+> Disp.text "AND" <+> go 0 e2 - go d (EOr e1 e2) = parens (d < 1) $ go 1 e1 <+> Disp.text "OR" <+> go 1 e2 - - - parens False doc = doc - parens True doc = Disp.parens doc + pretty = go 0 + where + go :: Int -> LicenseExpression -> Disp.Doc + go _ (ELicense lic exc) = + let doc = pretty lic + in maybe id (\e d -> d <+> Disp.text "WITH" <+> pretty e) exc doc + go d (EAnd e1 e2) = parens (d < 0) $ go 0 e1 <+> Disp.text "AND" <+> go 0 e2 + go d (EOr e1 e2) = parens (d < 1) $ go 1 e1 <+> Disp.text "OR" <+> go 1 e2 + + parens False doc = doc + parens True doc = Disp.parens doc instance Pretty SimpleLicenseExpression where - pretty (ELicenseId i) = pretty i - pretty (ELicenseIdPlus i) = pretty i <<>> Disp.char '+' - pretty (ELicenseRef r) = pretty r + pretty (ELicenseId i) = pretty i + pretty (ELicenseIdPlus i) = pretty i <<>> Disp.char '+' + pretty (ELicenseRef r) = pretty r instance Parsec SimpleLicenseExpression where - parsec = idstring >>= simple where - simple n - | Just l <- "LicenseRef-" `isPrefixOfMaybe` n = - maybe (fail $ "Incorrect LicenseRef format: " ++ n) (return . ELicenseRef) $ mkLicenseRef Nothing l - | Just d <- "DocumentRef-" `isPrefixOfMaybe` n = do - _ <- P.string ":LicenseRef-" - l <- idstring - maybe (fail $ "Incorrect LicenseRef format:" ++ n) (return . ELicenseRef) $ mkLicenseRef (Just d) l - | otherwise = do - v <- askCabalSpecVersion - l <- maybe (fail $ "Unknown SPDX license identifier: '" ++ n ++ "' " ++ licenseIdMigrationMessage n) return $ - mkLicenseId (cabalSpecVersionToSPDXListVersion v) n - orLater <- isJust <$> P.optional (P.char '+') - if orLater - then return (ELicenseIdPlus l) - else return (ELicenseId l) + parsec = idstring >>= simple + where + simple n + | Just l <- "LicenseRef-" `isPrefixOfMaybe` n = + maybe (fail $ "Incorrect LicenseRef format: " ++ n) (return . ELicenseRef) $ mkLicenseRef Nothing l + | Just d <- "DocumentRef-" `isPrefixOfMaybe` n = do + _ <- P.string ":LicenseRef-" + l <- idstring + maybe (fail $ "Incorrect LicenseRef format:" ++ n) (return . ELicenseRef) $ mkLicenseRef (Just d) l + | otherwise = do + v <- askCabalSpecVersion + l <- + maybe (fail $ "Unknown SPDX license identifier: '" ++ n ++ "' " ++ licenseIdMigrationMessage n) return $ + mkLicenseId (cabalSpecVersionToSPDXListVersion v) n + orLater <- isJust <$> P.optional (P.char '+') + if orLater + then return (ELicenseIdPlus l) + else return (ELicenseId l) idstring :: P.CharParsing m => m String idstring = P.munch1 $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' @@ -105,43 +107,43 @@ idstring = P.munch1 $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' -- returns suffix part isPrefixOfMaybe :: Eq a => [a] -> [a] -> Maybe [a] isPrefixOfMaybe pfx s - | pfx `isPrefixOf` s = Just (drop (length pfx) s) - | otherwise = Nothing + | pfx `isPrefixOf` s = Just (drop (length pfx) s) + | otherwise = Nothing instance Parsec LicenseExpression where - parsec = expr - where - expr = compoundOr + parsec = expr + where + expr = compoundOr - simple = do - s <- parsec - exc <- exception - return $ ELicense s exc + simple = do + s <- parsec + exc <- exception + return $ ELicense s exc - exception = P.optional $ P.try (spaces1 *> P.string "WITH" *> spaces1) *> parsec + exception = P.optional $ P.try (spaces1 *> P.string "WITH" *> spaces1) *> parsec - compoundOr = do - x <- compoundAnd - l <- P.optional $ P.try (spaces1 *> P.string "OR" *> spaces1) *> compoundOr - return $ maybe id (flip EOr) l x + compoundOr = do + x <- compoundAnd + l <- P.optional $ P.try (spaces1 *> P.string "OR" *> spaces1) *> compoundOr + return $ maybe id (flip EOr) l x - compoundAnd = do - x <- compound - l <- P.optional $ P.try (spaces1 *> P.string "AND" *> spaces1) *> compoundAnd - return $ maybe id (flip EAnd) l x + compoundAnd = do + x <- compound + l <- P.optional $ P.try (spaces1 *> P.string "AND" *> spaces1) *> compoundAnd + return $ maybe id (flip EAnd) l x - compound = braces <|> simple + compound = braces <|> simple - -- NOTE: we require that there's a space around AND & OR operators, - -- i.e. @(MIT)AND(MIT)@ will cause parse-error. - braces = do - _ <- P.char '(' - _ <- P.spaces - x <- expr - _ <- P.char ')' - return x + -- NOTE: we require that there's a space around AND & OR operators, + -- i.e. @(MIT)AND(MIT)@ will cause parse-error. + braces = do + _ <- P.char '(' + _ <- P.spaces + x <- expr + _ <- P.char ')' + return x - spaces1 = P.space *> P.spaces + spaces1 = P.space *> P.spaces -- notes: -- @@ -152,11 +154,11 @@ instance Parsec LicenseExpression where -- We handle that by having greedy 'idstring' parser, so MITAND would parse as invalid license identifier. instance NFData LicenseExpression where - rnf (ELicense s e) = rnf s `seq` rnf e - rnf (EAnd x y) = rnf x `seq` rnf y - rnf (EOr x y) = rnf x `seq` rnf y + rnf (ELicense s e) = rnf s `seq` rnf e + rnf (EAnd x y) = rnf x `seq` rnf y + rnf (EOr x y) = rnf x `seq` rnf y instance NFData SimpleLicenseExpression where - rnf (ELicenseId i) = rnf i - rnf (ELicenseIdPlus i) = rnf i - rnf (ELicenseRef r) = rnf r + rnf (ELicenseId i) = rnf i + rnf (ELicenseIdPlus i) = rnf i + rnf (ELicenseRef r) = rnf r diff --git a/Cabal-syntax/src/Distribution/SPDX/LicenseListVersion.hs b/Cabal-syntax/src/Distribution/SPDX/LicenseListVersion.hs index 467405a0b59..9aeb6280454 100644 --- a/Cabal-syntax/src/Distribution/SPDX/LicenseListVersion.hs +++ b/Cabal-syntax/src/Distribution/SPDX/LicenseListVersion.hs @@ -1,18 +1,18 @@ -module Distribution.SPDX.LicenseListVersion ( - LicenseListVersion (..), - cabalSpecVersionToSPDXListVersion, - ) where +module Distribution.SPDX.LicenseListVersion + ( LicenseListVersion (..) + , cabalSpecVersionToSPDXListVersion + ) where import Distribution.CabalSpecVersion -- | SPDX License List version @Cabal@ is aware of. data LicenseListVersion - = LicenseListVersion_3_0 - | LicenseListVersion_3_2 - | LicenseListVersion_3_6 - | LicenseListVersion_3_9 - | LicenseListVersion_3_10 - | LicenseListVersion_3_16 + = LicenseListVersion_3_0 + | LicenseListVersion_3_2 + | LicenseListVersion_3_6 + | LicenseListVersion_3_9 + | LicenseListVersion_3_10 + | LicenseListVersion_3_16 deriving (Eq, Ord, Show, Enum, Bounded) cabalSpecVersionToSPDXListVersion :: CabalSpecVersion -> LicenseListVersion @@ -21,4 +21,4 @@ cabalSpecVersionToSPDXListVersion CabalSpecV3_6 = LicenseListVersion_3_10 cabalSpecVersionToSPDXListVersion CabalSpecV3_4 = LicenseListVersion_3_9 cabalSpecVersionToSPDXListVersion CabalSpecV3_0 = LicenseListVersion_3_6 cabalSpecVersionToSPDXListVersion CabalSpecV2_4 = LicenseListVersion_3_2 -cabalSpecVersionToSPDXListVersion _ = LicenseListVersion_3_0 +cabalSpecVersionToSPDXListVersion _ = LicenseListVersion_3_0 diff --git a/Cabal-syntax/src/Distribution/SPDX/LicenseReference.hs b/Cabal-syntax/src/Distribution/SPDX/LicenseReference.hs index 3f6e754bcca..949d6c4d15d 100644 --- a/Cabal-syntax/src/Distribution/SPDX/LicenseReference.hs +++ b/Cabal-syntax/src/Distribution/SPDX/LicenseReference.hs @@ -1,28 +1,29 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -module Distribution.SPDX.LicenseReference ( - LicenseRef, - licenseRef, - licenseDocumentRef, - mkLicenseRef, - mkLicenseRef', - ) where -import Prelude () +module Distribution.SPDX.LicenseReference + ( LicenseRef + , licenseRef + , licenseDocumentRef + , mkLicenseRef + , mkLicenseRef' + ) where + import Distribution.Compat.Prelude +import Prelude () -import Distribution.Utils.Generic (isAsciiAlphaNum) -import Distribution.Pretty import Distribution.Parsec +import Distribution.Pretty +import Distribution.Utils.Generic (isAsciiAlphaNum) import qualified Distribution.Compat.CharParsing as P import qualified Text.PrettyPrint as Disp -- | A user defined license reference denoted by @LicenseRef-[idstring]@ (for a license not on the SPDX License List); data LicenseRef = LicenseRef - { _lrDocument :: !(Maybe String) - , _lrLicense :: !String - } + { _lrDocument :: !(Maybe String) + , _lrLicense :: !String + } deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) -- | License reference. @@ -37,44 +38,45 @@ instance Binary LicenseRef instance Structured LicenseRef instance NFData LicenseRef where - rnf (LicenseRef d l) = rnf d `seq` rnf l + rnf (LicenseRef d l) = rnf d `seq` rnf l instance Pretty LicenseRef where - pretty (LicenseRef Nothing l) = Disp.text "LicenseRef-" <<>> Disp.text l - pretty (LicenseRef (Just d) l) = - Disp.text "DocumentRef-" <<>> Disp.text d <<>> Disp.char ':' <<>> Disp.text "LicenseRef-" <<>> Disp.text l + pretty (LicenseRef Nothing l) = Disp.text "LicenseRef-" <<>> Disp.text l + pretty (LicenseRef (Just d) l) = + Disp.text "DocumentRef-" <<>> Disp.text d <<>> Disp.char ':' <<>> Disp.text "LicenseRef-" <<>> Disp.text l instance Parsec LicenseRef where - parsec = name <|> doc - where - name = do - _ <- P.string "LicenseRef-" - n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' - pure (LicenseRef Nothing n) + parsec = name <|> doc + where + name = do + _ <- P.string "LicenseRef-" + n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' + pure (LicenseRef Nothing n) - doc = do - _ <- P.string "DocumentRef-" - d <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' - _ <- P.char ':' - _ <- P.string "LicenseRef-" - n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' - pure (LicenseRef (Just d) n) + doc = do + _ <- P.string "DocumentRef-" + d <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' + _ <- P.char ':' + _ <- P.string "LicenseRef-" + n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' + pure (LicenseRef (Just d) n) -- | Create 'LicenseRef' from optional document ref and name. mkLicenseRef :: Maybe String -> String -> Maybe LicenseRef mkLicenseRef d l = do - d' <- traverse checkIdString d - l' <- checkIdString l - pure (LicenseRef d' l') + d' <- traverse checkIdString d + l' <- checkIdString l + pure (LicenseRef d' l') where checkIdString s - | all (\c -> isAsciiAlphaNum c || c == '-' || c == '.') s = Just s - | otherwise = Nothing + | all (\c -> isAsciiAlphaNum c || c == '-' || c == '.') s = Just s + | otherwise = Nothing -- | Like 'mkLicenseRef' but convert invalid characters into @-@. mkLicenseRef' :: Maybe String -> String -> LicenseRef mkLicenseRef' d l = LicenseRef (fmap f d) (f l) where f = map g - g c | isAsciiAlphaNum c || c == '-' || c == '.' = c - | otherwise = '-' + g c + | isAsciiAlphaNum c || c == '-' || c == '.' = c + | otherwise = '-' diff --git a/Cabal-syntax/src/Distribution/System.hs b/Cabal-syntax/src/Distribution/System.hs index 68bda631f19..5142bf523b1 100644 --- a/Cabal-syntax/src/Distribution/System.hs +++ b/Cabal-syntax/src/Distribution/System.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.System -- Copyright : Duncan Coutts 2007-2008 @@ -17,41 +18,40 @@ -- do not agree on using the same strings for the same platforms! (In -- particular see the controversy over \"windows\" vs \"mingw32\"). So to make it -- more consistent and easy to use we have an 'OS' enumeration. --- -module Distribution.System ( - -- * Operating System - OS(..), - buildOS, - - -- * Machine Architecture - Arch(..), - buildArch, - - -- * Platform is a pair of arch and OS - Platform(..), - buildPlatform, - platformFromTriple, - - -- * Internal - knownOSs, - knownArches, - - -- * Classification - ClassificationStrictness (..), - classifyOS, - classifyArch, +module Distribution.System + ( -- * Operating System + OS (..) + , buildOS + + -- * Machine Architecture + , Arch (..) + , buildArch + + -- * Platform is a pair of arch and OS + , Platform (..) + , buildPlatform + , platformFromTriple + + -- * Internal + , knownOSs + , knownArches + + -- * Classification + , ClassificationStrictness (..) + , classifyOS + , classifyArch ) where +import Control.Applicative (Applicative (..)) +import Distribution.Compat.Prelude hiding (Applicative (..)) import Prelude () -import Distribution.Compat.Prelude hiding (Applicative(..)) -import Control.Applicative (Applicative(..)) #if !MIN_VERSION_base(4,10,0) import Control.Applicative (liftA2) #endif -import qualified System.Info (os, arch) import Distribution.Utils.Generic (lowercase) +import qualified System.Info (arch, os) import Distribution.Parsec import Distribution.Pretty @@ -75,11 +75,12 @@ import qualified Text.PrettyPrint as Disp -- The 'Compat' classification allows us to recognise aliases that are already -- in common use but it allows us to distinguish them from the canonical name -- which enables us to warn about such deprecated aliases. --- data ClassificationStrictness = Permissive | Compat | Strict -- ------------------------------------------------------------ + -- * Operating System + -- ------------------------------------------------------------ -- | These are the known OS names: Linux, Windows, OSX @@ -93,17 +94,25 @@ data ClassificationStrictness = Permissive | Compat | Strict -- * Hurd alias: gnu -- * FreeBSD alias: kfreebsdgnu -- * Solaris alias: solaris2 --- -data OS = Linux | Windows | OSX -- tier 1 desktop OSs - | FreeBSD | OpenBSD | NetBSD -- other free Unix OSs - | DragonFly - | Solaris | AIX | HPUX | IRIX -- ageing Unix OSs - | HaLVM -- bare metal / VMs / hypervisors - | Hurd -- GNU's microkernel - | IOS | Android -- mobile OSs - | Ghcjs - | Wasi - | OtherOS String +data OS + = Linux + | Windows + | OSX -- tier 1 desktop OSs + | FreeBSD + | OpenBSD + | NetBSD -- other free Unix OSs + | DragonFly + | Solaris + | AIX + | HPUX + | IRIX -- ageing Unix OSs + | HaLVM -- bare metal / VMs / hypervisors + | Hurd -- GNU's microkernel + | IOS + | Android -- mobile OSs + | Ghcjs + | Wasi + | OtherOS String deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) instance Binary OS @@ -111,50 +120,63 @@ instance Structured OS instance NFData OS where rnf = genericRnf knownOSs :: [OS] -knownOSs = [Linux, Windows, OSX - ,FreeBSD, OpenBSD, NetBSD, DragonFly - ,Solaris, AIX, HPUX, IRIX - ,HaLVM - ,Hurd - ,IOS, Android - ,Ghcjs - ,Wasi] +knownOSs = + [ Linux + , Windows + , OSX + , FreeBSD + , OpenBSD + , NetBSD + , DragonFly + , Solaris + , AIX + , HPUX + , IRIX + , HaLVM + , Hurd + , IOS + , Android + , Ghcjs + , Wasi + ] osAliases :: ClassificationStrictness -> OS -> [String] osAliases Permissive Windows = ["mingw32", "win32", "cygwin32"] -osAliases Compat Windows = ["mingw32", "win32"] -osAliases _ OSX = ["darwin"] -osAliases _ Hurd = ["gnu"] +osAliases Compat Windows = ["mingw32", "win32"] +osAliases _ OSX = ["darwin"] +osAliases _ Hurd = ["gnu"] osAliases Permissive FreeBSD = ["kfreebsdgnu"] -osAliases Compat FreeBSD = ["kfreebsdgnu"] +osAliases Compat FreeBSD = ["kfreebsdgnu"] osAliases Permissive Solaris = ["solaris2"] -osAliases Compat Solaris = ["solaris2"] +osAliases Compat Solaris = ["solaris2"] osAliases Permissive Android = ["linux-android", "linux-androideabi", "linux-androideabihf"] -osAliases Compat Android = ["linux-android"] -osAliases _ _ = [] +osAliases Compat Android = ["linux-android"] +osAliases _ _ = [] instance Pretty OS where pretty (OtherOS name) = Disp.text name - pretty other = Disp.text (lowercase (show other)) + pretty other = Disp.text (lowercase (show other)) instance Parsec OS where parsec = classifyOS Compat <$> parsecIdent - - classifyOS :: ClassificationStrictness -> String -> OS classifyOS strictness s = fromMaybe (OtherOS s) $ lookup (lowercase s) osMap where - osMap = [ (name, os) - | os <- knownOSs - , name <- prettyShow os : osAliases strictness os ] + osMap = + [ (name, os) + | os <- knownOSs + , name <- prettyShow os : osAliases strictness os + ] buildOS :: OS buildOS = classifyOS Permissive System.Info.os -- ------------------------------------------------------------ + -- * Machine Architecture + -- ------------------------------------------------------------ -- | These are the known Arches: I386, X86_64, PPC, PPC64, Sparc, @@ -168,15 +190,27 @@ buildOS = classifyOS Permissive System.Info.os -- * Mips aliases: mipsel, mipseb -- * Arm aliases: armeb, armel -- * AArch64 aliases: arm64 --- -data Arch = I386 | X86_64 | PPC | PPC64 | Sparc - | Arm | AArch64 | Mips | SH - | IA64 | S390 | S390X - | Alpha | Hppa | Rs6000 - | M68k | Vax - | JavaScript - | Wasm32 - | OtherArch String +data Arch + = I386 + | X86_64 + | PPC + | PPC64 + | Sparc + | Arm + | AArch64 + | Mips + | SH + | IA64 + | S390 + | S390X + | Alpha + | Hppa + | Rs6000 + | M68k + | Vax + | JavaScript + | Wasm32 + | OtherArch String deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) instance Binary Arch @@ -184,28 +218,42 @@ instance Structured Arch instance NFData Arch where rnf = genericRnf knownArches :: [Arch] -knownArches = [I386, X86_64, PPC, PPC64, Sparc - ,Arm, AArch64, Mips, SH - ,IA64, S390, S390X - ,Alpha, Hppa, Rs6000 - ,M68k, Vax - ,JavaScript - ,Wasm32] +knownArches = + [ I386 + , X86_64 + , PPC + , PPC64 + , Sparc + , Arm + , AArch64 + , Mips + , SH + , IA64 + , S390 + , S390X + , Alpha + , Hppa + , Rs6000 + , M68k + , Vax + , JavaScript + , Wasm32 + ] archAliases :: ClassificationStrictness -> Arch -> [String] -archAliases Strict _ = [] -archAliases Compat _ = [] -archAliases _ PPC = ["powerpc"] -archAliases _ PPC64 = ["powerpc64", "powerpc64le"] -archAliases _ Sparc = ["sparc64", "sun4"] -archAliases _ Mips = ["mipsel", "mipseb"] -archAliases _ Arm = ["armeb", "armel"] -archAliases _ AArch64 = ["arm64"] -archAliases _ _ = [] +archAliases Strict _ = [] +archAliases Compat _ = [] +archAliases _ PPC = ["powerpc"] +archAliases _ PPC64 = ["powerpc64", "powerpc64le"] +archAliases _ Sparc = ["sparc64", "sun4"] +archAliases _ Mips = ["mipsel", "mipseb"] +archAliases _ Arm = ["armeb", "armel"] +archAliases _ AArch64 = ["arm64"] +archAliases _ _ = [] instance Pretty Arch where pretty (OtherArch name) = Disp.text name - pretty other = Disp.text (lowercase (show other)) + pretty other = Disp.text (lowercase (show other)) instance Parsec Arch where parsec = classifyArch Strict <$> parsecIdent @@ -214,15 +262,19 @@ classifyArch :: ClassificationStrictness -> String -> Arch classifyArch strictness s = fromMaybe (OtherArch s) $ lookup (lowercase s) archMap where - archMap = [ (name, arch) - | arch <- knownArches - , name <- prettyShow arch : archAliases strictness arch ] + archMap = + [ (name, arch) + | arch <- knownArches + , name <- prettyShow arch : archAliases strictness arch + ] buildArch :: Arch buildArch = classifyArch Permissive System.Info.arch -- ------------------------------------------------------------ + -- * Platform + -- ------------------------------------------------------------ data Platform = Platform Arch OS @@ -236,25 +288,25 @@ instance Pretty Platform where pretty (Platform arch os) = pretty arch <<>> Disp.char '-' <<>> pretty os instance Parsec Platform where - -- TODO: there are ambiguous platforms like: `arch-word-os` - -- which could be parsed as - -- * Platform "arch-word" "os" - -- * Platform "arch" "word-os" - -- We could support that preferring variants 'OtherOS' or 'OtherArch' - -- - -- For now we split into arch and os parts on the first dash. - parsec = do - arch <- parsecDashlessArch - _ <- P.char '-' - os <- parsec - return (Platform arch os) - where - parsecDashlessArch = classifyArch Strict <$> dashlessIdent - - dashlessIdent = liftA2 (:) firstChar rest - where - firstChar = P.satisfy isAlpha - rest = P.munch (\c -> isAlphaNum c || c == '_') + -- TODO: there are ambiguous platforms like: `arch-word-os` + -- which could be parsed as + -- * Platform "arch-word" "os" + -- * Platform "arch" "word-os" + -- We could support that preferring variants 'OtherOS' or 'OtherArch' + -- + -- For now we split into arch and os parts on the first dash. + parsec = do + arch <- parsecDashlessArch + _ <- P.char '-' + os <- parsec + return (Platform arch os) + where + parsecDashlessArch = classifyArch Strict <$> dashlessIdent + + dashlessIdent = liftA2 (:) firstChar rest + where + firstChar = P.satisfy isAlpha + rest = P.munch (\c -> isAlphaNum c || c == '_') -- | The platform Cabal was compiled on. In most cases, -- @LocalBuildInfo.hostPlatform@ should be used instead (the platform we're @@ -268,17 +320,18 @@ parsecIdent :: CabalParsing m => m String parsecIdent = (:) <$> firstChar <*> rest where firstChar = P.satisfy isAlpha - rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-') + rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-') platformFromTriple :: String -> Maybe Platform platformFromTriple triple = - either (const Nothing) Just $ explicitEitherParsec parseTriple triple - where parseWord = P.munch1 (\c -> isAlphaNum c || c == '_') - parseTriple = do - arch <- fmap (classifyArch Permissive) parseWord - _ <- P.char '-' - _ <- parseWord -- Skip vendor - _ <- P.char '-' - os <- fmap (classifyOS Permissive) parsecIdent -- OS may have hyphens, like - -- 'nto-qnx' - return $ Platform arch os + either (const Nothing) Just $ explicitEitherParsec parseTriple triple + where + parseWord = P.munch1 (\c -> isAlphaNum c || c == '_') + parseTriple = do + arch <- fmap (classifyArch Permissive) parseWord + _ <- P.char '-' + _ <- parseWord -- Skip vendor + _ <- P.char '-' + os <- fmap (classifyOS Permissive) parsecIdent -- OS may have hyphens, like + -- 'nto-qnx' + return $ Platform arch os diff --git a/Cabal-syntax/src/Distribution/Text.hs b/Cabal-syntax/src/Distribution/Text.hs index 258b4dc835f..0589e35261e 100644 --- a/Cabal-syntax/src/Distribution/Text.hs +++ b/Cabal-syntax/src/Distribution/Text.hs @@ -1,9 +1,10 @@ -- Since @3.0@ this is a compat module. module Distribution.Text (display, simpleParse) where + {- {-# DEPRECATED "Use Distribution.Parsec or Distribution.Pretty" #-} -} -import Distribution.Pretty import Distribution.Parsec +import Distribution.Pretty display :: Pretty a => a -> String display = prettyShow diff --git a/Cabal-syntax/src/Distribution/Types/AbiDependency.hs b/Cabal-syntax/src/Distribution/Types/AbiDependency.hs index 8442bf9d410..2f380d15af2 100644 --- a/Cabal-syntax/src/Distribution/Types/AbiDependency.hs +++ b/Cabal-syntax/src/Distribution/Types/AbiDependency.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} + module Distribution.Types.AbiDependency where import Distribution.Compat.Prelude @@ -9,8 +10,8 @@ import Distribution.Parsec import Distribution.Pretty import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.Package as Package -import qualified Text.PrettyPrint as Disp +import qualified Distribution.Package as Package +import qualified Text.PrettyPrint as Disp -- | An ABI dependency is a dependency on a library which also -- records the ABI hash ('abiHash') of the library it depends @@ -22,22 +23,22 @@ import qualified Text.PrettyPrint as Disp -- is critical if we are shadowing libraries; differences in the -- ABI hash let us know what packages get shadowed by the new version -- of a package. -data AbiDependency = AbiDependency { - depUnitId :: Package.UnitId, - depAbiHash :: Package.AbiHash - } +data AbiDependency = AbiDependency + { depUnitId :: Package.UnitId + , depAbiHash :: Package.AbiHash + } deriving (Eq, Generic, Read, Show, Typeable) instance Pretty AbiDependency where - pretty (AbiDependency uid abi) = - pretty uid <<>> Disp.char '=' <<>> pretty abi - -instance Parsec AbiDependency where - parsec = do - uid <- parsec - _ <- P.char '=' - abi <- parsec - return (AbiDependency uid abi) + pretty (AbiDependency uid abi) = + pretty uid <<>> Disp.char '=' <<>> pretty abi + +instance Parsec AbiDependency where + parsec = do + uid <- parsec + _ <- P.char '=' + abi <- parsec + return (AbiDependency uid abi) instance Binary AbiDependency instance Structured AbiDependency diff --git a/Cabal-syntax/src/Distribution/Types/AbiHash.hs b/Cabal-syntax/src/Distribution/Types/AbiHash.hs index 6c154066e81..a1be416c4ba 100644 --- a/Cabal-syntax/src/Distribution/Types/AbiHash.hs +++ b/Cabal-syntax/src/Distribution/Types/AbiHash.hs @@ -3,16 +3,18 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Distribution.Types.AbiHash - ( AbiHash, unAbiHash, mkAbiHash + ( AbiHash + , unAbiHash + , mkAbiHash ) where -import Prelude () import Distribution.Compat.Prelude import Distribution.Utils.ShortText +import Prelude () import qualified Distribution.Compat.CharParsing as P -import Distribution.Pretty import Distribution.Parsec +import Distribution.Pretty import Text.PrettyPrint (text) @@ -25,7 +27,7 @@ import Text.PrettyPrint (text) -- -- @since 2.0.0.2 newtype AbiHash = AbiHash ShortText - deriving (Eq, Show, Read, Generic, Typeable) + deriving (Eq, Show, Read, Generic, Typeable) -- | Convert 'AbiHash' to 'String' -- @@ -48,14 +50,14 @@ mkAbiHash = AbiHash . toShortText -- -- @since 2.0.0.2 instance IsString AbiHash where - fromString = mkAbiHash + fromString = mkAbiHash instance Binary AbiHash instance Structured AbiHash instance NFData AbiHash where rnf = genericRnf instance Pretty AbiHash where - pretty = text . unAbiHash + pretty = text . unAbiHash instance Parsec AbiHash where - parsec = fmap mkAbiHash (P.munch isAlphaNum) + parsec = fmap mkAbiHash (P.munch isAlphaNum) diff --git a/Cabal-syntax/src/Distribution/Types/Benchmark.hs b/Cabal-syntax/src/Distribution/Types/Benchmark.hs index 1f0bb27c709..be0911432ec 100644 --- a/Cabal-syntax/src/Distribution/Types/Benchmark.hs +++ b/Cabal-syntax/src/Distribution/Types/Benchmark.hs @@ -1,20 +1,20 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.Benchmark ( - Benchmark(..), - emptyBenchmark, - benchmarkType, - benchmarkModules, - benchmarkModulesAutogen -) where +module Distribution.Types.Benchmark + ( Benchmark (..) + , emptyBenchmark + , benchmarkType + , benchmarkModules + , benchmarkModulesAutogen + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.BuildInfo -import Distribution.Types.BenchmarkType import Distribution.Types.BenchmarkInterface +import Distribution.Types.BenchmarkType +import Distribution.Types.BuildInfo import Distribution.Types.UnqualComponentName import Distribution.ModuleName @@ -22,49 +22,57 @@ import Distribution.ModuleName import qualified Distribution.Types.BuildInfo.Lens as L -- | A \"benchmark\" stanza in a cabal file. --- -data Benchmark = Benchmark { - benchmarkName :: UnqualComponentName, - benchmarkInterface :: BenchmarkInterface, - benchmarkBuildInfo :: BuildInfo - } - deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) +data Benchmark = Benchmark + { benchmarkName :: UnqualComponentName + , benchmarkInterface :: BenchmarkInterface + , benchmarkBuildInfo :: BuildInfo + } + deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) instance Binary Benchmark instance Structured Benchmark instance NFData Benchmark where rnf = genericRnf instance L.HasBuildInfo Benchmark where - buildInfo f (Benchmark x1 x2 x3) = fmap (\y1 -> Benchmark x1 x2 y1) (f x3) + buildInfo f (Benchmark x1 x2 x3) = fmap (\y1 -> Benchmark x1 x2 y1) (f x3) instance Monoid Benchmark where - mempty = Benchmark { - benchmarkName = mempty, - benchmarkInterface = mempty, - benchmarkBuildInfo = mempty - } - mappend = (<>) + mempty = + Benchmark + { benchmarkName = mempty + , benchmarkInterface = mempty + , benchmarkBuildInfo = mempty + } + mappend = (<>) instance Semigroup Benchmark where - a <> b = Benchmark { - benchmarkName = combine' benchmarkName, - benchmarkInterface = combine benchmarkInterface, - benchmarkBuildInfo = combine benchmarkBuildInfo - } - where combine field = field a `mappend` field b - combine' field = case ( unUnqualComponentName $ field a - , unUnqualComponentName $ field b) of - ("", _) -> field b - (_, "") -> field a - (x, y) -> error $ "Ambiguous values for test field: '" - ++ x ++ "' and '" ++ y ++ "'" + a <> b = + Benchmark + { benchmarkName = combine' benchmarkName + , benchmarkInterface = combine benchmarkInterface + , benchmarkBuildInfo = combine benchmarkBuildInfo + } + where + combine field = field a `mappend` field b + combine' field = case ( unUnqualComponentName $ field a + , unUnqualComponentName $ field b + ) of + ("", _) -> field b + (_, "") -> field a + (x, y) -> + error $ + "Ambiguous values for test field: '" + ++ x + ++ "' and '" + ++ y + ++ "'" emptyBenchmark :: Benchmark emptyBenchmark = mempty benchmarkType :: Benchmark -> BenchmarkType benchmarkType benchmark = case benchmarkInterface benchmark of - BenchmarkExeV10 ver _ -> BenchmarkTypeExe ver + BenchmarkExeV10 ver _ -> BenchmarkTypeExe ver BenchmarkUnsupported benchmarktype -> benchmarktype -- | Get all the module names from a benchmark. diff --git a/Cabal-syntax/src/Distribution/Types/Benchmark/Lens.hs b/Cabal-syntax/src/Distribution/Types/Benchmark/Lens.hs index db46345f5e6..40b17330fec 100644 --- a/Cabal-syntax/src/Distribution/Types/Benchmark/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/Benchmark/Lens.hs @@ -1,27 +1,27 @@ -module Distribution.Types.Benchmark.Lens ( - Benchmark, - module Distribution.Types.Benchmark.Lens, - ) where +module Distribution.Types.Benchmark.Lens + ( Benchmark + , module Distribution.Types.Benchmark.Lens + ) where import Distribution.Compat.Lens import Distribution.Compat.Prelude import Prelude () -import Distribution.Types.Benchmark (Benchmark) -import Distribution.Types.BenchmarkInterface (BenchmarkInterface) -import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.Benchmark (Benchmark) +import Distribution.Types.BenchmarkInterface (BenchmarkInterface) +import Distribution.Types.BuildInfo (BuildInfo) import Distribution.Types.UnqualComponentName (UnqualComponentName) import qualified Distribution.Types.Benchmark as T benchmarkName :: Lens' Benchmark UnqualComponentName -benchmarkName f s = fmap (\x -> s { T.benchmarkName = x }) (f (T.benchmarkName s)) +benchmarkName f s = fmap (\x -> s{T.benchmarkName = x}) (f (T.benchmarkName s)) {-# INLINE benchmarkName #-} benchmarkInterface :: Lens' Benchmark BenchmarkInterface -benchmarkInterface f s = fmap (\x -> s { T.benchmarkInterface = x }) (f (T.benchmarkInterface s)) +benchmarkInterface f s = fmap (\x -> s{T.benchmarkInterface = x}) (f (T.benchmarkInterface s)) {-# INLINE benchmarkInterface #-} benchmarkBuildInfo :: Lens' Benchmark BuildInfo -benchmarkBuildInfo f s = fmap (\x -> s { T.benchmarkBuildInfo = x }) (f (T.benchmarkBuildInfo s)) +benchmarkBuildInfo f s = fmap (\x -> s{T.benchmarkBuildInfo = x}) (f (T.benchmarkBuildInfo s)) {-# INLINE benchmarkBuildInfo #-} diff --git a/Cabal-syntax/src/Distribution/Types/BenchmarkInterface.hs b/Cabal-syntax/src/Distribution/Types/BenchmarkInterface.hs index d9e741fd7b1..b894e71b791 100644 --- a/Cabal-syntax/src/Distribution/Types/BenchmarkInterface.hs +++ b/Cabal-syntax/src/Distribution/Types/BenchmarkInterface.hs @@ -1,12 +1,12 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.BenchmarkInterface ( - BenchmarkInterface(..), -) where +module Distribution.Types.BenchmarkInterface + ( BenchmarkInterface (..) + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Types.BenchmarkType import Distribution.Version @@ -15,31 +15,26 @@ import Distribution.Version -- -- More interfaces may be defined in future, either new revisions or -- totally new interfaces. --- -data BenchmarkInterface = - - -- | Benchmark interface \"exitcode-stdio-1.0\". The benchmark - -- takes the form of an executable. It returns a zero exit code - -- for success, non-zero for failure. The stdout and stderr - -- channels may be logged. Test tooling may pass command line - -- arguments and/or connect the stdin channel to the test. - -- - BenchmarkExeV10 Version FilePath - - -- | A benchmark that does not conform to one of the above - -- interfaces for the given reason (e.g. unknown benchmark type). - -- - | BenchmarkUnsupported BenchmarkType - deriving (Eq, Ord, Generic, Read, Show, Typeable, Data) +data BenchmarkInterface + = -- | Benchmark interface \"exitcode-stdio-1.0\". The benchmark + -- takes the form of an executable. It returns a zero exit code + -- for success, non-zero for failure. The stdout and stderr + -- channels may be logged. Test tooling may pass command line + -- arguments and/or connect the stdin channel to the test. + BenchmarkExeV10 Version FilePath + | -- | A benchmark that does not conform to one of the above + -- interfaces for the given reason (e.g. unknown benchmark type). + BenchmarkUnsupported BenchmarkType + deriving (Eq, Ord, Generic, Read, Show, Typeable, Data) instance Binary BenchmarkInterface instance Structured BenchmarkInterface instance NFData BenchmarkInterface where rnf = genericRnf instance Monoid BenchmarkInterface where - mempty = BenchmarkUnsupported (BenchmarkTypeUnknown mempty nullVersion) - mappend = (<>) + mempty = BenchmarkUnsupported (BenchmarkTypeUnknown mempty nullVersion) + mappend = (<>) instance Semigroup BenchmarkInterface where - a <> (BenchmarkUnsupported _) = a - _ <> b = b + a <> (BenchmarkUnsupported _) = a + _ <> b = b diff --git a/Cabal-syntax/src/Distribution/Types/BenchmarkType.hs b/Cabal-syntax/src/Distribution/Types/BenchmarkType.hs index c92bd292c0b..9dd3fad3ff9 100644 --- a/Cabal-syntax/src/Distribution/Types/BenchmarkType.hs +++ b/Cabal-syntax/src/Distribution/Types/BenchmarkType.hs @@ -1,12 +1,12 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} -module Distribution.Types.BenchmarkType ( - BenchmarkType(..), - knownBenchmarkTypes, - benchmarkTypeExe, -) where +module Distribution.Types.BenchmarkType + ( BenchmarkType (..) + , knownBenchmarkTypes + , benchmarkTypeExe + ) where import Distribution.Compat.Prelude import Prelude () @@ -14,31 +14,31 @@ import Prelude () import Distribution.Parsec import Distribution.Pretty import Distribution.Version -import Text.PrettyPrint (char, text) +import Text.PrettyPrint (char, text) -- | The \"benchmark-type\" field in the benchmark stanza. --- -data BenchmarkType = BenchmarkTypeExe Version - -- ^ \"type: exitcode-stdio-x.y\" - | BenchmarkTypeUnknown String Version - -- ^ Some unknown benchmark type e.g. \"type: foo\" - deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) +data BenchmarkType + = -- | \"type: exitcode-stdio-x.y\" + BenchmarkTypeExe Version + | -- | Some unknown benchmark type e.g. \"type: foo\" + BenchmarkTypeUnknown String Version + deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) instance Binary BenchmarkType instance Structured BenchmarkType instance NFData BenchmarkType where rnf = genericRnf knownBenchmarkTypes :: [BenchmarkType] -knownBenchmarkTypes = [ benchmarkTypeExe ] +knownBenchmarkTypes = [benchmarkTypeExe] benchmarkTypeExe :: BenchmarkType -benchmarkTypeExe = BenchmarkTypeExe (mkVersion [1,0]) +benchmarkTypeExe = BenchmarkTypeExe (mkVersion [1, 0]) instance Pretty BenchmarkType where - pretty (BenchmarkTypeExe ver) = text "exitcode-stdio-" <<>> pretty ver + pretty (BenchmarkTypeExe ver) = text "exitcode-stdio-" <<>> pretty ver pretty (BenchmarkTypeUnknown name ver) = text name <<>> char '-' <<>> pretty ver instance Parsec BenchmarkType where - parsec = parsecStandard $ \ver name -> case name of - "exitcode-stdio" -> BenchmarkTypeExe ver - _ -> BenchmarkTypeUnknown name ver + parsec = parsecStandard $ \ver name -> case name of + "exitcode-stdio" -> BenchmarkTypeExe ver + _ -> BenchmarkTypeUnknown name ver diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index cef7a374428..67efb90955d 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -1,223 +1,254 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.BuildInfo ( - BuildInfo(..), +module Distribution.Types.BuildInfo + ( BuildInfo (..) + , emptyBuildInfo + , allLanguages + , allExtensions + , usedExtensions + , usesTemplateHaskellOrQQ + , hcOptions + , hcProfOptions + , hcSharedOptions + , hcStaticOptions + ) where - emptyBuildInfo, - allLanguages, - allExtensions, - usedExtensions, - usesTemplateHaskellOrQQ, - - hcOptions, - hcProfOptions, - hcSharedOptions, - hcStaticOptions, -) where - -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.Mixin import Distribution.Types.Dependency import Distribution.Types.ExeDependency import Distribution.Types.LegacyExeDependency +import Distribution.Types.Mixin import Distribution.Types.PkgconfigDependency import Distribution.Utils.Path -import Distribution.ModuleName import Distribution.Compiler +import Distribution.ModuleName import Language.Haskell.Extension -- Consider refactoring into executable and library versions. -data BuildInfo = BuildInfo { - -- | component is buildable here - buildable :: Bool, - -- | Tools needed to build this bit. - -- - -- This is a legacy field that 'buildToolDepends' largely supersedes. - -- - -- Unless use are very sure what you are doing, use the functions in - -- "Distribution.Simple.BuildToolDepends" rather than accessing this - -- field directly. - buildTools :: [LegacyExeDependency], - -- | Haskell tools needed to build this bit - -- - -- This field is better than 'buildTools' because it allows one to - -- precisely specify an executable in a package. - -- - -- Unless use are very sure what you are doing, use the functions in - -- "Distribution.Simple.BuildToolDepends" rather than accessing this - -- field directly. - buildToolDepends :: [ExeDependency], - cppOptions :: [String], -- ^ options for pre-processing Haskell code - asmOptions :: [String], -- ^ options for assembler - cmmOptions :: [String], -- ^ options for C-- compiler - ccOptions :: [String], -- ^ options for C compiler - cxxOptions :: [String], -- ^ options for C++ compiler - ldOptions :: [String], -- ^ options for linker - hsc2hsOptions :: [String], -- ^ options for hsc2hs - pkgconfigDepends :: [PkgconfigDependency], -- ^ pkg-config packages that are used - frameworks :: [String], -- ^support frameworks for Mac OS X - extraFrameworkDirs:: [String], -- ^ extra locations to find frameworks. - asmSources :: [FilePath], -- ^ Assembly files. - cmmSources :: [FilePath], -- ^ C-- files. - cSources :: [FilePath], - cxxSources :: [FilePath], - jsSources :: [FilePath], - hsSourceDirs :: [SymbolicPath PackageDir SourceDir], -- ^ where to look for the Haskell module hierarchy - otherModules :: [ModuleName], -- ^ non-exposed or non-main modules - virtualModules :: [ModuleName], -- ^ exposed modules that do not have a source file (e.g. @GHC.Prim@ from @ghc-prim@ package) - autogenModules :: [ModuleName], -- ^ not present on sdist, Paths_* or user-generated with a custom Setup.hs - - defaultLanguage :: Maybe Language,-- ^ language used when not explicitly specified - otherLanguages :: [Language], -- ^ other languages used within the package - defaultExtensions :: [Extension], -- ^ language extensions used by all modules - otherExtensions :: [Extension], -- ^ other language extensions used within the package - oldExtensions :: [Extension], -- ^ the old extensions field, treated same as 'defaultExtensions' - - extraLibs :: [String], -- ^ what libraries to link with when compiling a program that uses your package - extraLibsStatic :: [String], -- ^ what libraries to link with when compiling a program fully statically that uses your package - extraGHCiLibs :: [String], -- ^ if present, overrides extraLibs when package is loaded with GHCi. - extraBundledLibs :: [String], -- ^ if present, adds libs to hs-libraries, which become part of the package. - -- Example 1: the Cffi library shipping with the rts, alongside the HSrts-1.0.a,.o,... - -- Example 2: a library that is being built by a foreign tool (e.g. rust) - -- and copied and registered together with this library. The - -- logic on how this library is built will have to be encoded in a - -- custom Setup for now. Otherwise cabal would need to learn how to - -- call arbitrary library builders. - extraLibFlavours :: [String], -- ^ Hidden Flag. This set of strings, will be appended to all libraries when - -- copying. E.g. [libHS_ | flavour <- extraLibFlavours]. This - -- should only be needed in very specific cases, e.g. the `rts` package, where - -- there are multiple copies of slightly differently built libs. - extraDynLibFlavours :: [String], -- ^ Hidden Flag. This set of strings will be appended to all /dynamic/ - -- libraries when copying. This is particularly useful with the `rts` package, - -- where we want different dynamic flavours of the RTS library to be installed. - extraLibDirs :: [String], - extraLibDirsStatic :: [String], - includeDirs :: [FilePath], -- ^directories to find .h files - includes :: [FilePath], -- ^ The .h files to be found in includeDirs - autogenIncludes :: [FilePath], -- ^ The .h files to be generated (e.g. by @autoconf@) - installIncludes :: [FilePath], -- ^ .h files to install with the package - options :: PerCompilerFlavor [String], - profOptions :: PerCompilerFlavor [String], - sharedOptions :: PerCompilerFlavor [String], - staticOptions :: PerCompilerFlavor [String], - customFieldsBI :: [(String,String)], -- ^Custom fields starting - -- with x-, stored in a - -- simple assoc-list. - targetBuildDepends :: [Dependency], -- ^ Dependencies specific to a library or executable target - mixins :: [Mixin] - } - deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) +data BuildInfo = BuildInfo + { buildable :: Bool + -- ^ component is buildable here + , buildTools :: [LegacyExeDependency] + -- ^ Tools needed to build this bit. + -- + -- This is a legacy field that 'buildToolDepends' largely supersedes. + -- + -- Unless use are very sure what you are doing, use the functions in + -- "Distribution.Simple.BuildToolDepends" rather than accessing this + -- field directly. + , buildToolDepends :: [ExeDependency] + -- ^ Haskell tools needed to build this bit + -- + -- This field is better than 'buildTools' because it allows one to + -- precisely specify an executable in a package. + -- + -- Unless use are very sure what you are doing, use the functions in + -- "Distribution.Simple.BuildToolDepends" rather than accessing this + -- field directly. + , cppOptions :: [String] + -- ^ options for pre-processing Haskell code + , asmOptions :: [String] + -- ^ options for assembler + , cmmOptions :: [String] + -- ^ options for C-- compiler + , ccOptions :: [String] + -- ^ options for C compiler + , cxxOptions :: [String] + -- ^ options for C++ compiler + , ldOptions :: [String] + -- ^ options for linker + , hsc2hsOptions :: [String] + -- ^ options for hsc2hs + , pkgconfigDepends :: [PkgconfigDependency] + -- ^ pkg-config packages that are used + , frameworks :: [String] + -- ^ support frameworks for Mac OS X + , extraFrameworkDirs :: [String] + -- ^ extra locations to find frameworks. + , asmSources :: [FilePath] + -- ^ Assembly files. + , cmmSources :: [FilePath] + -- ^ C-- files. + , cSources :: [FilePath] + , cxxSources :: [FilePath] + , jsSources :: [FilePath] + , hsSourceDirs :: [SymbolicPath PackageDir SourceDir] + -- ^ where to look for the Haskell module hierarchy + , otherModules :: [ModuleName] + -- ^ non-exposed or non-main modules + , virtualModules :: [ModuleName] + -- ^ exposed modules that do not have a source file (e.g. @GHC.Prim@ from @ghc-prim@ package) + , autogenModules :: [ModuleName] + -- ^ not present on sdist, Paths_* or user-generated with a custom Setup.hs + , defaultLanguage :: Maybe Language + -- ^ language used when not explicitly specified + , otherLanguages :: [Language] + -- ^ other languages used within the package + , defaultExtensions :: [Extension] + -- ^ language extensions used by all modules + , otherExtensions :: [Extension] + -- ^ other language extensions used within the package + , oldExtensions :: [Extension] + -- ^ the old extensions field, treated same as 'defaultExtensions' + , extraLibs :: [String] + -- ^ what libraries to link with when compiling a program that uses your package + , extraLibsStatic :: [String] + -- ^ what libraries to link with when compiling a program fully statically that uses your package + , extraGHCiLibs :: [String] + -- ^ if present, overrides extraLibs when package is loaded with GHCi. + , extraBundledLibs :: [String] + -- ^ if present, adds libs to hs-libraries, which become part of the package. + -- Example 1: the Cffi library shipping with the rts, alongside the HSrts-1.0.a,.o,... + -- Example 2: a library that is being built by a foreign tool (e.g. rust) + -- and copied and registered together with this library. The + -- logic on how this library is built will have to be encoded in a + -- custom Setup for now. Otherwise cabal would need to learn how to + -- call arbitrary library builders. + , extraLibFlavours :: [String] + -- ^ Hidden Flag. This set of strings, will be appended to all libraries when + -- copying. E.g. [libHS_ | flavour <- extraLibFlavours]. This + -- should only be needed in very specific cases, e.g. the `rts` package, where + -- there are multiple copies of slightly differently built libs. + , extraDynLibFlavours :: [String] + -- ^ Hidden Flag. This set of strings will be appended to all /dynamic/ + -- libraries when copying. This is particularly useful with the `rts` package, + -- where we want different dynamic flavours of the RTS library to be installed. + , extraLibDirs :: [String] + , extraLibDirsStatic :: [String] + , includeDirs :: [FilePath] + -- ^ directories to find .h files + , includes :: [FilePath] + -- ^ The .h files to be found in includeDirs + , autogenIncludes :: [FilePath] + -- ^ The .h files to be generated (e.g. by @autoconf@) + , installIncludes :: [FilePath] + -- ^ .h files to install with the package + , options :: PerCompilerFlavor [String] + , profOptions :: PerCompilerFlavor [String] + , sharedOptions :: PerCompilerFlavor [String] + , staticOptions :: PerCompilerFlavor [String] + , customFieldsBI :: [(String, String)] + -- ^ Custom fields starting + -- with x-, stored in a + -- simple assoc-list. + , targetBuildDepends :: [Dependency] + -- ^ Dependencies specific to a library or executable target + , mixins :: [Mixin] + } + deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) instance Binary BuildInfo instance Structured BuildInfo instance NFData BuildInfo where rnf = genericRnf instance Monoid BuildInfo where - mempty = BuildInfo { - buildable = True, - buildTools = [], - buildToolDepends = [], - cppOptions = [], - asmOptions = [], - cmmOptions = [], - ccOptions = [], - cxxOptions = [], - ldOptions = [], - hsc2hsOptions = [], - pkgconfigDepends = [], - frameworks = [], - extraFrameworkDirs = [], - asmSources = [], - cmmSources = [], - cSources = [], - cxxSources = [], - jsSources = [], - hsSourceDirs = [], - otherModules = [], - virtualModules = [], - autogenModules = [], - defaultLanguage = Nothing, - otherLanguages = [], - defaultExtensions = [], - otherExtensions = [], - oldExtensions = [], - extraLibs = [], - extraLibsStatic = [], - extraGHCiLibs = [], - extraBundledLibs = [], - extraLibFlavours = [], - extraDynLibFlavours = [], - extraLibDirs = [], - extraLibDirsStatic = [], - includeDirs = [], - includes = [], - autogenIncludes = [], - installIncludes = [], - options = mempty, - profOptions = mempty, - sharedOptions = mempty, - staticOptions = mempty, - customFieldsBI = [], - targetBuildDepends = [], - mixins = [] - } + mempty = + BuildInfo + { buildable = True + , buildTools = [] + , buildToolDepends = [] + , cppOptions = [] + , asmOptions = [] + , cmmOptions = [] + , ccOptions = [] + , cxxOptions = [] + , ldOptions = [] + , hsc2hsOptions = [] + , pkgconfigDepends = [] + , frameworks = [] + , extraFrameworkDirs = [] + , asmSources = [] + , cmmSources = [] + , cSources = [] + , cxxSources = [] + , jsSources = [] + , hsSourceDirs = [] + , otherModules = [] + , virtualModules = [] + , autogenModules = [] + , defaultLanguage = Nothing + , otherLanguages = [] + , defaultExtensions = [] + , otherExtensions = [] + , oldExtensions = [] + , extraLibs = [] + , extraLibsStatic = [] + , extraGHCiLibs = [] + , extraBundledLibs = [] + , extraLibFlavours = [] + , extraDynLibFlavours = [] + , extraLibDirs = [] + , extraLibDirsStatic = [] + , includeDirs = [] + , includes = [] + , autogenIncludes = [] + , installIncludes = [] + , options = mempty + , profOptions = mempty + , sharedOptions = mempty + , staticOptions = mempty + , customFieldsBI = [] + , targetBuildDepends = [] + , mixins = [] + } mappend = (<>) instance Semigroup BuildInfo where - a <> b = BuildInfo { - buildable = buildable a && buildable b, - buildTools = combine buildTools, - buildToolDepends = combine buildToolDepends, - cppOptions = combine cppOptions, - asmOptions = combine asmOptions, - cmmOptions = combine cmmOptions, - ccOptions = combine ccOptions, - cxxOptions = combine cxxOptions, - ldOptions = combine ldOptions, - hsc2hsOptions = combine hsc2hsOptions, - pkgconfigDepends = combine pkgconfigDepends, - frameworks = combineNub frameworks, - extraFrameworkDirs = combineNub extraFrameworkDirs, - asmSources = combineNub asmSources, - cmmSources = combineNub cmmSources, - cSources = combineNub cSources, - cxxSources = combineNub cxxSources, - jsSources = combineNub jsSources, - hsSourceDirs = combineNub hsSourceDirs, - otherModules = combineNub otherModules, - virtualModules = combineNub virtualModules, - autogenModules = combineNub autogenModules, - defaultLanguage = combineMby defaultLanguage, - otherLanguages = combineNub otherLanguages, - defaultExtensions = combineNub defaultExtensions, - otherExtensions = combineNub otherExtensions, - oldExtensions = combineNub oldExtensions, - extraLibs = combine extraLibs, - extraLibsStatic = combine extraLibsStatic, - extraGHCiLibs = combine extraGHCiLibs, - extraBundledLibs = combine extraBundledLibs, - extraLibFlavours = combine extraLibFlavours, - extraDynLibFlavours = combine extraDynLibFlavours, - extraLibDirs = combineNub extraLibDirs, - extraLibDirsStatic = combineNub extraLibDirsStatic, - includeDirs = combineNub includeDirs, - includes = combineNub includes, - autogenIncludes = combineNub autogenIncludes, - installIncludes = combineNub installIncludes, - options = combine options, - profOptions = combine profOptions, - sharedOptions = combine sharedOptions, - staticOptions = combine staticOptions, - customFieldsBI = combine customFieldsBI, - targetBuildDepends = combineNub targetBuildDepends, - mixins = combine mixins - } + a <> b = + BuildInfo + { buildable = buildable a && buildable b + , buildTools = combine buildTools + , buildToolDepends = combine buildToolDepends + , cppOptions = combine cppOptions + , asmOptions = combine asmOptions + , cmmOptions = combine cmmOptions + , ccOptions = combine ccOptions + , cxxOptions = combine cxxOptions + , ldOptions = combine ldOptions + , hsc2hsOptions = combine hsc2hsOptions + , pkgconfigDepends = combine pkgconfigDepends + , frameworks = combineNub frameworks + , extraFrameworkDirs = combineNub extraFrameworkDirs + , asmSources = combineNub asmSources + , cmmSources = combineNub cmmSources + , cSources = combineNub cSources + , cxxSources = combineNub cxxSources + , jsSources = combineNub jsSources + , hsSourceDirs = combineNub hsSourceDirs + , otherModules = combineNub otherModules + , virtualModules = combineNub virtualModules + , autogenModules = combineNub autogenModules + , defaultLanguage = combineMby defaultLanguage + , otherLanguages = combineNub otherLanguages + , defaultExtensions = combineNub defaultExtensions + , otherExtensions = combineNub otherExtensions + , oldExtensions = combineNub oldExtensions + , extraLibs = combine extraLibs + , extraLibsStatic = combine extraLibsStatic + , extraGHCiLibs = combine extraGHCiLibs + , extraBundledLibs = combine extraBundledLibs + , extraLibFlavours = combine extraLibFlavours + , extraDynLibFlavours = combine extraDynLibFlavours + , extraLibDirs = combineNub extraLibDirs + , extraLibDirsStatic = combineNub extraLibDirsStatic + , includeDirs = combineNub includeDirs + , includes = combineNub includes + , autogenIncludes = combineNub autogenIncludes + , installIncludes = combineNub installIncludes + , options = combine options + , profOptions = combine profOptions + , sharedOptions = combine sharedOptions + , staticOptions = combine staticOptions + , customFieldsBI = combine customFieldsBI + , targetBuildDepends = combineNub targetBuildDepends + , mixins = combine mixins + } where - combine field = field a `mappend` field b + combine field = field a `mappend` field b combineNub field = nub (combine field) combineMby field = field b `mplus` field a @@ -225,32 +256,33 @@ emptyBuildInfo :: BuildInfo emptyBuildInfo = mempty -- | The 'Language's used by this component --- allLanguages :: BuildInfo -> [Language] -allLanguages bi = maybeToList (defaultLanguage bi) - ++ otherLanguages bi +allLanguages bi = + maybeToList (defaultLanguage bi) + ++ otherLanguages bi -- | The 'Extension's that are used somewhere by this component --- allExtensions :: BuildInfo -> [Extension] -allExtensions bi = usedExtensions bi - ++ otherExtensions bi +allExtensions bi = + usedExtensions bi + ++ otherExtensions bi -- | The 'Extensions' that are used by all modules in this component --- usedExtensions :: BuildInfo -> [Extension] -usedExtensions bi = oldExtensions bi - ++ defaultExtensions bi +usedExtensions bi = + oldExtensions bi + ++ defaultExtensions bi -- | Whether any modules in this component use Template Haskell or -- Quasi Quotes usesTemplateHaskellOrQQ :: BuildInfo -> Bool usesTemplateHaskellOrQQ bi = any p (allExtensions bi) where - p ex = ex `elem` - [EnableExtension TemplateHaskell, EnableExtension QuasiQuotes] + p ex = + ex + `elem` [EnableExtension TemplateHaskell, EnableExtension QuasiQuotes] --- |Select options for a particular Haskell compiler. +-- | Select options for a particular Haskell compiler. hcOptions :: CompilerFlavor -> BuildInfo -> [String] hcOptions = lookupHcOptions options @@ -263,10 +295,13 @@ hcSharedOptions = lookupHcOptions sharedOptions hcStaticOptions :: CompilerFlavor -> BuildInfo -> [String] hcStaticOptions = lookupHcOptions staticOptions -lookupHcOptions :: (BuildInfo -> PerCompilerFlavor [String]) - -> CompilerFlavor -> BuildInfo -> [String] +lookupHcOptions + :: (BuildInfo -> PerCompilerFlavor [String]) + -> CompilerFlavor + -> BuildInfo + -> [String] lookupHcOptions f hc bi = case f bi of - PerCompilerFlavor ghc ghcjs - | hc == GHC -> ghc - | hc == GHCJS -> ghcjs - | otherwise -> mempty + PerCompilerFlavor ghc ghcjs + | hc == GHC -> ghc + | hc == GHCJS -> ghcjs + | otherwise -> mempty diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index b3d558a9412..63cfba526ab 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -1,356 +1,355 @@ -module Distribution.Types.BuildInfo.Lens ( - BuildInfo, - HasBuildInfo (..), - HasBuildInfos (..), - ) where +module Distribution.Types.BuildInfo.Lens + ( BuildInfo + , HasBuildInfo (..) + , HasBuildInfos (..) + ) where import Distribution.Compat.Lens import Distribution.Compat.Prelude import Prelude () -import Distribution.Compiler (PerCompilerFlavor) -import Distribution.ModuleName (ModuleName) -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.Dependency (Dependency) -import Distribution.Types.ExeDependency (ExeDependency) +import Distribution.Compiler (PerCompilerFlavor) +import Distribution.ModuleName (ModuleName) +import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.Dependency (Dependency) +import Distribution.Types.ExeDependency (ExeDependency) import Distribution.Types.LegacyExeDependency (LegacyExeDependency) -import Distribution.Types.Mixin (Mixin) +import Distribution.Types.Mixin (Mixin) import Distribution.Types.PkgconfigDependency (PkgconfigDependency) import Distribution.Utils.Path -import Language.Haskell.Extension (Extension, Language) +import Language.Haskell.Extension (Extension, Language) import qualified Distribution.Types.BuildInfo as T -- | Classy lenses for 'BuildInfo'. class HasBuildInfo a where - buildInfo :: Lens' a BuildInfo + buildInfo :: Lens' a BuildInfo - buildable :: Lens' a Bool - buildable = buildInfo . buildable - {-# INLINE buildable #-} + buildable :: Lens' a Bool + buildable = buildInfo . buildable + {-# INLINE buildable #-} - buildTools :: Lens' a [LegacyExeDependency] - buildTools = buildInfo . buildTools - {-# INLINE buildTools #-} + buildTools :: Lens' a [LegacyExeDependency] + buildTools = buildInfo . buildTools + {-# INLINE buildTools #-} - buildToolDepends :: Lens' a [ExeDependency] - buildToolDepends = buildInfo . buildToolDepends - {-# INLINE buildToolDepends #-} + buildToolDepends :: Lens' a [ExeDependency] + buildToolDepends = buildInfo . buildToolDepends + {-# INLINE buildToolDepends #-} - cppOptions :: Lens' a [String] - cppOptions = buildInfo . cppOptions - {-# INLINE cppOptions #-} + cppOptions :: Lens' a [String] + cppOptions = buildInfo . cppOptions + {-# INLINE cppOptions #-} - asmOptions :: Lens' a [String] - asmOptions = buildInfo . asmOptions - {-# INLINE asmOptions #-} + asmOptions :: Lens' a [String] + asmOptions = buildInfo . asmOptions + {-# INLINE asmOptions #-} - cmmOptions :: Lens' a [String] - cmmOptions = buildInfo . cmmOptions - {-# INLINE cmmOptions #-} + cmmOptions :: Lens' a [String] + cmmOptions = buildInfo . cmmOptions + {-# INLINE cmmOptions #-} - ccOptions :: Lens' a [String] - ccOptions = buildInfo . ccOptions - {-# INLINE ccOptions #-} + ccOptions :: Lens' a [String] + ccOptions = buildInfo . ccOptions + {-# INLINE ccOptions #-} - cxxOptions :: Lens' a [String] - cxxOptions = buildInfo . cxxOptions - {-# INLINE cxxOptions #-} + cxxOptions :: Lens' a [String] + cxxOptions = buildInfo . cxxOptions + {-# INLINE cxxOptions #-} - ldOptions :: Lens' a [String] - ldOptions = buildInfo . ldOptions - {-# INLINE ldOptions #-} + ldOptions :: Lens' a [String] + ldOptions = buildInfo . ldOptions + {-# INLINE ldOptions #-} - hsc2hsOptions :: Lens' a [String] - hsc2hsOptions = buildInfo . hsc2hsOptions - {-# INLINE hsc2hsOptions #-} + hsc2hsOptions :: Lens' a [String] + hsc2hsOptions = buildInfo . hsc2hsOptions + {-# INLINE hsc2hsOptions #-} - pkgconfigDepends :: Lens' a [PkgconfigDependency] - pkgconfigDepends = buildInfo . pkgconfigDepends - {-# INLINE pkgconfigDepends #-} + pkgconfigDepends :: Lens' a [PkgconfigDependency] + pkgconfigDepends = buildInfo . pkgconfigDepends + {-# INLINE pkgconfigDepends #-} - frameworks :: Lens' a [String] - frameworks = buildInfo . frameworks - {-# INLINE frameworks #-} + frameworks :: Lens' a [String] + frameworks = buildInfo . frameworks + {-# INLINE frameworks #-} - extraFrameworkDirs :: Lens' a [String] - extraFrameworkDirs = buildInfo . extraFrameworkDirs - {-# INLINE extraFrameworkDirs #-} + extraFrameworkDirs :: Lens' a [String] + extraFrameworkDirs = buildInfo . extraFrameworkDirs + {-# INLINE extraFrameworkDirs #-} - asmSources :: Lens' a [FilePath] - asmSources = buildInfo . asmSources - {-# INLINE asmSources #-} + asmSources :: Lens' a [FilePath] + asmSources = buildInfo . asmSources + {-# INLINE asmSources #-} - cmmSources :: Lens' a [FilePath] - cmmSources = buildInfo . cmmSources - {-# INLINE cmmSources #-} + cmmSources :: Lens' a [FilePath] + cmmSources = buildInfo . cmmSources + {-# INLINE cmmSources #-} - cSources :: Lens' a [FilePath] - cSources = buildInfo . cSources - {-# INLINE cSources #-} + cSources :: Lens' a [FilePath] + cSources = buildInfo . cSources + {-# INLINE cSources #-} - cxxSources :: Lens' a [FilePath] - cxxSources = buildInfo . cxxSources - {-# INLINE cxxSources #-} + cxxSources :: Lens' a [FilePath] + cxxSources = buildInfo . cxxSources + {-# INLINE cxxSources #-} - jsSources :: Lens' a [FilePath] - jsSources = buildInfo . jsSources - {-# INLINE jsSources #-} + jsSources :: Lens' a [FilePath] + jsSources = buildInfo . jsSources + {-# INLINE jsSources #-} - hsSourceDirs :: Lens' a [SymbolicPath PackageDir SourceDir] - hsSourceDirs = buildInfo . hsSourceDirs - {-# INLINE hsSourceDirs #-} + hsSourceDirs :: Lens' a [SymbolicPath PackageDir SourceDir] + hsSourceDirs = buildInfo . hsSourceDirs + {-# INLINE hsSourceDirs #-} - otherModules :: Lens' a [ModuleName] - otherModules = buildInfo . otherModules - {-# INLINE otherModules #-} + otherModules :: Lens' a [ModuleName] + otherModules = buildInfo . otherModules + {-# INLINE otherModules #-} - virtualModules :: Lens' a [ModuleName] - virtualModules = buildInfo . virtualModules - {-# INLINE virtualModules #-} + virtualModules :: Lens' a [ModuleName] + virtualModules = buildInfo . virtualModules + {-# INLINE virtualModules #-} - autogenModules :: Lens' a [ModuleName] - autogenModules = buildInfo . autogenModules - {-# INLINE autogenModules #-} + autogenModules :: Lens' a [ModuleName] + autogenModules = buildInfo . autogenModules + {-# INLINE autogenModules #-} - defaultLanguage :: Lens' a (Maybe Language) - defaultLanguage = buildInfo . defaultLanguage - {-# INLINE defaultLanguage #-} + defaultLanguage :: Lens' a (Maybe Language) + defaultLanguage = buildInfo . defaultLanguage + {-# INLINE defaultLanguage #-} - otherLanguages :: Lens' a [Language] - otherLanguages = buildInfo . otherLanguages - {-# INLINE otherLanguages #-} + otherLanguages :: Lens' a [Language] + otherLanguages = buildInfo . otherLanguages + {-# INLINE otherLanguages #-} - defaultExtensions :: Lens' a [Extension] - defaultExtensions = buildInfo . defaultExtensions - {-# INLINE defaultExtensions #-} + defaultExtensions :: Lens' a [Extension] + defaultExtensions = buildInfo . defaultExtensions + {-# INLINE defaultExtensions #-} - otherExtensions :: Lens' a [Extension] - otherExtensions = buildInfo . otherExtensions - {-# INLINE otherExtensions #-} + otherExtensions :: Lens' a [Extension] + otherExtensions = buildInfo . otherExtensions + {-# INLINE otherExtensions #-} - oldExtensions :: Lens' a [Extension] - oldExtensions = buildInfo . oldExtensions - {-# INLINE oldExtensions #-} + oldExtensions :: Lens' a [Extension] + oldExtensions = buildInfo . oldExtensions + {-# INLINE oldExtensions #-} - extraLibs :: Lens' a [String] - extraLibs = buildInfo . extraLibs - {-# INLINE extraLibs #-} + extraLibs :: Lens' a [String] + extraLibs = buildInfo . extraLibs + {-# INLINE extraLibs #-} - extraLibsStatic :: Lens' a [String] - extraLibsStatic = buildInfo . extraLibsStatic - {-# INLINE extraLibsStatic #-} + extraLibsStatic :: Lens' a [String] + extraLibsStatic = buildInfo . extraLibsStatic + {-# INLINE extraLibsStatic #-} - extraGHCiLibs :: Lens' a [String] - extraGHCiLibs = buildInfo . extraGHCiLibs - {-# INLINE extraGHCiLibs #-} + extraGHCiLibs :: Lens' a [String] + extraGHCiLibs = buildInfo . extraGHCiLibs + {-# INLINE extraGHCiLibs #-} - extraBundledLibs :: Lens' a [String] - extraBundledLibs = buildInfo . extraBundledLibs - {-# INLINE extraBundledLibs #-} + extraBundledLibs :: Lens' a [String] + extraBundledLibs = buildInfo . extraBundledLibs + {-# INLINE extraBundledLibs #-} - extraLibFlavours :: Lens' a [String] - extraLibFlavours = buildInfo . extraLibFlavours - {-# INLINE extraLibFlavours #-} + extraLibFlavours :: Lens' a [String] + extraLibFlavours = buildInfo . extraLibFlavours + {-# INLINE extraLibFlavours #-} - extraDynLibFlavours :: Lens' a [String] - extraDynLibFlavours = buildInfo . extraDynLibFlavours - {-# INLINE extraDynLibFlavours #-} + extraDynLibFlavours :: Lens' a [String] + extraDynLibFlavours = buildInfo . extraDynLibFlavours + {-# INLINE extraDynLibFlavours #-} - extraLibDirs :: Lens' a [String] - extraLibDirs = buildInfo . extraLibDirs - {-# INLINE extraLibDirs #-} + extraLibDirs :: Lens' a [String] + extraLibDirs = buildInfo . extraLibDirs + {-# INLINE extraLibDirs #-} - extraLibDirsStatic :: Lens' a [String] - extraLibDirsStatic = buildInfo . extraLibDirsStatic - {-# INLINE extraLibDirsStatic #-} + extraLibDirsStatic :: Lens' a [String] + extraLibDirsStatic = buildInfo . extraLibDirsStatic + {-# INLINE extraLibDirsStatic #-} - includeDirs :: Lens' a [FilePath] - includeDirs = buildInfo . includeDirs - {-# INLINE includeDirs #-} + includeDirs :: Lens' a [FilePath] + includeDirs = buildInfo . includeDirs + {-# INLINE includeDirs #-} - includes :: Lens' a [FilePath] - includes = buildInfo . includes - {-# INLINE includes #-} + includes :: Lens' a [FilePath] + includes = buildInfo . includes + {-# INLINE includes #-} - autogenIncludes :: Lens' a [FilePath] - autogenIncludes = buildInfo . autogenIncludes - {-# INLINE autogenIncludes #-} + autogenIncludes :: Lens' a [FilePath] + autogenIncludes = buildInfo . autogenIncludes + {-# INLINE autogenIncludes #-} - installIncludes :: Lens' a [FilePath] - installIncludes = buildInfo . installIncludes - {-# INLINE installIncludes #-} + installIncludes :: Lens' a [FilePath] + installIncludes = buildInfo . installIncludes + {-# INLINE installIncludes #-} - options :: Lens' a (PerCompilerFlavor [String]) - options = buildInfo . options - {-# INLINE options #-} + options :: Lens' a (PerCompilerFlavor [String]) + options = buildInfo . options + {-# INLINE options #-} - profOptions :: Lens' a (PerCompilerFlavor [String]) - profOptions = buildInfo . profOptions - {-# INLINE profOptions #-} + profOptions :: Lens' a (PerCompilerFlavor [String]) + profOptions = buildInfo . profOptions + {-# INLINE profOptions #-} - sharedOptions :: Lens' a (PerCompilerFlavor [String]) - sharedOptions = buildInfo . sharedOptions - {-# INLINE sharedOptions #-} + sharedOptions :: Lens' a (PerCompilerFlavor [String]) + sharedOptions = buildInfo . sharedOptions + {-# INLINE sharedOptions #-} - staticOptions :: Lens' a (PerCompilerFlavor [String]) - staticOptions = buildInfo . staticOptions - {-# INLINE staticOptions #-} + staticOptions :: Lens' a (PerCompilerFlavor [String]) + staticOptions = buildInfo . staticOptions + {-# INLINE staticOptions #-} - customFieldsBI :: Lens' a [(String,String)] - customFieldsBI = buildInfo . customFieldsBI - {-# INLINE customFieldsBI #-} + customFieldsBI :: Lens' a [(String, String)] + customFieldsBI = buildInfo . customFieldsBI + {-# INLINE customFieldsBI #-} - targetBuildDepends :: Lens' a [Dependency] - targetBuildDepends = buildInfo . targetBuildDepends - {-# INLINE targetBuildDepends #-} - - mixins :: Lens' a [Mixin] - mixins = buildInfo . mixins - {-# INLINE mixins #-} + targetBuildDepends :: Lens' a [Dependency] + targetBuildDepends = buildInfo . targetBuildDepends + {-# INLINE targetBuildDepends #-} + mixins :: Lens' a [Mixin] + mixins = buildInfo . mixins + {-# INLINE mixins #-} instance HasBuildInfo BuildInfo where - buildInfo = id - {-# INLINE buildInfo #-} + buildInfo = id + {-# INLINE buildInfo #-} - buildable f s = fmap (\x -> s { T.buildable = x }) (f (T.buildable s)) - {-# INLINE buildable #-} + buildable f s = fmap (\x -> s{T.buildable = x}) (f (T.buildable s)) + {-# INLINE buildable #-} - buildTools f s = fmap (\x -> s { T.buildTools = x }) (f (T.buildTools s)) - {-# INLINE buildTools #-} + buildTools f s = fmap (\x -> s{T.buildTools = x}) (f (T.buildTools s)) + {-# INLINE buildTools #-} - buildToolDepends f s = fmap (\x -> s { T.buildToolDepends = x }) (f (T.buildToolDepends s)) - {-# INLINE buildToolDepends #-} + buildToolDepends f s = fmap (\x -> s{T.buildToolDepends = x}) (f (T.buildToolDepends s)) + {-# INLINE buildToolDepends #-} - cppOptions f s = fmap (\x -> s { T.cppOptions = x }) (f (T.cppOptions s)) - {-# INLINE cppOptions #-} + cppOptions f s = fmap (\x -> s{T.cppOptions = x}) (f (T.cppOptions s)) + {-# INLINE cppOptions #-} - asmOptions f s = fmap (\x -> s { T.asmOptions = x }) (f (T.asmOptions s)) - {-# INLINE asmOptions #-} + asmOptions f s = fmap (\x -> s{T.asmOptions = x}) (f (T.asmOptions s)) + {-# INLINE asmOptions #-} - cmmOptions f s = fmap (\x -> s { T.cmmOptions = x }) (f (T.cmmOptions s)) - {-# INLINE cmmOptions #-} + cmmOptions f s = fmap (\x -> s{T.cmmOptions = x}) (f (T.cmmOptions s)) + {-# INLINE cmmOptions #-} - ccOptions f s = fmap (\x -> s { T.ccOptions = x }) (f (T.ccOptions s)) - {-# INLINE ccOptions #-} + ccOptions f s = fmap (\x -> s{T.ccOptions = x}) (f (T.ccOptions s)) + {-# INLINE ccOptions #-} - cxxOptions f s = fmap (\x -> s { T.cxxOptions = x }) (f (T.cxxOptions s)) - {-# INLINE cxxOptions #-} + cxxOptions f s = fmap (\x -> s{T.cxxOptions = x}) (f (T.cxxOptions s)) + {-# INLINE cxxOptions #-} - ldOptions f s = fmap (\x -> s { T.ldOptions = x }) (f (T.ldOptions s)) - {-# INLINE ldOptions #-} + ldOptions f s = fmap (\x -> s{T.ldOptions = x}) (f (T.ldOptions s)) + {-# INLINE ldOptions #-} - hsc2hsOptions f s = fmap (\x -> s { T.hsc2hsOptions = x }) (f (T.hsc2hsOptions s)) - {-# INLINE hsc2hsOptions #-} + hsc2hsOptions f s = fmap (\x -> s{T.hsc2hsOptions = x}) (f (T.hsc2hsOptions s)) + {-# INLINE hsc2hsOptions #-} - pkgconfigDepends f s = fmap (\x -> s { T.pkgconfigDepends = x }) (f (T.pkgconfigDepends s)) - {-# INLINE pkgconfigDepends #-} + pkgconfigDepends f s = fmap (\x -> s{T.pkgconfigDepends = x}) (f (T.pkgconfigDepends s)) + {-# INLINE pkgconfigDepends #-} - frameworks f s = fmap (\x -> s { T.frameworks = x }) (f (T.frameworks s)) - {-# INLINE frameworks #-} + frameworks f s = fmap (\x -> s{T.frameworks = x}) (f (T.frameworks s)) + {-# INLINE frameworks #-} - extraFrameworkDirs f s = fmap (\x -> s { T.extraFrameworkDirs = x }) (f (T.extraFrameworkDirs s)) - {-# INLINE extraFrameworkDirs #-} + extraFrameworkDirs f s = fmap (\x -> s{T.extraFrameworkDirs = x}) (f (T.extraFrameworkDirs s)) + {-# INLINE extraFrameworkDirs #-} - asmSources f s = fmap (\x -> s { T.asmSources = x }) (f (T.asmSources s)) - {-# INLINE asmSources #-} + asmSources f s = fmap (\x -> s{T.asmSources = x}) (f (T.asmSources s)) + {-# INLINE asmSources #-} - cmmSources f s = fmap (\x -> s { T.cmmSources = x }) (f (T.cmmSources s)) - {-# INLINE cmmSources #-} + cmmSources f s = fmap (\x -> s{T.cmmSources = x}) (f (T.cmmSources s)) + {-# INLINE cmmSources #-} - cSources f s = fmap (\x -> s { T.cSources = x }) (f (T.cSources s)) - {-# INLINE cSources #-} + cSources f s = fmap (\x -> s{T.cSources = x}) (f (T.cSources s)) + {-# INLINE cSources #-} - cxxSources f s = fmap (\x -> s { T.cSources = x }) (f (T.cxxSources s)) - {-# INLINE cxxSources #-} + cxxSources f s = fmap (\x -> s{T.cSources = x}) (f (T.cxxSources s)) + {-# INLINE cxxSources #-} - jsSources f s = fmap (\x -> s { T.jsSources = x }) (f (T.jsSources s)) - {-# INLINE jsSources #-} + jsSources f s = fmap (\x -> s{T.jsSources = x}) (f (T.jsSources s)) + {-# INLINE jsSources #-} - hsSourceDirs f s = fmap (\x -> s { T.hsSourceDirs = x }) (f (T.hsSourceDirs s)) - {-# INLINE hsSourceDirs #-} + hsSourceDirs f s = fmap (\x -> s{T.hsSourceDirs = x}) (f (T.hsSourceDirs s)) + {-# INLINE hsSourceDirs #-} - otherModules f s = fmap (\x -> s { T.otherModules = x }) (f (T.otherModules s)) - {-# INLINE otherModules #-} + otherModules f s = fmap (\x -> s{T.otherModules = x}) (f (T.otherModules s)) + {-# INLINE otherModules #-} - virtualModules f s = fmap (\x -> s { T.virtualModules = x }) (f (T.virtualModules s)) - {-# INLINE virtualModules #-} + virtualModules f s = fmap (\x -> s{T.virtualModules = x}) (f (T.virtualModules s)) + {-# INLINE virtualModules #-} - autogenModules f s = fmap (\x -> s { T.autogenModules = x }) (f (T.autogenModules s)) - {-# INLINE autogenModules #-} + autogenModules f s = fmap (\x -> s{T.autogenModules = x}) (f (T.autogenModules s)) + {-# INLINE autogenModules #-} - defaultLanguage f s = fmap (\x -> s { T.defaultLanguage = x }) (f (T.defaultLanguage s)) - {-# INLINE defaultLanguage #-} + defaultLanguage f s = fmap (\x -> s{T.defaultLanguage = x}) (f (T.defaultLanguage s)) + {-# INLINE defaultLanguage #-} - otherLanguages f s = fmap (\x -> s { T.otherLanguages = x }) (f (T.otherLanguages s)) - {-# INLINE otherLanguages #-} + otherLanguages f s = fmap (\x -> s{T.otherLanguages = x}) (f (T.otherLanguages s)) + {-# INLINE otherLanguages #-} - defaultExtensions f s = fmap (\x -> s { T.defaultExtensions = x }) (f (T.defaultExtensions s)) - {-# INLINE defaultExtensions #-} + defaultExtensions f s = fmap (\x -> s{T.defaultExtensions = x}) (f (T.defaultExtensions s)) + {-# INLINE defaultExtensions #-} - otherExtensions f s = fmap (\x -> s { T.otherExtensions = x }) (f (T.otherExtensions s)) - {-# INLINE otherExtensions #-} + otherExtensions f s = fmap (\x -> s{T.otherExtensions = x}) (f (T.otherExtensions s)) + {-# INLINE otherExtensions #-} - oldExtensions f s = fmap (\x -> s { T.oldExtensions = x }) (f (T.oldExtensions s)) - {-# INLINE oldExtensions #-} + oldExtensions f s = fmap (\x -> s{T.oldExtensions = x}) (f (T.oldExtensions s)) + {-# INLINE oldExtensions #-} - extraLibs f s = fmap (\x -> s { T.extraLibs = x }) (f (T.extraLibs s)) - {-# INLINE extraLibs #-} + extraLibs f s = fmap (\x -> s{T.extraLibs = x}) (f (T.extraLibs s)) + {-# INLINE extraLibs #-} - extraLibsStatic f s = fmap (\x -> s { T.extraLibsStatic = x}) (f (T.extraLibsStatic s)) - {-# INLINE extraLibsStatic #-} + extraLibsStatic f s = fmap (\x -> s{T.extraLibsStatic = x}) (f (T.extraLibsStatic s)) + {-# INLINE extraLibsStatic #-} - extraGHCiLibs f s = fmap (\x -> s { T.extraGHCiLibs = x }) (f (T.extraGHCiLibs s)) - {-# INLINE extraGHCiLibs #-} + extraGHCiLibs f s = fmap (\x -> s{T.extraGHCiLibs = x}) (f (T.extraGHCiLibs s)) + {-# INLINE extraGHCiLibs #-} - extraBundledLibs f s = fmap (\x -> s { T.extraBundledLibs = x }) (f (T.extraBundledLibs s)) - {-# INLINE extraBundledLibs #-} + extraBundledLibs f s = fmap (\x -> s{T.extraBundledLibs = x}) (f (T.extraBundledLibs s)) + {-# INLINE extraBundledLibs #-} - extraLibFlavours f s = fmap (\x -> s { T.extraLibFlavours = x }) (f (T.extraLibFlavours s)) - {-# INLINE extraLibFlavours #-} + extraLibFlavours f s = fmap (\x -> s{T.extraLibFlavours = x}) (f (T.extraLibFlavours s)) + {-# INLINE extraLibFlavours #-} - extraDynLibFlavours f s = fmap (\x -> s { T.extraDynLibFlavours = x}) (f (T.extraDynLibFlavours s)) - {-# INLINE extraDynLibFlavours #-} + extraDynLibFlavours f s = fmap (\x -> s{T.extraDynLibFlavours = x}) (f (T.extraDynLibFlavours s)) + {-# INLINE extraDynLibFlavours #-} - extraLibDirs f s = fmap (\x -> s { T.extraLibDirs = x }) (f (T.extraLibDirs s)) - {-# INLINE extraLibDirs #-} + extraLibDirs f s = fmap (\x -> s{T.extraLibDirs = x}) (f (T.extraLibDirs s)) + {-# INLINE extraLibDirs #-} - extraLibDirsStatic f s = fmap (\x -> s { T.extraLibDirsStatic = x}) (f (T.extraLibDirsStatic s)) - {-# INLINE extraLibDirsStatic #-} + extraLibDirsStatic f s = fmap (\x -> s{T.extraLibDirsStatic = x}) (f (T.extraLibDirsStatic s)) + {-# INLINE extraLibDirsStatic #-} - includeDirs f s = fmap (\x -> s { T.includeDirs = x }) (f (T.includeDirs s)) - {-# INLINE includeDirs #-} + includeDirs f s = fmap (\x -> s{T.includeDirs = x}) (f (T.includeDirs s)) + {-# INLINE includeDirs #-} - includes f s = fmap (\x -> s { T.includes = x }) (f (T.includes s)) - {-# INLINE includes #-} + includes f s = fmap (\x -> s{T.includes = x}) (f (T.includes s)) + {-# INLINE includes #-} - autogenIncludes f s = fmap (\x -> s { T.autogenIncludes = x }) (f (T.autogenIncludes s)) - {-# INLINE autogenIncludes #-} + autogenIncludes f s = fmap (\x -> s{T.autogenIncludes = x}) (f (T.autogenIncludes s)) + {-# INLINE autogenIncludes #-} - installIncludes f s = fmap (\x -> s { T.installIncludes = x }) (f (T.installIncludes s)) - {-# INLINE installIncludes #-} + installIncludes f s = fmap (\x -> s{T.installIncludes = x}) (f (T.installIncludes s)) + {-# INLINE installIncludes #-} - options f s = fmap (\x -> s { T.options = x }) (f (T.options s)) - {-# INLINE options #-} + options f s = fmap (\x -> s{T.options = x}) (f (T.options s)) + {-# INLINE options #-} - profOptions f s = fmap (\x -> s { T.profOptions = x }) (f (T.profOptions s)) - {-# INLINE profOptions #-} + profOptions f s = fmap (\x -> s{T.profOptions = x}) (f (T.profOptions s)) + {-# INLINE profOptions #-} - sharedOptions f s = fmap (\x -> s { T.sharedOptions = x }) (f (T.sharedOptions s)) - {-# INLINE sharedOptions #-} + sharedOptions f s = fmap (\x -> s{T.sharedOptions = x}) (f (T.sharedOptions s)) + {-# INLINE sharedOptions #-} - staticOptions f s = fmap (\x -> s { T.staticOptions = x }) (f (T.staticOptions s)) - {-# INLINE staticOptions #-} + staticOptions f s = fmap (\x -> s{T.staticOptions = x}) (f (T.staticOptions s)) + {-# INLINE staticOptions #-} - customFieldsBI f s = fmap (\x -> s { T.customFieldsBI = x }) (f (T.customFieldsBI s)) - {-# INLINE customFieldsBI #-} + customFieldsBI f s = fmap (\x -> s{T.customFieldsBI = x}) (f (T.customFieldsBI s)) + {-# INLINE customFieldsBI #-} - targetBuildDepends f s = fmap (\x -> s { T.targetBuildDepends = x }) (f (T.targetBuildDepends s)) - {-# INLINE targetBuildDepends #-} + targetBuildDepends f s = fmap (\x -> s{T.targetBuildDepends = x}) (f (T.targetBuildDepends s)) + {-# INLINE targetBuildDepends #-} - mixins f s = fmap (\x -> s { T.mixins = x }) (f (T.mixins s)) - {-# INLINE mixins #-} + mixins f s = fmap (\x -> s{T.mixins = x}) (f (T.mixins s)) + {-# INLINE mixins #-} class HasBuildInfos a where traverseBuildInfos :: Traversal' a BuildInfo diff --git a/Cabal-syntax/src/Distribution/Types/BuildType.hs b/Cabal-syntax/src/Distribution/Types/BuildType.hs index c9ace093640..e80770843f3 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildType.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildType.hs @@ -2,30 +2,34 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -module Distribution.Types.BuildType ( - BuildType(..), - knownBuildTypes, -) where +module Distribution.Types.BuildType + ( BuildType (..) + , knownBuildTypes + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.CabalSpecVersion (CabalSpecVersion (..)) -import Distribution.Pretty import Distribution.Parsec +import Distribution.Pretty import qualified Distribution.Compat.CharParsing as P import qualified Text.PrettyPrint as Disp -- | The type of build system used by this package. data BuildType - = Simple -- ^ calls @Distribution.Simple.defaultMain@ - | Configure -- ^ calls @Distribution.Simple.defaultMainWithHooks defaultUserHooks@, - -- which invokes @configure@ to generate additional build - -- information used by later phases. - | Make -- ^ calls @Distribution.Make.defaultMain@ - | Custom -- ^ uses user-supplied @Setup.hs@ or @Setup.lhs@ (default) - deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) + = -- | calls @Distribution.Simple.defaultMain@ + Simple + | -- | calls @Distribution.Simple.defaultMainWithHooks defaultUserHooks@, + -- which invokes @configure@ to generate additional build + -- information used by later phases. + Configure + | -- | calls @Distribution.Make.defaultMain@ + Make + | -- | uses user-supplied @Setup.hs@ or @Setup.lhs@ (default) + Custom + deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) instance Binary BuildType instance Structured BuildType @@ -41,15 +45,15 @@ instance Parsec BuildType where parsec = do name <- P.munch1 isAlphaNum case name of - "Simple" -> return Simple + "Simple" -> return Simple "Configure" -> return Configure - "Custom" -> return Custom - "Make" -> return Make - "Default" -> do - v <- askCabalSpecVersion - if v <= CabalSpecV1_18 -- oldest version needing this, based on hackage-tests + "Custom" -> return Custom + "Make" -> return Make + "Default" -> do + v <- askCabalSpecVersion + if v <= CabalSpecV1_18 -- oldest version needing this, based on hackage-tests then do - parsecWarning PWTBuildTypeDefault "build-type: Default is parsed as Custom for legacy reasons. See https://github.com/haskell/cabal/issues/5020" - return Custom + parsecWarning PWTBuildTypeDefault "build-type: Default is parsed as Custom for legacy reasons. See https://github.com/haskell/cabal/issues/5020" + return Custom else fail ("unknown build-type: '" ++ name ++ "'") - _ -> fail ("unknown build-type: '" ++ name ++ "'") + _ -> fail ("unknown build-type: '" ++ name ++ "'") diff --git a/Cabal-syntax/src/Distribution/Types/Component.hs b/Cabal-syntax/src/Distribution/Types/Component.hs index c45597dd328..6a6027bd258 100644 --- a/Cabal-syntax/src/Distribution/Types/Component.hs +++ b/Cabal-syntax/src/Distribution/Types/Component.hs @@ -1,61 +1,63 @@ {-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.Component ( - Component(..), - foldComponent, - componentBuildInfo, - componentBuildable, - componentName, - partitionComponents, -) where +module Distribution.Types.Component + ( Component (..) + , foldComponent + , componentBuildInfo + , componentBuildable + , componentName + , partitionComponents + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.Library -import Distribution.Types.ForeignLib +import Distribution.Types.Benchmark import Distribution.Types.Executable +import Distribution.Types.ForeignLib +import Distribution.Types.Library import Distribution.Types.TestSuite -import Distribution.Types.Benchmark -import Distribution.Types.ComponentName import Distribution.Types.BuildInfo +import Distribution.Types.ComponentName import qualified Distribution.Types.BuildInfo.Lens as L -data Component = CLib Library - | CFLib ForeignLib - | CExe Executable - | CTest TestSuite - | CBench Benchmark - deriving (Show, Eq, Read) +data Component + = CLib Library + | CFLib ForeignLib + | CExe Executable + | CTest TestSuite + | CBench Benchmark + deriving (Show, Eq, Read) instance Semigroup Component where - CLib l <> CLib l' = CLib (l <> l') - CFLib l <> CFLib l' = CFLib (l <> l') - CExe e <> CExe e' = CExe (e <> e') - CTest t <> CTest t' = CTest (t <> t') - CBench b <> CBench b' = CBench (b <> b') - _ <> _ = error "Cannot merge Component" + CLib l <> CLib l' = CLib (l <> l') + CFLib l <> CFLib l' = CFLib (l <> l') + CExe e <> CExe e' = CExe (e <> e') + CTest t <> CTest t' = CTest (t <> t') + CBench b <> CBench b' = CBench (b <> b') + _ <> _ = error "Cannot merge Component" instance L.HasBuildInfo Component where - buildInfo f (CLib l) = CLib <$> L.buildInfo f l - buildInfo f (CFLib l) = CFLib <$> L.buildInfo f l - buildInfo f (CExe e) = CExe <$> L.buildInfo f e - buildInfo f (CTest t) = CTest <$> L.buildInfo f t - buildInfo f (CBench b) = CBench <$> L.buildInfo f b + buildInfo f (CLib l) = CLib <$> L.buildInfo f l + buildInfo f (CFLib l) = CFLib <$> L.buildInfo f l + buildInfo f (CExe e) = CExe <$> L.buildInfo f e + buildInfo f (CTest t) = CTest <$> L.buildInfo f t + buildInfo f (CBench b) = CBench <$> L.buildInfo f b -foldComponent :: (Library -> a) - -> (ForeignLib -> a) - -> (Executable -> a) - -> (TestSuite -> a) - -> (Benchmark -> a) - -> Component - -> a -foldComponent f _ _ _ _ (CLib lib) = f lib -foldComponent _ f _ _ _ (CFLib flib)= f flib -foldComponent _ _ f _ _ (CExe exe) = f exe -foldComponent _ _ _ f _ (CTest tst) = f tst +foldComponent + :: (Library -> a) + -> (ForeignLib -> a) + -> (Executable -> a) + -> (TestSuite -> a) + -> (Benchmark -> a) + -> Component + -> a +foldComponent f _ _ _ _ (CLib lib) = f lib +foldComponent _ f _ _ _ (CFLib flib) = f flib +foldComponent _ _ f _ _ (CExe exe) = f exe +foldComponent _ _ _ f _ (CTest tst) = f tst foldComponent _ _ _ _ f (CBench bch) = f bch componentBuildInfo :: Component -> BuildInfo @@ -67,25 +69,25 @@ componentBuildInfo = -- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components". -- -- @since 2.0.0.2 --- componentBuildable :: Component -> Bool componentBuildable = buildable . componentBuildInfo componentName :: Component -> ComponentName componentName = - foldComponent (CLibName . libName) - (CFLibName . foreignLibName) - (CExeName . exeName) - (CTestName . testName) - (CBenchName . benchmarkName) + foldComponent + (CLibName . libName) + (CFLibName . foreignLibName) + (CExeName . exeName) + (CTestName . testName) + (CBenchName . benchmarkName) partitionComponents - :: [Component] - -> ([Library], [ForeignLib], [Executable], [TestSuite], [Benchmark]) -partitionComponents = foldr (foldComponent fa fb fc fd fe) ([],[],[],[],[]) + :: [Component] + -> ([Library], [ForeignLib], [Executable], [TestSuite], [Benchmark]) +partitionComponents = foldr (foldComponent fa fb fc fd fe) ([], [], [], [], []) where - fa x ~(a,b,c,d,e) = (x:a,b,c,d,e) - fb x ~(a,b,c,d,e) = (a,x:b,c,d,e) - fc x ~(a,b,c,d,e) = (a,b,x:c,d,e) - fd x ~(a,b,c,d,e) = (a,b,c,x:d,e) - fe x ~(a,b,c,d,e) = (a,b,c,d,x:e) + fa x ~(a, b, c, d, e) = (x : a, b, c, d, e) + fb x ~(a, b, c, d, e) = (a, x : b, c, d, e) + fc x ~(a, b, c, d, e) = (a, b, x : c, d, e) + fd x ~(a, b, c, d, e) = (a, b, c, x : d, e) + fe x ~(a, b, c, d, e) = (a, b, c, d, x : e) diff --git a/Cabal-syntax/src/Distribution/Types/ComponentId.hs b/Cabal-syntax/src/Distribution/Types/ComponentId.hs index e275ab6e55c..47cf1d97ee3 100644 --- a/Cabal-syntax/src/Distribution/Types/ComponentId.hs +++ b/Cabal-syntax/src/Distribution/Types/ComponentId.hs @@ -3,15 +3,17 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Distribution.Types.ComponentId - ( ComponentId, unComponentId, mkComponentId + ( ComponentId + , unComponentId + , mkComponentId ) where -import Prelude () import Distribution.Compat.Prelude import Distribution.Utils.ShortText +import Prelude () -import Distribution.Pretty import Distribution.Parsec +import Distribution.Pretty import qualified Distribution.Compat.CharParsing as P import Text.PrettyPrint (text) @@ -30,7 +32,7 @@ import Text.PrettyPrint (text) -- -- @since 2.0.0.2 newtype ComponentId = ComponentId ShortText - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) -- | Construct a 'ComponentId' from a 'String' -- @@ -53,7 +55,7 @@ unComponentId (ComponentId s) = fromShortText s -- -- @since 2.0.0.2 instance IsString ComponentId where - fromString = mkComponentId + fromString = mkComponentId instance Binary ComponentId instance Structured ComponentId @@ -63,7 +65,8 @@ instance Pretty ComponentId where instance Parsec ComponentId where parsec = mkComponentId `fmap` P.munch1 abi_char - where abi_char c = isAlphaNum c || c `elem` "-_." + where + abi_char c = isAlphaNum c || c `elem` "-_." instance NFData ComponentId where - rnf = rnf . unComponentId + rnf = rnf . unComponentId diff --git a/Cabal-syntax/src/Distribution/Types/ComponentName.hs b/Cabal-syntax/src/Distribution/Types/ComponentName.hs index 0dc0b3137c2..01ed6f7655f 100644 --- a/Cabal-syntax/src/Distribution/Types/ComponentName.hs +++ b/Cabal-syntax/src/Distribution/Types/ComponentName.hs @@ -2,45 +2,46 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PatternSynonyms #-} -module Distribution.Types.ComponentName ( - ComponentName(.., CFLibName, CExeName, CTestName, CBenchName), - showComponentName, - componentNameRaw, - componentNameStanza, - componentNameString, +module Distribution.Types.ComponentName + ( ComponentName (.., CFLibName, CExeName, CTestName, CBenchName) + , showComponentName + , componentNameRaw + , componentNameStanza + , componentNameString ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.UnqualComponentName -import Distribution.Types.LibraryName -import Distribution.Pretty import Distribution.Parsec +import Distribution.Pretty +import Distribution.Types.LibraryName +import Distribution.Types.UnqualComponentName -import qualified Text.PrettyPrint as Disp import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp -- Libraries live in a separate namespace, so must distinguish -data ComponentName = CLibName LibraryName - | CNotLibName NotLibComponentName - deriving (Eq, Generic, Ord, Read, Show, Typeable) +data ComponentName + = CLibName LibraryName + | CNotLibName NotLibComponentName + deriving (Eq, Generic, Ord, Read, Show, Typeable) data NotLibComponentName - = CNLFLibName { toCompName :: UnqualComponentName } - | CNLExeName { toCompName :: UnqualComponentName } - | CNLTestName { toCompName :: UnqualComponentName } - | CNLBenchName { toCompName :: UnqualComponentName } - deriving (Eq, Generic, Ord, Read, Show, Typeable) + = CNLFLibName {toCompName :: UnqualComponentName} + | CNLExeName {toCompName :: UnqualComponentName} + | CNLTestName {toCompName :: UnqualComponentName} + | CNLBenchName {toCompName :: UnqualComponentName} + deriving (Eq, Generic, Ord, Read, Show, Typeable) pattern CFLibName :: UnqualComponentName -> ComponentName -pattern CFLibName n = CNotLibName (CNLFLibName n) +pattern CFLibName n = CNotLibName (CNLFLibName n) pattern CExeName :: UnqualComponentName -> ComponentName -pattern CExeName n = CNotLibName (CNLExeName n) +pattern CExeName n = CNotLibName (CNLExeName n) pattern CTestName :: UnqualComponentName -> ComponentName -pattern CTestName n = CNotLibName (CNLTestName n) +pattern CTestName n = CNotLibName (CNLTestName n) pattern CBenchName :: UnqualComponentName -> ComponentName pattern CBenchName n = CNotLibName (CNLBenchName n) @@ -54,42 +55,43 @@ instance Structured ComponentName -- Build-target-ish syntax instance Pretty ComponentName where - pretty (CLibName lib) = prettyLibraryNameComponent lib - pretty (CFLibName str) = Disp.text "flib:" <<>> pretty str - pretty (CExeName str) = Disp.text "exe:" <<>> pretty str - pretty (CTestName str) = Disp.text "test:" <<>> pretty str - pretty (CBenchName str) = Disp.text "bench:" <<>> pretty str + pretty (CLibName lib) = prettyLibraryNameComponent lib + pretty (CFLibName str) = Disp.text "flib:" <<>> pretty str + pretty (CExeName str) = Disp.text "exe:" <<>> pretty str + pretty (CTestName str) = Disp.text "test:" <<>> pretty str + pretty (CBenchName str) = Disp.text "bench:" <<>> pretty str instance Parsec ComponentName where - -- note: this works as lib/flib/... all start with different character! - parsec = parseComposite <|> parseLib - where - parseLib = CLibName <$> parsecLibraryNameComponent - parseComposite = do - ctor <- P.choice - [ P.string "flib:" >> return CFLibName - , P.string "exe:" >> return CExeName - , P.string "bench:" >> return CBenchName - , P.string "test:" >> return CTestName - ] - ctor <$> parsec + -- note: this works as lib/flib/... all start with different character! + parsec = parseComposite <|> parseLib + where + parseLib = CLibName <$> parsecLibraryNameComponent + parseComposite = do + ctor <- + P.choice + [ P.string "flib:" >> return CFLibName + , P.string "exe:" >> return CExeName + , P.string "bench:" >> return CBenchName + , P.string "test:" >> return CTestName + ] + ctor <$> parsec showComponentName :: ComponentName -> String -showComponentName (CLibName lib) = showLibraryName lib -showComponentName (CFLibName name) = "foreign library '" ++ prettyShow name ++ "'" -showComponentName (CExeName name) = "executable '" ++ prettyShow name ++ "'" -showComponentName (CTestName name) = "test suite '" ++ prettyShow name ++ "'" +showComponentName (CLibName lib) = showLibraryName lib +showComponentName (CFLibName name) = "foreign library '" ++ prettyShow name ++ "'" +showComponentName (CExeName name) = "executable '" ++ prettyShow name ++ "'" +showComponentName (CTestName name) = "test suite '" ++ prettyShow name ++ "'" showComponentName (CBenchName name) = "benchmark '" ++ prettyShow name ++ "'" componentNameRaw :: ComponentName -> String -componentNameRaw l@(CLibName _) = showComponentName l +componentNameRaw l@(CLibName _) = showComponentName l componentNameRaw (CNotLibName x) = prettyShow $ toCompName x componentNameStanza :: ComponentName -> String -componentNameStanza (CLibName lib) = libraryNameStanza lib -componentNameStanza (CFLibName name) = "foreign-library " ++ prettyShow name -componentNameStanza (CExeName name) = "executable " ++ prettyShow name -componentNameStanza (CTestName name) = "test-suite " ++ prettyShow name +componentNameStanza (CLibName lib) = libraryNameStanza lib +componentNameStanza (CFLibName name) = "foreign-library " ++ prettyShow name +componentNameStanza (CExeName name) = "executable " ++ prettyShow name +componentNameStanza (CTestName name) = "test-suite " ++ prettyShow name componentNameStanza (CBenchName name) = "benchmark " ++ prettyShow name -- | This gets the underlying unqualified component name. In fact, it is @@ -97,5 +99,5 @@ componentNameStanza (CBenchName name) = "benchmark " ++ prettyShow name -- @Nothing@ if the 'ComponentName' was for the public -- library. componentNameString :: ComponentName -> Maybe UnqualComponentName -componentNameString (CLibName lib) = libraryNameString lib +componentNameString (CLibName lib) = libraryNameString lib componentNameString (CNotLibName x) = Just $ toCompName x diff --git a/Cabal-syntax/src/Distribution/Types/ComponentRequestedSpec.hs b/Cabal-syntax/src/Distribution/Types/ComponentRequestedSpec.hs index 3044c7600a8..224b38c839d 100644 --- a/Cabal-syntax/src/Distribution/Types/ComponentRequestedSpec.hs +++ b/Cabal-syntax/src/Distribution/Types/ComponentRequestedSpec.hs @@ -1,20 +1,18 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.ComponentRequestedSpec ( - -- $buildable_vs_enabled_components - ComponentRequestedSpec(..), - ComponentDisabledReason(..), +module Distribution.Types.ComponentRequestedSpec + ( -- $buildable_vs_enabled_components + ComponentRequestedSpec (..) + , ComponentDisabledReason (..) + , defaultComponentRequestedSpec + , componentNameRequested + , componentEnabled + , componentDisabledReason + ) where - defaultComponentRequestedSpec, - componentNameRequested, - - componentEnabled, - componentDisabledReason, -) where - -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Types.Component -- TODO: maybe remove me? import Distribution.Types.ComponentName @@ -64,9 +62,11 @@ import Distribution.Pretty (prettyShow) -- -- @since 2.0.0.2 data ComponentRequestedSpec - = ComponentRequestedSpec { testsRequested :: Bool - , benchmarksRequested :: Bool } - | OneComponentRequestedSpec ComponentName + = ComponentRequestedSpec + { testsRequested :: Bool + , benchmarksRequested :: Bool + } + | OneComponentRequestedSpec ComponentName deriving (Generic, Read, Show, Eq, Typeable) instance Binary ComponentRequestedSpec @@ -96,32 +96,39 @@ componentNameRequested enabled = isNothing . componentNameNotRequestedReason ena -- | Is this component disabled, and if so, why? -- -- @since 2.0.0.2 -componentDisabledReason :: ComponentRequestedSpec -> Component - -> Maybe ComponentDisabledReason +componentDisabledReason + :: ComponentRequestedSpec + -> Component + -> Maybe ComponentDisabledReason componentDisabledReason enabled comp - | not (componentBuildable comp) = Just DisabledComponent - | otherwise = componentNameNotRequestedReason enabled (componentName comp) + | not (componentBuildable comp) = Just DisabledComponent + | otherwise = componentNameNotRequestedReason enabled (componentName comp) -- | Is this component name disabled, and if so, why? -- -- @since 2.0.0.2 -componentNameNotRequestedReason :: ComponentRequestedSpec -> ComponentName - -> Maybe ComponentDisabledReason componentNameNotRequestedReason - ComponentRequestedSpec{ testsRequested = False } (CTestName _) - = Just DisabledAllTests + :: ComponentRequestedSpec + -> ComponentName + -> Maybe ComponentDisabledReason +componentNameNotRequestedReason + ComponentRequestedSpec{testsRequested = False} + (CTestName _) = + Just DisabledAllTests componentNameNotRequestedReason - ComponentRequestedSpec{ benchmarksRequested = False } (CBenchName _) - = Just DisabledAllBenchmarks + ComponentRequestedSpec{benchmarksRequested = False} + (CBenchName _) = + Just DisabledAllBenchmarks componentNameNotRequestedReason ComponentRequestedSpec{} _ = Nothing componentNameNotRequestedReason (OneComponentRequestedSpec cname) c - | c == cname = Nothing - | otherwise = Just (DisabledAllButOne (prettyShow cname)) + | c == cname = Nothing + | otherwise = Just (DisabledAllButOne (prettyShow cname)) -- | A reason explaining why a component is disabled. -- -- @since 2.0.0.2 -data ComponentDisabledReason = DisabledComponent - | DisabledAllTests - | DisabledAllBenchmarks - | DisabledAllButOne String +data ComponentDisabledReason + = DisabledComponent + | DisabledAllTests + | DisabledAllBenchmarks + | DisabledAllButOne String diff --git a/Cabal-syntax/src/Distribution/Types/CondTree.hs b/Cabal-syntax/src/Distribution/Types/CondTree.hs index 84d46ffa49c..5fe25e649d7 100644 --- a/Cabal-syntax/src/Distribution/Types/CondTree.hs +++ b/Cabal-syntax/src/Distribution/Types/CondTree.hs @@ -1,37 +1,36 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Types.CondTree ( - CondTree(..), - CondBranch(..), - condIfThen, - condIfThenElse, - foldCondTree, - mapCondTree, - mapTreeConstrs, - mapTreeConds, - mapTreeData, - traverseCondTreeV, - traverseCondBranchV, - traverseCondTreeC, - traverseCondBranchC, - extractCondition, - simplifyCondTree, - ignoreConditions, -) where +module Distribution.Types.CondTree + ( CondTree (..) + , CondBranch (..) + , condIfThen + , condIfThenElse + , foldCondTree + , mapCondTree + , mapTreeConstrs + , mapTreeConds + , mapTreeData + , traverseCondTreeV + , traverseCondBranchV + , traverseCondTreeC + , traverseCondBranchC + , extractCondition + , simplifyCondTree + , ignoreConditions + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Types.Condition import qualified Distribution.Compat.Lens as L - -- | A 'CondTree' is used to represent the conditional structure of -- a Cabal file, reflecting a syntax element subject to constraints, -- and then any number of sub-elements which may be enabled subject @@ -56,13 +55,12 @@ import qualified Distribution.Compat.Lens as L -- derived off of 'targetBuildInfo' (perhaps a good refactoring -- would be to convert this into an opaque type, with a smart -- constructor that pre-computes the dependencies.) --- data CondTree v c a = CondNode - { condTreeData :: a - , condTreeConstraints :: c - , condTreeComponents :: [CondBranch v c a] - } - deriving (Show, Eq, Typeable, Data, Generic, Functor, Foldable, Traversable) + { condTreeData :: a + , condTreeConstraints :: c + , condTreeComponents :: [CondBranch v c a] + } + deriving (Show, Eq, Typeable, Data, Generic, Functor, Foldable, Traversable) instance (Binary v, Binary c, Binary a) => Binary (CondTree v c a) instance (Structured v, Structured c, Structured a) => Structured (CondTree v c a) @@ -72,26 +70,25 @@ instance (Semigroup a, Semigroup c) => Semigroup (CondTree v c a) where (CondNode a c bs) <> (CondNode a' c' bs') = CondNode (a <> a') (c <> c') (bs <> bs') instance (Semigroup a, Semigroup c, Monoid a, Monoid c) => Monoid (CondTree v c a) where - mappend = (<>) - mempty = CondNode mempty mempty mempty + mappend = (<>) + mempty = CondNode mempty mempty mempty -- | A 'CondBranch' represents a conditional branch, e.g., @if -- flag(foo)@ on some syntax @a@. It also has an optional false -- branch. --- data CondBranch v c a = CondBranch - { condBranchCondition :: Condition v - , condBranchIfTrue :: CondTree v c a - , condBranchIfFalse :: Maybe (CondTree v c a) - } - deriving (Show, Eq, Typeable, Data, Generic, Functor, Traversable) + { condBranchCondition :: Condition v + , condBranchIfTrue :: CondTree v c a + , condBranchIfFalse :: Maybe (CondTree v c a) + } + deriving (Show, Eq, Typeable, Data, Generic, Functor, Traversable) -- This instance is written by hand because GHC 8.0.1/8.0.2 infinite -- loops when trying to derive it with optimizations. See -- https://gitlab.haskell.org/ghc/ghc/-/issues/13056 instance Foldable (CondBranch v c) where - foldMap f (CondBranch _ c Nothing) = foldMap f c - foldMap f (CondBranch _ c (Just a)) = foldMap f c `mappend` foldMap f a + foldMap f (CondBranch _ c Nothing) = foldMap f c + foldMap f (CondBranch _ c (Just a)) = foldMap f c `mappend` foldMap f a instance (Binary v, Binary c, Binary a) => Binary (CondBranch v c a) instance (Structured v, Structured c, Structured a) => Structured (CondBranch v c a) @@ -103,15 +100,20 @@ condIfThen c t = CondBranch c t Nothing condIfThenElse :: Condition v -> CondTree v c a -> CondTree v c a -> CondBranch v c a condIfThenElse c t e = CondBranch c t (Just e) -mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w) - -> CondTree v c a -> CondTree w d b +mapCondTree + :: (a -> b) + -> (c -> d) + -> (Condition v -> Condition w) + -> CondTree v c a + -> CondTree w d b mapCondTree fa fc fcnd (CondNode a c ifs) = - CondNode (fa a) (fc c) (map g ifs) + CondNode (fa a) (fc c) (map g ifs) where - g (CondBranch cnd t me) - = CondBranch (fcnd cnd) - (mapCondTree fa fc fcnd t) - (fmap (mapCondTree fa fc fcnd) me) + g (CondBranch cnd t me) = + CondBranch + (fcnd cnd) + (mapCondTree fa fc fcnd t) + (fmap (mapCondTree fa fc fcnd) me) mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a mapTreeConstrs f = mapCondTree id f id @@ -125,11 +127,12 @@ mapTreeData f = mapCondTree f id id -- | @@Traversal@@ for the variables traverseCondTreeV :: L.Traversal (CondTree v c a) (CondTree w c a) v w traverseCondTreeV f (CondNode a c ifs) = - CondNode a c <$> traverse (traverseCondBranchV f) ifs + CondNode a c <$> traverse (traverseCondBranchV f) ifs -- | @@Traversal@@ for the variables traverseCondBranchV :: L.Traversal (CondBranch v c a) (CondBranch w c a) v w -traverseCondBranchV f (CondBranch cnd t me) = CondBranch +traverseCondBranchV f (CondBranch cnd t me) = + CondBranch <$> traverse f cnd <*> traverseCondTreeV f t <*> traverse (traverseCondTreeV f) me @@ -137,15 +140,15 @@ traverseCondBranchV f (CondBranch cnd t me) = CondBranch -- | @@Traversal@@ for the aggregated constraints traverseCondTreeC :: L.Traversal (CondTree v c a) (CondTree v d a) c d traverseCondTreeC f (CondNode a c ifs) = - CondNode a <$> f c <*> traverse (traverseCondBranchC f) ifs + CondNode a <$> f c <*> traverse (traverseCondBranchC f) ifs -- | @@Traversal@@ for the aggregated constraints traverseCondBranchC :: L.Traversal (CondBranch v c a) (CondBranch v d a) c d -traverseCondBranchC f (CondBranch cnd t me) = CondBranch cnd +traverseCondBranchC f (CondBranch cnd t me) = + CondBranch cnd <$> traverseCondTreeC f t <*> traverse (traverseCondTreeC f) me - -- | Extract the condition matched by the given predicate from a cond tree. -- -- We use this mainly for extracting buildable conditions (see the Note in @@ -154,40 +157,43 @@ traverseCondBranchC f (CondBranch cnd t me) = CondBranch cnd extractCondition :: Eq v => (a -> Bool) -> CondTree v c a -> Condition v extractCondition p = go where - go (CondNode x _ cs) | not (p x) = Lit False - | otherwise = goList cs + go (CondNode x _ cs) + | not (p x) = Lit False + | otherwise = goList cs - goList [] = Lit True + goList [] = Lit True goList (CondBranch c t e : cs) = let ct = go t ce = maybe (Lit True) go e - in + in ((c `cAnd` ct) `cOr` (CNot c `cAnd` ce)) `cAnd` goList cs -- | Flattens a CondTree using a partial flag assignment. When a condition -- cannot be evaluated, both branches are ignored. -simplifyCondTree :: (Semigroup a, Semigroup d) => - (v -> Either v Bool) - -> CondTree v d a - -> (d, a) +simplifyCondTree + :: (Semigroup a, Semigroup d) + => (v -> Either v Bool) + -> CondTree v d a + -> (d, a) simplifyCondTree env (CondNode a d ifs) = - foldl (<>) (d, a) $ mapMaybe simplifyIf ifs + foldl (<>) (d, a) $ mapMaybe simplifyIf ifs where simplifyIf (CondBranch cnd t me) = - case simplifyCondition cnd env of - (Lit True, _) -> Just $ simplifyCondTree env t - (Lit False, _) -> fmap (simplifyCondTree env) me - _ -> Nothing + case simplifyCondition cnd env of + (Lit True, _) -> Just $ simplifyCondTree env t + (Lit False, _) -> fmap (simplifyCondTree env) me + _ -> Nothing -- | Flatten a CondTree. This will resolve the CondTree by taking all -- possible paths into account. Note that since branches represent exclusive -- choices this may not result in a \"sane\" result. ignoreConditions :: (Semigroup a, Semigroup c) => CondTree v c a -> (a, c) ignoreConditions (CondNode a c ifs) = foldl (<>) (a, c) $ concatMap f ifs - where f (CondBranch _ t me) = ignoreConditions t - : maybeToList (fmap ignoreConditions me) - + where + f (CondBranch _ t me) = + ignoreConditions t + : maybeToList (fmap ignoreConditions me) -- | Flatten a CondTree. This will traverse the CondTree by taking all -- possible paths into account, but merging inclusive when two paths diff --git a/Cabal-syntax/src/Distribution/Types/Condition.hs b/Cabal-syntax/src/Distribution/Types/Condition.hs index 0c89cb910da..114c25afa66 100644 --- a/Cabal-syntax/src/Distribution/Types/Condition.hs +++ b/Cabal-syntax/src/Distribution/Types/Condition.hs @@ -1,85 +1,87 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.Condition ( - Condition(..), - cNot, - cAnd, - cOr, - simplifyCondition, -) where +module Distribution.Types.Condition + ( Condition (..) + , cNot + , cAnd + , cOr + , simplifyCondition + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -- | A boolean expression parameterized over the variable type used. -data Condition c = Var c - | Lit Bool - | CNot (Condition c) - | COr (Condition c) (Condition c) - | CAnd (Condition c) (Condition c) - deriving (Show, Eq, Typeable, Data, Generic) +data Condition c + = Var c + | Lit Bool + | CNot (Condition c) + | COr (Condition c) (Condition c) + | CAnd (Condition c) (Condition c) + deriving (Show, Eq, Typeable, Data, Generic) -- | Boolean negation of a 'Condition' value. cNot :: Condition a -> Condition a -cNot (Lit b) = Lit (not b) +cNot (Lit b) = Lit (not b) cNot (CNot c) = c -cNot c = CNot c +cNot c = CNot c -- | Boolean AND of two 'Condition' values. cAnd :: Condition a -> Condition a -> Condition a -cAnd (Lit False) _ = Lit False -cAnd _ (Lit False) = Lit False -cAnd (Lit True) x = x -cAnd x (Lit True) = x -cAnd x y = CAnd x y +cAnd (Lit False) _ = Lit False +cAnd _ (Lit False) = Lit False +cAnd (Lit True) x = x +cAnd x (Lit True) = x +cAnd x y = CAnd x y -- | Boolean OR of two 'Condition' values. cOr :: Eq v => Condition v -> Condition v -> Condition v -cOr (Lit True) _ = Lit True -cOr _ (Lit True) = Lit True -cOr (Lit False) x = x -cOr x (Lit False) = x -cOr c (CNot d) - | c == d = Lit True -cOr (CNot c) d - | c == d = Lit True -cOr x y = COr x y +cOr (Lit True) _ = Lit True +cOr _ (Lit True) = Lit True +cOr (Lit False) x = x +cOr x (Lit False) = x +cOr c (CNot d) + | c == d = Lit True +cOr (CNot c) d + | c == d = Lit True +cOr x y = COr x y instance Functor Condition where - f `fmap` Var c = Var (f c) - _ `fmap` Lit c = Lit c - f `fmap` CNot c = CNot (fmap f c) - f `fmap` COr c d = COr (fmap f c) (fmap f d) + f `fmap` Var c = Var (f c) + _ `fmap` Lit c = Lit c + f `fmap` CNot c = CNot (fmap f c) + f `fmap` COr c d = COr (fmap f c) (fmap f d) f `fmap` CAnd c d = CAnd (fmap f c) (fmap f d) instance Foldable Condition where - f `foldMap` Var c = f c - _ `foldMap` Lit _ = mempty - f `foldMap` CNot c = foldMap f c - f `foldMap` COr c d = foldMap f c `mappend` foldMap f d + f `foldMap` Var c = f c + _ `foldMap` Lit _ = mempty + f `foldMap` CNot c = foldMap f c + f `foldMap` COr c d = foldMap f c `mappend` foldMap f d f `foldMap` CAnd c d = foldMap f c `mappend` foldMap f d instance Traversable Condition where - f `traverse` Var c = Var `fmap` f c - _ `traverse` Lit c = pure $ Lit c - f `traverse` CNot c = CNot `fmap` traverse f c - f `traverse` COr c d = COr `fmap` traverse f c <*> traverse f d + f `traverse` Var c = Var `fmap` f c + _ `traverse` Lit c = pure $ Lit c + f `traverse` CNot c = CNot `fmap` traverse f c + f `traverse` COr c d = COr `fmap` traverse f c <*> traverse f d f `traverse` CAnd c d = CAnd `fmap` traverse f c <*> traverse f d instance Applicative Condition where - pure = Var + pure = Var (<*>) = ap instance Monad Condition where return = pure + -- Terminating cases (>>=) (Lit x) _ = Lit x (>>=) (Var x) f = f x -- Recursing cases - (>>=) (CNot x ) f = CNot (x >>= f) - (>>=) (COr x y) f = COr (x >>= f) (y >>= f) - (>>=) (CAnd x y) f = CAnd (x >>= f) (y >>= f) + (>>=) (CNot x) f = CNot (x >>= f) + (>>=) (COr x y) f = COr (x >>= f) (y >>= f) + (>>=) (CAnd x y) f = CAnd (x >>= f) (y >>= f) instance Monoid (Condition a) where mempty = Lit False @@ -101,35 +103,37 @@ instance Structured c => Structured (Condition c) instance NFData c => NFData (Condition c) where rnf = genericRnf -- | Simplify the condition and return its free variables. -simplifyCondition :: Condition c - -> (c -> Either d Bool) -- ^ (partial) variable assignment - -> (Condition d, [d]) +simplifyCondition + :: Condition c + -> (c -> Either d Bool) + -- ^ (partial) variable assignment + -> (Condition d, [d]) simplifyCondition cond i = fv . walk $ cond where walk cnd = case cnd of - Var v -> either Var Lit (i v) - Lit b -> Lit b - CNot c -> case walk c of - Lit True -> Lit False - Lit False -> Lit True - c' -> CNot c' + Var v -> either Var Lit (i v) + Lit b -> Lit b + CNot c -> case walk c of + Lit True -> Lit False + Lit False -> Lit True + c' -> CNot c' COr c d -> case (walk c, walk d) of - (Lit False, d') -> d' - (Lit True, _) -> Lit True - (c', Lit False) -> c' - (_, Lit True) -> Lit True - (c',d') -> COr c' d' + (Lit False, d') -> d' + (Lit True, _) -> Lit True + (c', Lit False) -> c' + (_, Lit True) -> Lit True + (c', d') -> COr c' d' CAnd c d -> case (walk c, walk d) of - (Lit False, _) -> Lit False - (Lit True, d') -> d' - (_, Lit False) -> Lit False - (c', Lit True) -> c' - (c',d') -> CAnd c' d' + (Lit False, _) -> Lit False + (Lit True, d') -> d' + (_, Lit False) -> Lit False + (c', Lit True) -> c' + (c', d') -> CAnd c' d' -- gather free vars fv c = (c, fv' c) fv' c = case c of - Var v -> [v] - Lit _ -> [] - CNot c' -> fv' c' - COr c1 c2 -> fv' c1 ++ fv' c2 + Var v -> [v] + Lit _ -> [] + CNot c' -> fv' c' + COr c1 c2 -> fv' c1 ++ fv' c2 CAnd c1 c2 -> fv' c1 ++ fv' c2 diff --git a/Cabal-syntax/src/Distribution/Types/ConfVar.hs b/Cabal-syntax/src/Distribution/Types/ConfVar.hs index 39e5e04d326..220a6556fbd 100644 --- a/Cabal-syntax/src/Distribution/Types/ConfVar.hs +++ b/Cabal-syntax/src/Distribution/Types/ConfVar.hs @@ -1,23 +1,25 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.ConfVar ( - ConfVar(..), - ) where -import Prelude () +module Distribution.Types.ConfVar + ( ConfVar (..) + ) where + import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.Flag -import Distribution.Types.VersionRange import Distribution.Compiler import Distribution.System +import Distribution.Types.Flag +import Distribution.Types.VersionRange -- | A @ConfVar@ represents the variable type used. -data ConfVar = OS OS - | Arch Arch - | PackageFlag FlagName - | Impl CompilerFlavor VersionRange - deriving (Eq, Show, Typeable, Data, Generic) +data ConfVar + = OS OS + | Arch Arch + | PackageFlag FlagName + | Impl CompilerFlavor VersionRange + deriving (Eq, Show, Typeable, Data, Generic) instance Binary ConfVar instance Structured ConfVar diff --git a/Cabal-syntax/src/Distribution/Types/Dependency.hs b/Cabal-syntax/src/Distribution/Types/Dependency.hs index bfdc78cd06d..959cb7bd249 100644 --- a/Cabal-syntax/src/Distribution/Types/Dependency.hs +++ b/Cabal-syntax/src/Distribution/Types/Dependency.hs @@ -1,7 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} + module Distribution.Types.Dependency - ( Dependency(..) + ( Dependency (..) , mkDependency , depPkgName , depVerRange @@ -14,11 +15,11 @@ import Distribution.Compat.Prelude import Prelude () import Distribution.Types.VersionRange (isAnyVersionLight) -import Distribution.Version (VersionRange, anyVersion, simplifyVersionRange) +import Distribution.Version (VersionRange, anyVersion, simplifyVersionRange) import Distribution.CabalSpecVersion -import Distribution.Compat.CharParsing (char, spaces) -import Distribution.Compat.Parsing (between, option) +import Distribution.Compat.CharParsing (char, spaces) +import Distribution.Compat.Parsing (between, option) import Distribution.Parsec import Distribution.Pretty import Distribution.Types.LibraryName @@ -26,7 +27,7 @@ import Distribution.Types.PackageName import Distribution.Types.UnqualComponentName import qualified Distribution.Compat.NonEmptySet as NES -import qualified Text.PrettyPrint as PP +import qualified Text.PrettyPrint as PP -- | Describes a dependency on a source package (API) -- @@ -36,15 +37,15 @@ import qualified Text.PrettyPrint as PP -- /Note:/ 'Dependency' is not an instance of 'Ord', and so it cannot be used -- in 'Set' or as the key to a 'Map'. For these and similar use cases see -- 'DependencyMap'. --- -data Dependency = Dependency - PackageName - VersionRange - (NonEmptySet LibraryName) - -- ^ The set of libraries required from the package. - -- Only the selected libraries will be built. - -- It does not affect the cabal-install solver yet. - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) +data Dependency + = -- | The set of libraries required from the package. + -- Only the selected libraries will be built. + -- It does not affect the cabal-install solver yet. + Dependency + PackageName + VersionRange + (NonEmptySet LibraryName) + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) depPkgName :: Dependency -> PackageName depPkgName (Dependency pn _ _) = pn @@ -61,15 +62,15 @@ depLibraries (Dependency _ _ cs) = cs -- it is automatically converted to 'LMainLibName'. -- -- @since 3.4.0.0 --- mkDependency :: PackageName -> VersionRange -> NonEmptySet LibraryName -> Dependency mkDependency pn vr lb = Dependency pn vr (NES.map conv lb) where pn' = packageNameToUnqualComponentName pn - conv l@LMainLibName = l - conv l@(LSubLibName ln) | ln == pn' = LMainLibName - | otherwise = l + conv l@LMainLibName = l + conv l@(LSubLibName ln) + | ln == pn' = LMainLibName + | otherwise = l instance Binary Dependency instance Structured Dependency @@ -88,23 +89,23 @@ instance NFData Dependency where rnf = genericRnf -- -- >>> prettyShow $ Dependency "pkg" anyVersion $ NES.insert (LSubLibName "sublib-b") $ NES.singleton (LSubLibName "sublib-a") -- "pkg:{sublib-a, sublib-b}" --- instance Pretty Dependency where - pretty (Dependency name ver sublibs) = withSubLibs (pretty name) <+> pver - where - -- TODO: change to isAnyVersion after #6736 - pver | isAnyVersionLight ver = PP.empty - | otherwise = pretty ver + pretty (Dependency name ver sublibs) = withSubLibs (pretty name) <+> pver + where + -- TODO: change to isAnyVersion after #6736 + pver + | isAnyVersionLight ver = PP.empty + | otherwise = pretty ver - withSubLibs doc = case NES.toList sublibs of - [LMainLibName] -> doc - [LSubLibName uq] -> doc <<>> PP.colon <<>> pretty uq - _ -> doc <<>> PP.colon <<>> PP.braces prettySublibs + withSubLibs doc = case NES.toList sublibs of + [LMainLibName] -> doc + [LSubLibName uq] -> doc <<>> PP.colon <<>> pretty uq + _ -> doc <<>> PP.colon <<>> PP.braces prettySublibs - prettySublibs = PP.hsep $ PP.punctuate PP.comma $ prettySublib <$> NES.toList sublibs + prettySublibs = PP.hsep $ PP.punctuate PP.comma $ prettySublib <$> NES.toList sublibs - prettySublib LMainLibName = PP.text $ unPackageName name - prettySublib (LSubLibName un) = PP.text $ unUnqualComponentName un + prettySublib LMainLibName = PP.text $ unPackageName name + prettySublib (LSubLibName un) = PP.text $ unUnqualComponentName un -- | -- @@ -137,36 +138,37 @@ instance Pretty Dependency where -- -- >>> map (`simpleParsec'` "mylib:sub") [CabalSpecV2_4, CabalSpecV3_0] :: [Maybe Dependency] -- [Nothing,Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub") :| [])))] --- instance Parsec Dependency where - parsec = do - name <- parsec - - libs <- option mainLibSet $ do - _ <- char ':' - versionGuardMultilibs - NES.singleton <$> parseLib <|> parseMultipleLibs - - spaces -- https://github.com/haskell/cabal/issues/5846 - - ver <- parsec <|> pure anyVersion - return $ mkDependency name ver libs - where - parseLib = LSubLibName <$> parsec - parseMultipleLibs = between - (char '{' *> spaces) - (spaces *> char '}') - (NES.fromNonEmpty <$> parsecCommaNonEmpty parseLib) + parsec = do + name <- parsec + + libs <- option mainLibSet $ do + _ <- char ':' + versionGuardMultilibs + NES.singleton <$> parseLib <|> parseMultipleLibs + + spaces -- https://github.com/haskell/cabal/issues/5846 + ver <- parsec <|> pure anyVersion + return $ mkDependency name ver libs + where + parseLib = LSubLibName <$> parsec + parseMultipleLibs = + between + (char '{' *> spaces) + (spaces *> char '}') + (NES.fromNonEmpty <$> parsecCommaNonEmpty parseLib) versionGuardMultilibs :: CabalParsing m => m () versionGuardMultilibs = do csv <- askCabalSpecVersion - when (csv < CabalSpecV3_0) $ fail $ unwords - [ "Sublibrary dependency syntax used." - , "To use this syntax the package needs to specify at least 'cabal-version: 3.0'." - , "Alternatively, if you are depending on an internal library, you can write" - , "directly the library name as it were a package." - ] + when (csv < CabalSpecV3_0) $ + fail $ + unwords + [ "Sublibrary dependency syntax used." + , "To use this syntax the package needs to specify at least 'cabal-version: 3.0'." + , "Alternatively, if you are depending on an internal library, you can write" + , "directly the library name as it were a package." + ] -- | Library set with main library. -- @@ -176,7 +178,6 @@ mainLibSet = NES.singleton LMainLibName -- | Simplify the 'VersionRange' expression in a 'Dependency'. -- See 'simplifyVersionRange'. --- simplifyDependency :: Dependency -> Dependency simplifyDependency (Dependency name range comps) = Dependency name (simplifyVersionRange range) comps diff --git a/Cabal-syntax/src/Distribution/Types/DependencyMap.hs b/Cabal-syntax/src/Distribution/Types/DependencyMap.hs index c7e66cf73b4..aebca2c4cbf 100644 --- a/Cabal-syntax/src/Distribution/Types/DependencyMap.hs +++ b/Cabal-syntax/src/Distribution/Types/DependencyMap.hs @@ -1,9 +1,9 @@ -module Distribution.Types.DependencyMap ( - DependencyMap, - toDepMap, - fromDepMap, - constrainBy, -) where +module Distribution.Types.DependencyMap + ( DependencyMap + , toDepMap + , fromDepMap + , constrainBy + ) where import Distribution.Compat.Prelude import Prelude () @@ -18,40 +18,42 @@ import qualified Data.Map.Lazy as Map -- | A map of dependencies. Newtyped since the default monoid instance is not -- appropriate. The monoid instance uses 'intersectVersionRanges'. -newtype DependencyMap = DependencyMap { unDependencyMap :: Map PackageName (VersionRange, NonEmptySet LibraryName) } +newtype DependencyMap = DependencyMap {unDependencyMap :: Map PackageName (VersionRange, NonEmptySet LibraryName)} deriving (Show, Read, Eq) instance Monoid DependencyMap where - mempty = DependencyMap Map.empty - mappend = (<>) + mempty = DependencyMap Map.empty + mappend = (<>) instance Semigroup DependencyMap where - (DependencyMap a) <> (DependencyMap b) = - DependencyMap (Map.unionWith intersectVersionRangesAndJoinComponents a b) + (DependencyMap a) <> (DependencyMap b) = + DependencyMap (Map.unionWith intersectVersionRangesAndJoinComponents a b) -intersectVersionRangesAndJoinComponents :: (VersionRange, NonEmptySet LibraryName) - -> (VersionRange, NonEmptySet LibraryName) - -> (VersionRange, NonEmptySet LibraryName) +intersectVersionRangesAndJoinComponents + :: (VersionRange, NonEmptySet LibraryName) + -> (VersionRange, NonEmptySet LibraryName) + -> (VersionRange, NonEmptySet LibraryName) intersectVersionRangesAndJoinComponents (va, ca) (vb, cb) = (intersectVersionRanges va vb, ca <> cb) toDepMap :: [Dependency] -> DependencyMap toDepMap ds = - DependencyMap $ Map.fromListWith intersectVersionRangesAndJoinComponents [ (p,(vr,cs)) | Dependency p vr cs <- ds ] + DependencyMap $ Map.fromListWith intersectVersionRangesAndJoinComponents [(p, (vr, cs)) | Dependency p vr cs <- ds] fromDepMap :: DependencyMap -> [Dependency] -fromDepMap m = [ Dependency p vr cs | (p,(vr,cs)) <- Map.toList (unDependencyMap m) ] +fromDepMap m = [Dependency p vr cs | (p, (vr, cs)) <- Map.toList (unDependencyMap m)] -- Apply extra constraints to a dependency map. -- Combines dependencies where the result will only contain keys from the left -- (first) map. If a key also exists in the right map, both constraints will -- be intersected. constrainBy - :: DependencyMap - -> [PackageVersionConstraint] - -> DependencyMap -constrainBy = foldl' tightenConstraint where + :: DependencyMap + -> [PackageVersionConstraint] + -> DependencyMap +constrainBy = foldl' tightenConstraint + where tightenConstraint (DependencyMap l) (PackageVersionConstraint pn vr) = DependencyMap $ - case Map.lookup pn l of - Nothing -> l - Just (vr', cs) -> Map.insert pn (intersectVersionRanges vr' vr, cs) l + case Map.lookup pn l of + Nothing -> l + Just (vr', cs) -> Map.insert pn (intersectVersionRanges vr' vr, cs) l diff --git a/Cabal-syntax/src/Distribution/Types/ExeDependency.hs b/Cabal-syntax/src/Distribution/Types/ExeDependency.hs index 7030058bea3..17a79703fcc 100644 --- a/Cabal-syntax/src/Distribution/Types/ExeDependency.hs +++ b/Cabal-syntax/src/Distribution/Types/ExeDependency.hs @@ -1,7 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} + module Distribution.Types.ExeDependency - ( ExeDependency(..) + ( ExeDependency (..) , qualifiedExeName ) where @@ -13,18 +14,18 @@ import Distribution.Pretty import Distribution.Types.ComponentName import Distribution.Types.PackageName import Distribution.Types.UnqualComponentName -import Distribution.Version (VersionRange, anyVersion, isAnyVersion) +import Distribution.Version (VersionRange, anyVersion, isAnyVersion) import qualified Distribution.Compat.CharParsing as P import qualified Text.PrettyPrint as PP -- | Describes a dependency on an executable from a package --- -data ExeDependency = ExeDependency - PackageName - UnqualComponentName -- name of executable component of package - VersionRange - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) +data ExeDependency + = ExeDependency + PackageName + UnqualComponentName -- name of executable component of package + VersionRange + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) instance Binary ExeDependency instance Structured ExeDependency @@ -32,10 +33,11 @@ instance NFData ExeDependency where rnf = genericRnf instance Pretty ExeDependency where pretty (ExeDependency name exe ver) = - pretty name <<>> PP.colon <<>> pretty exe PP.<+> pver + pretty name <<>> PP.colon <<>> pretty exe PP.<+> pver where - pver | isAnyVersion ver = PP.empty - | otherwise = pretty ver + pver + | isAnyVersion ver = PP.empty + | otherwise = pretty ver -- | -- @@ -58,14 +60,13 @@ instance Pretty ExeDependency where -- -- >>> simpleParsec "happy :happy >= 1.19.12" :: Maybe ExeDependency -- Nothing --- instance Parsec ExeDependency where - parsec = do - name <- parsec - _ <- P.char ':' - exe <- lexemeParsec - ver <- parsec <|> pure anyVersion - return (ExeDependency name exe ver) + parsec = do + name <- parsec + _ <- P.char ':' + exe <- lexemeParsec + ver <- parsec <|> pure anyVersion + return (ExeDependency name exe ver) qualifiedExeName :: ExeDependency -> ComponentName qualifiedExeName (ExeDependency _ ucn _) = CExeName ucn diff --git a/Cabal-syntax/src/Distribution/Types/Executable.hs b/Cabal-syntax/src/Distribution/Types/Executable.hs index 45fcc69a6b3..618f91dc5f3 100644 --- a/Cabal-syntax/src/Distribution/Types/Executable.hs +++ b/Cabal-syntax/src/Distribution/Types/Executable.hs @@ -1,33 +1,33 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.Executable ( - Executable(..), - emptyExecutable, - exeModules, - exeModulesAutogen -) where +module Distribution.Types.Executable + ( Executable (..) + , emptyExecutable + , exeModules + , exeModulesAutogen + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () +import Distribution.ModuleName import Distribution.Types.BuildInfo -import Distribution.Types.UnqualComponentName import Distribution.Types.ExecutableScope -import Distribution.ModuleName +import Distribution.Types.UnqualComponentName import qualified Distribution.Types.BuildInfo.Lens as L -data Executable = Executable { - exeName :: UnqualComponentName, - modulePath :: FilePath, - exeScope :: ExecutableScope, - buildInfo :: BuildInfo - } - deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) +data Executable = Executable + { exeName :: UnqualComponentName + , modulePath :: FilePath + , exeScope :: ExecutableScope + , buildInfo :: BuildInfo + } + deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) instance L.HasBuildInfo Executable where - buildInfo f l = (\x -> l { buildInfo = x }) <$> f (buildInfo l) + buildInfo f l = (\x -> l{buildInfo = x}) <$> f (buildInfo l) instance Binary Executable instance Structured Executable @@ -38,19 +38,27 @@ instance Monoid Executable where mappend = (<>) instance Semigroup Executable where - a <> b = Executable{ - exeName = combine' exeName, - modulePath = combine modulePath, - exeScope = combine exeScope, - buildInfo = combine buildInfo - } - where combine field = field a `mappend` field b - combine' field = case ( unUnqualComponentName $ field a - , unUnqualComponentName $ field b) of - ("", _) -> field b - (_, "") -> field a - (x, y) -> error $ "Ambiguous values for executable field: '" - ++ x ++ "' and '" ++ y ++ "'" + a <> b = + Executable + { exeName = combine' exeName + , modulePath = combine modulePath + , exeScope = combine exeScope + , buildInfo = combine buildInfo + } + where + combine field = field a `mappend` field b + combine' field = case ( unUnqualComponentName $ field a + , unUnqualComponentName $ field b + ) of + ("", _) -> field b + (_, "") -> field a + (x, y) -> + error $ + "Ambiguous values for executable field: '" + ++ x + ++ "' and '" + ++ y + ++ "'" emptyExecutable :: Executable emptyExecutable = mempty diff --git a/Cabal-syntax/src/Distribution/Types/Executable/Lens.hs b/Cabal-syntax/src/Distribution/Types/Executable/Lens.hs index 36813072e69..73410519e90 100644 --- a/Cabal-syntax/src/Distribution/Types/Executable/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/Executable/Lens.hs @@ -1,31 +1,31 @@ -module Distribution.Types.Executable.Lens ( - Executable, - module Distribution.Types.Executable.Lens, - ) where +module Distribution.Types.Executable.Lens + ( Executable + , module Distribution.Types.Executable.Lens + ) where import Distribution.Compat.Lens import Distribution.Compat.Prelude import Prelude () -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.Executable (Executable) -import Distribution.Types.ExecutableScope (ExecutableScope) +import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.Executable (Executable) +import Distribution.Types.ExecutableScope (ExecutableScope) import Distribution.Types.UnqualComponentName (UnqualComponentName) import qualified Distribution.Types.Executable as T exeName :: Lens' Executable UnqualComponentName -exeName f s = fmap (\x -> s { T.exeName = x }) (f (T.exeName s)) +exeName f s = fmap (\x -> s{T.exeName = x}) (f (T.exeName s)) {-# INLINE exeName #-} modulePath :: Lens' Executable String -modulePath f s = fmap (\x -> s { T.modulePath = x }) (f (T.modulePath s)) +modulePath f s = fmap (\x -> s{T.modulePath = x}) (f (T.modulePath s)) {-# INLINE modulePath #-} exeScope :: Lens' Executable ExecutableScope -exeScope f s = fmap (\x -> s { T.exeScope = x }) (f (T.exeScope s)) +exeScope f s = fmap (\x -> s{T.exeScope = x}) (f (T.exeScope s)) {-# INLINE exeScope #-} exeBuildInfo :: Lens' Executable BuildInfo -exeBuildInfo f s = fmap (\x -> s { T.buildInfo = x }) (f (T.buildInfo s)) +exeBuildInfo f s = fmap (\x -> s{T.buildInfo = x}) (f (T.buildInfo s)) {-# INLINE exeBuildInfo #-} diff --git a/Cabal-syntax/src/Distribution/Types/ExecutableScope.hs b/Cabal-syntax/src/Distribution/Types/ExecutableScope.hs index 520261692c6..1221fae1c1a 100644 --- a/Cabal-syntax/src/Distribution/Types/ExecutableScope.hs +++ b/Cabal-syntax/src/Distribution/Types/ExecutableScope.hs @@ -2,31 +2,33 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -module Distribution.Types.ExecutableScope ( - ExecutableScope(..), -) where +module Distribution.Types.ExecutableScope + ( ExecutableScope (..) + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Pretty import Distribution.Parsec +import Distribution.Pretty import qualified Distribution.Compat.CharParsing as P import qualified Text.PrettyPrint as Disp -data ExecutableScope = ExecutablePublic - | ExecutablePrivate - deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) +data ExecutableScope + = ExecutablePublic + | ExecutablePrivate + deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) instance Pretty ExecutableScope where - pretty ExecutablePublic = Disp.text "public" - pretty ExecutablePrivate = Disp.text "private" + pretty ExecutablePublic = Disp.text "public" + pretty ExecutablePrivate = Disp.text "private" instance Parsec ExecutableScope where - parsec = P.try pub <|> pri where - pub = ExecutablePublic <$ P.string "public" - pri = ExecutablePrivate <$ P.string "private" + parsec = P.try pub <|> pri + where + pub = ExecutablePublic <$ P.string "public" + pri = ExecutablePrivate <$ P.string "private" instance Binary ExecutableScope instance Structured ExecutableScope @@ -34,10 +36,10 @@ instance NFData ExecutableScope where rnf = genericRnf -- | 'Any' like semigroup, where 'ExecutablePrivate' is 'Any True' instance Semigroup ExecutableScope where - ExecutablePublic <> x = x - x@ExecutablePrivate <> _ = x + ExecutablePublic <> x = x + x@ExecutablePrivate <> _ = x -- | 'mempty' = 'ExecutablePublic' instance Monoid ExecutableScope where - mempty = ExecutablePublic - mappend = (<>) + mempty = ExecutablePublic + mappend = (<>) diff --git a/Cabal-syntax/src/Distribution/Types/ExposedModule.hs b/Cabal-syntax/src/Distribution/Types/ExposedModule.hs index 22f8d7b9803..4afd03a3263 100644 --- a/Cabal-syntax/src/Distribution/Types/ExposedModule.hs +++ b/Cabal-syntax/src/Distribution/Types/ExposedModule.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} + module Distribution.Types.ExposedModule where import Distribution.Compat.Prelude @@ -11,34 +12,34 @@ import Distribution.Parsec import Distribution.Pretty import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp +import qualified Text.PrettyPrint as Disp -data ExposedModule - = ExposedModule { - exposedName :: ModuleName, - exposedReexport :: Maybe OpenModule - } +data ExposedModule = ExposedModule + { exposedName :: ModuleName + , exposedReexport :: Maybe OpenModule + } deriving (Eq, Generic, Read, Show, Typeable) instance Pretty ExposedModule where - pretty (ExposedModule m reexport) = - Disp.hsep [ pretty m - , case reexport of - Just m' -> Disp.hsep [Disp.text "from", pretty m'] - Nothing -> Disp.empty - ] + pretty (ExposedModule m reexport) = + Disp.hsep + [ pretty m + , case reexport of + Just m' -> Disp.hsep [Disp.text "from", pretty m'] + Nothing -> Disp.empty + ] instance Parsec ExposedModule where - parsec = do - m <- parsecMaybeQuoted parsec - P.spaces + parsec = do + m <- parsecMaybeQuoted parsec + P.spaces - reexport <- P.optional $ do - _ <- P.string "from" - P.skipSpaces1 - parsec + reexport <- P.optional $ do + _ <- P.string "from" + P.skipSpaces1 + parsec - return (ExposedModule m reexport) + return (ExposedModule m reexport) instance Binary ExposedModule instance Structured ExposedModule diff --git a/Cabal-syntax/src/Distribution/Types/Flag.hs b/Cabal-syntax/src/Distribution/Types/Flag.hs index 83cff4e0639..eff71748d9f 100644 --- a/Cabal-syntax/src/Distribution/Types/Flag.hs +++ b/Cabal-syntax/src/Distribution/Types/Flag.hs @@ -1,45 +1,49 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Distribution.Types.Flag ( - -- * Package flag - PackageFlag(..), - emptyFlag, + +module Distribution.Types.Flag + ( -- * Package flag + PackageFlag (..) + , emptyFlag + -- * Flag name - FlagName, - mkFlagName, - unFlagName, + , FlagName + , mkFlagName + , unFlagName + -- * Flag assignment - FlagAssignment, - mkFlagAssignment, - unFlagAssignment, - lookupFlagAssignment, - insertFlagAssignment, - diffFlagAssignment, - findDuplicateFlagAssignments, - nullFlagAssignment, - showFlagValue, - dispFlagAssignment, - showFlagAssignment, - parsecFlagAssignment, - parsecFlagAssignmentNonEmpty, + , FlagAssignment + , mkFlagAssignment + , unFlagAssignment + , lookupFlagAssignment + , insertFlagAssignment + , diffFlagAssignment + , findDuplicateFlagAssignments + , nullFlagAssignment + , showFlagValue + , dispFlagAssignment + , showFlagAssignment + , parsecFlagAssignment + , parsecFlagAssignmentNonEmpty + -- ** Legacy formats - legacyShowFlagAssignment, - legacyShowFlagAssignment', - legacyParsecFlagAssignment, - ) where + , legacyShowFlagAssignment + , legacyShowFlagAssignment' + , legacyParsecFlagAssignment + ) where -import Prelude () import Distribution.Compat.Prelude -import Distribution.Utils.ShortText import Distribution.Utils.Generic (lowercase) +import Distribution.Utils.ShortText +import Prelude () import Distribution.Parsec import Distribution.Pretty import qualified Data.Map as Map -import qualified Text.PrettyPrint as Disp import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp -- ----------------------------------------------------------------------------- -- The Flag' type @@ -47,12 +51,12 @@ import qualified Distribution.Compat.CharParsing as P -- | A flag can represent a feature to be included, or a way of linking -- a target against its dependencies, or in fact whatever you can think of. data PackageFlag = MkPackageFlag - { flagName :: FlagName - , flagDescription :: String - , flagDefault :: Bool - , flagManual :: Bool - } - deriving (Show, Eq, Typeable, Data, Generic) + { flagName :: FlagName + , flagDescription :: String + , flagDefault :: Bool + , flagManual :: Bool + } + deriving (Show, Eq, Typeable, Data, Generic) instance Binary PackageFlag instance Structured PackageFlag @@ -60,11 +64,12 @@ instance NFData PackageFlag where rnf = genericRnf -- | A 'PackageFlag' initialized with default parameters. emptyFlag :: FlagName -> PackageFlag -emptyFlag name = MkPackageFlag - { flagName = name +emptyFlag name = + MkPackageFlag + { flagName = name , flagDescription = "" - , flagDefault = True - , flagManual = False + , flagDefault = True + , flagManual = False } -- | A 'FlagName' is the name of a user-defined configuration flag @@ -75,7 +80,7 @@ emptyFlag name = MkPackageFlag -- -- @since 2.0.0.2 newtype FlagName = FlagName ShortText - deriving (Eq, Generic, Ord, Show, Read, Typeable, Data, NFData) + deriving (Eq, Generic, Ord, Show, Read, Typeable, Data, NFData) -- | Construct a 'FlagName' from a 'String' -- @@ -92,7 +97,7 @@ mkFlagName = FlagName . toShortText -- -- @since 2.0.0.2 instance IsString FlagName where - fromString = mkFlagName + fromString = mkFlagName -- | Convert 'FlagName' to 'String' -- @@ -104,16 +109,16 @@ instance Binary FlagName instance Structured FlagName instance Pretty FlagName where - pretty = Disp.text . unFlagName + pretty = Disp.text . unFlagName instance Parsec FlagName where - -- Note: we don't check that FlagName doesn't have leading dash, - -- cabal check will do that. - parsec = mkFlagName . lowercase <$> parsec' - where - parsec' = (:) <$> lead <*> rest - lead = P.satisfy (\c -> isAlphaNum c || c == '_') - rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-') + -- Note: we don't check that FlagName doesn't have leading dash, + -- cabal check will do that. + parsec = mkFlagName . lowercase <$> parsec' + where + parsec' = (:) <$> lead <*> rest + lead = P.satisfy (\c -> isAlphaNum c || c == '_') + rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-') -- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to -- 'Bool' flag values. It represents the flags chosen by the user or @@ -121,26 +126,23 @@ instance Parsec FlagName where -- becomes @[("foo", True), ("bar", False)]@ -- -- TODO: Why we record the multiplicity of the flag? --- -newtype FlagAssignment - = FlagAssignment { getFlagAssignment :: Map.Map FlagName (Int, Bool) } +newtype FlagAssignment = FlagAssignment {getFlagAssignment :: Map.Map FlagName (Int, Bool)} deriving (Binary, Generic, NFData, Typeable) instance Structured FlagAssignment instance Eq FlagAssignment where - (==) (FlagAssignment m1) (FlagAssignment m2) - = fmap snd m1 == fmap snd m2 + (==) (FlagAssignment m1) (FlagAssignment m2) = + fmap snd m1 == fmap snd m2 instance Ord FlagAssignment where - compare (FlagAssignment m1) (FlagAssignment m2) - = fmap snd m1 `compare` fmap snd m2 + compare (FlagAssignment m1) (FlagAssignment m2) = + fmap snd m1 `compare` fmap snd m2 -- | Combines pairs of values contained in the 'FlagAssignment' Map. -- -- The last flag specified takes precedence, and we record the number -- of times we have seen the flag. --- combineFlagValues :: (Int, Bool) -> (Int, Bool) -> (Int, Bool) combineFlagValues (c1, _) (c2, b2) = (c1 + c2, b2) @@ -151,8 +153,8 @@ combineFlagValues (c1, _) (c2, b2) = (c1 + c2, b2) -- specified so that we have the option of warning the user about -- supplying duplicate flags. instance Semigroup FlagAssignment where - (<>) (FlagAssignment m1) (FlagAssignment m2) - = FlagAssignment (Map.unionWith combineFlagValues m1 m2) + (<>) (FlagAssignment m1) (FlagAssignment m2) = + FlagAssignment (Map.unionWith combineFlagValues m1 m2) instance Monoid FlagAssignment where mempty = FlagAssignment Map.empty @@ -166,8 +168,9 @@ instance Monoid FlagAssignment where -- @since 2.2.0 mkFlagAssignment :: [(FlagName, Bool)] -> FlagAssignment mkFlagAssignment = - FlagAssignment . - Map.fromListWith (flip combineFlagValues) . fmap (fmap (\b -> (1, b))) + FlagAssignment + . Map.fromListWith (flip combineFlagValues) + . fmap (fmap (\b -> (1, b))) -- | Deconstruct a 'FlagAssignment' into a list of flag/value pairs. -- @@ -204,8 +207,9 @@ insertFlagAssignment :: FlagName -> Bool -> FlagAssignment -> FlagAssignment -- flag; rather than enforcing uniqueness at construction, it's -- verified later on via `D.C.Dependency.configuredPackageProblems` insertFlagAssignment flag val = - FlagAssignment . - Map.insertWith (flip combineFlagValues) flag (1, val) . getFlagAssignment + FlagAssignment + . Map.insertWith (flip combineFlagValues) flag (1, val) + . getFlagAssignment -- | Remove all flag-assignments from the first 'FlagAssignment' that -- are contained in the second 'FlagAssignment' @@ -217,8 +221,9 @@ insertFlagAssignment flag val = -- -- @since 2.2.0 diffFlagAssignment :: FlagAssignment -> FlagAssignment -> FlagAssignment -diffFlagAssignment fa1 fa2 = FlagAssignment - (Map.difference (getFlagAssignment fa1) (getFlagAssignment fa2)) +diffFlagAssignment fa1 fa2 = + FlagAssignment + (Map.difference (getFlagAssignment fa1) (getFlagAssignment fa2)) -- | Find the 'FlagName's that have been listed more than once. -- @@ -229,20 +234,20 @@ findDuplicateFlagAssignments = -- | @since 2.2.0 instance Read FlagAssignment where - readsPrec p s = [ (FlagAssignment x, rest) | (x,rest) <- readsPrec p s ] + readsPrec p s = [(FlagAssignment x, rest) | (x, rest) <- readsPrec p s] -- | @since 2.2.0 instance Show FlagAssignment where - showsPrec p (FlagAssignment xs) = showsPrec p xs + showsPrec p (FlagAssignment xs) = showsPrec p xs -- | String representation of a flag-value pair. showFlagValue :: (FlagName, Bool) -> String -showFlagValue (f, True) = '+' : unFlagName f -showFlagValue (f, False) = '-' : unFlagName f +showFlagValue (f, True) = '+' : unFlagName f +showFlagValue (f, False) = '-' : unFlagName f -- | @since 3.4.0.0 instance Pretty FlagAssignment where - pretty = dispFlagAssignment + pretty = dispFlagAssignment -- | -- @@ -273,33 +278,31 @@ instance Pretty FlagAssignment where -- Nothing -- -- @since 3.4.0.0 --- instance Parsec FlagAssignment where - parsec = parsecFlagAssignment + parsec = parsecFlagAssignment -- | Pretty-prints a flag assignment. dispFlagAssignment :: FlagAssignment -> Disp.Doc dispFlagAssignment = Disp.hsep . map (Disp.text . showFlagValue) . unFlagAssignment - - -- | Parses a flag assignment. parsecFlagAssignment :: CabalParsing m => m FlagAssignment parsecFlagAssignment = mkFlagAssignment <$> sepByEnding (onFlag <|> offFlag) P.skipSpaces1 where onFlag = do - _ <- P.char '+' - f <- parsec - return (f, True) + _ <- P.char '+' + f <- parsec + return (f, True) offFlag = do - _ <- P.char '-' - f <- parsec - return (f, False) + _ <- P.char '-' + f <- parsec + return (f, False) sepByEnding :: CabalParsing m => m a -> m b -> m [a] - sepByEnding p sep = afterSeparator where - element = (:) <$> p <*> afterElement - afterElement = sep *> afterSeparator <|> pure [] + sepByEnding p sep = afterSeparator + where + element = (:) <$> p <*> afterElement + afterElement = sep *> afterSeparator <|> pure [] afterSeparator = element <|> pure [] -- | Parse a non-empty flag assignment @@ -311,18 +314,19 @@ parsecFlagAssignmentNonEmpty :: CabalParsing m => m FlagAssignment parsecFlagAssignmentNonEmpty = mkFlagAssignment <$> sepByEnding1 (onFlag <|> offFlag) P.skipSpaces1 where onFlag = do - _ <- P.char '+' - f <- parsec - return (f, True) + _ <- P.char '+' + f <- parsec + return (f, True) offFlag = do - _ <- P.char '-' - f <- parsec - return (f, False) + _ <- P.char '-' + f <- parsec + return (f, False) sepByEnding1 :: CabalParsing m => m a -> m b -> m [a] - sepByEnding1 p sep = element where - element = (:) <$> p <*> afterElement - afterElement = sep *> afterSeparator <|> pure [] + sepByEnding1 p sep = element + where + element = (:) <$> p <*> afterElement + afterElement = sep *> afterSeparator <|> pure [] afterSeparator = element <|> pure [] -- | Show flag assignment. @@ -340,7 +344,7 @@ showFlagAssignment = prettyShow . dispFlagAssignment -- @since 3.4.0.0 legacyShowFlagAssignment :: FlagAssignment -> String legacyShowFlagAssignment = - prettyShow . Disp.hsep . map Disp.text . legacyShowFlagAssignment' + prettyShow . Disp.hsep . map Disp.text . legacyShowFlagAssignment' -- | @since 3.4.0.0 legacyShowFlagAssignment' :: FlagAssignment -> [String] @@ -348,22 +352,23 @@ legacyShowFlagAssignment' = map legacyShowFlagValue . unFlagAssignment -- | @since 3.4.0.0 legacyShowFlagValue :: (FlagName, Bool) -> String -legacyShowFlagValue (f, True) = unFlagName f -legacyShowFlagValue (f, False) = '-' : unFlagName f +legacyShowFlagValue (f, True) = unFlagName f +legacyShowFlagValue (f, False) = '-' : unFlagName f -- | -- We need this as far as we support custom setups older than 2.2.0.0 -- -- @since 3.4.0.0 legacyParsecFlagAssignment :: CabalParsing m => m FlagAssignment -legacyParsecFlagAssignment = mkFlagAssignment <$> - P.sepBy (onFlag <|> offFlag) P.skipSpaces1 +legacyParsecFlagAssignment = + mkFlagAssignment + <$> P.sepBy (onFlag <|> offFlag) P.skipSpaces1 where onFlag = do - _ <- P.optional (P.char '+') - f <- parsec - return (f, True) + _ <- P.optional (P.char '+') + f <- parsec + return (f, True) offFlag = do - _ <- P.char '-' - f <- parsec - return (f, False) + _ <- P.char '-' + f <- parsec + return (f, False) diff --git a/Cabal-syntax/src/Distribution/Types/ForeignLib.hs b/Cabal-syntax/src/Distribution/Types/ForeignLib.hs index d1883483d5f..9d714f9895f 100644 --- a/Cabal-syntax/src/Distribution/Types/ForeignLib.hs +++ b/Cabal-syntax/src/Distribution/Types/ForeignLib.hs @@ -1,20 +1,19 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.ForeignLib( - ForeignLib(..), - emptyForeignLib, - foreignLibModules, - foreignLibIsShared, - foreignLibVersion, - - LibVersionInfo, - mkLibVersionInfo, - libVersionInfoCRA, - libVersionNumber, - libVersionNumberShow, - libVersionMajor -) where +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Types.ForeignLib + ( ForeignLib (..) + , emptyForeignLib + , foreignLibModules + , foreignLibIsShared + , foreignLibVersion + , LibVersionInfo + , mkLibVersionInfo + , libVersionInfoCRA + , libVersionNumber + , libVersionNumberShow + , libVersionMajor + ) where import Distribution.Compat.Prelude import Prelude () @@ -30,76 +29,76 @@ import Distribution.Types.UnqualComponentName import Distribution.Version import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp -import qualified Text.Read as Read +import qualified Text.PrettyPrint as Disp +import qualified Text.Read as Read import qualified Distribution.Types.BuildInfo.Lens as L -- | A foreign library stanza is like a library stanza, except that -- the built code is intended for consumption by a non-Haskell client. -data ForeignLib = ForeignLib { - -- | Name of the foreign library - foreignLibName :: UnqualComponentName - -- | What kind of foreign library is this (static or dynamic). - , foreignLibType :: ForeignLibType - -- | What options apply to this foreign library (e.g., are we - -- merging in all foreign dependencies.) - , foreignLibOptions :: [ForeignLibOption] - -- | Build information for this foreign library. - , foreignLibBuildInfo :: BuildInfo - -- | Libtool-style version-info data to compute library version. - -- Refer to the libtool documentation on the - -- current:revision:age versioning scheme. - , foreignLibVersionInfo :: Maybe LibVersionInfo - -- | Linux library version - , foreignLibVersionLinux :: Maybe Version - - -- | (Windows-specific) module definition files - -- - -- This is a list rather than a maybe field so that we can flatten - -- the condition trees (for instance, when creating an sdist) - , foreignLibModDefFile :: [FilePath] - } - deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) +data ForeignLib = ForeignLib + { foreignLibName :: UnqualComponentName + -- ^ Name of the foreign library + , foreignLibType :: ForeignLibType + -- ^ What kind of foreign library is this (static or dynamic). + , foreignLibOptions :: [ForeignLibOption] + -- ^ What options apply to this foreign library (e.g., are we + -- merging in all foreign dependencies.) + , foreignLibBuildInfo :: BuildInfo + -- ^ Build information for this foreign library. + , foreignLibVersionInfo :: Maybe LibVersionInfo + -- ^ Libtool-style version-info data to compute library version. + -- Refer to the libtool documentation on the + -- current:revision:age versioning scheme. + , foreignLibVersionLinux :: Maybe Version + -- ^ Linux library version + , foreignLibModDefFile :: [FilePath] + -- ^ (Windows-specific) module definition files + -- + -- This is a list rather than a maybe field so that we can flatten + -- the condition trees (for instance, when creating an sdist) + } + deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) data LibVersionInfo = LibVersionInfo Int Int Int deriving (Data, Eq, Generic, Typeable) instance Ord LibVersionInfo where - LibVersionInfo c r _ `compare` LibVersionInfo c' r' _ = - case c `compare` c' of - EQ -> r `compare` r' - e -> e + LibVersionInfo c r _ `compare` LibVersionInfo c' r' _ = + case c `compare` c' of + EQ -> r `compare` r' + e -> e instance Show LibVersionInfo where - showsPrec d (LibVersionInfo c r a) = showParen (d > 10) - $ showString "mkLibVersionInfo " - . showsPrec 11 (c,r,a) + showsPrec d (LibVersionInfo c r a) = + showParen (d > 10) $ + showString "mkLibVersionInfo " + . showsPrec 11 (c, r, a) instance Read LibVersionInfo where - readPrec = Read.parens $ do - Read.Ident "mkLibVersionInfo" <- Read.lexP - t <- Read.step Read.readPrec - return (mkLibVersionInfo t) + readPrec = Read.parens $ do + Read.Ident "mkLibVersionInfo" <- Read.lexP + t <- Read.step Read.readPrec + return (mkLibVersionInfo t) instance Binary LibVersionInfo instance Structured LibVersionInfo instance NFData LibVersionInfo where rnf = genericRnf instance Pretty LibVersionInfo where - pretty (LibVersionInfo c r a) - = Disp.hcat $ Disp.punctuate (Disp.char ':') $ map Disp.int [c,r,a] + pretty (LibVersionInfo c r a) = + Disp.hcat $ Disp.punctuate (Disp.char ':') $ map Disp.int [c, r, a] instance Parsec LibVersionInfo where - parsec = do - c <- P.integral - (r, a) <- P.option (0,0) $ do - _ <- P.char ':' - r <- P.integral - a <- P.option 0 $ do - _ <- P.char ':' - P.integral - return (r,a) - return $ mkLibVersionInfo (c,r,a) + parsec = do + c <- P.integral + (r, a) <- P.option (0, 0) $ do + _ <- P.char ':' + r <- P.integral + a <- P.option 0 $ do + _ <- P.char ':' + P.integral + return (r, a) + return $ mkLibVersionInfo (c, r, a) -- | Construct 'LibVersionInfo' from @(current, revision, age)@ -- numbers. @@ -109,64 +108,73 @@ instance Parsec LibVersionInfo where -- -- All version components must be non-negative. mkLibVersionInfo :: (Int, Int, Int) -> LibVersionInfo -mkLibVersionInfo (c,r,a) = LibVersionInfo c r a +mkLibVersionInfo (c, r, a) = LibVersionInfo c r a -- | From a given 'LibVersionInfo', extract the @(current, revision, -- age)@ numbers. libVersionInfoCRA :: LibVersionInfo -> (Int, Int, Int) -libVersionInfoCRA (LibVersionInfo c r a) = (c,r,a) +libVersionInfoCRA (LibVersionInfo c r a) = (c, r, a) -- | Given a version-info field, produce a @major.minor.build@ version libVersionNumber :: LibVersionInfo -> (Int, Int, Int) -libVersionNumber (LibVersionInfo c r a) = (c-a , a , r) +libVersionNumber (LibVersionInfo c r a) = (c - a, a, r) -- | Given a version-info field, return @"major.minor.build"@ as a -- 'String' libVersionNumberShow :: LibVersionInfo -> String libVersionNumberShow v = - let (major, minor, build) = libVersionNumber v - in show major ++ "." ++ show minor ++ "." ++ show build + let (major, minor, build) = libVersionNumber v + in show major ++ "." ++ show minor ++ "." ++ show build -- | Return the @major@ version of a version-info field. libVersionMajor :: LibVersionInfo -> Int -libVersionMajor (LibVersionInfo c _ a) = c-a +libVersionMajor (LibVersionInfo c _ a) = c - a instance L.HasBuildInfo ForeignLib where - buildInfo f l = (\x -> l { foreignLibBuildInfo = x }) <$> f (foreignLibBuildInfo l) + buildInfo f l = (\x -> l{foreignLibBuildInfo = x}) <$> f (foreignLibBuildInfo l) instance Binary ForeignLib instance Structured ForeignLib instance NFData ForeignLib where rnf = genericRnf instance Semigroup ForeignLib where - a <> b = ForeignLib { - foreignLibName = combine' foreignLibName - , foreignLibType = combine foreignLibType - , foreignLibOptions = combine foreignLibOptions - , foreignLibBuildInfo = combine foreignLibBuildInfo - , foreignLibVersionInfo = combine'' foreignLibVersionInfo - , foreignLibVersionLinux = combine'' foreignLibVersionLinux - , foreignLibModDefFile = combine foreignLibModDefFile - } - where combine field = field a `mappend` field b - combine' field = case ( unUnqualComponentName $ field a - , unUnqualComponentName $ field b) of - ("", _) -> field b - (_, "") -> field a - (x, y) -> error $ "Ambiguous values for executable field: '" - ++ x ++ "' and '" ++ y ++ "'" - combine'' field = field b + a <> b = + ForeignLib + { foreignLibName = combine' foreignLibName + , foreignLibType = combine foreignLibType + , foreignLibOptions = combine foreignLibOptions + , foreignLibBuildInfo = combine foreignLibBuildInfo + , foreignLibVersionInfo = combine'' foreignLibVersionInfo + , foreignLibVersionLinux = combine'' foreignLibVersionLinux + , foreignLibModDefFile = combine foreignLibModDefFile + } + where + combine field = field a `mappend` field b + combine' field = case ( unUnqualComponentName $ field a + , unUnqualComponentName $ field b + ) of + ("", _) -> field b + (_, "") -> field a + (x, y) -> + error $ + "Ambiguous values for executable field: '" + ++ x + ++ "' and '" + ++ y + ++ "'" + combine'' field = field b instance Monoid ForeignLib where - mempty = ForeignLib { - foreignLibName = mempty - , foreignLibType = ForeignLibTypeUnknown - , foreignLibOptions = [] - , foreignLibBuildInfo = mempty - , foreignLibVersionInfo = Nothing - , foreignLibVersionLinux = Nothing - , foreignLibModDefFile = [] - } + mempty = + ForeignLib + { foreignLibName = mempty + , foreignLibType = ForeignLibTypeUnknown + , foreignLibOptions = [] + , foreignLibBuildInfo = mempty + , foreignLibVersionInfo = Nothing + , foreignLibVersionLinux = Nothing + , foreignLibModDefFile = [] + } mappend = (<>) -- | An empty foreign library. @@ -189,11 +197,11 @@ foreignLibIsShared = foreignLibTypeIsShared . foreignLibType foreignLibVersion :: ForeignLib -> OS -> [Int] foreignLibVersion flib Linux = case foreignLibVersionLinux flib of - Just v -> versionNumbers v + Just v -> versionNumbers v Nothing -> case foreignLibVersionInfo flib of Just v' -> let (major, minor, build) = libVersionNumber v' - in [major, minor, build] + in [major, minor, build] Nothing -> [] foreignLibVersion _ _ = [] diff --git a/Cabal-syntax/src/Distribution/Types/ForeignLib/Lens.hs b/Cabal-syntax/src/Distribution/Types/ForeignLib/Lens.hs index fe2df57733c..a5905af2ff8 100644 --- a/Cabal-syntax/src/Distribution/Types/ForeignLib/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/ForeignLib/Lens.hs @@ -1,45 +1,45 @@ -module Distribution.Types.ForeignLib.Lens ( - ForeignLib, - module Distribution.Types.ForeignLib.Lens, - ) where +module Distribution.Types.ForeignLib.Lens + ( ForeignLib + , module Distribution.Types.ForeignLib.Lens + ) where import Distribution.Compat.Lens import Distribution.Compat.Prelude import Prelude () -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.ForeignLib (ForeignLib, LibVersionInfo) -import Distribution.Types.ForeignLibOption (ForeignLibOption) -import Distribution.Types.ForeignLibType (ForeignLibType) +import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.ForeignLib (ForeignLib, LibVersionInfo) +import Distribution.Types.ForeignLibOption (ForeignLibOption) +import Distribution.Types.ForeignLibType (ForeignLibType) import Distribution.Types.UnqualComponentName (UnqualComponentName) -import Distribution.Version (Version) +import Distribution.Version (Version) import qualified Distribution.Types.ForeignLib as T foreignLibName :: Lens' ForeignLib UnqualComponentName -foreignLibName f s = fmap (\x -> s { T.foreignLibName = x }) (f (T.foreignLibName s)) +foreignLibName f s = fmap (\x -> s{T.foreignLibName = x}) (f (T.foreignLibName s)) {-# INLINE foreignLibName #-} foreignLibType :: Lens' ForeignLib ForeignLibType -foreignLibType f s = fmap (\x -> s { T.foreignLibType = x }) (f (T.foreignLibType s)) +foreignLibType f s = fmap (\x -> s{T.foreignLibType = x}) (f (T.foreignLibType s)) {-# INLINE foreignLibType #-} foreignLibOptions :: Lens' ForeignLib [ForeignLibOption] -foreignLibOptions f s = fmap (\x -> s { T.foreignLibOptions = x }) (f (T.foreignLibOptions s)) +foreignLibOptions f s = fmap (\x -> s{T.foreignLibOptions = x}) (f (T.foreignLibOptions s)) {-# INLINE foreignLibOptions #-} foreignLibBuildInfo :: Lens' ForeignLib BuildInfo -foreignLibBuildInfo f s = fmap (\x -> s { T.foreignLibBuildInfo = x }) (f (T.foreignLibBuildInfo s)) +foreignLibBuildInfo f s = fmap (\x -> s{T.foreignLibBuildInfo = x}) (f (T.foreignLibBuildInfo s)) {-# INLINE foreignLibBuildInfo #-} foreignLibVersionInfo :: Lens' ForeignLib (Maybe LibVersionInfo) -foreignLibVersionInfo f s = fmap (\x -> s { T.foreignLibVersionInfo = x }) (f (T.foreignLibVersionInfo s)) +foreignLibVersionInfo f s = fmap (\x -> s{T.foreignLibVersionInfo = x}) (f (T.foreignLibVersionInfo s)) {-# INLINE foreignLibVersionInfo #-} foreignLibVersionLinux :: Lens' ForeignLib (Maybe Version) -foreignLibVersionLinux f s = fmap (\x -> s { T.foreignLibVersionLinux = x }) (f (T.foreignLibVersionLinux s)) +foreignLibVersionLinux f s = fmap (\x -> s{T.foreignLibVersionLinux = x}) (f (T.foreignLibVersionLinux s)) {-# INLINE foreignLibVersionLinux #-} foreignLibModDefFile :: Lens' ForeignLib [FilePath] -foreignLibModDefFile f s = fmap (\x -> s { T.foreignLibModDefFile = x }) (f (T.foreignLibModDefFile s)) +foreignLibModDefFile f s = fmap (\x -> s{T.foreignLibModDefFile = x}) (f (T.foreignLibModDefFile s)) {-# INLINE foreignLibModDefFile #-} diff --git a/Cabal-syntax/src/Distribution/Types/ForeignLibOption.hs b/Cabal-syntax/src/Distribution/Types/ForeignLibOption.hs index 4b9a2bc2c66..5ed65410e70 100644 --- a/Cabal-syntax/src/Distribution/Types/ForeignLibOption.hs +++ b/Cabal-syntax/src/Distribution/Types/ForeignLibOption.hs @@ -2,27 +2,27 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -module Distribution.Types.ForeignLibOption( - ForeignLibOption(..) -) where +module Distribution.Types.ForeignLibOption + ( ForeignLibOption (..) + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Pretty import Distribution.Parsec +import Distribution.Pretty import qualified Distribution.Compat.CharParsing as P import qualified Text.PrettyPrint as Disp -data ForeignLibOption = - -- | Merge in all dependent libraries (i.e., use - -- @ghc -shared -static@ rather than just record - -- the dependencies, ala @ghc -shared -dynamic@). - -- This option is compulsory on Windows and unsupported - -- on other platforms. - ForeignLibStandalone - deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) +data ForeignLibOption + = -- | Merge in all dependent libraries (i.e., use + -- @ghc -shared -static@ rather than just record + -- the dependencies, ala @ghc -shared -dynamic@). + -- This option is compulsory on Windows and unsupported + -- on other platforms. + ForeignLibStandalone + deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) instance Pretty ForeignLibOption where pretty ForeignLibStandalone = Disp.text "standalone" @@ -32,7 +32,7 @@ instance Parsec ForeignLibOption where name <- P.munch1 (\c -> isAlphaNum c || c == '-') case name of "standalone" -> return ForeignLibStandalone - _ -> fail "unrecognized foreign-library option" + _ -> fail "unrecognized foreign-library option" instance Binary ForeignLibOption instance Structured ForeignLibOption diff --git a/Cabal-syntax/src/Distribution/Types/ForeignLibType.hs b/Cabal-syntax/src/Distribution/Types/ForeignLibType.hs index d5d80d97cba..23617b80c48 100644 --- a/Cabal-syntax/src/Distribution/Types/ForeignLibType.hs +++ b/Cabal-syntax/src/Distribution/Types/ForeignLibType.hs @@ -2,37 +2,37 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -module Distribution.Types.ForeignLibType( - ForeignLibType(..), - knownForeignLibTypes, - foreignLibTypeIsShared, -) where +module Distribution.Types.ForeignLibType + ( ForeignLibType (..) + , knownForeignLibTypes + , foreignLibTypeIsShared + ) where -import Prelude () import Distribution.Compat.Prelude import Distribution.PackageDescription.Utils +import Prelude () -import Distribution.Pretty import Distribution.Parsec +import Distribution.Pretty import qualified Distribution.Compat.CharParsing as P import qualified Text.PrettyPrint as Disp -- | What kind of foreign library is to be built? -data ForeignLibType = - -- | A native shared library (@.so@ on Linux, @.dylib@ on OSX, or - -- @.dll@ on Windows). - ForeignLibNativeShared - -- | A native static library (not currently supported.) - | ForeignLibNativeStatic - -- TODO: Maybe this should record a string? - | ForeignLibTypeUnknown - deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) +data ForeignLibType + = -- | A native shared library (@.so@ on Linux, @.dylib@ on OSX, or + -- @.dll@ on Windows). + ForeignLibNativeShared + | -- | A native static library (not currently supported.) + ForeignLibNativeStatic + | -- TODO: Maybe this should record a string? + ForeignLibTypeUnknown + deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) instance Pretty ForeignLibType where pretty ForeignLibNativeShared = Disp.text "native-shared" pretty ForeignLibNativeStatic = Disp.text "native-static" - pretty ForeignLibTypeUnknown = Disp.text "unknown" + pretty ForeignLibTypeUnknown = Disp.text "unknown" instance Parsec ForeignLibType where parsec = do @@ -40,7 +40,7 @@ instance Parsec ForeignLibType where return $ case name of "native-shared" -> ForeignLibNativeShared "native-static" -> ForeignLibNativeStatic - _ -> ForeignLibTypeUnknown + _ -> ForeignLibTypeUnknown instance Binary ForeignLibType instance Structured ForeignLibType @@ -56,14 +56,14 @@ instance Monoid ForeignLibType where mappend = (<>) knownForeignLibTypes :: [ForeignLibType] -knownForeignLibTypes = [ - ForeignLibNativeShared - , ForeignLibNativeStatic - ] +knownForeignLibTypes = + [ ForeignLibNativeShared + , ForeignLibNativeStatic + ] foreignLibTypeIsShared :: ForeignLibType -> Bool foreignLibTypeIsShared t = - case t of - ForeignLibNativeShared -> True - ForeignLibNativeStatic -> False - ForeignLibTypeUnknown -> cabalBug "Unknown foreign library type" + case t of + ForeignLibNativeShared -> True + ForeignLibNativeStatic -> False + ForeignLibTypeUnknown -> cabalBug "Unknown foreign library type" diff --git a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs index ee8f9d5284b..55ec8652304 100644 --- a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs +++ b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs @@ -3,62 +3,75 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Types.GenericPackageDescription ( - GenericPackageDescription(..), - emptyGenericPackageDescription, -) where +module Distribution.Types.GenericPackageDescription + ( GenericPackageDescription (..) + , emptyGenericPackageDescription + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -- lens -import Distribution.Compat.Lens as L -import qualified Distribution.Types.BuildInfo.Lens as L +import Distribution.Compat.Lens as L +import qualified Distribution.Types.BuildInfo.Lens as L import Distribution.Types.PackageDescription +import Distribution.Package import Distribution.Types.Benchmark import Distribution.Types.CondTree import Distribution.Types.ConfVar -import Distribution.Types.Dependency import Distribution.Types.Executable import Distribution.Types.Flag import Distribution.Types.ForeignLib import Distribution.Types.Library import Distribution.Types.TestSuite import Distribution.Types.UnqualComponentName -import Distribution.Package import Distribution.Version -- --------------------------------------------------------------------------- -- The 'GenericPackageDescription' type -data GenericPackageDescription = - GenericPackageDescription +data GenericPackageDescription = GenericPackageDescription { packageDescription :: PackageDescription - , gpdScannedVersion :: Maybe Version - -- ^ This is a version as specified in source. - -- We populate this field in index reading for dummy GPDs, - -- only when GPD reading failed, but scanning haven't. - -- - -- Cabal-the-library never produces GPDs with Just as gpdScannedVersion. - -- - -- Perfectly, PackageIndex should have sum type, so we don't need to - -- have dummy GPDs. - , genPackageFlags :: [PackageFlag] - , condLibrary :: Maybe (CondTree ConfVar [Dependency] Library) - , condSubLibraries :: [( UnqualComponentName - , CondTree ConfVar [Dependency] Library )] - , condForeignLibs :: [( UnqualComponentName - , CondTree ConfVar [Dependency] ForeignLib )] - , condExecutables :: [( UnqualComponentName - , CondTree ConfVar [Dependency] Executable )] - , condTestSuites :: [( UnqualComponentName - , CondTree ConfVar [Dependency] TestSuite )] - , condBenchmarks :: [( UnqualComponentName - , CondTree ConfVar [Dependency] Benchmark )] + , gpdScannedVersion :: Maybe Version + -- ^ This is a version as specified in source. + -- We populate this field in index reading for dummy GPDs, + -- only when GPD reading failed, but scanning haven't. + -- + -- Cabal-the-library never produces GPDs with Just as gpdScannedVersion. + -- + -- Perfectly, PackageIndex should have sum type, so we don't need to + -- have dummy GPDs. + , genPackageFlags :: [PackageFlag] + , condLibrary :: Maybe (CondTree ConfVar [Dependency] Library) + , condSubLibraries + :: [ ( UnqualComponentName + , CondTree ConfVar [Dependency] Library + ) + ] + , condForeignLibs + :: [ ( UnqualComponentName + , CondTree ConfVar [Dependency] ForeignLib + ) + ] + , condExecutables + :: [ ( UnqualComponentName + , CondTree ConfVar [Dependency] Executable + ) + ] + , condTestSuites + :: [ ( UnqualComponentName + , CondTree ConfVar [Dependency] TestSuite + ) + ] + , condBenchmarks + :: [ ( UnqualComponentName + , CondTree ConfVar [Dependency] Benchmark + ) + ] } - deriving (Show, Eq, Typeable, Data, Generic) + deriving (Show, Eq, Typeable, Data, Generic) instance Package GenericPackageDescription where packageId = packageId . packageDescription @@ -74,30 +87,34 @@ emptyGenericPackageDescription = GenericPackageDescription emptyPackageDescripti -- Traversal Instances instance L.HasBuildInfos GenericPackageDescription where - traverseBuildInfos f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6) = - GenericPackageDescription - <$> L.traverseBuildInfos f p - <*> pure v - <*> pure a1 - <*> (traverse . traverseCondTreeBuildInfo) f x1 - <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x2 - <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x3 - <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x4 - <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x5 - <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x6 + traverseBuildInfos f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6) = + GenericPackageDescription + <$> L.traverseBuildInfos f p + <*> pure v + <*> pure a1 + <*> (traverse . traverseCondTreeBuildInfo) f x1 + <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x2 + <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x3 + <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x4 + <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x5 + <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x6 -- We use this traversal to keep [Dependency] field in CondTree up to date. traverseCondTreeBuildInfo - :: forall f comp v. (Applicative f, L.HasBuildInfo comp) - => LensLike' f (CondTree v [Dependency] comp) L.BuildInfo -traverseCondTreeBuildInfo g = node where + :: forall f comp v + . (Applicative f, L.HasBuildInfo comp) + => LensLike' f (CondTree v [Dependency] comp) L.BuildInfo +traverseCondTreeBuildInfo g = node + where mkCondNode :: comp -> [CondBranch v [Dependency] comp] -> CondTree v [Dependency] comp mkCondNode comp = CondNode comp (view L.targetBuildDepends comp) - node (CondNode comp _ branches) = mkCondNode + node (CondNode comp _ branches) = + mkCondNode <$> L.buildInfo g comp <*> traverse branch branches - branch (CondBranch v x y) = CondBranch v + branch (CondBranch v x y) = + CondBranch v <$> node x <*> traverse node y diff --git a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs index 012d7365e54..213c97128f9 100644 --- a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs @@ -1,34 +1,36 @@ {-# LANGUAGE Rank2Types #-} -module Distribution.Types.GenericPackageDescription.Lens ( - GenericPackageDescription, - PackageFlag, - FlagName, - ConfVar (..), - module Distribution.Types.GenericPackageDescription.Lens, - ) where - -import Prelude() -import Distribution.Compat.Prelude + +module Distribution.Types.GenericPackageDescription.Lens + ( GenericPackageDescription + , PackageFlag + , FlagName + , ConfVar (..) + , module Distribution.Types.GenericPackageDescription.Lens + ) where + import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Prelude () import qualified Distribution.Types.GenericPackageDescription as T -- We import types from their packages, so we can remove unused imports -- and have wider inter-module dependency graph + +import Distribution.Compiler (CompilerFlavor) +import Distribution.System (Arch, OS) +import Distribution.Types.Benchmark (Benchmark) import Distribution.Types.CondTree (CondTree) +import Distribution.Types.ConfVar (ConfVar (..)) import Distribution.Types.Dependency (Dependency) import Distribution.Types.Executable (Executable) -import Distribution.Types.PackageDescription (PackageDescription) -import Distribution.Types.Benchmark (Benchmark) +import Distribution.Types.Flag (FlagName, PackageFlag (MkPackageFlag)) import Distribution.Types.ForeignLib (ForeignLib) -import Distribution.Types.GenericPackageDescription (GenericPackageDescription(GenericPackageDescription) ) -import Distribution.Types.Flag (PackageFlag(MkPackageFlag), FlagName) -import Distribution.Types.ConfVar (ConfVar (..)) +import Distribution.Types.GenericPackageDescription (GenericPackageDescription (GenericPackageDescription)) import Distribution.Types.Library (Library) +import Distribution.Types.PackageDescription (PackageDescription) import Distribution.Types.TestSuite (TestSuite) import Distribution.Types.UnqualComponentName (UnqualComponentName) -import Distribution.System (Arch, OS) -import Distribution.Compiler (CompilerFlavor) import Distribution.Version (Version, VersionRange) ------------------------------------------------------------------------------- @@ -36,59 +38,60 @@ import Distribution.Version (Version, VersionRange) ------------------------------------------------------------------------------- packageDescription :: Lens' GenericPackageDescription PackageDescription -packageDescription f s = fmap (\x -> s { T.packageDescription = x }) (f (T.packageDescription s)) +packageDescription f s = fmap (\x -> s{T.packageDescription = x}) (f (T.packageDescription s)) {-# INLINE packageDescription #-} gpdScannedVersion :: Lens' GenericPackageDescription (Maybe Version) -gpdScannedVersion f s = fmap (\x -> s { T.gpdScannedVersion = x }) (f (T.gpdScannedVersion s)) +gpdScannedVersion f s = fmap (\x -> s{T.gpdScannedVersion = x}) (f (T.gpdScannedVersion s)) {-# INLINE gpdScannedVersion #-} genPackageFlags :: Lens' GenericPackageDescription [PackageFlag] -genPackageFlags f s = fmap (\x -> s { T.genPackageFlags = x }) (f (T.genPackageFlags s)) +genPackageFlags f s = fmap (\x -> s{T.genPackageFlags = x}) (f (T.genPackageFlags s)) {-# INLINE genPackageFlags #-} condLibrary :: Lens' GenericPackageDescription (Maybe (CondTree ConfVar [Dependency] Library)) -condLibrary f s = fmap (\x -> s { T.condLibrary = x }) (f (T.condLibrary s)) +condLibrary f s = fmap (\x -> s{T.condLibrary = x}) (f (T.condLibrary s)) {-# INLINE condLibrary #-} -condSubLibraries :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] Library))] -condSubLibraries f s = fmap (\x -> s { T.condSubLibraries = x }) (f (T.condSubLibraries s)) +condSubLibraries :: Lens' GenericPackageDescription [(UnqualComponentName, (CondTree ConfVar [Dependency] Library))] +condSubLibraries f s = fmap (\x -> s{T.condSubLibraries = x}) (f (T.condSubLibraries s)) {-# INLINE condSubLibraries #-} -condForeignLibs :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] ForeignLib))] -condForeignLibs f s = fmap (\x -> s { T.condForeignLibs = x }) (f (T.condForeignLibs s)) +condForeignLibs :: Lens' GenericPackageDescription [(UnqualComponentName, (CondTree ConfVar [Dependency] ForeignLib))] +condForeignLibs f s = fmap (\x -> s{T.condForeignLibs = x}) (f (T.condForeignLibs s)) {-# INLINE condForeignLibs #-} -condExecutables :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] Executable))] -condExecutables f s = fmap (\x -> s { T.condExecutables = x }) (f (T.condExecutables s)) +condExecutables :: Lens' GenericPackageDescription [(UnqualComponentName, (CondTree ConfVar [Dependency] Executable))] +condExecutables f s = fmap (\x -> s{T.condExecutables = x}) (f (T.condExecutables s)) {-# INLINE condExecutables #-} -condTestSuites :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] TestSuite))] -condTestSuites f s = fmap (\x -> s { T.condTestSuites = x }) (f (T.condTestSuites s)) +condTestSuites :: Lens' GenericPackageDescription [(UnqualComponentName, (CondTree ConfVar [Dependency] TestSuite))] +condTestSuites f s = fmap (\x -> s{T.condTestSuites = x}) (f (T.condTestSuites s)) {-# INLINE condTestSuites #-} -condBenchmarks :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] Benchmark))] -condBenchmarks f s = fmap (\x -> s { T.condBenchmarks = x }) (f (T.condBenchmarks s)) +condBenchmarks :: Lens' GenericPackageDescription [(UnqualComponentName, (CondTree ConfVar [Dependency] Benchmark))] +condBenchmarks f s = fmap (\x -> s{T.condBenchmarks = x}) (f (T.condBenchmarks s)) {-# INLINE condBenchmarks #-} allCondTrees :: Applicative f - => (forall a. CondTree ConfVar [Dependency] a - -> f (CondTree ConfVar [Dependency] a)) + => ( forall a + . CondTree ConfVar [Dependency] a + -> f (CondTree ConfVar [Dependency] a) + ) -> GenericPackageDescription -> f GenericPackageDescription allCondTrees f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6) = - GenericPackageDescription - <$> pure p - <*> pure v - <*> pure a1 - <*> traverse f x1 - <*> (traverse . _2) f x2 - <*> (traverse . _2) f x3 - <*> (traverse . _2) f x4 - <*> (traverse . _2) f x5 - <*> (traverse . _2) f x6 - + GenericPackageDescription + <$> pure p + <*> pure v + <*> pure a1 + <*> traverse f x1 + <*> (traverse . _2) f x2 + <*> (traverse . _2) f x3 + <*> (traverse . _2) f x4 + <*> (traverse . _2) f x5 + <*> (traverse . _2) f x6 ------------------------------------------------------------------------------- -- Flag @@ -116,16 +119,16 @@ flagManual f (MkPackageFlag x1 x2 x3 x4) = fmap (\y1 -> MkPackageFlag x1 x2 x3 y _OS :: Traversal' ConfVar OS _OS f (OS os) = OS <$> f os -_OS _ x = pure x +_OS _ x = pure x _Arch :: Traversal' ConfVar Arch _Arch f (Arch arch) = Arch <$> f arch -_Arch _ x = pure x +_Arch _ x = pure x _PackageFlag :: Traversal' ConfVar FlagName _PackageFlag f (PackageFlag flag) = PackageFlag <$> f flag -_PackageFlag _ x = pure x +_PackageFlag _ x = pure x _Impl :: Traversal' ConfVar (CompilerFlavor, VersionRange) _Impl f (Impl cf vr) = uncurry Impl <$> f (cf, vr) -_Impl _ x = pure x +_Impl _ x = pure x diff --git a/Cabal-syntax/src/Distribution/Types/HookedBuildInfo.hs b/Cabal-syntax/src/Distribution/Types/HookedBuildInfo.hs index 62f3551f131..a57d9f8c852 100644 --- a/Cabal-syntax/src/Distribution/Types/HookedBuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/HookedBuildInfo.hs @@ -1,9 +1,9 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.HookedBuildInfo ( - HookedBuildInfo, - emptyHookedBuildInfo, +module Distribution.Types.HookedBuildInfo + ( HookedBuildInfo + , emptyHookedBuildInfo ) where -- import Distribution.Compat.Prelude diff --git a/Cabal-syntax/src/Distribution/Types/IncludeRenaming.hs b/Cabal-syntax/src/Distribution/Types/IncludeRenaming.hs index 0b313912a8d..c8cb70d91f1 100644 --- a/Cabal-syntax/src/Distribution/Types/IncludeRenaming.hs +++ b/Cabal-syntax/src/Distribution/Types/IncludeRenaming.hs @@ -1,11 +1,11 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.IncludeRenaming ( - IncludeRenaming(..), - defaultIncludeRenaming, - isDefaultIncludeRenaming, -) where +module Distribution.Types.IncludeRenaming + ( IncludeRenaming (..) + , defaultIncludeRenaming + , isDefaultIncludeRenaming + ) where import Distribution.Compat.Prelude import Prelude () @@ -13,21 +13,20 @@ import Prelude () import Distribution.Types.ModuleRenaming import qualified Distribution.Compat.CharParsing as P -import Distribution.Parsec -import Distribution.Pretty -import Text.PrettyPrint (text) -import qualified Text.PrettyPrint as Disp +import Distribution.Parsec +import Distribution.Pretty +import Text.PrettyPrint (text) +import qualified Text.PrettyPrint as Disp -- --------------------------------------------------------------------------- -- Module renaming -- | A renaming on an include: (provides renaming, requires renaming) -data IncludeRenaming - = IncludeRenaming { - includeProvidesRn :: ModuleRenaming, - includeRequiresRn :: ModuleRenaming - } - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) +data IncludeRenaming = IncludeRenaming + { includeProvidesRn :: ModuleRenaming + , includeRequiresRn :: ModuleRenaming + } + deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) instance Binary IncludeRenaming instance Structured IncludeRenaming @@ -44,25 +43,26 @@ isDefaultIncludeRenaming :: IncludeRenaming -> Bool isDefaultIncludeRenaming (IncludeRenaming p r) = isDefaultRenaming p && isDefaultRenaming r instance Pretty IncludeRenaming where - pretty (IncludeRenaming prov_rn req_rn) = - pretty prov_rn - <+> (if isDefaultRenaming req_rn - then Disp.empty - else text "requires" <+> pretty req_rn) + pretty (IncludeRenaming prov_rn req_rn) = + pretty prov_rn + <+> ( if isDefaultRenaming req_rn + then Disp.empty + else text "requires" <+> pretty req_rn + ) instance Parsec IncludeRenaming where - parsec = do - prov_rn <- parsec - req_rn <- P.option defaultRenaming $ P.try $ do - P.spaces -- no need to be space - _ <- P.string "requires" - P.spaces - parsec - -- Requirements don't really care if they're mentioned - -- or not (since you can't thin a requirement.) But - -- we have a little hack in Configure to combine - -- the provisions and requirements together before passing - -- them to GHC, and so the most neutral choice for a requirement - -- is for the "with" field to be False, so we correctly - -- thin provisions. - return (IncludeRenaming prov_rn req_rn) + parsec = do + prov_rn <- parsec + req_rn <- P.option defaultRenaming $ P.try $ do + P.spaces -- no need to be space + _ <- P.string "requires" + P.spaces + parsec + -- Requirements don't really care if they're mentioned + -- or not (since you can't thin a requirement.) But + -- we have a little hack in Configure to combine + -- the provisions and requirements together before passing + -- them to GHC, and so the most neutral choice for a requirement + -- is for the "with" field to be False, so we correctly + -- thin provisions. + return (IncludeRenaming prov_rn req_rn) diff --git a/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo.hs b/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo.hs index 0d047db5590..b3e353876eb 100644 --- a/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo.hs @@ -1,100 +1,101 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} -module Distribution.Types.InstalledPackageInfo ( - InstalledPackageInfo (..), - emptyInstalledPackageInfo, - mungedPackageId, - mungedPackageName, - AbiDependency (..), - ExposedModule (..), - ) where +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Distribution.Types.InstalledPackageInfo + ( InstalledPackageInfo (..) + , emptyInstalledPackageInfo + , mungedPackageId + , mungedPackageName + , AbiDependency (..) + , ExposedModule (..) + ) where import Distribution.Compat.Prelude import Prelude () import Distribution.Backpack -import Distribution.Compat.Graph (IsNode (..)) +import Distribution.Compat.Graph (IsNode (..)) import Distribution.License import Distribution.ModuleName -import Distribution.Package hiding (installedUnitId) +import Distribution.Package hiding (installedUnitId) import Distribution.Types.AbiDependency import Distribution.Types.ExposedModule import Distribution.Types.LibraryName import Distribution.Types.LibraryVisibility import Distribution.Types.MungedPackageId import Distribution.Types.MungedPackageName -import Distribution.Version (nullVersion) -import Distribution.Utils.ShortText (ShortText) +import Distribution.Utils.ShortText (ShortText) +import Distribution.Version (nullVersion) import qualified Distribution.Package as Package -import qualified Distribution.SPDX as SPDX +import qualified Distribution.SPDX as SPDX -- ----------------------------------------------------------------------------- -- The InstalledPackageInfo type -- For BC reasons, we continue to name this record an InstalledPackageInfo; -- but it would more accurately be called an InstalledUnitInfo with Backpack -data InstalledPackageInfo - = InstalledPackageInfo { - -- these parts (sourcePackageId, installedUnitId) are - -- exactly the same as PackageDescription - sourcePackageId :: PackageId, - sourceLibName :: LibraryName, - installedComponentId_ :: ComponentId, - libVisibility :: LibraryVisibility, - installedUnitId :: UnitId, - -- INVARIANT: if this package is definite, OpenModule's - -- OpenUnitId directly records UnitId. If it is - -- indefinite, OpenModule is always an OpenModuleVar - -- with the same ModuleName as the key. - instantiatedWith :: [(ModuleName, OpenModule)], - compatPackageKey :: String, - license :: Either SPDX.License License, - copyright :: !ShortText, - maintainer :: !ShortText, - author :: !ShortText, - stability :: !ShortText, - homepage :: !ShortText, - pkgUrl :: !ShortText, - synopsis :: !ShortText, - description :: !ShortText, - category :: !ShortText, - -- these parts are required by an installed package only: - abiHash :: AbiHash, - indefinite :: Bool, - exposed :: Bool, - -- INVARIANT: if the package is definite, OpenModule's - -- OpenUnitId directly records UnitId. - exposedModules :: [ExposedModule], - hiddenModules :: [ModuleName], - trusted :: Bool, - importDirs :: [FilePath], - libraryDirs :: [FilePath], - libraryDirsStatic :: [FilePath], - libraryDynDirs :: [FilePath], -- ^ overrides 'libraryDirs' - dataDir :: FilePath, - hsLibraries :: [String], - extraLibraries :: [String], - extraLibrariesStatic :: [String], - extraGHCiLibraries:: [String], -- overrides extraLibraries for GHCi - includeDirs :: [FilePath], - includes :: [String], - -- INVARIANT: if the package is definite, UnitId is NOT - -- a ComponentId of an indefinite package - depends :: [UnitId], - abiDepends :: [AbiDependency], - ccOptions :: [String], - cxxOptions :: [String], - ldOptions :: [String], - frameworkDirs :: [FilePath], - frameworks :: [String], - haddockInterfaces :: [FilePath], - haddockHTMLs :: [FilePath], - pkgRoot :: Maybe FilePath - } - deriving (Eq, Generic, Typeable, Read, Show) +data InstalledPackageInfo = InstalledPackageInfo + { -- these parts (sourcePackageId, installedUnitId) are + -- exactly the same as PackageDescription + sourcePackageId :: PackageId + , sourceLibName :: LibraryName + , installedComponentId_ :: ComponentId + , libVisibility :: LibraryVisibility + , installedUnitId :: UnitId + , -- INVARIANT: if this package is definite, OpenModule's + -- OpenUnitId directly records UnitId. If it is + -- indefinite, OpenModule is always an OpenModuleVar + -- with the same ModuleName as the key. + instantiatedWith :: [(ModuleName, OpenModule)] + , compatPackageKey :: String + , license :: Either SPDX.License License + , copyright :: !ShortText + , maintainer :: !ShortText + , author :: !ShortText + , stability :: !ShortText + , homepage :: !ShortText + , pkgUrl :: !ShortText + , synopsis :: !ShortText + , description :: !ShortText + , category :: !ShortText + , -- these parts are required by an installed package only: + abiHash :: AbiHash + , indefinite :: Bool + , exposed :: Bool + , -- INVARIANT: if the package is definite, OpenModule's + -- OpenUnitId directly records UnitId. + exposedModules :: [ExposedModule] + , hiddenModules :: [ModuleName] + , trusted :: Bool + , importDirs :: [FilePath] + , libraryDirs :: [FilePath] + , libraryDirsStatic :: [FilePath] + , libraryDynDirs :: [FilePath] + -- ^ overrides 'libraryDirs' + , dataDir :: FilePath + , hsLibraries :: [String] + , extraLibraries :: [String] + , extraLibrariesStatic :: [String] + , extraGHCiLibraries :: [String] -- overrides extraLibraries for GHCi + , includeDirs :: [FilePath] + , includes :: [String] + , -- INVARIANT: if the package is definite, UnitId is NOT + -- a ComponentId of an indefinite package + depends :: [UnitId] + , abiDepends :: [AbiDependency] + , ccOptions :: [String] + , cxxOptions :: [String] + , ldOptions :: [String] + , frameworkDirs :: [FilePath] + , frameworks :: [String] + , haddockInterfaces :: [FilePath] + , haddockHTMLs :: [FilePath] + , pkgRoot :: Maybe FilePath + } + deriving (Eq, Generic, Typeable, Read, Show) instance Binary InstalledPackageInfo instance Structured InstalledPackageInfo @@ -102,25 +103,25 @@ instance Structured InstalledPackageInfo instance NFData InstalledPackageInfo where rnf = genericRnf instance Package.HasMungedPackageId InstalledPackageInfo where - mungedId = mungedPackageId + mungedId = mungedPackageId instance Package.Package InstalledPackageInfo where - packageId = sourcePackageId + packageId = sourcePackageId instance Package.HasUnitId InstalledPackageInfo where - installedUnitId = installedUnitId + installedUnitId = installedUnitId instance Package.PackageInstalled InstalledPackageInfo where - installedDepends = depends + installedDepends = depends instance IsNode InstalledPackageInfo where - type Key InstalledPackageInfo = UnitId - nodeKey = installedUnitId - nodeNeighbors = depends + type Key InstalledPackageInfo = UnitId + nodeKey = installedUnitId + nodeNeighbors = depends mungedPackageId :: InstalledPackageInfo -> MungedPackageId mungedPackageId ipi = - MungedPackageId (mungedPackageName ipi) (packageVersion ipi) + MungedPackageId (mungedPackageName ipi) (packageVersion ipi) -- | Returns the munged package name, which we write into @name@ for -- compatibility with old versions of GHC. @@ -128,50 +129,50 @@ mungedPackageName :: InstalledPackageInfo -> MungedPackageName mungedPackageName ipi = MungedPackageName (packageName ipi) (sourceLibName ipi) emptyInstalledPackageInfo :: InstalledPackageInfo -emptyInstalledPackageInfo - = InstalledPackageInfo { - sourcePackageId = PackageIdentifier (mkPackageName "") nullVersion, - sourceLibName = LMainLibName, - installedComponentId_ = mkComponentId "", - installedUnitId = mkUnitId "", - instantiatedWith = [], - compatPackageKey = "", - license = Left SPDX.NONE, - copyright = "", - maintainer = "", - author = "", - stability = "", - homepage = "", - pkgUrl = "", - synopsis = "", - description = "", - category = "", - abiHash = mkAbiHash "", - indefinite = False, - exposed = False, - exposedModules = [], - hiddenModules = [], - trusted = False, - importDirs = [], - libraryDirs = [], - libraryDirsStatic = [], - libraryDynDirs = [], - dataDir = "", - hsLibraries = [], - extraLibraries = [], - extraLibrariesStatic = [], - extraGHCiLibraries= [], - includeDirs = [], - includes = [], - depends = [], - abiDepends = [], - ccOptions = [], - cxxOptions = [], - ldOptions = [], - frameworkDirs = [], - frameworks = [], - haddockInterfaces = [], - haddockHTMLs = [], - pkgRoot = Nothing, - libVisibility = LibraryVisibilityPrivate +emptyInstalledPackageInfo = + InstalledPackageInfo + { sourcePackageId = PackageIdentifier (mkPackageName "") nullVersion + , sourceLibName = LMainLibName + , installedComponentId_ = mkComponentId "" + , installedUnitId = mkUnitId "" + , instantiatedWith = [] + , compatPackageKey = "" + , license = Left SPDX.NONE + , copyright = "" + , maintainer = "" + , author = "" + , stability = "" + , homepage = "" + , pkgUrl = "" + , synopsis = "" + , description = "" + , category = "" + , abiHash = mkAbiHash "" + , indefinite = False + , exposed = False + , exposedModules = [] + , hiddenModules = [] + , trusted = False + , importDirs = [] + , libraryDirs = [] + , libraryDirsStatic = [] + , libraryDynDirs = [] + , dataDir = "" + , hsLibraries = [] + , extraLibraries = [] + , extraLibrariesStatic = [] + , extraGHCiLibraries = [] + , includeDirs = [] + , includes = [] + , depends = [] + , abiDepends = [] + , ccOptions = [] + , cxxOptions = [] + , ldOptions = [] + , frameworkDirs = [] + , frameworks = [] + , haddockInterfaces = [] + , haddockHTMLs = [] + , pkgRoot = Nothing + , libVisibility = LibraryVisibilityPrivate } diff --git a/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs b/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs index f176ea01187..d7546635545 100644 --- a/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs @@ -1,18 +1,19 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -module Distribution.Types.InstalledPackageInfo.FieldGrammar ( - ipiFieldGrammar, - ) where +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Distribution.Types.InstalledPackageInfo.FieldGrammar + ( ipiFieldGrammar + ) where import Distribution.Compat.Prelude import Prelude () import Distribution.Backpack import Distribution.CabalSpecVersion -import Distribution.Compat.Lens (Lens', (&), (.~)) +import Distribution.Compat.Lens (Lens', (&), (.~)) import Distribution.Compat.Newtype import Distribution.FieldGrammar import Distribution.FieldGrammar.FieldDescrs @@ -27,16 +28,16 @@ import Distribution.Types.MungedPackageName import Distribution.Types.UnqualComponentName import Distribution.Version -import qualified Data.Char as Char -import qualified Data.Map as Map +import qualified Data.Char as Char +import qualified Data.Map as Map import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.SPDX as SPDX -import qualified Text.PrettyPrint as Disp +import qualified Distribution.SPDX as SPDX +import qualified Text.PrettyPrint as Disp import Distribution.Types.InstalledPackageInfo import qualified Distribution.Types.InstalledPackageInfo.Lens as L -import qualified Distribution.Types.PackageId.Lens as L +import qualified Distribution.Types.PackageId.Lens as L -- Note: GHC goes nuts and inlines everything, -- One can see e.g. in -ddump-simpl-stats: @@ -53,76 +54,80 @@ f <@> x = f <*> x {-# NOINLINE (<@>) #-} ipiFieldGrammar - :: ( FieldGrammar c g, Applicative (g InstalledPackageInfo), Applicative (g Basic) - , c (Identity AbiHash) - , c (Identity LibraryVisibility) - , c (Identity PackageName) - , c (Identity UnitId) - , c (Identity UnqualComponentName) - , c (List FSep (Identity AbiDependency) AbiDependency) - , c (List FSep (Identity UnitId) UnitId) - , c (List FSep (MQuoted ModuleName) ModuleName) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (MQuoted MungedPackageName) - , c (MQuoted Version) - , c CompatPackageKey - , c ExposedModules - , c InstWith - , c SpecLicenseLenient - ) - => g InstalledPackageInfo InstalledPackageInfo -ipiFieldGrammar = mkInstalledPackageInfo + :: ( FieldGrammar c g + , Applicative (g InstalledPackageInfo) + , Applicative (g Basic) + , c (Identity AbiHash) + , c (Identity LibraryVisibility) + , c (Identity PackageName) + , c (Identity UnitId) + , c (Identity UnqualComponentName) + , c (List FSep (Identity AbiDependency) AbiDependency) + , c (List FSep (Identity UnitId) UnitId) + , c (List FSep (MQuoted ModuleName) ModuleName) + , c (List FSep FilePathNT String) + , c (List FSep Token String) + , c (MQuoted MungedPackageName) + , c (MQuoted Version) + , c CompatPackageKey + , c ExposedModules + , c InstWith + , c SpecLicenseLenient + ) + => g InstalledPackageInfo InstalledPackageInfo +ipiFieldGrammar = + mkInstalledPackageInfo -- Deprecated fields - <$> monoidalFieldAla "hugs-options" (alaList' FSep Token) unitedList - --- https://github.com/haskell/cabal/commit/40f3601e17024f07e0da8e64d3dd390177ce908b - ^^^ deprecatedSince CabalSpecV1_22 "hugs isn't supported anymore" + <$> monoidalFieldAla "hugs-options" (alaList' FSep Token) unitedList + --- https://github.com/haskell/cabal/commit/40f3601e17024f07e0da8e64d3dd390177ce908b + ^^^ deprecatedSince CabalSpecV1_22 "hugs isn't supported anymore" -- Very basic fields: name, version, package-name, lib-name and visibility <@> blurFieldGrammar basic basicFieldGrammar -- Basic fields - <@> optionalFieldDef "id" L.installedUnitId (mkUnitId "") - <@> optionalFieldDefAla "instantiated-with" InstWith L.instantiatedWith [] - <@> optionalFieldDefAla "key" CompatPackageKey L.compatPackageKey "" - <@> optionalFieldDefAla "license" SpecLicenseLenient L.license (Left SPDX.NONE) - <@> freeTextFieldDefST "copyright" L.copyright - <@> freeTextFieldDefST "maintainer" L.maintainer - <@> freeTextFieldDefST "author" L.author - <@> freeTextFieldDefST "stability" L.stability - <@> freeTextFieldDefST "homepage" L.homepage - <@> freeTextFieldDefST "package-url" L.pkgUrl - <@> freeTextFieldDefST "synopsis" L.synopsis - <@> freeTextFieldDefST "description" L.description - <@> freeTextFieldDefST "category" L.category + <@> optionalFieldDef "id" L.installedUnitId (mkUnitId "") + <@> optionalFieldDefAla "instantiated-with" InstWith L.instantiatedWith [] + <@> optionalFieldDefAla "key" CompatPackageKey L.compatPackageKey "" + <@> optionalFieldDefAla "license" SpecLicenseLenient L.license (Left SPDX.NONE) + <@> freeTextFieldDefST "copyright" L.copyright + <@> freeTextFieldDefST "maintainer" L.maintainer + <@> freeTextFieldDefST "author" L.author + <@> freeTextFieldDefST "stability" L.stability + <@> freeTextFieldDefST "homepage" L.homepage + <@> freeTextFieldDefST "package-url" L.pkgUrl + <@> freeTextFieldDefST "synopsis" L.synopsis + <@> freeTextFieldDefST "description" L.description + <@> freeTextFieldDefST "category" L.category -- Installed fields - <@> optionalFieldDef "abi" L.abiHash (mkAbiHash "") - <@> booleanFieldDef "indefinite" L.indefinite False - <@> booleanFieldDef "exposed" L.exposed False - <@> monoidalFieldAla "exposed-modules" ExposedModules L.exposedModules - <@> monoidalFieldAla "hidden-modules" (alaList' FSep MQuoted) L.hiddenModules - <@> booleanFieldDef "trusted" L.trusted False - <@> monoidalFieldAla "import-dirs" (alaList' FSep FilePathNT) L.importDirs - <@> monoidalFieldAla "library-dirs" (alaList' FSep FilePathNT) L.libraryDirs - <@> monoidalFieldAla "library-dirs-static" (alaList' FSep FilePathNT) L.libraryDirsStatic - <@> monoidalFieldAla "dynamic-library-dirs" (alaList' FSep FilePathNT) L.libraryDynDirs - <@> optionalFieldDefAla "data-dir" FilePathNT L.dataDir "" - <@> monoidalFieldAla "hs-libraries" (alaList' FSep Token) L.hsLibraries - <@> monoidalFieldAla "extra-libraries" (alaList' FSep Token) L.extraLibraries - <@> monoidalFieldAla "extra-libraries-static" (alaList' FSep Token) L.extraLibrariesStatic - <@> monoidalFieldAla "extra-ghci-libraries" (alaList' FSep Token) L.extraGHCiLibraries - <@> monoidalFieldAla "include-dirs" (alaList' FSep FilePathNT) L.includeDirs - <@> monoidalFieldAla "includes" (alaList' FSep FilePathNT) L.includes - <@> monoidalFieldAla "depends" (alaList FSep) L.depends - <@> monoidalFieldAla "abi-depends" (alaList FSep) L.abiDepends - <@> monoidalFieldAla "cc-options" (alaList' FSep Token) L.ccOptions - <@> monoidalFieldAla "cxx-options" (alaList' FSep Token) L.cxxOptions - <@> monoidalFieldAla "ld-options" (alaList' FSep Token) L.ldOptions - <@> monoidalFieldAla "framework-dirs" (alaList' FSep FilePathNT) L.frameworkDirs - <@> monoidalFieldAla "frameworks" (alaList' FSep Token) L.frameworks - <@> monoidalFieldAla "haddock-interfaces" (alaList' FSep FilePathNT) L.haddockInterfaces - <@> monoidalFieldAla "haddock-html" (alaList' FSep FilePathNT) L.haddockHTMLs - <@> optionalFieldAla "pkgroot" FilePathNT L.pkgRoot + <@> optionalFieldDef "abi" L.abiHash (mkAbiHash "") + <@> booleanFieldDef "indefinite" L.indefinite False + <@> booleanFieldDef "exposed" L.exposed False + <@> monoidalFieldAla "exposed-modules" ExposedModules L.exposedModules + <@> monoidalFieldAla "hidden-modules" (alaList' FSep MQuoted) L.hiddenModules + <@> booleanFieldDef "trusted" L.trusted False + <@> monoidalFieldAla "import-dirs" (alaList' FSep FilePathNT) L.importDirs + <@> monoidalFieldAla "library-dirs" (alaList' FSep FilePathNT) L.libraryDirs + <@> monoidalFieldAla "library-dirs-static" (alaList' FSep FilePathNT) L.libraryDirsStatic + <@> monoidalFieldAla "dynamic-library-dirs" (alaList' FSep FilePathNT) L.libraryDynDirs + <@> optionalFieldDefAla "data-dir" FilePathNT L.dataDir "" + <@> monoidalFieldAla "hs-libraries" (alaList' FSep Token) L.hsLibraries + <@> monoidalFieldAla "extra-libraries" (alaList' FSep Token) L.extraLibraries + <@> monoidalFieldAla "extra-libraries-static" (alaList' FSep Token) L.extraLibrariesStatic + <@> monoidalFieldAla "extra-ghci-libraries" (alaList' FSep Token) L.extraGHCiLibraries + <@> monoidalFieldAla "include-dirs" (alaList' FSep FilePathNT) L.includeDirs + <@> monoidalFieldAla "includes" (alaList' FSep FilePathNT) L.includes + <@> monoidalFieldAla "depends" (alaList FSep) L.depends + <@> monoidalFieldAla "abi-depends" (alaList FSep) L.abiDepends + <@> monoidalFieldAla "cc-options" (alaList' FSep Token) L.ccOptions + <@> monoidalFieldAla "cxx-options" (alaList' FSep Token) L.cxxOptions + <@> monoidalFieldAla "ld-options" (alaList' FSep Token) L.ldOptions + <@> monoidalFieldAla "framework-dirs" (alaList' FSep FilePathNT) L.frameworkDirs + <@> monoidalFieldAla "frameworks" (alaList' FSep Token) L.frameworks + <@> monoidalFieldAla "haddock-interfaces" (alaList' FSep FilePathNT) L.haddockInterfaces + <@> monoidalFieldAla "haddock-html" (alaList' FSep FilePathNT) L.haddockHTMLs + <@> optionalFieldAla "pkgroot" FilePathNT L.pkgRoot where - mkInstalledPackageInfo _ Basic {..} = InstalledPackageInfo + mkInstalledPackageInfo _ Basic{..} = + InstalledPackageInfo -- _basicPkgName is not used -- setMaybePackageId says it can be no-op. (PackageIdentifier pn _basicVersion) @@ -149,7 +154,7 @@ unitedList f s = s <$ f [] -- /Should/ be irrelevant. combineLibraryName :: LibraryName -> LibraryName -> LibraryName combineLibraryName l@(LSubLibName _) _ = l -combineLibraryName _ l = l +combineLibraryName _ l = l -- To maintain backwards-compatibility, we accept both comma/non-comma -- separated variants of this field. You SHOULD use the comma syntax if you @@ -158,23 +163,26 @@ combineLibraryName _ l = l showExposedModules :: [ExposedModule] -> Disp.Doc showExposedModules xs - | all isExposedModule xs = Disp.fsep (map pretty xs) - | otherwise = Disp.fsep (Disp.punctuate Disp.comma (map pretty xs)) - where isExposedModule (ExposedModule _ Nothing) = True - isExposedModule _ = False + | all isExposedModule xs = Disp.fsep (map pretty xs) + | otherwise = Disp.fsep (Disp.punctuate Disp.comma (map pretty xs)) + where + isExposedModule (ExposedModule _ Nothing) = True + isExposedModule _ = False -- | Setter for the @package-name@ field. It should be acceptable for this -- to be a no-op. setMaybePackageName :: Maybe PackageName -> InstalledPackageInfo -> InstalledPackageInfo -setMaybePackageName Nothing ipi = ipi -setMaybePackageName (Just pn) ipi = ipi - { sourcePackageId = (sourcePackageId ipi) {pkgName=pn} +setMaybePackageName Nothing ipi = ipi +setMaybePackageName (Just pn) ipi = + ipi + { sourcePackageId = (sourcePackageId ipi){pkgName = pn} } setMungedPackageName :: MungedPackageName -> InstalledPackageInfo -> InstalledPackageInfo -setMungedPackageName (MungedPackageName pn ln) ipi = ipi - { sourcePackageId = (sourcePackageId ipi) {pkgName=pn} - , sourceLibName = ln +setMungedPackageName (MungedPackageName pn ln) ipi = + ipi + { sourcePackageId = (sourcePackageId ipi){pkgName = pn} + , sourceLibName = ln } --- | Returns @Just@ if the @name@ field of the IPI record would not contain @@ -182,54 +190,55 @@ setMungedPackageName (MungedPackageName pn ln) ipi = ipi --- when it's redundant. maybePackageName :: InstalledPackageInfo -> Maybe PackageName maybePackageName ipi = case sourceLibName ipi of - LMainLibName -> Nothing - LSubLibName _ -> Just (packageName ipi) + LMainLibName -> Nothing + LSubLibName _ -> Just (packageName ipi) ------------------------------------------------------------------------------- -- Auxiliary types ------------------------------------------------------------------------------- -newtype ExposedModules = ExposedModules { getExposedModules :: [ExposedModule] } +newtype ExposedModules = ExposedModules {getExposedModules :: [ExposedModule]} instance Newtype [ExposedModule] ExposedModules instance Parsec ExposedModules where - parsec = ExposedModules <$> parsecOptCommaList parsec + parsec = ExposedModules <$> parsecOptCommaList parsec instance Pretty ExposedModules where - pretty = showExposedModules . getExposedModules + pretty = showExposedModules . getExposedModules -newtype CompatPackageKey = CompatPackageKey { getCompatPackageKey :: String } +newtype CompatPackageKey = CompatPackageKey {getCompatPackageKey :: String} instance Newtype String CompatPackageKey instance Pretty CompatPackageKey where - pretty = Disp.text . getCompatPackageKey + pretty = Disp.text . getCompatPackageKey instance Parsec CompatPackageKey where - parsec = CompatPackageKey <$> P.munch1 uid_char where - uid_char c = Char.isAlphaNum c || c `elem` ("-_.=[],:<>+" :: String) + parsec = CompatPackageKey <$> P.munch1 uid_char + where + uid_char c = Char.isAlphaNum c || c `elem` ("-_.=[],:<>+" :: String) -newtype InstWith = InstWith { getInstWith :: [(ModuleName,OpenModule)] } +newtype InstWith = InstWith {getInstWith :: [(ModuleName, OpenModule)]} -instance Newtype [(ModuleName, OpenModule)] InstWith +instance Newtype [(ModuleName, OpenModule)] InstWith instance Pretty InstWith where - pretty = dispOpenModuleSubst . Map.fromList . getInstWith + pretty = dispOpenModuleSubst . Map.fromList . getInstWith instance Parsec InstWith where - parsec = InstWith . Map.toList <$> parsecOpenModuleSubst + parsec = InstWith . Map.toList <$> parsecOpenModuleSubst -- | SPDX License expression or legacy license. Lenient parser, accepts either. -newtype SpecLicenseLenient = SpecLicenseLenient { getSpecLicenseLenient :: Either SPDX.License License } +newtype SpecLicenseLenient = SpecLicenseLenient {getSpecLicenseLenient :: Either SPDX.License License} instance Newtype (Either SPDX.License License) SpecLicenseLenient instance Parsec SpecLicenseLenient where - parsec = fmap SpecLicenseLenient $ Left <$> P.try parsec <|> Right <$> parsec + parsec = fmap SpecLicenseLenient $ Left <$> P.try parsec <|> Right <$> parsec instance Pretty SpecLicenseLenient where - pretty = either pretty pretty . getSpecLicenseLenient + pretty = either pretty pretty . getSpecLicenseLenient ------------------------------------------------------------------------------- -- Basic fields @@ -239,24 +248,26 @@ instance Pretty SpecLicenseLenient where -- in serialised textual representation -- to the actual 'InstalledPackageInfo' fields. data Basic = Basic - { _basicName :: MungedPackageName - , _basicVersion :: Version - , _basicPkgName :: Maybe PackageName - , _basicLibName :: LibraryName - , _basicLibVisibility :: LibraryVisibility - } + { _basicName :: MungedPackageName + , _basicVersion :: Version + , _basicPkgName :: Maybe PackageName + , _basicLibName :: LibraryName + , _basicLibVisibility :: LibraryVisibility + } basic :: Lens' InstalledPackageInfo Basic basic f ipi = g <$> f b where - b = Basic + b = + Basic (mungedPackageName ipi) (packageVersion ipi) (maybePackageName ipi) (sourceLibName ipi) (libVisibility ipi) - g (Basic n v pn ln lv) = ipi + g (Basic n v pn ln lv) = + ipi & setMungedPackageName n & L.sourcePackageId . L.pkgVersion .~ v & setMaybePackageName pn @@ -264,42 +275,46 @@ basic f ipi = g <$> f b & L.libVisibility .~ lv basicName :: Lens' Basic MungedPackageName -basicName f b = (\x -> b { _basicName = x }) <$> f (_basicName b) +basicName f b = (\x -> b{_basicName = x}) <$> f (_basicName b) {-# INLINE basicName #-} basicVersion :: Lens' Basic Version -basicVersion f b = (\x -> b { _basicVersion = x }) <$> f (_basicVersion b) +basicVersion f b = (\x -> b{_basicVersion = x}) <$> f (_basicVersion b) {-# INLINE basicVersion #-} basicPkgName :: Lens' Basic (Maybe PackageName) -basicPkgName f b = (\x -> b { _basicPkgName = x }) <$> f (_basicPkgName b) +basicPkgName f b = (\x -> b{_basicPkgName = x}) <$> f (_basicPkgName b) {-# INLINE basicPkgName #-} basicLibName :: Lens' Basic (Maybe UnqualComponentName) -basicLibName f b = (\x -> b { _basicLibName = maybeToLibraryName x }) <$> - f (libraryNameString (_basicLibName b)) +basicLibName f b = + (\x -> b{_basicLibName = maybeToLibraryName x}) + <$> f (libraryNameString (_basicLibName b)) {-# INLINE basicLibName #-} basicLibVisibility :: Lens' Basic LibraryVisibility -basicLibVisibility f b = (\x -> b { _basicLibVisibility = x }) <$> - f (_basicLibVisibility b) +basicLibVisibility f b = + (\x -> b{_basicLibVisibility = x}) + <$> f (_basicLibVisibility b) {-# INLINE basicLibVisibility #-} basicFieldGrammar - :: ( FieldGrammar c g, Applicative (g Basic) - , c (Identity LibraryVisibility) - , c (Identity PackageName) - , c (Identity UnqualComponentName) - , c (MQuoted MungedPackageName) - , c (MQuoted Version) - ) - => g Basic Basic -basicFieldGrammar = mkBasic - <$> optionalFieldDefAla "name" MQuoted basicName (mungedPackageName emptyInstalledPackageInfo) - <*> optionalFieldDefAla "version" MQuoted basicVersion nullVersion - <*> optionalField "package-name" basicPkgName - <*> optionalField "lib-name" basicLibName - <*> optionalFieldDef "visibility" basicLibVisibility LibraryVisibilityPrivate + :: ( FieldGrammar c g + , Applicative (g Basic) + , c (Identity LibraryVisibility) + , c (Identity PackageName) + , c (Identity UnqualComponentName) + , c (MQuoted MungedPackageName) + , c (MQuoted Version) + ) + => g Basic Basic +basicFieldGrammar = + mkBasic + <$> optionalFieldDefAla "name" MQuoted basicName (mungedPackageName emptyInstalledPackageInfo) + <*> optionalFieldDefAla "version" MQuoted basicVersion nullVersion + <*> optionalField "package-name" basicPkgName + <*> optionalField "lib-name" basicLibName + <*> optionalFieldDef "visibility" basicLibVisibility LibraryVisibilityPrivate where mkBasic n v pn ln lv = Basic n v pn ln' lv' where @@ -310,10 +325,10 @@ basicFieldGrammar = mkBasic -- This can be removed once we stop supporting GHC<8.8, at the -- condition that we keep marking main libraries as public when -- registering them. - lv' = if - let MungedPackageName _ mln = n in - -- We need to check both because on ghc<8.2 ln' will always - -- be LMainLibName - ln' == LMainLibName && mln == LMainLibName - then LibraryVisibilityPublic - else lv + lv' = + if let MungedPackageName _ mln = n + in -- We need to check both because on ghc<8.2 ln' will always + -- be LMainLibName + ln' == LMainLibName && mln == LMainLibName + then LibraryVisibilityPublic + else lv diff --git a/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/Lens.hs index 9d1df886370..47fa1c96f40 100644 --- a/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/Lens.hs @@ -1,198 +1,196 @@ -module Distribution.Types.InstalledPackageInfo.Lens ( - InstalledPackageInfo, - module Distribution.Types.InstalledPackageInfo.Lens - ) where +module Distribution.Types.InstalledPackageInfo.Lens + ( InstalledPackageInfo + , module Distribution.Types.InstalledPackageInfo.Lens + ) where import Distribution.Compat.Lens import Distribution.Compat.Prelude import Prelude () -import Distribution.Backpack (OpenModule) -import Distribution.License (License) -import Distribution.ModuleName (ModuleName) -import Distribution.Package (AbiHash, ComponentId, PackageIdentifier, UnitId) +import Distribution.Backpack (OpenModule) +import Distribution.License (License) +import Distribution.ModuleName (ModuleName) +import Distribution.Package (AbiHash, ComponentId, PackageIdentifier, UnitId) import Distribution.Types.InstalledPackageInfo (AbiDependency, ExposedModule, InstalledPackageInfo) -import Distribution.Types.LibraryName (LibraryName) -import Distribution.Types.LibraryVisibility (LibraryVisibility) -import Distribution.Utils.ShortText (ShortText) +import Distribution.Types.LibraryName (LibraryName) +import Distribution.Types.LibraryVisibility (LibraryVisibility) +import Distribution.Utils.ShortText (ShortText) - -import qualified Distribution.SPDX as SPDX +import qualified Distribution.SPDX as SPDX import qualified Distribution.Types.InstalledPackageInfo as T sourcePackageId :: Lens' InstalledPackageInfo PackageIdentifier -sourcePackageId f s = fmap (\x -> s { T.sourcePackageId = x }) (f (T.sourcePackageId s)) +sourcePackageId f s = fmap (\x -> s{T.sourcePackageId = x}) (f (T.sourcePackageId s)) {-# INLINE sourcePackageId #-} installedUnitId :: Lens' InstalledPackageInfo UnitId -installedUnitId f s = fmap (\x -> s { T.installedUnitId = x }) (f (T.installedUnitId s)) +installedUnitId f s = fmap (\x -> s{T.installedUnitId = x}) (f (T.installedUnitId s)) {-# INLINE installedUnitId #-} installedComponentId_ :: Lens' InstalledPackageInfo ComponentId -installedComponentId_ f s = fmap (\x -> s { T.installedComponentId_ = x }) (f (T.installedComponentId_ s)) +installedComponentId_ f s = fmap (\x -> s{T.installedComponentId_ = x}) (f (T.installedComponentId_ s)) {-# INLINE installedComponentId_ #-} -instantiatedWith :: Lens' InstalledPackageInfo [(ModuleName,OpenModule)] -instantiatedWith f s = fmap (\x -> s { T.instantiatedWith = x }) (f (T.instantiatedWith s)) +instantiatedWith :: Lens' InstalledPackageInfo [(ModuleName, OpenModule)] +instantiatedWith f s = fmap (\x -> s{T.instantiatedWith = x}) (f (T.instantiatedWith s)) {-# INLINE instantiatedWith #-} sourceLibName :: Lens' InstalledPackageInfo LibraryName -sourceLibName f s = fmap (\x -> s { T.sourceLibName = x }) (f (T.sourceLibName s)) +sourceLibName f s = fmap (\x -> s{T.sourceLibName = x}) (f (T.sourceLibName s)) {-# INLINE sourceLibName #-} compatPackageKey :: Lens' InstalledPackageInfo String -compatPackageKey f s = fmap (\x -> s { T.compatPackageKey = x }) (f (T.compatPackageKey s)) +compatPackageKey f s = fmap (\x -> s{T.compatPackageKey = x}) (f (T.compatPackageKey s)) {-# INLINE compatPackageKey #-} license :: Lens' InstalledPackageInfo (Either SPDX.License License) -license f s = fmap (\x -> s { T.license = x }) (f (T.license s)) +license f s = fmap (\x -> s{T.license = x}) (f (T.license s)) {-# INLINE license #-} copyright :: Lens' InstalledPackageInfo ShortText -copyright f s = fmap (\x -> s { T.copyright = x }) (f (T.copyright s)) +copyright f s = fmap (\x -> s{T.copyright = x}) (f (T.copyright s)) {-# INLINE copyright #-} maintainer :: Lens' InstalledPackageInfo ShortText -maintainer f s = fmap (\x -> s { T.maintainer = x }) (f (T.maintainer s)) +maintainer f s = fmap (\x -> s{T.maintainer = x}) (f (T.maintainer s)) {-# INLINE maintainer #-} author :: Lens' InstalledPackageInfo ShortText -author f s = fmap (\x -> s { T.author = x }) (f (T.author s)) +author f s = fmap (\x -> s{T.author = x}) (f (T.author s)) {-# INLINE author #-} stability :: Lens' InstalledPackageInfo ShortText -stability f s = fmap (\x -> s { T.stability = x }) (f (T.stability s)) +stability f s = fmap (\x -> s{T.stability = x}) (f (T.stability s)) {-# INLINE stability #-} homepage :: Lens' InstalledPackageInfo ShortText -homepage f s = fmap (\x -> s { T.homepage = x }) (f (T.homepage s)) +homepage f s = fmap (\x -> s{T.homepage = x}) (f (T.homepage s)) {-# INLINE homepage #-} pkgUrl :: Lens' InstalledPackageInfo ShortText -pkgUrl f s = fmap (\x -> s { T.pkgUrl = x }) (f (T.pkgUrl s)) +pkgUrl f s = fmap (\x -> s{T.pkgUrl = x}) (f (T.pkgUrl s)) {-# INLINE pkgUrl #-} synopsis :: Lens' InstalledPackageInfo ShortText -synopsis f s = fmap (\x -> s { T.synopsis = x }) (f (T.synopsis s)) +synopsis f s = fmap (\x -> s{T.synopsis = x}) (f (T.synopsis s)) {-# INLINE synopsis #-} description :: Lens' InstalledPackageInfo ShortText -description f s = fmap (\x -> s { T.description = x }) (f (T.description s)) +description f s = fmap (\x -> s{T.description = x}) (f (T.description s)) {-# INLINE description #-} category :: Lens' InstalledPackageInfo ShortText -category f s = fmap (\x -> s { T.category = x }) (f (T.category s)) +category f s = fmap (\x -> s{T.category = x}) (f (T.category s)) {-# INLINE category #-} abiHash :: Lens' InstalledPackageInfo AbiHash -abiHash f s = fmap (\x -> s { T.abiHash = x }) (f (T.abiHash s)) +abiHash f s = fmap (\x -> s{T.abiHash = x}) (f (T.abiHash s)) {-# INLINE abiHash #-} indefinite :: Lens' InstalledPackageInfo Bool -indefinite f s = fmap (\x -> s { T.indefinite = x }) (f (T.indefinite s)) +indefinite f s = fmap (\x -> s{T.indefinite = x}) (f (T.indefinite s)) {-# INLINE indefinite #-} exposed :: Lens' InstalledPackageInfo Bool -exposed f s = fmap (\x -> s { T.exposed = x }) (f (T.exposed s)) +exposed f s = fmap (\x -> s{T.exposed = x}) (f (T.exposed s)) {-# INLINE exposed #-} exposedModules :: Lens' InstalledPackageInfo [ExposedModule] -exposedModules f s = fmap (\x -> s { T.exposedModules = x }) (f (T.exposedModules s)) +exposedModules f s = fmap (\x -> s{T.exposedModules = x}) (f (T.exposedModules s)) {-# INLINE exposedModules #-} hiddenModules :: Lens' InstalledPackageInfo [ModuleName] -hiddenModules f s = fmap (\x -> s { T.hiddenModules = x }) (f (T.hiddenModules s)) +hiddenModules f s = fmap (\x -> s{T.hiddenModules = x}) (f (T.hiddenModules s)) {-# INLINE hiddenModules #-} trusted :: Lens' InstalledPackageInfo Bool -trusted f s = fmap (\x -> s { T.trusted = x }) (f (T.trusted s)) +trusted f s = fmap (\x -> s{T.trusted = x}) (f (T.trusted s)) {-# INLINE trusted #-} importDirs :: Lens' InstalledPackageInfo [FilePath] -importDirs f s = fmap (\x -> s { T.importDirs = x }) (f (T.importDirs s)) +importDirs f s = fmap (\x -> s{T.importDirs = x}) (f (T.importDirs s)) {-# INLINE importDirs #-} libraryDirs :: Lens' InstalledPackageInfo [FilePath] -libraryDirs f s = fmap (\x -> s { T.libraryDirs = x }) (f (T.libraryDirs s)) +libraryDirs f s = fmap (\x -> s{T.libraryDirs = x}) (f (T.libraryDirs s)) {-# INLINE libraryDirs #-} libraryDirsStatic :: Lens' InstalledPackageInfo [FilePath] -libraryDirsStatic f s = fmap (\x -> s { T.libraryDirsStatic = x }) (f (T.libraryDirsStatic s)) +libraryDirsStatic f s = fmap (\x -> s{T.libraryDirsStatic = x}) (f (T.libraryDirsStatic s)) {-# INLINE libraryDirsStatic #-} libraryDynDirs :: Lens' InstalledPackageInfo [FilePath] -libraryDynDirs f s = fmap (\x -> s { T.libraryDynDirs = x }) (f (T.libraryDynDirs s)) +libraryDynDirs f s = fmap (\x -> s{T.libraryDynDirs = x}) (f (T.libraryDynDirs s)) {-# INLINE libraryDynDirs #-} dataDir :: Lens' InstalledPackageInfo FilePath -dataDir f s = fmap (\x -> s { T.dataDir = x }) (f (T.dataDir s)) +dataDir f s = fmap (\x -> s{T.dataDir = x}) (f (T.dataDir s)) {-# INLINE dataDir #-} hsLibraries :: Lens' InstalledPackageInfo [String] -hsLibraries f s = fmap (\x -> s { T.hsLibraries = x }) (f (T.hsLibraries s)) +hsLibraries f s = fmap (\x -> s{T.hsLibraries = x}) (f (T.hsLibraries s)) {-# INLINE hsLibraries #-} extraLibraries :: Lens' InstalledPackageInfo [String] -extraLibraries f s = fmap (\x -> s { T.extraLibraries = x }) (f (T.extraLibraries s)) +extraLibraries f s = fmap (\x -> s{T.extraLibraries = x}) (f (T.extraLibraries s)) {-# INLINE extraLibraries #-} extraLibrariesStatic :: Lens' InstalledPackageInfo [String] -extraLibrariesStatic f s = fmap (\x -> s { T.extraLibrariesStatic = x }) (f (T.extraLibrariesStatic s)) +extraLibrariesStatic f s = fmap (\x -> s{T.extraLibrariesStatic = x}) (f (T.extraLibrariesStatic s)) {-# INLINE extraLibrariesStatic #-} extraGHCiLibraries :: Lens' InstalledPackageInfo [String] -extraGHCiLibraries f s = fmap (\x -> s { T.extraGHCiLibraries = x }) (f (T.extraGHCiLibraries s)) +extraGHCiLibraries f s = fmap (\x -> s{T.extraGHCiLibraries = x}) (f (T.extraGHCiLibraries s)) {-# INLINE extraGHCiLibraries #-} includeDirs :: Lens' InstalledPackageInfo [FilePath] -includeDirs f s = fmap (\x -> s { T.includeDirs = x }) (f (T.includeDirs s)) +includeDirs f s = fmap (\x -> s{T.includeDirs = x}) (f (T.includeDirs s)) {-# INLINE includeDirs #-} includes :: Lens' InstalledPackageInfo [String] -includes f s = fmap (\x -> s { T.includes = x }) (f (T.includes s)) +includes f s = fmap (\x -> s{T.includes = x}) (f (T.includes s)) {-# INLINE includes #-} depends :: Lens' InstalledPackageInfo [UnitId] -depends f s = fmap (\x -> s { T.depends = x }) (f (T.depends s)) +depends f s = fmap (\x -> s{T.depends = x}) (f (T.depends s)) {-# INLINE depends #-} abiDepends :: Lens' InstalledPackageInfo [AbiDependency] -abiDepends f s = fmap (\x -> s { T.abiDepends = x }) (f (T.abiDepends s)) +abiDepends f s = fmap (\x -> s{T.abiDepends = x}) (f (T.abiDepends s)) {-# INLINE abiDepends #-} ccOptions :: Lens' InstalledPackageInfo [String] -ccOptions f s = fmap (\x -> s { T.ccOptions = x }) (f (T.ccOptions s)) +ccOptions f s = fmap (\x -> s{T.ccOptions = x}) (f (T.ccOptions s)) {-# INLINE ccOptions #-} cxxOptions :: Lens' InstalledPackageInfo [String] -cxxOptions f s = fmap (\x -> s { T.cxxOptions = x }) (f (T.cxxOptions s)) +cxxOptions f s = fmap (\x -> s{T.cxxOptions = x}) (f (T.cxxOptions s)) {-# INLINE cxxOptions #-} ldOptions :: Lens' InstalledPackageInfo [String] -ldOptions f s = fmap (\x -> s { T.ldOptions = x }) (f (T.ldOptions s)) +ldOptions f s = fmap (\x -> s{T.ldOptions = x}) (f (T.ldOptions s)) {-# INLINE ldOptions #-} frameworkDirs :: Lens' InstalledPackageInfo [FilePath] -frameworkDirs f s = fmap (\x -> s { T.frameworkDirs = x }) (f (T.frameworkDirs s)) +frameworkDirs f s = fmap (\x -> s{T.frameworkDirs = x}) (f (T.frameworkDirs s)) {-# INLINE frameworkDirs #-} frameworks :: Lens' InstalledPackageInfo [String] -frameworks f s = fmap (\x -> s { T.frameworks = x }) (f (T.frameworks s)) +frameworks f s = fmap (\x -> s{T.frameworks = x}) (f (T.frameworks s)) {-# INLINE frameworks #-} haddockInterfaces :: Lens' InstalledPackageInfo [FilePath] -haddockInterfaces f s = fmap (\x -> s { T.haddockInterfaces = x }) (f (T.haddockInterfaces s)) +haddockInterfaces f s = fmap (\x -> s{T.haddockInterfaces = x}) (f (T.haddockInterfaces s)) {-# INLINE haddockInterfaces #-} haddockHTMLs :: Lens' InstalledPackageInfo [FilePath] -haddockHTMLs f s = fmap (\x -> s { T.haddockHTMLs = x }) (f (T.haddockHTMLs s)) +haddockHTMLs f s = fmap (\x -> s{T.haddockHTMLs = x}) (f (T.haddockHTMLs s)) {-# INLINE haddockHTMLs #-} pkgRoot :: Lens' InstalledPackageInfo (Maybe FilePath) -pkgRoot f s = fmap (\x -> s { T.pkgRoot = x }) (f (T.pkgRoot s)) +pkgRoot f s = fmap (\x -> s{T.pkgRoot = x}) (f (T.pkgRoot s)) {-# INLINE pkgRoot #-} libVisibility :: Lens' InstalledPackageInfo LibraryVisibility -libVisibility f s = fmap (\x -> s { T.libVisibility = x }) (f (T.libVisibility s)) +libVisibility f s = fmap (\x -> s{T.libVisibility = x}) (f (T.libVisibility s)) {-# INLINE libVisibility #-} - diff --git a/Cabal-syntax/src/Distribution/Types/LegacyExeDependency.hs b/Cabal-syntax/src/Distribution/Types/LegacyExeDependency.hs index 8f010d330ed..7acf028d0b3 100644 --- a/Cabal-syntax/src/Distribution/Types/LegacyExeDependency.hs +++ b/Cabal-syntax/src/Distribution/Types/LegacyExeDependency.hs @@ -1,7 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} + module Distribution.Types.LegacyExeDependency - ( LegacyExeDependency(..) + ( LegacyExeDependency (..) ) where import Distribution.Compat.Prelude @@ -12,7 +13,7 @@ import Distribution.Pretty import Distribution.Version (VersionRange, anyVersion) import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp +import qualified Text.PrettyPrint as Disp -- | Describes a legacy `build-tools`-style dependency on an executable -- @@ -21,27 +22,28 @@ import qualified Text.PrettyPrint as Disp -- executable (UnqualComponentName). Thus the name is stringly typed. -- -- @since 2.0.0.2 -data LegacyExeDependency = LegacyExeDependency - String - VersionRange - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) +data LegacyExeDependency + = LegacyExeDependency + String + VersionRange + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) instance Binary LegacyExeDependency instance Structured LegacyExeDependency instance NFData LegacyExeDependency where rnf = genericRnf instance Pretty LegacyExeDependency where - pretty (LegacyExeDependency name ver) = - Disp.text name <+> pretty ver + pretty (LegacyExeDependency name ver) = + Disp.text name <+> pretty ver instance Parsec LegacyExeDependency where - parsec = do - name <- parsecMaybeQuoted nameP - P.spaces - verRange <- parsecMaybeQuoted parsec <|> pure anyVersion - pure $ LegacyExeDependency name verRange - where - nameP = intercalate "-" <$> toList <$> P.sepByNonEmpty component (P.char '-') - component = do - cs <- P.munch1 (\c -> isAlphaNum c || c == '+' || c == '_') - if all isDigit cs then fail "invalid component" else return cs + parsec = do + name <- parsecMaybeQuoted nameP + P.spaces + verRange <- parsecMaybeQuoted parsec <|> pure anyVersion + pure $ LegacyExeDependency name verRange + where + nameP = intercalate "-" <$> toList <$> P.sepByNonEmpty component (P.char '-') + component = do + cs <- P.munch1 (\c -> isAlphaNum c || c == '+' || c == '_') + if all isDigit cs then fail "invalid component" else return cs diff --git a/Cabal-syntax/src/Distribution/Types/Lens.hs b/Cabal-syntax/src/Distribution/Types/Lens.hs index 1581ff23cdd..2934d722fbd 100644 --- a/Cabal-syntax/src/Distribution/Types/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/Lens.hs @@ -1,16 +1,16 @@ -module Distribution.Types.Lens ( - module Distribution.Types.Benchmark.Lens, - module Distribution.Types.BuildInfo.Lens, - module Distribution.Types.Executable.Lens, - module Distribution.Types.ForeignLib.Lens, - module Distribution.Types.GenericPackageDescription.Lens, - module Distribution.Types.Library.Lens, - module Distribution.Types.PackageDescription.Lens, - module Distribution.Types.PackageId.Lens, - module Distribution.Types.SetupBuildInfo.Lens, - module Distribution.Types.SourceRepo.Lens, - module Distribution.Types.TestSuite.Lens, - ) where +module Distribution.Types.Lens + ( module Distribution.Types.Benchmark.Lens + , module Distribution.Types.BuildInfo.Lens + , module Distribution.Types.Executable.Lens + , module Distribution.Types.ForeignLib.Lens + , module Distribution.Types.GenericPackageDescription.Lens + , module Distribution.Types.Library.Lens + , module Distribution.Types.PackageDescription.Lens + , module Distribution.Types.PackageId.Lens + , module Distribution.Types.SetupBuildInfo.Lens + , module Distribution.Types.SourceRepo.Lens + , module Distribution.Types.TestSuite.Lens + ) where import Distribution.Types.Benchmark.Lens import Distribution.Types.BuildInfo.Lens diff --git a/Cabal-syntax/src/Distribution/Types/Library.hs b/Cabal-syntax/src/Distribution/Types/Library.hs index 4ac153bc0b0..738965ea167 100644 --- a/Cabal-syntax/src/Distribution/Types/Library.hs +++ b/Cabal-syntax/src/Distribution/Types/Library.hs @@ -1,51 +1,55 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.Library ( - Library(..), - emptyLibrary, - explicitLibModules, - libModulesAutogen, -) where +module Distribution.Types.Library + ( Library (..) + , emptyLibrary + , explicitLibModules + , libModulesAutogen + ) where import Distribution.Compat.Prelude import Prelude () import Distribution.ModuleName import Distribution.Types.BuildInfo +import Distribution.Types.LibraryName import Distribution.Types.LibraryVisibility import Distribution.Types.ModuleReexport -import Distribution.Types.LibraryName import qualified Distribution.Types.BuildInfo.Lens as L data Library = Library - { libName :: LibraryName - , exposedModules :: [ModuleName] - , reexportedModules :: [ModuleReexport] - , signatures :: [ModuleName] -- ^ What sigs need implementations? - , libExposed :: Bool -- ^ Is the lib to be exposed by default? (i.e. whether its modules available in GHCi for example) - , libVisibility :: LibraryVisibility -- ^ Whether this multilib can be used as a dependency for other packages. - , libBuildInfo :: BuildInfo - } - deriving (Generic, Show, Eq, Ord, Read, Typeable, Data) + { libName :: LibraryName + , exposedModules :: [ModuleName] + , reexportedModules :: [ModuleReexport] + , signatures :: [ModuleName] + -- ^ What sigs need implementations? + , libExposed :: Bool + -- ^ Is the lib to be exposed by default? (i.e. whether its modules available in GHCi for example) + , libVisibility :: LibraryVisibility + -- ^ Whether this multilib can be used as a dependency for other packages. + , libBuildInfo :: BuildInfo + } + deriving (Generic, Show, Eq, Ord, Read, Typeable, Data) instance L.HasBuildInfo Library where - buildInfo f l = (\x -> l { libBuildInfo = x }) <$> f (libBuildInfo l) + buildInfo f l = (\x -> l{libBuildInfo = x}) <$> f (libBuildInfo l) instance Binary Library instance Structured Library instance NFData Library where rnf = genericRnf emptyLibrary :: Library -emptyLibrary = Library - { libName = LMainLibName - , exposedModules = mempty +emptyLibrary = + Library + { libName = LMainLibName + , exposedModules = mempty , reexportedModules = mempty - , signatures = mempty - , libExposed = True - , libVisibility = mempty - , libBuildInfo = mempty + , signatures = mempty + , libExposed = True + , libVisibility = mempty + , libBuildInfo = mempty } -- | This instance is not good. @@ -55,22 +59,23 @@ emptyLibrary = Library -- -- More concretely, 'addBuildableCondition' will make `libVisibility = False` -- libraries when `buildable: false`. This may cause problems. --- instance Monoid Library where - mempty = emptyLibrary - mappend = (<>) + mempty = emptyLibrary + mappend = (<>) instance Semigroup Library where - a <> b = Library - { libName = combineLibraryName (libName a) (libName b) - , exposedModules = combine exposedModules - , reexportedModules = combine reexportedModules - , signatures = combine signatures - , libExposed = libExposed a && libExposed b -- so False propagates - , libVisibility = combine libVisibility - , libBuildInfo = combine libBuildInfo - } - where combine field = field a `mappend` field b + a <> b = + Library + { libName = combineLibraryName (libName a) (libName b) + , exposedModules = combine exposedModules + , reexportedModules = combine reexportedModules + , signatures = combine signatures + , libExposed = libExposed a && libExposed b -- so False propagates + , libVisibility = combine libVisibility + , libBuildInfo = combine libBuildInfo + } + where + combine field = field a `mappend` field b -- | Get all the module names from the library (exposed and internal modules) -- which are explicitly listed in the package description which would @@ -78,9 +83,10 @@ instance Semigroup Library where -- do not need to be compiled.) This may not include all modules for which -- GHC generated interface files (i.e., implicit modules.) explicitLibModules :: Library -> [ModuleName] -explicitLibModules lib = exposedModules lib - ++ otherModules (libBuildInfo lib) - ++ signatures lib +explicitLibModules lib = + exposedModules lib + ++ otherModules (libBuildInfo lib) + ++ signatures lib -- | Get all the auto generated module names from the library, exposed or not. -- This are a subset of 'libModules'. @@ -93,4 +99,4 @@ libModulesAutogen lib = autogenModules (libBuildInfo lib) -- /Should/ be irrelevant. combineLibraryName :: LibraryName -> LibraryName -> LibraryName combineLibraryName l@(LSubLibName _) _ = l -combineLibraryName _ l = l +combineLibraryName _ l = l diff --git a/Cabal-syntax/src/Distribution/Types/Library/Lens.hs b/Cabal-syntax/src/Distribution/Types/Library/Lens.hs index fefccbdd1a3..9787f3700dd 100644 --- a/Cabal-syntax/src/Distribution/Types/Library/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/Library/Lens.hs @@ -1,45 +1,45 @@ -module Distribution.Types.Library.Lens ( - Library, - module Distribution.Types.Library.Lens, - ) where +module Distribution.Types.Library.Lens + ( Library + , module Distribution.Types.Library.Lens + ) where import Distribution.Compat.Lens import Distribution.Compat.Prelude import Prelude () -import Distribution.ModuleName (ModuleName) -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.Library (Library) -import Distribution.Types.LibraryName (LibraryName) +import Distribution.ModuleName (ModuleName) +import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.Library (Library) +import Distribution.Types.LibraryName (LibraryName) import Distribution.Types.LibraryVisibility (LibraryVisibility) -import Distribution.Types.ModuleReexport (ModuleReexport) +import Distribution.Types.ModuleReexport (ModuleReexport) import qualified Distribution.Types.Library as T libName :: Lens' Library LibraryName -libName f s = fmap (\x -> s { T.libName = x }) (f (T.libName s)) +libName f s = fmap (\x -> s{T.libName = x}) (f (T.libName s)) {-# INLINE libName #-} exposedModules :: Lens' Library [ModuleName] -exposedModules f s = fmap (\x -> s { T.exposedModules = x }) (f (T.exposedModules s)) +exposedModules f s = fmap (\x -> s{T.exposedModules = x}) (f (T.exposedModules s)) {-# INLINE exposedModules #-} reexportedModules :: Lens' Library [ModuleReexport] -reexportedModules f s = fmap (\x -> s { T.reexportedModules = x }) (f (T.reexportedModules s)) +reexportedModules f s = fmap (\x -> s{T.reexportedModules = x}) (f (T.reexportedModules s)) {-# INLINE reexportedModules #-} signatures :: Lens' Library [ModuleName] -signatures f s = fmap (\x -> s { T.signatures = x }) (f (T.signatures s)) +signatures f s = fmap (\x -> s{T.signatures = x}) (f (T.signatures s)) {-# INLINE signatures #-} libExposed :: Lens' Library Bool -libExposed f s = fmap (\x -> s { T.libExposed = x }) (f (T.libExposed s)) +libExposed f s = fmap (\x -> s{T.libExposed = x}) (f (T.libExposed s)) {-# INLINE libExposed #-} libVisibility :: Lens' Library LibraryVisibility -libVisibility f s = fmap (\x -> s { T.libVisibility = x }) (f (T.libVisibility s)) +libVisibility f s = fmap (\x -> s{T.libVisibility = x}) (f (T.libVisibility s)) {-# INLINE libVisibility #-} libBuildInfo :: Lens' Library BuildInfo -libBuildInfo f s = fmap (\x -> s { T.libBuildInfo = x }) (f (T.libBuildInfo s)) +libBuildInfo f s = fmap (\x -> s{T.libBuildInfo = x}) (f (T.libBuildInfo s)) {-# INLINE libBuildInfo #-} diff --git a/Cabal-syntax/src/Distribution/Types/LibraryName.hs b/Cabal-syntax/src/Distribution/Types/LibraryName.hs index 109ccd1a127..2b8f53f4f89 100644 --- a/Cabal-syntax/src/Distribution/Types/LibraryName.hs +++ b/Cabal-syntax/src/Distribution/Types/LibraryName.hs @@ -1,31 +1,33 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.LibraryName ( - LibraryName(..), - defaultLibName, - maybeToLibraryName, - showLibraryName, - libraryNameStanza, - libraryNameString, - -- * Pretty & Parse - prettyLibraryNameComponent, - parsecLibraryNameComponent, +module Distribution.Types.LibraryName + ( LibraryName (..) + , defaultLibName + , maybeToLibraryName + , showLibraryName + , libraryNameStanza + , libraryNameString + + -- * Pretty & Parse + , prettyLibraryNameComponent + , parsecLibraryNameComponent ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.UnqualComponentName -import Distribution.Pretty import Distribution.Parsec +import Distribution.Pretty +import Distribution.Types.UnqualComponentName import qualified Distribution.Compat.CharParsing as P import qualified Text.PrettyPrint as Disp -data LibraryName = LMainLibName - | LSubLibName UnqualComponentName - deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) +data LibraryName + = LMainLibName + | LSubLibName UnqualComponentName + deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) instance Binary LibraryName instance Structured LibraryName @@ -37,28 +39,28 @@ instance NFData LibraryName where rnf = genericRnf -- as there's other way to represent 'LibraryName', namely as bare -- 'UnqualComponentName'. prettyLibraryNameComponent :: LibraryName -> Disp.Doc -prettyLibraryNameComponent LMainLibName = Disp.text "lib" +prettyLibraryNameComponent LMainLibName = Disp.text "lib" prettyLibraryNameComponent (LSubLibName str) = Disp.text "lib:" <<>> pretty str parsecLibraryNameComponent :: CabalParsing m => m LibraryName parsecLibraryNameComponent = do - _ <- P.string "lib" - parseComposite <|> parseSingle + _ <- P.string "lib" + parseComposite <|> parseSingle where parseSingle = return LMainLibName parseComposite = do - _ <- P.char ':' - LSubLibName <$> parsec + _ <- P.char ':' + LSubLibName <$> parsec defaultLibName :: LibraryName defaultLibName = LMainLibName showLibraryName :: LibraryName -> String -showLibraryName LMainLibName = "library" +showLibraryName LMainLibName = "library" showLibraryName (LSubLibName name) = "library '" ++ prettyShow name ++ "'" libraryNameStanza :: LibraryName -> String -libraryNameStanza LMainLibName = "library" +libraryNameStanza LMainLibName = "library" libraryNameStanza (LSubLibName name) = "library " ++ prettyShow name libraryNameString :: LibraryName -> Maybe UnqualComponentName @@ -70,4 +72,3 @@ libraryNameString (LSubLibName n) = Just n maybeToLibraryName :: Maybe UnqualComponentName -> LibraryName maybeToLibraryName Nothing = LMainLibName maybeToLibraryName (Just n) = LSubLibName n - diff --git a/Cabal-syntax/src/Distribution/Types/LibraryVisibility.hs b/Cabal-syntax/src/Distribution/Types/LibraryVisibility.hs index 7ef160ace4d..bf113488a5c 100644 --- a/Cabal-syntax/src/Distribution/Types/LibraryVisibility.hs +++ b/Cabal-syntax/src/Distribution/Types/LibraryVisibility.hs @@ -1,10 +1,10 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} -module Distribution.Types.LibraryVisibility( - LibraryVisibility(..), -) where +module Distribution.Types.LibraryVisibility + ( LibraryVisibility (..) + ) where import Distribution.Compat.Prelude import Prelude () @@ -13,39 +13,38 @@ import Distribution.Parsec import Distribution.Pretty import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp +import qualified Text.PrettyPrint as Disp -- | Multi-lib visibility -- -- @since 3.0.0.0 --- data LibraryVisibility - -- | Can be used as a dependency for other packages - = LibraryVisibilityPublic - -- | Internal library, default - | LibraryVisibilityPrivate - deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) + = -- | Can be used as a dependency for other packages + LibraryVisibilityPublic + | -- | Internal library, default + LibraryVisibilityPrivate + deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) instance Pretty LibraryVisibility where - pretty LibraryVisibilityPublic = Disp.text "public" - pretty LibraryVisibilityPrivate = Disp.text "private" + pretty LibraryVisibilityPublic = Disp.text "public" + pretty LibraryVisibilityPrivate = Disp.text "private" instance Parsec LibraryVisibility where parsec = do name <- P.munch1 isAlpha case name of - "public" -> return LibraryVisibilityPublic + "public" -> return LibraryVisibilityPublic "private" -> return LibraryVisibilityPrivate - _ -> fail $ "Unknown visibility: " ++ name + _ -> fail $ "Unknown visibility: " ++ name instance Binary LibraryVisibility instance Structured LibraryVisibility instance NFData LibraryVisibility where rnf = genericRnf instance Semigroup LibraryVisibility where - LibraryVisibilityPrivate <> LibraryVisibilityPrivate = LibraryVisibilityPrivate - _ <> _ = LibraryVisibilityPublic + LibraryVisibilityPrivate <> LibraryVisibilityPrivate = LibraryVisibilityPrivate + _ <> _ = LibraryVisibilityPublic instance Monoid LibraryVisibility where - mempty = LibraryVisibilityPrivate - mappend = (<>) + mempty = LibraryVisibilityPrivate + mappend = (<>) diff --git a/Cabal-syntax/src/Distribution/Types/Mixin.hs b/Cabal-syntax/src/Distribution/Types/Mixin.hs index c119006e163..6a2a527ca58 100644 --- a/Cabal-syntax/src/Distribution/Types/Mixin.hs +++ b/Cabal-syntax/src/Distribution/Types/Mixin.hs @@ -1,11 +1,11 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.Mixin ( - Mixin(..), - mkMixin, - normaliseMixin, -) where +module Distribution.Types.Mixin + ( Mixin (..) + , mkMixin + , normaliseMixin + ) where import Distribution.Compat.Prelude import Prelude () @@ -19,18 +19,19 @@ import Distribution.Types.PackageName import Distribution.Types.UnqualComponentName import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as PP +import qualified Text.PrettyPrint as PP -- | -- -- /Invariant:/ if 'mixinLibraryName' is 'LSubLibName', it's not -- the same as 'mixinPackageName'. In other words, -- the same invariant as 'Dependency' has. --- -data Mixin = Mixin { mixinPackageName :: PackageName - , mixinLibraryName :: LibraryName - , mixinIncludeRenaming :: IncludeRenaming } - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) +data Mixin = Mixin + { mixinPackageName :: PackageName + , mixinLibraryName :: LibraryName + , mixinIncludeRenaming :: IncludeRenaming + } + deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) instance Binary Mixin instance Structured Mixin @@ -38,8 +39,8 @@ instance Structured Mixin instance NFData Mixin where rnf = genericRnf instance Pretty Mixin where - pretty (Mixin pn LMainLibName incl) = pretty pn <+> pretty incl - pretty (Mixin pn (LSubLibName ln) incl) = pretty pn <<>> PP.colon <<>> pretty ln <+> pretty incl + pretty (Mixin pn LMainLibName incl) = pretty pn <+> pretty incl + pretty (Mixin pn (LSubLibName ln) incl) = pretty pn <<>> PP.colon <<>> pretty ln <+> pretty incl -- | -- @@ -56,36 +57,37 @@ instance Pretty Mixin where -- -- >>> map (`simpleParsec'` "mylib:sub") [CabalSpecV3_0, CabalSpecV3_4] :: [Maybe Mixin] -- [Nothing,Just (Mixin {mixinPackageName = PackageName "mylib", mixinLibraryName = LSubLibName (UnqualComponentName "sub"), mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}})] --- instance Parsec Mixin where - parsec = do - pn <- parsec - ln <- P.option LMainLibName $ do - _ <- P.char ':' - versionGuardMultilibs - LSubLibName <$> parsec - P.spaces - incl <- parsec - return (mkMixin pn ln incl) - where + parsec = do + pn <- parsec + ln <- P.option LMainLibName $ do + _ <- P.char ':' + versionGuardMultilibs + LSubLibName <$> parsec + P.spaces + incl <- parsec + return (mkMixin pn ln incl) + where versionGuardMultilibs :: CabalParsing m => m () versionGuardMultilibs = do csv <- askCabalSpecVersion - when (csv < CabalSpecV3_4) $ fail $ unwords - [ "Sublibrary mixin syntax used." - , "To use this syntax the package needs to specify at least 'cabal-version: 3.4'." - ] + when (csv < CabalSpecV3_4) $ + fail $ + unwords + [ "Sublibrary mixin syntax used." + , "To use this syntax the package needs to specify at least 'cabal-version: 3.4'." + ] -- | Smart constructor of 'Mixin', enforces invariant. -- -- @since 3.4.0.0 mkMixin :: PackageName -> LibraryName -> IncludeRenaming -> Mixin mkMixin pn (LSubLibName uqn) incl - | packageNameToUnqualComponentName pn == uqn - = Mixin pn LMainLibName incl -mkMixin pn ln incl - = Mixin pn ln incl + | packageNameToUnqualComponentName pn == uqn = + Mixin pn LMainLibName incl +mkMixin pn ln incl = + Mixin pn ln incl -- | Restore invariant normaliseMixin :: Mixin -> Mixin diff --git a/Cabal-syntax/src/Distribution/Types/Module.hs b/Cabal-syntax/src/Distribution/Types/Module.hs index 187163c2824..e9febeff070 100644 --- a/Cabal-syntax/src/Distribution/Types/Module.hs +++ b/Cabal-syntax/src/Distribution/Types/Module.hs @@ -3,18 +3,18 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Distribution.Types.Module - ( Module(..) + ( Module (..) ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp -import Distribution.Pretty +import Distribution.ModuleName import Distribution.Parsec +import Distribution.Pretty import Distribution.Types.UnitId -import Distribution.ModuleName +import qualified Text.PrettyPrint as Disp -- | A module identity uniquely identifies a Haskell module by -- qualifying a 'ModuleName' with the 'UnitId' which defined @@ -24,23 +24,23 @@ import Distribution.ModuleName -- There are a few cases where Cabal needs to know about -- module identities, e.g., when writing out reexported modules in -- the 'InstalledPackageInfo'. -data Module = - Module DefUnitId ModuleName - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) +data Module + = Module DefUnitId ModuleName + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) instance Binary Module instance Structured Module instance Pretty Module where - pretty (Module uid mod_name) = - pretty uid <<>> Disp.text ":" <<>> pretty mod_name + pretty (Module uid mod_name) = + pretty uid <<>> Disp.text ":" <<>> pretty mod_name instance Parsec Module where - parsec = do - uid <- parsec - _ <- P.char ':' - mod_name <- parsec - return (Module uid mod_name) + parsec = do + uid <- parsec + _ <- P.char ':' + mod_name <- parsec + return (Module uid mod_name) instance NFData Module where - rnf (Module uid mod_name) = rnf uid `seq` rnf mod_name + rnf (Module uid mod_name) = rnf uid `seq` rnf mod_name diff --git a/Cabal-syntax/src/Distribution/Types/ModuleReexport.hs b/Cabal-syntax/src/Distribution/Types/ModuleReexport.hs index 03aae9cd4f6..0dae6002c3c 100644 --- a/Cabal-syntax/src/Distribution/Types/ModuleReexport.hs +++ b/Cabal-syntax/src/Distribution/Types/ModuleReexport.hs @@ -1,9 +1,9 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.ModuleReexport ( - ModuleReexport(..) -) where +module Distribution.Types.ModuleReexport + ( ModuleReexport (..) + ) where import Distribution.Compat.Prelude import Prelude () @@ -14,37 +14,37 @@ import Distribution.Pretty import Distribution.Types.PackageName import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp +import qualified Text.PrettyPrint as Disp -- ----------------------------------------------------------------------------- -- Module re-exports -data ModuleReexport = ModuleReexport { - moduleReexportOriginalPackage :: Maybe PackageName, - moduleReexportOriginalName :: ModuleName, - moduleReexportName :: ModuleName - } - deriving (Eq, Ord, Generic, Read, Show, Typeable, Data) +data ModuleReexport = ModuleReexport + { moduleReexportOriginalPackage :: Maybe PackageName + , moduleReexportOriginalName :: ModuleName + , moduleReexportName :: ModuleName + } + deriving (Eq, Ord, Generic, Read, Show, Typeable, Data) instance Binary ModuleReexport instance Structured ModuleReexport instance NFData ModuleReexport where rnf = genericRnf instance Pretty ModuleReexport where - pretty (ModuleReexport mpkgname origname newname) = - maybe Disp.empty (\pkgname -> pretty pkgname <<>> Disp.char ':') mpkgname - <<>> pretty origname + pretty (ModuleReexport mpkgname origname newname) = + maybe Disp.empty (\pkgname -> pretty pkgname <<>> Disp.char ':') mpkgname + <<>> pretty origname <+> if newname == origname - then Disp.empty - else Disp.text "as" <+> pretty newname + then Disp.empty + else Disp.text "as" <+> pretty newname instance Parsec ModuleReexport where - parsec = do - mpkgname <- P.optional (P.try $ parsec <* P.char ':') - origname <- parsec - newname <- P.option origname $ P.try $ do - P.spaces - _ <- P.string "as" - P.spaces - parsec - return (ModuleReexport mpkgname origname newname) + parsec = do + mpkgname <- P.optional (P.try $ parsec <* P.char ':') + origname <- parsec + newname <- P.option origname $ P.try $ do + P.spaces + _ <- P.string "as" + P.spaces + parsec + return (ModuleReexport mpkgname origname newname) diff --git a/Cabal-syntax/src/Distribution/Types/ModuleRenaming.hs b/Cabal-syntax/src/Distribution/Types/ModuleRenaming.hs index 581d45b9938..022a321a055 100644 --- a/Cabal-syntax/src/Distribution/Types/ModuleRenaming.hs +++ b/Cabal-syntax/src/Distribution/Types/ModuleRenaming.hs @@ -1,13 +1,13 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RankNTypes #-} -module Distribution.Types.ModuleRenaming ( - ModuleRenaming(..), - interpModuleRenaming, - defaultRenaming, - isDefaultRenaming, -) where +module Distribution.Types.ModuleRenaming + ( ModuleRenaming (..) + , interpModuleRenaming + , defaultRenaming + , isDefaultRenaming + ) where import Distribution.CabalSpecVersion import Distribution.Compat.Prelude hiding (empty) @@ -17,10 +17,10 @@ import Distribution.ModuleName import Distribution.Parsec import Distribution.Pretty -import qualified Data.Map as Map -import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.Set as Set import qualified Distribution.Compat.CharParsing as P -import Text.PrettyPrint (hsep, parens, punctuate, text, comma) +import Text.PrettyPrint (comma, hsep, parens, punctuate, text) -- | Renaming applied to the modules provided by a package. -- The boolean indicates whether or not to also include all of the @@ -30,18 +30,17 @@ import Text.PrettyPrint (hsep, parens, punctuate, text, comm -- If a renaming is omitted you get the 'DefaultRenaming'. -- -- (NB: This is a list not a map so that we can preserve order.) --- data ModuleRenaming - -- | A module renaming/thinning; e.g., @(A as B, C as C)@ - -- brings @B@ and @C@ into scope. - = ModuleRenaming [(ModuleName, ModuleName)] - -- | The default renaming, bringing all exported modules - -- into scope. - | DefaultRenaming - -- | Hiding renaming, e.g., @hiding (A, B)@, bringing all - -- exported modules into scope except the hidden ones. - | HidingRenaming [ModuleName] - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) + = -- | A module renaming/thinning; e.g., @(A as B, C as C)@ + -- brings @B@ and @C@ into scope. + ModuleRenaming [(ModuleName, ModuleName)] + | -- | The default renaming, bringing all exported modules + -- into scope. + DefaultRenaming + | -- | Hiding renaming, e.g., @hiding (A, B)@, bringing all + -- exported modules into scope except the hidden ones. + HidingRenaming [ModuleName] + deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) -- | Interpret a 'ModuleRenaming' as a partial map from 'ModuleName' -- to 'ModuleName'. For efficiency, you should partially apply it @@ -49,11 +48,11 @@ data ModuleRenaming interpModuleRenaming :: ModuleRenaming -> ModuleName -> Maybe ModuleName interpModuleRenaming DefaultRenaming = Just interpModuleRenaming (ModuleRenaming rns) = - let m = Map.fromList rns - in \k -> Map.lookup k m + let m = Map.fromList rns + in \k -> Map.lookup k m interpModuleRenaming (HidingRenaming hs) = - let s = Set.fromList hs - in \k -> if k `Set.member` s then Nothing else Just k + let s = Set.fromList hs + in \k -> if k `Set.member` s then Nothing else Just k -- | The default renaming, if something is specified in @build-depends@ -- only. @@ -66,10 +65,8 @@ isDefaultRenaming :: ModuleRenaming -> Bool isDefaultRenaming DefaultRenaming = True isDefaultRenaming _ = False - - -instance Binary ModuleRenaming where -instance Structured ModuleRenaming where +instance Binary ModuleRenaming +instance Structured ModuleRenaming instance NFData ModuleRenaming where rnf = genericRnf @@ -77,58 +74,62 @@ instance NFData ModuleRenaming where rnf = genericRnf -- to allow "hiding (A, B)" or other modifier words. instance Pretty ModuleRenaming where pretty DefaultRenaming = mempty - pretty (HidingRenaming hides) - = text "hiding" <+> parens (hsep (punctuate comma (map pretty hides))) - pretty (ModuleRenaming rns) - = parens . hsep $ punctuate comma (map dispEntry rns) - where dispEntry (orig, new) - | orig == new = pretty orig - | otherwise = pretty orig <+> text "as" <+> pretty new + pretty (HidingRenaming hides) = + text "hiding" <+> parens (hsep (punctuate comma (map pretty hides))) + pretty (ModuleRenaming rns) = + parens . hsep $ punctuate comma (map dispEntry rns) + where + dispEntry (orig, new) + | orig == new = pretty orig + | otherwise = pretty orig <+> text "as" <+> pretty new instance Parsec ModuleRenaming where - parsec = do - csv <- askCabalSpecVersion - if csv >= CabalSpecV3_0 - then moduleRenamingParsec parensLax lexemeParsec - else moduleRenamingParsec parensStrict parsec - where - -- For cabal spec versions < 3.0 white spaces were not skipped - -- after the '(' and ')' tokens in the mixin field. This - -- parser checks the cabal file version and does the correct - -- skipping of spaces. - parensLax p = P.between (P.char '(' >> P.spaces) (P.char ')' >> P.spaces) p - parensStrict p = P.between (P.char '(' >> warnSpaces) (P.char ')') p - - warnSpaces = P.optional $ - P.space *> fail "space after parenthesis, use cabal-version: 3.0 or higher" + parsec = do + csv <- askCabalSpecVersion + if csv >= CabalSpecV3_0 + then moduleRenamingParsec parensLax lexemeParsec + else moduleRenamingParsec parensStrict parsec + where + -- For cabal spec versions < 3.0 white spaces were not skipped + -- after the '(' and ')' tokens in the mixin field. This + -- parser checks the cabal file version and does the correct + -- skipping of spaces. + parensLax p = P.between (P.char '(' >> P.spaces) (P.char ')' >> P.spaces) p + parensStrict p = P.between (P.char '(' >> warnSpaces) (P.char ')') p + + warnSpaces = + P.optional $ + P.space *> fail "space after parenthesis, use cabal-version: 3.0 or higher" moduleRenamingParsec - :: CabalParsing m - => (forall a. m a -> m a) -- ^ between parens - -> m ModuleName -- ^ module name parser - -> m ModuleRenaming + :: CabalParsing m + => (forall a. m a -> m a) + -- ^ between parens + -> m ModuleName + -- ^ module name parser + -> m ModuleRenaming moduleRenamingParsec bp mn = - -- NB: try not necessary as the first token is obvious - P.choice [ parseRename, parseHiding, return DefaultRenaming ] + -- NB: try not necessary as the first token is obvious + P.choice [parseRename, parseHiding, return DefaultRenaming] where cma = P.char ',' >> P.spaces parseRename = do - rns <- bp parseList - P.spaces - return (ModuleRenaming rns) + rns <- bp parseList + P.spaces + return (ModuleRenaming rns) parseHiding = do - _ <- P.string "hiding" - P.spaces -- space isn't strictly required as next is an open paren - hides <- bp (P.sepBy mn cma) - return (HidingRenaming hides) + _ <- P.string "hiding" + P.spaces -- space isn't strictly required as next is an open paren + hides <- bp (P.sepBy mn cma) + return (HidingRenaming hides) parseList = - P.sepBy parseEntry cma + P.sepBy parseEntry cma parseEntry = do - orig <- parsec + orig <- parsec + P.spaces + P.option (orig, orig) $ do + _ <- P.string "as" + P.skipSpaces1 -- require space after "as" + new <- parsec P.spaces - P.option (orig, orig) $ do - _ <- P.string "as" - P.skipSpaces1 -- require space after "as" - new <- parsec - P.spaces - return (orig, new) + return (orig, new) diff --git a/Cabal-syntax/src/Distribution/Types/MungedPackageId.hs b/Cabal-syntax/src/Distribution/Types/MungedPackageId.hs index 2403c9f220c..f1e0904586d 100644 --- a/Cabal-syntax/src/Distribution/Types/MungedPackageId.hs +++ b/Cabal-syntax/src/Distribution/Types/MungedPackageId.hs @@ -1,7 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} + module Distribution.Types.MungedPackageId - ( MungedPackageId(..) + ( MungedPackageId (..) , computeCompatPackageId ) where @@ -13,22 +14,21 @@ import Distribution.Pretty import Distribution.Types.LibraryName import Distribution.Types.MungedPackageName import Distribution.Types.PackageId -import Distribution.Version (Version, nullVersion) +import Distribution.Version (Version, nullVersion) import qualified Text.PrettyPrint as Disp -- | A simple pair of a 'MungedPackageName' and 'Version'. 'MungedPackageName' is to -- 'MungedPackageId' as 'PackageName' is to 'PackageId'. See 'MungedPackageName' for more -- info. -data MungedPackageId - = MungedPackageId { - -- | The combined package and component name. see documentation for - -- 'MungedPackageName'. - mungedName :: MungedPackageName, - -- | The version of this package / component, eg 1.2 - mungedVersion :: Version - } - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) +data MungedPackageId = MungedPackageId + { mungedName :: MungedPackageName + -- ^ The combined package and component name. see documentation for + -- 'MungedPackageName'. + , mungedVersion :: Version + -- ^ The version of this package / component, eg 1.2 + } + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) instance Binary MungedPackageId instance Structured MungedPackageId @@ -40,11 +40,10 @@ instance Structured MungedPackageId -- -- >>> prettyShow $ MungedPackageId (MungedPackageName "servant" (LSubLibName "lackey")) (mkVersion [0,1,2]) -- "z-servant-z-lackey-0.1.2" --- instance Pretty MungedPackageId where - pretty (MungedPackageId n v) - | v == nullVersion = pretty n -- if no version, don't show version. - | otherwise = pretty n <<>> Disp.char '-' <<>> pretty v + pretty (MungedPackageId n v) + | v == nullVersion = pretty n -- if no version, don't show version. + | otherwise = pretty n <<>> Disp.char '-' <<>> pretty v -- | -- @@ -65,18 +64,17 @@ instance Pretty MungedPackageId where -- -- >>> simpleParsec "foo-bar.4-2" :: Maybe MungedPackageId -- Nothing --- instance Parsec MungedPackageId where - parsec = do - PackageIdentifier pn v <- parsec - return $ MungedPackageId (decodeCompatPackageName pn) v + parsec = do + PackageIdentifier pn v <- parsec + return $ MungedPackageId (decodeCompatPackageName pn) v instance NFData MungedPackageId where - rnf (MungedPackageId name version) = rnf name `seq` rnf version + rnf (MungedPackageId name version) = rnf name `seq` rnf version computeCompatPackageId :: PackageId -> LibraryName -> MungedPackageId computeCompatPackageId (PackageIdentifier pn vr) ln = - MungedPackageId (MungedPackageName pn ln) vr + MungedPackageId (MungedPackageName pn ln) vr -- $setup -- >>> :seti -XOverloadedStrings diff --git a/Cabal-syntax/src/Distribution/Types/MungedPackageName.hs b/Cabal-syntax/src/Distribution/Types/MungedPackageName.hs index 6b80ebb8cce..78b648993d4 100644 --- a/Cabal-syntax/src/Distribution/Types/MungedPackageName.hs +++ b/Cabal-syntax/src/Distribution/Types/MungedPackageName.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} + module Distribution.Types.MungedPackageName ( MungedPackageName (..) , decodeCompatPackageName @@ -29,7 +30,6 @@ import qualified Text.PrettyPrint as Disp -- In @3.0.0.0@ representation was changed from opaque (string) to semantic representation. -- -- @since 2.0.0.2 --- data MungedPackageName = MungedPackageName !PackageName !LibraryName deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) @@ -71,12 +71,11 @@ instance NFData MungedPackageName where rnf = genericRnf -- -- >>> prettyShow $ MungedPackageName "servant" (LSubLibName "lackey") -- "z-servant-z-lackey" --- instance Pretty MungedPackageName where - -- First handle the cases where we can just use the original 'PackageName'. - -- This is for the PRIMARY library, and it is non-Backpack, or the - -- indefinite package for us. - pretty = Disp.text . encodeCompatPackageName' + -- First handle the cases where we can just use the original 'PackageName'. + -- This is for the PRIMARY library, and it is non-Backpack, or the + -- indefinite package for us. + pretty = Disp.text . encodeCompatPackageName' -- | -- @@ -88,9 +87,8 @@ instance Pretty MungedPackageName where -- -- >>> simpleParsec "z-servant-zz" :: Maybe MungedPackageName -- Just (MungedPackageName (PackageName "z-servant-zz") LMainLibName) --- instance Parsec MungedPackageName where - parsec = decodeCompatPackageName' <$> parsecUnqualComponentName + parsec = decodeCompatPackageName' <$> parsecUnqualComponentName ------------------------------------------------------------------------------- -- ZDashCode conversions @@ -100,7 +98,6 @@ instance Parsec MungedPackageName where -- -- >>> decodeCompatPackageName "z-servant-z-lackey" -- MungedPackageName (PackageName "servant") (LSubLibName (UnqualComponentName "lackey")) --- decodeCompatPackageName :: PackageName -> MungedPackageName decodeCompatPackageName = decodeCompatPackageName' . unPackageName @@ -111,44 +108,48 @@ decodeCompatPackageName = decodeCompatPackageName' . unPackageName -- -- This is used in @cabal-install@ in the Solver. -- May become obsolete as solver moves to per-component solving. --- encodeCompatPackageName :: MungedPackageName -> PackageName encodeCompatPackageName = mkPackageName . encodeCompatPackageName' decodeCompatPackageName' :: String -> MungedPackageName decodeCompatPackageName' m = - case m of - 'z':'-':rest | Right [pn, cn] <- explicitEitherParsec parseZDashCode rest - -> MungedPackageName (mkPackageName pn) (LSubLibName (mkUnqualComponentName cn)) - s -> MungedPackageName (mkPackageName s) LMainLibName + case m of + 'z' : '-' : rest + | Right [pn, cn] <- explicitEitherParsec parseZDashCode rest -> + MungedPackageName (mkPackageName pn) (LSubLibName (mkUnqualComponentName cn)) + s -> MungedPackageName (mkPackageName s) LMainLibName encodeCompatPackageName' :: MungedPackageName -> String -encodeCompatPackageName' (MungedPackageName pn LMainLibName) = unPackageName pn +encodeCompatPackageName' (MungedPackageName pn LMainLibName) = unPackageName pn encodeCompatPackageName' (MungedPackageName pn (LSubLibName uqn)) = - "z-" ++ zdashcode (unPackageName pn) ++ - "-z-" ++ zdashcode (unUnqualComponentName uqn) + "z-" + ++ zdashcode (unPackageName pn) + ++ "-z-" + ++ zdashcode (unUnqualComponentName uqn) zdashcode :: String -> String zdashcode s = go s (Nothing :: Maybe Int) [] - where go [] _ r = reverse r - go ('-':z) (Just n) r | n > 0 = go z (Just 0) ('-':'z':r) - go ('-':z) _ r = go z (Just 0) ('-':r) - go ('z':z) (Just n) r = go z (Just (n+1)) ('z':r) - go (c:z) _ r = go z Nothing (c:r) + where + go [] _ r = reverse r + go ('-' : z) (Just n) r | n > 0 = go z (Just 0) ('-' : 'z' : r) + go ('-' : z) _ r = go z (Just 0) ('-' : r) + go ('z' : z) (Just n) r = go z (Just (n + 1)) ('z' : r) + go (c : z) _ r = go z Nothing (c : r) parseZDashCode :: CabalParsing m => m [String] parseZDashCode = do - ns <- toList <$> P.sepByNonEmpty (some (P.satisfy (/= '-'))) (P.char '-') - return (go ns) + ns <- toList <$> P.sepByNonEmpty (some (P.satisfy (/= '-'))) (P.char '-') + return (go ns) where - go ns = case break (=="z") ns of - (_, []) -> [paste ns] - (as, "z":bs) -> paste as : go bs - _ -> error "parseZDashCode: go" + go ns = case break (== "z") ns of + (_, []) -> [paste ns] + (as, "z" : bs) -> paste as : go bs + _ -> error "parseZDashCode: go" unZ :: String -> String unZ "" = error "parseZDashCode: unZ" - unZ r@('z':zs) | all (=='z') zs = zs - | otherwise = r + unZ r@('z' : zs) + | all (== 'z') zs = zs + | otherwise = r unZ r = r paste :: [String] -> String paste = intercalate "-" . map unZ diff --git a/Cabal-syntax/src/Distribution/Types/PackageDescription.hs b/Cabal-syntax/src/Distribution/Types/PackageDescription.hs index cab7af05bd4..f8f84311cec 100644 --- a/Cabal-syntax/src/Distribution/Types/PackageDescription.hs +++ b/Cabal-syntax/src/Distribution/Types/PackageDescription.hs @@ -4,6 +4,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Types.PackageDescription -- Copyright : Isaac Jones 2003-2005 @@ -25,70 +26,70 @@ -- It was done this way initially to avoid breaking too much stuff when the -- feature was introduced. It could probably do with being rationalised at some -- point to make it simpler. - -module Distribution.Types.PackageDescription ( - PackageDescription(..), - license, - license', - buildType, - emptyPackageDescription, - hasPublicLib, - hasLibs, - allLibraries, - withLib, - hasExes, - withExe, - hasTests, - withTest, - hasBenchmarks, - withBenchmark, - hasForeignLibs, - withForeignLib, - allBuildInfo, - enabledBuildInfos, - allBuildDepends, - enabledBuildDepends, - updatePackageDescription, - pkgComponents, - pkgBuildableComponents, - enabledComponents, - lookupComponent, - getComponent, +module Distribution.Types.PackageDescription + ( PackageDescription (..) + , license + , license' + , buildType + , emptyPackageDescription + , hasPublicLib + , hasLibs + , allLibraries + , withLib + , hasExes + , withExe + , hasTests + , withTest + , hasBenchmarks + , withBenchmark + , hasForeignLibs + , withForeignLib + , allBuildInfo + , enabledBuildInfos + , allBuildDepends + , enabledBuildDepends + , updatePackageDescription + , pkgComponents + , pkgBuildableComponents + , enabledComponents + , lookupComponent + , getComponent ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Control.Monad ((<=<)) -- lens -import qualified Distribution.Types.BuildInfo.Lens as L -import Distribution.Types.Library -import Distribution.Types.TestSuite -import Distribution.Types.Executable + import Distribution.Types.Benchmark +import qualified Distribution.Types.BuildInfo.Lens as L +import Distribution.Types.Executable import Distribution.Types.ForeignLib +import Distribution.Types.Library +import Distribution.Types.TestSuite +import Distribution.Types.BuildInfo +import Distribution.Types.BuildType import Distribution.Types.Component +import Distribution.Types.ComponentName import Distribution.Types.ComponentRequestedSpec import Distribution.Types.Dependency +import Distribution.Types.HookedBuildInfo import Distribution.Types.PackageId -import Distribution.Types.ComponentName import Distribution.Types.PackageName -import Distribution.Types.UnqualComponentName import Distribution.Types.SetupBuildInfo -import Distribution.Types.BuildInfo -import Distribution.Types.BuildType import Distribution.Types.SourceRepo -import Distribution.Types.HookedBuildInfo +import Distribution.Types.UnqualComponentName import Distribution.CabalSpecVersion import Distribution.Compiler import Distribution.License import Distribution.Package -import Distribution.Version import Distribution.Utils.Path import Distribution.Utils.ShortText +import Distribution.Version import qualified Distribution.SPDX as SPDX @@ -100,53 +101,53 @@ import qualified Distribution.SPDX as SPDX -- which is needed for all packages, such as the package name and version, and -- information which is needed for the simple build system only, such as -- the compiler options and library name. --- -data PackageDescription - = PackageDescription { - -- the following are required by all packages: - - -- | The version of the Cabal spec that this package description uses. - specVersion :: CabalSpecVersion, - package :: PackageIdentifier, - licenseRaw :: Either SPDX.License License, - licenseFiles :: [SymbolicPath PackageDir LicenseFile], - copyright :: !ShortText, - maintainer :: !ShortText, - author :: !ShortText, - stability :: !ShortText, - testedWith :: [(CompilerFlavor,VersionRange)], - homepage :: !ShortText, - pkgUrl :: !ShortText, - bugReports :: !ShortText, - sourceRepos :: [SourceRepo], - synopsis :: !ShortText, -- ^A one-line summary of this package - description :: !ShortText, -- ^A more verbose description of this package - category :: !ShortText, - customFieldsPD :: [(String,String)], -- ^Custom fields starting - -- with x-, stored in a - -- simple assoc-list. - - -- | The original @build-type@ value as parsed from the - -- @.cabal@ file without defaulting. See also 'buildType'. - -- - -- @since 2.2 - buildTypeRaw :: Maybe BuildType, - setupBuildInfo :: Maybe SetupBuildInfo, - -- components - library :: Maybe Library, - subLibraries :: [Library], - executables :: [Executable], - foreignLibs :: [ForeignLib], - testSuites :: [TestSuite], - benchmarks :: [Benchmark], - -- files - dataFiles :: [FilePath], - dataDir :: FilePath, - extraSrcFiles :: [FilePath], - extraTmpFiles :: [FilePath], - extraDocFiles :: [FilePath] - } - deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) +data PackageDescription = PackageDescription + { -- the following are required by all packages: + + specVersion :: CabalSpecVersion + -- ^ The version of the Cabal spec that this package description uses. + , package :: PackageIdentifier + , licenseRaw :: Either SPDX.License License + , licenseFiles :: [SymbolicPath PackageDir LicenseFile] + , copyright :: !ShortText + , maintainer :: !ShortText + , author :: !ShortText + , stability :: !ShortText + , testedWith :: [(CompilerFlavor, VersionRange)] + , homepage :: !ShortText + , pkgUrl :: !ShortText + , bugReports :: !ShortText + , sourceRepos :: [SourceRepo] + , synopsis :: !ShortText + -- ^ A one-line summary of this package + , description :: !ShortText + -- ^ A more verbose description of this package + , category :: !ShortText + , customFieldsPD :: [(String, String)] + -- ^ Custom fields starting + -- with x-, stored in a + -- simple assoc-list. + , buildTypeRaw :: Maybe BuildType + -- ^ The original @build-type@ value as parsed from the + -- @.cabal@ file without defaulting. See also 'buildType'. + -- + -- @since 2.2 + , setupBuildInfo :: Maybe SetupBuildInfo + , -- components + library :: Maybe Library + , subLibraries :: [Library] + , executables :: [Executable] + , foreignLibs :: [ForeignLib] + , testSuites :: [TestSuite] + , benchmarks :: [Benchmark] + , -- files + dataFiles :: [FilePath] + , dataDir :: FilePath + , extraSrcFiles :: [FilePath] + , extraTmpFiles :: [FilePath] + , extraDocFiles :: [FilePath] + } + deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) instance Binary PackageDescription instance Structured PackageDescription @@ -185,49 +186,53 @@ license' = either id licenseToSPDX -- @since 2.2 buildType :: PackageDescription -> BuildType buildType pkg - | specVersion pkg >= CabalSpecV2_2 - = fromMaybe newDefault (buildTypeRaw pkg) + | specVersion pkg >= CabalSpecV2_2 = + fromMaybe newDefault (buildTypeRaw pkg) | otherwise -- cabal-version < 2.1 - = fromMaybe Custom (buildTypeRaw pkg) + = + fromMaybe Custom (buildTypeRaw pkg) where - newDefault | isNothing (setupBuildInfo pkg) = Simple - | otherwise = Custom + newDefault + | isNothing (setupBuildInfo pkg) = Simple + | otherwise = Custom emptyPackageDescription :: PackageDescription -emptyPackageDescription - = PackageDescription { - package = PackageIdentifier (mkPackageName "") - nullVersion, - licenseRaw = Right UnspecifiedLicense, -- TODO: - licenseFiles = [], - specVersion = CabalSpecV1_0, - buildTypeRaw = Nothing, - copyright = mempty, - maintainer = mempty, - author = mempty, - stability = mempty, - testedWith = [], - homepage = mempty, - pkgUrl = mempty, - bugReports = mempty, - sourceRepos = [], - synopsis = mempty, - description = mempty, - category = mempty, - customFieldsPD = [], - setupBuildInfo = Nothing, - library = Nothing, - subLibraries = [], - foreignLibs = [], - executables = [], - testSuites = [], - benchmarks = [], - dataFiles = [], - dataDir = ".", - extraSrcFiles = [], - extraTmpFiles = [], - extraDocFiles = [] - } +emptyPackageDescription = + PackageDescription + { package = + PackageIdentifier + (mkPackageName "") + nullVersion + , licenseRaw = Right UnspecifiedLicense -- TODO: + , licenseFiles = [] + , specVersion = CabalSpecV1_0 + , buildTypeRaw = Nothing + , copyright = mempty + , maintainer = mempty + , author = mempty + , stability = mempty + , testedWith = [] + , homepage = mempty + , pkgUrl = mempty + , bugReports = mempty + , sourceRepos = [] + , synopsis = mempty + , description = mempty + , category = mempty + , customFieldsPD = [] + , setupBuildInfo = Nothing + , library = Nothing + , subLibraries = [] + , foreignLibs = [] + , executables = [] + , testSuites = [] + , benchmarks = [] + , dataFiles = [] + , dataDir = "." + , extraSrcFiles = [] + , extraTmpFiles = [] + , extraDocFiles = [] + } -- --------------------------------------------------------------------------- -- The Library type @@ -235,9 +240,9 @@ emptyPackageDescription -- | Does this package have a buildable PUBLIC library? hasPublicLib :: PackageDescription -> Bool hasPublicLib p = - case library p of - Just lib -> buildable (libBuildInfo lib) - Nothing -> False + case library p of + Just lib -> buildable (libBuildInfo lib) + Nothing -> False -- | Does this package have any libraries? hasLibs :: PackageDescription -> Bool @@ -254,12 +259,12 @@ allLibraries p = maybeToList (library p) ++ subLibraries p -- for more information. withLib :: PackageDescription -> (Library -> IO ()) -> IO () withLib pkg_descr f = - sequence_ [f lib | lib <- allLibraries pkg_descr, buildable (libBuildInfo lib)] + sequence_ [f lib | lib <- allLibraries pkg_descr, buildable (libBuildInfo lib)] -- --------------------------------------------------------------------------- -- The Executable type --- |does this package have any executables? +-- | does this package have any executables? hasExes :: PackageDescription -> Bool hasExes p = any (buildable . buildInfo) (executables p) @@ -283,10 +288,9 @@ hasTests = any (buildable . testBuildInfo) . testSuites -- You probably want 'withTestLBI' if you have a 'LocalBuildInfo', see the note in -- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components" -- for more information. - withTest :: PackageDescription -> (TestSuite -> IO ()) -> IO () withTest pkg_descr f = - sequence_ [ f test | test <- testSuites pkg_descr, buildable (testBuildInfo test) ] + sequence_ [f test | test <- testSuites pkg_descr, buildable (testBuildInfo test)] -- --------------------------------------------------------------------------- -- The Benchmark type @@ -299,10 +303,9 @@ hasBenchmarks = any (buildable . benchmarkBuildInfo) . benchmarks -- You probably want 'withBenchLBI' if you have a 'LocalBuildInfo', see the note in -- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components" -- for more information. - withBenchmark :: PackageDescription -> (Benchmark -> IO ()) -> IO () withBenchmark pkg_descr f = - sequence_ [f bench | bench <- benchmarks pkg_descr, buildable (benchmarkBuildInfo bench)] + sequence_ [f bench | bench <- benchmarks pkg_descr, buildable (benchmarkBuildInfo bench)] -- --------------------------------------------------------------------------- -- The ForeignLib type @@ -315,10 +318,11 @@ hasForeignLibs p = any (buildable . foreignLibBuildInfo) (foreignLibs p) -- description. withForeignLib :: PackageDescription -> (ForeignLib -> IO ()) -> IO () withForeignLib pkg_descr f = - sequence_ [ f flib - | flib <- foreignLibs pkg_descr - , buildable (foreignLibBuildInfo flib) - ] + sequence_ + [ f flib + | flib <- foreignLibs pkg_descr + , buildable (foreignLibBuildInfo flib) + ] -- --------------------------------------------------------------------------- -- The BuildInfo type @@ -328,27 +332,30 @@ withForeignLib pkg_descr f = -- -- Useful for implementing package checks. allBuildInfo :: PackageDescription -> [BuildInfo] -allBuildInfo pkg_descr = [ bi | lib <- allLibraries pkg_descr - , let bi = libBuildInfo lib ] - ++ [ bi | flib <- foreignLibs pkg_descr - , let bi = foreignLibBuildInfo flib ] - ++ [ bi | exe <- executables pkg_descr - , let bi = buildInfo exe ] - ++ [ bi | tst <- testSuites pkg_descr - , let bi = testBuildInfo tst ] - ++ [ bi | tst <- benchmarks pkg_descr - , let bi = benchmarkBuildInfo tst ] +allBuildInfo pkg_descr = + [ bi | lib <- allLibraries pkg_descr, let bi = libBuildInfo lib + ] + ++ [ bi | flib <- foreignLibs pkg_descr, let bi = foreignLibBuildInfo flib + ] + ++ [ bi | exe <- executables pkg_descr, let bi = buildInfo exe + ] + ++ [ bi | tst <- testSuites pkg_descr, let bi = testBuildInfo tst + ] + ++ [ bi | tst <- benchmarks pkg_descr, let bi = benchmarkBuildInfo tst + ] -- | Return all of the 'BuildInfo's of enabled components, i.e., all of -- the ones that would be built if you run @./Setup build@. enabledBuildInfos :: PackageDescription -> ComponentRequestedSpec -> [BuildInfo] enabledBuildInfos pkg enabled = - [ componentBuildInfo comp - | comp <- enabledComponents pkg enabled ] - + [ componentBuildInfo comp + | comp <- enabledComponents pkg enabled + ] -- ------------------------------------------------------------ + -- * Utils + -- ------------------------------------------------------------ -- | Get the combined build-depends entries of all components. @@ -360,42 +367,50 @@ allBuildDepends = targetBuildDepends <=< allBuildInfo enabledBuildDepends :: PackageDescription -> ComponentRequestedSpec -> [Dependency] enabledBuildDepends spec pd = targetBuildDepends =<< enabledBuildInfos spec pd - updatePackageDescription :: HookedBuildInfo -> PackageDescription -> PackageDescription -updatePackageDescription (mb_lib_bi, exe_bi) p - = p{ executables = updateExecutables exe_bi (executables p) - , library = updateLibrary mb_lib_bi (library p) } - where - updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library - updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = bi `mappend` libBuildInfo lib}) - updateLibrary Nothing mb_lib = mb_lib - updateLibrary (Just _) Nothing = Nothing - - updateExecutables :: [(UnqualComponentName, BuildInfo)] -- ^[(exeName, new buildinfo)] - -> [Executable] -- ^list of executables to update - -> [Executable] -- ^list with exeNames updated - updateExecutables exe_bi' executables' = foldr updateExecutable executables' exe_bi' - - updateExecutable :: (UnqualComponentName, BuildInfo) -- ^(exeName, new buildinfo) - -> [Executable] -- ^list of executables to update - -> [Executable] -- ^list with exeName updated - updateExecutable _ [] = [] - updateExecutable exe_bi'@(name,bi) (exe:exes) - | exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes - | otherwise = exe : updateExecutable exe_bi' exes +updatePackageDescription (mb_lib_bi, exe_bi) p = + p + { executables = updateExecutables exe_bi (executables p) + , library = updateLibrary mb_lib_bi (library p) + } + where + updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library + updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = bi `mappend` libBuildInfo lib}) + updateLibrary Nothing mb_lib = mb_lib + updateLibrary (Just _) Nothing = Nothing + + updateExecutables + :: [(UnqualComponentName, BuildInfo)] + -- \^[(exeName, new buildinfo)] + -> [Executable] + -- \^list of executables to update + -> [Executable] + -- \^list with exeNames updated + updateExecutables exe_bi' executables' = foldr updateExecutable executables' exe_bi' + + updateExecutable + :: (UnqualComponentName, BuildInfo) + -- \^(exeName, new buildinfo) + -> [Executable] + -- \^list of executables to update + -> [Executable] + -- \^list with exeName updated + updateExecutable _ [] = [] + updateExecutable exe_bi'@(name, bi) (exe : exes) + | exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes + | otherwise = exe : updateExecutable exe_bi' exes -- ----------------------------------------------------------------------------- -- Source-representation of buildable components -- | All the components in the package. --- pkgComponents :: PackageDescription -> [Component] pkgComponents pkg = - [ CLib lib | lib <- allLibraries pkg ] - ++ [ CFLib flib | flib <- foreignLibs pkg ] - ++ [ CExe exe | exe <- executables pkg ] - ++ [ CTest tst | tst <- testSuites pkg ] - ++ [ CBench bm | bm <- benchmarks pkg ] + [CLib lib | lib <- allLibraries pkg] + ++ [CFLib flib | flib <- foreignLibs pkg] + ++ [CExe exe | exe <- executables pkg] + ++ [CTest tst | tst <- testSuites pkg] + ++ [CBench bm | bm <- benchmarks pkg] -- | A list of all components in the package that are buildable, -- i.e., were not marked with @buildable: False@. This does NOT @@ -403,55 +418,86 @@ pkgComponents pkg = -- see 'enabledComponents' instead. -- -- @since 2.0.0.2 --- pkgBuildableComponents :: PackageDescription -> [Component] pkgBuildableComponents = filter componentBuildable . pkgComponents -- | A list of all components in the package that are enabled. -- -- @since 2.0.0.2 --- enabledComponents :: PackageDescription -> ComponentRequestedSpec -> [Component] enabledComponents pkg enabled = filter (componentEnabled enabled) $ pkgBuildableComponents pkg lookupComponent :: PackageDescription -> ComponentName -> Maybe Component lookupComponent pkg (CLibName name) = - fmap CLib $ find ((name ==) . libName) (allLibraries pkg) + fmap CLib $ find ((name ==) . libName) (allLibraries pkg) lookupComponent pkg (CFLibName name) = - fmap CFLib $ find ((name ==) . foreignLibName) (foreignLibs pkg) + fmap CFLib $ find ((name ==) . foreignLibName) (foreignLibs pkg) lookupComponent pkg (CExeName name) = - fmap CExe $ find ((name ==) . exeName) (executables pkg) + fmap CExe $ find ((name ==) . exeName) (executables pkg) lookupComponent pkg (CTestName name) = - fmap CTest $ find ((name ==) . testName) (testSuites pkg) + fmap CTest $ find ((name ==) . testName) (testSuites pkg) lookupComponent pkg (CBenchName name) = - fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg) + fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg) getComponent :: PackageDescription -> ComponentName -> Component getComponent pkg cname = - case lookupComponent pkg cname of - Just cpnt -> cpnt - Nothing -> missingComponent + case lookupComponent pkg cname of + Just cpnt -> cpnt + Nothing -> missingComponent where missingComponent = - error $ "internal error: the package description contains no " - ++ "component corresponding to " ++ show cname + error $ + "internal error: the package description contains no " + ++ "component corresponding to " + ++ show cname -- ----------------------------------------------------------------------------- -- Traversal Instances instance L.HasBuildInfos PackageDescription where - traverseBuildInfos f (PackageDescription a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 - x1 x2 x3 x4 x5 x6 - a20 a21 a22 a23 a24) = - PackageDescription a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 + traverseBuildInfos + f + ( PackageDescription + a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 + a11 + a12 + a13 + a14 + a15 + a16 + a17 + a18 + a19 + x1 + x2 + x3 + x4 + x5 + x6 + a20 + a21 + a22 + a23 + a24 + ) = + PackageDescription a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 <$> (traverse . L.buildInfo) f x1 -- library <*> (traverse . L.buildInfo) f x2 -- sub libraries <*> (traverse . L.buildInfo) f x3 -- executables <*> (traverse . L.buildInfo) f x4 -- foreign libs <*> (traverse . L.buildInfo) f x5 -- test suites <*> (traverse . L.buildInfo) f x6 -- benchmarks - <*> pure a20 -- data files - <*> pure a21 -- data dir - <*> pure a22 -- extra src files - <*> pure a23 -- extra temp files - <*> pure a24 -- extra doc files + <*> pure a20 -- data files + <*> pure a21 -- data dir + <*> pure a22 -- extra src files + <*> pure a23 -- extra temp files + <*> pure a24 -- extra doc files diff --git a/Cabal-syntax/src/Distribution/Types/PackageDescription/Lens.hs b/Cabal-syntax/src/Distribution/Types/PackageDescription/Lens.hs index 84be2292c5b..f2fdc7e57d6 100644 --- a/Cabal-syntax/src/Distribution/Types/PackageDescription/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/PackageDescription/Lens.hs @@ -1,193 +1,194 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -module Distribution.Types.PackageDescription.Lens ( - PackageDescription, - module Distribution.Types.PackageDescription.Lens, - ) where +{-# LANGUAGE RankNTypes #-} + +module Distribution.Types.PackageDescription.Lens + ( PackageDescription + , module Distribution.Types.PackageDescription.Lens + ) where import Distribution.Compat.Lens import Distribution.Compat.Prelude import Prelude () -import Distribution.CabalSpecVersion (CabalSpecVersion) -import Distribution.Compiler (CompilerFlavor) -import Distribution.License (License) -import Distribution.ModuleName (ModuleName) -import Distribution.Types.Benchmark (Benchmark, benchmarkModules) -import Distribution.Types.Benchmark.Lens (benchmarkBuildInfo, benchmarkName) -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.BuildType (BuildType) -import Distribution.Types.ComponentName (ComponentName (..)) -import Distribution.Types.Executable (Executable, exeModules) -import Distribution.Types.Executable.Lens (exeBuildInfo, exeName) -import Distribution.Types.ForeignLib (ForeignLib, foreignLibModules) -import Distribution.Types.ForeignLib.Lens (foreignLibBuildInfo, foreignLibName) -import Distribution.Types.Library (Library, explicitLibModules) -import Distribution.Types.Library.Lens (libBuildInfo, libName) +import Distribution.CabalSpecVersion (CabalSpecVersion) +import Distribution.Compiler (CompilerFlavor) +import Distribution.License (License) +import Distribution.ModuleName (ModuleName) +import Distribution.Types.Benchmark (Benchmark, benchmarkModules) +import Distribution.Types.Benchmark.Lens (benchmarkBuildInfo, benchmarkName) +import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.BuildType (BuildType) +import Distribution.Types.ComponentName (ComponentName (..)) +import Distribution.Types.Executable (Executable, exeModules) +import Distribution.Types.Executable.Lens (exeBuildInfo, exeName) +import Distribution.Types.ForeignLib (ForeignLib, foreignLibModules) +import Distribution.Types.ForeignLib.Lens (foreignLibBuildInfo, foreignLibName) +import Distribution.Types.Library (Library, explicitLibModules) +import Distribution.Types.Library.Lens (libBuildInfo, libName) import Distribution.Types.PackageDescription (PackageDescription) -import Distribution.Types.PackageId (PackageIdentifier) -import Distribution.Types.SetupBuildInfo (SetupBuildInfo) -import Distribution.Types.SourceRepo (SourceRepo) -import Distribution.Types.TestSuite (TestSuite, testModules) -import Distribution.Types.TestSuite.Lens (testBuildInfo, testName) -import Distribution.Utils.Path (LicenseFile, PackageDir, SymbolicPath) -import Distribution.Utils.ShortText (ShortText) -import Distribution.Version (VersionRange) - -import qualified Distribution.SPDX as SPDX +import Distribution.Types.PackageId (PackageIdentifier) +import Distribution.Types.SetupBuildInfo (SetupBuildInfo) +import Distribution.Types.SourceRepo (SourceRepo) +import Distribution.Types.TestSuite (TestSuite, testModules) +import Distribution.Types.TestSuite.Lens (testBuildInfo, testName) +import Distribution.Utils.Path (LicenseFile, PackageDir, SymbolicPath) +import Distribution.Utils.ShortText (ShortText) +import Distribution.Version (VersionRange) + +import qualified Distribution.SPDX as SPDX import qualified Distribution.Types.PackageDescription as T package :: Lens' PackageDescription PackageIdentifier -package f s = fmap (\x -> s { T.package = x }) (f (T.package s)) +package f s = fmap (\x -> s{T.package = x}) (f (T.package s)) {-# INLINE package #-} licenseRaw :: Lens' PackageDescription (Either SPDX.License License) -licenseRaw f s = fmap (\x -> s { T.licenseRaw = x }) (f (T.licenseRaw s)) +licenseRaw f s = fmap (\x -> s{T.licenseRaw = x}) (f (T.licenseRaw s)) {-# INLINE licenseRaw #-} licenseFiles :: Lens' PackageDescription [SymbolicPath PackageDir LicenseFile] -licenseFiles f s = fmap (\x -> s { T.licenseFiles = x }) (f (T.licenseFiles s)) +licenseFiles f s = fmap (\x -> s{T.licenseFiles = x}) (f (T.licenseFiles s)) {-# INLINE licenseFiles #-} copyright :: Lens' PackageDescription ShortText -copyright f s = fmap (\x -> s { T.copyright = x }) (f (T.copyright s)) +copyright f s = fmap (\x -> s{T.copyright = x}) (f (T.copyright s)) {-# INLINE copyright #-} maintainer :: Lens' PackageDescription ShortText -maintainer f s = fmap (\x -> s { T.maintainer = x }) (f (T.maintainer s)) +maintainer f s = fmap (\x -> s{T.maintainer = x}) (f (T.maintainer s)) {-# INLINE maintainer #-} author :: Lens' PackageDescription ShortText -author f s = fmap (\x -> s { T.author = x }) (f (T.author s)) +author f s = fmap (\x -> s{T.author = x}) (f (T.author s)) {-# INLINE author #-} stability :: Lens' PackageDescription ShortText -stability f s = fmap (\x -> s { T.stability = x }) (f (T.stability s)) +stability f s = fmap (\x -> s{T.stability = x}) (f (T.stability s)) {-# INLINE stability #-} -testedWith :: Lens' PackageDescription [(CompilerFlavor,VersionRange)] -testedWith f s = fmap (\x -> s { T.testedWith = x }) (f (T.testedWith s)) +testedWith :: Lens' PackageDescription [(CompilerFlavor, VersionRange)] +testedWith f s = fmap (\x -> s{T.testedWith = x}) (f (T.testedWith s)) {-# INLINE testedWith #-} homepage :: Lens' PackageDescription ShortText -homepage f s = fmap (\x -> s { T.homepage = x }) (f (T.homepage s)) +homepage f s = fmap (\x -> s{T.homepage = x}) (f (T.homepage s)) {-# INLINE homepage #-} pkgUrl :: Lens' PackageDescription ShortText -pkgUrl f s = fmap (\x -> s { T.pkgUrl = x }) (f (T.pkgUrl s)) +pkgUrl f s = fmap (\x -> s{T.pkgUrl = x}) (f (T.pkgUrl s)) {-# INLINE pkgUrl #-} bugReports :: Lens' PackageDescription ShortText -bugReports f s = fmap (\x -> s { T.bugReports = x }) (f (T.bugReports s)) +bugReports f s = fmap (\x -> s{T.bugReports = x}) (f (T.bugReports s)) {-# INLINE bugReports #-} sourceRepos :: Lens' PackageDescription [SourceRepo] -sourceRepos f s = fmap (\x -> s { T.sourceRepos = x }) (f (T.sourceRepos s)) +sourceRepos f s = fmap (\x -> s{T.sourceRepos = x}) (f (T.sourceRepos s)) {-# INLINE sourceRepos #-} synopsis :: Lens' PackageDescription ShortText -synopsis f s = fmap (\x -> s { T.synopsis = x }) (f (T.synopsis s)) +synopsis f s = fmap (\x -> s{T.synopsis = x}) (f (T.synopsis s)) {-# INLINE synopsis #-} description :: Lens' PackageDescription ShortText -description f s = fmap (\x -> s { T.description = x }) (f (T.description s)) +description f s = fmap (\x -> s{T.description = x}) (f (T.description s)) {-# INLINE description #-} category :: Lens' PackageDescription ShortText -category f s = fmap (\x -> s { T.category = x }) (f (T.category s)) +category f s = fmap (\x -> s{T.category = x}) (f (T.category s)) {-# INLINE category #-} -customFieldsPD :: Lens' PackageDescription [(String,String)] -customFieldsPD f s = fmap (\x -> s { T.customFieldsPD = x }) (f (T.customFieldsPD s)) +customFieldsPD :: Lens' PackageDescription [(String, String)] +customFieldsPD f s = fmap (\x -> s{T.customFieldsPD = x}) (f (T.customFieldsPD s)) {-# INLINE customFieldsPD #-} specVersion :: Lens' PackageDescription CabalSpecVersion -specVersion f s = fmap (\x -> s { T.specVersion = x }) (f (T.specVersion s)) +specVersion f s = fmap (\x -> s{T.specVersion = x}) (f (T.specVersion s)) {-# INLINE specVersion #-} buildTypeRaw :: Lens' PackageDescription (Maybe BuildType) -buildTypeRaw f s = fmap (\x -> s { T.buildTypeRaw = x }) (f (T.buildTypeRaw s)) +buildTypeRaw f s = fmap (\x -> s{T.buildTypeRaw = x}) (f (T.buildTypeRaw s)) {-# INLINE buildTypeRaw #-} setupBuildInfo :: Lens' PackageDescription (Maybe SetupBuildInfo) -setupBuildInfo f s = fmap (\x -> s { T.setupBuildInfo = x }) (f (T.setupBuildInfo s)) +setupBuildInfo f s = fmap (\x -> s{T.setupBuildInfo = x}) (f (T.setupBuildInfo s)) {-# INLINE setupBuildInfo #-} library :: Lens' PackageDescription (Maybe Library) -library f s = fmap (\x -> s { T.library = x }) (f (T.library s)) +library f s = fmap (\x -> s{T.library = x}) (f (T.library s)) {-# INLINE library #-} subLibraries :: Lens' PackageDescription [Library] -subLibraries f s = fmap (\x -> s { T.subLibraries = x }) (f (T.subLibraries s)) +subLibraries f s = fmap (\x -> s{T.subLibraries = x}) (f (T.subLibraries s)) {-# INLINE subLibraries #-} executables :: Lens' PackageDescription [Executable] -executables f s = fmap (\x -> s { T.executables = x }) (f (T.executables s)) +executables f s = fmap (\x -> s{T.executables = x}) (f (T.executables s)) {-# INLINE executables #-} foreignLibs :: Lens' PackageDescription [ForeignLib] -foreignLibs f s = fmap (\x -> s { T.foreignLibs = x }) (f (T.foreignLibs s)) +foreignLibs f s = fmap (\x -> s{T.foreignLibs = x}) (f (T.foreignLibs s)) {-# INLINE foreignLibs #-} testSuites :: Lens' PackageDescription [TestSuite] -testSuites f s = fmap (\x -> s { T.testSuites = x }) (f (T.testSuites s)) +testSuites f s = fmap (\x -> s{T.testSuites = x}) (f (T.testSuites s)) {-# INLINE testSuites #-} benchmarks :: Lens' PackageDescription [Benchmark] -benchmarks f s = fmap (\x -> s { T.benchmarks = x }) (f (T.benchmarks s)) +benchmarks f s = fmap (\x -> s{T.benchmarks = x}) (f (T.benchmarks s)) {-# INLINE benchmarks #-} dataFiles :: Lens' PackageDescription [FilePath] -dataFiles f s = fmap (\x -> s { T.dataFiles = x }) (f (T.dataFiles s)) +dataFiles f s = fmap (\x -> s{T.dataFiles = x}) (f (T.dataFiles s)) {-# INLINE dataFiles #-} dataDir :: Lens' PackageDescription FilePath -dataDir f s = fmap (\x -> s { T.dataDir = x }) (f (T.dataDir s)) +dataDir f s = fmap (\x -> s{T.dataDir = x}) (f (T.dataDir s)) {-# INLINE dataDir #-} extraSrcFiles :: Lens' PackageDescription [String] -extraSrcFiles f s = fmap (\x -> s { T.extraSrcFiles = x }) (f (T.extraSrcFiles s)) +extraSrcFiles f s = fmap (\x -> s{T.extraSrcFiles = x}) (f (T.extraSrcFiles s)) {-# INLINE extraSrcFiles #-} extraTmpFiles :: Lens' PackageDescription [String] -extraTmpFiles f s = fmap (\x -> s { T.extraTmpFiles = x }) (f (T.extraTmpFiles s)) +extraTmpFiles f s = fmap (\x -> s{T.extraTmpFiles = x}) (f (T.extraTmpFiles s)) {-# INLINE extraTmpFiles #-} extraDocFiles :: Lens' PackageDescription [String] -extraDocFiles f s = fmap (\x -> s { T.extraDocFiles = x }) (f (T.extraDocFiles s)) +extraDocFiles f s = fmap (\x -> s{T.extraDocFiles = x}) (f (T.extraDocFiles s)) {-# INLINE extraDocFiles #-} -- | @since 3.0.0.0 allLibraries :: Traversal' PackageDescription Library allLibraries f pd = mk <$> traverse f (T.library pd) <*> traverse f (T.subLibraries pd) where - mk l ls = pd { T.library = l, T.subLibraries = ls } + mk l ls = pd{T.library = l, T.subLibraries = ls} -- | @since 2.4 componentModules :: Monoid r => ComponentName -> Getting r PackageDescription [ModuleName] componentModules cname = case cname of - CLibName name -> - componentModules' name allLibraries libName explicitLibModules - CFLibName name -> - componentModules' name (foreignLibs . traverse) foreignLibName foreignLibModules - CExeName name -> - componentModules' name (executables . traverse) exeName exeModules - CTestName name -> - componentModules' name (testSuites . traverse) testName testModules - CBenchName name -> - componentModules' name (benchmarks . traverse) benchmarkName benchmarkModules + CLibName name -> + componentModules' name allLibraries libName explicitLibModules + CFLibName name -> + componentModules' name (foreignLibs . traverse) foreignLibName foreignLibModules + CExeName name -> + componentModules' name (executables . traverse) exeName exeModules + CTestName name -> + componentModules' name (testSuites . traverse) testName testModules + CBenchName name -> + componentModules' name (benchmarks . traverse) benchmarkName benchmarkModules where componentModules' - :: (Eq name, Monoid r) - => name - -> Traversal' PackageDescription a - -> Lens' a name - -> (a -> [ModuleName]) - -> Getting r PackageDescription [ModuleName] + :: (Eq name, Monoid r) + => name + -> Traversal' PackageDescription a + -> Lens' a name + -> (a -> [ModuleName]) + -> Getting r PackageDescription [ModuleName] componentModules' name pdL nameL modules = - pdL - . filtered ((== name) . view nameL) - . getting modules + pdL + . filtered ((== name) . view nameL) + . getting modules filtered :: (a -> Bool) -> Traversal' a a filtered p f s = if p s then f s else pure s @@ -195,27 +196,28 @@ componentModules cname = case cname of -- | @since 2.4 componentBuildInfo :: ComponentName -> Traversal' PackageDescription BuildInfo componentBuildInfo cname = case cname of - CLibName name -> - componentBuildInfo' name allLibraries libName libBuildInfo - CFLibName name -> - componentBuildInfo' name (foreignLibs . traverse) foreignLibName foreignLibBuildInfo - CExeName name -> - componentBuildInfo' name (executables . traverse) exeName exeBuildInfo - CTestName name -> - componentBuildInfo' name (testSuites . traverse) testName testBuildInfo - CBenchName name -> - componentBuildInfo' name (benchmarks . traverse) benchmarkName benchmarkBuildInfo + CLibName name -> + componentBuildInfo' name allLibraries libName libBuildInfo + CFLibName name -> + componentBuildInfo' name (foreignLibs . traverse) foreignLibName foreignLibBuildInfo + CExeName name -> + componentBuildInfo' name (executables . traverse) exeName exeBuildInfo + CTestName name -> + componentBuildInfo' name (testSuites . traverse) testName testBuildInfo + CBenchName name -> + componentBuildInfo' name (benchmarks . traverse) benchmarkName benchmarkBuildInfo where - componentBuildInfo' :: Eq name - => name - -> Traversal' PackageDescription a - -> Lens' a name - -> Traversal' a BuildInfo - -> Traversal' PackageDescription BuildInfo + componentBuildInfo' + :: Eq name + => name + -> Traversal' PackageDescription a + -> Lens' a name + -> Traversal' a BuildInfo + -> Traversal' PackageDescription BuildInfo componentBuildInfo' name pdL nameL biL = - pdL - . filtered ((== name) . view nameL) - . biL + pdL + . filtered ((== name) . view nameL) + . biL filtered :: (a -> Bool) -> Traversal' a a filtered p f s = if p s then f s else pure s diff --git a/Cabal-syntax/src/Distribution/Types/PackageId.hs b/Cabal-syntax/src/Distribution/Types/PackageId.hs index 5740153f1a9..b5c4764ad22 100644 --- a/Cabal-syntax/src/Distribution/Types/PackageId.hs +++ b/Cabal-syntax/src/Distribution/Types/PackageId.hs @@ -1,32 +1,34 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} + module Distribution.Types.PackageId - ( PackageIdentifier(..) + ( PackageIdentifier (..) , PackageId ) where import Distribution.Compat.Prelude import Prelude () -import Distribution.Parsec (Parsec (..), simpleParsec) +import Distribution.Parsec (Parsec (..), simpleParsec) import Distribution.Pretty import Distribution.Types.PackageName -import Distribution.Version (Version, nullVersion) +import Distribution.Version (Version, nullVersion) -import qualified Data.List.NonEmpty as NE +import qualified Data.List.NonEmpty as NE import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp +import qualified Text.PrettyPrint as Disp -- | Type alias so we can use the shorter name PackageId. type PackageId = PackageIdentifier -- | The name and version of a package. -data PackageIdentifier - = PackageIdentifier { - pkgName :: PackageName, -- ^The name of this package, eg. foo - pkgVersion :: Version -- ^the version of this package, eg 1.2 - } - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) +data PackageIdentifier = PackageIdentifier + { pkgName :: PackageName + -- ^ The name of this package, eg. foo + , pkgVersion :: Version + -- ^ the version of this package, eg 1.2 + } + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) instance Binary PackageIdentifier instance Structured PackageIdentifier @@ -34,7 +36,7 @@ instance Structured PackageIdentifier instance Pretty PackageIdentifier where pretty (PackageIdentifier n v) | v == nullVersion = pretty n -- if no version, don't show version. - | otherwise = pretty n <<>> Disp.char '-' <<>> pretty v + | otherwise = pretty n <<>> Disp.char '-' <<>> pretty v -- | -- @@ -57,18 +59,17 @@ instance Pretty PackageIdentifier where -- -- >>> simpleParsec "1.2.3" :: Maybe PackageIdentifier -- Nothing --- instance Parsec PackageIdentifier where parsec = do - xs' <- P.sepByNonEmpty component (P.char '-') - (v, xs) <- case simpleParsec (NE.last xs') of - Nothing -> return (nullVersion, toList xs') -- all components are version - Just v -> return (v, NE.init xs') - if not (null xs) && all (\c -> all (/= '.') c && not (all isDigit c)) xs - then return $ PackageIdentifier (mkPackageName (intercalate "-" xs)) v + xs' <- P.sepByNonEmpty component (P.char '-') + (v, xs) <- case simpleParsec (NE.last xs') of + Nothing -> return (nullVersion, toList xs') -- all components are version + Just v -> return (v, NE.init xs') + if not (null xs) && all (\c -> all (/= '.') c && not (all isDigit c)) xs + then return $ PackageIdentifier (mkPackageName (intercalate "-" xs)) v else fail "all digits or a dot in a portion of package name" where - component = P.munch1 (\c -> isAlphaNum c || c == '.') + component = P.munch1 (\c -> isAlphaNum c || c == '.') instance NFData PackageIdentifier where - rnf (PackageIdentifier name version) = rnf name `seq` rnf version + rnf (PackageIdentifier name version) = rnf name `seq` rnf version diff --git a/Cabal-syntax/src/Distribution/Types/PackageId/Lens.hs b/Cabal-syntax/src/Distribution/Types/PackageId/Lens.hs index d2a669a89af..08305234fbd 100644 --- a/Cabal-syntax/src/Distribution/Types/PackageId/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/PackageId/Lens.hs @@ -1,22 +1,22 @@ -module Distribution.Types.PackageId.Lens ( - PackageIdentifier, - module Distribution.Types.PackageId.Lens, - ) where +module Distribution.Types.PackageId.Lens + ( PackageIdentifier + , module Distribution.Types.PackageId.Lens + ) where import Distribution.Compat.Lens import Distribution.Compat.Prelude import Prelude () -import Distribution.Types.PackageId (PackageIdentifier) +import Distribution.Types.PackageId (PackageIdentifier) import Distribution.Types.PackageName (PackageName) -import Distribution.Version (Version) +import Distribution.Version (Version) import qualified Distribution.Types.PackageId as T pkgName :: Lens' PackageIdentifier PackageName -pkgName f s = fmap (\x -> s { T.pkgName = x }) (f (T.pkgName s)) +pkgName f s = fmap (\x -> s{T.pkgName = x}) (f (T.pkgName s)) {-# INLINE pkgName #-} pkgVersion :: Lens' PackageIdentifier Version -pkgVersion f s = fmap (\x -> s { T.pkgVersion = x }) (f (T.pkgVersion s)) +pkgVersion f s = fmap (\x -> s{T.pkgVersion = x}) (f (T.pkgVersion s)) {-# INLINE pkgVersion #-} diff --git a/Cabal-syntax/src/Distribution/Types/PackageName.hs b/Cabal-syntax/src/Distribution/Types/PackageName.hs index b9afa5aee94..4cf9d1aeb59 100644 --- a/Cabal-syntax/src/Distribution/Types/PackageName.hs +++ b/Cabal-syntax/src/Distribution/Types/PackageName.hs @@ -1,19 +1,22 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Distribution.Types.PackageName ( PackageName - , unPackageName, mkPackageName - , unPackageNameST, mkPackageNameST + , unPackageName + , mkPackageName + , unPackageNameST + , mkPackageNameST ) where -import Prelude () import Distribution.Compat.Prelude import Distribution.Utils.ShortText +import Prelude () -import qualified Text.PrettyPrint as Disp -import Distribution.Pretty import Distribution.Parsec +import Distribution.Pretty +import qualified Text.PrettyPrint as Disp -- | A package name. -- @@ -24,7 +27,7 @@ import Distribution.Parsec -- -- @since 2.0.0.2 newtype PackageName = PackageName ShortText - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) -- | Convert 'PackageName' to 'String' unPackageName :: PackageName -> String @@ -70,4 +73,4 @@ instance Parsec PackageName where parsec = mkPackageName <$> parsecUnqualComponentName instance NFData PackageName where - rnf (PackageName pkg) = rnf pkg + rnf (PackageName pkg) = rnf pkg diff --git a/Cabal-syntax/src/Distribution/Types/PackageVersionConstraint.hs b/Cabal-syntax/src/Distribution/Types/PackageVersionConstraint.hs index dc35ad45f6f..9c328378d07 100644 --- a/Cabal-syntax/src/Distribution/Types/PackageVersionConstraint.hs +++ b/Cabal-syntax/src/Distribution/Types/PackageVersionConstraint.hs @@ -1,10 +1,11 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.PackageVersionConstraint ( - PackageVersionConstraint(..), - thisPackageVersionConstraint, - simplifyPackageVersionConstraint, -) where +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint (..) + , thisPackageVersionConstraint + , simplifyPackageVersionConstraint + ) where import Distribution.Compat.Prelude import Prelude () @@ -15,7 +16,7 @@ import Distribution.Types.PackageId import Distribution.Types.PackageName import Distribution.Types.Version import Distribution.Types.VersionRange.Internal -import Distribution.Version (simplifyVersionRange) +import Distribution.Version (simplifyVersionRange) import qualified Distribution.Compat.CharParsing as P @@ -25,7 +26,7 @@ import qualified Distribution.Compat.CharParsing as P -- There are a few places in the codebase where 'Dependency' was used where -- 'PackageVersionConstraint' is not used instead (#5570). data PackageVersionConstraint = PackageVersionConstraint PackageName VersionRange - deriving (Generic, Read, Show, Eq, Typeable, Data) + deriving (Generic, Read, Show, Eq, Typeable, Data) instance Binary PackageVersionConstraint instance Structured PackageVersionConstraint @@ -38,7 +39,7 @@ instance Pretty PackageVersionConstraint where -- pretty (PackageVersionConstraint name (ThisVersion ver)) = -- pretty (PackageIdentifier name ver) pretty (PackageVersionConstraint name ver) = - pretty name <+> pretty ver + pretty name <+> pretty ver -- | -- @@ -50,25 +51,23 @@ instance Pretty PackageVersionConstraint where -- -- >>> simpleParsec "foo-2.0" :: Maybe PackageVersionConstraint -- Just (PackageVersionConstraint (PackageName "foo") (ThisVersion (mkVersion [2,0]))) --- instance Parsec PackageVersionConstraint where parsec = do - PackageIdentifier name ver <- parsec - if ver == nullVersion + PackageIdentifier name ver <- parsec + if ver == nullVersion then do - P.spaces - vr <- parsec <|> return anyVersion - P.spaces - return (PackageVersionConstraint name vr) - else - pure (PackageVersionConstraint name (thisVersion ver)) + P.spaces + vr <- parsec <|> return anyVersion + P.spaces + return (PackageVersionConstraint name vr) + else pure (PackageVersionConstraint name (thisVersion ver)) -- | @since 3.4.0.0 thisPackageVersionConstraint :: PackageIdentifier -> PackageVersionConstraint thisPackageVersionConstraint (PackageIdentifier pn vr) = - PackageVersionConstraint pn (thisVersion vr) + PackageVersionConstraint pn (thisVersion vr) -- | @since 3.4.0.0 simplifyPackageVersionConstraint :: PackageVersionConstraint -> PackageVersionConstraint simplifyPackageVersionConstraint (PackageVersionConstraint pn vr) = - PackageVersionConstraint pn (simplifyVersionRange vr) + PackageVersionConstraint pn (simplifyVersionRange vr) diff --git a/Cabal-syntax/src/Distribution/Types/PkgconfigDependency.hs b/Cabal-syntax/src/Distribution/Types/PkgconfigDependency.hs index 737c71ee5b8..695d3a3a184 100644 --- a/Cabal-syntax/src/Distribution/Types/PkgconfigDependency.hs +++ b/Cabal-syntax/src/Distribution/Types/PkgconfigDependency.hs @@ -1,7 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} + module Distribution.Types.PkgconfigDependency - ( PkgconfigDependency(..) + ( PkgconfigDependency (..) ) where import Distribution.Compat.Prelude @@ -18,22 +19,23 @@ import qualified Distribution.Compat.CharParsing as P -- | Describes a dependency on a pkg-config library -- -- @since 2.0.0.2 -data PkgconfigDependency = PkgconfigDependency - PkgconfigName - PkgconfigVersionRange - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) +data PkgconfigDependency + = PkgconfigDependency + PkgconfigName + PkgconfigVersionRange + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) instance Binary PkgconfigDependency instance Structured PkgconfigDependency instance NFData PkgconfigDependency where rnf = genericRnf instance Pretty PkgconfigDependency where - pretty (PkgconfigDependency name PcAnyVersion) = pretty name - pretty (PkgconfigDependency name ver) = pretty name <+> pretty ver + pretty (PkgconfigDependency name PcAnyVersion) = pretty name + pretty (PkgconfigDependency name ver) = pretty name <+> pretty ver instance Parsec PkgconfigDependency where - parsec = do - name <- parsec - P.spaces - verRange <- parsec <|> pure anyPkgconfigVersion - pure $ PkgconfigDependency name verRange + parsec = do + name <- parsec + P.spaces + verRange <- parsec <|> pure anyPkgconfigVersion + pure $ PkgconfigDependency name verRange diff --git a/Cabal-syntax/src/Distribution/Types/PkgconfigName.hs b/Cabal-syntax/src/Distribution/Types/PkgconfigName.hs index 61176687e81..c3a93dd27c1 100644 --- a/Cabal-syntax/src/Distribution/Types/PkgconfigName.hs +++ b/Cabal-syntax/src/Distribution/Types/PkgconfigName.hs @@ -1,16 +1,19 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Distribution.Types.PkgconfigName - ( PkgconfigName, unPkgconfigName, mkPkgconfigName + ( PkgconfigName + , unPkgconfigName + , mkPkgconfigName ) where -import Prelude () import Distribution.Compat.Prelude import Distribution.Utils.ShortText +import Prelude () -import Distribution.Pretty import Distribution.Parsec +import Distribution.Pretty import qualified Distribution.Compat.CharParsing as P import qualified Text.PrettyPrint as Disp @@ -21,7 +24,7 @@ import qualified Text.PrettyPrint as Disp -- -- @since 2.0.0.2 newtype PkgconfigName = PkgconfigName ShortText - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) -- | Convert 'PkgconfigName' to 'String' -- @@ -44,7 +47,7 @@ mkPkgconfigName = PkgconfigName . toShortText -- -- @since 2.0.0.2 instance IsString PkgconfigName where - fromString = mkPkgconfigName + fromString = mkPkgconfigName instance Binary PkgconfigName instance Structured PkgconfigName @@ -56,13 +59,14 @@ instance Pretty PkgconfigName where pretty = Disp.text . unPkgconfigName instance Parsec PkgconfigName where - parsec = mkPkgconfigName <$> P.munch1 isNameChar where - -- https://gitlab.haskell.org/ghc/ghc/issues/17752 - isNameChar '-' = True - isNameChar '_' = True - isNameChar '.' = True - isNameChar '+' = True - isNameChar c = isAlphaNum c + parsec = mkPkgconfigName <$> P.munch1 isNameChar + where + -- https://gitlab.haskell.org/ghc/ghc/issues/17752 + isNameChar '-' = True + isNameChar '_' = True + isNameChar '.' = True + isNameChar '+' = True + isNameChar c = isAlphaNum c instance NFData PkgconfigName where - rnf (PkgconfigName pkg) = rnf pkg + rnf (PkgconfigName pkg) = rnf pkg diff --git a/Cabal-syntax/src/Distribution/Types/PkgconfigVersion.hs b/Cabal-syntax/src/Distribution/Types/PkgconfigVersion.hs index 8779f328a66..dc328c44dda 100644 --- a/Cabal-syntax/src/Distribution/Types/PkgconfigVersion.hs +++ b/Cabal-syntax/src/Distribution/Types/PkgconfigVersion.hs @@ -1,10 +1,11 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} + -- @since 3.0 -module Distribution.Types.PkgconfigVersion ( - PkgconfigVersion (..), - rpmvercmp, - ) where +module Distribution.Types.PkgconfigVersion + ( PkgconfigVersion (..) + , rpmvercmp + ) where import Distribution.Compat.Prelude import Prelude () @@ -13,10 +14,10 @@ import Distribution.Parsec import Distribution.Pretty import Distribution.Utils.Generic (isAsciiAlphaNum) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as PP +import qualified Text.PrettyPrint as PP -- | @pkg-config@ versions. -- @@ -28,17 +29,17 @@ newtype PkgconfigVersion = PkgconfigVersion BS.ByteString deriving (Generic, Read, Show, Typeable, Data) instance Eq PkgconfigVersion where - PkgconfigVersion a == PkgconfigVersion b = rpmvercmp a b == EQ + PkgconfigVersion a == PkgconfigVersion b = rpmvercmp a b == EQ instance Ord PkgconfigVersion where - PkgconfigVersion a `compare` PkgconfigVersion b = rpmvercmp a b + PkgconfigVersion a `compare` PkgconfigVersion b = rpmvercmp a b instance Binary PkgconfigVersion instance Structured PkgconfigVersion instance NFData PkgconfigVersion where rnf = genericRnf instance Pretty PkgconfigVersion where - pretty (PkgconfigVersion bs) = PP.text (BS8.unpack bs) + pretty (PkgconfigVersion bs) = PP.text (BS8.unpack bs) -- | -- @@ -47,10 +48,10 @@ instance Pretty PkgconfigVersion where -- -- >>> simpleParsec "0.3.5+ds" :: Maybe PkgconfigVersion -- Nothing --- instance Parsec PkgconfigVersion where - parsec = PkgconfigVersion . BS8.pack <$> P.munch1 predicate where - predicate c = isAsciiAlphaNum c || c == '.' || c == '-' + parsec = PkgconfigVersion . BS8.pack <$> P.munch1 predicate + where + predicate c = isAsciiAlphaNum c || c == '.' || c == '-' ------------------------------------------------------------------------------- -- rpmvercmp - pure Haskell implementation @@ -66,36 +67,36 @@ rpmvercmp a b = go0 (BS.unpack a) (BS.unpack b) -- if there is _any_ trailing "garbage", it seems to affect result -- https://github.com/haskell/cabal/issues/6805 go0 [] [] = EQ - go0 [] _ = LT - go0 _ [] = GT + go0 [] _ = LT + go0 _ [] = GT go0 xs ys = go1 (dropNonAlnum8 xs) (dropNonAlnum8 ys) go1 :: [Word8] -> [Word8] -> Ordering go1 [] [] = EQ - go1 [] _ = LT - go1 _ [] = GT - go1 xs@(x:_) ys + go1 [] _ = LT + go1 _ [] = GT + go1 xs@(x : _) ys | isDigit8 x = let (xs1, xs2) = span isDigit8 xs (ys1, ys2) = span isDigit8 ys - -- numeric segments are always newer than alpha segments - in if null ys1 - then GT - else compareInt xs1 ys1 <> go0 xs2 ys2 - + in -- numeric segments are always newer than alpha segments + if null ys1 + then GT + else compareInt xs1 ys1 <> go0 xs2 ys2 -- isAlpha | otherwise = let (xs1, xs2) = span isAlpha8 xs (ys1, ys2) = span isAlpha8 ys - in if null ys1 - then LT - else compareStr xs1 ys1 <> go0 xs2 ys2 + in if null ys1 + then LT + else compareStr xs1 ys1 <> go0 xs2 ys2 -- compare as numbers compareInt :: [Word8] -> [Word8] -> Ordering compareInt xs ys = - -- whichever number has more digits wins - compare (length xs') (length ys') <> + -- whichever number has more digits wins + compare (length xs') (length ys') + <> -- equal length: use per character compare, "strcmp" compare xs' ys' where @@ -115,4 +116,3 @@ isDigit8 w = 0x30 <= w && w <= 0x39 isAlpha8 :: Word8 -> Bool isAlpha8 w = (0x41 <= w && w <= 0x5A) || (0x61 <= w && w <= 0x7A) - diff --git a/Cabal-syntax/src/Distribution/Types/PkgconfigVersionRange.hs b/Cabal-syntax/src/Distribution/Types/PkgconfigVersionRange.hs index d39499b4475..fe74f70c7be 100644 --- a/Cabal-syntax/src/Distribution/Types/PkgconfigVersionRange.hs +++ b/Cabal-syntax/src/Distribution/Types/PkgconfigVersionRange.hs @@ -1,14 +1,16 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.PkgconfigVersionRange ( - PkgconfigVersionRange (..), - anyPkgconfigVersion, - isAnyPkgconfigVersion, - withinPkgconfigVersionRange, +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Types.PkgconfigVersionRange + ( PkgconfigVersionRange (..) + , anyPkgconfigVersion + , isAnyPkgconfigVersion + , withinPkgconfigVersionRange + -- * Internal - versionToPkgconfigVersion, - versionRangeToPkgconfigVersionRange, - ) where + , versionToPkgconfigVersion + , versionRangeToPkgconfigVersionRange + ) where import Distribution.Compat.Prelude import Prelude () @@ -21,19 +23,19 @@ import Distribution.Types.Version import Distribution.Types.VersionInterval import Distribution.Types.VersionRange -import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Char8 as BS8 import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as PP +import qualified Text.PrettyPrint as PP -- | @since 3.0 data PkgconfigVersionRange = PcAnyVersion - | PcThisVersion PkgconfigVersion -- = version - | PcLaterVersion PkgconfigVersion -- > version (NB. not >=) - | PcEarlierVersion PkgconfigVersion -- < version - | PcOrLaterVersion PkgconfigVersion -- >= version - | PcOrEarlierVersion PkgconfigVersion -- =< version - | PcUnionVersionRanges PkgconfigVersionRange PkgconfigVersionRange + | PcThisVersion PkgconfigVersion -- = version + | PcLaterVersion PkgconfigVersion -- > version (NB. not >=) + | PcEarlierVersion PkgconfigVersion -- < version + | PcOrLaterVersion PkgconfigVersion -- >= version + | PcOrEarlierVersion PkgconfigVersion -- =< version + | PcUnionVersionRanges PkgconfigVersionRange PkgconfigVersionRange | PcIntersectVersionRanges PkgconfigVersionRange PkgconfigVersionRange deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) @@ -42,62 +44,63 @@ instance Structured PkgconfigVersionRange instance NFData PkgconfigVersionRange where rnf = genericRnf instance Pretty PkgconfigVersionRange where - pretty = pp 0 where - pp :: Int -> PkgconfigVersionRange -> PP.Doc - pp _ PcAnyVersion = PP.text "-any" - pp _ (PcThisVersion v) = PP.text "==" <<>> pretty v - pp _ (PcLaterVersion v) = PP.text ">" <<>> pretty v - pp _ (PcEarlierVersion v) = PP.text "<" <<>> pretty v - pp _ (PcOrLaterVersion v) = PP.text ">=" <<>> pretty v - pp _ (PcOrEarlierVersion v) = PP.text "<=" <<>> pretty v - - pp d (PcUnionVersionRanges v u) = parens (d >= 1) $ - pp 1 v PP.<+> PP.text "||" PP.<+> pp 0 u - pp d (PcIntersectVersionRanges v u) = parens (d >= 2) $ - pp 2 v PP.<+> PP.text "&&" PP.<+> pp 1 u - - parens True = PP.parens - parens False = id + pretty = pp 0 + where + pp :: Int -> PkgconfigVersionRange -> PP.Doc + pp _ PcAnyVersion = PP.text "-any" + pp _ (PcThisVersion v) = PP.text "==" <<>> pretty v + pp _ (PcLaterVersion v) = PP.text ">" <<>> pretty v + pp _ (PcEarlierVersion v) = PP.text "<" <<>> pretty v + pp _ (PcOrLaterVersion v) = PP.text ">=" <<>> pretty v + pp _ (PcOrEarlierVersion v) = PP.text "<=" <<>> pretty v + pp d (PcUnionVersionRanges v u) = + parens (d >= 1) $ + pp 1 v PP.<+> PP.text "||" PP.<+> pp 0 u + pp d (PcIntersectVersionRanges v u) = + parens (d >= 2) $ + pp 2 v PP.<+> PP.text "&&" PP.<+> pp 1 u + + parens True = PP.parens + parens False = id instance Parsec PkgconfigVersionRange where - -- note: the wildcard is used in some places, e.g - -- http://hackage.haskell.org/package/bindings-libzip-0.10.1/bindings-libzip.cabal - -- - -- however, in the presence of alphanumerics etc. lax version parser, - -- wildcard is ill-specified - - parsec = do - csv <- askCabalSpecVersion - if csv >= CabalSpecV3_0 - then pkgconfigParser - else versionRangeToPkgconfigVersionRange <$> versionRangeParser P.integral csv + -- note: the wildcard is used in some places, e.g + -- http://hackage.haskell.org/package/bindings-libzip-0.10.1/bindings-libzip.cabal + -- + -- however, in the presence of alphanumerics etc. lax version parser, + -- wildcard is ill-specified + + parsec = do + csv <- askCabalSpecVersion + if csv >= CabalSpecV3_0 + then pkgconfigParser + else versionRangeToPkgconfigVersionRange <$> versionRangeParser P.integral csv -- "modern" parser of @pkg-config@ package versions. pkgconfigParser :: CabalParsing m => m PkgconfigVersionRange -pkgconfigParser = P.spaces >> expr where +pkgconfigParser = P.spaces >> expr + where -- every parser here eats trailing space expr = do - ts <- term `P.sepByNonEmpty` (P.string "||" >> P.spaces) - return $ foldr1 PcUnionVersionRanges ts + ts <- term `P.sepByNonEmpty` (P.string "||" >> P.spaces) + return $ foldr1 PcUnionVersionRanges ts term = do - fs <- factor `P.sepByNonEmpty` (P.string "&&" >> P.spaces) - return $ foldr1 PcIntersectVersionRanges fs + fs <- factor `P.sepByNonEmpty` (P.string "&&" >> P.spaces) + return $ foldr1 PcIntersectVersionRanges fs factor = parens expr <|> prim prim = do - op <- P.munch1 isOpChar P. "operator" - case op of - "-" -> anyPkgconfigVersion <$ (P.string "any" *> P.spaces) - - "==" -> afterOp PcThisVersion - ">" -> afterOp PcLaterVersion - "<" -> afterOp PcEarlierVersion - ">=" -> afterOp PcOrLaterVersion - "<=" -> afterOp PcOrEarlierVersion - - _ -> P.unexpected $ "Unknown version operator " ++ show op + op <- P.munch1 isOpChar P. "operator" + case op of + "-" -> anyPkgconfigVersion <$ (P.string "any" *> P.spaces) + "==" -> afterOp PcThisVersion + ">" -> afterOp PcLaterVersion + "<" -> afterOp PcEarlierVersion + ">=" -> afterOp PcOrLaterVersion + "<=" -> afterOp PcOrEarlierVersion + _ -> P.unexpected $ "Unknown version operator " ++ show op -- https://gitlab.haskell.org/ghc/ghc/issues/17752 isOpChar '<' = True @@ -105,15 +108,16 @@ pkgconfigParser = P.spaces >> expr where isOpChar '>' = True isOpChar '^' = True isOpChar '-' = True - isOpChar _ = False + isOpChar _ = False afterOp f = do - P.spaces - v <- parsec - P.spaces - return (f v) + P.spaces + v <- parsec + P.spaces + return (f v) - parens = P.between + parens = + P.between ((P.char '(' P. "opening paren") >> P.spaces) (P.char ')' >> P.spaces) @@ -125,14 +129,15 @@ isAnyPkgconfigVersion :: PkgconfigVersionRange -> Bool isAnyPkgconfigVersion = (== PcAnyVersion) withinPkgconfigVersionRange :: PkgconfigVersion -> PkgconfigVersionRange -> Bool -withinPkgconfigVersionRange v = go where - go PcAnyVersion = True - go (PcThisVersion u) = v == u - go (PcLaterVersion u) = v > u - go (PcEarlierVersion u) = v < u - go (PcOrLaterVersion u) = v >= u - go (PcOrEarlierVersion u) = v <= u - go (PcUnionVersionRanges a b) = go a || go b +withinPkgconfigVersionRange v = go + where + go PcAnyVersion = True + go (PcThisVersion u) = v == u + go (PcLaterVersion u) = v > u + go (PcEarlierVersion u) = v < u + go (PcOrLaterVersion u) = v >= u + go (PcOrEarlierVersion u) = v <= u + go (PcUnionVersionRanges a b) = go a || go b go (PcIntersectVersionRanges a b) = go a && go b ------------------------------------------------------------------------------- @@ -144,14 +149,14 @@ versionToPkgconfigVersion = PkgconfigVersion . BS8.pack . prettyShow versionRangeToPkgconfigVersionRange :: VersionRange -> PkgconfigVersionRange versionRangeToPkgconfigVersionRange vr - | isAnyVersion vr - = PcAnyVersion - | otherwise - = case asVersionIntervals vr of - [] -> PcEarlierVersion (PkgconfigVersion (BS8.pack "0")) - (i:is) -> foldl (\r j -> PcUnionVersionRanges r (conv j)) (conv i) is + | isAnyVersion vr = + PcAnyVersion + | otherwise = + case asVersionIntervals vr of + [] -> PcEarlierVersion (PkgconfigVersion (BS8.pack "0")) + (i : is) -> foldl (\r j -> PcUnionVersionRanges r (conv j)) (conv i) is where - conv (VersionInterval (LowerBound v b) NoUpperBound) = convL v b + conv (VersionInterval (LowerBound v b) NoUpperBound) = convL v b conv (VersionInterval (LowerBound v b) (UpperBound u c)) = PcIntersectVersionRanges (convL v b) (convU u c) convL v ExclusiveBound = PcLaterVersion (versionToPkgconfigVersion v) diff --git a/Cabal-syntax/src/Distribution/Types/SetupBuildInfo.hs b/Cabal-syntax/src/Distribution/Types/SetupBuildInfo.hs index fe4f716169d..18a01523a9e 100644 --- a/Cabal-syntax/src/Distribution/Types/SetupBuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/SetupBuildInfo.hs @@ -1,12 +1,12 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.SetupBuildInfo ( - SetupBuildInfo(..) -) where +module Distribution.Types.SetupBuildInfo + ( SetupBuildInfo (..) + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Types.Dependency @@ -18,24 +18,25 @@ import Distribution.Types.Dependency -- options authors can specify to just Haskell package dependencies. data SetupBuildInfo = SetupBuildInfo - { setupDepends :: [Dependency] - , defaultSetupDepends :: Bool - -- ^ Is this a default 'custom-setup' section added by the cabal-install - -- code (as opposed to user-provided)? This field is only used - -- internally, and doesn't correspond to anything in the .cabal - -- file. See #3199. - } - deriving (Generic, Show, Eq, Ord, Read, Typeable, Data) + { setupDepends :: [Dependency] + , defaultSetupDepends :: Bool + -- ^ Is this a default 'custom-setup' section added by the cabal-install + -- code (as opposed to user-provided)? This field is only used + -- internally, and doesn't correspond to anything in the .cabal + -- file. See #3199. + } + deriving (Generic, Show, Eq, Ord, Read, Typeable, Data) instance Binary SetupBuildInfo instance Structured SetupBuildInfo instance NFData SetupBuildInfo where rnf = genericRnf instance Monoid SetupBuildInfo where - mempty = SetupBuildInfo [] False - mappend = (<>) + mempty = SetupBuildInfo [] False + mappend = (<>) instance Semigroup SetupBuildInfo where - a <> b = SetupBuildInfo - (setupDepends a <> setupDepends b) - (defaultSetupDepends a || defaultSetupDepends b) + a <> b = + SetupBuildInfo + (setupDepends a <> setupDepends b) + (defaultSetupDepends a || defaultSetupDepends b) diff --git a/Cabal-syntax/src/Distribution/Types/SetupBuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/SetupBuildInfo/Lens.hs index d10ca2e9f4d..93bd28ae819 100644 --- a/Cabal-syntax/src/Distribution/Types/SetupBuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/SetupBuildInfo/Lens.hs @@ -1,21 +1,21 @@ -module Distribution.Types.SetupBuildInfo.Lens ( - SetupBuildInfo, - module Distribution.Types.SetupBuildInfo.Lens, - ) where +module Distribution.Types.SetupBuildInfo.Lens + ( SetupBuildInfo + , module Distribution.Types.SetupBuildInfo.Lens + ) where import Distribution.Compat.Lens import Distribution.Compat.Prelude import Prelude () -import Distribution.Types.Dependency (Dependency) +import Distribution.Types.Dependency (Dependency) import Distribution.Types.SetupBuildInfo (SetupBuildInfo) import qualified Distribution.Types.SetupBuildInfo as T setupDepends :: Lens' SetupBuildInfo [Dependency] -setupDepends f s = fmap (\x -> s { T.setupDepends = x }) (f (T.setupDepends s)) +setupDepends f s = fmap (\x -> s{T.setupDepends = x}) (f (T.setupDepends s)) {-# INLINE setupDepends #-} defaultSetupDepends :: Lens' SetupBuildInfo Bool -defaultSetupDepends f s = fmap (\x -> s { T.defaultSetupDepends = x }) (f (T.defaultSetupDepends s)) +defaultSetupDepends f s = fmap (\x -> s{T.defaultSetupDepends = x}) (f (T.defaultSetupDepends s)) {-# INLINE defaultSetupDepends #-} diff --git a/Cabal-syntax/src/Distribution/Types/SourceRepo.hs b/Cabal-syntax/src/Distribution/Types/SourceRepo.hs index 12e0cada2b9..16a0fc60e0e 100644 --- a/Cabal-syntax/src/Distribution/Types/SourceRepo.hs +++ b/Cabal-syntax/src/Distribution/Types/SourceRepo.hs @@ -1,31 +1,33 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.SourceRepo ( - SourceRepo(..), - RepoKind(..), - RepoType(..), - KnownRepoType (..), - knownRepoTypes, - emptySourceRepo, - classifyRepoType, - classifyRepoKind, +module Distribution.Types.SourceRepo + ( SourceRepo (..) + , RepoKind (..) + , RepoType (..) + , KnownRepoType (..) + , knownRepoTypes + , emptySourceRepo + , classifyRepoType + , classifyRepoKind ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Utils.Generic (lowercase) -import Distribution.Pretty import Distribution.Parsec +import Distribution.Pretty +import qualified Data.Map.Strict as M import qualified Distribution.Compat.CharParsing as P import qualified Text.PrettyPrint as Disp -import qualified Data.Map.Strict as M -- ------------------------------------------------------------ + -- * Source repos + -- ------------------------------------------------------------ -- | Information about the source revision control system for a package. @@ -43,57 +45,50 @@ import qualified Data.Map.Strict as M -- The required information is the 'RepoType' which tells us if it's using -- 'Darcs', 'Git' for example. The 'repoLocation' and other details are -- interpreted according to the repo type. --- -data SourceRepo = SourceRepo { - -- | The kind of repo. This field is required. - repoKind :: RepoKind, - - -- | The type of the source repository system for this repo, eg 'Darcs' or +data SourceRepo = SourceRepo + { repoKind :: RepoKind + -- ^ The kind of repo. This field is required. + , repoType :: Maybe RepoType + -- ^ The type of the source repository system for this repo, eg 'Darcs' or -- 'Git'. This field is required. - repoType :: Maybe RepoType, - - -- | The location of the repository. For most 'RepoType's this is a URL. + , repoLocation :: Maybe String + -- ^ The location of the repository. For most 'RepoType's this is a URL. -- This field is required. - repoLocation :: Maybe String, - - -- | 'CVS' can put multiple \"modules\" on one server and requires a + , repoModule :: Maybe String + -- ^ 'CVS' can put multiple \"modules\" on one server and requires a -- module name in addition to the location to identify a particular repo. -- Logically this is part of the location but unfortunately has to be -- specified separately. This field is required for the 'CVS' 'RepoType' and -- should not be given otherwise. - repoModule :: Maybe String, - - -- | The name or identifier of the branch, if any. Many source control + , repoBranch :: Maybe String + -- ^ The name or identifier of the branch, if any. Many source control -- systems have the notion of multiple branches in a repo that exist in the -- same location. For example 'Git' and 'CVS' use this while systems like -- 'Darcs' use different locations for different branches. This field is -- optional but should be used if necessary to identify the sources, -- especially for the 'RepoThis' repo kind. - repoBranch :: Maybe String, - - -- | The tag identify a particular state of the repository. This should be + , repoTag :: Maybe String + -- ^ The tag identify a particular state of the repository. This should be -- given for the 'RepoThis' repo kind and not for 'RepoHead' kind. - -- - repoTag :: Maybe String, - - -- | Some repositories contain multiple projects in different subdirectories + , repoSubdir :: Maybe FilePath + -- ^ Some repositories contain multiple projects in different subdirectories -- This field specifies the subdirectory where this packages sources can be -- found, eg the subdirectory containing the @.cabal@ file. It is interpreted -- relative to the root of the repository. This field is optional. If not -- given the default is \".\" ie no subdirectory. - repoSubdir :: Maybe FilePath -} + } deriving (Eq, Ord, Generic, Read, Show, Typeable, Data) emptySourceRepo :: RepoKind -> SourceRepo -emptySourceRepo kind = SourceRepo - { repoKind = kind - , repoType = Nothing +emptySourceRepo kind = + SourceRepo + { repoKind = kind + , repoType = Nothing , repoLocation = Nothing - , repoModule = Nothing - , repoBranch = Nothing - , repoTag = Nothing - , repoSubdir = Nothing + , repoModule = Nothing + , repoBranch = Nothing + , repoTag = Nothing + , repoSubdir = Nothing } instance Binary SourceRepo @@ -101,18 +96,15 @@ instance Structured SourceRepo instance NFData SourceRepo where rnf = genericRnf -- | What this repo info is for, what it represents. --- -data RepoKind = - -- | The repository for the \"head\" or development version of the project. +data RepoKind + = -- | The repository for the \"head\" or development version of the project. -- This repo is where we should track the latest development activity or -- the usual repo people should get to contribute patches. RepoHead - - -- | The repository containing the sources for this exact package version + | -- | The repository containing the sources for this exact package version -- or release. For this kind of repo a tag should be given to give enough -- information to re-create the exact sources. - | RepoThis - + RepoThis | RepoKindUnknown String deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) @@ -123,10 +115,17 @@ instance NFData RepoKind where rnf = genericRnf -- | An enumeration of common source control systems. The fields used in the -- 'SourceRepo' depend on the type of repo. The tools and methods used to -- obtain and track the repo depend on the repo type. --- -data KnownRepoType = Darcs | Git | SVN | CVS - | Mercurial | GnuArch | Bazaar | Monotone - | Pijul -- ^ @since 3.4.0.0 +data KnownRepoType + = Darcs + | Git + | SVN + | CVS + | Mercurial + | GnuArch + | Bazaar + | Monotone + | -- | @since 3.4.0.0 + Pijul deriving (Eq, Generic, Ord, Read, Show, Typeable, Data, Enum, Bounded) instance Binary KnownRepoType @@ -144,8 +143,9 @@ instance Parsec KnownRepoType where instance Pretty KnownRepoType where pretty = Disp.text . lowercase . show -data RepoType = KnownRepoType KnownRepoType - | OtherRepoType String +data RepoType + = KnownRepoType KnownRepoType + | OtherRepoType String deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) instance Binary RepoType @@ -156,14 +156,14 @@ knownRepoTypes :: [KnownRepoType] knownRepoTypes = [minBound .. maxBound] repoTypeAliases :: KnownRepoType -> [String] -repoTypeAliases Bazaar = ["bzr"] +repoTypeAliases Bazaar = ["bzr"] repoTypeAliases Mercurial = ["hg"] -repoTypeAliases GnuArch = ["arch"] -repoTypeAliases _ = [] +repoTypeAliases GnuArch = ["arch"] +repoTypeAliases _ = [] instance Pretty RepoKind where - pretty RepoHead = Disp.text "head" - pretty RepoThis = Disp.text "this" + pretty RepoHead = Disp.text "head" + pretty RepoThis = Disp.text "this" pretty (RepoKindUnknown other) = Disp.text other instance Parsec RepoKind where @@ -173,7 +173,7 @@ classifyRepoKind :: String -> RepoKind classifyRepoKind name = case lowercase name of "head" -> RepoHead "this" -> RepoThis - _ -> RepoKindUnknown name + _ -> RepoKindUnknown name instance Parsec RepoType where parsec = classifyRepoType <$> P.munch1 isIdent @@ -193,8 +193,8 @@ knownRepoTypeMap :: Map String KnownRepoType knownRepoTypeMap = M.fromList [ (name, repoType') - | repoType' <- knownRepoTypes - , name <- prettyShow repoType' : repoTypeAliases repoType' + | repoType' <- knownRepoTypes + , name <- prettyShow repoType' : repoTypeAliases repoType' ] isIdent :: Char -> Bool diff --git a/Cabal-syntax/src/Distribution/Types/SourceRepo/Lens.hs b/Cabal-syntax/src/Distribution/Types/SourceRepo/Lens.hs index 5f2fd8be873..171fc6f3e97 100644 --- a/Cabal-syntax/src/Distribution/Types/SourceRepo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/SourceRepo/Lens.hs @@ -1,39 +1,39 @@ -module Distribution.Types.SourceRepo.Lens ( - T.SourceRepo, - module Distribution.Types.SourceRepo.Lens, - ) where +module Distribution.Types.SourceRepo.Lens + ( T.SourceRepo + , module Distribution.Types.SourceRepo.Lens + ) where -import Prelude() -import Distribution.Compat.Prelude import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.SourceRepo (SourceRepo, RepoKind, RepoType) +import Distribution.Types.SourceRepo (RepoKind, RepoType, SourceRepo) import qualified Distribution.Types.SourceRepo as T repoKind :: Lens' SourceRepo RepoKind -repoKind f s = fmap (\x -> s { T.repoKind = x }) (f (T.repoKind s)) +repoKind f s = fmap (\x -> s{T.repoKind = x}) (f (T.repoKind s)) {-# INLINE repoKind #-} repoType :: Lens' SourceRepo (Maybe RepoType) -repoType f s = fmap (\x -> s { T.repoType = x }) (f (T.repoType s)) +repoType f s = fmap (\x -> s{T.repoType = x}) (f (T.repoType s)) {-# INLINE repoType #-} repoLocation :: Lens' SourceRepo (Maybe String) -repoLocation f s = fmap (\x -> s { T.repoLocation = x }) (f (T.repoLocation s)) +repoLocation f s = fmap (\x -> s{T.repoLocation = x}) (f (T.repoLocation s)) {-# INLINE repoLocation #-} repoModule :: Lens' SourceRepo (Maybe String) -repoModule f s = fmap (\x -> s { T.repoModule = x }) (f (T.repoModule s)) +repoModule f s = fmap (\x -> s{T.repoModule = x}) (f (T.repoModule s)) {-# INLINE repoModule #-} repoBranch :: Lens' SourceRepo (Maybe String) -repoBranch f s = fmap (\x -> s { T.repoBranch = x }) (f (T.repoBranch s)) +repoBranch f s = fmap (\x -> s{T.repoBranch = x}) (f (T.repoBranch s)) {-# INLINE repoBranch #-} repoTag :: Lens' SourceRepo (Maybe String) -repoTag f s = fmap (\x -> s { T.repoTag = x }) (f (T.repoTag s)) +repoTag f s = fmap (\x -> s{T.repoTag = x}) (f (T.repoTag s)) {-# INLINE repoTag #-} repoSubdir :: Lens' SourceRepo (Maybe FilePath) -repoSubdir f s = fmap (\x -> s { T.repoSubdir = x }) (f (T.repoSubdir s)) +repoSubdir f s = fmap (\x -> s{T.repoSubdir = x}) (f (T.repoSubdir s)) {-# INLINE repoSubdir #-} diff --git a/Cabal-syntax/src/Distribution/Types/TestSuite.hs b/Cabal-syntax/src/Distribution/Types/TestSuite.hs index 9cdacbadba1..5e72965b815 100644 --- a/Cabal-syntax/src/Distribution/Types/TestSuite.hs +++ b/Cabal-syntax/src/Distribution/Types/TestSuite.hs @@ -1,20 +1,20 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.TestSuite ( - TestSuite(..), - emptyTestSuite, - testType, - testModules, - testModulesAutogen -) where +module Distribution.Types.TestSuite + ( TestSuite (..) + , emptyTestSuite + , testType + , testModules + , testModulesAutogen + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Types.BuildInfo -import Distribution.Types.TestType import Distribution.Types.TestSuiteInterface +import Distribution.Types.TestType import Distribution.Types.UnqualComponentName import Distribution.ModuleName @@ -22,17 +22,16 @@ import Distribution.ModuleName import qualified Distribution.Types.BuildInfo.Lens as L -- | A \"test-suite\" stanza in a cabal file. --- -data TestSuite = TestSuite { - testName :: UnqualComponentName, - testInterface :: TestSuiteInterface, - testBuildInfo :: BuildInfo, - testCodeGenerators :: [String] - } - deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) +data TestSuite = TestSuite + { testName :: UnqualComponentName + , testInterface :: TestSuiteInterface + , testBuildInfo :: BuildInfo + , testCodeGenerators :: [String] + } + deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) instance L.HasBuildInfo TestSuite where - buildInfo f l = (\x -> l { testBuildInfo = x }) <$> f (testBuildInfo l) + buildInfo f l = (\x -> l{testBuildInfo = x}) <$> f (testBuildInfo l) instance Binary TestSuite instance Structured TestSuite @@ -40,45 +39,55 @@ instance Structured TestSuite instance NFData TestSuite where rnf = genericRnf instance Monoid TestSuite where - mempty = TestSuite { - testName = mempty, - testInterface = mempty, - testBuildInfo = mempty, - testCodeGenerators = mempty - } - mappend = (<>) + mempty = + TestSuite + { testName = mempty + , testInterface = mempty + , testBuildInfo = mempty + , testCodeGenerators = mempty + } + mappend = (<>) instance Semigroup TestSuite where - a <> b = TestSuite { - testName = combine' testName, - testInterface = combine testInterface, - testBuildInfo = combine testBuildInfo, - testCodeGenerators = combine testCodeGenerators - } - where combine field = field a `mappend` field b - combine' field = case ( unUnqualComponentName $ field a - , unUnqualComponentName $ field b) of - ("", _) -> field b - (_, "") -> field a - (x, y) -> error $ "Ambiguous values for test field: '" - ++ x ++ "' and '" ++ y ++ "'" + a <> b = + TestSuite + { testName = combine' testName + , testInterface = combine testInterface + , testBuildInfo = combine testBuildInfo + , testCodeGenerators = combine testCodeGenerators + } + where + combine field = field a `mappend` field b + combine' field = case ( unUnqualComponentName $ field a + , unUnqualComponentName $ field b + ) of + ("", _) -> field b + (_, "") -> field a + (x, y) -> + error $ + "Ambiguous values for test field: '" + ++ x + ++ "' and '" + ++ y + ++ "'" emptyTestSuite :: TestSuite emptyTestSuite = mempty - testType :: TestSuite -> TestType testType test = case testInterface test of - TestSuiteExeV10 ver _ -> TestTypeExe ver - TestSuiteLibV09 ver _ -> TestTypeLib ver + TestSuiteExeV10 ver _ -> TestTypeExe ver + TestSuiteLibV09 ver _ -> TestTypeLib ver TestSuiteUnsupported testtype -> testtype -- | Get all the module names from a test suite. testModules :: TestSuite -> [ModuleName] -testModules test = (case testInterface test of - TestSuiteLibV09 _ m -> [m] - _ -> []) - ++ otherModules (testBuildInfo test) +testModules test = + ( case testInterface test of + TestSuiteLibV09 _ m -> [m] + _ -> [] + ) + ++ otherModules (testBuildInfo test) -- | Get all the auto generated module names from a test suite. -- This are a subset of 'testModules'. diff --git a/Cabal-syntax/src/Distribution/Types/TestSuite/Lens.hs b/Cabal-syntax/src/Distribution/Types/TestSuite/Lens.hs index 3f7135f37e7..d44862eed48 100644 --- a/Cabal-syntax/src/Distribution/Types/TestSuite/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/TestSuite/Lens.hs @@ -1,27 +1,27 @@ -module Distribution.Types.TestSuite.Lens ( - TestSuite, - module Distribution.Types.TestSuite.Lens, - ) where +module Distribution.Types.TestSuite.Lens + ( TestSuite + , module Distribution.Types.TestSuite.Lens + ) where import Distribution.Compat.Lens import Distribution.Compat.Prelude import Prelude () -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.TestSuite (TestSuite) -import Distribution.Types.TestSuiteInterface (TestSuiteInterface) +import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.TestSuite (TestSuite) +import Distribution.Types.TestSuiteInterface (TestSuiteInterface) import Distribution.Types.UnqualComponentName (UnqualComponentName) import qualified Distribution.Types.TestSuite as T testName :: Lens' TestSuite UnqualComponentName -testName f s = fmap (\x -> s { T.testName = x }) (f (T.testName s)) +testName f s = fmap (\x -> s{T.testName = x}) (f (T.testName s)) {-# INLINE testName #-} testInterface :: Lens' TestSuite TestSuiteInterface -testInterface f s = fmap (\x -> s { T.testInterface = x }) (f (T.testInterface s)) +testInterface f s = fmap (\x -> s{T.testInterface = x}) (f (T.testInterface s)) {-# INLINE testInterface #-} testBuildInfo :: Lens' TestSuite BuildInfo -testBuildInfo f s = fmap (\x -> s { T.testBuildInfo = x }) (f (T.testBuildInfo s)) +testBuildInfo f s = fmap (\x -> s{T.testBuildInfo = x}) (f (T.testBuildInfo s)) {-# INLINE testBuildInfo #-} diff --git a/Cabal-syntax/src/Distribution/Types/TestSuiteInterface.hs b/Cabal-syntax/src/Distribution/Types/TestSuiteInterface.hs index 7bbf2a14265..a1a2879a924 100644 --- a/Cabal-syntax/src/Distribution/Types/TestSuiteInterface.hs +++ b/Cabal-syntax/src/Distribution/Types/TestSuiteInterface.hs @@ -1,41 +1,34 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.TestSuiteInterface ( - TestSuiteInterface(..), -) where +module Distribution.Types.TestSuiteInterface + ( TestSuiteInterface (..) + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.TestType import Distribution.ModuleName +import Distribution.Types.TestType import Distribution.Version -- | The test suite interfaces that are currently defined. -- -- More interfaces may be defined in future, either new revisions or totally -- new interfaces. --- -data TestSuiteInterface = - - -- | Test interface \"exitcode-stdio-1.0\". The test-suite takes the form - -- of an executable. It returns a zero exit code for success, non-zero for - -- failure. The stdout and stderr channels may be logged. Test tooling may - -- pass command line arguments and/or connect the stdin channel to the test. - -- - TestSuiteExeV10 Version FilePath - - -- | Test interface \"detailed-0.9\". The test-suite takes the form of a - -- library containing a designated module that exports \"tests :: [Test]\". - -- - | TestSuiteLibV09 Version ModuleName - - -- | A test suite that does not conform to one of the above interfaces for - -- the given reason (e.g. unknown test type). - -- - | TestSuiteUnsupported TestType - deriving (Eq, Ord, Generic, Read, Show, Typeable, Data) +data TestSuiteInterface + = -- | Test interface \"exitcode-stdio-1.0\". The test-suite takes the form + -- of an executable. It returns a zero exit code for success, non-zero for + -- failure. The stdout and stderr channels may be logged. Test tooling may + -- pass command line arguments and/or connect the stdin channel to the test. + TestSuiteExeV10 Version FilePath + | -- | Test interface \"detailed-0.9\". The test-suite takes the form of a + -- library containing a designated module that exports \"tests :: [Test]\". + TestSuiteLibV09 Version ModuleName + | -- | A test suite that does not conform to one of the above interfaces for + -- the given reason (e.g. unknown test type). + TestSuiteUnsupported TestType + deriving (Eq, Ord, Generic, Read, Show, Typeable, Data) instance Binary TestSuiteInterface instance Structured TestSuiteInterface @@ -43,9 +36,9 @@ instance Structured TestSuiteInterface instance NFData TestSuiteInterface where rnf = genericRnf instance Monoid TestSuiteInterface where - mempty = TestSuiteUnsupported (TestTypeUnknown mempty nullVersion) - mappend = (<>) + mempty = TestSuiteUnsupported (TestTypeUnknown mempty nullVersion) + mappend = (<>) instance Semigroup TestSuiteInterface where - a <> (TestSuiteUnsupported _) = a - _ <> b = b + a <> (TestSuiteUnsupported _) = a + _ <> b = b diff --git a/Cabal-syntax/src/Distribution/Types/TestType.hs b/Cabal-syntax/src/Distribution/Types/TestType.hs index 748d0c2bcd5..6ac0866d6f1 100644 --- a/Cabal-syntax/src/Distribution/Types/TestType.hs +++ b/Cabal-syntax/src/Distribution/Types/TestType.hs @@ -1,13 +1,13 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} -module Distribution.Types.TestType ( - TestType(..), - knownTestTypes, - testTypeExe, - testTypeLib, -) where +module Distribution.Types.TestType + ( TestType (..) + , knownTestTypes + , testTypeExe + , testTypeLib + ) where import Distribution.Compat.Prelude import Distribution.Version @@ -15,14 +15,17 @@ import Prelude () import Distribution.Parsec import Distribution.Pretty -import Text.PrettyPrint (char, text) +import Text.PrettyPrint (char, text) -- | The \"test-type\" field in the test suite stanza. --- -data TestType = TestTypeExe Version -- ^ \"type: exitcode-stdio-x.y\" - | TestTypeLib Version -- ^ \"type: detailed-x.y\" - | TestTypeUnknown String Version -- ^ Some unknown test type e.g. \"type: foo\" - deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) +data TestType + = -- | \"type: exitcode-stdio-x.y\" + TestTypeExe Version + | -- | \"type: detailed-x.y\" + TestTypeLib Version + | -- | Some unknown test type e.g. \"type: foo\" + TestTypeUnknown String Version + deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) instance Binary TestType instance Structured TestType @@ -30,23 +33,24 @@ instance Structured TestType instance NFData TestType where rnf = genericRnf knownTestTypes :: [TestType] -knownTestTypes = [ testTypeExe - , testTypeLib - ] +knownTestTypes = + [ testTypeExe + , testTypeLib + ] testTypeExe :: TestType -testTypeExe = TestTypeExe (mkVersion [1,0]) +testTypeExe = TestTypeExe (mkVersion [1, 0]) testTypeLib :: TestType -testTypeLib = TestTypeLib (mkVersion [0,9]) +testTypeLib = TestTypeLib (mkVersion [0, 9]) instance Pretty TestType where - pretty (TestTypeExe ver) = text "exitcode-stdio-" <<>> pretty ver - pretty (TestTypeLib ver) = text "detailed-" <<>> pretty ver + pretty (TestTypeExe ver) = text "exitcode-stdio-" <<>> pretty ver + pretty (TestTypeLib ver) = text "detailed-" <<>> pretty ver pretty (TestTypeUnknown name ver) = text name <<>> char '-' <<>> pretty ver instance Parsec TestType where parsec = parsecStandard $ \ver name -> case name of - "exitcode-stdio" -> TestTypeExe ver - "detailed" -> TestTypeLib ver - _ -> TestTypeUnknown name ver + "exitcode-stdio" -> TestTypeExe ver + "detailed" -> TestTypeLib ver + _ -> TestTypeUnknown name ver diff --git a/Cabal-syntax/src/Distribution/Types/UnitId.hs b/Cabal-syntax/src/Distribution/Types/UnitId.hs index 047a43f27c3..36a1d003b2e 100644 --- a/Cabal-syntax/src/Distribution/Types/UnitId.hs +++ b/Cabal-syntax/src/Distribution/Types/UnitId.hs @@ -1,10 +1,12 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Distribution.Types.UnitId - ( UnitId, unUnitId, mkUnitId + ( UnitId + , unUnitId + , mkUnitId , DefUnitId , unsafeMkDefUnitId , unDefUnitId @@ -13,13 +15,13 @@ module Distribution.Types.UnitId , getHSLibraryName ) where -import Prelude () import Distribution.Compat.Prelude import Distribution.Utils.ShortText +import Prelude () import qualified Distribution.Compat.CharParsing as P -import Distribution.Pretty import Distribution.Parsec +import Distribution.Pretty import Distribution.Types.ComponentId import Distribution.Types.PackageId @@ -61,7 +63,6 @@ import Text.PrettyPrint (text) -- representation of a UnitId to pass, e.g., as a @-package-id@ -- flag, use the 'display' function, which will work on all -- versions of Cabal. --- newtype UnitId = UnitId ShortText deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, NFData) @@ -70,25 +71,23 @@ instance Structured UnitId -- | The textual format for 'UnitId' coincides with the format -- GHC accepts for @-package-id@. --- instance Pretty UnitId where - pretty = text . unUnitId + pretty = text . unUnitId -- | The textual format for 'UnitId' coincides with the format -- GHC accepts for @-package-id@. --- instance Parsec UnitId where - parsec = mkUnitId <$> P.munch1 isUnitChar where - -- https://gitlab.haskell.org/ghc/ghc/issues/17752 - isUnitChar '-' = True - isUnitChar '_' = True - isUnitChar '.' = True - isUnitChar '+' = True - isUnitChar c = isAlphaNum c + parsec = mkUnitId <$> P.munch1 isUnitChar + where + -- https://gitlab.haskell.org/ghc/ghc/issues/17752 + isUnitChar '-' = True + isUnitChar '_' = True + isUnitChar '.' = True + isUnitChar '+' = True + isUnitChar c = isAlphaNum c -- | If you need backwards compatibility, consider using 'display' -- instead, which is supported by all versions of Cabal. --- unUnitId :: UnitId -> String unUnitId (UnitId s) = fromShortText s @@ -99,7 +98,7 @@ mkUnitId = UnitId . toShortText -- -- @since 2.0.0.2 instance IsString UnitId where - fromString = mkUnitId + fromString = mkUnitId -- | Create a unit identity with no associated hash directly -- from a 'ComponentId'. @@ -118,7 +117,7 @@ getHSLibraryName uid = "HS" ++ prettyShow uid -- | A 'UnitId' for a definite package. The 'DefUnitId' invariant says -- that a 'UnitId' identified this way is definite; i.e., it has no -- unfilled holes. -newtype DefUnitId = DefUnitId { unDefUnitId :: UnitId } +newtype DefUnitId = DefUnitId {unDefUnitId :: UnitId} deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, Binary, NFData, Pretty) instance Structured DefUnitId diff --git a/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs b/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs index 763ec99d568..a13fc917633 100644 --- a/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs +++ b/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs @@ -1,9 +1,14 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Distribution.Types.UnqualComponentName - ( UnqualComponentName, unUnqualComponentName, unUnqualComponentNameST, mkUnqualComponentName - , packageNameToUnqualComponentName, unqualComponentNameToPackageName + ( UnqualComponentName + , unUnqualComponentName + , unUnqualComponentNameST + , mkUnqualComponentName + , packageNameToUnqualComponentName + , unqualComponentNameToPackageName ) where import Distribution.Compat.Prelude @@ -22,8 +27,17 @@ import Distribution.Types.PackageName -- -- @since 2.0.0.2 newtype UnqualComponentName = UnqualComponentName ShortText - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, - Semigroup, Monoid) -- TODO: bad enabler of bad monoids + deriving + ( Generic + , Read + , Show + , Eq + , Ord + , Typeable + , Data + , Semigroup + , Monoid -- TODO: bad enabler of bad monoids + ) -- | Convert 'UnqualComponentName' to 'String' -- diff --git a/Cabal-syntax/src/Distribution/Types/Version.hs b/Cabal-syntax/src/Distribution/Types/Version.hs index fae5f889b01..90ad33b1048 100644 --- a/Cabal-syntax/src/Distribution/Types/Version.hs +++ b/Cabal-syntax/src/Distribution/Types/Version.hs @@ -1,31 +1,32 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.Version ( - -- * Package versions - Version, - mkVersion, - mkVersion', - versionNumbers, - nullVersion, - alterVersion, - version0, +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Types.Version + ( -- * Package versions + Version + , mkVersion + , mkVersion' + , versionNumbers + , nullVersion + , alterVersion + , version0 -- * Internal - validVersion, - versionDigitParser, - ) where + , validVersion + , versionDigitParser + ) where -import Data.Bits (shiftL, shiftR, (.&.), (.|.)) +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) import Distribution.Compat.Prelude import Prelude () import Distribution.Parsec import Distribution.Pretty -import qualified Data.Version as Base +import qualified Data.Version as Base import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp -import qualified Text.Read as Read +import qualified Text.PrettyPrint as Disp +import qualified Text.Read as Read -- | A 'Version' represents the version of a software entity. -- @@ -38,68 +39,73 @@ import qualified Text.Read as Read -- 'Binary' instance using a different (and more compact) encoding. -- -- @since 2.0.0.2 -data Version = PV0 {-# UNPACK #-} !Word64 - | PV1 !Int [Int] - -- NOTE: If a version fits into the packed Word64 - -- representation (i.e. at most four version components - -- which all fall into the [0..0xfffe] range), then PV0 - -- MUST be used. This is essential for the 'Eq' instance - -- to work. - deriving (Data,Eq,Generic,Typeable) +data Version + = PV0 {-# UNPACK #-} !Word64 + | PV1 !Int [Int] + -- NOTE: If a version fits into the packed Word64 + -- representation (i.e. at most four version components + -- which all fall into the [0..0xfffe] range), then PV0 + -- MUST be used. This is essential for the 'Eq' instance + -- to work. + deriving (Data, Eq, Generic, Typeable) instance Ord Version where - compare (PV0 x) (PV0 y) = compare x y - compare (PV1 x xs) (PV1 y ys) = case compare x y of - EQ -> compare xs ys - c -> c - compare (PV0 w) (PV1 y ys) = case compare x y of - EQ -> compare [x2,x3,x4] ys - c -> c - where - x = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1 - x2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1 - x3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1 - x4 = fromIntegral (w .&. 0xffff) - 1 - compare (PV1 x xs) (PV0 w) = case compare x y of - EQ -> compare xs [y2,y3,y4] - c -> c - where - y = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1 - y2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1 - y3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1 - y4 = fromIntegral (w .&. 0xffff) - 1 + compare (PV0 x) (PV0 y) = compare x y + compare (PV1 x xs) (PV1 y ys) = case compare x y of + EQ -> compare xs ys + c -> c + compare (PV0 w) (PV1 y ys) = case compare x y of + EQ -> compare [x2, x3, x4] ys + c -> c + where + x = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1 + x2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1 + x3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1 + x4 = fromIntegral (w .&. 0xffff) - 1 + compare (PV1 x xs) (PV0 w) = case compare x y of + EQ -> compare xs [y2, y3, y4] + c -> c + where + y = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1 + y2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1 + y3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1 + y4 = fromIntegral (w .&. 0xffff) - 1 instance Show Version where - showsPrec d v = showParen (d > 10) - $ showString "mkVersion " + showsPrec d v = + showParen (d > 10) $ + showString "mkVersion " . showsPrec 11 (versionNumbers v) instance Read Version where - readPrec = Read.parens $ do - Read.Ident "mkVersion" <- Read.lexP - v <- Read.step Read.readPrec - return (mkVersion v) + readPrec = Read.parens $ do + Read.Ident "mkVersion" <- Read.lexP + v <- Read.step Read.readPrec + return (mkVersion v) instance Binary Version instance Structured Version instance NFData Version where - rnf (PV0 _) = () - rnf (PV1 _ ns) = rnf ns + rnf (PV0 _) = () + rnf (PV1 _ ns) = rnf ns instance Pretty Version where - pretty ver - = Disp.hcat (Disp.punctuate (Disp.char '.') - (map Disp.int $ versionNumbers ver)) + pretty ver = + Disp.hcat + ( Disp.punctuate + (Disp.char '.') + (map Disp.int $ versionNumbers ver) + ) instance Parsec Version where - parsec = mkVersion <$> toList <$> P.sepByNonEmpty versionDigitParser (P.char '.') <* tags - where - tags = do - ts <- many $ P.char '-' *> some (P.satisfy isAlphaNum) - case ts of - [] -> pure () - (_ : _) -> parsecWarning PWTVersionTag "version with tags" + parsec = mkVersion <$> toList <$> P.sepByNonEmpty versionDigitParser (P.char '.') <* tags + where + tags = do + ts <- many $ P.char '-' *> some (P.satisfy isAlphaNum) + case ts of + [] -> pure () + (_ : _) -> parsecWarning PWTVersionTag "version with tags" -- | An integral without leading zeroes. -- @@ -108,15 +114,15 @@ versionDigitParser :: CabalParsing m => m Int versionDigitParser = (some d >>= toNumber) P. "version digit (integral without leading zeroes)" where toNumber :: CabalParsing m => [Int] -> m Int - toNumber [0] = return 0 - toNumber (0:_) = P.unexpected "Version digit with leading zero" + toNumber [0] = return 0 + toNumber (0 : _) = P.unexpected "Version digit with leading zero" toNumber xs - -- 10^9 = 1000000000 - -- 2^30 = 1073741824 - -- - -- GHC Int is at least 32 bits, so 2^31-1 is the 'maxBound'. - | length xs > 9 = P.unexpected "At most 9 numbers are allowed per version number part" - | otherwise = return $ foldl' (\a b -> a * 10 + b) 0 xs + -- 10^9 = 1000000000 + -- 2^30 = 1073741824 + -- + -- GHC Int is at least 32 bits, so 2^31-1 is the 'maxBound'. + | length xs > 9 = P.unexpected "At most 9 numbers are allowed per version number part" + | otherwise = return $ foldl' (\a b -> a * 10 + b) 0 xs d :: P.CharParsing m => m Int d = f <$> P.satisfyRange '0' '9' @@ -134,42 +140,56 @@ versionDigitParser = (some d >>= toNumber) P. "version digit (integral withou mkVersion :: [Int] -> Version -- TODO: add validity check; disallow 'mkVersion []' (we have -- 'nullVersion' for that) -mkVersion [] = nullVersion -mkVersion (v1:[]) - | inWord16VerRep1 v1 = PV0 (mkWord64VerRep1 v1) - | otherwise = PV1 v1 [] +mkVersion [] = nullVersion +mkVersion (v1 : []) + | inWord16VerRep1 v1 = PV0 (mkWord64VerRep1 v1) + | otherwise = PV1 v1 [] where - inWord16VerRep1 x1 = inWord16 (x1 .|. (x1+1)) - mkWord64VerRep1 y1 = mkWord64VerRep (y1+1) 0 0 0 - -mkVersion (v1:vs@(v2:[])) - | inWord16VerRep2 v1 v2 = PV0 (mkWord64VerRep2 v1 v2) - | otherwise = PV1 v1 vs + inWord16VerRep1 x1 = inWord16 (x1 .|. (x1 + 1)) + mkWord64VerRep1 y1 = mkWord64VerRep (y1 + 1) 0 0 0 +mkVersion (v1 : vs@(v2 : [])) + | inWord16VerRep2 v1 v2 = PV0 (mkWord64VerRep2 v1 v2) + | otherwise = PV1 v1 vs where - inWord16VerRep2 x1 x2 = inWord16 (x1 .|. (x1+1) - .|. x2 .|. (x2+1)) - mkWord64VerRep2 y1 y2 = mkWord64VerRep (y1+1) (y2+1) 0 0 - -mkVersion (v1:vs@(v2:v3:[])) - | inWord16VerRep3 v1 v2 v3 = PV0 (mkWord64VerRep3 v1 v2 v3) - | otherwise = PV1 v1 vs + inWord16VerRep2 x1 x2 = + inWord16 + ( x1 + .|. (x1 + 1) + .|. x2 + .|. (x2 + 1) + ) + mkWord64VerRep2 y1 y2 = mkWord64VerRep (y1 + 1) (y2 + 1) 0 0 +mkVersion (v1 : vs@(v2 : v3 : [])) + | inWord16VerRep3 v1 v2 v3 = PV0 (mkWord64VerRep3 v1 v2 v3) + | otherwise = PV1 v1 vs where - inWord16VerRep3 x1 x2 x3 = inWord16 (x1 .|. (x1+1) - .|. x2 .|. (x2+1) - .|. x3 .|. (x3+1)) - mkWord64VerRep3 y1 y2 y3 = mkWord64VerRep (y1+1) (y2+1) (y3+1) 0 - -mkVersion (v1:vs@(v2:v3:v4:[])) + inWord16VerRep3 x1 x2 x3 = + inWord16 + ( x1 + .|. (x1 + 1) + .|. x2 + .|. (x2 + 1) + .|. x3 + .|. (x3 + 1) + ) + mkWord64VerRep3 y1 y2 y3 = mkWord64VerRep (y1 + 1) (y2 + 1) (y3 + 1) 0 +mkVersion (v1 : vs@(v2 : v3 : v4 : [])) | inWord16VerRep4 v1 v2 v3 v4 = PV0 (mkWord64VerRep4 v1 v2 v3 v4) - | otherwise = PV1 v1 vs + | otherwise = PV1 v1 vs where - inWord16VerRep4 x1 x2 x3 x4 = inWord16 (x1 .|. (x1+1) - .|. x2 .|. (x2+1) - .|. x3 .|. (x3+1) - .|. x4 .|. (x4+1)) - mkWord64VerRep4 y1 y2 y3 y4 = mkWord64VerRep (y1+1) (y2+1) (y3+1) (y4+1) - -mkVersion (v1:vs) = PV1 v1 vs + inWord16VerRep4 x1 x2 x3 x4 = + inWord16 + ( x1 + .|. (x1 + 1) + .|. x2 + .|. (x2 + 1) + .|. x3 + .|. (x3 + 1) + .|. x4 + .|. (x4 + 1) + ) + mkWord64VerRep4 y1 y2 y3 y4 = mkWord64VerRep (y1 + 1) (y2 + 1) (y3 + 1) (y4 + 1) +mkVersion (v1 : vs) = PV1 v1 vs -- | Version 0. A lower bound of 'Version'. -- @@ -180,10 +200,10 @@ version0 = mkVersion [0] {-# INLINE mkWord64VerRep #-} mkWord64VerRep :: Int -> Int -> Int -> Int -> Word64 mkWord64VerRep v1 v2 v3 v4 = - (fromIntegral v1 `shiftL` 48) - .|. (fromIntegral v2 `shiftL` 32) - .|. (fromIntegral v3 `shiftL` 16) - .|. fromIntegral v4 + (fromIntegral v1 `shiftL` 48) + .|. (fromIntegral v2 `shiftL` 32) + .|. (fromIntegral v3 `shiftL` 16) + .|. fromIntegral v4 {-# INLINE inWord16 #-} inWord16 :: Int -> Bool @@ -204,20 +224,19 @@ mkVersion' = mkVersion . Base.versionBranch -- -- @since 2.0.0.2 versionNumbers :: Version -> [Int] -versionNumbers (PV1 n ns) = n:ns +versionNumbers (PV1 n ns) = n : ns versionNumbers (PV0 w) - | v1 < 0 = [] - | v2 < 0 = [v1] - | v3 < 0 = [v1,v2] - | v4 < 0 = [v1,v2,v3] - | otherwise = [v1,v2,v3,v4] + | v1 < 0 = [] + | v2 < 0 = [v1] + | v3 < 0 = [v1, v2] + | v4 < 0 = [v1, v2, v3] + | otherwise = [v1, v2, v3, v4] where v1 = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1 v2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1 v3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1 v4 = fromIntegral (w .&. 0xffff) - 1 - -- | Constant representing the special /null/ 'Version' -- -- The 'nullVersion' compares (via 'Ord') as less than every proper @@ -239,4 +258,4 @@ alterVersion f = mkVersion . f . versionNumbers -- internal helper validVersion :: Version -> Bool -validVersion v = v /= nullVersion && all (>=0) (versionNumbers v) +validVersion v = v /= nullVersion && all (>= 0) (versionNumbers v) diff --git a/Cabal-syntax/src/Distribution/Types/VersionInterval.hs b/Cabal-syntax/src/Distribution/Types/VersionInterval.hs index cc8c3966349..e63e8701188 100644 --- a/Cabal-syntax/src/Distribution/Types/VersionInterval.hs +++ b/Cabal-syntax/src/Distribution/Types/VersionInterval.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} -- | This module implements a view of a 'VersionRange' as a finite @@ -8,37 +8,36 @@ -- preserve the caret operator @^>=x.y@. This constraint a priori -- specifies the same interval as @==x.y.*@, but indicates that newer -- versions could be acceptable (@allow-newer: ^@). --- -module Distribution.Types.VersionInterval ( - -- * Version intervals - VersionIntervals, - unVersionIntervals, +module Distribution.Types.VersionInterval + ( -- * Version intervals + VersionIntervals + , unVersionIntervals -- * Conversions - toVersionIntervals, - fromVersionIntervals, + , toVersionIntervals + , fromVersionIntervals -- ** Normalisation - normaliseVersionRange2, + , normaliseVersionRange2 -- * Relaxation - relaxLastInterval, - relaxHeadInterval, + , relaxLastInterval + , relaxHeadInterval -- * Version intervals view - asVersionIntervals, - VersionInterval (..), - LowerBound(..), - UpperBound(..), - Bound(..), + , asVersionIntervals + , VersionInterval (..) + , LowerBound (..) + , UpperBound (..) + , Bound (..) -- * Invariants - invariantVersionIntervals, - ) where + , invariantVersionIntervals + ) where -import Control.Applicative (liftA2) -import Control.Exception (assert) -import Distribution.Compat.Prelude hiding (Applicative(..)) +import Control.Applicative (liftA2) +import Control.Exception (assert) +import Distribution.Compat.Prelude hiding (Applicative (..)) import Prelude () import Distribution.Types.Version @@ -64,19 +63,17 @@ import Distribution.Types.VersionRange.Internal -- or containment. It also makes it easier to identify \'simple\' version -- predicates for translation into foreign packaging systems that do not -- support complex version range expressions. --- newtype VersionIntervals = VersionIntervals [VersionInterval] deriving (Eq, Show, Typeable) -- | Inspect the list of version intervals. --- unVersionIntervals :: VersionIntervals -> [VersionInterval] unVersionIntervals (VersionIntervals is) = is -data VersionInterval = VersionInterval !LowerBound !UpperBound deriving (Eq, Show) -data LowerBound = LowerBound !Version !Bound deriving (Eq, Show) -data UpperBound = NoUpperBound | UpperBound !Version !Bound deriving (Eq, Show) -data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show) +data VersionInterval = VersionInterval !LowerBound !UpperBound deriving (Eq, Show) +data LowerBound = LowerBound !Version !Bound deriving (Eq, Show) +data UpperBound = NoUpperBound | UpperBound !Version !Bound deriving (Eq, Show) +data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show) zeroLowerBound :: LowerBound zeroLowerBound = LowerBound version0 InclusiveBound @@ -89,29 +86,27 @@ isVersion0 = (==) version0 ------------------------------------------------------------------------------- stage1 :: VersionRange -> [VersionInterval] -stage1 = cataVersionRange alg where +stage1 = cataVersionRange alg + where -- version range leafs transform into singleton intervals - alg (ThisVersionF v) = [VersionInterval (LowerBound v InclusiveBound) (UpperBound v InclusiveBound)] - alg (LaterVersionF v) = [VersionInterval (LowerBound v ExclusiveBound) NoUpperBound] - alg (OrLaterVersionF v) = [VersionInterval (LowerBound v InclusiveBound) NoUpperBound] + alg (ThisVersionF v) = [VersionInterval (LowerBound v InclusiveBound) (UpperBound v InclusiveBound)] + alg (LaterVersionF v) = [VersionInterval (LowerBound v ExclusiveBound) NoUpperBound] + alg (OrLaterVersionF v) = [VersionInterval (LowerBound v InclusiveBound) NoUpperBound] alg (EarlierVersionF v) - | isVersion0 v = [] - | otherwise = [VersionInterval zeroLowerBound (UpperBound v ExclusiveBound)] - alg (OrEarlierVersionF v) = [VersionInterval zeroLowerBound (UpperBound v InclusiveBound)] - - -- ^>= version-range's upper bound should be MajorBound - alg (MajorBoundVersionF v) = [VersionInterval (LowerBound v InclusiveBound) (UpperBound (majorUpperBound v) ExclusiveBound)] - + | isVersion0 v = [] + | otherwise = [VersionInterval zeroLowerBound (UpperBound v ExclusiveBound)] + alg (OrEarlierVersionF v) = [VersionInterval zeroLowerBound (UpperBound v InclusiveBound)] + -- \^>= version-range's upper bound should be MajorBound + alg (MajorBoundVersionF v) = [VersionInterval (LowerBound v InclusiveBound) (UpperBound (majorUpperBound v) ExclusiveBound)] -- union: just merge the version intervals - alg (UnionVersionRangesF v1 v2) = v1 ++ v2 - + alg (UnionVersionRangesF v1 v2) = v1 ++ v2 -- intersection: pairwise intersect. Strip empty intervals. Sort to restore the invariant. alg (IntersectVersionRangesF v1 v2) = mapMaybe nonEmptyInterval $ liftA2 intersectInterval (stage2and3 v1) (stage2and3 v2) -- | Check that interval is non-empty nonEmptyInterval :: VersionInterval -> Maybe VersionInterval nonEmptyInterval i | nonEmptyVI i = Just i -nonEmptyInterval _ = Nothing +nonEmptyInterval _ = Nothing ------------------------------------------------------------------------------- -- Stage2 @@ -122,7 +117,7 @@ stage2 = sortBy lowerboundCmp lowerboundCmp :: VersionInterval -> VersionInterval -> Ordering lowerboundCmp (VersionInterval (LowerBound v vb) _) (VersionInterval (LowerBound u ub) _) = - compare v u `mappend` compareBound vb ub + compare v u `mappend` compareBound vb ub where compareBound :: Bound -> Bound -> Ordering compareBound InclusiveBound InclusiveBound = EQ @@ -136,7 +131,6 @@ lowerboundCmp (VersionInterval (LowerBound v vb) _) (VersionInterval (LowerBound -- | Post-processing takes a list of ordered version intervals, -- but possibly overlapping, and creates 'VersionIntervals'. --- postprocess :: [VersionInterval] -> VersionIntervals postprocess = checkInvariant . VersionIntervals . stage2and3 @@ -144,15 +138,15 @@ stage2and3 :: [VersionInterval] -> [VersionInterval] stage2and3 = stage3 . stage2 stage3 :: [VersionInterval] -> [VersionInterval] -stage3 [] = [] -stage3 (VersionInterval lb ub : rest) = stage3go lb ub rest +stage3 [] = [] +stage3 (VersionInterval lb ub : rest) = stage3go lb ub rest stage3go :: LowerBound -> UpperBound -> [VersionInterval] -> [VersionInterval] -stage3go !lb NoUpperBound _ = [VersionInterval lb NoUpperBound] -stage3go !lb !ub [] = [VersionInterval lb ub] -stage3go !lb !ub (VersionInterval lb' ub' : rest') - | doesNotTouch ub lb' = VersionInterval lb ub : stage3go lb' ub' rest' - | otherwise = stage3go lb (unionUpper ub ub') rest' +stage3go !lb NoUpperBound _ = [VersionInterval lb NoUpperBound] +stage3go !lb !ub [] = [VersionInterval lb ub] +stage3go !lb !ub (VersionInterval lb' ub' : rest') + | doesNotTouch ub lb' = VersionInterval lb ub : stage3go lb' ub' rest' + | otherwise = stage3go lb (unionUpper ub ub') rest' ------------------------------------------------------------------------------- -- Intersections @@ -160,41 +154,41 @@ stage3go !lb !ub (VersionInterval lb' ub' : rest') intersectInterval :: VersionInterval -> VersionInterval -> VersionInterval intersectInterval (VersionInterval lv uv) (VersionInterval lu uu) = - VersionInterval (intersectLower lv lu) (intersectUpper uv uu) + VersionInterval (intersectLower lv lu) (intersectUpper uv uu) intersectLower :: LowerBound -> LowerBound -> LowerBound intersectLower (LowerBound v vb) (LowerBound u ub) = case compare v u of - EQ -> LowerBound v (intersectBound vb ub) - LT -> LowerBound u ub - GT -> LowerBound v vb + EQ -> LowerBound v (intersectBound vb ub) + LT -> LowerBound u ub + GT -> LowerBound v vb intersectUpper :: UpperBound -> UpperBound -> UpperBound -intersectUpper NoUpperBound b = b -intersectUpper b NoUpperBound = b +intersectUpper NoUpperBound b = b +intersectUpper b NoUpperBound = b intersectUpper (UpperBound v vb) (UpperBound u ub) = case compare v u of - EQ -> UpperBound v (intersectBound vb ub) - LT -> UpperBound v vb - GT -> UpperBound u ub + EQ -> UpperBound v (intersectBound vb ub) + LT -> UpperBound v vb + GT -> UpperBound u ub intersectBound :: Bound -> Bound -> Bound intersectBound InclusiveBound InclusiveBound = InclusiveBound -intersectBound _ _ = ExclusiveBound +intersectBound _ _ = ExclusiveBound ------------------------------------------------------------------------------- -- Unions ------------------------------------------------------------------------------- unionUpper :: UpperBound -> UpperBound -> UpperBound -unionUpper NoUpperBound _ = NoUpperBound -unionUpper _ NoUpperBound = NoUpperBound +unionUpper NoUpperBound _ = NoUpperBound +unionUpper _ NoUpperBound = NoUpperBound unionUpper (UpperBound v vb) (UpperBound u ub) = case compare v u of - EQ -> UpperBound v (unionBound vb ub) - LT -> UpperBound u ub - GT -> UpperBound v vb + EQ -> UpperBound v (unionBound vb ub) + LT -> UpperBound u ub + GT -> UpperBound v vb unionBound :: Bound -> Bound -> Bound unionBound ExclusiveBound ExclusiveBound = ExclusiveBound -unionBound _ _ = InclusiveBound +unionBound _ _ = InclusiveBound ------------------------------------------------------------------------------- -- VersionRange @@ -221,7 +215,6 @@ unionBound _ _ = InclusiveBound -- > ,UpperBound v' InclusiveBound)] <- asVersionIntervals vr -- > , v == v' = Just v -- > | otherwise = Nothing --- asVersionIntervals :: VersionRange -> [VersionInterval] asVersionIntervals = unVersionIntervals . toVersionIntervals @@ -235,11 +228,10 @@ asVersionIntervals = unVersionIntervals . toVersionIntervals -- ---| or ---) but not ---] or ---) or ---] -- |--- (--- (--- [--- [--- -- @ --- doesNotTouch :: UpperBound -> LowerBound -> Bool -doesNotTouch NoUpperBound _ = False +doesNotTouch NoUpperBound _ = False doesNotTouch (UpperBound u ub) (LowerBound l lb) = - (u < l) || (u == l && ub == ExclusiveBound && lb == ExclusiveBound) + (u < l) || (u == l && ub == ExclusiveBound && lb == ExclusiveBound) ------------------------------------------------------------------------------- -- Invariants @@ -249,19 +241,18 @@ doesNotTouch (UpperBound u ub) (LowerBound l lb) = -- -- * all intervals are valid (lower bound is less then upper bound, i.e. non-empty) -- * intervals doesn't touch each other (distinct) --- invariantVersionIntervals :: VersionIntervals -> Bool invariantVersionIntervals (VersionIntervals intervals) = - all validInterval intervals && - all doesNotTouch' adjacentIntervals + all validInterval intervals + && all doesNotTouch' adjacentIntervals where doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool doesNotTouch' (VersionInterval _ u, VersionInterval l' _) = doesNotTouch u l' adjacentIntervals :: [(VersionInterval, VersionInterval)] adjacentIntervals = case intervals of - [] -> [] - (_:tl) -> zip intervals tl + [] -> [] + (_ : tl) -> zip intervals tl checkInvariant :: VersionIntervals -> VersionIntervals checkInvariant is = assert (invariantVersionIntervals is) is @@ -271,13 +262,13 @@ validInterval :: VersionInterval -> Bool validInterval i@(VersionInterval l u) = validLower l && validUpper u && nonEmptyVI i where validLower (LowerBound v _) = validVersion v - validUpper NoUpperBound = True - validUpper (UpperBound v _) = validVersion v + validUpper NoUpperBound = True + validUpper (UpperBound v _) = validVersion v -- Check an interval is non-empty -- nonEmptyVI :: VersionInterval -> Bool -nonEmptyVI (VersionInterval _ NoUpperBound) = True +nonEmptyVI (VersionInterval _ NoUpperBound) = True nonEmptyVI (VersionInterval (LowerBound l lb) (UpperBound u ub)) = (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound) @@ -286,39 +277,35 @@ nonEmptyVI (VersionInterval (LowerBound l lb) (UpperBound u ub)) = ------------------------------------------------------------------------------- -- | Convert a 'VersionRange' to a sequence of version intervals. --- toVersionIntervals :: VersionRange -> VersionIntervals toVersionIntervals = postprocess . stage1 -- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression -- representing the version intervals. --- fromVersionIntervals :: VersionIntervals -> VersionRange -fromVersionIntervals (VersionIntervals []) = noVersion -fromVersionIntervals (VersionIntervals (x:xs)) = foldr1 unionVersionRanges (fmap intervalToVersionRange (x:|xs)) +fromVersionIntervals (VersionIntervals []) = noVersion +fromVersionIntervals (VersionIntervals (x : xs)) = foldr1 unionVersionRanges (fmap intervalToVersionRange (x :| xs)) intervalToVersionRange :: VersionInterval -> VersionRange intervalToVersionRange (VersionInterval (LowerBound v vb) upper') = case upper' of - NoUpperBound - -> lowerBound - - UpperBound u ub - | vb == InclusiveBound - , ub == InclusiveBound - , v == u - -> thisVersion v - - UpperBound u ub -> withLowerBound (makeUpperBound u ub) + NoUpperBound -> + lowerBound + UpperBound u ub + | vb == InclusiveBound + , ub == InclusiveBound + , v == u -> + thisVersion v + UpperBound u ub -> withLowerBound (makeUpperBound u ub) where lowerBound :: VersionRange lowerBound = case vb of - InclusiveBound -> orLaterVersion v - ExclusiveBound -> laterVersion v + InclusiveBound -> orLaterVersion v + ExclusiveBound -> laterVersion v withLowerBound :: VersionRange -> VersionRange withLowerBound vr - | isVersion0 v, vb == InclusiveBound = vr - | otherwise = intersectVersionRanges lowerBound vr + | isVersion0 v, vb == InclusiveBound = vr + | otherwise = intersectVersionRanges lowerBound vr makeUpperBound :: Version -> Bound -> VersionRange makeUpperBound u InclusiveBound = orEarlierVersion u @@ -329,7 +316,6 @@ intervalToVersionRange (VersionInterval (LowerBound v vb) upper') = case upper' ------------------------------------------------------------------------------- -- | Since @Cabal-3.6@ this function.. TODO --- normaliseVersionRange2 :: VersionRange -> VersionRange normaliseVersionRange2 = fromVersionIntervals . toVersionIntervals @@ -340,12 +326,12 @@ normaliseVersionRange2 = fromVersionIntervals . toVersionIntervals relaxLastInterval :: VersionIntervals -> VersionIntervals relaxLastInterval (VersionIntervals xs) = VersionIntervals (relaxLastInterval' xs) where - relaxLastInterval' [] = [] + relaxLastInterval' [] = [] relaxLastInterval' [VersionInterval l _] = [VersionInterval l NoUpperBound] - relaxLastInterval' (i:is) = i : relaxLastInterval' is + relaxLastInterval' (i : is) = i : relaxLastInterval' is relaxHeadInterval :: VersionIntervals -> VersionIntervals relaxHeadInterval (VersionIntervals xs) = VersionIntervals (relaxHeadInterval' xs) where - relaxHeadInterval' [] = [] + relaxHeadInterval' [] = [] relaxHeadInterval' (VersionInterval _ u : is) = VersionInterval zeroLowerBound u : is diff --git a/Cabal-syntax/src/Distribution/Types/VersionInterval/Legacy.hs b/Cabal-syntax/src/Distribution/Types/VersionInterval/Legacy.hs index a24ab771dd7..f5e86d4a429 100644 --- a/Cabal-syntax/src/Distribution/Types/VersionInterval/Legacy.hs +++ b/Cabal-syntax/src/Distribution/Types/VersionInterval/Legacy.hs @@ -9,32 +9,31 @@ -- The current module "Distribution.Types.VersionInterval" (refurbished since -- @Cabal >= 3.6@) makes some effort to preserve the caret operator, -- but so far does not expose the Boolean algebra structure. --- -module Distribution.Types.VersionInterval.Legacy ( - -- * Version intervals - VersionIntervals, - toVersionIntervals, - fromVersionIntervals, - withinIntervals, - versionIntervals, - mkVersionIntervals, - unionVersionIntervals, - intersectVersionIntervals, - invertVersionIntervals, - relaxLastInterval, - relaxHeadInterval, +module Distribution.Types.VersionInterval.Legacy + ( -- * Version intervals + VersionIntervals + , toVersionIntervals + , fromVersionIntervals + , withinIntervals + , versionIntervals + , mkVersionIntervals + , unionVersionIntervals + , intersectVersionIntervals + , invertVersionIntervals + , relaxLastInterval + , relaxHeadInterval -- * Version intervals view - asVersionIntervals, - VersionInterval, - LowerBound(..), - UpperBound(..), - Bound(..), - ) where + , asVersionIntervals + , VersionInterval + , LowerBound (..) + , UpperBound (..) + , Bound (..) + ) where -import Prelude () -import Distribution.Compat.Prelude import Control.Exception (assert) +import Distribution.Compat.Prelude +import Prelude () import Distribution.Types.Version import Distribution.Types.VersionRange.Internal @@ -72,11 +71,9 @@ import qualified Prelude (foldr1) -- > ,UpperBound v' InclusiveBound)] <- asVersionIntervals vr -- > , v == v' = Just v -- > | otherwise = Nothing --- asVersionIntervals :: VersionRange -> [VersionInterval] asVersionIntervals = versionIntervals . toVersionIntervals - ------------------------------------------------------------------------------- -- VersionInterval ------------------------------------------------------------------------------- @@ -98,12 +95,10 @@ asVersionIntervals = versionIntervals . toVersionIntervals -- or containment. It also makes it easier to identify \'simple\' version -- predicates for translation into foreign packaging systems that do not -- support complex version range expressions. --- newtype VersionIntervals = VersionIntervals [VersionInterval] deriving (Eq, Show, Typeable) -- | Inspect the list of version intervals. --- versionIntervals :: VersionIntervals -> [VersionInterval] versionIntervals (VersionIntervals is) = is @@ -115,21 +110,25 @@ versionIntervals (VersionIntervals is) = is -- 4. \( [lb,ub] \) meaning \( lb ≤ \_ < ub \). -- -- The upper bound can also be missing, meaning "\( ..,∞) \)". --- type VersionInterval = (LowerBound, UpperBound) data LowerBound - = LowerBound Version !Bound -- ^ Either exclusive @(v,..@ or inclusive @[v,..@. + = -- | Either exclusive @(v,..@ or inclusive @[v,..@. + LowerBound Version !Bound deriving (Eq, Show) data UpperBound - = NoUpperBound -- ^ @..,∞)@ - | UpperBound Version !Bound -- ^ Either exclusive @..,v)@ or inclusive @..,v]@. + = -- | @..,∞)@ + NoUpperBound + | -- | Either exclusive @..,v)@ or inclusive @..,v]@. + UpperBound Version !Bound deriving (Eq, Show) data Bound - = ExclusiveBound -- ^ @(v,..@ if used as lower bound, @..,v)@ if used as upper bound. - | InclusiveBound -- ^ @[v,..@ if used as lower bound, @..,v]@ if used as upper bound. + = -- | @(v,..@ if used as lower bound, @..,v)@ if used as upper bound. + ExclusiveBound + | -- | @[v,..@ if used as lower bound, @..,v]@ if used as upper bound. + InclusiveBound deriving (Eq, Show) -- | @[0,..@. @@ -140,7 +139,6 @@ isVersion0 :: Version -> Bool isVersion0 = (==) version0 -- | @lb1 <= lb2@ holds iff interval @lb1..@ is contained in interval @lb2..@. --- instance Ord LowerBound where LowerBound ver bound <= LowerBound ver' bound' = case compare ver ver' of LT -> True @@ -148,9 +146,8 @@ instance Ord LowerBound where GT -> False -- | @ub1 <= ub2@ holds iff interval @0..ub1@ is contained in interval @0..ub2@. --- instance Ord UpperBound where - _ <= NoUpperBound = True + _ <= NoUpperBound = True NoUpperBound <= UpperBound _ _ = False UpperBound ver bound <= UpperBound ver' bound' = case compare ver ver' of LT -> True @@ -160,54 +157,49 @@ instance Ord UpperBound where -- | Check that the sequence is ordered, -- adjacent intervals are separated (do not overlap), -- an no interval is empty (which would be a redundant entry). --- invariant :: VersionIntervals -> Bool -invariant (VersionIntervals intervals) = all validInterval intervals - && all doesNotTouch' adjacentIntervals +invariant (VersionIntervals intervals) = + all validInterval intervals + && all doesNotTouch' adjacentIntervals where doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool - doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l' + doesNotTouch' ((_, u), (l', _)) = doesNotTouch u l' -- adjacentIntervals = zip intervals (tail intervals) adjacentIntervals :: [(VersionInterval, VersionInterval)] adjacentIntervals = case intervals of - [] -> [] - (_:tl) -> zip intervals tl + [] -> [] + (_ : tl) -> zip intervals tl -- | The partial identity function, erroring out on illformed 'VersionIntervals'. --- checkInvariant :: VersionIntervals -> VersionIntervals checkInvariant is = assert (invariant is) is -- | Directly construct a 'VersionIntervals' from a list of intervals. --- mkVersionIntervals :: [VersionInterval] -> VersionIntervals mkVersionIntervals intervals - | invariant (VersionIntervals intervals) = VersionIntervals intervals - | otherwise - = checkInvariant + | invariant (VersionIntervals intervals) = VersionIntervals intervals + | otherwise = + checkInvariant . foldl' (flip insertInterval) (VersionIntervals []) . filter validInterval $ intervals -- | Add an interval to the sequence, fusing with existing intervals if necessary. --- insertInterval :: VersionInterval -> VersionIntervals -> VersionIntervals insertInterval i is = unionVersionIntervals (VersionIntervals [i]) is -- | A valid interval is non-empty. --- validInterval :: (LowerBound, UpperBound) -> Bool validInterval i@(l, u) = validLower l && validUpper u && nonEmptyVI i where validLower (LowerBound v _) = validVersion v - validUpper NoUpperBound = True + validUpper NoUpperBound = True validUpper (UpperBound v _) = validVersion v -- | Check that an interval is non-empty. --- nonEmptyVI :: VersionInterval -> Bool -nonEmptyVI (_, NoUpperBound ) = True +nonEmptyVI (_, NoUpperBound) = True nonEmptyVI (LowerBound l lb, UpperBound u ub) = (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound) @@ -222,8 +214,8 @@ nonEmptyVI (LowerBound l lb, UpperBound u ub) = doesNotTouch :: UpperBound -> LowerBound -> Bool doesNotTouch NoUpperBound _ = False doesNotTouch (UpperBound u ub) (LowerBound l lb) = - u < l - || (u == l && ub == ExclusiveBound && lb == ExclusiveBound) + u < l + || (u == l && ub == ExclusiveBound && lb == ExclusiveBound) -- | Check an upper bound does not intersect a lower bound: -- @@ -233,12 +225,11 @@ doesNotTouch (UpperBound u ub) (LowerBound l lb) = -- |--- (--- (--- [--- [--- -- -- @ --- doesNotIntersect :: UpperBound -> LowerBound -> Bool doesNotIntersect NoUpperBound _ = False doesNotIntersect (UpperBound u ub) (LowerBound l lb) = - u < l - || (u == l && not (ub == InclusiveBound && lb == InclusiveBound)) + u < l + || (u == l && not (ub == InclusiveBound && lb == InclusiveBound)) -- | Test if a version falls within the version intervals. -- @@ -247,39 +238,39 @@ doesNotIntersect (UpperBound u ub) (LowerBound l lb) = -- -- > withinIntervals v (toVersionIntervals vr) = withinRange v vr -- > withinIntervals v ivs = withinRange v (fromVersionIntervals ivs) --- withinIntervals :: Version -> VersionIntervals -> Bool withinIntervals v (VersionIntervals intervals) = any withinInterval intervals where - withinInterval (lowerBound, upperBound) = withinLower lowerBound - && withinUpper upperBound - withinLower (LowerBound v' ExclusiveBound) = v' < v + withinInterval (lowerBound, upperBound) = + withinLower lowerBound + && withinUpper upperBound + withinLower (LowerBound v' ExclusiveBound) = v' < v withinLower (LowerBound v' InclusiveBound) = v' <= v - withinUpper NoUpperBound = True - withinUpper (UpperBound v' ExclusiveBound) = v' > v + withinUpper NoUpperBound = True + withinUpper (UpperBound v' ExclusiveBound) = v' > v withinUpper (UpperBound v' InclusiveBound) = v' >= v -- | Convert a 'VersionRange' to a sequence of version intervals. --- toVersionIntervals :: VersionRange -> VersionIntervals -toVersionIntervals = cataVersionRange alg where +toVersionIntervals = cataVersionRange alg + where -- @== v@ - alg (ThisVersionF v) = chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound) + alg (ThisVersionF v) = chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound) -- @> v@ - alg (LaterVersionF v) = chkIvl (LowerBound v ExclusiveBound, NoUpperBound) + alg (LaterVersionF v) = chkIvl (LowerBound v ExclusiveBound, NoUpperBound) -- @>= v@ - alg (OrLaterVersionF v) = chkIvl (LowerBound v InclusiveBound, NoUpperBound) + alg (OrLaterVersionF v) = chkIvl (LowerBound v InclusiveBound, NoUpperBound) -- @< v@ alg (EarlierVersionF v) - | isVersion0 v = VersionIntervals [] - | otherwise = chkIvl (minLowerBound, UpperBound v ExclusiveBound) + | isVersion0 v = VersionIntervals [] + | otherwise = chkIvl (minLowerBound, UpperBound v ExclusiveBound) -- @<= v@ - alg (OrEarlierVersionF v) = chkIvl (minLowerBound, UpperBound v InclusiveBound) + alg (OrEarlierVersionF v) = chkIvl (minLowerBound, UpperBound v InclusiveBound) -- @^>= v@ - alg (MajorBoundVersionF v) = chkIvl (LowerBound v InclusiveBound, UpperBound (majorUpperBound v) ExclusiveBound) + alg (MajorBoundVersionF v) = chkIvl (LowerBound v InclusiveBound, UpperBound (majorUpperBound v) ExclusiveBound) -- @r || r'@ - alg (UnionVersionRangesF v1 v2) = unionVersionIntervals v1 v2 + alg (UnionVersionRangesF v1 v2) = unionVersionIntervals v1 v2 -- @r && r'@ alg (IntersectVersionRangesF v1 v2) = intersectVersionIntervals v1 v2 @@ -287,55 +278,52 @@ toVersionIntervals = cataVersionRange alg where -- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression -- representing the version intervals. --- fromVersionIntervals :: VersionIntervals -> VersionRange fromVersionIntervals (VersionIntervals []) = noVersion fromVersionIntervals (VersionIntervals intervals) = - Prelude.foldr1 unionVersionRanges [ interval l u | (l, u) <- intervals ] - + Prelude.foldr1 unionVersionRanges [interval l u | (l, u) <- intervals] where - interval (LowerBound v InclusiveBound) - (UpperBound v' InclusiveBound) | v == v' - = thisVersion v + interval + (LowerBound v InclusiveBound) + (UpperBound v' InclusiveBound) + | v == v' = + thisVersion v interval l u = lowerBound l `intersectVersionRanges'` upperBound u lowerBound (LowerBound v InclusiveBound) - | isVersion0 v = Nothing - | otherwise = Just (orLaterVersion v) + | isVersion0 v = Nothing + | otherwise = Just (orLaterVersion v) lowerBound (LowerBound v ExclusiveBound) = Just (laterVersion v) - upperBound NoUpperBound = Nothing + upperBound NoUpperBound = Nothing upperBound (UpperBound v InclusiveBound) = Just (orEarlierVersion v) upperBound (UpperBound v ExclusiveBound) = Just (earlierVersion v) - intersectVersionRanges' Nothing Nothing = anyVersion - intersectVersionRanges' (Just vr) Nothing = vr - intersectVersionRanges' Nothing (Just vr) = vr + intersectVersionRanges' Nothing Nothing = anyVersion + intersectVersionRanges' (Just vr) Nothing = vr + intersectVersionRanges' Nothing (Just vr) = vr intersectVersionRanges' (Just vr) (Just vr') = intersectVersionRanges vr vr' -- | Union two interval sequences, fusing intervals where necessary. -- Computed \( O(n+m) \) time, resulting in sequence of length \( ≤ n+m \). --- -unionVersionIntervals :: VersionIntervals -> VersionIntervals - -> VersionIntervals +unionVersionIntervals + :: VersionIntervals + -> VersionIntervals + -> VersionIntervals unionVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = checkInvariant (VersionIntervals (union is0 is'0)) where - union is [] = is + union is [] = is union [] is' = is' - union (i:is) (i':is') = case unionInterval i i' of - + union (i : is) (i' : is') = case unionInterval i i' of -- @i < i'@ and separated: keep @i@. - Left Nothing -> i : union is (i' :is') - + Left Nothing -> i : union is (i' : is') -- @i'' = i ∪ i'@ and @i@ ends first: drop @i@, replace @i'@ by @i''@. - Left (Just i'') -> union is (i'':is') - + Left (Just i'') -> union is (i'' : is') -- @i' < i@ and separated: keep @i'@. - Right Nothing -> i' : union (i :is) is' - + Right Nothing -> i' : union (i : is) is' -- @i'' = i ∪ i'@ and @i'@ ends first: drop @i'@, replace @i@ by @i''@. - Right (Just i'') -> union (i'':is) is' + Right (Just i'') -> union (i'' : is) is' -- | Given two version intervals @i1@ and @i2@, return one of the following: -- @@ -346,24 +334,23 @@ unionVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = -- -- Herein, @i < i'@ means that the whole of the interval @i@ is strictly left of the whole of @i'@, -- and @ub(i)@ returns the right boundary of interval @i@ which could be inclusive or exclusive. --- -unionInterval :: VersionInterval -> VersionInterval - -> Either (Maybe VersionInterval) (Maybe VersionInterval) -unionInterval (lower , upper ) (lower', upper') - +unionInterval + :: VersionInterval + -> VersionInterval + -> Either (Maybe VersionInterval) (Maybe VersionInterval) +unionInterval (lower, upper) (lower', upper') -- Non-intersecting intervals with the left interval ending first | upper `doesNotTouch` lower' = Left Nothing - -- Non-intersecting intervals with the right interval first | upper' `doesNotTouch` lower = Right Nothing - -- Complete or partial overlap, with the left interval ending first - | upper <= upper' = lowerBound `seq` - Left (Just (lowerBound, upper')) - + | upper <= upper' = + lowerBound `seq` + Left (Just (lowerBound, upper')) -- Complete or partial overlap, with the left interval ending first - | otherwise = lowerBound `seq` - Right (Just (lowerBound, upper)) + | otherwise = + lowerBound `seq` + Right (Just (lowerBound, upper)) where lowerBound = min lower lower' @@ -374,27 +361,24 @@ unionInterval (lower , upper ) (lower', upper') -- (rather than the naive \( O(nm) \). -- -- The length of \( is \cap is' \) is \( ≤ \min(n,m) \). --- -intersectVersionIntervals :: VersionIntervals -> VersionIntervals - -> VersionIntervals +intersectVersionIntervals + :: VersionIntervals + -> VersionIntervals + -> VersionIntervals intersectVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = checkInvariant (VersionIntervals (intersect is0 is'0)) where - intersect _ [] = [] - intersect [] _ = [] - intersect (i:is) (i':is') = case intersectInterval i i' of - + intersect _ [] = [] + intersect [] _ = [] + intersect (i : is) (i' : is') = case intersectInterval i i' of -- @i < i'@: throw out @i@ - Left Nothing -> intersect is (i':is') - + Left Nothing -> intersect is (i' : is') -- @i'' = i /\ i'@ and @i@ ends first: replace @i@ by @i''@. - Left (Just i'') -> i'' : intersect is (i':is') - + Left (Just i'') -> i'' : intersect is (i' : is') -- @i' < i@: throw out @i'@ - Right Nothing -> intersect (i:is) is' - + Right Nothing -> intersect (i : is) is' -- @i'' = i /\ i'@ and @i'@ ends first: replace @i'@ by @i''@. - Right (Just i'') -> i'' : intersect (i:is) is' + Right (Just i'') -> i'' : intersect (i : is) is' -- | Given two version intervals @i1@ and @i2@, return one of the following: -- @@ -405,69 +389,72 @@ intersectVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = -- -- Herein, @i < i'@ means that the whole of the interval @i@ is strictly left of the whole of @i'@, -- and @ub(i)@ returns the right boundary of interval @i@ which could be inclusive or exclusive. --- -intersectInterval :: VersionInterval -> VersionInterval - -> Either (Maybe VersionInterval) (Maybe VersionInterval) -intersectInterval (lower , upper ) (lower', upper') - +intersectInterval + :: VersionInterval + -> VersionInterval + -> Either (Maybe VersionInterval) (Maybe VersionInterval) +intersectInterval (lower, upper) (lower', upper') -- Non-intersecting intervals with the left interval ending first | upper `doesNotIntersect` lower' = Left Nothing - -- Non-intersecting intervals with the right interval first | upper' `doesNotIntersect` lower = Right Nothing - -- Complete or partial overlap, with the left interval ending first - | upper <= upper' = lowerBound `seq` - Left (Just (lowerBound, upper)) - + | upper <= upper' = + lowerBound `seq` + Left (Just (lowerBound, upper)) -- Complete or partial overlap, with the right interval ending first - | otherwise = lowerBound `seq` - Right (Just (lowerBound, upper')) + | otherwise = + lowerBound `seq` + Right (Just (lowerBound, upper')) where lowerBound = max lower lower' -- | Compute the complement. -- \( O(n) \). -invertVersionIntervals :: VersionIntervals - -> VersionIntervals +invertVersionIntervals + :: VersionIntervals + -> VersionIntervals invertVersionIntervals (VersionIntervals xs) = - case xs of - -- Empty interval set - [] -> VersionIntervals [(noLowerBound, NoUpperBound)] - -- Interval with no lower bound - ((lb, ub) : more) | lb == noLowerBound -> - VersionIntervals $ invertVersionIntervals' ub more - -- Interval with a lower bound - ((lb, ub) : more) -> - VersionIntervals $ (noLowerBound, invertLowerBound lb) + case xs of + -- Empty interval set + [] -> VersionIntervals [(noLowerBound, NoUpperBound)] + -- Interval with no lower bound + ((lb, ub) : more) + | lb == noLowerBound -> + VersionIntervals $ invertVersionIntervals' ub more + -- Interval with a lower bound + ((lb, ub) : more) -> + VersionIntervals $ + (noLowerBound, invertLowerBound lb) : invertVersionIntervals' ub more - where - -- Invert subsequent version intervals given the upper bound of - -- the intervals already inverted. - invertVersionIntervals' :: UpperBound - -> [(LowerBound, UpperBound)] - -> [(LowerBound, UpperBound)] - invertVersionIntervals' NoUpperBound [] = [] - invertVersionIntervals' ub0 [] = [(invertUpperBound ub0, NoUpperBound)] - invertVersionIntervals' ub0 [(lb, NoUpperBound)] = - [(invertUpperBound ub0, invertLowerBound lb)] - invertVersionIntervals' ub0 ((lb, ub1) : more) = - (invertUpperBound ub0, invertLowerBound lb) - : invertVersionIntervals' ub1 more - - invertLowerBound :: LowerBound -> UpperBound - invertLowerBound (LowerBound v b) = UpperBound v (invertBound b) - - invertUpperBound :: UpperBound -> LowerBound - invertUpperBound (UpperBound v b) = LowerBound v (invertBound b) - invertUpperBound NoUpperBound = error "NoUpperBound: unexpected" - - invertBound :: Bound -> Bound - invertBound ExclusiveBound = InclusiveBound - invertBound InclusiveBound = ExclusiveBound - - noLowerBound :: LowerBound - noLowerBound = LowerBound (mkVersion [0]) InclusiveBound + where + -- Invert subsequent version intervals given the upper bound of + -- the intervals already inverted. + invertVersionIntervals' + :: UpperBound + -> [(LowerBound, UpperBound)] + -> [(LowerBound, UpperBound)] + invertVersionIntervals' NoUpperBound [] = [] + invertVersionIntervals' ub0 [] = [(invertUpperBound ub0, NoUpperBound)] + invertVersionIntervals' ub0 [(lb, NoUpperBound)] = + [(invertUpperBound ub0, invertLowerBound lb)] + invertVersionIntervals' ub0 ((lb, ub1) : more) = + (invertUpperBound ub0, invertLowerBound lb) + : invertVersionIntervals' ub1 more + + invertLowerBound :: LowerBound -> UpperBound + invertLowerBound (LowerBound v b) = UpperBound v (invertBound b) + + invertUpperBound :: UpperBound -> LowerBound + invertUpperBound (UpperBound v b) = LowerBound v (invertBound b) + invertUpperBound NoUpperBound = error "NoUpperBound: unexpected" + + invertBound :: Bound -> Bound + invertBound ExclusiveBound = InclusiveBound + invertBound InclusiveBound = ExclusiveBound + + noLowerBound :: LowerBound + noLowerBound = LowerBound (mkVersion [0]) InclusiveBound -- | Remove the last upper bound, enlarging the range. -- But empty ranges stay empty. @@ -475,9 +462,9 @@ invertVersionIntervals (VersionIntervals xs) = relaxLastInterval :: VersionIntervals -> VersionIntervals relaxLastInterval (VersionIntervals xs) = VersionIntervals (relaxLastInterval' xs) where - relaxLastInterval' [] = [] - relaxLastInterval' [(l,_)] = [(l, NoUpperBound)] - relaxLastInterval' (i:is) = i : relaxLastInterval' is + relaxLastInterval' [] = [] + relaxLastInterval' [(l, _)] = [(l, NoUpperBound)] + relaxLastInterval' (i : is) = i : relaxLastInterval' is -- | Remove the first lower bound (i.e, make it \( [0 \). -- Empty ranges stay empty. @@ -485,5 +472,5 @@ relaxLastInterval (VersionIntervals xs) = VersionIntervals (relaxLastInterval' x relaxHeadInterval :: VersionIntervals -> VersionIntervals relaxHeadInterval (VersionIntervals xs) = VersionIntervals (relaxHeadInterval' xs) where - relaxHeadInterval' [] = [] - relaxHeadInterval' ((_,u):is) = (minLowerBound,u) : is + relaxHeadInterval' [] = [] + relaxHeadInterval' ((_, u) : is) = (minLowerBound, u) : is diff --git a/Cabal-syntax/src/Distribution/Types/VersionRange.hs b/Cabal-syntax/src/Distribution/Types/VersionRange.hs index 1f10688407d..c470b93c0d2 100644 --- a/Cabal-syntax/src/Distribution/Types/VersionRange.hs +++ b/Cabal-syntax/src/Distribution/Types/VersionRange.hs @@ -1,42 +1,48 @@ -module Distribution.Types.VersionRange ( - -- * Version ranges - VersionRange, +module Distribution.Types.VersionRange + ( -- * Version ranges + VersionRange -- ** Constructing - anyVersion, noVersion, - thisVersion, notThisVersion, - laterVersion, earlierVersion, - orLaterVersion, orEarlierVersion, - unionVersionRanges, intersectVersionRanges, - withinVersion, - majorBoundVersion, + , anyVersion + , noVersion + , thisVersion + , notThisVersion + , laterVersion + , earlierVersion + , orLaterVersion + , orEarlierVersion + , unionVersionRanges + , intersectVersionRanges + , withinVersion + , majorBoundVersion -- ** Inspection - -- - -- See "Distribution.Version" for more utilities. - withinRange, - foldVersionRange, - normaliseVersionRange, - stripParensVersionRange, - hasUpperBound, - hasLowerBound, + + -- + -- See "Distribution.Version" for more utilities. + , withinRange + , foldVersionRange + , normaliseVersionRange + , stripParensVersionRange + , hasUpperBound + , hasLowerBound -- ** Cata & ana - VersionRangeF (..), - cataVersionRange, - anaVersionRange, - hyloVersionRange, - projectVersionRange, - embedVersionRange, + , VersionRangeF (..) + , cataVersionRange + , anaVersionRange + , hyloVersionRange + , projectVersionRange + , embedVersionRange -- ** Utilities - isAnyVersion, - isAnyVersionLight, - wildcardUpperBound, - majorUpperBound, - isWildcardRange, - versionRangeParser, - ) where + , isAnyVersion + , isAnyVersionLight + , wildcardUpperBound + , majorUpperBound + , isWildcardRange + , versionRangeParser + ) where import Distribution.Compat.Prelude import Distribution.Types.Version @@ -51,30 +57,38 @@ import Prelude () -- in terms of the other basic syntax. -- -- For a semantic view use 'asVersionIntervals'. --- -foldVersionRange :: a -- ^ @\"-any\"@ version - -> (Version -> a) -- ^ @\"== v\"@ - -> (Version -> a) -- ^ @\"> v\"@ - -> (Version -> a) -- ^ @\"< v\"@ - -> (a -> a -> a) -- ^ @\"_ || _\"@ union - -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection - -> VersionRange -> a +foldVersionRange + :: a + -- ^ @\"-any\"@ version + -> (Version -> a) + -- ^ @\"== v\"@ + -> (Version -> a) + -- ^ @\"> v\"@ + -> (Version -> a) + -- ^ @\"< v\"@ + -> (a -> a -> a) + -- ^ @\"_ || _\"@ union + -> (a -> a -> a) + -- ^ @\"_ && _\"@ intersection + -> VersionRange + -> a foldVersionRange _any this later earlier union intersect = fold where fold = cataVersionRange alg - alg (ThisVersionF v) = this v - alg (LaterVersionF v) = later v - alg (OrLaterVersionF v) = union (this v) (later v) - alg (EarlierVersionF v) = earlier v - alg (OrEarlierVersionF v) = union (this v) (earlier v) - alg (MajorBoundVersionF v) = fold (majorBound v) - alg (UnionVersionRangesF v1 v2) = union v1 v2 + alg (ThisVersionF v) = this v + alg (LaterVersionF v) = later v + alg (OrLaterVersionF v) = union (this v) (later v) + alg (EarlierVersionF v) = earlier v + alg (OrEarlierVersionF v) = union (this v) (earlier v) + alg (MajorBoundVersionF v) = fold (majorBound v) + alg (UnionVersionRangesF v1 v2) = union v1 v2 alg (IntersectVersionRangesF v1 v2) = intersect v1 v2 - majorBound v = intersectVersionRanges - (orLaterVersion v) - (earlierVersion (majorUpperBound v)) + majorBound v = + intersectVersionRanges + (orLaterVersion v) + (earlierVersion (majorUpperBound v)) -- | Normalise 'VersionRange'. -- @@ -83,17 +97,19 @@ normaliseVersionRange :: VersionRange -> VersionRange normaliseVersionRange = hyloVersionRange embed projectVersionRange where -- == v || > v, > v || == v ==> >= v - embed (UnionVersionRangesF (ThisVersion v) (LaterVersion v')) | v == v' = - orLaterVersion v - embed (UnionVersionRangesF (LaterVersion v) (ThisVersion v')) | v == v' = - orLaterVersion v - + embed (UnionVersionRangesF (ThisVersion v) (LaterVersion v')) + | v == v' = + orLaterVersion v + embed (UnionVersionRangesF (LaterVersion v) (ThisVersion v')) + | v == v' = + orLaterVersion v -- == v || < v, < v || == v ==> <= v - embed (UnionVersionRangesF (ThisVersion v) (EarlierVersion v')) | v == v' = - orEarlierVersion v - embed (UnionVersionRangesF (EarlierVersion v) (ThisVersion v')) | v == v' = - orEarlierVersion v - + embed (UnionVersionRangesF (ThisVersion v) (EarlierVersion v')) + | v == v' = + orEarlierVersion v + embed (UnionVersionRangesF (EarlierVersion v) (ThisVersion v')) + | v == v' = + orEarlierVersion v -- otherwise embed normally embed vr = embedVersionRange vr @@ -108,15 +124,15 @@ stripParensVersionRange = id -- | Does this version fall within the given range? -- -- This is the evaluation function for the 'VersionRange' type. --- withinRange :: Version -> VersionRange -> Bool -withinRange v = foldVersionRange - True - (\v' -> v == v') - (\v' -> v > v') - (\v' -> v < v') - (||) - (&&) +withinRange v = + foldVersionRange + True + (\v' -> v == v') + (\v' -> v > v') + (\v' -> v < v') + (||) + (&&) -- | Does this 'VersionRange' place any restriction on the 'Version' or is it -- in fact equivalent to 'AnyVersion'. @@ -125,11 +141,10 @@ withinRange v = foldVersionRange -- the following is @True@ (for all @v@). -- -- > isAnyVersion (EarlierVersion v `UnionVersionRanges` orLaterVersion v) --- isAnyVersion :: VersionRange -> Bool isAnyVersion vr = case asVersionIntervals vr of - [VersionInterval (LowerBound v InclusiveBound) NoUpperBound] -> v == version0 - _ -> False + [VersionInterval (LowerBound v InclusiveBound) NoUpperBound] -> v == version0 + _ -> False -- A fast and non-precise version of 'isAnyVersion', -- returns 'True' only for @>= 0@ 'VersionRange's. @@ -141,29 +156,31 @@ isAnyVersion vr = case asVersionIntervals vr of -- isAnyVersionLight :: VersionRange -> Bool isAnyVersionLight (OrLaterVersion v) = v == version0 -isAnyVersionLight _vr = False +isAnyVersionLight _vr = False ---------------------------- -- Wildcard range utilities -- - isWildcardRange :: Version -> Version -> Bool isWildcardRange ver1 ver2 = check (versionNumbers ver1) (versionNumbers ver2) - where check (n:[]) (m:[]) | n+1 == m = True - check (n:ns) (m:ms) | n == m = check ns ms - check _ _ = False + where + check (n : []) (m : []) | n + 1 == m = True + check (n : ns) (m : ms) | n == m = check ns ms + check _ _ = False -- | Does the version range have an upper bound? -- -- @since 1.24.0.0 hasUpperBound :: VersionRange -> Bool -hasUpperBound = foldVersionRange - False - (const True) - (const False) - (const True) - (&&) (||) +hasUpperBound = + foldVersionRange + False + (const True) + (const False) + (const True) + (&&) + (||) -- | Does the version range have an explicit lower bound? -- @@ -172,9 +189,11 @@ hasUpperBound = foldVersionRange -- -- @since 1.24.0.0 hasLowerBound :: VersionRange -> Bool -hasLowerBound = foldVersionRange - False - (const True) - (const True) - (const False) - (&&) (||) +hasLowerBound = + foldVersionRange + False + (const True) + (const True) + (const False) + (&&) + (||) diff --git a/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs b/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs index 67eede71059..7d7101d8660 100644 --- a/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs +++ b/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs @@ -1,35 +1,37 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- | The only purpose of this module is to prevent the export of -- 'VersionRange' constructors from -- "Distribution.Types.VersionRange". To avoid creating orphan -- instances, a lot of related code had to be moved here too. - module Distribution.Types.VersionRange.Internal - ( VersionRange(..) - , anyVersion, noVersion - , thisVersion, notThisVersion - , laterVersion, earlierVersion - , orLaterVersion, orEarlierVersion - , unionVersionRanges, intersectVersionRanges + ( VersionRange (..) + , anyVersion + , noVersion + , thisVersion + , notThisVersion + , laterVersion + , earlierVersion + , orLaterVersion + , orEarlierVersion + , unionVersionRanges + , intersectVersionRanges , withinVersion , majorBoundVersion - - , VersionRangeF(..) + , VersionRangeF (..) , projectVersionRange , embedVersionRange , cataVersionRange , anaVersionRange , hyloVersionRange , versionRangeParser - , majorUpperBound , wildcardUpperBound ) where @@ -41,22 +43,22 @@ import Prelude () import Distribution.CabalSpecVersion import Distribution.Parsec import Distribution.Pretty -import Distribution.Utils.Generic (unsnoc) +import Distribution.Utils.Generic (unsnoc) import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.Compat.DList as DList -import qualified Text.PrettyPrint as Disp +import qualified Distribution.Compat.DList as DList +import qualified Text.PrettyPrint as Disp data VersionRange - = ThisVersion Version -- = version - | LaterVersion Version -- > version (NB. not >=) - | OrLaterVersion Version -- >= version - | EarlierVersion Version -- < version - | OrEarlierVersion Version -- <= version - | MajorBoundVersion Version -- @^>= ver@ (same as >= ver && < MAJ(ver)+1) - | UnionVersionRanges VersionRange VersionRange + = ThisVersion Version -- = version + | LaterVersion Version -- > version (NB. not >=) + | OrLaterVersion Version -- >= version + | EarlierVersion Version -- < version + | OrEarlierVersion Version -- <= version + | MajorBoundVersion Version -- @^>= ver@ (same as >= ver && < MAJ(ver)+1) + | UnionVersionRanges VersionRange VersionRange | IntersectVersionRanges VersionRange VersionRange - deriving ( Data, Eq, Ord, Generic, Read, Show, Typeable ) + deriving (Data, Eq, Ord, Generic, Read, Show, Typeable) instance Binary VersionRange instance Structured VersionRange @@ -66,7 +68,6 @@ instance NFData VersionRange where rnf = genericRnf -- versions. -- -- > withinRange v anyVersion = True --- anyVersion :: VersionRange anyVersion = OrLaterVersion (mkVersion [0]) @@ -76,49 +77,42 @@ anyVersion = OrLaterVersion (mkVersion [0]) -- for example @< 0@. -- -- > withinRange v noVersion = False --- noVersion :: VersionRange noVersion = EarlierVersion (mkVersion [0]) -- | The version range @== v@. -- -- > withinRange v' (thisVersion v) = v' == v --- thisVersion :: Version -> VersionRange thisVersion = ThisVersion -- | The version range @/= v@. -- -- > withinRange v' (notThisVersion v) = v' /= v --- notThisVersion :: Version -> VersionRange notThisVersion v = UnionVersionRanges (EarlierVersion v) (LaterVersion v) -- | The version range @> v@. -- -- > withinRange v' (laterVersion v) = v' > v --- laterVersion :: Version -> VersionRange laterVersion = LaterVersion -- | The version range @>= v@. -- -- > withinRange v' (orLaterVersion v) = v' >= v --- orLaterVersion :: Version -> VersionRange orLaterVersion = OrLaterVersion -- | The version range @< v@. -- -- > withinRange v' (earlierVersion v) = v' < v --- earlierVersion :: Version -> VersionRange earlierVersion = EarlierVersion -- | The version range @<= v@. -- -- > withinRange v' (orEarlierVersion v) = v' <= v --- orEarlierVersion :: Version -> VersionRange orEarlierVersion = OrEarlierVersion @@ -126,7 +120,6 @@ orEarlierVersion = OrEarlierVersion -- -- > withinRange v' (unionVersionRanges vr1 vr2) -- > = withinRange v' vr1 || withinRange v' vr2 --- unionVersionRanges :: VersionRange -> VersionRange -> VersionRange unionVersionRanges = UnionVersionRanges @@ -134,7 +127,6 @@ unionVersionRanges = UnionVersionRanges -- -- > withinRange v' (intersectVersionRanges vr1 vr2) -- > = withinRange v' vr1 && withinRange v' vr2 --- intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange intersectVersionRanges = IntersectVersionRanges @@ -146,9 +138,9 @@ intersectVersionRanges = IntersectVersionRanges -- > withinRange v' (withinVersion v) = v' >= v && v' < upper v -- > where -- > upper (Version lower t) = Version (init lower ++ [last lower + 1]) t --- withinVersion :: Version -> VersionRange -withinVersion v = intersectVersionRanges +withinVersion v = + intersectVersionRanges (orLaterVersion v) (earlierVersion (wildcardUpperBound v)) @@ -163,33 +155,49 @@ withinVersion v = intersectVersionRanges majorBoundVersion :: Version -> VersionRange majorBoundVersion = MajorBoundVersion - -- | F-Algebra of 'VersionRange'. See 'cataVersionRange'. -- -- @since 2.2 data VersionRangeF a - = ThisVersionF Version -- ^ @== version@. - | LaterVersionF Version -- ^ @> version@. NB: not @>=@ - | OrLaterVersionF Version -- ^ @>= version@. - | EarlierVersionF Version -- ^ @< version@. - | OrEarlierVersionF Version -- ^ @<= version@. - | MajorBoundVersionF Version -- ^ @^>= version@, same as @>= version && < MAJ(version)+1@. - | UnionVersionRangesF a a -- ^ @||@. - | IntersectVersionRangesF a a -- ^ @&&@. - deriving ( Data, Eq, Generic, Read, Show, Typeable - , Functor, Foldable, Traversable ) + = -- | @== version@. + ThisVersionF Version + | -- | @> version@. NB: not @>=@ + LaterVersionF Version + | -- | @>= version@. + OrLaterVersionF Version + | -- | @< version@. + EarlierVersionF Version + | -- | @<= version@. + OrEarlierVersionF Version + | -- | @^>= version@, same as @>= version && < MAJ(version)+1@. + MajorBoundVersionF Version + | -- | @||@. + UnionVersionRangesF a a + | -- | @&&@. + IntersectVersionRangesF a a + deriving + ( Data + , Eq + , Generic + , Read + , Show + , Typeable + , Functor + , Foldable + , Traversable + ) -- | Generic destructor for 'VersionRange'. -- -- @since 2.2 projectVersionRange :: VersionRange -> VersionRangeF VersionRange -projectVersionRange (ThisVersion v) = ThisVersionF v -projectVersionRange (LaterVersion v) = LaterVersionF v -projectVersionRange (OrLaterVersion v) = OrLaterVersionF v -projectVersionRange (EarlierVersion v) = EarlierVersionF v -projectVersionRange (OrEarlierVersion v) = OrEarlierVersionF v -projectVersionRange (MajorBoundVersion v) = MajorBoundVersionF v -projectVersionRange (UnionVersionRanges a b) = UnionVersionRangesF a b +projectVersionRange (ThisVersion v) = ThisVersionF v +projectVersionRange (LaterVersion v) = LaterVersionF v +projectVersionRange (OrLaterVersion v) = OrLaterVersionF v +projectVersionRange (EarlierVersion v) = EarlierVersionF v +projectVersionRange (OrEarlierVersion v) = OrEarlierVersionF v +projectVersionRange (MajorBoundVersion v) = MajorBoundVersionF v +projectVersionRange (UnionVersionRanges a b) = UnionVersionRangesF a b projectVersionRange (IntersectVersionRanges a b) = IntersectVersionRangesF a b -- | Fold 'VersionRange'. @@ -202,13 +210,13 @@ cataVersionRange f = c where c = f . fmap c . projectVersionRange -- -- @since 2.2 embedVersionRange :: VersionRangeF VersionRange -> VersionRange -embedVersionRange (ThisVersionF v) = ThisVersion v -embedVersionRange (LaterVersionF v) = LaterVersion v -embedVersionRange (OrLaterVersionF v) = OrLaterVersion v -embedVersionRange (EarlierVersionF v) = EarlierVersion v -embedVersionRange (OrEarlierVersionF v) = OrEarlierVersion v -embedVersionRange (MajorBoundVersionF v) = MajorBoundVersion v -embedVersionRange (UnionVersionRangesF a b) = UnionVersionRanges a b +embedVersionRange (ThisVersionF v) = ThisVersion v +embedVersionRange (LaterVersionF v) = LaterVersion v +embedVersionRange (OrLaterVersionF v) = OrLaterVersion v +embedVersionRange (EarlierVersionF v) = EarlierVersion v +embedVersionRange (OrEarlierVersionF v) = OrEarlierVersion v +embedVersionRange (MajorBoundVersionF v) = MajorBoundVersion v +embedVersionRange (UnionVersionRangesF a b) = UnionVersionRanges a b embedVersionRange (IntersectVersionRangesF a b) = IntersectVersionRanges a b -- | Unfold 'VersionRange'. @@ -220,9 +228,11 @@ anaVersionRange g = a where a = embedVersionRange . fmap a . g -- | Refold 'VersionRange'. -- -- @since 2.2 -hyloVersionRange :: (VersionRangeF VersionRange -> VersionRange) - -> (VersionRange -> VersionRangeF VersionRange) - -> VersionRange -> VersionRange +hyloVersionRange + :: (VersionRangeF VersionRange -> VersionRange) + -> (VersionRange -> VersionRangeF VersionRange) + -> VersionRange + -> VersionRange hyloVersionRange f g = h where h = f . fmap h . g ------------------------------------------------------------------------------- @@ -242,43 +252,46 @@ hyloVersionRange f g = h where h = f . fmap h . g -- -- >>> fmap (prettyVersioned CabalSpecV1_6) (simpleParsec' CabalSpecV1_6 "-any" :: Maybe VersionRange) -- Just >=0 --- instance Pretty VersionRange where - pretty = prettyVersioned cabalSpecLatest + pretty = prettyVersioned cabalSpecLatest - prettyVersioned csv - | csv > CabalSpecV1_6 = prettyVersionRange - | otherwise = prettyVersionRange16 + prettyVersioned csv + | csv > CabalSpecV1_6 = prettyVersionRange + | otherwise = prettyVersionRange16 prettyVersionRange :: VersionRange -> Disp.Doc prettyVersionRange vr = cataVersionRange alg vr 0 where alg :: VersionRangeF (Int -> Disp.Doc) -> Int -> Disp.Doc - alg (ThisVersionF v) _ = Disp.text "==" <<>> pretty v - alg (LaterVersionF v) _ = Disp.text ">" <<>> pretty v - alg (OrLaterVersionF v) _ = Disp.text ">=" <<>> pretty v - alg (EarlierVersionF v) _ = Disp.text "<" <<>> pretty v - alg (OrEarlierVersionF v) _ = Disp.text "<=" <<>> pretty v - alg (MajorBoundVersionF v) _ = Disp.text "^>=" <<>> pretty v - alg (UnionVersionRangesF r1 r2) d = parens (d > 0) - $ r1 1 <+> Disp.text "||" <+> r2 0 - alg (IntersectVersionRangesF r1 r2) d = parens (d > 1) - $ r1 2 <+> Disp.text "&&" <+> r2 1 - - parens True = Disp.parens + alg (ThisVersionF v) _ = Disp.text "==" <<>> pretty v + alg (LaterVersionF v) _ = Disp.text ">" <<>> pretty v + alg (OrLaterVersionF v) _ = Disp.text ">=" <<>> pretty v + alg (EarlierVersionF v) _ = Disp.text "<" <<>> pretty v + alg (OrEarlierVersionF v) _ = Disp.text "<=" <<>> pretty v + alg (MajorBoundVersionF v) _ = Disp.text "^>=" <<>> pretty v + alg (UnionVersionRangesF r1 r2) d = + parens (d > 0) $ + r1 1 <+> Disp.text "||" <+> r2 0 + alg (IntersectVersionRangesF r1 r2) d = + parens (d > 1) $ + r1 2 <+> Disp.text "&&" <+> r2 1 + + parens True = Disp.parens parens False = id -- | Don't use && and || operators. If possible. prettyVersionRange16 :: VersionRange -> Disp.Doc prettyVersionRange16 (IntersectVersionRanges (OrLaterVersion v) (EarlierVersion u)) - | u == wildcardUpperBound v - = Disp.text "==" <<>> dispWild v + | u == wildcardUpperBound v = + Disp.text "==" <<>> dispWild v where dispWild ver = - Disp.hcat (Disp.punctuate (Disp.char '.') - (map Disp.int $ versionNumbers ver)) + Disp.hcat + ( Disp.punctuate + (Disp.char '.') + (map Disp.int $ versionNumbers ver) + ) <<>> Disp.text ".*" - prettyVersionRange16 vr = prettyVersionRange vr -- | @@ -318,9 +331,8 @@ prettyVersionRange16 vr = prettyVersionRange vr -- -- >>> map (`simpleParsecW'` "== 1.2.*") [CabalSpecV1_4, CabalSpecV1_6] :: [Maybe VersionRange] -- [Nothing,Just (IntersectVersionRanges (OrLaterVersion (mkVersion [1,2])) (EarlierVersion (mkVersion [1,3])))] --- instance Parsec VersionRange where - parsec = askCabalSpecVersion >>= versionRangeParser versionDigitParser + parsec = askCabalSpecVersion >>= versionRangeParser versionDigitParser -- | 'VersionRange' parser parametrised by version digit parser. -- @@ -331,180 +343,197 @@ instance Parsec VersionRange where -- @since 3.0 versionRangeParser :: forall m. CabalParsing m => m Int -> CabalSpecVersion -> m VersionRange versionRangeParser digitParser csv = expr + where + expr = do + P.spaces + t <- term + P.spaces + ( do + _ <- P.string "||" + checkOp + P.spaces + e <- expr + return (unionVersionRanges t e) + <|> return t + ) + term = do + f <- factor + P.spaces + ( do + _ <- P.string "&&" + checkOp + P.spaces + t <- term + return (intersectVersionRanges f t) + <|> return f + ) + factor = parens expr <|> prim + + prim = do + op <- P.munch1 isOpChar P. "operator" + case op of + "-" -> anyVersion <$ P.string "any" <|> P.string "none" *> noVersion' + "==" -> do + P.spaces + ( do + (wild, v) <- verOrWild + checkWild wild + pure $ (if wild then withinVersion else thisVersion) v + <|> (verSet' thisVersion =<< verSet) + ) + "^>=" -> do + P.spaces + ( do + (wild, v) <- verOrWild + when wild $ + P.unexpected $ + "wild-card version after ^>= operator" + majorBoundVersion' v + <|> (verSet' majorBoundVersion =<< verSet) + ) + _ -> do + P.spaces + (wild, v) <- verOrWild + when wild $ + P.unexpected $ + "wild-card version after non-== operator: " ++ show op + case op of + ">=" -> pure $ orLaterVersion v + "<" -> pure $ earlierVersion v + "<=" -> pure $ orEarlierVersion v + ">" -> pure $ laterVersion v + _ -> fail $ "Unknown version operator " ++ show op + + -- Cannot be warning + -- On 2020-03-16 there was around 27400 files on Hackage failing to parse due this + -- For example https://hackage.haskell.org/package/haxr-3000.0.0/haxr.cabal + -- + checkOp = + when (csv < CabalSpecV1_8) $ + parsecWarning PWTVersionOperator $ + unwords + [ "version operators used." + , "To use version operators the package needs to specify at least 'cabal-version: >= 1.8'." + ] + + -- Cannot be warning + -- On 2020-03-16 there was 46 files on Hackage failing to parse due this + -- For example https://hackage.haskell.org/package/derive-0.1.2/derive.cabal + -- + checkWild False = pure () + checkWild True = + when (csv < CabalSpecV1_6) $ + parsecWarning PWTVersionWildcard $ + unwords + [ "Wildcard syntax used." + , "To use version wildcards the package needs to specify at least 'cabal-version: >= 1.6'." + ] + + -- https://gitlab.haskell.org/ghc/ghc/issues/17752 + isOpChar '<' = True + isOpChar '=' = True + isOpChar '>' = True + isOpChar '^' = True + isOpChar '-' = csv < CabalSpecV3_4 + -- https://github.com/haskell/cabal/issues/6589 + -- Unfortunately we have must not consume the dash, + -- as otherwise following parts may not be parsed. + -- + -- i.e. we cannot fail here with good error. + isOpChar _ = False + + -- -none version range is available since 1.22 + noVersion' = + if csv >= CabalSpecV1_22 + then pure noVersion + else + fail $ + unwords + [ "-none version range used." + , "To use this syntax the package needs to specify at least 'cabal-version: 1.22'." + , "Alternatively, if broader compatibility is important then use" + , "<0 or other empty range." + ] + + -- \^>= is available since 2.0 + majorBoundVersion' v = + if csv >= CabalSpecV2_0 + then pure $ majorBoundVersion v + else + fail $ + unwords + [ "major bounded version syntax (caret, ^>=) used." + , "To use this syntax the package need to specify at least 'cabal-version: 2.0'." + , "Alternatively, if broader compatibility is important then use:" + , prettyShow $ eliminateMajorBoundSyntax $ majorBoundVersion v + ] where - expr = do P.spaces - t <- term - P.spaces - (do _ <- P.string "||" - checkOp - P.spaces - e <- expr - return (unionVersionRanges t e) - <|> - return t) - term = do f <- factor - P.spaces - (do _ <- P.string "&&" - checkOp - P.spaces - t <- term - return (intersectVersionRanges f t) - <|> - return f) - factor = parens expr <|> prim - - prim = do - op <- P.munch1 isOpChar P. "operator" - case op of - "-" -> anyVersion <$ P.string "any" <|> P.string "none" *> noVersion' - - "==" -> do - P.spaces - (do (wild, v) <- verOrWild - checkWild wild - pure $ (if wild then withinVersion else thisVersion) v - <|> - (verSet' thisVersion =<< verSet)) - - "^>=" -> do - P.spaces - (do (wild, v) <- verOrWild - when wild $ P.unexpected $ - "wild-card version after ^>= operator" - majorBoundVersion' v - <|> - (verSet' majorBoundVersion =<< verSet)) - - _ -> do - P.spaces - (wild, v) <- verOrWild - when wild $ P.unexpected $ - "wild-card version after non-== operator: " ++ show op - case op of - ">=" -> pure $ orLaterVersion v - "<" -> pure $ earlierVersion v - "<=" -> pure $ orEarlierVersion v - ">" -> pure $ laterVersion v - _ -> fail $ "Unknown version operator " ++ show op - - -- Cannot be warning - -- On 2020-03-16 there was around 27400 files on Hackage failing to parse due this - -- For example https://hackage.haskell.org/package/haxr-3000.0.0/haxr.cabal - -- - checkOp = when (csv < CabalSpecV1_8) $ - parsecWarning PWTVersionOperator $ unwords - [ "version operators used." - , "To use version operators the package needs to specify at least 'cabal-version: >= 1.8'." - ] - - -- Cannot be warning - -- On 2020-03-16 there was 46 files on Hackage failing to parse due this - -- For example https://hackage.haskell.org/package/derive-0.1.2/derive.cabal - -- - checkWild False = pure () - checkWild True = when (csv < CabalSpecV1_6) $ - parsecWarning PWTVersionWildcard $ unwords - [ "Wildcard syntax used." - , "To use version wildcards the package needs to specify at least 'cabal-version: >= 1.6'." - ] - - -- https://gitlab.haskell.org/ghc/ghc/issues/17752 - isOpChar '<' = True - isOpChar '=' = True - isOpChar '>' = True - isOpChar '^' = True - isOpChar '-' = csv < CabalSpecV3_4 - -- https://github.com/haskell/cabal/issues/6589 - -- Unfortunately we have must not consume the dash, - -- as otherwise following parts may not be parsed. - -- - -- i.e. we cannot fail here with good error. - isOpChar _ = False - - -- -none version range is available since 1.22 - noVersion' = - if csv >= CabalSpecV1_22 - then pure noVersion - else fail $ unwords - [ "-none version range used." - , "To use this syntax the package needs to specify at least 'cabal-version: 1.22'." - , "Alternatively, if broader compatibility is important then use" - , "<0 or other empty range." - ] - - -- ^>= is available since 2.0 - majorBoundVersion' v = - if csv >= CabalSpecV2_0 - then pure $ majorBoundVersion v - else fail $ unwords - [ "major bounded version syntax (caret, ^>=) used." - , "To use this syntax the package need to specify at least 'cabal-version: 2.0'." - , "Alternatively, if broader compatibility is important then use:" - , prettyShow $ eliminateMajorBoundSyntax $ majorBoundVersion v - ] - where - eliminateMajorBoundSyntax = hyloVersionRange embed projectVersionRange - embed (MajorBoundVersionF u) = intersectVersionRanges - (orLaterVersion u) (earlierVersion (majorUpperBound u)) - embed vr = embedVersionRange vr - - -- version set notation (e.g. "== { 0.0.1.0, 0.0.2.0, 0.1.0.0 }") - verSet' op vs = - if csv >= CabalSpecV3_0 - then pure $ foldr1 unionVersionRanges (fmap op vs) - else fail $ unwords - [ "version set syntax used." - , "To use this syntax the package needs to specify at least 'cabal-version: 3.0'." - , "Alternatively, if broader compatibility is important then use" - , "a series of single version constraints joined with the || operator:" - , prettyShow (foldr1 unionVersionRanges (fmap op vs)) - ] - - verSet :: CabalParsing m => m (NonEmpty Version) - verSet = do - _ <- P.char '{' - P.spaces - vs <- P.sepByNonEmpty (verPlain <* P.spaces) (P.char ',' *> P.spaces) - _ <- P.char '}' - pure vs - - -- a plain version without tags or wildcards - verPlain :: CabalParsing m => m Version - verPlain = mkVersion <$> toList <$> P.sepByNonEmpty digitParser (P.char '.') - - -- either wildcard or normal version - verOrWild :: CabalParsing m => m (Bool, Version) - verOrWild = do - x <- digitParser - verLoop (DList.singleton x) - - -- trailing: wildcard (.y.*) or normal version (optional tags) (.y.z-tag) - verLoop :: CabalParsing m => DList.DList Int -> m (Bool, Version) - verLoop acc = verLoop' acc - <|> (tags *> pure (False, mkVersion (DList.toList acc))) - - verLoop' :: CabalParsing m => DList.DList Int -> m (Bool, Version) - verLoop' acc = do - _ <- P.char '.' - let digit = digitParser >>= verLoop . DList.snoc acc - let wild = (True, mkVersion (DList.toList acc)) <$ P.char '*' - digit <|> wild - - parens p = P.between - ((P.char '(' P. "opening paren") >> P.spaces) - (P.char ')' >> P.spaces) - $ do - a <- p - P.spaces - return a - - tags :: CabalParsing m => m () - tags = do - ts <- many $ P.char '-' *> some (P.satisfy isAlphaNum) - case ts of - [] -> pure () - (_ : _) -> parsecWarning PWTVersionTag "version with tags" - + eliminateMajorBoundSyntax = hyloVersionRange embed projectVersionRange + embed (MajorBoundVersionF u) = + intersectVersionRanges + (orLaterVersion u) + (earlierVersion (majorUpperBound u)) + embed vr = embedVersionRange vr + + -- version set notation (e.g. "== { 0.0.1.0, 0.0.2.0, 0.1.0.0 }") + verSet' op vs = + if csv >= CabalSpecV3_0 + then pure $ foldr1 unionVersionRanges (fmap op vs) + else + fail $ + unwords + [ "version set syntax used." + , "To use this syntax the package needs to specify at least 'cabal-version: 3.0'." + , "Alternatively, if broader compatibility is important then use" + , "a series of single version constraints joined with the || operator:" + , prettyShow (foldr1 unionVersionRanges (fmap op vs)) + ] + + verSet :: CabalParsing m => m (NonEmpty Version) + verSet = do + _ <- P.char '{' + P.spaces + vs <- P.sepByNonEmpty (verPlain <* P.spaces) (P.char ',' *> P.spaces) + _ <- P.char '}' + pure vs + + -- a plain version without tags or wildcards + verPlain :: CabalParsing m => m Version + verPlain = mkVersion <$> toList <$> P.sepByNonEmpty digitParser (P.char '.') + + -- either wildcard or normal version + verOrWild :: CabalParsing m => m (Bool, Version) + verOrWild = do + x <- digitParser + verLoop (DList.singleton x) + + -- trailing: wildcard (.y.*) or normal version (optional tags) (.y.z-tag) + verLoop :: CabalParsing m => DList.DList Int -> m (Bool, Version) + verLoop acc = + verLoop' acc + <|> (tags *> pure (False, mkVersion (DList.toList acc))) + + verLoop' :: CabalParsing m => DList.DList Int -> m (Bool, Version) + verLoop' acc = do + _ <- P.char '.' + let digit = digitParser >>= verLoop . DList.snoc acc + let wild = (True, mkVersion (DList.toList acc)) <$ P.char '*' + digit <|> wild + + parens p = P.between + ((P.char '(' P. "opening paren") >> P.spaces) + (P.char ')' >> P.spaces) + $ do + a <- p + P.spaces + return a + + tags :: CabalParsing m => m () + tags = do + ts <- many $ P.char '-' *> some (P.satisfy isAlphaNum) + case ts of + [] -> pure () + (_ : _) -> parsecWarning PWTVersionTag "version with tags" ---------------------------- -- Wildcard range utilities @@ -518,9 +547,9 @@ versionRangeParser digitParser csv = expr -- @since 2.2 majorUpperBound :: Version -> Version majorUpperBound = alterVersion $ \numbers -> case numbers of - [] -> [0,1] -- should not happen - [m1] -> [m1,1] -- e.g. version '1' - (m1:m2:_) -> [m1,m2+1] + [] -> [0, 1] -- should not happen + [m1] -> [m1, 1] -- e.g. version '1' + (m1 : m2 : _) -> [m1, m2 + 1] -- | Increment the last version number. -- @@ -531,6 +560,6 @@ majorUpperBound = alterVersion $ \numbers -> case numbers of -- @since 2.2 wildcardUpperBound :: Version -> Version wildcardUpperBound = alterVersion $ - \lowerBound -> case unsnoc lowerBound of - Nothing -> [] - Just (xs, x) -> xs ++ [x + 1] + \lowerBound -> case unsnoc lowerBound of + Nothing -> [] + Just (xs, x) -> xs ++ [x + 1] diff --git a/Cabal-syntax/src/Distribution/Utils/Base62.hs b/Cabal-syntax/src/Distribution/Utils/Base62.hs index ad3bc10fea8..757528e750f 100644 --- a/Cabal-syntax/src/Distribution/Utils/Base62.hs +++ b/Cabal-syntax/src/Distribution/Utils/Base62.hs @@ -1,11 +1,10 @@ - -- | Implementation of base-62 encoding, which we use when computing hashes -- for fully instantiated unit ids. module Distribution.Utils.Base62 (hashToBase62) where -import GHC.Fingerprint ( Fingerprint(..), fingerprintString ) -import Numeric ( showIntAtBase ) -import Data.Char ( chr ) +import Data.Char (chr) +import GHC.Fingerprint (Fingerprint (..), fingerprintString) +import Numeric (showIntAtBase) -- | Hash a string using GHC's fingerprinting algorithm (a 128-bit -- MD5 hash) and then encode the resulting hash in base 62. @@ -14,9 +13,8 @@ hashToBase62 s = showFingerprint $ fingerprintString s where showIntAtBase62 x = showIntAtBase 62 representBase62 x "" representBase62 x - | x < 10 = chr (48 + x) - | x < 36 = chr (65 + x - 10) - | x < 62 = chr (97 + x - 36) - | otherwise = '@' + | x < 10 = chr (48 + x) + | x < 36 = chr (65 + x - 10) + | x < 62 = chr (97 + x - 36) + | otherwise = '@' showFingerprint (Fingerprint a b) = showIntAtBase62 a ++ showIntAtBase62 b - diff --git a/Cabal-syntax/src/Distribution/Utils/Generic.hs b/Cabal-syntax/src/Distribution/Utils/Generic.hs index 5a3e750a397..997e0132f5a 100644 --- a/Cabal-syntax/src/Distribution/Utils/Generic.hs +++ b/Cabal-syntax/src/Distribution/Utils/Generic.hs @@ -1,11 +1,12 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Utils.Generic -- Copyright : Isaac Jones, Simon Marlow 2003-2004 @@ -20,122 +21,132 @@ -- lib like @cabal-install@. It has a very simple set of logging actions. It -- has low level functions for running programs, a bunch of wrappers for -- various directory and file functions that do extra logging. - -module Distribution.Utils.Generic ( - -- * reading and writing files safely - withFileContents, - writeFileAtomic, - - -- * Unicode - - -- ** Conversions - fromUTF8BS, - fromUTF8LBS, - - toUTF8BS, - toUTF8LBS, - - validateUTF8, - - -- ** File I/O - readUTF8File, - withUTF8FileContents, - writeUTF8File, - - -- ** BOM - ignoreBOM, - - -- ** Misc - normaliseLineEndings, - - -- * generic utils - dropWhileEndLE, - takeWhileEndLE, - equating, - comparing, - isInfixOf, - intercalate, - lowercase, - isAscii, - isAsciiAlpha, - isAsciiAlphaNum, - listUnion, - listUnionRight, - ordNub, - ordNubBy, - ordNubRight, - safeHead, - safeTail, - safeLast, - safeInit, - unintersperse, - wrapText, - wrapLine, - unfoldrM, - spanMaybe, - breakMaybe, - unsnoc, - unsnocNE, - - -- * Triples - fstOf3, - sndOf3, - trdOf3, - - -- * FilePath stuff - isAbsoluteOnAnyPlatform, - isRelativeOnAnyPlatform, +module Distribution.Utils.Generic + ( -- * reading and writing files safely + withFileContents + , writeFileAtomic + + -- * Unicode + + -- ** Conversions + , fromUTF8BS + , fromUTF8LBS + , toUTF8BS + , toUTF8LBS + , validateUTF8 + + -- ** File I/O + , readUTF8File + , withUTF8FileContents + , writeUTF8File + + -- ** BOM + , ignoreBOM + + -- ** Misc + , normaliseLineEndings + + -- * generic utils + , dropWhileEndLE + , takeWhileEndLE + , equating + , comparing + , isInfixOf + , intercalate + , lowercase + , isAscii + , isAsciiAlpha + , isAsciiAlphaNum + , listUnion + , listUnionRight + , ordNub + , ordNubBy + , ordNubRight + , safeHead + , safeTail + , safeLast + , safeInit + , unintersperse + , wrapText + , wrapLine + , unfoldrM + , spanMaybe + , breakMaybe + , unsnoc + , unsnocNE + + -- * Triples + , fstOf3 + , sndOf3 + , trdOf3 + + -- * FilePath stuff + , isAbsoluteOnAnyPlatform + , isRelativeOnAnyPlatform ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Utils.String -import Data.Bits ((.&.), (.|.), shiftL) -import Data.List - ( isInfixOf ) -import qualified Data.Set as Set +import Data.Bits (shiftL, (.&.), (.|.)) import qualified Data.ByteString as SBS import qualified Data.ByteString.Lazy as LBS +import Data.List + ( isInfixOf + ) +import qualified Data.Set as Set +import qualified Control.Exception as Exception import System.Directory - ( removeFile, renameFile ) + ( removeFile + , renameFile + ) import System.FilePath - ( (<.>), splitFileName ) + ( splitFileName + , (<.>) + ) import System.IO - ( withFile, withBinaryFile - , openBinaryTempFileWithDefaultPermissions - , IOMode(ReadMode), hGetContents, hClose ) -import qualified Control.Exception as Exception + ( IOMode (ReadMode) + , hClose + , hGetContents + , openBinaryTempFileWithDefaultPermissions + , withBinaryFile + , withFile + ) -- ----------------------------------------------------------------------------- -- Helper functions -- | Wraps text to the default line width. Existing newlines are preserved. wrapText :: String -> String -wrapText = unlines - . map (intercalate "\n" - . map unwords - . wrapLine 79 - . words) - . lines +wrapText = + unlines + . map + ( intercalate "\n" + . map unwords + . wrapLine 79 + . words + ) + . lines -- | Wraps a list of words to a list of lines of words of a particular width. wrapLine :: Int -> [String] -> [[String]] wrapLine width = wrap 0 [] - where wrap :: Int -> [String] -> [String] -> [[String]] - wrap 0 [] (w:ws) - | length w + 1 > width - = wrap (length w) [w] ws - wrap col line (w:ws) - | col + length w + 1 > width - = reverse line : wrap 0 [] (w:ws) - wrap col line (w:ws) - = let col' = col + length w + 1 - in wrap col' (w:line) ws - wrap _ [] [] = [] - wrap _ line [] = [reverse line] + where + wrap :: Int -> [String] -> [String] -> [[String]] + wrap 0 [] (w : ws) + | length w + 1 > width = + wrap (length w) [w] ws + wrap col line (w : ws) + | col + length w + 1 > width = + reverse line : wrap 0 [] (w : ws) + wrap col line (w : ws) = + let col' = col + length w + 1 + in wrap col' (w : line) ws + wrap _ [] [] = [] + wrap _ line [] = [reverse line] ----------------------------------- -- Safely reading and writing files @@ -144,11 +155,12 @@ wrapLine width = wrap 0 [] -- -- The file is read lazily but if it is not fully consumed by the action then -- the remaining input is truncated and the file is closed. --- withFileContents :: FilePath -> (String -> IO a) -> IO a withFileContents name action = - withFile name ReadMode - (\hnd -> hGetContents hnd >>= action) + withFile + name + ReadMode + (\hnd -> hGetContents hnd >>= action) -- | Writes a file atomically. -- @@ -157,32 +169,32 @@ withFileContents name action = -- -- On windows it is not possible to delete a file that is open by a process. -- This case will give an IO exception but the atomic property is not affected. --- writeFileAtomic :: FilePath -> LBS.ByteString -> IO () writeFileAtomic targetPath content = do let (targetDir, targetFile) = splitFileName targetPath Exception.bracketOnError (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp") (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath) - (\(tmpPath, handle) -> do + ( \(tmpPath, handle) -> do LBS.hPut handle content hClose handle - renameFile tmpPath targetPath) + renameFile tmpPath targetPath + ) -- ------------------------------------------------------------ + -- * Unicode stuff + -- ------------------------------------------------------------ -- | Decode 'String' from UTF8-encoded 'BS.ByteString' -- -- Invalid data in the UTF8 stream (this includes code-points @U+D800@ -- through @U+DFFF@) will be decoded as the replacement character (@U+FFFD@). --- fromUTF8BS :: SBS.ByteString -> String fromUTF8BS = decodeStringUtf8 . SBS.unpack -- | Variant of 'fromUTF8BS' for lazy 'BS.ByteString's --- fromUTF8LBS :: LBS.ByteString -> String fromUTF8LBS = decodeStringUtf8 . LBS.unpack @@ -190,93 +202,92 @@ fromUTF8LBS = decodeStringUtf8 . LBS.unpack -- -- Code-points in the @U+D800@-@U+DFFF@ range will be encoded -- as the replacement character (i.e. @U+FFFD@). --- toUTF8BS :: String -> SBS.ByteString toUTF8BS = SBS.pack . encodeStringUtf8 -- | Variant of 'toUTF8BS' for lazy 'BS.ByteString's --- toUTF8LBS :: String -> LBS.ByteString toUTF8LBS = LBS.pack . encodeStringUtf8 -- | Check that strict 'ByteString' is valid UTF8. Returns 'Just offset' if it's not. validateUTF8 :: SBS.ByteString -> Maybe Int -validateUTF8 = go 0 where +validateUTF8 = go 0 + where go off bs = case SBS.uncons bs of - Nothing -> Nothing - Just (c, bs') - | c <= 0x7F -> go (off + 1) bs' - | c <= 0xBF -> Just off - | c <= 0xDF -> twoBytes off c bs' - | c <= 0xEF -> moreBytes off 3 0x800 bs' (fromIntegral $ c .&. 0xF) - | c <= 0xF7 -> moreBytes off 4 0x10000 bs' (fromIntegral $ c .&. 0x7) - | c <= 0xFB -> moreBytes off 5 0x200000 bs' (fromIntegral $ c .&. 0x3) - | c <= 0xFD -> moreBytes off 6 0x4000000 bs' (fromIntegral $ c .&. 0x1) - | otherwise -> Just off + Nothing -> Nothing + Just (c, bs') + | c <= 0x7F -> go (off + 1) bs' + | c <= 0xBF -> Just off + | c <= 0xDF -> twoBytes off c bs' + | c <= 0xEF -> moreBytes off 3 0x800 bs' (fromIntegral $ c .&. 0xF) + | c <= 0xF7 -> moreBytes off 4 0x10000 bs' (fromIntegral $ c .&. 0x7) + | c <= 0xFB -> moreBytes off 5 0x200000 bs' (fromIntegral $ c .&. 0x3) + | c <= 0xFD -> moreBytes off 6 0x4000000 bs' (fromIntegral $ c .&. 0x1) + | otherwise -> Just off twoBytes off c0 bs = case SBS.uncons bs of - Nothing -> Just off - Just (c1, bs') - | c1 .&. 0xC0 == 0x80 -> - if d >= (0x80 :: Int) - then go (off + 2) bs' - else Just off - | otherwise -> Just off - where - d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) .|. fromIntegral (c1 .&. 0x3F) + Nothing -> Just off + Just (c1, bs') + | c1 .&. 0xC0 == 0x80 -> + if d >= (0x80 :: Int) + then go (off + 2) bs' + else Just off + | otherwise -> Just off + where + d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) .|. fromIntegral (c1 .&. 0x3F) moreBytes :: Int -> Int -> Int -> SBS.ByteString -> Int -> Maybe Int moreBytes off 1 overlong cs' acc - | overlong <= acc, acc <= 0x10FFFF, acc < 0xD800 || 0xDFFF < acc - = go (off + 1) cs' - - | otherwise - = Just off - + | overlong <= acc + , acc <= 0x10FFFF + , acc < 0xD800 || 0xDFFF < acc = + go (off + 1) cs' + | otherwise = + Just off moreBytes off byteCount overlong bs acc = case SBS.uncons bs of - Just (cn, bs') | cn .&. 0xC0 == 0x80 -> - moreBytes (off + 1) (byteCount-1) overlong bs' ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F) - _ -> Just off - + Just (cn, bs') + | cn .&. 0xC0 == 0x80 -> + moreBytes (off + 1) (byteCount - 1) overlong bs' ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F) + _ -> Just off -- | Ignore a Unicode byte order mark (BOM) at the beginning of the input --- ignoreBOM :: String -> String -ignoreBOM ('\xFEFF':string) = string -ignoreBOM string = string +ignoreBOM ('\xFEFF' : string) = string +ignoreBOM string = string -- | Reads a UTF8 encoded text file as a Unicode String -- -- Reads lazily using ordinary 'readFile'. --- readUTF8File :: FilePath -> IO String readUTF8File f = (ignoreBOM . fromUTF8LBS) <$> LBS.readFile f -- | Reads a UTF8 encoded text file as a Unicode String -- -- Same behaviour as 'withFileContents'. --- withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a withUTF8FileContents name action = - withBinaryFile name ReadMode + withBinaryFile + name + ReadMode (\hnd -> LBS.hGetContents hnd >>= action . ignoreBOM . fromUTF8LBS) -- | Writes a Unicode String as a UTF8 encoded text file. -- -- Uses 'writeFileAtomic', so provides the same guarantees. --- writeUTF8File :: FilePath -> String -> IO () writeUTF8File path = writeFileAtomic path . toUTF8LBS -- | Fix different systems silly line ending conventions normaliseLineEndings :: String -> String normaliseLineEndings [] = [] -normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows -normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old OS X -normaliseLineEndings ( c :s) = c : normaliseLineEndings s +normaliseLineEndings ('\r' : '\n' : s) = '\n' : normaliseLineEndings s -- windows +normaliseLineEndings ('\r' : s) = '\n' : normaliseLineEndings s -- old OS X +normaliseLineEndings (c : s) = c : normaliseLineEndings s -- ------------------------------------------------------------ + -- * Common utils + -- ------------------------------------------------------------ -- | @dropWhileEndLE p@ is equivalent to @reverse . dropWhile p . reverse@, but @@ -300,9 +311,8 @@ normaliseLineEndings ( c :s) = c : normaliseLineEndings s -- >>> take 3 $ dropWhileEndLE (<3) [5, 4, 3, 2, 1, undefined] -- *** Exception: Prelude.undefined -- ... --- dropWhileEndLE :: (a -> Bool) -> [a] -> [a] -dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) [] +dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x : r) [] -- | @takeWhileEndLE p@ is equivalent to @reverse . takeWhile p . reverse@, but -- is usually faster (as well as being easier to read). @@ -310,7 +320,7 @@ takeWhileEndLE :: (a -> Bool) -> [a] -> [a] takeWhileEndLE p = fst . foldr go ([], False) where go x (rest, done) - | not done && p x = (x:rest, False) + | not done && p x = (x : rest, False) | otherwise = (rest, True) -- | Like 'Data.List.nub', but has @O(n log n)@ complexity instead of @@ -325,16 +335,17 @@ ordNubBy :: Ord b => (a -> b) -> [a] -> [a] ordNubBy f l = go Set.empty l where go !_ [] = [] - go !s (x:xs) + go !s (x : xs) | y `Set.member` s = go s xs - | otherwise = let !s' = Set.insert y s - in x : go s' xs + | otherwise = + let !s' = Set.insert y s + in x : go s' xs where y = f x -- | Like "Data.List.union", but has @O(n log n)@ complexity instead of -- @O(n^2)@. -listUnion :: (Ord a) => [a] -> [a] -> [a] +listUnion :: Ord a => [a] -> [a] -> [a] listUnion a b = a ++ ordNub (filter (`Set.notMember` aSet) b) where aSet = Set.fromList a @@ -348,12 +359,13 @@ listUnion a b = a ++ ordNub (filter (`Set.notMember` aSet) b) -- -- >>> ordNubRight [1,2,1] :: [Int] -- [2,1] --- -ordNubRight :: (Ord a) => [a] -> [a] +ordNubRight :: Ord a => [a] -> [a] ordNubRight = fst . foldr go ([], Set.empty) where - go x p@(l, s) = if x `Set.member` s then p - else (x:l, Set.insert x s) + go x p@(l, s) = + if x `Set.member` s + then p + else (x : l, Set.insert x s) -- | A right-biased version of 'listUnion'. -- @@ -364,8 +376,7 @@ ordNubRight = fst . foldr go ([], Set.empty) -- -- >>> listUnionRight [1,2,3,4,3] [2,1,1] -- [4,3,2,1,1] --- -listUnionRight :: (Ord a) => [a] -> [a] -> [a] +listUnionRight :: Ord a => [a] -> [a] -> [a] listUnionRight a b = ordNubRight (filter (`Set.notMember` bSet) a) ++ b where bSet = Set.fromList b @@ -374,30 +385,30 @@ listUnionRight a b = ordNubRight (filter (`Set.notMember` bSet) a) ++ b -- -- @since 3.2.0.0 safeHead :: [a] -> Maybe a -safeHead [] = Nothing -safeHead (x:_) = Just x +safeHead [] = Nothing +safeHead (x : _) = Just x -- | A total variant of 'tail'. -- -- @since 3.2.0.0 safeTail :: [a] -> [a] -safeTail [] = [] -safeTail (_:xs) = xs +safeTail [] = [] +safeTail (_ : xs) = xs -- | A total variant of 'last'. -- -- @since 3.2.0.0 safeLast :: [a] -> Maybe a -safeLast [] = Nothing -safeLast (x:xs) = Just (foldl (\_ a -> a) x xs) +safeLast [] = Nothing +safeLast (x : xs) = Just (foldl (\_ a -> a) x xs) -- | A total variant of 'init'. -- -- @since 3.2.0.0 safeInit :: [a] -> [a] -safeInit [] = [] -safeInit [_] = [] -safeInit (x:xs) = x : safeInit xs +safeInit [] = [] +safeInit [_] = [] +safeInit (x : xs) = x : safeInit xs equating :: Eq a => (b -> a) -> b -> b -> Bool equating p x y = p x == p y @@ -415,7 +426,8 @@ isAscii c = fromEnum c < 0x80 -- | Ascii letters. isAsciiAlpha :: Char -> Bool -isAsciiAlpha c = ('a' <= c && c <= 'z') +isAsciiAlpha c = + ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') -- | Ascii letters and digits. @@ -425,17 +437,17 @@ isAsciiAlpha c = ('a' <= c && c <= 'z') -- -- >>> isAsciiAlphaNum 'ä' -- False --- isAsciiAlphaNum :: Char -> Bool isAsciiAlphaNum c = isAscii c && isAlphaNum c unintersperse :: Char -> String -> [String] -unintersperse mark = unfoldr unintersperse1 where - unintersperse1 str - | null str = Nothing - | otherwise = - let (this, rest) = break (== mark) str in - Just (this, safeTail rest) +unintersperse mark = unfoldr unintersperse1 + where + unintersperse1 str + | null str = Nothing + | otherwise = + let (this, rest) = break (== mark) str + in Just (this, safeTail rest) -- | Like 'break', but with 'Maybe' predicate -- @@ -446,13 +458,13 @@ unintersperse mark = unfoldr unintersperse1 where -- (["foo","bar"],Nothing) -- -- @since 2.2 --- breakMaybe :: (a -> Maybe b) -> [a] -> ([a], Maybe (b, [a])) -breakMaybe f = go id where - go !acc [] = (acc [], Nothing) - go !acc (x:xs) = case f x of - Nothing -> go (acc . (x:)) xs - Just b -> (acc [], Just (b, xs)) +breakMaybe f = go id + where + go !acc [] = (acc [], Nothing) + go !acc (x : xs) = case f x of + Nothing -> go (acc . (x :)) xs + Just b -> (acc [], Just (b, xs)) -- | Like 'span' but with 'Maybe' predicate -- @@ -463,12 +475,11 @@ breakMaybe f = go id where -- ([1,2],["foo"]) -- -- @since 2.2 --- -spanMaybe :: (a -> Maybe b) -> [a] -> ([b],[a]) -spanMaybe _ xs@[] = ([], xs) -spanMaybe p xs@(x:xs') = case p x of - Just y -> let (ys, zs) = spanMaybe p xs' in (y : ys, zs) - Nothing -> ([], xs) +spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) +spanMaybe _ xs@[] = ([], xs) +spanMaybe p xs@(x : xs') = case p x of + Just y -> let (ys, zs) = spanMaybe p xs' in (y : ys, zs) + Nothing -> ([], xs) -- | 'unfoldr' with monadic action. -- @@ -476,14 +487,14 @@ spanMaybe p xs@(x:xs') = case p x of -- [3,4,5,6,7] -- -- @since 2.2 --- unfoldrM :: Monad m => (b -> m (Maybe (a, b))) -> b -> m [a] -unfoldrM f = go where +unfoldrM f = go + where go b = do - m <- f b - case m of - Nothing -> return [] - Just (a, b') -> liftM (a :) (go b') + m <- f b + case m of + Nothing -> return [] + Just (a, b') -> liftM (a :) (go b') -- | The opposite of 'snoc', which is the reverse of 'cons' -- @@ -496,10 +507,9 @@ unfoldrM f = go where -- Nothing -- -- @since 3.2.0.0 --- unsnoc :: [a] -> Maybe ([a], a) -unsnoc [] = Nothing -unsnoc (x:xs) = Just (unsnocNE (x :| xs)) +unsnoc [] = Nothing +unsnoc (x : xs) = Just (unsnocNE (x :| xs)) -- | Like 'unsnoc', but for 'NonEmpty' so without the 'Maybe' -- @@ -512,30 +522,32 @@ unsnoc (x:xs) = Just (unsnocNE (x :| xs)) -- ([],1) -- -- @since 3.2.0.0 --- unsnocNE :: NonEmpty a -> ([a], a) -unsnocNE (x:|xs) = go x xs where - go y [] = ([], y) - go y (z:zs) = let ~(ws, w) = go z zs in (y : ws, w) +unsnocNE (x :| xs) = go x xs + where + go y [] = ([], y) + go y (z : zs) = let ~(ws, w) = go z zs in (y : ws, w) ------------------------------------------------------------------------------- -- Triples ------------------------------------------------------------------------------- -- | @since 3.4.0.0 -fstOf3 :: (a,b,c) -> a -fstOf3 (a,_,_) = a +fstOf3 :: (a, b, c) -> a +fstOf3 (a, _, _) = a -- | @since 3.4.0.0 -sndOf3 :: (a,b,c) -> b -sndOf3 (_,b,_) = b +sndOf3 :: (a, b, c) -> b +sndOf3 (_, b, _) = b -- | @since 3.4.0.0 -trdOf3 :: (a,b,c) -> c -trdOf3 (_,_,c) = c +trdOf3 :: (a, b, c) -> c +trdOf3 (_, _, c) = c -- ------------------------------------------------------------ + -- * FilePath stuff + -- ------------------------------------------------------------ -- | 'isAbsoluteOnAnyPlatform' and 'isRelativeOnAnyPlatform' are like @@ -559,12 +571,12 @@ trdOf3 (_,_,c) = c -- the platform independent heuristics. isAbsoluteOnAnyPlatform :: FilePath -> Bool -- C:\\directory -isAbsoluteOnAnyPlatform (drive:':':'\\':_) = isAlpha drive -isAbsoluteOnAnyPlatform (drive:':':'/':_) = isAlpha drive +isAbsoluteOnAnyPlatform (drive : ':' : '\\' : _) = isAlpha drive +isAbsoluteOnAnyPlatform (drive : ':' : '/' : _) = isAlpha drive -- UNC -isAbsoluteOnAnyPlatform ('\\':'\\':_) = True +isAbsoluteOnAnyPlatform ('\\' : '\\' : _) = True -- Posix root -isAbsoluteOnAnyPlatform ('/':_) = True +isAbsoluteOnAnyPlatform ('/' : _) = True isAbsoluteOnAnyPlatform _ = False -- | @isRelativeOnAnyPlatform = not . 'isAbsoluteOnAnyPlatform'@ diff --git a/Cabal-syntax/src/Distribution/Utils/MD5.hs b/Cabal-syntax/src/Distribution/Utils/MD5.hs index 323fbc05023..f42f9103754 100644 --- a/Cabal-syntax/src/Distribution/Utils/MD5.hs +++ b/Cabal-syntax/src/Distribution/Utils/MD5.hs @@ -1,24 +1,26 @@ -module Distribution.Utils.MD5 ( - MD5, - showMD5, - md5, +module Distribution.Utils.MD5 + ( MD5 + , showMD5 + , md5 + -- * Helpers - md5FromInteger, + , md5FromInteger + -- * Binary - binaryPutMD5, - binaryGetMD5, - ) where + , binaryPutMD5 + , binaryGetMD5 + ) where -import Data.Binary (Get, Put) -import Data.Binary.Get (getWord64le) -import Data.Binary.Put (putWord64le) -import Data.Bits (complement, shiftR, (.&.)) -import Foreign.Ptr (castPtr) -import GHC.Fingerprint (Fingerprint (..), fingerprintData) -import Numeric (showHex) +import Data.Binary (Get, Put) +import Data.Binary.Get (getWord64le) +import Data.Binary.Put (putWord64le) +import Data.Bits (complement, shiftR, (.&.)) +import Foreign.Ptr (castPtr) +import GHC.Fingerprint (Fingerprint (..), fingerprintData) +import Numeric (showHex) import System.IO.Unsafe (unsafeDupablePerformIO) -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS type MD5 = Fingerprint @@ -33,7 +35,8 @@ type MD5 = Fingerprint -- -- @since 3.2.0.0 showMD5 :: MD5 -> String -showMD5 (Fingerprint a b) = pad a' ++ pad b' where +showMD5 (Fingerprint a b) = pad a' ++ pad b' + where a' = showHex a "" b' = showHex b "" pad s = replicate (16 - length s) '0' ++ s @@ -41,20 +44,20 @@ showMD5 (Fingerprint a b) = pad a' ++ pad b' where -- | @since 3.2.0.0 md5 :: BS.ByteString -> MD5 md5 bs = unsafeDupablePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> - fingerprintData (castPtr ptr) len + fingerprintData (castPtr ptr) len -- | @since 3.2.0.0 binaryPutMD5 :: MD5 -> Put binaryPutMD5 (Fingerprint a b) = do - putWord64le a - putWord64le b + putWord64le a + putWord64le b -- | @since 3.2.0.0 binaryGetMD5 :: Get MD5 binaryGetMD5 = do - a <- getWord64le - b <- getWord64le - return (Fingerprint a b) + a <- getWord64le + b <- getWord64le + return (Fingerprint a b) -- | -- @@ -73,7 +76,8 @@ binaryGetMD5 = do -- -- @since 3.4.0.0 md5FromInteger :: Integer -> MD5 -md5FromInteger i = Fingerprint hi lo where +md5FromInteger i = Fingerprint hi lo + where mask = complement 0 - lo = mask .&. fromInteger i - hi = mask .&. fromInteger (i `shiftR` 64) + lo = mask .&. fromInteger i + hi = mask .&. fromInteger (i `shiftR` 64) diff --git a/Cabal-syntax/src/Distribution/Utils/Path.hs b/Cabal-syntax/src/Distribution/Utils/Path.hs index eb3d11deb96..9da89bdd7f3 100644 --- a/Cabal-syntax/src/Distribution/Utils/Path.hs +++ b/Cabal-syntax/src/Distribution/Utils/Path.hs @@ -1,31 +1,36 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StandaloneDeriving #-} -module Distribution.Utils.Path ( - -- * Symbolic path - SymbolicPath, - getSymbolicPath, - sameDirectory, - unsafeMakeSymbolicPath, + +module Distribution.Utils.Path + ( -- * Symbolic path + SymbolicPath + , getSymbolicPath + , sameDirectory + , unsafeMakeSymbolicPath + -- * Path ends - PackageDir, - SourceDir, - LicenseFile, - IsDir, -) where + , PackageDir + , SourceDir + , LicenseFile + , IsDir + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Parsec import Distribution.Pretty import Distribution.Utils.Generic (isAbsoluteOnAnyPlatform) import qualified Distribution.Compat.CharParsing as P + -- import qualified Text.PrettyPrint as Disp ------------------------------------------------------------------------------- + -- * SymbolicPath + ------------------------------------------------------------------------------- -- | Symbolic paths. @@ -33,7 +38,6 @@ import qualified Distribution.Compat.CharParsing as P -- These paths are system independent and relative. -- They are *symbolic* which means we cannot perform any 'IO' -- until we interpret them. --- newtype SymbolicPath from to = SymbolicPath FilePath deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) @@ -44,7 +48,6 @@ instance NFData (SymbolicPath from to) where rnf = genericRnf -- | Extract underlying 'FilePath'. -- -- Avoid using this in new code. --- getSymbolicPath :: SymbolicPath from to -> FilePath getSymbolicPath (SymbolicPath p) = p @@ -56,21 +59,28 @@ unsafeMakeSymbolicPath :: FilePath -> SymbolicPath from to unsafeMakeSymbolicPath = SymbolicPath ------------------------------------------------------------------------------- + -- ** Parsing and pretty printing + ------------------------------------------------------------------------------- instance Parsec (SymbolicPath from to) where - parsec = do - token <- parsecToken - if null token then P.unexpected "empty FilePath" - else if isAbsoluteOnAnyPlatform token then P.unexpected "absolute FilePath" - else return (SymbolicPath token) -- TODO: normalise + parsec = do + token <- parsecToken + if null token + then P.unexpected "empty FilePath" + else + if isAbsoluteOnAnyPlatform token + then P.unexpected "absolute FilePath" + else return (SymbolicPath token) -- TODO: normalise instance Pretty (SymbolicPath from to) where - pretty = showFilePath . getSymbolicPath + pretty = showFilePath . getSymbolicPath ------------------------------------------------------------------------------- + -- * Composition + ------------------------------------------------------------------------------- -- TODO @@ -83,14 +93,16 @@ instance Pretty (SymbolicPath from to) where -- () :: path a b -> path b c -> path a c ------------------------------------------------------------------------------- + -- * Path ends + ------------------------------------------------------------------------------- -- | Class telling that index is for directories. class IsDir dir data PackageDir deriving (Typeable) -data SourceDir deriving (Typeable) +data SourceDir deriving (Typeable) data LicenseFile deriving (Typeable) diff --git a/Cabal-syntax/src/Distribution/Utils/ShortText.hs b/Cabal-syntax/src/Distribution/Utils/ShortText.hs index 8279b4af6fe..0b128de9698 100644 --- a/Cabal-syntax/src/Distribution/Utils/ShortText.hs +++ b/Cabal-syntax/src/Distribution/Utils/ShortText.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} -- | Compact representation of short 'Strings' -- @@ -11,25 +11,25 @@ -- import qualified Distribution.Utils.ShortText as ShortText -- @ module Distribution.Utils.ShortText - ( -- * 'ShortText' type - ShortText - , toShortText - , fromShortText - , unsafeFromUTF8BS + ( -- * 'ShortText' type + ShortText + , toShortText + , fromShortText + , unsafeFromUTF8BS - -- * Operations - , null - , length + -- * Operations + , null + , length - -- * internal utilities - , decodeStringUtf8 - , encodeStringUtf8 - ) where + -- * internal utilities + , decodeStringUtf8 + , encodeStringUtf8 + ) where import Distribution.Compat.Prelude hiding (length, null) import Prelude () -import Distribution.Utils.String (decodeStringUtf8, encodeStringUtf8) +import Distribution.Utils.String (decodeStringUtf8, encodeStringUtf8) import Distribution.Utils.Structured (Structured (..), nominalStructure) #if defined(MIN_VERSION_bytestring) @@ -56,7 +56,7 @@ import Distribution.Utils.Structured (Structured (..), nominalStructure) #endif import qualified Data.ByteString as BS -import qualified Data.List as List +import qualified Data.List as List #if HAVE_SHORTBYTESTRING import qualified Data.ByteString.Short as BS.Short @@ -133,27 +133,28 @@ null = List.null . unST instance Structured ShortText where structure = nominalStructure instance NFData ShortText where - rnf = rnf . unST + rnf = rnf . unST instance Show ShortText where - show = show . fromShortText + show = show . fromShortText instance Read ShortText where - readsPrec p = map (first toShortText) . readsPrec p + readsPrec p = map (first toShortText) . readsPrec p instance Semigroup ShortText where - ST a <> ST b = ST (mappend a b) + ST a <> ST b = ST (mappend a b) instance Monoid ShortText where - mempty = ST mempty - mappend = (<>) + mempty = ST mempty + mappend = (<>) instance IsString ShortText where - fromString = toShortText + fromString = toShortText -- | /O(n)/. Length in characters. /Slow/ as converts to string. -- -- @since 3.2.0.0 length :: ShortText -> Int length = List.length . fromShortText + -- Note: avoid using it, we use it @cabal check@ implementation, where it's ok. diff --git a/Cabal-syntax/src/Distribution/Utils/String.hs b/Cabal-syntax/src/Distribution/Utils/String.hs index a1cf4633ae9..13b022f812c 100644 --- a/Cabal-syntax/src/Distribution/Utils/String.hs +++ b/Cabal-syntax/src/Distribution/Utils/String.hs @@ -1,14 +1,14 @@ module Distribution.Utils.String - ( -- * Encode to/from UTF8 - decodeStringUtf8 - , encodeStringUtf8 - , trim - ) where + ( -- * Encode to/from UTF8 + decodeStringUtf8 + , encodeStringUtf8 + , trim + ) where -import Data.Word import Data.Bits -import Data.Char (chr,ord) +import Data.Char (chr, ord) import Data.List (dropWhileEnd) +import Data.Word import GHC.Unicode (isSpace) -- | Decode 'String' from UTF8-encoded octets. @@ -21,46 +21,48 @@ decodeStringUtf8 :: [Word8] -> String decodeStringUtf8 = go where go :: [Word8] -> String - go [] = [] + go [] = [] go (c : cs) | c <= 0x7F = chr (fromIntegral c) : go cs | c <= 0xBF = replacementChar : go cs | c <= 0xDF = twoBytes c cs - | c <= 0xEF = moreBytes 3 0x800 cs (fromIntegral $ c .&. 0xF) - | c <= 0xF7 = moreBytes 4 0x10000 cs (fromIntegral $ c .&. 0x7) - | c <= 0xFB = moreBytes 5 0x200000 cs (fromIntegral $ c .&. 0x3) + | c <= 0xEF = moreBytes 3 0x800 cs (fromIntegral $ c .&. 0xF) + | c <= 0xF7 = moreBytes 4 0x10000 cs (fromIntegral $ c .&. 0x7) + | c <= 0xFB = moreBytes 5 0x200000 cs (fromIntegral $ c .&. 0x3) | c <= 0xFD = moreBytes 6 0x4000000 cs (fromIntegral $ c .&. 0x1) - | otherwise = replacementChar : go cs + | otherwise = replacementChar : go cs twoBytes :: Word8 -> [Word8] -> String - twoBytes c0 (c1:cs') - | c1 .&. 0xC0 == 0x80 - = let d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) - .|. fromIntegral (c1 .&. 0x3F) - in if d >= 0x80 - then chr d : go cs' - else replacementChar : go cs' - twoBytes _ cs' = replacementChar : go cs' + twoBytes c0 (c1 : cs') + | c1 .&. 0xC0 == 0x80 = + let d = + (fromIntegral (c0 .&. 0x1F) `shiftL` 6) + .|. fromIntegral (c1 .&. 0x3F) + in if d >= 0x80 + then chr d : go cs' + else replacementChar : go cs' + twoBytes _ cs' = replacementChar : go cs' moreBytes :: Int -> Int -> [Word8] -> Int -> [Char] moreBytes 1 overlong cs' acc - | overlong <= acc, acc <= 0x10FFFF, acc < 0xD800 || 0xDFFF < acc - = chr acc : go cs' - - | otherwise - = replacementChar : go cs' - - moreBytes byteCount overlong (cn:cs') acc - | cn .&. 0xC0 == 0x80 - = moreBytes (byteCount-1) overlong cs' - ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F) - - moreBytes _ _ cs' _ - = replacementChar : go cs' + | overlong <= acc + , acc <= 0x10FFFF + , acc < 0xD800 || 0xDFFF < acc = + chr acc : go cs' + | otherwise = + replacementChar : go cs' + moreBytes byteCount overlong (cn : cs') acc + | cn .&. 0xC0 == 0x80 = + moreBytes + (byteCount - 1) + overlong + cs' + ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F) + moreBytes _ _ cs' _ = + replacementChar : go cs' replacementChar = '\xfffd' - -- | Encode 'String' to a list of UTF8-encoded octets -- -- Code-points in the @U+D800@-@U+DFFF@ range will be encoded @@ -68,28 +70,36 @@ decodeStringUtf8 = go -- -- See also 'decodeUtf8' encodeStringUtf8 :: String -> [Word8] -encodeStringUtf8 [] = [] -encodeStringUtf8 (c:cs) - | c <= '\x07F' = w8 - : encodeStringUtf8 cs - | c <= '\x7FF' = (0xC0 .|. w8ShiftR 6 ) - : (0x80 .|. (w8 .&. 0x3F)) - : encodeStringUtf8 cs - | c <= '\xD7FF'= (0xE0 .|. w8ShiftR 12 ) - : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) - : (0x80 .|. (w8 .&. 0x3F)) - : encodeStringUtf8 cs - | c <= '\xDFFF'= 0xEF : 0xBF : 0xBD -- U+FFFD - : encodeStringUtf8 cs - | c <= '\xFFFF'= (0xE0 .|. w8ShiftR 12 ) - : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) - : (0x80 .|. (w8 .&. 0x3F)) - : encodeStringUtf8 cs - | otherwise = (0xf0 .|. w8ShiftR 18 ) - : (0x80 .|. (w8ShiftR 12 .&. 0x3F)) - : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) - : (0x80 .|. (w8 .&. 0x3F)) - : encodeStringUtf8 cs +encodeStringUtf8 [] = [] +encodeStringUtf8 (c : cs) + | c <= '\x07F' = + w8 + : encodeStringUtf8 cs + | c <= '\x7FF' = + (0xC0 .|. w8ShiftR 6) + : (0x80 .|. (w8 .&. 0x3F)) + : encodeStringUtf8 cs + | c <= '\xD7FF' = + (0xE0 .|. w8ShiftR 12) + : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) + : (0x80 .|. (w8 .&. 0x3F)) + : encodeStringUtf8 cs + | c <= '\xDFFF' = + 0xEF + : 0xBF + : 0xBD -- U+FFFD + : encodeStringUtf8 cs + | c <= '\xFFFF' = + (0xE0 .|. w8ShiftR 12) + : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) + : (0x80 .|. (w8 .&. 0x3F)) + : encodeStringUtf8 cs + | otherwise = + (0xf0 .|. w8ShiftR 18) + : (0x80 .|. (w8ShiftR 12 .&. 0x3F)) + : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) + : (0x80 .|. (w8 .&. 0x3F)) + : encodeStringUtf8 cs where w8 = fromIntegral (ord c) :: Word8 w8ShiftR :: Int -> Word8 diff --git a/Cabal-syntax/src/Distribution/Utils/Structured.hs b/Cabal-syntax/src/Distribution/Utils/Structured.hs index ca3147710c8..ba10212bca1 100644 --- a/Cabal-syntax/src/Distribution/Utils/Structured.hs +++ b/Cabal-syntax/src/Distribution/Utils/Structured.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + -- | -- -- Copyright: (c) 2019 Oleg Grenrus @@ -38,42 +39,44 @@ -- -- Technically, 'Structured' is not related to 'Binary', and may -- be useful in other uses. --- -module Distribution.Utils.Structured ( - -- * Encoding and decoding +module Distribution.Utils.Structured + ( -- * Encoding and decoding + -- | These functions operate like @binary@'s counterparts, -- but the serialised version has a structure hash in front. - structuredEncode, - structuredEncodeFile, - structuredDecode, - structuredDecodeOrFailIO, - structuredDecodeFileOrFail, + structuredEncode + , structuredEncodeFile + , structuredDecode + , structuredDecodeOrFailIO + , structuredDecodeFileOrFail + -- * Structured class - Structured (structure), - MD5, - structureHash, - structureBuilder, - genericStructure, - GStructured, - nominalStructure, - containerStructure, + , Structured (structure) + , MD5 + , structureHash + , structureBuilder + , genericStructure + , GStructured + , nominalStructure + , containerStructure + -- * Structure type - Structure (..), - Tag (..), - TypeName, - ConstructorName, - TypeVersion, - SopStructure, - hashStructure, - typeVersion, - typeName, - ) where - -import Data.Int (Int16, Int32, Int64, Int8) + , Structure (..) + , Tag (..) + , TypeName + , ConstructorName + , TypeVersion + , SopStructure + , hashStructure + , typeVersion + , typeName + ) where + +import Data.Int (Int16, Int32, Int64, Int8) import Data.List.NonEmpty (NonEmpty) -import Data.Proxy (Proxy (..)) -import Data.Ratio (Ratio) -import Data.Word (Word, Word16, Word32, Word64, Word8) +import Data.Proxy (Proxy (..)) +import Data.Ratio (Ratio) +import Data.Word (Word, Word16, Word32, Word64, Word8) import qualified Control.Monad.Trans.State.Strict as State @@ -81,22 +84,22 @@ import Control.Exception (ErrorCall (..), catch, evaluate) import GHC.Generics -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS #if MIN_VERSION_bytestring(0,10,4) import qualified Data.ByteString.Builder as Builder #else import qualified Data.ByteString.Lazy.Builder as Builder #endif -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import qualified Data.Map as Map -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified Data.Time as Time -import qualified Distribution.Compat.Binary as Binary +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import qualified Data.Map as Map +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified Data.Time as Time +import qualified Distribution.Compat.Binary as Binary #ifdef MIN_VERSION_aeson import qualified Data.Aeson as Aeson @@ -104,34 +107,35 @@ import qualified Data.Aeson as Aeson import Data.Kind (Type) -import Distribution.Compat.Typeable (Typeable, TypeRep, typeRep) +import Distribution.Compat.Typeable (TypeRep, Typeable, typeRep) import Distribution.Utils.MD5 import Data.Monoid (mconcat) -import qualified Data.Semigroup import qualified Data.Foldable - +import qualified Data.Semigroup ------------------------------------------------------------------------------- -- Types ------------------------------------------------------------------------------- -type TypeName = String +type TypeName = String type ConstructorName = String -- | A semantic version of a data type. Usually 0. -type TypeVersion = Word32 +type TypeVersion = Word32 -- | Structure of a datatype. -- -- It can be infinite, as far as 'TypeRep's involved are finite. -- (e.g. polymorphic recursion might cause troubles). --- data Structure - = Nominal !TypeRep !TypeVersion TypeName [Structure] -- ^ nominal, yet can be parametrised by other structures. - | Newtype !TypeRep !TypeVersion TypeName Structure -- ^ a newtype wrapper - | Structure !TypeRep !TypeVersion TypeName SopStructure -- ^ sum-of-products structure + = -- | nominal, yet can be parametrised by other structures. + Nominal !TypeRep !TypeVersion TypeName [Structure] + | -- | a newtype wrapper + Newtype !TypeRep !TypeVersion TypeName Structure + | -- | sum-of-products structure + Structure !TypeRep !TypeVersion TypeName SopStructure deriving (Eq, Ord, Show, Generic) type SopStructure = [(ConstructorName, [Structure])] @@ -146,8 +150,8 @@ hashStructure = md5 . LBS.toStrict . Builder.toLazyByteString . structureBuilder -- 'typeVersion' :: Lens' 'Structure' 'TypeVersion' -- @ typeVersion :: Functor f => (TypeVersion -> f TypeVersion) -> Structure -> f Structure -typeVersion f (Nominal t v n s) = fmap (\v' -> Nominal t v' n s) (f v) -typeVersion f (Newtype t v n s) = fmap (\v' -> Newtype t v' n s) (f v) +typeVersion f (Nominal t v n s) = fmap (\v' -> Nominal t v' n s) (f v) +typeVersion f (Newtype t v n s) = fmap (\v' -> Newtype t v' n s) (f v) typeVersion f (Structure t v n s) = fmap (\v' -> Structure t v' n s) (f v) -- | A van-Laarhoven lens into 'TypeName' of 'Structure' @@ -156,8 +160,8 @@ typeVersion f (Structure t v n s) = fmap (\v' -> Structure t v' n s) (f v) -- 'typeName' :: Lens' 'Structure' 'TypeName' -- @ typeName :: Functor f => (TypeName -> f TypeName) -> Structure -> f Structure -typeName f (Nominal t v n s) = fmap (\n' -> Nominal t v n' s) (f n) -typeName f (Newtype t v n s) = fmap (\n' -> Newtype t v n' s) (f n) +typeName f (Nominal t v n s) = fmap (\n' -> Nominal t v n' s) (f n) +typeName f (Newtype t v n s) = fmap (\n' -> Newtype t v n' s) (f n) typeName f (Structure t v n s) = fmap (\n' -> Structure t v n' s) (f n) ------------------------------------------------------------------------------- @@ -170,45 +174,45 @@ typeName f (Structure t v n s) = fmap (\n' -> Structure t v n' s) (f n) -- we keep track of 'TypeRep's, and put just 'TypeRep' name when it's occurred -- another time. structureBuilder :: Structure -> Builder.Builder -structureBuilder s0 = State.evalState (go s0) Map.empty where +structureBuilder s0 = State.evalState (go s0) Map.empty + where go :: Structure -> State.State (Map.Map String (NonEmpty TypeRep)) Builder.Builder - go (Nominal t v n s) = withTypeRep t $ do - s' <- traverse go s - return $ mconcat $ Builder.word8 1 : Builder.word32LE v : Builder.stringUtf8 n : s' - - go (Newtype t v n s) = withTypeRep t $ do - s' <- go s - return $ mconcat [Builder.word8 2, Builder.word32LE v, Builder.stringUtf8 n, s'] - + go (Nominal t v n s) = withTypeRep t $ do + s' <- traverse go s + return $ mconcat $ Builder.word8 1 : Builder.word32LE v : Builder.stringUtf8 n : s' + go (Newtype t v n s) = withTypeRep t $ do + s' <- go s + return $ mconcat [Builder.word8 2, Builder.word32LE v, Builder.stringUtf8 n, s'] go (Structure t v n s) = withTypeRep t $ do - s' <- goSop s - return $ mconcat [Builder.word8 3, Builder.word32LE v, Builder.stringUtf8 n, s'] + s' <- goSop s + return $ mconcat [Builder.word8 3, Builder.word32LE v, Builder.stringUtf8 n, s'] withTypeRep t k = do - acc <- State.get - case insert t acc of - Nothing -> return $ mconcat [ Builder.word8 0, Builder.stringUtf8 (show t) ] - Just acc' -> do - State.put acc' - k + acc <- State.get + case insert t acc of + Nothing -> return $ mconcat [Builder.word8 0, Builder.stringUtf8 (show t)] + Just acc' -> do + State.put acc' + k goSop :: SopStructure -> State.State (Map.Map String (NonEmpty TypeRep)) Builder.Builder goSop sop = do - parts <- traverse part sop - return $ mconcat parts + parts <- traverse part sop + return $ mconcat parts part (cn, s) = do - s' <- traverse go s - return $ Data.Monoid.mconcat [ Builder.stringUtf8 cn, mconcat s' ] + s' <- traverse go s + return $ Data.Monoid.mconcat [Builder.stringUtf8 cn, mconcat s'] insert :: TypeRep -> Map.Map String (NonEmpty TypeRep) -> Maybe (Map.Map String (NonEmpty TypeRep)) insert tr m = case Map.lookup trShown m of - Nothing -> inserted - Just ne | tr `Data.Foldable.elem` ne -> Nothing - | otherwise -> inserted + Nothing -> inserted + Just ne + | tr `Data.Foldable.elem` ne -> Nothing + | otherwise -> inserted where inserted = Just (Map.insertWith (Data.Semigroup.<>) trShown (pure tr) m) - trShown = show tr + trShown = show tr ------------------------------------------------------------------------------- -- Classes @@ -224,18 +228,17 @@ structureBuilder s0 = State.evalState (go s0) Map.empty where -- @ -- -- @since 3.2.0.0 --- class Typeable a => Structured a where - structure :: Proxy a -> Structure - default structure :: (Generic a, GStructured (Rep a)) => Proxy a -> Structure - structure = genericStructure + structure :: Proxy a -> Structure + default structure :: (Generic a, GStructured (Rep a)) => Proxy a -> Structure + structure = genericStructure - -- This member is hidden. It's there to precalc - structureHash' :: Tagged a MD5 - structureHash' = Tagged (hashStructure (structure (Proxy :: Proxy a))) + -- This member is hidden. It's there to precalc + structureHash' :: Tagged a MD5 + structureHash' = Tagged (hashStructure (structure (Proxy :: Proxy a))) -- private Tagged -newtype Tagged a b = Tagged { untag :: b } +newtype Tagged a b = Tagged {untag :: b} -- | Semantically @'hashStructure' . 'structure'@. structureHash :: forall a. Structured a => Proxy a -> MD5 @@ -249,8 +252,10 @@ structureHash _ = untag (structureHash' :: Tagged a MD5) -- Encode a value to using binary serialisation to a lazy 'LBS.ByteString'. -- Encoding starts with 16 byte large structure hash. structuredEncode - :: forall a. (Binary.Binary a, Structured a) - => a -> LBS.ByteString + :: forall a + . (Binary.Binary a, Structured a) + => a + -> LBS.ByteString structuredEncode x = Binary.encode (Tag :: Tag a, x) -- | Lazily serialise a value to a file @@ -261,13 +266,15 @@ structuredEncodeFile f = LBS.writeFile f . structuredEncode -- Decode a value from a lazy 'LBS.ByteString', reconstructing the original structure. -- Throws pure exception on invalid inputs. structuredDecode - :: forall a. (Binary.Binary a, Structured a) - => LBS.ByteString -> a + :: forall a + . (Binary.Binary a, Structured a) + => LBS.ByteString + -> a structuredDecode lbs = snd (Binary.decode lbs :: (Tag a, a)) structuredDecodeOrFailIO :: (Binary.Binary a, Structured a) => LBS.ByteString -> IO (Either String a) structuredDecodeOrFailIO bs = - catch (evaluate (structuredDecode bs) >>= return . Right) handler + catch (evaluate (structuredDecode bs) >>= return . Right) handler where handler (ErrorCallWithLocation str _) = return $ Left str @@ -282,22 +289,24 @@ structuredDecodeFileOrFail f = structuredDecodeOrFailIO =<< LBS.readFile f data Tag a = Tag instance Structured a => Binary.Binary (Tag a) where - get = do - actual <- binaryGetMD5 - if actual == expected - then return Tag - else fail $ concat + get = do + actual <- binaryGetMD5 + if actual == expected + then return Tag + else + fail $ + concat [ "Non-matching structured hashes: " , showMD5 actual , "; expected: " , showMD5 expected ] - where - expected = untag (structureHash' :: Tagged a MD5) + where + expected = untag (structureHash' :: Tagged a MD5) - put _ = binaryPutMD5 expected - where - expected = untag (structureHash' :: Tagged a MD5) + put _ = binaryPutMD5 expected + where + expected = untag (structureHash' :: Tagged a MD5) ------------------------------------------------------------------------------- -- Smart constructors @@ -305,15 +314,20 @@ instance Structured a => Binary.Binary (Tag a) where -- | Use 'Typeable' to infer name nominalStructure :: Typeable a => Proxy a -> Structure -nominalStructure p = Nominal tr 0 (show tr) [] where +nominalStructure p = Nominal tr 0 (show tr) [] + where tr = typeRep p containerStructure :: forall f a. (Typeable f, Structured a) => Proxy (f a) -> Structure -containerStructure _ = Nominal faTypeRep 0 (show fTypeRep) +containerStructure _ = + Nominal + faTypeRep + 0 + (show fTypeRep) [ structure (Proxy :: Proxy a) ] where - fTypeRep = typeRep (Proxy :: Proxy f) + fTypeRep = typeRep (Proxy :: Proxy f) faTypeRep = typeRep (Proxy :: Proxy (f a)) ------------------------------------------------------------------------------- @@ -326,50 +340,50 @@ genericStructure _ = gstructured (typeRep (Proxy :: Proxy a)) (Proxy :: Proxy (R -- | Used to implement 'genericStructure'. class GStructured (f :: Type -> Type) where - gstructured :: TypeRep -> Proxy f -> TypeVersion -> Structure + gstructured :: TypeRep -> Proxy f -> TypeVersion -> Structure instance (i ~ D, Datatype c, GStructuredSum f) => GStructured (M1 i c f) where - gstructured tr _ v = case sop of - [(_, [s])] | isNewtype p -> Newtype tr v name s - _ -> Structure tr v name sop - where - p = undefined :: M1 i c f () - name = datatypeName p - sop = gstructuredSum (Proxy :: Proxy f) [] + gstructured tr _ v = case sop of + [(_, [s])] | isNewtype p -> Newtype tr v name s + _ -> Structure tr v name sop + where + p = undefined :: M1 i c f () + name = datatypeName p + sop = gstructuredSum (Proxy :: Proxy f) [] class GStructuredSum (f :: Type -> Type) where - gstructuredSum :: Proxy f -> SopStructure -> SopStructure + gstructuredSum :: Proxy f -> SopStructure -> SopStructure instance (i ~ C, Constructor c, GStructuredProd f) => GStructuredSum (M1 i c f) where - gstructuredSum _ xs = (name, prod) : xs - where - name = conName (undefined :: M1 i c f ()) - prod = gstructuredProd (Proxy :: Proxy f) [] + gstructuredSum _ xs = (name, prod) : xs + where + name = conName (undefined :: M1 i c f ()) + prod = gstructuredProd (Proxy :: Proxy f) [] instance (GStructuredSum f, GStructuredSum g) => GStructuredSum (f :+: g) where - gstructuredSum _ xs - = gstructuredSum (Proxy :: Proxy f) - $ gstructuredSum (Proxy :: Proxy g) xs + gstructuredSum _ xs = + gstructuredSum (Proxy :: Proxy f) $ + gstructuredSum (Proxy :: Proxy g) xs instance GStructuredSum V1 where - gstructuredSum _ = id + gstructuredSum _ = id class GStructuredProd (f :: Type -> Type) where - gstructuredProd :: Proxy f -> [Structure] -> [Structure] + gstructuredProd :: Proxy f -> [Structure] -> [Structure] instance (i ~ S, GStructuredProd f) => GStructuredProd (M1 i c f) where - gstructuredProd _ = gstructuredProd (Proxy :: Proxy f) + gstructuredProd _ = gstructuredProd (Proxy :: Proxy f) instance Structured c => GStructuredProd (K1 i c) where - gstructuredProd _ xs = structure (Proxy :: Proxy c) : xs + gstructuredProd _ xs = structure (Proxy :: Proxy c) : xs instance GStructuredProd U1 where - gstructuredProd _ = id + gstructuredProd _ = id instance (GStructuredProd f, GStructuredProd g) => GStructuredProd (f :*: g) where - gstructuredProd _ xs - = gstructuredProd (Proxy :: Proxy f) - $ gstructuredProd (Proxy :: Proxy g) xs + gstructuredProd _ xs = + gstructuredProd (Proxy :: Proxy f) $ + gstructuredProd (Proxy :: Proxy g) xs ------------------------------------------------------------------------------- -- instances @@ -379,23 +393,23 @@ instance Structured () instance Structured Bool instance Structured Ordering -instance Structured Char where structure = nominalStructure -instance Structured Int where structure = nominalStructure +instance Structured Char where structure = nominalStructure +instance Structured Int where structure = nominalStructure instance Structured Integer where structure = nominalStructure instance Structured Data.Word.Word where structure = nominalStructure -instance Structured Int8 where structure = nominalStructure +instance Structured Int8 where structure = nominalStructure instance Structured Int16 where structure = nominalStructure instance Structured Int32 where structure = nominalStructure instance Structured Int64 where structure = nominalStructure -instance Structured Word8 where structure = nominalStructure +instance Structured Word8 where structure = nominalStructure instance Structured Word16 where structure = nominalStructure instance Structured Word32 where structure = nominalStructure instance Structured Word64 where structure = nominalStructure -instance Structured Float where structure = nominalStructure +instance Structured Float where structure = nominalStructure instance Structured Double where structure = nominalStructure instance Structured a => Structured (Maybe a) @@ -417,17 +431,17 @@ instance Structured LBS.ByteString where structure = nominalStructure instance Structured T.Text where structure = nominalStructure instance Structured LT.Text where structure = nominalStructure -instance (Structured k, Structured v) => Structured (Map.Map k v) where structure _ = Nominal (typeRep (Proxy :: Proxy (Map.Map k v))) 0 "Map" [ structure (Proxy :: Proxy k), structure (Proxy :: Proxy v) ] -instance (Structured k) => Structured (Set.Set k) where structure = containerStructure -instance (Structured v) => Structured (IM.IntMap v) where structure = containerStructure +instance (Structured k, Structured v) => Structured (Map.Map k v) where structure _ = Nominal (typeRep (Proxy :: Proxy (Map.Map k v))) 0 "Map" [structure (Proxy :: Proxy k), structure (Proxy :: Proxy v)] +instance Structured k => Structured (Set.Set k) where structure = containerStructure +instance Structured v => Structured (IM.IntMap v) where structure = containerStructure instance Structured IS.IntSet where structure = nominalStructure -instance (Structured v) => Structured (Seq.Seq v) where structure = containerStructure +instance Structured v => Structured (Seq.Seq v) where structure = containerStructure -instance Structured Time.UTCTime where structure = nominalStructure -instance Structured Time.DiffTime where structure = nominalStructure -instance Structured Time.UniversalTime where structure = nominalStructure +instance Structured Time.UTCTime where structure = nominalStructure +instance Structured Time.DiffTime where structure = nominalStructure +instance Structured Time.UniversalTime where structure = nominalStructure instance Structured Time.NominalDiffTime where structure = nominalStructure -instance Structured Time.Day where structure = nominalStructure -instance Structured Time.TimeZone where structure = nominalStructure -instance Structured Time.TimeOfDay where structure = nominalStructure -instance Structured Time.LocalTime where structure = nominalStructure +instance Structured Time.Day where structure = nominalStructure +instance Structured Time.TimeZone where structure = nominalStructure +instance Structured Time.TimeOfDay where structure = nominalStructure +instance Structured Time.LocalTime where structure = nominalStructure diff --git a/Cabal-syntax/src/Distribution/Version.hs b/Cabal-syntax/src/Distribution/Version.hs index 33e2885af7e..80383358037 100644 --- a/Cabal-syntax/src/Distribution/Version.hs +++ b/Cabal-syntax/src/Distribution/Version.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Version -- Copyright : Isaac Jones, Simon Marlow 2003-2004 @@ -11,83 +12,86 @@ -- Exports the 'Version' type along with a parser and pretty printer. A version -- is something like @\"1.3.3\"@. It also defines the 'VersionRange' data -- types. Version ranges are like @\">= 1.2 && < 2\"@. - -module Distribution.Version ( - -- * Package versions - Version, - version0, - mkVersion, - mkVersion', - versionNumbers, - nullVersion, - alterVersion, - - -- * Version ranges - VersionRange, - - -- ** Constructing - anyVersion, noVersion, - thisVersion, notThisVersion, - laterVersion, earlierVersion, - orLaterVersion, orEarlierVersion, - unionVersionRanges, intersectVersionRanges, - withinVersion, - majorBoundVersion, - - -- ** Inspection - withinRange, - isAnyVersion, - isNoVersion, - isSpecificVersion, - simplifyVersionRange, - foldVersionRange, - normaliseVersionRange, - stripParensVersionRange, - hasUpperBound, - hasLowerBound, - - -- ** Cata & ana - VersionRangeF (..), - cataVersionRange, - anaVersionRange, - hyloVersionRange, - projectVersionRange, - embedVersionRange, - - -- ** Utilities - wildcardUpperBound, - majorUpperBound, - - -- ** Modification - removeUpperBound, - removeLowerBound, - transformCaret, - transformCaretUpper, - transformCaretLower, - - -- * Version intervals view - asVersionIntervals, - VersionInterval(..), - LowerBound(..), - UpperBound(..), - Bound(..), - - -- ** 'VersionIntervals' abstract type - -- | The 'VersionIntervals' type and the accompanying functions are exposed - -- primarily for completeness and testing purposes. In practice - -- 'asVersionIntervals' is the main function to use to - -- view a 'VersionRange' as a bunch of 'VersionInterval's. - -- - VersionIntervals, - toVersionIntervals, - fromVersionIntervals, - unVersionIntervals, - - ) where +module Distribution.Version + ( -- * Package versions + Version + , version0 + , mkVersion + , mkVersion' + , versionNumbers + , nullVersion + , alterVersion + + -- * Version ranges + , VersionRange + + -- ** Constructing + , anyVersion + , noVersion + , thisVersion + , notThisVersion + , laterVersion + , earlierVersion + , orLaterVersion + , orEarlierVersion + , unionVersionRanges + , intersectVersionRanges + , withinVersion + , majorBoundVersion + + -- ** Inspection + , withinRange + , isAnyVersion + , isNoVersion + , isSpecificVersion + , simplifyVersionRange + , foldVersionRange + , normaliseVersionRange + , stripParensVersionRange + , hasUpperBound + , hasLowerBound + + -- ** Cata & ana + , VersionRangeF (..) + , cataVersionRange + , anaVersionRange + , hyloVersionRange + , projectVersionRange + , embedVersionRange + + -- ** Utilities + , wildcardUpperBound + , majorUpperBound + + -- ** Modification + , removeUpperBound + , removeLowerBound + , transformCaret + , transformCaretUpper + , transformCaretLower + + -- * Version intervals view + , asVersionIntervals + , VersionInterval (..) + , LowerBound (..) + , UpperBound (..) + , Bound (..) + + -- ** 'VersionIntervals' abstract type + + -- | The 'VersionIntervals' type and the accompanying functions are exposed + -- primarily for completeness and testing purposes. In practice + -- 'asVersionIntervals' is the main function to use to + -- view a 'VersionRange' as a bunch of 'VersionInterval's. + , VersionIntervals + , toVersionIntervals + , fromVersionIntervals + , unVersionIntervals + ) where import Distribution.Types.Version -import Distribution.Types.VersionRange import Distribution.Types.VersionInterval +import Distribution.Types.VersionRange ------------------------------------------------------------------------------- -- Utilities on VersionRange requiring VersionInterval @@ -99,22 +103,20 @@ import Distribution.Types.VersionInterval -- For example this is @True@ (for all @v@): -- -- > isNoVersion (EarlierVersion v `IntersectVersionRanges` LaterVersion v) --- isNoVersion :: VersionRange -> Bool isNoVersion vr = case asVersionIntervals vr of [] -> True - _ -> False + _ -> False -- | Is this version range in fact just a specific version? -- -- For example the version range @\">= 3 && <= 3\"@ contains only the version -- @3@. --- isSpecificVersion :: VersionRange -> Maybe Version isSpecificVersion vr = case asVersionIntervals vr of - [VersionInterval (LowerBound v InclusiveBound) (UpperBound v' InclusiveBound)] + [VersionInterval (LowerBound v InclusiveBound) (UpperBound v' InclusiveBound)] | v == v' -> Just v - _ -> Nothing + _ -> Nothing ------------------------------------------------------------------------------- -- Transformations @@ -135,14 +137,13 @@ isSpecificVersion vr = case asVersionIntervals vr of -- > ==> simplifyVersionRange r = simplifyVersionRange r' -- > || isNoVersion r -- > || isNoVersion r' --- simplifyVersionRange :: VersionRange -> VersionRange simplifyVersionRange vr - -- If the version range is inconsistent then we just return the - -- original since that has more information than ">1 && < 1", which - -- is the canonical inconsistent version range. - | null (unVersionIntervals vi) = vr - | otherwise = fromVersionIntervals vi + -- If the version range is inconsistent then we just return the + -- original since that has more information than ">1 && < 1", which + -- is the canonical inconsistent version range. + | null (unVersionIntervals vi) = vr + | otherwise = fromVersionIntervals vi where vi = toVersionIntervals vr @@ -160,26 +161,26 @@ removeLowerBound = fromVersionIntervals . relaxHeadInterval . toVersionIntervals -- | Rewrite @^>= x.y.z@ into @>= x.y.z && < x.(y+1)@ -- -- @since 3.6.0.0 --- transformCaret :: VersionRange -> VersionRange -transformCaret = hyloVersionRange embed projectVersionRange where +transformCaret = hyloVersionRange embed projectVersionRange + where embed (MajorBoundVersionF v) = orLaterVersion v `intersectVersionRanges` earlierVersion (majorUpperBound v) - embed vr = embedVersionRange vr + embed vr = embedVersionRange vr -- | Rewrite @^>= x.y.z@ into @>= x.y.z@ -- -- @since 3.6.0.0 --- transformCaretUpper :: VersionRange -> VersionRange -transformCaretUpper = hyloVersionRange embed projectVersionRange where +transformCaretUpper = hyloVersionRange embed projectVersionRange + where embed (MajorBoundVersionF v) = orLaterVersion v - embed vr = embedVersionRange vr + embed vr = embedVersionRange vr -- | Rewrite @^>= x.y.z@ into @ VersionRange -transformCaretLower = hyloVersionRange embed projectVersionRange where +transformCaretLower = hyloVersionRange embed projectVersionRange + where embed (MajorBoundVersionF v) = earlierVersion (majorUpperBound v) - embed vr = embedVersionRange vr + embed vr = embedVersionRange vr diff --git a/Cabal-syntax/src/Language/Haskell/Extension.hs b/Cabal-syntax/src/Language/Haskell/Extension.hs index b7adc1c7e7e..669e569c239 100644 --- a/Cabal-syntax/src/Language/Haskell/Extension.hs +++ b/Cabal-syntax/src/Language/Haskell/Extension.hs @@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- + -- | -- Module : Language.Haskell.Extension -- Copyright : Isaac Jones 2003-2004 @@ -12,22 +13,20 @@ -- Portability : portable -- -- Haskell language dialects and extensions - -module Language.Haskell.Extension ( - Language(..), - knownLanguages, - classifyLanguage, - - Extension(..), - KnownExtension(..), - deprecatedExtensions, - classifyExtension, - knownExtensions +module Language.Haskell.Extension + ( Language (..) + , knownLanguages + , classifyLanguage + , Extension (..) + , KnownExtension (..) + , deprecatedExtensions + , classifyExtension + , knownExtensions ) where import Distribution.Compat.Prelude -import Data.Array (Array, accumArray, bounds, Ix(inRange), (!)) +import Data.Array (Array, Ix (inRange), accumArray, bounds, (!)) import Distribution.Parsec import Distribution.Pretty @@ -36,30 +35,27 @@ import qualified Distribution.Compat.CharParsing as P import qualified Text.PrettyPrint as Disp -- ------------------------------------------------------------ + -- * Language + -- ------------------------------------------------------------ -- | This represents a Haskell language dialect. -- -- Language 'Extension's are interpreted relative to one of these base -- languages. --- -data Language = - - -- | The Haskell 98 language as defined by the Haskell 98 report. - -- - Haskell98 - - -- | The Haskell 2010 language as defined by the Haskell 2010 report. - -- - | Haskell2010 - - -- | The GHC2021 collection of language extensions. - -- - | GHC2021 - - -- | An unknown language, identified by its name. - | UnknownLanguage String +data Language + = -- | The Haskell 98 language as defined by the Haskell 98 report. + -- + Haskell98 + | -- | The Haskell 2010 language as defined by the Haskell 2010 report. + -- + Haskell2010 + | -- | The GHC2021 collection of language extensions. + -- + GHC2021 + | -- | An unknown language, identified by its name. + UnknownLanguage String deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) instance Binary Language @@ -73,46 +69,49 @@ knownLanguages = [Haskell98, Haskell2010, GHC2021] instance Pretty Language where pretty (UnknownLanguage other) = Disp.text other - pretty other = Disp.text (show other) + pretty other = Disp.text (show other) instance Parsec Language where parsec = classifyLanguage <$> P.munch1 isAlphaNum classifyLanguage :: String -> Language classifyLanguage = \str -> case lookup str langTable of - Just lang -> lang - Nothing -> UnknownLanguage str + Just lang -> lang + Nothing -> UnknownLanguage str where - langTable = [ (show lang, lang) - | lang <- knownLanguages ] + langTable = + [ (show lang, lang) + | lang <- knownLanguages + ] -- ------------------------------------------------------------ + -- * Extension + -- ------------------------------------------------------------ -- Note: if you add a new 'KnownExtension': -- + -- * also add it to the Distribution.Simple.X.languageExtensions lists + -- (where X is each compiler: GHC, UHC, HaskellSuite) -- + -- | This represents language extensions beyond a base 'Language' definition -- (such as 'Haskell98') that are supported by some implementations, usually -- in some special mode. -- -- Where applicable, references are given to an implementation's -- official documentation. - -data Extension = - -- | Enable a known extension +data Extension + = -- | Enable a known extension EnableExtension KnownExtension - - -- | Disable a known extension - | DisableExtension KnownExtension - - -- | An unknown extension, identified by the name of its @LANGUAGE@ - -- pragma. - | UnknownExtension String - + | -- | Disable a known extension + DisableExtension KnownExtension + | -- | An unknown extension, identified by the name of its @LANGUAGE@ + -- pragma. + UnknownExtension String deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) instance Binary Extension @@ -125,567 +124,420 @@ instance NFData Extension where rnf = genericRnf -- -- Check -- for more information. -data KnownExtension = - - -- | Allow overlapping class instances, provided there is a unique - -- most specific instance for each use. +data KnownExtension + = -- | Allow overlapping class instances, provided there is a unique + -- most specific instance for each use. OverlappingInstances - - -- | Ignore structural rules guaranteeing the termination of class - -- instance resolution. Termination is guaranteed by a fixed-depth - -- recursion stack, and compilation may fail if this depth is - -- exceeded. - | UndecidableInstances - - -- | Implies 'OverlappingInstances'. Allow the implementation to - -- choose an instance even when it is possible that further - -- instantiation of types will lead to a more specific instance - -- being applicable. - | IncoherentInstances - - -- | /(deprecated)/ Deprecated in favour of 'RecursiveDo'. - -- - -- Old description: Allow recursive bindings in @do@ blocks, using - -- the @rec@ keyword. See also 'RecursiveDo'. - | DoRec - - -- | Allow recursive bindings in @do@ blocks, using the @rec@ - -- keyword, or @mdo@, a variant of @do@. - | RecursiveDo - - -- | Provide syntax for writing list comprehensions which iterate - -- over several lists together, like the 'zipWith' family of - -- functions. - | ParallelListComp - - -- | Allow multiple parameters in a type class. - | MultiParamTypeClasses - - -- | Enable the dreaded monomorphism restriction. - | MonomorphismRestriction - - -- | Enable deep subsumption, relaxing the simple subsumption rules, - -- implicitly inserting eta-expansions when matching up function types - -- with different quantification structures. - | DeepSubsumption - - -- | Allow a specification attached to a multi-parameter type class - -- which indicates that some parameters are entirely determined by - -- others. The implementation will check that this property holds - -- for the declared instances, and will use this property to reduce - -- ambiguity in instance resolution. - | FunctionalDependencies - - -- | /(deprecated)/ A synonym for 'RankNTypes'. - -- - -- Old description: Like 'RankNTypes' but does not allow a - -- higher-rank type to itself appear on the left of a function - -- arrow. - | Rank2Types - - -- | Allow a universally-quantified type to occur on the left of a - -- function arrow. - | RankNTypes - - -- | /(deprecated)/ A synonym for 'RankNTypes'. - -- - -- Old description: Allow data constructors to have polymorphic - -- arguments. Unlike 'RankNTypes', does not allow this for ordinary - -- functions. - | PolymorphicComponents - - -- | Allow existentially-quantified data constructors. - | ExistentialQuantification - - -- | Cause a type variable in a signature, which has an explicit - -- @forall@ quantifier, to scope over the definition of the - -- accompanying value declaration. - | ScopedTypeVariables - - -- | Deprecated, use 'ScopedTypeVariables' instead. - | PatternSignatures - - -- | Enable implicit function parameters with dynamic scope. - | ImplicitParams - - -- | Relax some restrictions on the form of the context of a type - -- signature. - | FlexibleContexts - - -- | Relax some restrictions on the form of the context of an - -- instance declaration. - | FlexibleInstances - - -- | Allow data type declarations with no constructors. - | EmptyDataDecls - - -- | Run the C preprocessor on Haskell source code. - | CPP - - -- | Allow an explicit kind signature giving the kind of types over - -- which a type variable ranges. - | KindSignatures - - -- | Enable a form of pattern which forces evaluation before an - -- attempted match, and a form of strict @let@/@where@ binding. - | BangPatterns - - -- | Allow type synonyms in instance heads. - | TypeSynonymInstances - - -- | Enable Template Haskell, a system for compile-time - -- metaprogramming. - | TemplateHaskell - - -- | Enable the Foreign Function Interface. In GHC, implements the - -- standard Haskell 98 Foreign Function Interface Addendum, plus - -- some GHC-specific extensions. - | ForeignFunctionInterface - - -- | Enable arrow notation. - | Arrows - - -- | /(deprecated)/ Enable generic type classes, with default instances defined in - -- terms of the algebraic structure of a type. - | Generics - - -- | Enable the implicit importing of the module "Prelude". When - -- disabled, when desugaring certain built-in syntax into ordinary - -- identifiers, use whatever is in scope rather than the "Prelude" - -- -- version. - | ImplicitPrelude - - -- | Enable syntax for implicitly binding local names corresponding - -- to the field names of a record. Puns bind specific names, unlike - -- 'RecordWildCards'. - | NamedFieldPuns - - -- | Enable a form of guard which matches a pattern and binds - -- variables. - | PatternGuards - - -- | Allow a type declared with @newtype@ to use @deriving@ for any - -- class with an instance for the underlying type. - | GeneralizedNewtypeDeriving - - -- Synonym for GeneralizedNewtypeDeriving added in GHC 8.6.1. - | GeneralisedNewtypeDeriving - - -- | Enable the \"Trex\" extensible records system. - | ExtensibleRecords - - -- | Enable type synonyms which are transparent in some definitions - -- and opaque elsewhere, as a way of implementing abstract - -- datatypes. - | RestrictedTypeSynonyms - - -- | Enable an alternate syntax for string literals, - -- with string templating. - | HereDocuments - - -- | Allow the character @#@ as a postfix modifier on identifiers. - -- Also enables literal syntax for unboxed values. - | MagicHash - - -- | Allow data types and type synonyms which are indexed by types, - -- i.e. ad-hoc polymorphism for types. - | TypeFamilies - - -- | Allow a standalone declaration which invokes the type class - -- @deriving@ mechanism. - | StandaloneDeriving - - -- | Allow certain Unicode characters to stand for certain ASCII - -- character sequences, e.g. keywords and punctuation. - | UnicodeSyntax - - -- | Allow the use of unboxed types as foreign types, e.g. in - -- @foreign import@ and @foreign export@. - | UnliftedFFITypes - - -- | Enable interruptible FFI. - | InterruptibleFFI - - -- | Allow use of CAPI FFI calling convention (@foreign import capi@). - | CApiFFI - - -- | Defer validity checking of types until after expanding type - -- synonyms, relaxing the constraints on how synonyms may be used. - | LiberalTypeSynonyms - - -- | Allow the name of a type constructor, type class, or type - -- variable to be an infix operator. - | TypeOperators - - -- | Enable syntax for implicitly binding local names corresponding - -- to the field names of a record. A wildcard binds all unmentioned - -- names, unlike 'NamedFieldPuns'. - | RecordWildCards - - -- | Deprecated, use 'NamedFieldPuns' instead. - | RecordPuns - - -- | Allow a record field name to be disambiguated by the type of - -- the record it's in. - | DisambiguateRecordFields - - -- | Enable traditional record syntax (as supported by Haskell 98) - | TraditionalRecordSyntax - - -- | Enable overloading of string literals using a type class, much - -- like integer literals. - | OverloadedStrings - - -- | Enable generalized algebraic data types, in which type - -- variables may be instantiated on a per-constructor basis. Implies - -- 'GADTSyntax'. - | GADTs - - -- | Enable GADT syntax for declaring ordinary algebraic datatypes. - | GADTSyntax - - -- | /(deprecated)/ Has no effect. - -- - -- Old description: Make pattern bindings monomorphic. - | MonoPatBinds - - -- | Relax the requirements on mutually-recursive polymorphic - -- functions. - | RelaxedPolyRec - - -- | Allow default instantiation of polymorphic types in more - -- situations. - | ExtendedDefaultRules - - -- | Enable unboxed tuples. - | UnboxedTuples - - -- | Enable @deriving@ for classes 'Data.Typeable.Typeable' and - -- 'Data.Generics.Data'. - | DeriveDataTypeable - - -- | Enable @deriving@ for 'GHC.Generics.Generic' and 'GHC.Generics.Generic1'. - | DeriveGeneric - - -- | Enable support for default signatures. - | DefaultSignatures - - -- | Allow type signatures to be specified in instance declarations. - | InstanceSigs - - -- | Allow a class method's type to place additional constraints on - -- a class type variable. - | ConstrainedClassMethods - - -- | Allow imports to be qualified by the package name the module is - -- intended to be imported from, e.g. - -- - -- > import "network" Network.Socket - | PackageImports - - -- | /(deprecated)/ Allow a type variable to be instantiated at a - -- polymorphic type. - | ImpredicativeTypes - - -- | /(deprecated)/ Change the syntax for qualified infix operators. - | NewQualifiedOperators - - -- | Relax the interpretation of left operator sections to allow - -- unary postfix operators. - | PostfixOperators - - -- | Enable quasi-quotation, a mechanism for defining new concrete - -- syntax for expressions and patterns. - | QuasiQuotes - - -- | Enable generalized list comprehensions, supporting operations - -- such as sorting and grouping. - | TransformListComp - - -- | Enable monad comprehensions, which generalise the list - -- comprehension syntax to work for any monad. - | MonadComprehensions - - -- | Enable view patterns, which match a value by applying a - -- function and matching on the result. - | ViewPatterns - - -- | Allow concrete XML syntax to be used in expressions and patterns, - -- as per the Haskell Server Pages extension language: - -- . The ideas behind it are - -- discussed in the paper \"Haskell Server Pages through Dynamic Loading\" - -- by Niklas Broberg, from Haskell Workshop '05. - | XmlSyntax - - -- | Allow regular pattern matching over lists, as discussed in the - -- paper \"Regular Expression Patterns\" by Niklas Broberg, Andreas Farre - -- and Josef Svenningsson, from ICFP '04. - | RegularPatterns - - -- | Enable the use of tuple sections, e.g. @(, True)@ desugars into - -- @\x -> (x, True)@. - | TupleSections - - -- | Allow GHC primops, written in C--, to be imported into a Haskell - -- file. - | GHCForeignImportPrim - - -- | Support for patterns of the form @n + k@, where @k@ is an - -- integer literal. - | NPlusKPatterns - - -- | Improve the layout rule when @if@ expressions are used in a @do@ - -- block. - | DoAndIfThenElse - - -- | Enable support for multi-way @if@-expressions. - | MultiWayIf - - -- | Enable support lambda-@case@ expressions. - | LambdaCase - - -- | Makes much of the Haskell sugar be desugared into calls to the - -- function with a particular name that is in scope. - | RebindableSyntax - - -- | Make @forall@ a keyword in types, which can be used to give the - -- generalisation explicitly. - | ExplicitForAll - - -- | Allow contexts to be put on datatypes, e.g. the @Eq a@ in - -- @data Eq a => Set a = NilSet | ConsSet a (Set a)@. - | DatatypeContexts - - -- | Local (@let@ and @where@) bindings are monomorphic. - | MonoLocalBinds - - -- | Enable @deriving@ for the 'Data.Functor.Functor' class. - | DeriveFunctor - - -- | Enable @deriving@ for the 'Data.Traversable.Traversable' class. - | DeriveTraversable - - -- | Enable @deriving@ for the 'Data.Foldable.Foldable' class. - | DeriveFoldable - - -- | Enable non-decreasing indentation for @do@ blocks. - | NondecreasingIndentation - - -- | Allow imports to be qualified with a safe keyword that requires - -- the imported module be trusted as according to the Safe Haskell - -- definition of trust. - -- - -- > import safe Network.Socket - | SafeImports - - -- | Compile a module in the Safe, Safe Haskell mode -- a restricted - -- form of the Haskell language to ensure type safety. - | Safe - - -- | Compile a module in the Trustworthy, Safe Haskell mode -- no - -- restrictions apply but the module is marked as trusted as long as - -- the package the module resides in is trusted. - | Trustworthy - - -- | Compile a module in the Unsafe, Safe Haskell mode so that - -- modules compiled using Safe, Safe Haskell mode can't import it. - | Unsafe - - -- | Allow type class/implicit parameter/equality constraints to be - -- used as types with the special kind constraint. Also generalise - -- the @(ctxt => ty)@ syntax so that any type of kind constraint can - -- occur before the arrow. - | ConstraintKinds - - -- | Enable kind polymorphism. - | PolyKinds - - -- | Enable datatype promotion. - | DataKinds - - -- | Enable @type data@ declarations, defining constructors at the type level. - | TypeData - - -- | Enable parallel arrays syntax (@[:@, @:]@) for /Data Parallel Haskell/. - | ParallelArrays - - -- | Enable explicit role annotations, like in (@type role Foo representational representational@). - | RoleAnnotations - - -- | Enable overloading of list literals, arithmetic sequences and - -- list patterns using the 'IsList' type class. - | OverloadedLists - - -- | Enable case expressions that have no alternatives. Also applies to lambda-case expressions if they are enabled. - | EmptyCase - - -- | /(deprecated)/ Deprecated in favour of 'DeriveDataTypeable'. - -- - -- Old description: Triggers the generation of derived 'Typeable' - -- instances for every datatype and type class declaration. - | AutoDeriveTypeable - - -- | Desugars negative literals directly (without using negate). - | NegativeLiterals - - -- | Allow the use of binary integer literal syntax (e.g. @0b11001001@ to denote @201@). - | BinaryLiterals - - -- | Allow the use of floating literal syntax for all instances of 'Num', including 'Int' and 'Integer'. - | NumDecimals - - -- | Enable support for type classes with no type parameter. - | NullaryTypeClasses - - -- | Enable explicit namespaces in module import/export lists. - | ExplicitNamespaces - - -- | Allow the user to write ambiguous types, and the type inference engine to infer them. - | AllowAmbiguousTypes - - -- | Enable @foreign import javascript@. - | JavaScriptFFI - - -- | Allow giving names to and abstracting over patterns. - | PatternSynonyms - - -- | Allow anonymous placeholders (underscore) inside type signatures. The - -- type inference engine will generate a message describing the type inferred - -- at the hole's location. - | PartialTypeSignatures - - -- | Allow named placeholders written with a leading underscore inside type - -- signatures. Wildcards with the same name unify to the same type. - | NamedWildCards - - -- | Enable @deriving@ for any class. - | DeriveAnyClass - - -- | Enable @deriving@ for the 'Language.Haskell.TH.Syntax.Lift' class. - | DeriveLift - - -- | Enable support for 'static pointers' (and the @static@ - -- keyword) to refer to globally stable names, even across - -- different programs. - | StaticPointers - - -- | Switches data type declarations to be strict by default (as if - -- they had a bang using @BangPatterns@), and allow opt-in field - -- laziness using @~@. - | StrictData - - -- | Switches all pattern bindings to be strict by default (as if - -- they had a bang using @BangPatterns@), ordinary patterns are - -- recovered using @~@. Implies @StrictData@. - | Strict - - -- | Allows @do@-notation for types that are @'Applicative'@ as well - -- as @'Monad'@. When enabled, desugaring @do@ notation tries to use - -- @(<*>)@ and @'fmap'@ and @'join'@ as far as possible. - | ApplicativeDo - - -- | Allow records to use duplicated field labels for accessors. - | DuplicateRecordFields - - -- | Enable explicit type applications with the syntax @id \@Int@. - | TypeApplications - - -- | Dissolve the distinction between types and kinds, allowing the compiler - -- to reason about kind equality and therefore enabling GADTs to be promoted - -- to the type-level. - | TypeInType - - -- | Allow recursive (and therefore undecidable) super-class relationships. - | UndecidableSuperClasses - - -- | A temporary extension to help library authors check if their - -- code will compile with the new planned desugaring of fail. - | MonadFailDesugaring - - -- | A subset of @TemplateHaskell@ including only quoting. - | TemplateHaskellQuotes - - -- | Allows use of the @#label@ syntax. - | OverloadedLabels - - -- | Allow functional dependency annotations on type families to declare them - -- as injective. - | TypeFamilyDependencies - - -- | Allow multiple @deriving@ clauses, each optionally qualified with a - -- /strategy/. - | DerivingStrategies - - -- | Enable deriving instances via types of the same runtime representation. - -- Implies 'DerivingStrategies'. - | DerivingVia - - -- | Enable the use of unboxed sum syntax. - | UnboxedSums - - -- | Allow use of hexadecimal literal notation for floating-point values. - | HexFloatLiterals - - -- | Allow @do@ blocks etc. in argument position. - | BlockArguments - - -- | Allow use of underscores in numeric literals. - | NumericUnderscores - - -- | Allow @forall@ in constraints. - | QuantifiedConstraints - - -- | Have @*@ refer to @Type@. - | StarIsType - - -- | Liberalises deriving to provide instances for empty data types. - | EmptyDataDeriving - - -- | Enable detection of complete user-supplied kind signatures. - | CUSKs - - -- | Allows the syntax @import M qualified@. - | ImportQualifiedPost - - -- | Allow the use of standalone kind signatures. - | StandaloneKindSignatures - - -- | Enable unlifted newtypes. - | UnliftedNewtypes - - -- | Use whitespace to determine whether the minus sign stands for negation or subtraction. - | LexicalNegation - - -- | Enable qualified do-notation desugaring. - | QualifiedDo - - -- | Enable linear types. - | LinearTypes - - -- | Allow the use of visible forall in types of terms. - | RequiredTypeArguments - - -- | Enable the generation of selector functions corresponding to record fields. - | FieldSelectors - - -- | Enable the use of record dot-accessor and updater syntax - | OverloadedRecordDot - - -- | Provides record @.@ syntax in record updates, e.g. @x {foo.bar = 1}@. - | OverloadedRecordUpdate - - -- | Enable data types for which an unlifted or levity-polymorphic result kind is inferred. - | UnliftedDatatypes - - -- | Undocumented parsing-related extensions introduced in GHC 7.0. - | AlternativeLayoutRule - - -- | Undocumented parsing-related extensions introduced in GHC 7.0. - | AlternativeLayoutRuleTransitional - - -- | Undocumented parsing-related extensions introduced in GHC 7.2. - | RelaxedLayout - + | -- | Ignore structural rules guaranteeing the termination of class + -- instance resolution. Termination is guaranteed by a fixed-depth + -- recursion stack, and compilation may fail if this depth is + -- exceeded. + UndecidableInstances + | -- | Implies 'OverlappingInstances'. Allow the implementation to + -- choose an instance even when it is possible that further + -- instantiation of types will lead to a more specific instance + -- being applicable. + IncoherentInstances + | -- | /(deprecated)/ Deprecated in favour of 'RecursiveDo'. + -- + -- Old description: Allow recursive bindings in @do@ blocks, using + -- the @rec@ keyword. See also 'RecursiveDo'. + DoRec + | -- | Allow recursive bindings in @do@ blocks, using the @rec@ + -- keyword, or @mdo@, a variant of @do@. + RecursiveDo + | -- | Provide syntax for writing list comprehensions which iterate + -- over several lists together, like the 'zipWith' family of + -- functions. + ParallelListComp + | -- | Allow multiple parameters in a type class. + MultiParamTypeClasses + | -- | Enable the dreaded monomorphism restriction. + MonomorphismRestriction + | -- | Enable deep subsumption, relaxing the simple subsumption rules, + -- implicitly inserting eta-expansions when matching up function types + -- with different quantification structures. + DeepSubsumption + | -- | Allow a specification attached to a multi-parameter type class + -- which indicates that some parameters are entirely determined by + -- others. The implementation will check that this property holds + -- for the declared instances, and will use this property to reduce + -- ambiguity in instance resolution. + FunctionalDependencies + | -- | /(deprecated)/ A synonym for 'RankNTypes'. + -- + -- Old description: Like 'RankNTypes' but does not allow a + -- higher-rank type to itself appear on the left of a function + -- arrow. + Rank2Types + | -- | Allow a universally-quantified type to occur on the left of a + -- function arrow. + RankNTypes + | -- | /(deprecated)/ A synonym for 'RankNTypes'. + -- + -- Old description: Allow data constructors to have polymorphic + -- arguments. Unlike 'RankNTypes', does not allow this for ordinary + -- functions. + PolymorphicComponents + | -- | Allow existentially-quantified data constructors. + ExistentialQuantification + | -- | Cause a type variable in a signature, which has an explicit + -- @forall@ quantifier, to scope over the definition of the + -- accompanying value declaration. + ScopedTypeVariables + | -- | Deprecated, use 'ScopedTypeVariables' instead. + PatternSignatures + | -- | Enable implicit function parameters with dynamic scope. + ImplicitParams + | -- | Relax some restrictions on the form of the context of a type + -- signature. + FlexibleContexts + | -- | Relax some restrictions on the form of the context of an + -- instance declaration. + FlexibleInstances + | -- | Allow data type declarations with no constructors. + EmptyDataDecls + | -- | Run the C preprocessor on Haskell source code. + CPP + | -- | Allow an explicit kind signature giving the kind of types over + -- which a type variable ranges. + KindSignatures + | -- | Enable a form of pattern which forces evaluation before an + -- attempted match, and a form of strict @let@/@where@ binding. + BangPatterns + | -- | Allow type synonyms in instance heads. + TypeSynonymInstances + | -- | Enable Template Haskell, a system for compile-time + -- metaprogramming. + TemplateHaskell + | -- | Enable the Foreign Function Interface. In GHC, implements the + -- standard Haskell 98 Foreign Function Interface Addendum, plus + -- some GHC-specific extensions. + ForeignFunctionInterface + | -- | Enable arrow notation. + Arrows + | -- | /(deprecated)/ Enable generic type classes, with default instances defined in + -- terms of the algebraic structure of a type. + Generics + | -- | Enable the implicit importing of the module "Prelude". When + -- disabled, when desugaring certain built-in syntax into ordinary + -- identifiers, use whatever is in scope rather than the "Prelude" + -- -- version. + ImplicitPrelude + | -- | Enable syntax for implicitly binding local names corresponding + -- to the field names of a record. Puns bind specific names, unlike + -- 'RecordWildCards'. + NamedFieldPuns + | -- | Enable a form of guard which matches a pattern and binds + -- variables. + PatternGuards + | -- | Allow a type declared with @newtype@ to use @deriving@ for any + -- class with an instance for the underlying type. + GeneralizedNewtypeDeriving + | -- Synonym for GeneralizedNewtypeDeriving added in GHC 8.6.1. + GeneralisedNewtypeDeriving + | -- | Enable the \"Trex\" extensible records system. + ExtensibleRecords + | -- | Enable type synonyms which are transparent in some definitions + -- and opaque elsewhere, as a way of implementing abstract + -- datatypes. + RestrictedTypeSynonyms + | -- | Enable an alternate syntax for string literals, + -- with string templating. + HereDocuments + | -- | Allow the character @#@ as a postfix modifier on identifiers. + -- Also enables literal syntax for unboxed values. + MagicHash + | -- | Allow data types and type synonyms which are indexed by types, + -- i.e. ad-hoc polymorphism for types. + TypeFamilies + | -- | Allow a standalone declaration which invokes the type class + -- @deriving@ mechanism. + StandaloneDeriving + | -- | Allow certain Unicode characters to stand for certain ASCII + -- character sequences, e.g. keywords and punctuation. + UnicodeSyntax + | -- | Allow the use of unboxed types as foreign types, e.g. in + -- @foreign import@ and @foreign export@. + UnliftedFFITypes + | -- | Enable interruptible FFI. + InterruptibleFFI + | -- | Allow use of CAPI FFI calling convention (@foreign import capi@). + CApiFFI + | -- | Defer validity checking of types until after expanding type + -- synonyms, relaxing the constraints on how synonyms may be used. + LiberalTypeSynonyms + | -- | Allow the name of a type constructor, type class, or type + -- variable to be an infix operator. + TypeOperators + | -- | Enable syntax for implicitly binding local names corresponding + -- to the field names of a record. A wildcard binds all unmentioned + -- names, unlike 'NamedFieldPuns'. + RecordWildCards + | -- | Deprecated, use 'NamedFieldPuns' instead. + RecordPuns + | -- | Allow a record field name to be disambiguated by the type of + -- the record it's in. + DisambiguateRecordFields + | -- | Enable traditional record syntax (as supported by Haskell 98) + TraditionalRecordSyntax + | -- | Enable overloading of string literals using a type class, much + -- like integer literals. + OverloadedStrings + | -- | Enable generalized algebraic data types, in which type + -- variables may be instantiated on a per-constructor basis. Implies + -- 'GADTSyntax'. + GADTs + | -- | Enable GADT syntax for declaring ordinary algebraic datatypes. + GADTSyntax + | -- | /(deprecated)/ Has no effect. + -- + -- Old description: Make pattern bindings monomorphic. + MonoPatBinds + | -- | Relax the requirements on mutually-recursive polymorphic + -- functions. + RelaxedPolyRec + | -- | Allow default instantiation of polymorphic types in more + -- situations. + ExtendedDefaultRules + | -- | Enable unboxed tuples. + UnboxedTuples + | -- | Enable @deriving@ for classes 'Data.Typeable.Typeable' and + -- 'Data.Generics.Data'. + DeriveDataTypeable + | -- | Enable @deriving@ for 'GHC.Generics.Generic' and 'GHC.Generics.Generic1'. + DeriveGeneric + | -- | Enable support for default signatures. + DefaultSignatures + | -- | Allow type signatures to be specified in instance declarations. + InstanceSigs + | -- | Allow a class method's type to place additional constraints on + -- a class type variable. + ConstrainedClassMethods + | -- | Allow imports to be qualified by the package name the module is + -- intended to be imported from, e.g. + -- + -- > import "network" Network.Socket + PackageImports + | -- | /(deprecated)/ Allow a type variable to be instantiated at a + -- polymorphic type. + ImpredicativeTypes + | -- | /(deprecated)/ Change the syntax for qualified infix operators. + NewQualifiedOperators + | -- | Relax the interpretation of left operator sections to allow + -- unary postfix operators. + PostfixOperators + | -- | Enable quasi-quotation, a mechanism for defining new concrete + -- syntax for expressions and patterns. + QuasiQuotes + | -- | Enable generalized list comprehensions, supporting operations + -- such as sorting and grouping. + TransformListComp + | -- | Enable monad comprehensions, which generalise the list + -- comprehension syntax to work for any monad. + MonadComprehensions + | -- | Enable view patterns, which match a value by applying a + -- function and matching on the result. + ViewPatterns + | -- | Allow concrete XML syntax to be used in expressions and patterns, + -- as per the Haskell Server Pages extension language: + -- . The ideas behind it are + -- discussed in the paper \"Haskell Server Pages through Dynamic Loading\" + -- by Niklas Broberg, from Haskell Workshop '05. + XmlSyntax + | -- | Allow regular pattern matching over lists, as discussed in the + -- paper \"Regular Expression Patterns\" by Niklas Broberg, Andreas Farre + -- and Josef Svenningsson, from ICFP '04. + RegularPatterns + | -- | Enable the use of tuple sections, e.g. @(, True)@ desugars into + -- @\x -> (x, True)@. + TupleSections + | -- | Allow GHC primops, written in C--, to be imported into a Haskell + -- file. + GHCForeignImportPrim + | -- | Support for patterns of the form @n + k@, where @k@ is an + -- integer literal. + NPlusKPatterns + | -- | Improve the layout rule when @if@ expressions are used in a @do@ + -- block. + DoAndIfThenElse + | -- | Enable support for multi-way @if@-expressions. + MultiWayIf + | -- | Enable support lambda-@case@ expressions. + LambdaCase + | -- | Makes much of the Haskell sugar be desugared into calls to the + -- function with a particular name that is in scope. + RebindableSyntax + | -- | Make @forall@ a keyword in types, which can be used to give the + -- generalisation explicitly. + ExplicitForAll + | -- | Allow contexts to be put on datatypes, e.g. the @Eq a@ in + -- @data Eq a => Set a = NilSet | ConsSet a (Set a)@. + DatatypeContexts + | -- | Local (@let@ and @where@) bindings are monomorphic. + MonoLocalBinds + | -- | Enable @deriving@ for the 'Data.Functor.Functor' class. + DeriveFunctor + | -- | Enable @deriving@ for the 'Data.Traversable.Traversable' class. + DeriveTraversable + | -- | Enable @deriving@ for the 'Data.Foldable.Foldable' class. + DeriveFoldable + | -- | Enable non-decreasing indentation for @do@ blocks. + NondecreasingIndentation + | -- | Allow imports to be qualified with a safe keyword that requires + -- the imported module be trusted as according to the Safe Haskell + -- definition of trust. + -- + -- > import safe Network.Socket + SafeImports + | -- | Compile a module in the Safe, Safe Haskell mode -- a restricted + -- form of the Haskell language to ensure type safety. + Safe + | -- | Compile a module in the Trustworthy, Safe Haskell mode -- no + -- restrictions apply but the module is marked as trusted as long as + -- the package the module resides in is trusted. + Trustworthy + | -- | Compile a module in the Unsafe, Safe Haskell mode so that + -- modules compiled using Safe, Safe Haskell mode can't import it. + Unsafe + | -- | Allow type class/implicit parameter/equality constraints to be + -- used as types with the special kind constraint. Also generalise + -- the @(ctxt => ty)@ syntax so that any type of kind constraint can + -- occur before the arrow. + ConstraintKinds + | -- | Enable kind polymorphism. + PolyKinds + | -- | Enable datatype promotion. + DataKinds + | -- | Enable @type data@ declarations, defining constructors at the type level. + TypeData + | -- | Enable parallel arrays syntax (@[:@, @:]@) for /Data Parallel Haskell/. + ParallelArrays + | -- | Enable explicit role annotations, like in (@type role Foo representational representational@). + RoleAnnotations + | -- | Enable overloading of list literals, arithmetic sequences and + -- list patterns using the 'IsList' type class. + OverloadedLists + | -- | Enable case expressions that have no alternatives. Also applies to lambda-case expressions if they are enabled. + EmptyCase + | -- | /(deprecated)/ Deprecated in favour of 'DeriveDataTypeable'. + -- + -- Old description: Triggers the generation of derived 'Typeable' + -- instances for every datatype and type class declaration. + AutoDeriveTypeable + | -- | Desugars negative literals directly (without using negate). + NegativeLiterals + | -- | Allow the use of binary integer literal syntax (e.g. @0b11001001@ to denote @201@). + BinaryLiterals + | -- | Allow the use of floating literal syntax for all instances of 'Num', including 'Int' and 'Integer'. + NumDecimals + | -- | Enable support for type classes with no type parameter. + NullaryTypeClasses + | -- | Enable explicit namespaces in module import/export lists. + ExplicitNamespaces + | -- | Allow the user to write ambiguous types, and the type inference engine to infer them. + AllowAmbiguousTypes + | -- | Enable @foreign import javascript@. + JavaScriptFFI + | -- | Allow giving names to and abstracting over patterns. + PatternSynonyms + | -- | Allow anonymous placeholders (underscore) inside type signatures. The + -- type inference engine will generate a message describing the type inferred + -- at the hole's location. + PartialTypeSignatures + | -- | Allow named placeholders written with a leading underscore inside type + -- signatures. Wildcards with the same name unify to the same type. + NamedWildCards + | -- | Enable @deriving@ for any class. + DeriveAnyClass + | -- | Enable @deriving@ for the 'Language.Haskell.TH.Syntax.Lift' class. + DeriveLift + | -- | Enable support for 'static pointers' (and the @static@ + -- keyword) to refer to globally stable names, even across + -- different programs. + StaticPointers + | -- | Switches data type declarations to be strict by default (as if + -- they had a bang using @BangPatterns@), and allow opt-in field + -- laziness using @~@. + StrictData + | -- | Switches all pattern bindings to be strict by default (as if + -- they had a bang using @BangPatterns@), ordinary patterns are + -- recovered using @~@. Implies @StrictData@. + Strict + | -- | Allows @do@-notation for types that are @'Applicative'@ as well + -- as @'Monad'@. When enabled, desugaring @do@ notation tries to use + -- @(<*>)@ and @'fmap'@ and @'join'@ as far as possible. + ApplicativeDo + | -- | Allow records to use duplicated field labels for accessors. + DuplicateRecordFields + | -- | Enable explicit type applications with the syntax @id \@Int@. + TypeApplications + | -- | Dissolve the distinction between types and kinds, allowing the compiler + -- to reason about kind equality and therefore enabling GADTs to be promoted + -- to the type-level. + TypeInType + | -- | Allow recursive (and therefore undecidable) super-class relationships. + UndecidableSuperClasses + | -- | A temporary extension to help library authors check if their + -- code will compile with the new planned desugaring of fail. + MonadFailDesugaring + | -- | A subset of @TemplateHaskell@ including only quoting. + TemplateHaskellQuotes + | -- | Allows use of the @#label@ syntax. + OverloadedLabels + | -- | Allow functional dependency annotations on type families to declare them + -- as injective. + TypeFamilyDependencies + | -- | Allow multiple @deriving@ clauses, each optionally qualified with a + -- /strategy/. + DerivingStrategies + | -- | Enable deriving instances via types of the same runtime representation. + -- Implies 'DerivingStrategies'. + DerivingVia + | -- | Enable the use of unboxed sum syntax. + UnboxedSums + | -- | Allow use of hexadecimal literal notation for floating-point values. + HexFloatLiterals + | -- | Allow @do@ blocks etc. in argument position. + BlockArguments + | -- | Allow use of underscores in numeric literals. + NumericUnderscores + | -- | Allow @forall@ in constraints. + QuantifiedConstraints + | -- | Have @*@ refer to @Type@. + StarIsType + | -- | Liberalises deriving to provide instances for empty data types. + EmptyDataDeriving + | -- | Enable detection of complete user-supplied kind signatures. + CUSKs + | -- | Allows the syntax @import M qualified@. + ImportQualifiedPost + | -- | Allow the use of standalone kind signatures. + StandaloneKindSignatures + | -- | Enable unlifted newtypes. + UnliftedNewtypes + | -- | Use whitespace to determine whether the minus sign stands for negation or subtraction. + LexicalNegation + | -- | Enable qualified do-notation desugaring. + QualifiedDo + | -- | Enable linear types. + LinearTypes + | -- | Allow the use of visible forall in types of terms. + RequiredTypeArguments + | -- | Enable the generation of selector functions corresponding to record fields. + FieldSelectors + | -- | Enable the use of record dot-accessor and updater syntax + OverloadedRecordDot + | -- | Provides record @.@ syntax in record updates, e.g. @x {foo.bar = 1}@. + OverloadedRecordUpdate + | -- | Enable data types for which an unlifted or levity-polymorphic result kind is inferred. + UnliftedDatatypes + | -- | Undocumented parsing-related extensions introduced in GHC 7.0. + AlternativeLayoutRule + | -- | Undocumented parsing-related extensions introduced in GHC 7.0. + AlternativeLayoutRuleTransitional + | -- | Undocumented parsing-related extensions introduced in GHC 7.2. + RelaxedLayout deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable, Data) instance Binary KnownExtension @@ -695,12 +547,12 @@ instance NFData KnownExtension where rnf = genericRnf -- | Extensions that have been deprecated, possibly paired with another -- extension that replaces it. --- deprecatedExtensions :: [(Extension, Maybe Extension)] deprecatedExtensions = [ (EnableExtension RecordPuns, Just (EnableExtension NamedFieldPuns)) , (EnableExtension PatternSignatures, Just (EnableExtension ScopedTypeVariables)) ] + -- NOTE: when adding deprecated extensions that have new alternatives -- we must be careful to make sure that the deprecation messages are -- valid. We must not recommend aliases that cannot be used with older @@ -710,8 +562,8 @@ deprecatedExtensions = instance Pretty Extension where pretty (UnknownExtension other) = Disp.text other - pretty (EnableExtension ke) = Disp.text (show ke) - pretty (DisableExtension ke) = Disp.text ("No" ++ show ke) + pretty (EnableExtension ke) = Disp.text (show ke) + pretty (DisableExtension ke) = Disp.text ("No" ++ show ke) instance Parsec Extension where parsec = classifyExtension <$> P.munch1 isAlphaNum @@ -720,13 +572,13 @@ instance Pretty KnownExtension where pretty ke = Disp.text (show ke) classifyExtension :: String -> Extension -classifyExtension string - = case classifyKnownExtension string of +classifyExtension string = + case classifyKnownExtension string of Just ext -> EnableExtension ext Nothing -> - case string of - 'N':'o':string' -> - case classifyKnownExtension string' of + case string of + 'N' : 'o' : string' -> + case classifyKnownExtension string' of Just ext -> DisableExtension ext Nothing -> UnknownExtension string _ -> UnknownExtension string @@ -740,17 +592,19 @@ classifyExtension string -- -- This gives an order of magnitude improvement in parsing speed, and it'll -- also allow us to do case insensitive matches in future if we prefer. --- classifyKnownExtension :: String -> Maybe KnownExtension classifyKnownExtension "" = Nothing classifyKnownExtension string@(c : _) - | inRange (bounds knownExtensionTable) c - = lookup string (knownExtensionTable ! c) + | inRange (bounds knownExtensionTable) c = + lookup string (knownExtensionTable ! c) | otherwise = Nothing knownExtensionTable :: Array Char [(String, KnownExtension)] knownExtensionTable = - accumArray (flip (:)) [] ('A', 'Z') + accumArray + (flip (:)) + [] + ('A', 'Z') [ (hd, (str, extension)) -- assume KnownExtension's Show returns a non-empty string | (extension, str@(hd : _)) <- map (\e -> (e, show e)) [toEnum 0 ..] ] diff --git a/Cabal/Setup.hs b/Cabal/Setup.hs index 42784ab13d2..a3e3aa6e410 100644 --- a/Cabal/Setup.hs +++ b/Cabal/Setup.hs @@ -1,4 +1,5 @@ import Distribution.Simple + main :: IO () main = defaultMain diff --git a/Cabal/src/Distribution/Backpack/ComponentsGraph.hs b/Cabal/src/Distribution/Backpack/ComponentsGraph.hs index 656fc22d364..aef3db817c6 100644 --- a/Cabal/src/Distribution/Backpack/ComponentsGraph.hs +++ b/Cabal/src/Distribution/Backpack/ComponentsGraph.hs @@ -1,24 +1,24 @@ -- | See -module Distribution.Backpack.ComponentsGraph ( - ComponentsGraph, - ComponentsWithDeps, - mkComponentsGraph, - componentsGraphToList, - dispComponentsWithDeps, - componentCycleMsg -) where +module Distribution.Backpack.ComponentsGraph + ( ComponentsGraph + , ComponentsWithDeps + , mkComponentsGraph + , componentsGraphToList + , dispComponentsWithDeps + , componentCycleMsg + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () +import Distribution.Compat.Graph (Graph, Node (..)) +import qualified Distribution.Compat.Graph as Graph +import qualified Distribution.Compat.NonEmptySet as NES import Distribution.Package import Distribution.PackageDescription import Distribution.Simple.BuildToolDepends import Distribution.Simple.LocalBuildInfo import Distribution.Types.ComponentRequestedSpec -import Distribution.Compat.Graph (Graph, Node(..)) -import qualified Distribution.Compat.Graph as Graph -import qualified Distribution.Compat.NonEmptySet as NES import Distribution.Utils.Generic import Distribution.Pretty (pretty) @@ -30,68 +30,76 @@ import Text.PrettyPrint -- | A graph of source-level components by their source-level -- dependencies --- type ComponentsGraph = Graph (Node ComponentName Component) -- | A list of components associated with the source level -- dependencies between them. --- type ComponentsWithDeps = [(Component, [ComponentName])] -- | Pretty-print 'ComponentsWithDeps'. --- dispComponentsWithDeps :: ComponentsWithDeps -> Doc dispComponentsWithDeps graph = - vcat [ hang (text "component" <+> pretty (componentName c)) 4 - (vcat [ text "dependency" <+> pretty cdep | cdep <- cdeps ]) - | (c, cdeps) <- graph ] + vcat + [ hang + (text "component" <+> pretty (componentName c)) + 4 + (vcat [text "dependency" <+> pretty cdep | cdep <- cdeps]) + | (c, cdeps) <- graph + ] -- | Create a 'Graph' of 'Component', or report a cycle if there is a -- problem. --- -mkComponentsGraph :: ComponentRequestedSpec - -> PackageDescription - -> Either [ComponentName] ComponentsGraph +mkComponentsGraph + :: ComponentRequestedSpec + -> PackageDescription + -> Either [ComponentName] ComponentsGraph mkComponentsGraph enabled pkg_descr = - let g = Graph.fromDistinctList - [ N c (componentName c) (componentDeps c) - | c <- pkgBuildableComponents pkg_descr - , componentEnabled enabled c ] - in case Graph.cycles g of - [] -> Right g - ccycles -> Left [ componentName c | N c _ _ <- concat ccycles ] + let g = + Graph.fromDistinctList + [ N c (componentName c) (componentDeps c) + | c <- pkgBuildableComponents pkg_descr + , componentEnabled enabled c + ] + in case Graph.cycles g of + [] -> Right g + ccycles -> Left [componentName c | N c _ _ <- concat ccycles] where -- The dependencies for the given component componentDeps component = - toolDependencies ++ libDependencies + toolDependencies ++ libDependencies where bi = componentBuildInfo component toolDependencies = CExeName <$> getAllInternalToolDependencies pkg_descr bi libDependencies = do - Dependency pkgname _ lns <- targetBuildDepends bi - guard (pkgname == packageName pkg_descr) + Dependency pkgname _ lns <- targetBuildDepends bi + guard (pkgname == packageName pkg_descr) - ln <- NES.toList lns - return (CLibName ln) + ln <- NES.toList lns + return (CLibName ln) -- | Given the package description and a 'PackageDescription' (used -- to determine if a package name is internal or not), sort the -- components in dependency order (fewest dependencies first). This is -- NOT necessarily the build order (although it is in the absence of -- Backpack.) --- -componentsGraphToList :: ComponentsGraph - -> ComponentsWithDeps +componentsGraphToList + :: ComponentsGraph + -> ComponentsWithDeps componentsGraphToList = - map (\(N c _ cs) -> (c, cs)) . Graph.revTopSort + map (\(N c _ cs) -> (c, cs)) . Graph.revTopSort -- | Error message when there is a cycle; takes the SCC of components. componentCycleMsg :: PackageIdentifier -> [ComponentName] -> Doc componentCycleMsg pn cnames = - text "Components in the package" <+> pretty pn <+> text "depend on each other in a cyclic way:" - $$ - text (intercalate " depends on " - [ "'" ++ showComponentName cname ++ "'" - | cname <- cnames ++ maybeToList (safeHead cnames) ]) + text "Components in the package" + <+> pretty pn + <+> text "depend on each other in a cyclic way:" + $$ text + ( intercalate + " depends on " + [ "'" ++ showComponentName cname ++ "'" + | cname <- cnames ++ maybeToList (safeHead cnames) + ] + ) diff --git a/Cabal/src/Distribution/Backpack/Configure.hs b/Cabal/src/Distribution/Backpack/Configure.hs index 60764fdf32d..7d85d487fc8 100644 --- a/Cabal/src/Distribution/Backpack/Configure.hs +++ b/Cabal/src/Distribution/Backpack/Configure.hs @@ -1,56 +1,59 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoMonoLocalBinds #-} -{-# LANGUAGE NondecreasingIndentation #-} -- | See -- -- WARNING: The contents of this module are HIGHLY experimental. -- We may refactor it under you. -module Distribution.Backpack.Configure ( - configureComponentLocalBuildInfos, -) where +module Distribution.Backpack.Configure + ( configureComponentLocalBuildInfos + ) where -import Prelude () import Distribution.Compat.Prelude hiding ((<>)) +import Prelude () import Distribution.Backpack -import Distribution.Backpack.FullUnitId -import Distribution.Backpack.PreExistingComponent +import Distribution.Backpack.ComponentsGraph import Distribution.Backpack.ConfiguredComponent +import Distribution.Backpack.FullUnitId +import Distribution.Backpack.Id import Distribution.Backpack.LinkedComponent +import Distribution.Backpack.PreExistingComponent import Distribution.Backpack.ReadyComponent -import Distribution.Backpack.ComponentsGraph -import Distribution.Backpack.Id -import Distribution.Simple.Compiler -import Distribution.Package +import Distribution.Compat.Graph (Graph, IsNode (..)) +import qualified Distribution.Compat.Graph as Graph +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo + , emptyInstalledPackageInfo + ) import qualified Distribution.InstalledPackageInfo as Installed -import Distribution.InstalledPackageInfo (InstalledPackageInfo - ,emptyInstalledPackageInfo) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import Distribution.PackageDescription import Distribution.ModuleName +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Simple.Compiler import Distribution.Simple.Flag import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Types.AnnotatedId -import Distribution.Types.ComponentRequestedSpec import Distribution.Types.ComponentInclude +import Distribution.Types.ComponentRequestedSpec import Distribution.Types.MungedPackageName -import Distribution.Verbosity -import qualified Distribution.Compat.Graph as Graph -import Distribution.Compat.Graph (Graph, IsNode(..)) import Distribution.Utils.LogProgress +import Distribution.Verbosity import Data.Either - ( lefts ) -import qualified Data.Set as Set + ( lefts + ) import qualified Data.Map as Map +import qualified Data.Set as Set import Distribution.Pretty import Text.PrettyPrint @@ -59,75 +62,123 @@ import Text.PrettyPrint ------------------------------------------------------------------------------ configureComponentLocalBuildInfos - :: Verbosity - -> Bool -- use_external_internal_deps - -> ComponentRequestedSpec - -> Bool -- deterministic - -> Flag String -- configIPID - -> Flag ComponentId -- configCID - -> PackageDescription - -> [PreExistingComponent] - -> FlagAssignment -- configConfigurationsFlags - -> [(ModuleName, Module)] -- configInstantiateWith - -> InstalledPackageIndex - -> Compiler - -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex) + :: Verbosity + -> Bool -- use_external_internal_deps + -> ComponentRequestedSpec + -> Bool -- deterministic + -> Flag String -- configIPID + -> Flag ComponentId -- configCID + -> PackageDescription + -> [PreExistingComponent] + -> FlagAssignment -- configConfigurationsFlags + -> [(ModuleName, Module)] -- configInstantiateWith + -> InstalledPackageIndex + -> Compiler + -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex) configureComponentLocalBuildInfos - verbosity use_external_internal_deps enabled deterministic ipid_flag cid_flag pkg_descr - prePkgDeps flagAssignment instantiate_with installedPackageSet comp = do + verbosity + use_external_internal_deps + enabled + deterministic + ipid_flag + cid_flag + pkg_descr + prePkgDeps + flagAssignment + instantiate_with + installedPackageSet + comp = do -- NB: In single component mode, this returns a *single* component. -- In this graph, the graph is NOT closed. graph0 <- case mkComponentsGraph enabled pkg_descr of - Left ccycle -> dieProgress (componentCycleMsg (package pkg_descr) ccycle) - Right g -> return (componentsGraphToList g) - infoProgress $ hang (text "Source component graph:") 4 - (dispComponentsWithDeps graph0) + Left ccycle -> dieProgress (componentCycleMsg (package pkg_descr) ccycle) + Right g -> return (componentsGraphToList g) + infoProgress $ + hang + (text "Source component graph:") + 4 + (dispComponentsWithDeps graph0) - let conf_pkg_map = Map.fromListWith Map.union - [(pc_pkgname pkg, - Map.singleton (pc_compname pkg) - (AnnotatedId { - ann_id = pc_cid pkg, - ann_pid = packageId pkg, - ann_cname = pc_compname pkg - })) - | pkg <- prePkgDeps] - graph1 <- toConfiguredComponents use_external_internal_deps - flagAssignment - deterministic ipid_flag cid_flag pkg_descr - conf_pkg_map (map fst graph0) - infoProgress $ hang (text "Configured component graph:") 4 - (vcat (map dispConfiguredComponent graph1)) + let conf_pkg_map = + Map.fromListWith + Map.union + [ ( pc_pkgname pkg + , Map.singleton + (pc_compname pkg) + ( AnnotatedId + { ann_id = pc_cid pkg + , ann_pid = packageId pkg + , ann_cname = pc_compname pkg + } + ) + ) + | pkg <- prePkgDeps + ] + graph1 <- + toConfiguredComponents + use_external_internal_deps + flagAssignment + deterministic + ipid_flag + cid_flag + pkg_descr + conf_pkg_map + (map fst graph0) + infoProgress $ + hang + (text "Configured component graph:") + 4 + (vcat (map dispConfiguredComponent graph1)) - let shape_pkg_map = Map.fromList + let shape_pkg_map = + Map.fromList [ (pc_cid pkg, (pc_open_uid pkg, pc_shape pkg)) - | pkg <- prePkgDeps] + | pkg <- prePkgDeps + ] uid_lookup def_uid - | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid - = FullUnitId (Installed.installedComponentId pkg) - (Map.fromList (Installed.instantiatedWith pkg)) - | otherwise = error ("uid_lookup: " ++ prettyShow uid) - where uid = unDefUnitId def_uid - graph2 <- toLinkedComponents verbosity uid_lookup - (package pkg_descr) shape_pkg_map graph1 + | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid = + FullUnitId + (Installed.installedComponentId pkg) + (Map.fromList (Installed.instantiatedWith pkg)) + | otherwise = error ("uid_lookup: " ++ prettyShow uid) + where + uid = unDefUnitId def_uid + graph2 <- + toLinkedComponents + verbosity + uid_lookup + (package pkg_descr) + shape_pkg_map + graph1 infoProgress $ - hang (text "Linked component graph:") 4 - (vcat (map dispLinkedComponent graph2)) + hang + (text "Linked component graph:") + 4 + (vcat (map dispLinkedComponent graph2)) - let pid_map = Map.fromList $ + let pid_map = + Map.fromList $ [ (pc_uid pkg, pc_munged_id pkg) - | pkg <- prePkgDeps] ++ - [ (Installed.installedUnitId pkg, mungedId pkg) - | (_, Module uid _) <- instantiate_with - , Just pkg <- [PackageIndex.lookupUnitId - installedPackageSet (unDefUnitId uid)] ] + | pkg <- prePkgDeps + ] + ++ [ (Installed.installedUnitId pkg, mungedId pkg) + | (_, Module uid _) <- instantiate_with + , Just pkg <- + [ PackageIndex.lookupUnitId + installedPackageSet + (unDefUnitId uid) + ] + ] subst = Map.fromList instantiate_with graph3 = toReadyComponents pid_map subst graph2 graph4 = Graph.revTopSort (Graph.fromDistinctList graph3) - infoProgress $ hang (text "Ready component graph:") 4 - (vcat (map dispReadyComponent graph4)) + infoProgress $ + hang + (text "Ready component graph:") + 4 + (vcat (map dispReadyComponent graph4)) toComponentLocalBuildInfos comp installedPackageSet pkg_descr prePkgDeps graph4 @@ -136,67 +187,81 @@ configureComponentLocalBuildInfos ------------------------------------------------------------------------------ toComponentLocalBuildInfos - :: Compiler - -> InstalledPackageIndex -- FULL set - -> PackageDescription - -> [PreExistingComponent] -- external package deps - -> [ReadyComponent] - -> LogProgress ([ComponentLocalBuildInfo], - InstalledPackageIndex) -- only relevant packages + :: Compiler + -> InstalledPackageIndex -- FULL set + -> PackageDescription + -> [PreExistingComponent] -- external package deps + -> [ReadyComponent] + -> LogProgress + ( [ComponentLocalBuildInfo] + , InstalledPackageIndex -- only relevant packages + ) toComponentLocalBuildInfos - comp installedPackageSet pkg_descr externalPkgDeps graph = do + comp + installedPackageSet + pkg_descr + externalPkgDeps + graph = do -- Check and make sure that every instantiated component exists. -- We have to do this now, because prior to linking/instantiating -- we don't actually know what the full set of 'UnitId's we need -- are. - let -- TODO: This is actually a bit questionable performance-wise, - -- since we will pay for the ALL installed packages even if - -- they are not related to what we are building. This was true - -- in the old configure code. - external_graph :: Graph (Either InstalledPackageInfo ReadyComponent) - external_graph = Graph.fromDistinctList - . map Left - $ PackageIndex.allPackages installedPackageSet - internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent) - internal_graph = Graph.fromDistinctList - . map Right - $ graph - combined_graph = Graph.unionRight external_graph internal_graph - local_graph = fromMaybe (error "toComponentLocalBuildInfos: closure returned Nothing") - $ Graph.closure combined_graph (map nodeKey graph) - -- The database of transitively reachable installed packages that the - -- external components the package (as a whole) depends on. This will be - -- used in several ways: - -- - -- * We'll use it to do a consistency check so we're not depending - -- on multiple versions of the same package (TODO: someday relax - -- this for private dependencies.) See right below. - -- - -- * We'll pass it on in the LocalBuildInfo, where preprocessors - -- and other things will incorrectly use it to determine what - -- the include paths and everything should be. - -- - packageDependsIndex = PackageIndex.fromList (lefts local_graph) - fullIndex = Graph.fromDistinctList local_graph + let + -- TODO: This is actually a bit questionable performance-wise, + -- since we will pay for the ALL installed packages even if + -- they are not related to what we are building. This was true + -- in the old configure code. + external_graph :: Graph (Either InstalledPackageInfo ReadyComponent) + external_graph = + Graph.fromDistinctList + . map Left + $ PackageIndex.allPackages installedPackageSet + internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent) + internal_graph = + Graph.fromDistinctList + . map Right + $ graph + combined_graph = Graph.unionRight external_graph internal_graph + local_graph = + fromMaybe (error "toComponentLocalBuildInfos: closure returned Nothing") $ + Graph.closure combined_graph (map nodeKey graph) + -- The database of transitively reachable installed packages that the + -- external components the package (as a whole) depends on. This will be + -- used in several ways: + -- + -- * We'll use it to do a consistency check so we're not depending + -- on multiple versions of the same package (TODO: someday relax + -- this for private dependencies.) See right below. + -- + -- * We'll pass it on in the LocalBuildInfo, where preprocessors + -- and other things will incorrectly use it to determine what + -- the include paths and everything should be. + -- + packageDependsIndex = PackageIndex.fromList (lefts local_graph) + fullIndex = Graph.fromDistinctList local_graph case Graph.broken fullIndex of - [] -> return () - broken -> - -- TODO: ppr this - dieProgress . text $ - "The following packages are broken because other" - ++ " packages they depend on are missing. These broken " - ++ "packages must be rebuilt before they can be used.\n" - -- TODO: Undupe. - ++ unlines [ "installed package " - ++ prettyShow (packageId pkg) - ++ " is broken due to missing package " - ++ intercalate ", " (map prettyShow deps) - | (Left pkg, deps) <- broken ] - ++ unlines [ "planned package " - ++ prettyShow (packageId pkg) - ++ " is broken due to missing package " - ++ intercalate ", " (map prettyShow deps) - | (Right pkg, deps) <- broken ] + [] -> return () + broken -> + -- TODO: ppr this + dieProgress . text $ + "The following packages are broken because other" + ++ " packages they depend on are missing. These broken " + ++ "packages must be rebuilt before they can be used.\n" + -- TODO: Undupe. + ++ unlines + [ "installed package " + ++ prettyShow (packageId pkg) + ++ " is broken due to missing package " + ++ intercalate ", " (map prettyShow deps) + | (Left pkg, deps) <- broken + ] + ++ unlines + [ "planned package " + ++ prettyShow (packageId pkg) + ++ " is broken due to missing package " + ++ intercalate ", " (map prettyShow deps) + | (Right pkg, deps) <- broken + ] -- In this section, we'd like to look at the 'packageDependsIndex' -- and see if we've picked multiple versions of the same @@ -213,25 +278,34 @@ toComponentLocalBuildInfos -- -- TODO: This is probably wrong for Backpack let pseudoTopPkg :: InstalledPackageInfo - pseudoTopPkg = emptyInstalledPackageInfo { - Installed.installedUnitId = mkLegacyUnitId (packageId pkg_descr), - Installed.sourcePackageId = packageId pkg_descr, - Installed.depends = map pc_uid externalPkgDeps - } + pseudoTopPkg = + emptyInstalledPackageInfo + { Installed.installedUnitId = mkLegacyUnitId (packageId pkg_descr) + , Installed.sourcePackageId = packageId pkg_descr + , Installed.depends = map pc_uid externalPkgDeps + } case PackageIndex.dependencyInconsistencies - . PackageIndex.insert pseudoTopPkg - $ packageDependsIndex of + . PackageIndex.insert pseudoTopPkg + $ packageDependsIndex of [] -> return () inconsistencies -> warnProgress $ - hang (text "This package indirectly depends on multiple versions of the same" <+> - text "package. This is very likely to cause a compile failure.") 2 - (vcat [ text "package" <+> pretty (packageName user) <+> - parens (pretty (installedUnitId user)) <+> text "requires" <+> - pretty inst - | (_dep_key, insts) <- inconsistencies - , (inst, users) <- insts - , user <- users ]) + hang + ( text "This package indirectly depends on multiple versions of the same" + <+> text "package. This is very likely to cause a compile failure." + ) + 2 + ( vcat + [ text "package" + <+> pretty (packageName user) + <+> parens (pretty (installedUnitId user)) + <+> text "requires" + <+> pretty inst + | (_dep_key, insts) <- inconsistencies + , (inst, users) <- insts + , user <- users + ] + ) let clbis = mkLinkedComponentsLocalBuildInfo comp graph -- forM clbis $ \(clbi,deps) -> info verbosity $ "UNIT" ++ hashUnitId (componentUnitId clbi) ++ "\n" ++ intercalate "\n" (map hashUnitId deps) return (clbis, packageDependsIndex) @@ -241,119 +315,124 @@ toComponentLocalBuildInfos -- -- This conversion is lossy; we lose some invariants from ReadyComponent mkLinkedComponentsLocalBuildInfo - :: Compiler - -> [ReadyComponent] - -> [ComponentLocalBuildInfo] + :: Compiler + -> [ReadyComponent] + -> [ComponentLocalBuildInfo] mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs where internalUnits = Set.fromList (map rc_uid rcs) isInternal x = Set.member x internalUnits go rc = case rc_component rc of - CLib lib -> - let convModuleExport (modname', (Module uid modname)) - | this_uid == unDefUnitId uid - , modname' == modname - = Installed.ExposedModule modname' Nothing - | otherwise - = Installed.ExposedModule modname' - (Just (OpenModule (DefiniteUnitId uid) modname)) - convOpenModuleExport (modname', modu@(OpenModule uid modname)) - | uid == this_open_uid - , modname' == modname - = Installed.ExposedModule modname' Nothing - | otherwise - = Installed.ExposedModule modname' (Just modu) - convOpenModuleExport (_, OpenModuleVar _) - = error "convOpenModuleExport: top-level modvar" - exports = + CLib lib -> + let convModuleExport (modname', (Module uid modname)) + | this_uid == unDefUnitId uid + , modname' == modname = + Installed.ExposedModule modname' Nothing + | otherwise = + Installed.ExposedModule + modname' + (Just (OpenModule (DefiniteUnitId uid) modname)) + convOpenModuleExport (modname', modu@(OpenModule uid modname)) + | uid == this_open_uid + , modname' == modname = + Installed.ExposedModule modname' Nothing + | otherwise = + Installed.ExposedModule modname' (Just modu) + convOpenModuleExport (_, OpenModuleVar _) = + error "convOpenModuleExport: top-level modvar" + exports = -- Loses invariants case rc_i rc of - Left indefc -> map convOpenModuleExport - $ Map.toList (indefc_provides indefc) - Right instc -> map convModuleExport - $ Map.toList (instc_provides instc) - insts = + Left indefc -> + map convOpenModuleExport $ + Map.toList (indefc_provides indefc) + Right instc -> + map convModuleExport $ + Map.toList (instc_provides instc) + insts = case rc_i rc of - Left indefc -> [ (m, OpenModuleVar m) | m <- indefc_requires indefc ] - Right instc -> [ (m, OpenModule (DefiniteUnitId uid') m') - | (m, Module uid' m') <- instc_insts instc ] - - compat_name = MungedPackageName (packageName rc) (libName lib) - compat_key = computeCompatPackageKey comp compat_name (packageVersion rc) this_uid + Left indefc -> [(m, OpenModuleVar m) | m <- indefc_requires indefc] + Right instc -> + [ (m, OpenModule (DefiniteUnitId uid') m') + | (m, Module uid' m') <- instc_insts instc + ] - in LibComponentLocalBuildInfo { - componentPackageDeps = cpds, - componentUnitId = this_uid, - componentComponentId = this_cid, - componentInstantiatedWith = insts, - componentIsIndefinite_ = is_indefinite, - componentLocalName = cname, - componentInternalDeps = internal_deps, - componentExeDeps = exe_deps, - componentIncludes = includes, - componentExposedModules = exports, - componentIsPublic = rc_public rc, - componentCompatPackageKey = compat_key, - componentCompatPackageName = compat_name - } - CFLib _ -> - FLibComponentLocalBuildInfo { - componentUnitId = this_uid, - componentComponentId = this_cid, - componentLocalName = cname, - componentPackageDeps = cpds, - componentExeDeps = exe_deps, - componentInternalDeps = internal_deps, - componentIncludes = includes - } - CExe _ -> - ExeComponentLocalBuildInfo { - componentUnitId = this_uid, - componentComponentId = this_cid, - componentLocalName = cname, - componentPackageDeps = cpds, - componentExeDeps = exe_deps, - componentInternalDeps = internal_deps, - componentIncludes = includes - } - CTest _ -> - TestComponentLocalBuildInfo { - componentUnitId = this_uid, - componentComponentId = this_cid, - componentLocalName = cname, - componentPackageDeps = cpds, - componentExeDeps = exe_deps, - componentInternalDeps = internal_deps, - componentIncludes = includes - } - CBench _ -> - BenchComponentLocalBuildInfo { - componentUnitId = this_uid, - componentComponentId = this_cid, - componentLocalName = cname, - componentPackageDeps = cpds, - componentExeDeps = exe_deps, - componentInternalDeps = internal_deps, - componentIncludes = includes - } - where - this_uid = rc_uid rc - this_open_uid = rc_open_uid rc - this_cid = rc_cid rc - cname = componentName (rc_component rc) - cpds = rc_depends rc - exe_deps = map ann_id $ rc_exe_deps rc - is_indefinite = - case rc_i rc of + compat_name = MungedPackageName (packageName rc) (libName lib) + compat_key = computeCompatPackageKey comp compat_name (packageVersion rc) this_uid + in LibComponentLocalBuildInfo + { componentPackageDeps = cpds + , componentUnitId = this_uid + , componentComponentId = this_cid + , componentInstantiatedWith = insts + , componentIsIndefinite_ = is_indefinite + , componentLocalName = cname + , componentInternalDeps = internal_deps + , componentExeDeps = exe_deps + , componentIncludes = includes + , componentExposedModules = exports + , componentIsPublic = rc_public rc + , componentCompatPackageKey = compat_key + , componentCompatPackageName = compat_name + } + CFLib _ -> + FLibComponentLocalBuildInfo + { componentUnitId = this_uid + , componentComponentId = this_cid + , componentLocalName = cname + , componentPackageDeps = cpds + , componentExeDeps = exe_deps + , componentInternalDeps = internal_deps + , componentIncludes = includes + } + CExe _ -> + ExeComponentLocalBuildInfo + { componentUnitId = this_uid + , componentComponentId = this_cid + , componentLocalName = cname + , componentPackageDeps = cpds + , componentExeDeps = exe_deps + , componentInternalDeps = internal_deps + , componentIncludes = includes + } + CTest _ -> + TestComponentLocalBuildInfo + { componentUnitId = this_uid + , componentComponentId = this_cid + , componentLocalName = cname + , componentPackageDeps = cpds + , componentExeDeps = exe_deps + , componentInternalDeps = internal_deps + , componentIncludes = includes + } + CBench _ -> + BenchComponentLocalBuildInfo + { componentUnitId = this_uid + , componentComponentId = this_cid + , componentLocalName = cname + , componentPackageDeps = cpds + , componentExeDeps = exe_deps + , componentInternalDeps = internal_deps + , componentIncludes = includes + } + where + this_uid = rc_uid rc + this_open_uid = rc_open_uid rc + this_cid = rc_cid rc + cname = componentName (rc_component rc) + cpds = rc_depends rc + exe_deps = map ann_id $ rc_exe_deps rc + is_indefinite = + case rc_i rc of Left _ -> True Right _ -> False - includes = - map (\ci -> (ci_id ci, ci_renaming ci)) $ + includes = + map (\ci -> (ci_id ci, ci_renaming ci)) $ case rc_i rc of - Left indefc -> - indefc_includes indefc - Right instc -> - map (\ci -> ci { ci_ann_id = fmap DefiniteUnitId (ci_ann_id ci) }) - (instc_includes instc) - internal_deps = filter isInternal (nodeNeighbors rc) + Left indefc -> + indefc_includes indefc + Right instc -> + map + (\ci -> ci{ci_ann_id = fmap DefiniteUnitId (ci_ann_id ci)}) + (instc_includes instc) + internal_deps = filter isInternal (nodeNeighbors rc) diff --git a/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs b/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs index 5f40fc6085a..79408f0ffa2 100644 --- a/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs +++ b/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs @@ -1,80 +1,68 @@ {-# LANGUAGE PatternGuards #-} --- | See -module Distribution.Backpack.ConfiguredComponent ( - ConfiguredComponent(..), - cc_name, - cc_cid, - cc_pkgid, - toConfiguredComponent, - toConfiguredComponents, - dispConfiguredComponent, - - ConfiguredComponentMap, - extendConfiguredComponentMap, - -- TODO: Should go somewhere else - newPackageDepsBehaviour -) where +-- | See +module Distribution.Backpack.ConfiguredComponent + ( ConfiguredComponent (..) + , cc_name + , cc_cid + , cc_pkgid + , toConfiguredComponent + , toConfiguredComponents + , dispConfiguredComponent + , ConfiguredComponentMap + , extendConfiguredComponentMap + -- TODO: Should go somewhere else + , newPackageDepsBehaviour + ) where -import Prelude () import Distribution.Compat.Prelude hiding ((<>)) +import Prelude () import Distribution.Backpack.Id import Distribution.CabalSpecVersion -import Distribution.Types.AnnotatedId -import Distribution.Types.Dependency -import Distribution.Types.ExeDependency -import Distribution.Types.IncludeRenaming -import Distribution.Types.ComponentId -import Distribution.Types.PackageId -import Distribution.Types.PackageName -import Distribution.Types.Mixin -import Distribution.Types.ComponentName -import Distribution.Types.LibraryName -import Distribution.Types.ComponentInclude import Distribution.Package import Distribution.PackageDescription import Distribution.Simple.BuildToolDepends -import Distribution.Simple.Flag ( Flag ) +import Distribution.Simple.Flag (Flag) import Distribution.Simple.LocalBuildInfo +import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentInclude +import Distribution.Utils.Generic import Distribution.Utils.LogProgress import Distribution.Utils.MapAccum -import Distribution.Utils.Generic import Control.Monad +import qualified Data.Map as Map import qualified Data.Set as Set import qualified Distribution.Compat.NonEmptySet as NonEmptySet -import qualified Data.Map as Map import Distribution.Pretty -import Text.PrettyPrint (Doc, hang, text, vcat, hsep, quotes, ($$)) +import Text.PrettyPrint (Doc, hang, hsep, quotes, text, vcat, ($$)) import qualified Text.PrettyPrint as PP -- | A configured component, we know exactly what its 'ComponentId' is, -- and the 'ComponentId's of the things it depends on. -data ConfiguredComponent - = ConfiguredComponent { - -- | Unique identifier of component, plus extra useful info. - cc_ann_id :: AnnotatedId ComponentId, - -- | The fragment of syntax from the Cabal file describing this - -- component. - cc_component :: Component, - -- | Is this the public library component of the package? - -- (If we invoke Setup with an instantiation, this is the - -- component the instantiation applies to.) - -- Note that in one-component configure mode, this is - -- always True, because any component is the "public" one.) - cc_public :: Bool, - -- | Dependencies on executables from @build-tools@ and - -- @build-tool-depends@. - cc_exe_deps :: [AnnotatedId ComponentId], - -- | The mixins of this package, including both explicit (from - -- the @mixins@ field) and implicit (from @build-depends@). Not - -- mix-in linked yet; component configuration only looks at - -- 'ComponentId's. - cc_includes :: [ComponentInclude ComponentId IncludeRenaming] - } - +data ConfiguredComponent = ConfiguredComponent + { cc_ann_id :: AnnotatedId ComponentId + -- ^ Unique identifier of component, plus extra useful info. + , cc_component :: Component + -- ^ The fragment of syntax from the Cabal file describing this + -- component. + , cc_public :: Bool + -- ^ Is this the public library component of the package? + -- (If we invoke Setup with an instantiation, this is the + -- component the instantiation applies to.) + -- Note that in one-component configure mode, this is + -- always True, because any component is the "public" one.) + , cc_exe_deps :: [AnnotatedId ComponentId] + -- ^ Dependencies on executables from @build-tools@ and + -- @build-tool-depends@. + , cc_includes :: [ComponentInclude ComponentId IncludeRenaming] + -- ^ The mixins of this package, including both explicit (from + -- the @mixins@ field) and implicit (from @build-depends@). Not + -- mix-in linked yet; component configuration only looks at + -- 'ComponentId's. + } -- | Uniquely identifies a configured component. cc_cid :: ConfiguredComponent -> ComponentId @@ -93,110 +81,132 @@ cc_name = ann_cname . cc_ann_id -- | Pretty-print a 'ConfiguredComponent'. dispConfiguredComponent :: ConfiguredComponent -> Doc dispConfiguredComponent cc = - hang (text "component" <+> pretty (cc_cid cc)) 4 - (vcat [ hsep $ [ text "include" - , pretty (ci_id incl), pretty (ci_renaming incl) ] - | incl <- cc_includes cc - ]) + hang + (text "component" <+> pretty (cc_cid cc)) + 4 + ( vcat + [ hsep $ + [ text "include" + , pretty (ci_id incl) + , pretty (ci_renaming incl) + ] + | incl <- cc_includes cc + ] + ) -- | Construct a 'ConfiguredComponent', given that the 'ComponentId' -- and library/executable dependencies are known. The primary -- work this does is handling implicit @backpack-include@ fields. mkConfiguredComponent - :: PackageDescription - -> ComponentId - -> [AnnotatedId ComponentId] -- lib deps - -> [AnnotatedId ComponentId] -- exe deps - -> Component - -> LogProgress ConfiguredComponent + :: PackageDescription + -> ComponentId + -> [AnnotatedId ComponentId] -- lib deps + -> [AnnotatedId ComponentId] -- exe deps + -> Component + -> LogProgress ConfiguredComponent mkConfiguredComponent pkg_descr this_cid lib_deps exe_deps component = do - -- Resolve each @mixins@ into the actual dependency - -- from @lib_deps@. - explicit_includes <- forM (mixins bi) $ \(Mixin pn ln rns) -> do - aid <- case Map.lookup (pn, CLibName ln) deps_map of - Nothing -> - dieProgress $ - text "Mix-in refers to non-existent library" <+> - quotes (pretty pn <<>> prettyLN ln) $$ - text "(did you forget to add the package to build-depends?)" - Just r -> return r - return ComponentInclude { - ci_ann_id = aid, - ci_renaming = rns, - ci_implicit = False - } + -- Resolve each @mixins@ into the actual dependency + -- from @lib_deps@. + explicit_includes <- forM (mixins bi) $ \(Mixin pn ln rns) -> do + aid <- case Map.lookup (pn, CLibName ln) deps_map of + Nothing -> + dieProgress $ + text "Mix-in refers to non-existent library" + <+> quotes (pretty pn <<>> prettyLN ln) + $$ text "(did you forget to add the package to build-depends?)" + Just r -> return r + return + ComponentInclude + { ci_ann_id = aid + , ci_renaming = rns + , ci_implicit = False + } - -- Any @build-depends@ which is not explicitly mentioned in - -- @backpack-include@ is converted into an "implicit" include. - let used_explicitly = Set.fromList (map ci_id explicit_includes) - implicit_includes - = map (\aid -> ComponentInclude { - ci_ann_id = aid, - ci_renaming = defaultIncludeRenaming, - ci_implicit = True - }) - $ filter (flip Set.notMember used_explicitly . ann_id) lib_deps + -- Any @build-depends@ which is not explicitly mentioned in + -- @backpack-include@ is converted into an "implicit" include. + let used_explicitly = Set.fromList (map ci_id explicit_includes) + implicit_includes = + map + ( \aid -> + ComponentInclude + { ci_ann_id = aid + , ci_renaming = defaultIncludeRenaming + , ci_implicit = True + } + ) + $ filter (flip Set.notMember used_explicitly . ann_id) lib_deps - return ConfiguredComponent { - cc_ann_id = AnnotatedId { - ann_id = this_cid, - ann_pid = package pkg_descr, - ann_cname = componentName component - }, - cc_component = component, - cc_public = is_public, - cc_exe_deps = exe_deps, - cc_includes = explicit_includes ++ implicit_includes - } + return + ConfiguredComponent + { cc_ann_id = + AnnotatedId + { ann_id = this_cid + , ann_pid = package pkg_descr + , ann_cname = componentName component + } + , cc_component = component + , cc_public = is_public + , cc_exe_deps = exe_deps + , cc_includes = explicit_includes ++ implicit_includes + } where bi :: BuildInfo bi = componentBuildInfo component prettyLN :: LibraryName -> Doc - prettyLN LMainLibName = PP.empty + prettyLN LMainLibName = PP.empty prettyLN (LSubLibName n) = PP.colon <<>> pretty n deps_map :: Map (PackageName, ComponentName) (AnnotatedId ComponentId) - deps_map = Map.fromList [ ((packageName dep, ann_cname dep), dep) - | dep <- lib_deps ] + deps_map = + Map.fromList + [ ((packageName dep, ann_cname dep), dep) + | dep <- lib_deps + ] is_public = componentName component == CLibName LMainLibName type ConfiguredComponentMap = - Map PackageName (Map ComponentName (AnnotatedId ComponentId)) + Map PackageName (Map ComponentName (AnnotatedId ComponentId)) toConfiguredComponent - :: PackageDescription - -> ComponentId - -> ConfiguredComponentMap - -> ConfiguredComponentMap - -> Component - -> LogProgress ConfiguredComponent + :: PackageDescription + -> ComponentId + -> ConfiguredComponentMap + -> ConfiguredComponentMap + -> Component + -> LogProgress ConfiguredComponent toConfiguredComponent pkg_descr this_cid lib_dep_map exe_dep_map component = do - lib_deps <- - if newPackageDepsBehaviour pkg_descr - then fmap concat $ forM (targetBuildDepends bi) $ - \(Dependency name _ sublibs) -> do - pkg <- case Map.lookup name lib_dep_map of - Nothing -> - dieProgress $ - text "Dependency on unbuildable" <+> - text "package" <+> pretty name - Just p -> return p - -- Return all library components - forM (NonEmptySet.toList sublibs) $ \lib -> - let comp = CLibName lib in - case Map.lookup comp pkg of - Nothing -> - dieProgress $ - text "Dependency on unbuildable" <+> - text (showLibraryName lib) <+> - text "from" <+> pretty name - Just v -> return v - else return old_style_lib_deps - mkConfiguredComponent - pkg_descr this_cid - lib_deps exe_deps component + lib_deps <- + if newPackageDepsBehaviour pkg_descr + then fmap concat $ + forM (targetBuildDepends bi) $ + \(Dependency name _ sublibs) -> do + pkg <- case Map.lookup name lib_dep_map of + Nothing -> + dieProgress $ + text "Dependency on unbuildable" + <+> text "package" + <+> pretty name + Just p -> return p + -- Return all library components + forM (NonEmptySet.toList sublibs) $ \lib -> + let comp = CLibName lib + in case Map.lookup comp pkg of + Nothing -> + dieProgress $ + text "Dependency on unbuildable" + <+> text (showLibraryName lib) + <+> text "from" + <+> pretty name + Just v -> return v + else return old_style_lib_deps + mkConfiguredComponent + pkg_descr + this_cid + lib_deps + exe_deps + component where bi = componentBuildInfo component -- lib_dep_map contains a mix of internal and external deps. @@ -206,62 +216,84 @@ toConfiguredComponent pkg_descr this_cid lib_dep_map exe_dep_map component = do -- this is not supported by old-style deps behavior -- because it would imply a cyclic dependency for the -- library itself. - old_style_lib_deps = [ e - | (pn, comp_map) <- Map.toList lib_dep_map - , pn /= packageName pkg_descr - , (cn, e) <- Map.toList comp_map - , cn == CLibName LMainLibName ] + old_style_lib_deps = + [ e + | (pn, comp_map) <- Map.toList lib_dep_map + , pn /= packageName pkg_descr + , (cn, e) <- Map.toList comp_map + , cn == CLibName LMainLibName + ] -- We have to nub here, because 'getAllToolDependencies' may return -- duplicates (see #4986). (NB: This is not needed for lib_deps, -- since those elaborate into includes, for which there explicitly -- may be multiple instances of a package) - exe_deps = ordNub $ + exe_deps = + ordNub $ [ exe | ExeDependency pn cn _ <- getAllToolDependencies pkg_descr bi - -- The error suppression here is important, because in general + , -- The error suppression here is important, because in general -- we won't know about external dependencies (e.g., 'happy') -- which the package is attempting to use (those deps are only -- fed in when cabal-install uses this codepath.) -- TODO: Let cabal-install request errors here - , Just exe <- [Map.lookup (CExeName cn) =<< Map.lookup pn exe_dep_map] + Just exe <- [Map.lookup (CExeName cn) =<< Map.lookup pn exe_dep_map] ] -- | Also computes the 'ComponentId', and sets cc_public if necessary. -- This is Cabal-only; cabal-install won't use this. toConfiguredComponent' - :: Bool -- use_external_internal_deps - -> FlagAssignment - -> PackageDescription - -> Bool -- deterministic - -> Flag String -- configIPID (todo: remove me) - -> Flag ComponentId -- configCID - -> ConfiguredComponentMap - -> Component - -> LogProgress ConfiguredComponent -toConfiguredComponent' use_external_internal_deps flags - pkg_descr deterministic ipid_flag cid_flag - dep_map component = do - cc <- toConfiguredComponent - pkg_descr this_cid - dep_map dep_map component - return $ if use_external_internal_deps - then cc { cc_public = True } - else cc - where - -- TODO: pass component names to it too! - this_cid = computeComponentId deterministic ipid_flag cid_flag - (package pkg_descr) (componentName component) (Just (deps, flags)) - deps = [ ann_id aid | m <- Map.elems dep_map - , aid <- Map.elems m ] + :: Bool -- use_external_internal_deps + -> FlagAssignment + -> PackageDescription + -> Bool -- deterministic + -> Flag String -- configIPID (todo: remove me) + -> Flag ComponentId -- configCID + -> ConfiguredComponentMap + -> Component + -> LogProgress ConfiguredComponent +toConfiguredComponent' + use_external_internal_deps + flags + pkg_descr + deterministic + ipid_flag + cid_flag + dep_map + component = do + cc <- + toConfiguredComponent + pkg_descr + this_cid + dep_map + dep_map + component + return $ + if use_external_internal_deps + then cc{cc_public = True} + else cc + where + -- TODO: pass component names to it too! + this_cid = + computeComponentId + deterministic + ipid_flag + cid_flag + (package pkg_descr) + (componentName component) + (Just (deps, flags)) + deps = + [ ann_id aid | m <- Map.elems dep_map, aid <- Map.elems m + ] extendConfiguredComponentMap - :: ConfiguredComponent - -> ConfiguredComponentMap - -> ConfiguredComponentMap + :: ConfiguredComponent + -> ConfiguredComponentMap + -> ConfiguredComponentMap extendConfiguredComponentMap cc = - Map.insertWith Map.union - (pkgName (cc_pkgid cc)) - (Map.singleton (cc_name cc) (cc_ann_id cc)) + Map.insertWith + Map.union + (pkgName (cc_pkgid cc)) + (Map.singleton (cc_name cc) (cc_ann_id cc)) -- Compute the 'ComponentId's for a graph of 'Component's. The -- list of internal components must be topologically sorted @@ -273,31 +305,42 @@ extendConfiguredComponentMap cc = -- be used to configure a component that depends on one version of a package for -- a library and another version for a build-tool. toConfiguredComponents - :: Bool -- use_external_internal_deps - -> FlagAssignment - -> Bool -- deterministic - -> Flag String -- configIPID - -> Flag ComponentId -- configCID - -> PackageDescription - -> ConfiguredComponentMap - -> [Component] - -> LogProgress [ConfiguredComponent] + :: Bool -- use_external_internal_deps + -> FlagAssignment + -> Bool -- deterministic + -> Flag String -- configIPID + -> Flag ComponentId -- configCID + -> PackageDescription + -> ConfiguredComponentMap + -> [Component] + -> LogProgress [ConfiguredComponent] toConfiguredComponents - use_external_internal_deps flags deterministic ipid_flag cid_flag pkg_descr - dep_map comps - = fmap snd (mapAccumM go dep_map comps) - where - go m component = do - cc <- toConfiguredComponent' - use_external_internal_deps flags pkg_descr - deterministic ipid_flag cid_flag - m component + use_external_internal_deps + flags + deterministic + ipid_flag + cid_flag + pkg_descr + dep_map + comps = + fmap snd (mapAccumM go dep_map comps) + where + go m component = do + cc <- + toConfiguredComponent' + use_external_internal_deps + flags + pkg_descr + deterministic + ipid_flag + cid_flag + m + component return (extendConfiguredComponentMap cc m, cc) newPackageDepsBehaviourMinVersion :: CabalSpecVersion newPackageDepsBehaviourMinVersion = CabalSpecV1_8 - -- In older cabal versions, there was only one set of package dependencies for -- the whole package. In this version, we can have separate dependencies per -- target, but we only enable this behaviour if the minimum cabal version @@ -305,4 +348,4 @@ newPackageDepsBehaviourMinVersion = CabalSpecV1_8 -- old behaviour. newPackageDepsBehaviour :: PackageDescription -> Bool newPackageDepsBehaviour pkg = - specVersion pkg >= newPackageDepsBehaviourMinVersion + specVersion pkg >= newPackageDepsBehaviourMinVersion diff --git a/Cabal/src/Distribution/Backpack/DescribeUnitId.hs b/Cabal/src/Distribution/Backpack/DescribeUnitId.hs index 3dc063bdfcd..9ea30c2924b 100644 --- a/Cabal/src/Distribution/Backpack/DescribeUnitId.hs +++ b/Cabal/src/Distribution/Backpack/DescribeUnitId.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Rank2Types #-} + module Distribution.Backpack.DescribeUnitId where import Distribution.Compat.Prelude @@ -36,26 +37,36 @@ import Text.PrettyPrint -- | Print a Setup message stating (1) what operation we are doing, -- for (2) which component (with enough details to uniquely identify -- the build in question.) --- -setupMessage' :: Pretty a => Verbosity - -> String -- ^ Operation being done (capitalized), on: - -> PackageIdentifier -- ^ Package - -> ComponentName -- ^ Component name - -> Maybe [(ModuleName, a)] -- ^ Instantiation, if available. - -- Polymorphic to take - -- 'OpenModule' or 'Module' - -> IO () +setupMessage' + :: Pretty a + => Verbosity + -> String + -- ^ Operation being done (capitalized), on: + -> PackageIdentifier + -- ^ Package + -> ComponentName + -- ^ Component name + -> Maybe [(ModuleName, a)] + -- ^ Instantiation, if available. + -- Polymorphic to take + -- 'OpenModule' or 'Module' + -> IO () setupMessage' verbosity msg pkgid cname mb_insts = withFrozenCallStack $ do - noticeDoc verbosity $ - case mb_insts of - Just insts | not (null insts) -> - hang (msg_doc <+> text "instantiated with") 2 - (vcat [ pretty k <+> text "=" <+> pretty v - | (k,v) <- insts ]) $$ - for_doc - _ -> - msg_doc <+> for_doc - + noticeDoc verbosity $ + case mb_insts of + Just insts + | not (null insts) -> + hang + (msg_doc <+> text "instantiated with") + 2 + ( vcat + [ pretty k <+> text "=" <+> pretty v + | (k, v) <- insts + ] + ) + $$ for_doc + _ -> + msg_doc <+> for_doc where msg_doc = text msg <+> text (showComponentName cname) for_doc = text "for" <+> pretty pkgid <<>> text ".." diff --git a/Cabal/src/Distribution/Backpack/FullUnitId.hs b/Cabal/src/Distribution/Backpack/FullUnitId.hs index fbc05386b61..0a751a66f27 100644 --- a/Cabal/src/Distribution/Backpack/FullUnitId.hs +++ b/Cabal/src/Distribution/Backpack/FullUnitId.hs @@ -1,26 +1,27 @@ {-# LANGUAGE DeriveGeneric #-} -module Distribution.Backpack.FullUnitId ( - FullUnitId(..), - FullDb, - expandOpenUnitId, - expandUnitId -) where + +module Distribution.Backpack.FullUnitId + ( FullUnitId (..) + , FullDb + , expandOpenUnitId + , expandUnitId + ) where import Distribution.Backpack -import Distribution.Types.ComponentId import Distribution.Compat.Prelude +import Distribution.Types.ComponentId -- Unlike OpenUnitId, which could direct to a UnitId. data FullUnitId = FullUnitId ComponentId OpenModuleSubst - deriving (Show, Generic) + deriving (Show, Generic) type FullDb = DefUnitId -> FullUnitId expandOpenUnitId :: FullDb -> OpenUnitId -> FullUnitId -expandOpenUnitId _db (IndefFullUnitId cid subst) - = FullUnitId cid subst -expandOpenUnitId db (DefiniteUnitId uid) - = expandUnitId db uid +expandOpenUnitId _db (IndefFullUnitId cid subst) = + FullUnitId cid subst +expandOpenUnitId db (DefiniteUnitId uid) = + expandUnitId db uid expandUnitId :: FullDb -> DefUnitId -> FullUnitId expandUnitId db uid = db uid diff --git a/Cabal/src/Distribution/Backpack/Id.hs b/Cabal/src/Distribution/Backpack/Id.hs index 9e1de85028f..38e831acf17 100644 --- a/Cabal/src/Distribution/Backpack/Id.hs +++ b/Cabal/src/Distribution/Backpack/Id.hs @@ -1,74 +1,86 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} + -- | See -module Distribution.Backpack.Id( - computeComponentId, - computeCompatPackageKey, -) where +module Distribution.Backpack.Id + ( computeComponentId + , computeCompatPackageKey + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.UnqualComponentName -import Distribution.Simple.Compiler import Distribution.PackageDescription -import Distribution.Simple.Flag ( Flag(..) ) +import Distribution.Simple.Compiler +import Distribution.Simple.Flag (Flag (..)) import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.LocalBuildInfo import Distribution.Types.ComponentId -import Distribution.Types.UnitId import Distribution.Types.MungedPackageName +import Distribution.Types.UnitId import Distribution.Utils.Base62 import Distribution.Version +import Distribution.Parsec (simpleParsec) import Distribution.Pretty - ( prettyShow ) -import Distribution.Parsec ( simpleParsec ) + ( prettyShow + ) -- | This method computes a default, "good enough" 'ComponentId' -- for a package. The intent is that cabal-install (or the user) will -- specify a more detailed IPID via the @--ipid@ flag if necessary. computeComponentId - :: Bool -- deterministic mode - -> Flag String - -> Flag ComponentId - -> PackageIdentifier - -> ComponentName - -- This is used by cabal-install's legacy codepath - -> Maybe ([ComponentId], FlagAssignment) - -> ComponentId + :: Bool -- deterministic mode + -> Flag String + -> Flag ComponentId + -> PackageIdentifier + -> ComponentName + -- This is used by cabal-install's legacy codepath + -> Maybe ([ComponentId], FlagAssignment) + -> ComponentId computeComponentId deterministic mb_ipid mb_cid pid cname mb_details = - -- show is found to be faster than intercalate and then replacement of - -- special character used in intercalating. We cannot simply hash by - -- doubly concatenating list, as it just flatten out the nested list, so - -- different sources can produce same hash - let hash_suffix - | Just (dep_ipids, flags) <- mb_details - = "-" ++ hashToBase62 + -- show is found to be faster than intercalate and then replacement of + -- special character used in intercalating. We cannot simply hash by + -- doubly concatenating list, as it just flatten out the nested list, so + -- different sources can produce same hash + let hash_suffix + | Just (dep_ipids, flags) <- mb_details = + "-" + ++ hashToBase62 -- For safety, include the package + version here -- for GHC 7.10, where just the hash is used as -- the package key - ( prettyShow pid - ++ show dep_ipids - ++ show flags ) - | otherwise = "" - generated_base = prettyShow pid ++ hash_suffix - explicit_base cid0 = fromPathTemplate (InstallDirs.substPathTemplate env - (toPathTemplate cid0)) - -- Hack to reuse install dirs machinery - -- NB: no real IPID available at this point - where env = packageTemplateEnv pid (mkUnitId "") - actual_base = case mb_ipid of - Flag ipid0 -> explicit_base ipid0 - NoFlag | deterministic -> prettyShow pid - | otherwise -> generated_base - in case mb_cid of - Flag cid -> cid - NoFlag -> mkComponentId $ actual_base - ++ (case componentNameString cname of - Nothing -> "" - Just s -> "-" ++ unUnqualComponentName s) + ( prettyShow pid + ++ show dep_ipids + ++ show flags + ) + | otherwise = "" + generated_base = prettyShow pid ++ hash_suffix + explicit_base cid0 = + fromPathTemplate + ( InstallDirs.substPathTemplate + env + (toPathTemplate cid0) + ) + where + -- Hack to reuse install dirs machinery + -- NB: no real IPID available at this point + env = packageTemplateEnv pid (mkUnitId "") + actual_base = case mb_ipid of + Flag ipid0 -> explicit_base ipid0 + NoFlag + | deterministic -> prettyShow pid + | otherwise -> generated_base + in case mb_cid of + Flag cid -> cid + NoFlag -> + mkComponentId $ + actual_base + ++ ( case componentNameString cname of + Nothing -> "" + Just s -> "-" ++ unUnqualComponentName s + ) -- | In GHC 8.0, the string we pass to GHC to use for symbol -- names for a package can be an arbitrary, IPID-compatible string. @@ -116,30 +128,29 @@ computeComponentId deterministic mb_ipid mb_cid pid cname mb_details = -- -- * For sub-components, we rehash the IPID into the correct format -- and pass that. --- computeCompatPackageKey - :: Compiler - -> MungedPackageName - -> Version - -> UnitId - -> String + :: Compiler + -> MungedPackageName + -> Version + -> UnitId + -> String computeCompatPackageKey comp pkg_name pkg_version uid - | not (packageKeySupported comp || unitIdSupported comp) - = prettyShow pkg_name ++ "-" ++ prettyShow pkg_version - | not (unifiedIPIDRequired comp) = - let str = unUnitId uid -- assume no Backpack support - mb_verbatim_key - = case simpleParsec str :: Maybe PackageId of - -- Something like 'foo-0.1', use it verbatim. - -- (NB: hash tags look like tags, so they are parsed, - -- so the extra equality check tests if a tag was dropped.) - Just pid0 | prettyShow pid0 == str -> Just str - _ -> Nothing - mb_truncated_key - = let cand = reverse (takeWhile isAlphaNum (reverse str)) - in if length cand == 22 && all isAlphaNum cand - then Just cand - else Nothing - rehashed_key = hashToBase62 str - in fromMaybe rehashed_key (mb_verbatim_key `mplus` mb_truncated_key) - | otherwise = prettyShow uid + | not (packageKeySupported comp || unitIdSupported comp) = + prettyShow pkg_name ++ "-" ++ prettyShow pkg_version + | not (unifiedIPIDRequired comp) = + let str = unUnitId uid -- assume no Backpack support + mb_verbatim_key = + case simpleParsec str :: Maybe PackageId of + -- Something like 'foo-0.1', use it verbatim. + -- (NB: hash tags look like tags, so they are parsed, + -- so the extra equality check tests if a tag was dropped.) + Just pid0 | prettyShow pid0 == str -> Just str + _ -> Nothing + mb_truncated_key = + let cand = reverse (takeWhile isAlphaNum (reverse str)) + in if length cand == 22 && all isAlphaNum cand + then Just cand + else Nothing + rehashed_key = hashToBase62 str + in fromMaybe rehashed_key (mb_verbatim_key `mplus` mb_truncated_key) + | otherwise = prettyShow uid diff --git a/Cabal/src/Distribution/Backpack/LinkedComponent.hs b/Cabal/src/Distribution/Backpack/LinkedComponent.hs index 797fef251ac..130157df20a 100644 --- a/Cabal/src/Distribution/Backpack/LinkedComponent.hs +++ b/Cabal/src/Distribution/Backpack/LinkedComponent.hs @@ -1,82 +1,76 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} + -- | See -module Distribution.Backpack.LinkedComponent ( - LinkedComponent(..), - lc_insts, - lc_uid, - lc_cid, - lc_pkgid, - toLinkedComponent, - toLinkedComponents, - dispLinkedComponent, - LinkedComponentMap, - extendLinkedComponentMap, -) where +module Distribution.Backpack.LinkedComponent + ( LinkedComponent (..) + , lc_insts + , lc_uid + , lc_cid + , lc_pkgid + , toLinkedComponent + , toLinkedComponents + , dispLinkedComponent + , LinkedComponentMap + , extendLinkedComponentMap + ) where -import Prelude () import Distribution.Compat.Prelude hiding ((<>)) +import Prelude () import Distribution.Backpack -import Distribution.Backpack.FullUnitId import Distribution.Backpack.ConfiguredComponent +import Distribution.Backpack.FullUnitId +import Distribution.Backpack.MixLink +import Distribution.Backpack.ModuleScope import Distribution.Backpack.ModuleShape import Distribution.Backpack.PreModuleShape -import Distribution.Backpack.ModuleScope import Distribution.Backpack.UnifyM -import Distribution.Backpack.MixLink import Distribution.Utils.MapAccum -import Distribution.Types.AnnotatedId -import Distribution.Types.ComponentName -import Distribution.Types.ModuleReexport -import Distribution.Types.ModuleRenaming -import Distribution.Types.IncludeRenaming -import Distribution.Types.ComponentInclude -import Distribution.Types.ComponentId -import Distribution.Types.PackageId +import Distribution.ModuleName import Distribution.Package import Distribution.PackageDescription -import Distribution.ModuleName import Distribution.Simple.LocalBuildInfo -import Distribution.Verbosity +import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentInclude import Distribution.Utils.LogProgress +import Distribution.Verbosity -import qualified Data.Set as Set import qualified Data.Map as Map +import qualified Data.Set as Set import Distribution.Pretty (pretty) -import Text.PrettyPrint (Doc, hang, text, vcat, ($+$), hsep, quotes) +import Text.PrettyPrint (Doc, hang, hsep, quotes, text, vcat, ($+$)) -- | A linked component is a component that has been mix-in linked, at -- which point we have determined how all the dependencies of the -- component are explicitly instantiated (in the form of an OpenUnitId). -- 'ConfiguredComponent' is mix-in linked into 'LinkedComponent', which -- is then instantiated into 'ReadyComponent'. -data LinkedComponent - = LinkedComponent { - -- | Uniquely identifies linked component - lc_ann_id :: AnnotatedId ComponentId, - -- | Corresponds to 'cc_component'. - lc_component :: Component, - -- | @build-tools@ and @build-tool-depends@ dependencies. - -- Corresponds to 'cc_exe_deps'. - lc_exe_deps :: [AnnotatedId OpenUnitId], - -- | Is this the public library of a package? Corresponds to - -- 'cc_public'. - lc_public :: Bool, - -- | Corresponds to 'cc_includes', but (1) this does not contain - -- includes of signature packages (packages with no exports), - -- and (2) the 'ModuleRenaming' for requirements (stored in - -- 'IncludeRenaming') has been removed, as it is reflected in - -- 'OpenUnitId'.) - lc_includes :: [ComponentInclude OpenUnitId ModuleRenaming], - -- | Like 'lc_includes', but this specifies includes on - -- signature packages which have no exports. - lc_sig_includes :: [ComponentInclude OpenUnitId ModuleRenaming], - -- | The module shape computed by mix-in linking. This is - -- newly computed from 'ConfiguredComponent' - lc_shape :: ModuleShape - } +data LinkedComponent = LinkedComponent + { lc_ann_id :: AnnotatedId ComponentId + -- ^ Uniquely identifies linked component + , lc_component :: Component + -- ^ Corresponds to 'cc_component'. + , lc_exe_deps :: [AnnotatedId OpenUnitId] + -- ^ @build-tools@ and @build-tool-depends@ dependencies. + -- Corresponds to 'cc_exe_deps'. + , lc_public :: Bool + -- ^ Is this the public library of a package? Corresponds to + -- 'cc_public'. + , lc_includes :: [ComponentInclude OpenUnitId ModuleRenaming] + -- ^ Corresponds to 'cc_includes', but (1) this does not contain + -- includes of signature packages (packages with no exports), + -- and (2) the 'ModuleRenaming' for requirements (stored in + -- 'IncludeRenaming') has been removed, as it is reflected in + -- 'OpenUnitId'.) + , lc_sig_includes :: [ComponentInclude OpenUnitId ModuleRenaming] + -- ^ Like 'lc_includes', but this specifies includes on + -- signature packages which have no exports. + , lc_shape :: ModuleShape + -- ^ The module shape computed by mix-in linking. This is + -- newly computed from 'ConfiguredComponent' + } -- | Uniquely identifies a 'LinkedComponent'. Corresponds to -- 'cc_cid'. @@ -96,94 +90,122 @@ lc_uid lc = IndefFullUnitId (lc_cid lc) . Map.fromList $ lc_insts lc -- | The instantiation of 'lc_uid'; this always has the invariant -- that it is a mapping from a module name @A@ to @@ (the hole A). lc_insts :: LinkedComponent -> [(ModuleName, OpenModule)] -lc_insts lc = [ (req, OpenModuleVar req) - | req <- Set.toList (modShapeRequires (lc_shape lc)) ] +lc_insts lc = + [ (req, OpenModuleVar req) + | req <- Set.toList (modShapeRequires (lc_shape lc)) + ] dispLinkedComponent :: LinkedComponent -> Doc dispLinkedComponent lc = - hang (text "unit" <+> pretty (lc_uid lc)) 4 $ - vcat [ text "include" <+> pretty (ci_id incl) <+> pretty (ci_renaming incl) - | incl <- lc_includes lc ] - $+$ - vcat [ text "signature include" <+> pretty (ci_id incl) - | incl <- lc_sig_includes lc ] - $+$ dispOpenModuleSubst (modShapeProvides (lc_shape lc)) + hang (text "unit" <+> pretty (lc_uid lc)) 4 $ + vcat + [ text "include" <+> pretty (ci_id incl) <+> pretty (ci_renaming incl) + | incl <- lc_includes lc + ] + $+$ vcat + [ text "signature include" <+> pretty (ci_id incl) + | incl <- lc_sig_includes lc + ] + $+$ dispOpenModuleSubst (modShapeProvides (lc_shape lc)) instance Package LinkedComponent where - packageId = lc_pkgid + packageId = lc_pkgid toLinkedComponent - :: Verbosity - -> FullDb - -> PackageId - -> LinkedComponentMap - -> ConfiguredComponent - -> LogProgress LinkedComponent -toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent { - cc_ann_id = aid@AnnotatedId { ann_id = this_cid }, - cc_component = component, - cc_exe_deps = exe_deps, - cc_public = is_public, - cc_includes = cid_includes - } = do + :: Verbosity + -> FullDb + -> PackageId + -> LinkedComponentMap + -> ConfiguredComponent + -> LogProgress LinkedComponent +toLinkedComponent + verbosity + db + this_pid + pkg_map + ConfiguredComponent + { cc_ann_id = aid@AnnotatedId{ann_id = this_cid} + , cc_component = component + , cc_exe_deps = exe_deps + , cc_public = is_public + , cc_includes = cid_includes + } = do let - -- The explicitly specified requirements, provisions and - -- reexports from the Cabal file. These are only non-empty for - -- libraries; everything else is trivial. - (src_reqs :: [ModuleName], - src_provs :: [ModuleName], - src_reexports :: [ModuleReexport]) = - case component of - CLib lib -> (signatures lib, - exposedModules lib, - reexportedModules lib) - _ -> ([], [], []) - src_hidden = otherModules (componentBuildInfo component) - - -- Take each included ComponentId and resolve it into an - -- *unlinked* unit identity. We will use unification (relying - -- on the ModuleShape) to resolve these into linked identities. - unlinked_includes :: [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming] - unlinked_includes = [ ComponentInclude (fmap lookupUid dep_aid) rns i - | ComponentInclude dep_aid rns i <- cid_includes ] - - lookupUid :: ComponentId -> (OpenUnitId, ModuleShape) - lookupUid cid = fromMaybe (error "linkComponent: lookupUid") - (Map.lookup cid pkg_map) + -- The explicitly specified requirements, provisions and + -- reexports from the Cabal file. These are only non-empty for + -- libraries; everything else is trivial. + ( src_reqs :: [ModuleName] + , src_provs :: [ModuleName] + , src_reexports :: [ModuleReexport] + ) = + case component of + CLib lib -> + ( signatures lib + , exposedModules lib + , reexportedModules lib + ) + _ -> ([], [], []) + src_hidden = otherModules (componentBuildInfo component) + + -- Take each included ComponentId and resolve it into an + -- \*unlinked* unit identity. We will use unification (relying + -- on the ModuleShape) to resolve these into linked identities. + unlinked_includes :: [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming] + unlinked_includes = + [ ComponentInclude (fmap lookupUid dep_aid) rns i + | ComponentInclude dep_aid rns i <- cid_includes + ] + + lookupUid :: ComponentId -> (OpenUnitId, ModuleShape) + lookupUid cid = + fromMaybe + (error "linkComponent: lookupUid") + (Map.lookup cid pkg_map) let orErr (Right x) = return x orErr (Left [err]) = dieProgress err orErr (Left errs) = do - dieProgress (vcat (intersperse (text "") -- double newline! - [ hang (text "-") 2 err | err <- errs])) + dieProgress + ( vcat + ( intersperse + (text "") -- double newline! + [hang (text "-") 2 err | err <- errs] + ) + ) -- Pre-shaping - let pre_shape = mixLinkPreModuleShape $ - PreModuleShape { - preModShapeProvides = Set.fromList (src_provs ++ src_hidden), - preModShapeRequires = Set.fromList src_reqs - } : [ renamePreModuleShape (toPreModuleShape sh) rns - | ComponentInclude (AnnotatedId { ann_id = (_, sh) }) rns _ <- unlinked_includes ] - reqs = preModShapeRequires pre_shape - insts = [ (req, OpenModuleVar req) - | req <- Set.toList reqs ] + let pre_shape = + mixLinkPreModuleShape $ + PreModuleShape + { preModShapeProvides = Set.fromList (src_provs ++ src_hidden) + , preModShapeRequires = Set.fromList src_reqs + } + : [ renamePreModuleShape (toPreModuleShape sh) rns + | ComponentInclude (AnnotatedId{ann_id = (_, sh)}) rns _ <- unlinked_includes + ] + reqs = preModShapeRequires pre_shape + insts = + [ (req, OpenModuleVar req) + | req <- Set.toList reqs + ] this_uid = IndefFullUnitId this_cid . Map.fromList $ insts -- OK, actually do unification -- TODO: the unification monad might return errors, in which -- case we have to deal. Use monadic bind for now. - (linked_shape0 :: ModuleScope, - linked_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming], - linked_sig_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming]) - <- orErr $ runUnifyM verbosity this_cid db $ do + ( linked_shape0 :: ModuleScope + , linked_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming] + , linked_sig_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming] + ) <- + orErr $ runUnifyM verbosity this_cid db $ do -- The unification monad is implemented using mutable -- references. Thus, we must convert our *pure* data -- structures into mutable ones to perform unification. let convertMod :: (ModuleName -> ModuleSource) -> ModuleName -> UnifyM s (ModuleScopeU s) convertMod from m = do - m_u <- convertModule (OpenModule this_uid m) - return (Map.singleton m [WithSource (from m) m_u], Map.empty) + m_u <- convertModule (OpenModule this_uid m) + return (Map.singleton m [WithSource (from m) m_u], Map.empty) -- Handle 'exposed-modules' exposed_mod_shapes_u <- traverse (convertMod FromExposedModules) src_provs -- Handle 'other-modules' @@ -192,8 +214,8 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent { -- Handle 'signatures' let convertReq :: ModuleName -> UnifyM s (ModuleScopeU s) convertReq req = do - req_u <- convertModule (OpenModuleVar req) - return (Map.empty, Map.singleton req [WithSource (FromSignatures req) req_u]) + req_u <- convertModule (OpenModuleVar req) + return (Map.empty, Map.singleton req [WithSource (FromSignatures req) req_u]) req_shapes_u <- traverse convertReq src_reqs -- Handle 'mixins' @@ -201,22 +223,26 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent { failIfErrs -- Prevent error cascade -- Mix-in link everything! mixLink is the real workhorse. - shape_u <- mixLink $ exposed_mod_shapes_u - ++ other_mod_shapes_u - ++ req_shapes_u - ++ incl_shapes_u + shape_u <- + mixLink $ + exposed_mod_shapes_u + ++ other_mod_shapes_u + ++ req_shapes_u + ++ incl_shapes_u -- src_reqs_u <- traverse convertReq src_reqs -- Read out all the final results by converting back -- into a pure representation. let convertIncludeU (ComponentInclude dep_aid rns i) = do - let component_name = pretty $ ann_cname dep_aid - uid <- convertUnitIdU (ann_id dep_aid) component_name - return (ComponentInclude { - ci_ann_id = dep_aid { ann_id = uid }, - ci_renaming = rns, - ci_implicit = i - }) + let component_name = pretty $ ann_cname dep_aid + uid <- convertUnitIdU (ann_id dep_aid) component_name + return + ( ComponentInclude + { ci_ann_id = dep_aid{ann_id = uid} + , ci_renaming = rns + , ci_implicit = i + } + ) shape <- convertModuleScopeU shape_u let (includes_u, sig_includes_u) = partitionEithers all_includes_u @@ -225,23 +251,26 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent { return (shape, incls, sig_incls) let isNotLib (CLib _) = False - isNotLib _ = True + isNotLib _ = True when (not (Set.null reqs) && isNotLib component) $ - dieProgress $ - hang (text "Non-library component has unfilled requirements:") - 4 (vcat [pretty req | req <- Set.toList reqs]) + dieProgress $ + hang + (text "Non-library component has unfilled requirements:") + 4 + (vcat [pretty req | req <- Set.toList reqs]) -- NB: do NOT include hidden modules here: GHC 7.10's ghc-pkg -- won't allow it (since someone could directly synthesize -- an 'InstalledPackageInfo' that violates abstraction.) -- Though, maybe it should be relaxed? let src_hidden_set = Set.fromList src_hidden - linked_shape = linked_shape0 { - modScopeProvides = + linked_shape = + linked_shape0 + { modScopeProvides = -- Would rather use withoutKeys but need BC Map.filterWithKey - (\k _ -> not (k `Set.member` src_hidden_set)) - (modScopeProvides linked_shape0) + (\k _ -> not (k `Set.member` src_hidden_set)) + (modScopeProvides linked_shape0) } -- OK, compute the reexports @@ -250,27 +279,29 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent { -- once. let hdl :: [Either Doc a] -> LogProgress [a] hdl es = - case partitionEithers es of - ([], rs) -> return rs - (ls, _) -> - dieProgress $ - hang (text "Problem with module re-exports:") 2 - (vcat [hang (text "-") 2 l | l <- ls]) + case partitionEithers es of + ([], rs) -> return rs + (ls, _) -> + dieProgress $ + hang + (text "Problem with module re-exports:") + 2 + (vcat [hang (text "-") 2 l | l <- ls]) reexports_list <- hdl . (flip map) src_reexports $ \reex@(ModuleReexport mb_pn from to) -> do case Map.lookup from (modScopeProvides linked_shape) of - Just cands@(x0:xs0) -> do + Just cands@(x0 : xs0) -> do -- Make sure there is at least one candidate (x, xs) <- case mb_pn of Just pn -> - let matches_pn (FromMixins pn' _ _) = pn == pn' + let matches_pn (FromMixins pn' _ _) = pn == pn' matches_pn (FromBuildDepends pn' _) = pn == pn' matches_pn (FromExposedModules _) = pn == packageName this_pid - matches_pn (FromOtherModules _) = pn == packageName this_pid - matches_pn (FromSignatures _) = pn == packageName this_pid - in case filter (matches_pn . getSource) cands of - (x1:xs1) -> return (x1, xs1) - _ -> Left (brokenReexportMsg reex) + matches_pn (FromOtherModules _) = pn == packageName this_pid + matches_pn (FromSignatures _) = pn == packageName this_pid + in case filter (matches_pn . getSource) cands of + (x1 : xs1) -> return (x1, xs1) + _ -> Left (brokenReexportMsg reex) Nothing -> return (x0, xs0) -- Test that all the candidates are consistent case filter (\x' -> unWithSource x /= unWithSource x') xs of @@ -282,33 +313,36 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent { -- TODO: maybe check this earlier; it's syntactically obvious. let build_reexports m (k, v) - | Map.member k m = - dieProgress $ hsep - [ text "Module name ", pretty k, text " is exported multiple times." ] - | otherwise = return (Map.insert k v m) - provs <- foldM build_reexports Map.empty $ - -- TODO: doublecheck we have checked for - -- src_provs duplicates already! - [ (mod_name, OpenModule this_uid mod_name) | mod_name <- src_provs ] ++ - reexports_list + | Map.member k m = + dieProgress $ + hsep + [text "Module name ", pretty k, text " is exported multiple times."] + | otherwise = return (Map.insert k v m) + provs <- + foldM build_reexports Map.empty $ + -- TODO: doublecheck we have checked for + -- src_provs duplicates already! + [(mod_name, OpenModule this_uid mod_name) | mod_name <- src_provs] + ++ reexports_list let final_linked_shape = ModuleShape provs (Map.keysSet (modScopeRequires linked_shape)) -- See Note Note [Signature package special case] let (linked_includes, linked_sig_includes) - | Set.null reqs = (linked_includes0 ++ linked_sig_includes0, []) - | otherwise = (linked_includes0, linked_sig_includes0) - - return $ LinkedComponent { - lc_ann_id = aid, - lc_component = component, - lc_public = is_public, - -- These must be executables - lc_exe_deps = map (fmap (\cid -> IndefFullUnitId cid Map.empty)) exe_deps, - lc_shape = final_linked_shape, - lc_includes = linked_includes, - lc_sig_includes = linked_sig_includes - } + | Set.null reqs = (linked_includes0 ++ linked_sig_includes0, []) + | otherwise = (linked_includes0, linked_sig_includes0) + + return $ + LinkedComponent + { lc_ann_id = aid + , lc_component = component + , lc_public = is_public + , -- These must be executables + lc_exe_deps = map (fmap (\cid -> IndefFullUnitId cid Map.empty)) exe_deps + , lc_shape = final_linked_shape + , lc_includes = linked_includes + , lc_sig_includes = linked_sig_includes + } -- Note [Signature package special case] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -336,63 +370,79 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent { -- Handle mix-in linking for components. In the absence of Backpack, -- every ComponentId gets converted into a UnitId by way of SimpleUnitId. toLinkedComponents - :: Verbosity - -> FullDb - -> PackageId - -> LinkedComponentMap - -> [ConfiguredComponent] - -> LogProgress [LinkedComponent] -toLinkedComponents verbosity db this_pid lc_map0 comps - = fmap snd (mapAccumM go lc_map0 comps) - where - go :: Map ComponentId (OpenUnitId, ModuleShape) - -> ConfiguredComponent - -> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent) - go lc_map cc = do - lc <- addProgressCtx (text "In the stanza" <+> text (componentNameStanza (cc_name cc))) $ - toLinkedComponent verbosity db this_pid lc_map cc - return (extendLinkedComponentMap lc lc_map, lc) + :: Verbosity + -> FullDb + -> PackageId + -> LinkedComponentMap + -> [ConfiguredComponent] + -> LogProgress [LinkedComponent] +toLinkedComponents verbosity db this_pid lc_map0 comps = + fmap snd (mapAccumM go lc_map0 comps) + where + go + :: Map ComponentId (OpenUnitId, ModuleShape) + -> ConfiguredComponent + -> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent) + go lc_map cc = do + lc <- + addProgressCtx (text "In the stanza" <+> text (componentNameStanza (cc_name cc))) $ + toLinkedComponent verbosity db this_pid lc_map cc + return (extendLinkedComponentMap lc lc_map, lc) type LinkedComponentMap = Map ComponentId (OpenUnitId, ModuleShape) -extendLinkedComponentMap :: LinkedComponent - -> LinkedComponentMap - -> LinkedComponentMap +extendLinkedComponentMap + :: LinkedComponent + -> LinkedComponentMap + -> LinkedComponentMap extendLinkedComponentMap lc m = - Map.insert (lc_cid lc) (lc_uid lc, lc_shape lc) m + Map.insert (lc_cid lc) (lc_uid lc, lc_shape lc) m brokenReexportMsg :: ModuleReexport -> Doc brokenReexportMsg (ModuleReexport (Just pn) from _to) = - vcat [ text "The package" <+> quotes (pretty pn) - , text "does not export a module" <+> quotes (pretty from) ] + vcat + [ text "The package" <+> quotes (pretty pn) + , text "does not export a module" <+> quotes (pretty from) + ] brokenReexportMsg (ModuleReexport Nothing from _to) = - vcat [ text "The module" <+> quotes (pretty from) - , text "is not exported by any suitable package." - , text "It occurs in neither the 'exposed-modules' of this package," - , text "nor any of its 'build-depends' dependencies." ] + vcat + [ text "The module" <+> quotes (pretty from) + , text "is not exported by any suitable package." + , text "It occurs in neither the 'exposed-modules' of this package," + , text "nor any of its 'build-depends' dependencies." + ] ambiguousReexportMsg :: ModuleReexport -> ModuleWithSource -> [ModuleWithSource] -> Doc ambiguousReexportMsg (ModuleReexport mb_pn from _to) y1 ys = - vcat [ text "Ambiguous reexport" <+> quotes (pretty from) - , hang (text "It could refer to either:") 2 - (vcat (msg : msgs)) - , help_msg mb_pn ] + vcat + [ text "Ambiguous reexport" <+> quotes (pretty from) + , hang + (text "It could refer to either:") + 2 + (vcat (msg : msgs)) + , help_msg mb_pn + ] where - msg = text " " <+> displayModuleWithSource y1 + msg = text " " <+> displayModuleWithSource y1 msgs = [text "or" <+> displayModuleWithSource y | y <- ys] help_msg Nothing = -- TODO: This advice doesn't help if the ambiguous exports -- come from a package named the same thing - vcat [ text "The ambiguity can be resolved by qualifying the" - , text "re-export with a package name." - , text "The syntax is 'packagename:ModuleName [as NewName]'." ] + vcat + [ text "The ambiguity can be resolved by qualifying the" + , text "re-export with a package name." + , text "The syntax is 'packagename:ModuleName [as NewName]'." + ] -- Qualifying won't help that much. help_msg (Just _) = - vcat [ text "The ambiguity can be resolved by using the" - , text "mixins field to rename one of the module" - , text "names differently." ] - displayModuleWithSource y - = vcat [ quotes (pretty (unWithSource y)) - , text "brought into scope by" <+> - dispModuleSource (getSource y) - ] + vcat + [ text "The ambiguity can be resolved by using the" + , text "mixins field to rename one of the module" + , text "names differently." + ] + displayModuleWithSource y = + vcat + [ quotes (pretty (unWithSource y)) + , text "brought into scope by" + <+> dispModuleSource (getSource y) + ] diff --git a/Cabal/src/Distribution/Backpack/MixLink.hs b/Cabal/src/Distribution/Backpack/MixLink.hs index 8b44e74e6e5..b358612b244 100644 --- a/Cabal/src/Distribution/Backpack/MixLink.hs +++ b/Cabal/src/Distribution/Backpack/MixLink.hs @@ -1,26 +1,27 @@ {-# LANGUAGE NondecreasingIndentation #-} + -- | See -module Distribution.Backpack.MixLink ( - mixLink, -) where +module Distribution.Backpack.MixLink + ( mixLink + ) where -import Prelude () import Distribution.Compat.Prelude hiding (mod) +import Prelude () import Distribution.Backpack -import Distribution.Backpack.UnifyM import Distribution.Backpack.FullUnitId import Distribution.Backpack.ModuleScope +import Distribution.Backpack.UnifyM -import qualified Distribution.Utils.UnionFind as UnionFind import Distribution.ModuleName import Distribution.Pretty import Distribution.Types.ComponentId +import qualified Distribution.Utils.UnionFind as UnionFind -import Text.PrettyPrint import Control.Monad -import qualified Data.Map as Map import qualified Data.Foldable as F +import qualified Data.Map as Map +import Text.PrettyPrint ----------------------------------------------------------------------- -- Linking @@ -28,78 +29,98 @@ import qualified Data.Foldable as F -- | Given to scopes of provisions and requirements, link them together. mixLink :: [ModuleScopeU s] -> UnifyM s (ModuleScopeU s) mixLink scopes = do - let provs = Map.unionsWith (++) (map fst scopes) - -- Invariant: any identically named holes refer to same mutable cell - reqs = Map.unionsWith (++) (map snd scopes) - filled = Map.intersectionWithKey linkProvision provs reqs - F.sequenceA_ filled - let remaining = Map.difference reqs filled - return (provs, remaining) + let provs = Map.unionsWith (++) (map fst scopes) + -- Invariant: any identically named holes refer to same mutable cell + reqs = Map.unionsWith (++) (map snd scopes) + filled = Map.intersectionWithKey linkProvision provs reqs + F.sequenceA_ filled + let remaining = Map.difference reqs filled + return (provs, remaining) -- | Link a list of possibly provided modules to a single -- requirement. This applies a side-condition that all -- of the provided modules at the same name are *actually* -- the same module. -linkProvision :: ModuleName - -> [ModuleWithSourceU s] -- provs - -> [ModuleWithSourceU s] -- reqs - -> UnifyM s [ModuleWithSourceU s] -linkProvision mod_name ret@(prov:provs) (req:reqs) = do - -- TODO: coalesce all the non-unifying modules together - forM_ provs $ \prov' -> do - -- Careful: read it out BEFORE unifying, because the - -- unification algorithm preemptively unifies modules - mod <- convertModuleU (unWithSource prov) - mod' <- convertModuleU (unWithSource prov') - r <- unify prov prov' - case r of - Just () -> return () - Nothing -> do - addErr $ - text "Ambiguous module" <+> quotes (pretty mod_name) $$ - text "It could refer to" <+> - ( text " " <+> (quotes (pretty mod) $$ in_scope_by (getSource prov)) $$ - text "or" <+> (quotes (pretty mod') $$ in_scope_by (getSource prov')) ) $$ - link_doc +linkProvision + :: ModuleName + -> [ModuleWithSourceU s] -- provs + -> [ModuleWithSourceU s] -- reqs + -> UnifyM s [ModuleWithSourceU s] +linkProvision mod_name ret@(prov : provs) (req : reqs) = do + -- TODO: coalesce all the non-unifying modules together + forM_ provs $ \prov' -> do + -- Careful: read it out BEFORE unifying, because the + -- unification algorithm preemptively unifies modules mod <- convertModuleU (unWithSource prov) - req_mod <- convertModuleU (unWithSource req) - self_cid <- fmap unify_self_cid getUnifEnv - case mod of - OpenModule (IndefFullUnitId cid _) _ - | cid == self_cid -> addErr $ - text "Cannot instantiate requirement" <+> quotes (pretty mod_name) <+> - in_scope_by (getSource req) $$ - text "with locally defined module" <+> in_scope_by (getSource prov) $$ - text "as this would create a cyclic dependency, which GHC does not support." $$ - text "Try moving this module to a separate library, e.g.," $$ - text "create a new stanza: library 'sublib'." - _ -> return () - r <- unify prov req + mod' <- convertModuleU (unWithSource prov') + r <- unify prov prov' case r of - Just () -> return () - Nothing -> do - -- TODO: Record and report WHERE the bad constraint came from - addErr $ text "Could not instantiate requirement" <+> quotes (pretty mod_name) $$ - nest 4 (text "Expected:" <+> pretty mod $$ - text "Actual: " <+> pretty req_mod) $$ - parens (text "This can occur if an exposed module of" <+> - text "a libraries shares a name with another module.") $$ - link_doc - return ret + Just () -> return () + Nothing -> do + addErr $ + text "Ambiguous module" + <+> quotes (pretty mod_name) + $$ text "It could refer to" + <+> ( text " " + <+> (quotes (pretty mod) $$ in_scope_by (getSource prov)) + $$ text "or" + <+> (quotes (pretty mod') $$ in_scope_by (getSource prov')) + ) + $$ link_doc + mod <- convertModuleU (unWithSource prov) + req_mod <- convertModuleU (unWithSource req) + self_cid <- fmap unify_self_cid getUnifEnv + case mod of + OpenModule (IndefFullUnitId cid _) _ + | cid == self_cid -> + addErr $ + text "Cannot instantiate requirement" + <+> quotes (pretty mod_name) + <+> in_scope_by (getSource req) + $$ text "with locally defined module" + <+> in_scope_by (getSource prov) + $$ text "as this would create a cyclic dependency, which GHC does not support." + $$ text "Try moving this module to a separate library, e.g.," + $$ text "create a new stanza: library 'sublib'." + _ -> return () + r <- unify prov req + case r of + Just () -> return () + Nothing -> do + -- TODO: Record and report WHERE the bad constraint came from + addErr $ + text "Could not instantiate requirement" + <+> quotes (pretty mod_name) + $$ nest + 4 + ( text "Expected:" + <+> pretty mod + $$ text "Actual: " + <+> pretty req_mod + ) + $$ parens + ( text "This can occur if an exposed module of" + <+> text "a libraries shares a name with another module." + ) + $$ link_doc + return ret where - unify s1 s2 = tryM $ addErrContext short_link_doc - $ unifyModule (unWithSource s1) (unWithSource s2) + unify s1 s2 = + tryM $ + addErrContext short_link_doc $ + unifyModule (unWithSource s1) (unWithSource s2) in_scope_by s = text "brought into scope by" <+> dispModuleSource s short_link_doc = text "While filling requirement" <+> quotes (pretty mod_name) link_doc = text "While filling requirements of" <+> reqs_doc reqs_doc | null reqs = dispModuleSource (getSource req) - | otherwise = ( text " " <+> dispModuleSource (getSource req) $$ - vcat [ text "and" <+> dispModuleSource (getSource r) | r <- reqs]) + | otherwise = + ( text " " + <+> dispModuleSource (getSource req) + $$ vcat [text "and" <+> dispModuleSource (getSource r) | r <- reqs] + ) linkProvision _ _ _ = error "linkProvision" - - ----------------------------------------------------------------------- -- The unification algorithm @@ -108,78 +129,93 @@ linkProvision _ _ _ = error "linkProvision" unifyUnitId :: UnitIdU s -> UnitIdU s -> UnifyM s () unifyUnitId uid1_u uid2_u - | uid1_u == uid2_u = return () - | otherwise = do - xuid1 <- liftST $ UnionFind.find uid1_u - xuid2 <- liftST $ UnionFind.find uid2_u - case (xuid1, xuid2) of - (UnitIdThunkU u1, UnitIdThunkU u2) - | u1 == u2 -> return () - | otherwise -> - failWith $ hang (text "Couldn't match unit IDs:") 4 - (text " " <+> pretty u1 $$ - text "and" <+> pretty u2) - (UnitIdThunkU uid1, UnitIdU _ cid2 insts2) - -> unifyThunkWith cid2 insts2 uid2_u uid1 uid1_u - (UnitIdU _ cid1 insts1, UnitIdThunkU uid2) - -> unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u - (UnitIdU _ cid1 insts1, UnitIdU _ cid2 insts2) - -> unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u + | uid1_u == uid2_u = return () + | otherwise = do + xuid1 <- liftST $ UnionFind.find uid1_u + xuid2 <- liftST $ UnionFind.find uid2_u + case (xuid1, xuid2) of + (UnitIdThunkU u1, UnitIdThunkU u2) + | u1 == u2 -> return () + | otherwise -> + failWith $ + hang + (text "Couldn't match unit IDs:") + 4 + ( text " " + <+> pretty u1 + $$ text "and" + <+> pretty u2 + ) + (UnitIdThunkU uid1, UnitIdU _ cid2 insts2) -> + unifyThunkWith cid2 insts2 uid2_u uid1 uid1_u + (UnitIdU _ cid1 insts1, UnitIdThunkU uid2) -> + unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u + (UnitIdU _ cid1 insts1, UnitIdU _ cid2 insts2) -> + unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u -unifyThunkWith :: ComponentId - -> Map ModuleName (ModuleU s) - -> UnitIdU s - -> DefUnitId - -> UnitIdU s - -> UnifyM s () +unifyThunkWith + :: ComponentId + -> Map ModuleName (ModuleU s) + -> UnitIdU s + -> DefUnitId + -> UnitIdU s + -> UnifyM s () unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u = do - db <- fmap unify_db getUnifEnv - let FullUnitId cid2 insts2' = expandUnitId db uid2 - insts2 <- convertModuleSubst insts2' - unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u + db <- fmap unify_db getUnifEnv + let FullUnitId cid2 insts2' = expandUnitId db uid2 + insts2 <- convertModuleSubst insts2' + unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u -unifyInner :: ComponentId - -> Map ModuleName (ModuleU s) - -> UnitIdU s - -> ComponentId - -> Map ModuleName (ModuleU s) - -> UnitIdU s - -> UnifyM s () +unifyInner + :: ComponentId + -> Map ModuleName (ModuleU s) + -> UnitIdU s + -> ComponentId + -> Map ModuleName (ModuleU s) + -> UnitIdU s + -> UnifyM s () unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u = do - when (cid1 /= cid2) $ - -- TODO: if we had a package identifier, could be an - -- easier to understand error message. - failWith $ - hang (text "Couldn't match component IDs:") 4 - (text " " <+> pretty cid1 $$ - text "and" <+> pretty cid2) - -- The KEY STEP which makes this a Huet-style unification - -- algorithm. (Also a payoff of using union-find.) - -- We can build infinite unit IDs this way, which is necessary - -- for support mutual recursion. NB: union keeps the SECOND - -- descriptor, so we always arrange for a UnitIdThunkU to live - -- there. - liftST $ UnionFind.union uid1_u uid2_u - F.sequenceA_ $ Map.intersectionWith unifyModule insts1 insts2 + when (cid1 /= cid2) $ + -- TODO: if we had a package identifier, could be an + -- easier to understand error message. + failWith $ + hang + (text "Couldn't match component IDs:") + 4 + ( text " " + <+> pretty cid1 + $$ text "and" + <+> pretty cid2 + ) + -- The KEY STEP which makes this a Huet-style unification + -- algorithm. (Also a payoff of using union-find.) + -- We can build infinite unit IDs this way, which is necessary + -- for support mutual recursion. NB: union keeps the SECOND + -- descriptor, so we always arrange for a UnitIdThunkU to live + -- there. + liftST $ UnionFind.union uid1_u uid2_u + F.sequenceA_ $ Map.intersectionWith unifyModule insts1 insts2 -- | Imperatively unify two modules. unifyModule :: ModuleU s -> ModuleU s -> UnifyM s () unifyModule mod1_u mod2_u - | mod1_u == mod2_u = return () - | otherwise = do - mod1 <- liftST $ UnionFind.find mod1_u - mod2 <- liftST $ UnionFind.find mod2_u - case (mod1, mod2) of - (ModuleVarU _, _) -> liftST $ UnionFind.union mod1_u mod2_u - (_, ModuleVarU _) -> liftST $ UnionFind.union mod2_u mod1_u - (ModuleU uid1 mod_name1, ModuleU uid2 mod_name2) -> do - when (mod_name1 /= mod_name2) $ - failWith $ - hang (text "Cannot match module names") 4 $ - text " " <+> pretty mod_name1 $$ - text "and" <+> pretty mod_name2 - -- NB: this is not actually necessary (because we'll - -- detect loops eventually in 'unifyUnitId'), but it - -- seems harmless enough - liftST $ UnionFind.union mod1_u mod2_u - unifyUnitId uid1 uid2 + | mod1_u == mod2_u = return () + | otherwise = do + mod1 <- liftST $ UnionFind.find mod1_u + mod2 <- liftST $ UnionFind.find mod2_u + case (mod1, mod2) of + (ModuleVarU _, _) -> liftST $ UnionFind.union mod1_u mod2_u + (_, ModuleVarU _) -> liftST $ UnionFind.union mod2_u mod1_u + (ModuleU uid1 mod_name1, ModuleU uid2 mod_name2) -> do + when (mod_name1 /= mod_name2) $ + failWith $ + hang (text "Cannot match module names") 4 $ + text " " + <+> pretty mod_name1 + $$ text "and" + <+> pretty mod_name2 + -- NB: this is not actually necessary (because we'll + -- detect loops eventually in 'unifyUnitId'), but it + -- seems harmless enough + liftST $ UnionFind.union mod1_u mod2_u + unifyUnitId uid1 uid2 diff --git a/Cabal/src/Distribution/Backpack/ModSubst.hs b/Cabal/src/Distribution/Backpack/ModSubst.hs index 7a9a01e3af7..984d4c0be98 100644 --- a/Cabal/src/Distribution/Backpack/ModSubst.hs +++ b/Cabal/src/Distribution/Backpack/ModSubst.hs @@ -5,13 +5,12 @@ -- applied to them. -- -- See also +module Distribution.Backpack.ModSubst + ( ModSubst (..) + ) where -module Distribution.Backpack.ModSubst ( - ModSubst(..), -) where - -import Prelude () import Distribution.Compat.Prelude hiding (mod) +import Prelude () import Distribution.Backpack import Distribution.ModuleName @@ -21,32 +20,33 @@ import qualified Data.Set as Set -- | Applying module substitutions to semantic objects. class ModSubst a where - -- In notation, substitution is postfix, which implies - -- putting it on the right hand side, but for partial - -- application it's more convenient to have it on the left - -- hand side. - modSubst :: OpenModuleSubst -> a -> a + -- In notation, substitution is postfix, which implies + -- putting it on the right hand side, but for partial + -- application it's more convenient to have it on the left + -- hand side. + modSubst :: OpenModuleSubst -> a -> a instance ModSubst OpenModule where - modSubst subst (OpenModule cid mod_name) = OpenModule (modSubst subst cid) mod_name - modSubst subst mod@(OpenModuleVar mod_name) - | Just mod' <- Map.lookup mod_name subst = mod' - | otherwise = mod + modSubst subst (OpenModule cid mod_name) = OpenModule (modSubst subst cid) mod_name + modSubst subst mod@(OpenModuleVar mod_name) + | Just mod' <- Map.lookup mod_name subst = mod' + | otherwise = mod instance ModSubst OpenUnitId where - modSubst subst (IndefFullUnitId cid insts) = IndefFullUnitId cid (modSubst subst insts) - modSubst _subst uid = uid + modSubst subst (IndefFullUnitId cid insts) = IndefFullUnitId cid (modSubst subst insts) + modSubst _subst uid = uid instance ModSubst (Set ModuleName) where - modSubst subst reqs - = Set.union (Set.difference reqs (Map.keysSet subst)) - (openModuleSubstFreeHoles subst) + modSubst subst reqs = + Set.union + (Set.difference reqs (Map.keysSet subst)) + (openModuleSubstFreeHoles subst) -- Substitutions are functorial. NB: this means that -- there is an @instance 'ModSubst' 'ModuleSubst'@! instance ModSubst a => ModSubst (Map k a) where - modSubst subst = fmap (modSubst subst) + modSubst subst = fmap (modSubst subst) instance ModSubst a => ModSubst [a] where - modSubst subst = fmap (modSubst subst) + modSubst subst = fmap (modSubst subst) instance ModSubst a => ModSubst (k, a) where - modSubst subst (x,y) = (x, modSubst subst y) + modSubst subst (x, y) = (x, modSubst subst y) diff --git a/Cabal/src/Distribution/Backpack/ModuleScope.hs b/Cabal/src/Distribution/Backpack/ModuleScope.hs index a6736d528d5..5e18766a15d 100644 --- a/Cabal/src/Distribution/Backpack/ModuleScope.hs +++ b/Cabal/src/Distribution/Backpack/ModuleScope.hs @@ -1,30 +1,31 @@ +{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveFoldable #-} + -- | See -module Distribution.Backpack.ModuleScope ( - -- * Module scopes - ModuleScope(..), - ModuleProvides, - ModuleRequires, - ModuleSource(..), - dispModuleSource, - WithSource(..), - unWithSource, - getSource, - ModuleWithSource, - emptyModuleScope, -) where +module Distribution.Backpack.ModuleScope + ( -- * Module scopes + ModuleScope (..) + , ModuleProvides + , ModuleRequires + , ModuleSource (..) + , dispModuleSource + , WithSource (..) + , unWithSource + , getSource + , ModuleWithSource + , emptyModuleScope + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.ModuleName -import Distribution.Types.IncludeRenaming -import Distribution.Types.PackageName +import Distribution.Pretty import Distribution.Types.ComponentName +import Distribution.Types.IncludeRenaming import Distribution.Types.LibraryName -import Distribution.Pretty +import Distribution.Types.PackageName import Distribution.Backpack import Distribution.Backpack.ModSubst @@ -32,7 +33,6 @@ import Distribution.Backpack.ModSubst import qualified Data.Map as Map import Text.PrettyPrint - ----------------------------------------------------------------------- -- Module scopes @@ -60,17 +60,16 @@ import Text.PrettyPrint -- Alternate strategy: go ahead and unify, and then if it is revealed -- that some requirements got filled "out-of-thin-air", error. - -- | A 'ModuleScope' describes the modules and requirements that -- are in-scope as we are processing a Cabal package. Unlike -- a 'ModuleShape', there may be multiple modules in scope at -- the same 'ModuleName'; this is only an error if we attempt -- to use those modules to fill a requirement. A 'ModuleScope' -- can influence the 'ModuleShape' via a reexport. -data ModuleScope = ModuleScope { - modScopeProvides :: ModuleProvides, - modScopeRequires :: ModuleRequires - } +data ModuleScope = ModuleScope + { modScopeProvides :: ModuleProvides + , modScopeRequires :: ModuleRequires + } -- | An empty 'ModuleScope'. emptyModuleScope :: ModuleScope @@ -79,49 +78,53 @@ emptyModuleScope = ModuleScope Map.empty Map.empty -- | Every 'Module' in scope at a 'ModuleName' is annotated with -- the 'PackageName' it comes from. type ModuleProvides = Map ModuleName [ModuleWithSource] + -- | INVARIANT: entries for ModuleName m, have msrc_module is OpenModuleVar m type ModuleRequires = Map ModuleName [ModuleWithSource] + -- TODO: consider newtping the two types above. -- | Description of where a module participating in mixin linking came -- from. data ModuleSource - = FromMixins PackageName ComponentName IncludeRenaming - | FromBuildDepends PackageName ComponentName - | FromExposedModules ModuleName - | FromOtherModules ModuleName - | FromSignatures ModuleName + = FromMixins PackageName ComponentName IncludeRenaming + | FromBuildDepends PackageName ComponentName + | FromExposedModules ModuleName + | FromOtherModules ModuleName + | FromSignatures ModuleName + -- We don't have line numbers, but if we did, we'd want to record that -- too -- TODO: Deduplicate this with Distribution.Backpack.UnifyM.ci_msg dispModuleSource :: ModuleSource -> Doc -dispModuleSource (FromMixins pn cn incls) - = text "mixins:" <+> dispComponent pn cn <+> pretty incls -dispModuleSource (FromBuildDepends pn cn) - = text "build-depends:" <+> dispComponent pn cn -dispModuleSource (FromExposedModules m) - = text "exposed-modules:" <+> pretty m -dispModuleSource (FromOtherModules m) - = text "other-modules:" <+> pretty m -dispModuleSource (FromSignatures m) - = text "signatures:" <+> pretty m +dispModuleSource (FromMixins pn cn incls) = + text "mixins:" <+> dispComponent pn cn <+> pretty incls +dispModuleSource (FromBuildDepends pn cn) = + text "build-depends:" <+> dispComponent pn cn +dispModuleSource (FromExposedModules m) = + text "exposed-modules:" <+> pretty m +dispModuleSource (FromOtherModules m) = + text "other-modules:" <+> pretty m +dispModuleSource (FromSignatures m) = + text "signatures:" <+> pretty m -- Dependency dispComponent :: PackageName -> ComponentName -> Doc dispComponent pn cn = - -- NB: This syntax isn't quite the source syntax, but it - -- should be clear enough. To do source syntax, we'd - -- need to know what the package we're linking is. - case cn of - CLibName LMainLibName -> pretty pn - CLibName (LSubLibName ucn) -> pretty pn <<>> colon <<>> pretty ucn - -- Case below shouldn't happen - _ -> pretty pn <+> parens (pretty cn) + -- NB: This syntax isn't quite the source syntax, but it + -- should be clear enough. To do source syntax, we'd + -- need to know what the package we're linking is. + case cn of + CLibName LMainLibName -> pretty pn + CLibName (LSubLibName ucn) -> pretty pn <<>> colon <<>> pretty ucn + -- Case below shouldn't happen + _ -> pretty pn <+> parens (pretty cn) -- | An 'OpenModule', annotated with where it came from in a Cabal file. data WithSource a = WithSource ModuleSource a - deriving (Functor, Foldable, Traversable) + deriving (Functor, Foldable, Traversable) + unWithSource :: WithSource a -> a unWithSource (WithSource _ x) = x getSource :: WithSource a -> ModuleSource @@ -129,4 +132,4 @@ getSource (WithSource s _) = s type ModuleWithSource = WithSource OpenModule instance ModSubst a => ModSubst (WithSource a) where - modSubst subst (WithSource s m) = WithSource s (modSubst subst m) + modSubst subst (WithSource s m) = WithSource s (modSubst subst m) diff --git a/Cabal/src/Distribution/Backpack/ModuleShape.hs b/Cabal/src/Distribution/Backpack/ModuleShape.hs index d1862776e13..039a6a30239 100644 --- a/Cabal/src/Distribution/Backpack/ModuleShape.hs +++ b/Cabal/src/Distribution/Backpack/ModuleShape.hs @@ -1,21 +1,22 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} + -- | See -module Distribution.Backpack.ModuleShape ( - -- * Module shapes - ModuleShape(..), - emptyModuleShape, - shapeInstalledPackage, -) where +module Distribution.Backpack.ModuleShape + ( -- * Module shapes + ModuleShape (..) + , emptyModuleShape + , shapeInstalledPackage + ) where -import Prelude () import Distribution.Compat.Prelude hiding (mod) +import Prelude () -import Distribution.ModuleName import Distribution.InstalledPackageInfo as IPI +import Distribution.ModuleName -import Distribution.Backpack.ModSubst import Distribution.Backpack +import Distribution.Backpack.ModSubst import qualified Data.Map as Map import qualified Data.Set as Set @@ -26,18 +27,18 @@ import qualified Data.Set as Set -- | A 'ModuleShape' describes the provisions and requirements of -- a library. We can extract a 'ModuleShape' from an -- 'InstalledPackageInfo'. -data ModuleShape = ModuleShape { - modShapeProvides :: OpenModuleSubst, - modShapeRequires :: Set ModuleName - } - deriving (Eq, Show, Generic, Typeable) +data ModuleShape = ModuleShape + { modShapeProvides :: OpenModuleSubst + , modShapeRequires :: Set ModuleName + } + deriving (Eq, Show, Generic, Typeable) instance Binary ModuleShape instance Structured ModuleShape instance ModSubst ModuleShape where - modSubst subst (ModuleShape provs reqs) - = ModuleShape (modSubst subst provs) (modSubst subst reqs) + modSubst subst (ModuleShape provs reqs) = + ModuleShape (modSubst subst provs) (modSubst subst reqs) -- | The default module shape, with no provisions and no requirements. emptyModuleShape :: ModuleShape @@ -78,7 +79,7 @@ shapeInstalledPackage ipi = ModuleShape (Map.fromList provs) reqs uid = installedOpenUnitId ipi provs = map shapeExposedModule (IPI.exposedModules ipi) reqs = requiredSignatures ipi - shapeExposedModule (IPI.ExposedModule mod_name Nothing) - = (mod_name, OpenModule uid mod_name) - shapeExposedModule (IPI.ExposedModule mod_name (Just mod)) - = (mod_name, mod) + shapeExposedModule (IPI.ExposedModule mod_name Nothing) = + (mod_name, OpenModule uid mod_name) + shapeExposedModule (IPI.ExposedModule mod_name (Just mod)) = + (mod_name, mod) diff --git a/Cabal/src/Distribution/Backpack/PreExistingComponent.hs b/Cabal/src/Distribution/Backpack/PreExistingComponent.hs index 2fcfdf1cc83..859f5424d1b 100644 --- a/Cabal/src/Distribution/Backpack/PreExistingComponent.hs +++ b/Cabal/src/Distribution/Backpack/PreExistingComponent.hs @@ -1,59 +1,55 @@ -- | See -module Distribution.Backpack.PreExistingComponent ( - PreExistingComponent(..), - ipiToPreExistingComponent, -) where +module Distribution.Backpack.PreExistingComponent + ( PreExistingComponent (..) + , ipiToPreExistingComponent + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Backpack.ModuleShape import Distribution.Backpack -import Distribution.Types.ComponentId -import Distribution.Types.MungedPackageId -import Distribution.Types.PackageId -import Distribution.Types.UnitId -import Distribution.Types.ComponentName -import Distribution.Types.PackageName +import Distribution.Backpack.ModuleShape import Distribution.Package +import Distribution.Types.ComponentName +import Distribution.Types.MungedPackageId import qualified Data.Map as Map -import qualified Distribution.InstalledPackageInfo as Installed import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as Installed -- | Stripped down version of 'LinkedComponent' for things -- we don't need to know how to build. -data PreExistingComponent - = PreExistingComponent { - -- | The actual name of the package. This may DISAGREE with 'pc_pkgid' - -- for internal dependencies: e.g., an internal component @lib@ may be - -- munged to @z-pkg-z-lib@, but we still want to use it when we see - -- @lib@ in @build-depends@ - pc_pkgname :: PackageName, - -- | The actual name of the component. - pc_compname :: ComponentName, - pc_munged_id :: MungedPackageId, - pc_uid :: UnitId, - pc_cid :: ComponentId, - pc_open_uid :: OpenUnitId, - pc_shape :: ModuleShape - } +data PreExistingComponent = PreExistingComponent + { pc_pkgname :: PackageName + -- ^ The actual name of the package. This may DISAGREE with 'pc_pkgid' + -- for internal dependencies: e.g., an internal component @lib@ may be + -- munged to @z-pkg-z-lib@, but we still want to use it when we see + -- @lib@ in @build-depends@ + , pc_compname :: ComponentName + -- ^ The actual name of the component. + , pc_munged_id :: MungedPackageId + , pc_uid :: UnitId + , pc_cid :: ComponentId + , pc_open_uid :: OpenUnitId + , pc_shape :: ModuleShape + } -- | Convert an 'InstalledPackageInfo' into a 'PreExistingComponent', -- which was brought into scope under the 'PackageName' (important for -- a package qualified reference.) ipiToPreExistingComponent :: InstalledPackageInfo -> PreExistingComponent ipiToPreExistingComponent ipi = - PreExistingComponent { - pc_pkgname = packageName ipi, - pc_compname = CLibName $ Installed.sourceLibName ipi, - pc_munged_id = mungedId ipi, - pc_uid = Installed.installedUnitId ipi, - pc_cid = Installed.installedComponentId ipi, - pc_open_uid = - IndefFullUnitId (Installed.installedComponentId ipi) - (Map.fromList (Installed.instantiatedWith ipi)), - pc_shape = shapeInstalledPackage ipi + PreExistingComponent + { pc_pkgname = packageName ipi + , pc_compname = CLibName $ Installed.sourceLibName ipi + , pc_munged_id = mungedId ipi + , pc_uid = Installed.installedUnitId ipi + , pc_cid = Installed.installedComponentId ipi + , pc_open_uid = + IndefFullUnitId + (Installed.installedComponentId ipi) + (Map.fromList (Installed.instantiatedWith ipi)) + , pc_shape = shapeInstalledPackage ipi } instance HasMungedPackageId PreExistingComponent where @@ -61,7 +57,8 @@ instance HasMungedPackageId PreExistingComponent where instance Package PreExistingComponent where packageId pec = PackageIdentifier (pc_pkgname pec) v - where MungedPackageId _ v = pc_munged_id pec + where + MungedPackageId _ v = pc_munged_id pec instance HasUnitId PreExistingComponent where installedUnitId = pc_uid diff --git a/Cabal/src/Distribution/Backpack/PreModuleShape.hs b/Cabal/src/Distribution/Backpack/PreModuleShape.hs index f07cd6123e4..1a26e59be5d 100644 --- a/Cabal/src/Distribution/Backpack/PreModuleShape.hs +++ b/Cabal/src/Distribution/Backpack/PreModuleShape.hs @@ -1,38 +1,38 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -module Distribution.Backpack.PreModuleShape ( - PreModuleShape(..), - toPreModuleShape, - renamePreModuleShape, - mixLinkPreModuleShape, -) where +module Distribution.Backpack.PreModuleShape + ( PreModuleShape (..) + , toPreModuleShape + , renamePreModuleShape + , mixLinkPreModuleShape + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import qualified Data.Set as Set import qualified Data.Map as Map +import qualified Data.Set as Set import Distribution.Backpack.ModuleShape +import Distribution.ModuleName import Distribution.Types.IncludeRenaming import Distribution.Types.ModuleRenaming -import Distribution.ModuleName -data PreModuleShape = PreModuleShape { - preModShapeProvides :: Set ModuleName, - preModShapeRequires :: Set ModuleName - } - deriving (Eq, Show, Generic) +data PreModuleShape = PreModuleShape + { preModShapeProvides :: Set ModuleName + , preModShapeRequires :: Set ModuleName + } + deriving (Eq, Show, Generic) toPreModuleShape :: ModuleShape -> PreModuleShape toPreModuleShape (ModuleShape provs reqs) = PreModuleShape (Map.keysSet provs) reqs renamePreModuleShape :: PreModuleShape -> IncludeRenaming -> PreModuleShape renamePreModuleShape (PreModuleShape provs reqs) (IncludeRenaming prov_rn req_rn) = - PreModuleShape - (Set.fromList (mapMaybe prov_fn (Set.toList provs))) - (Set.map req_fn reqs) + PreModuleShape + (Set.fromList (mapMaybe prov_fn (Set.toList provs))) + (Set.map req_fn reqs) where prov_fn = interpModuleRenaming prov_rn req_fn k = fromMaybe k (interpModuleRenaming req_rn k) @@ -41,4 +41,4 @@ mixLinkPreModuleShape :: [PreModuleShape] -> PreModuleShape mixLinkPreModuleShape shapes = PreModuleShape provs (Set.difference reqs provs) where provs = Set.unions (map preModShapeProvides shapes) - reqs = Set.unions (map preModShapeRequires shapes) + reqs = Set.unions (map preModShapeRequires shapes) diff --git a/Cabal/src/Distribution/Backpack/ReadyComponent.hs b/Cabal/src/Distribution/Backpack/ReadyComponent.hs index 1064776203b..7a3523d5eab 100644 --- a/Cabal/src/Distribution/Backpack/ReadyComponent.hs +++ b/Cabal/src/Distribution/Backpack/ReadyComponent.hs @@ -1,186 +1,199 @@ -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeFamilies #-} + -- | See -module Distribution.Backpack.ReadyComponent ( - ReadyComponent(..), - InstantiatedComponent(..), - IndefiniteComponent(..), - rc_depends, - rc_uid, - rc_pkgid, - dispReadyComponent, - toReadyComponents, -) where +module Distribution.Backpack.ReadyComponent + ( ReadyComponent (..) + , InstantiatedComponent (..) + , IndefiniteComponent (..) + , rc_depends + , rc_uid + , rc_pkgid + , dispReadyComponent + , toReadyComponents + ) where -import Prelude () import Distribution.Compat.Prelude hiding ((<>)) +import Prelude () import Distribution.Backpack import Distribution.Backpack.LinkedComponent import Distribution.Backpack.ModuleShape +import Distribution.Compat.Graph (IsNode (..)) import Distribution.Types.AnnotatedId -import Distribution.Types.ModuleRenaming import Distribution.Types.Component -import Distribution.Types.ComponentInclude import Distribution.Types.ComponentId +import Distribution.Types.ComponentInclude import Distribution.Types.ComponentName -import Distribution.Types.PackageId -import Distribution.Types.PackageName.Magic -import Distribution.Types.UnitId -import Distribution.Compat.Graph (IsNode(..)) +import Distribution.Types.Library +import Distribution.Types.LibraryName import Distribution.Types.Module +import Distribution.Types.ModuleRenaming import Distribution.Types.MungedPackageId import Distribution.Types.MungedPackageName -import Distribution.Types.Library -import Distribution.Types.LibraryName +import Distribution.Types.PackageId +import Distribution.Types.PackageName.Magic +import Distribution.Types.UnitId import Distribution.ModuleName import Distribution.Package import Distribution.Simple.Utils import Control.Monad -import Text.PrettyPrint import qualified Data.Map as Map import qualified Data.Set as Set +import Text.PrettyPrint -import Distribution.Version import Distribution.Pretty +import Distribution.Version -- | A 'ReadyComponent' is one that we can actually generate build -- products for. We have a ready component for the typecheck-only -- products of every indefinite package, as well as a ready component -- for every way these packages can be fully instantiated. --- -data ReadyComponent - = ReadyComponent { - rc_ann_id :: AnnotatedId UnitId, - -- | The 'OpenUnitId' for this package. At the moment, this - -- is used in only one case, which is to determine if an - -- export is of a module from this library (indefinite - -- libraries record these exports as 'OpenModule'); - -- 'rc_open_uid' can be conveniently used to test for - -- equality, whereas 'UnitId' cannot always be used in this - -- case. - rc_open_uid :: OpenUnitId, - -- | Corresponds to 'lc_cid'. Invariant: if 'rc_open_uid' - -- records a 'ComponentId', it coincides with this one. - rc_cid :: ComponentId, - -- | Corresponds to 'lc_component'. - rc_component :: Component, - -- | Corresponds to 'lc_exe_deps'. - -- Build-tools don't participate in mix-in linking. - -- (but what if they could?) - rc_exe_deps :: [AnnotatedId UnitId], - -- | Corresponds to 'lc_public'. - rc_public :: Bool, - -- | Extra metadata depending on whether or not this is an - -- indefinite library (typechecked only) or an instantiated - -- component (can be compiled). - rc_i :: Either IndefiniteComponent InstantiatedComponent - } +data ReadyComponent = ReadyComponent + { rc_ann_id :: AnnotatedId UnitId + , rc_open_uid :: OpenUnitId + -- ^ The 'OpenUnitId' for this package. At the moment, this + -- is used in only one case, which is to determine if an + -- export is of a module from this library (indefinite + -- libraries record these exports as 'OpenModule'); + -- 'rc_open_uid' can be conveniently used to test for + -- equality, whereas 'UnitId' cannot always be used in this + -- case. + , rc_cid :: ComponentId + -- ^ Corresponds to 'lc_cid'. Invariant: if 'rc_open_uid' + -- records a 'ComponentId', it coincides with this one. + , rc_component :: Component + -- ^ Corresponds to 'lc_component'. + , rc_exe_deps :: [AnnotatedId UnitId] + -- ^ Corresponds to 'lc_exe_deps'. + -- Build-tools don't participate in mix-in linking. + -- (but what if they could?) + , rc_public :: Bool + -- ^ Corresponds to 'lc_public'. + , rc_i :: Either IndefiniteComponent InstantiatedComponent + -- ^ Extra metadata depending on whether or not this is an + -- indefinite library (typechecked only) or an instantiated + -- component (can be compiled). + } -- | The final, string 'UnitId' that will uniquely identify -- the compilation products of this component. -rc_uid :: ReadyComponent -> UnitId +rc_uid :: ReadyComponent -> UnitId rc_uid = ann_id . rc_ann_id -- | Corresponds to 'lc_pkgid'. -rc_pkgid :: ReadyComponent -> PackageId +rc_pkgid :: ReadyComponent -> PackageId rc_pkgid = ann_pid . rc_ann_id -- | An 'InstantiatedComponent' is a library which is fully instantiated -- (or, possibly, has no requirements at all.) -data InstantiatedComponent - = InstantiatedComponent { - -- | How this library was instantiated. - instc_insts :: [(ModuleName, Module)], - -- | Dependencies induced by 'instc_insts'. These are recorded - -- here because there isn't a convenient way otherwise to get - -- the 'PackageId' we need to fill 'componentPackageDeps' as needed. - instc_insts_deps :: [(UnitId, MungedPackageId)], - -- | The modules exported/reexported by this library. - instc_provides :: Map ModuleName Module, - -- | The dependencies which need to be passed to the compiler - -- to bring modules into scope. These always refer to installed - -- fully instantiated libraries. - instc_includes :: [ComponentInclude DefUnitId ModuleRenaming] - } +data InstantiatedComponent = InstantiatedComponent + { instc_insts :: [(ModuleName, Module)] + -- ^ How this library was instantiated. + , instc_insts_deps :: [(UnitId, MungedPackageId)] + -- ^ Dependencies induced by 'instc_insts'. These are recorded + -- here because there isn't a convenient way otherwise to get + -- the 'PackageId' we need to fill 'componentPackageDeps' as needed. + , instc_provides :: Map ModuleName Module + -- ^ The modules exported/reexported by this library. + , instc_includes :: [ComponentInclude DefUnitId ModuleRenaming] + -- ^ The dependencies which need to be passed to the compiler + -- to bring modules into scope. These always refer to installed + -- fully instantiated libraries. + } -- | An 'IndefiniteComponent' is a library with requirements -- which we will typecheck only. -data IndefiniteComponent - = IndefiniteComponent { - -- | The requirements of the library. - indefc_requires :: [ModuleName], - -- | The modules exported/reexported by this library. - indefc_provides :: Map ModuleName OpenModule, - -- | The dependencies which need to be passed to the compiler - -- to bring modules into scope. These are 'OpenUnitId' because - -- these may refer to partially instantiated libraries. - indefc_includes :: [ComponentInclude OpenUnitId ModuleRenaming] - } +data IndefiniteComponent = IndefiniteComponent + { indefc_requires :: [ModuleName] + -- ^ The requirements of the library. + , indefc_provides :: Map ModuleName OpenModule + -- ^ The modules exported/reexported by this library. + , indefc_includes :: [ComponentInclude OpenUnitId ModuleRenaming] + -- ^ The dependencies which need to be passed to the compiler + -- to bring modules into scope. These are 'OpenUnitId' because + -- these may refer to partially instantiated libraries. + } -- | Compute the dependencies of a 'ReadyComponent' that should -- be recorded in the @depends@ field of 'InstalledPackageInfo'. rc_depends :: ReadyComponent -> [(UnitId, MungedPackageId)] rc_depends rc = ordNub $ - case rc_i rc of - Left indefc -> - map (\ci -> (abstractUnitId $ ci_id ci, toMungedPackageId ci)) - (indefc_includes indefc) - Right instc -> - map (\ci -> (unDefUnitId $ ci_id ci, toMungedPackageId ci)) - (instc_includes instc) - ++ instc_insts_deps instc + case rc_i rc of + Left indefc -> + map + (\ci -> (abstractUnitId $ ci_id ci, toMungedPackageId ci)) + (indefc_includes indefc) + Right instc -> + map + (\ci -> (unDefUnitId $ ci_id ci, toMungedPackageId ci)) + (instc_includes instc) + ++ instc_insts_deps instc where toMungedPackageId :: Pretty id => ComponentInclude id rn -> MungedPackageId toMungedPackageId ci = - computeCompatPackageId - (ci_pkgid ci) - (case ci_cname ci of - CLibName name -> name - _ -> error $ prettyShow (rc_cid rc) ++ - " depends on non-library " ++ prettyShow (ci_id ci)) + computeCompatPackageId + (ci_pkgid ci) + ( case ci_cname ci of + CLibName name -> name + _ -> + error $ + prettyShow (rc_cid rc) + ++ " depends on non-library " + ++ prettyShow (ci_id ci) + ) -- | Get the 'MungedPackageId' of a 'ReadyComponent' IF it is -- a library. rc_munged_id :: ReadyComponent -> MungedPackageId rc_munged_id rc = - computeCompatPackageId - (rc_pkgid rc) - (case rc_component rc of - CLib lib -> libName lib - _ -> error "rc_munged_id: not library") + computeCompatPackageId + (rc_pkgid rc) + ( case rc_component rc of + CLib lib -> libName lib + _ -> error "rc_munged_id: not library" + ) instance Package ReadyComponent where - packageId = rc_pkgid + packageId = rc_pkgid instance HasUnitId ReadyComponent where - installedUnitId = rc_uid + installedUnitId = rc_uid instance IsNode ReadyComponent where - type Key ReadyComponent = UnitId - nodeKey = rc_uid - nodeNeighbors rc = - (case rc_i rc of - Right inst | [] <- instc_insts inst - -> [] - | otherwise - -> [newSimpleUnitId (rc_cid rc)] - _ -> []) ++ - ordNub (map fst (rc_depends rc)) ++ - map ann_id (rc_exe_deps rc) + type Key ReadyComponent = UnitId + nodeKey = rc_uid + nodeNeighbors rc = + ( case rc_i rc of + Right inst + | [] <- instc_insts inst -> + [] + | otherwise -> + [newSimpleUnitId (rc_cid rc)] + _ -> [] + ) + ++ ordNub (map fst (rc_depends rc)) + ++ map ann_id (rc_exe_deps rc) dispReadyComponent :: ReadyComponent -> Doc dispReadyComponent rc = - hang (text (case rc_i rc of - Left _ -> "indefinite" - Right _ -> "definite") - <+> pretty (nodeKey rc) - {- <+> dispModSubst (Map.fromList (lc_insts lc)) -} ) 4 $ - vcat [ text "depends" <+> pretty uid - | uid <- nodeNeighbors rc ] + hang + ( text + ( case rc_i rc of + Left _ -> "indefinite" + Right _ -> "definite" + ) + <+> pretty (nodeKey rc) + {- <+> dispModSubst (Map.fromList (lc_insts lc)) -} + ) + 4 + $ vcat + [ text "depends" <+> pretty uid + | uid <- nodeNeighbors rc + ] -- | The state of 'InstM'; a mapping from 'UnitId's to their -- ready component, or @Nothing@ if its an external @@ -189,22 +202,25 @@ type InstS = Map UnitId (Maybe ReadyComponent) -- | A state monad for doing instantiations (can't use actual -- State because that would be an extra dependency.) -newtype InstM a = InstM { runInstM :: InstS -> (a, InstS) } +newtype InstM a = InstM {runInstM :: InstS -> (a, InstS)} instance Functor InstM where - fmap f (InstM m) = InstM $ \s -> let (x, s') = m s - in (f x, s') + fmap f (InstM m) = InstM $ \s -> + let (x, s') = m s + in (f x, s') instance Applicative InstM where - pure a = InstM $ \s -> (a, s) - InstM f <*> InstM x = InstM $ \s -> let (f', s') = f s - (x', s'') = x s' - in (f' x', s'') + pure a = InstM $ \s -> (a, s) + InstM f <*> InstM x = InstM $ \s -> + let (f', s') = f s + (x', s'') = x s' + in (f' x', s'') instance Monad InstM where - return = pure - InstM m >>= f = InstM $ \s -> let (x, s') = m s - in runInstM (f x) s' + return = pure + InstM m >>= f = InstM $ \s -> + let (x, s') = m s + in runInstM (f x) s' -- | Given a list of 'LinkedComponent's, expand the module graph -- so that we have an instantiated graph containing all of the @@ -222,27 +238,30 @@ instance Monad InstM where -- -- We also call 'improveUnitId' during this process, so that fully -- instantiated components are given 'HashedUnitId'. --- toReadyComponents - :: Map UnitId MungedPackageId - -> Map ModuleName Module -- subst for the public component - -> [LinkedComponent] - -> [ReadyComponent] -toReadyComponents pid_map subst0 comps - = catMaybes (Map.elems ready_map) + :: Map UnitId MungedPackageId + -> Map ModuleName Module -- subst for the public component + -> [LinkedComponent] + -> [ReadyComponent] +toReadyComponents pid_map subst0 comps = + catMaybes (Map.elems ready_map) where - cmap = Map.fromList [ (lc_cid lc, lc) | lc <- comps ] + cmap = Map.fromList [(lc_cid lc, lc) | lc <- comps] - instantiateUnitId :: ComponentId -> Map ModuleName Module - -> InstM DefUnitId + instantiateUnitId + :: ComponentId + -> Map ModuleName Module + -> InstM DefUnitId instantiateUnitId cid insts = InstM $ \s -> - case Map.lookup uid s of - Nothing -> - -- Knot tied - let (r, s') = runInstM (instantiateComponent uid cid insts) - (Map.insert uid r s) - in (def_uid, Map.insert uid r s') - Just _ -> (def_uid, s) + case Map.lookup uid s of + Nothing -> + -- Knot tied + let (r, s') = + runInstM + (instantiateComponent uid cid insts) + (Map.insert uid r s) + in (def_uid, Map.insert uid r s') + Just _ -> (def_uid, s) where -- The mkDefUnitId here indicates that we assume -- that Cabal handles unit id hash allocation. @@ -252,125 +271,142 @@ toReadyComponents pid_map subst0 comps uid = unDefUnitId def_uid instantiateComponent - :: UnitId -> ComponentId -> Map ModuleName Module - -> InstM (Maybe ReadyComponent) + :: UnitId + -> ComponentId + -> Map ModuleName Module + -> InstM (Maybe ReadyComponent) instantiateComponent uid cid insts | Just lc <- Map.lookup cid cmap = do - provides <- traverse (substModule insts) (modShapeProvides (lc_shape lc)) - -- NB: lc_sig_includes is omitted here, because we don't - -- need them to build - includes <- forM (lc_includes lc) $ \ci -> do - uid' <- substUnitId insts (ci_id ci) - return ci { ci_ann_id = fmap (const uid') (ci_ann_id ci) } - exe_deps <- traverse (substExeDep insts) (lc_exe_deps lc) - s <- InstM $ \s -> (s, s) - let getDep (Module dep_def_uid _) - | let dep_uid = unDefUnitId dep_def_uid + provides <- traverse (substModule insts) (modShapeProvides (lc_shape lc)) + -- NB: lc_sig_includes is omitted here, because we don't + -- need them to build + includes <- forM (lc_includes lc) $ \ci -> do + uid' <- substUnitId insts (ci_id ci) + return ci{ci_ann_id = fmap (const uid') (ci_ann_id ci)} + exe_deps <- traverse (substExeDep insts) (lc_exe_deps lc) + s <- InstM $ \s -> (s, s) + let getDep (Module dep_def_uid _) + | let dep_uid = unDefUnitId dep_def_uid = -- Lose DefUnitId invariant for rc_depends - = [(dep_uid, - fromMaybe err_pid $ - Map.lookup dep_uid pid_map <|> - fmap rc_munged_id (join (Map.lookup dep_uid s)))] - where - err_pid = MungedPackageId - (MungedPackageName nonExistentPackageThisIsCabalBug LMainLibName) - (mkVersion [0]) - instc = InstantiatedComponent { - instc_insts = Map.toList insts, - instc_insts_deps = concatMap getDep (Map.elems insts), - instc_provides = provides, - instc_includes = includes - -- NB: there is no dependency on the - -- indefinite version of this instantiated package here, - -- as (1) it doesn't go in depends in the - -- IPI: it's not a run time dep, and (2) - -- we don't have to tell GHC about it, it - -- will match up the ComponentId - -- automatically - } - return $ Just ReadyComponent { - rc_ann_id = (lc_ann_id lc) { ann_id = uid }, - rc_open_uid = DefiniteUnitId (unsafeMkDefUnitId uid), - rc_cid = lc_cid lc, - rc_component = lc_component lc, - rc_exe_deps = exe_deps, - rc_public = lc_public lc, - rc_i = Right instc - } + [ + ( dep_uid + , fromMaybe err_pid $ + Map.lookup dep_uid pid_map + <|> fmap rc_munged_id (join (Map.lookup dep_uid s)) + ) + ] + where + err_pid = + MungedPackageId + (MungedPackageName nonExistentPackageThisIsCabalBug LMainLibName) + (mkVersion [0]) + instc = + InstantiatedComponent + { instc_insts = Map.toList insts + , instc_insts_deps = concatMap getDep (Map.elems insts) + , instc_provides = provides + , instc_includes = includes + -- NB: there is no dependency on the + -- indefinite version of this instantiated package here, + -- as (1) it doesn't go in depends in the + -- IPI: it's not a run time dep, and (2) + -- we don't have to tell GHC about it, it + -- will match up the ComponentId + -- automatically + } + return $ + Just + ReadyComponent + { rc_ann_id = (lc_ann_id lc){ann_id = uid} + , rc_open_uid = DefiniteUnitId (unsafeMkDefUnitId uid) + , rc_cid = lc_cid lc + , rc_component = lc_component lc + , rc_exe_deps = exe_deps + , rc_public = lc_public lc + , rc_i = Right instc + } | otherwise = return Nothing substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId substUnitId _ (DefiniteUnitId uid) = - return uid + return uid substUnitId subst (IndefFullUnitId cid insts) = do - insts' <- substSubst subst insts - instantiateUnitId cid insts' + insts' <- substSubst subst insts + instantiateUnitId cid insts' -- NB: NOT composition - substSubst :: Map ModuleName Module - -> Map ModuleName OpenModule - -> InstM (Map ModuleName Module) + substSubst + :: Map ModuleName Module + -> Map ModuleName OpenModule + -> InstM (Map ModuleName Module) substSubst subst insts = traverse (substModule subst) insts substModule :: Map ModuleName Module -> OpenModule -> InstM Module substModule subst (OpenModuleVar mod_name) - | Just m <- Map.lookup mod_name subst = return m - | otherwise = error "substModule: non-closing substitution" + | Just m <- Map.lookup mod_name subst = return m + | otherwise = error "substModule: non-closing substitution" substModule subst (OpenModule uid mod_name) = do - uid' <- substUnitId subst uid - return (Module uid' mod_name) + uid' <- substUnitId subst uid + return (Module uid' mod_name) - substExeDep :: Map ModuleName Module - -> AnnotatedId OpenUnitId -> InstM (AnnotatedId UnitId) + substExeDep + :: Map ModuleName Module + -> AnnotatedId OpenUnitId + -> InstM (AnnotatedId UnitId) substExeDep insts exe_aid = do - exe_uid' <- substUnitId insts (ann_id exe_aid) - return exe_aid { ann_id = unDefUnitId exe_uid' } + exe_uid' <- substUnitId insts (ann_id exe_aid) + return exe_aid{ann_id = unDefUnitId exe_uid'} indefiniteUnitId :: ComponentId -> InstM UnitId indefiniteUnitId cid = do - let uid = newSimpleUnitId cid - r <- indefiniteComponent uid cid - InstM $ \s -> (uid, Map.insert uid r s) + let uid = newSimpleUnitId cid + r <- indefiniteComponent uid cid + InstM $ \s -> (uid, Map.insert uid r s) indefiniteComponent :: UnitId -> ComponentId -> InstM (Maybe ReadyComponent) indefiniteComponent uid cid | Just lc <- Map.lookup cid cmap = do - -- We're going to process includes, in case some of them - -- are fully definite even without any substitution. We - -- want to build those too; see #5634. - inst_includes <- forM (lc_includes lc) $ \ci -> - if Set.null (openUnitIdFreeHoles (ci_id ci)) - then do uid' <- substUnitId Map.empty (ci_id ci) - return $ ci { ci_ann_id = fmap (const (DefiniteUnitId uid')) (ci_ann_id ci) } - else return ci - exe_deps <- traverse (substExeDep Map.empty) (lc_exe_deps lc) - let indefc = IndefiniteComponent { - indefc_requires = map fst (lc_insts lc), - indefc_provides = modShapeProvides (lc_shape lc), - indefc_includes = inst_includes ++ lc_sig_includes lc - } - return $ Just ReadyComponent { - rc_ann_id = (lc_ann_id lc) { ann_id = uid }, - rc_cid = lc_cid lc, - rc_open_uid = lc_uid lc, - rc_component = lc_component lc, - -- It's always fully built - rc_exe_deps = exe_deps, - rc_public = lc_public lc, - rc_i = Left indefc + -- We're going to process includes, in case some of them + -- are fully definite even without any substitution. We + -- want to build those too; see #5634. + inst_includes <- forM (lc_includes lc) $ \ci -> + if Set.null (openUnitIdFreeHoles (ci_id ci)) + then do + uid' <- substUnitId Map.empty (ci_id ci) + return $ ci{ci_ann_id = fmap (const (DefiniteUnitId uid')) (ci_ann_id ci)} + else return ci + exe_deps <- traverse (substExeDep Map.empty) (lc_exe_deps lc) + let indefc = + IndefiniteComponent + { indefc_requires = map fst (lc_insts lc) + , indefc_provides = modShapeProvides (lc_shape lc) + , indefc_includes = inst_includes ++ lc_sig_includes lc + } + return $ + Just + ReadyComponent + { rc_ann_id = (lc_ann_id lc){ann_id = uid} + , rc_cid = lc_cid lc + , rc_open_uid = lc_uid lc + , rc_component = lc_component lc + , -- It's always fully built + rc_exe_deps = exe_deps + , rc_public = lc_public lc + , rc_i = Left indefc } | otherwise = return Nothing ready_map = snd $ runInstM work Map.empty work - -- Top-level instantiation per subst0 - | not (Map.null subst0) - , [lc] <- filter lc_public (Map.elems cmap) - = do _ <- instantiateUnitId (lc_cid lc) subst0 - return () - | otherwise - = forM_ (Map.elems cmap) $ \lc -> + -- Top-level instantiation per subst0 + | not (Map.null subst0) + , [lc] <- filter lc_public (Map.elems cmap) = + do + _ <- instantiateUnitId (lc_cid lc) subst0 + return () + | otherwise = + forM_ (Map.elems cmap) $ \lc -> if null (lc_insts lc) - then instantiateUnitId (lc_cid lc) Map.empty >> return () - else indefiniteUnitId (lc_cid lc) >> return () + then instantiateUnitId (lc_cid lc) Map.empty >> return () + else indefiniteUnitId (lc_cid lc) >> return () diff --git a/Cabal/src/Distribution/Backpack/UnifyM.hs b/Cabal/src/Distribution/Backpack/UnifyM.hs index 6b18a9d363a..6e0f00d9f63 100644 --- a/Cabal/src/Distribution/Backpack/UnifyM.hs +++ b/Cabal/src/Distribution/Backpack/UnifyM.hs @@ -1,163 +1,163 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} + -- | See -module Distribution.Backpack.UnifyM ( - -- * Unification monad - UnifyM, - runUnifyM, - failWith, - addErr, - failIfErrs, - tryM, - addErrContext, - addErrContextM, - liftST, - - UnifEnv(..), - getUnifEnv, +module Distribution.Backpack.UnifyM + ( -- * Unification monad + UnifyM + , runUnifyM + , failWith + , addErr + , failIfErrs + , tryM + , addErrContext + , addErrContextM + , liftST + , UnifEnv (..) + , getUnifEnv -- * Modules and unit IDs - ModuleU, - ModuleU'(..), - convertModule, - convertModuleU, - - UnitIdU, - UnitIdU'(..), - convertUnitId, - convertUnitIdU, - - ModuleSubstU, - convertModuleSubstU, - convertModuleSubst, - - ModuleScopeU, - emptyModuleScopeU, - convertModuleScopeU, - - ModuleWithSourceU, - - convertInclude, - convertModuleProvides, - convertModuleProvidesU, + , ModuleU + , ModuleU' (..) + , convertModule + , convertModuleU + , UnitIdU + , UnitIdU' (..) + , convertUnitId + , convertUnitIdU + , ModuleSubstU + , convertModuleSubstU + , convertModuleSubst + , ModuleScopeU + , emptyModuleScopeU + , convertModuleScopeU + , ModuleWithSourceU + , convertInclude + , convertModuleProvides + , convertModuleProvidesU + ) where -) where - -import Prelude () import Distribution.Compat.Prelude hiding (mod) +import Prelude () -import Distribution.Backpack.ModuleShape -import Distribution.Backpack.ModuleScope -import Distribution.Backpack.ModSubst -import Distribution.Backpack.FullUnitId import Distribution.Backpack +import Distribution.Backpack.FullUnitId +import Distribution.Backpack.ModSubst +import Distribution.Backpack.ModuleScope +import Distribution.Backpack.ModuleShape -import qualified Distribution.Utils.UnionFind as UnionFind import Distribution.ModuleName import Distribution.Package import Distribution.PackageDescription import Distribution.Pretty -import Distribution.Types.ComponentInclude import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentInclude +import qualified Distribution.Utils.UnionFind as UnionFind import Distribution.Verbosity -import Data.STRef -import Data.Traversable import Control.Monad.ST -import qualified Data.Map as Map -import qualified Data.Set as Set import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import Data.STRef +import qualified Data.Set as Set +import Data.Traversable import Text.PrettyPrint -- TODO: more detailed trace output on high verbosity would probably -- be appreciated by users debugging unification errors. Collect -- some good examples! -data ErrMsg = ErrMsg { - err_msg :: Doc, - err_ctx :: [Doc] - } +data ErrMsg = ErrMsg + { err_msg :: Doc + , err_ctx :: [Doc] + } type MsgDoc = Doc renderErrMsg :: ErrMsg -> MsgDoc -renderErrMsg ErrMsg { err_msg = msg, err_ctx = ctx } = - msg $$ vcat ctx +renderErrMsg ErrMsg{err_msg = msg, err_ctx = ctx} = + msg $$ vcat ctx -- | The unification monad, this monad encapsulates imperative -- unification. -newtype UnifyM s a = UnifyM { unUnifyM :: UnifEnv s -> ST s (Maybe a) } +newtype UnifyM s a = UnifyM {unUnifyM :: UnifEnv s -> ST s (Maybe a)} -- | Run a computation in the unification monad. runUnifyM :: Verbosity -> ComponentId -> FullDb -> (forall s. UnifyM s a) -> Either [MsgDoc] a -runUnifyM verbosity self_cid db m - = runST $ do i <- newSTRef 0 - hmap <- newSTRef Map.empty - errs <- newSTRef [] - mb_r <- unUnifyM m UnifEnv { - unify_uniq = i, - unify_reqs = hmap, - unify_self_cid = self_cid, - unify_verbosity = verbosity, - unify_ctx = [], - unify_db = db, - unify_errs = errs } - final_errs <- readSTRef errs - case mb_r of - Just x | null final_errs -> return (Right x) - _ -> return (Left (map renderErrMsg (reverse final_errs))) +runUnifyM verbosity self_cid db m = + runST $ do + i <- newSTRef 0 + hmap <- newSTRef Map.empty + errs <- newSTRef [] + mb_r <- + unUnifyM + m + UnifEnv + { unify_uniq = i + , unify_reqs = hmap + , unify_self_cid = self_cid + , unify_verbosity = verbosity + , unify_ctx = [] + , unify_db = db + , unify_errs = errs + } + final_errs <- readSTRef errs + case mb_r of + Just x | null final_errs -> return (Right x) + _ -> return (Left (map renderErrMsg (reverse final_errs))) + -- NB: GHC 7.6 throws a hissy fit if you pattern match on 'm'. type ErrCtx s = MsgDoc -- | The unification environment. -data UnifEnv s = UnifEnv { - -- | A supply of unique integers to label 'UnitIdU' - -- cells. This is used to determine loops in unit - -- identifiers (which can happen with mutual recursion.) - unify_uniq :: UnifRef s UnitIdUnique, - -- | The set of requirements in scope. When - -- a provision is brought into scope, we unify with - -- the requirement at the same module name to fill it. - -- This mapping grows monotonically. - unify_reqs :: UnifRef s (Map ModuleName (ModuleU s)), - -- | Component id of the unit we're linking. We use this - -- to detect if we fill a requirement with a local module, - -- which in principle should be OK but is not currently - -- supported by GHC. - unify_self_cid :: ComponentId, - -- | How verbose the error message should be - unify_verbosity :: Verbosity, - -- | The error reporting context - unify_ctx :: [ErrCtx s], - -- | The package index for expanding unit identifiers - unify_db :: FullDb, - -- | Accumulated errors - unify_errs :: UnifRef s [ErrMsg] - } +data UnifEnv s = UnifEnv + { unify_uniq :: UnifRef s UnitIdUnique + -- ^ A supply of unique integers to label 'UnitIdU' + -- cells. This is used to determine loops in unit + -- identifiers (which can happen with mutual recursion.) + , unify_reqs :: UnifRef s (Map ModuleName (ModuleU s)) + -- ^ The set of requirements in scope. When + -- a provision is brought into scope, we unify with + -- the requirement at the same module name to fill it. + -- This mapping grows monotonically. + , unify_self_cid :: ComponentId + -- ^ Component id of the unit we're linking. We use this + -- to detect if we fill a requirement with a local module, + -- which in principle should be OK but is not currently + -- supported by GHC. + , unify_verbosity :: Verbosity + -- ^ How verbose the error message should be + , unify_ctx :: [ErrCtx s] + -- ^ The error reporting context + , unify_db :: FullDb + -- ^ The package index for expanding unit identifiers + , unify_errs :: UnifRef s [ErrMsg] + -- ^ Accumulated errors + } instance Functor (UnifyM s) where - fmap f (UnifyM m) = UnifyM (fmap (fmap (fmap f)) m) + fmap f (UnifyM m) = UnifyM (fmap (fmap (fmap f)) m) instance Applicative (UnifyM s) where - pure = UnifyM . pure . pure . pure - UnifyM f <*> UnifyM x = UnifyM $ \r -> do - f' <- f r - case f' of + pure = UnifyM . pure . pure . pure + UnifyM f <*> UnifyM x = UnifyM $ \r -> do + f' <- f r + case f' of + Nothing -> return Nothing + Just f'' -> do + x' <- x r + case x' of Nothing -> return Nothing - Just f'' -> do - x' <- x r - case x' of - Nothing -> return Nothing - Just x'' -> return (Just (f'' x'')) + Just x'' -> return (Just (f'' x'')) instance Monad (UnifyM s) where - return = pure - UnifyM m >>= f = UnifyM $ \r -> do - x <- m r - case x of - Nothing -> return Nothing - Just x' -> unUnifyM (f x') r + return = pure + UnifyM m >>= f = UnifyM $ \r -> do + x <- m r + case x of + Nothing -> return Nothing + Just x' -> unUnifyM (f x') r -- | Lift a computation from 'ST' monad to 'UnifyM' monad. -- Internal use only. @@ -166,32 +166,35 @@ liftST m = UnifyM $ \_ -> fmap Just m addErr :: MsgDoc -> UnifyM s () addErr msg = do - env <- getUnifEnv - let err = ErrMsg { - err_msg = msg, - err_ctx = unify_ctx env - } - liftST $ modifySTRef (unify_errs env) (\errs -> err:errs) + env <- getUnifEnv + let err = + ErrMsg + { err_msg = msg + , err_ctx = unify_ctx env + } + liftST $ modifySTRef (unify_errs env) (\errs -> err : errs) failWith :: MsgDoc -> UnifyM s a failWith msg = do - addErr msg - failM + addErr msg + failM failM :: UnifyM s a failM = UnifyM $ \_ -> return Nothing failIfErrs :: UnifyM s () failIfErrs = do - env <- getUnifEnv - errs <- liftST $ readSTRef (unify_errs env) - when (not (null errs)) failM + env <- getUnifEnv + errs <- liftST $ readSTRef (unify_errs env) + when (not (null errs)) failM tryM :: UnifyM s a -> UnifyM s (Maybe a) tryM m = - UnifyM (\env -> do + UnifyM + ( \env -> do mb_r <- unUnifyM m env - return (Just mb_r)) + return (Just mb_r) + ) {- otherFail :: ErrMsg -> UnifyM s a @@ -236,8 +239,7 @@ addErrContext ctx m = addErrContextM ctx m -- | Add a message to the error context. It may make monadic queries. addErrContextM :: ErrCtx s -> UnifyM s a -> UnifyM s a addErrContextM ctx m = - UnifyM $ \r -> unUnifyM m r { unify_ctx = ctx : unify_ctx r } - + UnifyM $ \r -> unUnifyM m r{unify_ctx = ctx : unify_ctx r} ----------------------------------------------------------------------- -- The "unifiable" variants of the data types @@ -251,13 +253,13 @@ addErrContextM ctx m = -- | Contents of a mutable 'ModuleU' reference. data ModuleU' s - = ModuleU (UnitIdU s) ModuleName - | ModuleVarU ModuleName + = ModuleU (UnitIdU s) ModuleName + | ModuleVarU ModuleName -- | Contents of a mutable 'UnitIdU' reference. data UnitIdU' s - = UnitIdU UnitIdUnique ComponentId (Map ModuleName (ModuleU s)) - | UnitIdThunkU DefUnitId + = UnitIdU UnitIdUnique ComponentId (Map ModuleName (ModuleU s)) + | UnitIdThunkU DefUnitId -- | A mutable version of 'Module' which can be imperatively unified. type ModuleU s = UnionFind.Point s (ModuleU' s) @@ -273,7 +275,6 @@ type UnitIdU s = UnionFind.Point s (UnitIdU' s) -- participate in unification! type UnitIdUnique = Int - ----------------------------------------------------------------------- -- Conversion to the unifiable data types @@ -286,7 +287,7 @@ type MuEnv s = (IntMap (UnitIdU s), Int) extendMuEnv :: MuEnv s -> UnitIdU s -> MuEnv s extendMuEnv (m, i) x = - (IntMap.insert (i + 1) x m, i + 1) + (IntMap.insert (i + 1) x m, i + 1) {- lookupMuEnv :: MuEnv s -> Int {- de Bruijn index -} -> UnitIdU s @@ -308,37 +309,42 @@ emptyMuEnv = (IntMap.empty, -1) -- @hole:A@ binders. -- * @MuEnv@ - the environment for mu-binders. -convertUnitId' :: MuEnv s - -> OpenUnitId - -> UnifyM s (UnitIdU s) +convertUnitId' + :: MuEnv s + -> OpenUnitId + -> UnifyM s (UnitIdU s) -- TODO: this could be more lazy if we know there are no internal -- references convertUnitId' _ (DefiniteUnitId uid) = - liftST $ UnionFind.fresh (UnitIdThunkU uid) + liftST $ UnionFind.fresh (UnitIdThunkU uid) convertUnitId' stk (IndefFullUnitId cid insts) = do - fs <- fmap unify_uniq getUnifEnv - x <- liftST $ UnionFind.fresh (error "convertUnitId") -- tie the knot later - insts_u <- for insts $ convertModule' (extendMuEnv stk x) - u <- readUnifRef fs - writeUnifRef fs (u+1) - y <- liftST $ UnionFind.fresh (UnitIdU u cid insts_u) - liftST $ UnionFind.union x y - return y + fs <- fmap unify_uniq getUnifEnv + x <- liftST $ UnionFind.fresh (error "convertUnitId") -- tie the knot later + insts_u <- for insts $ convertModule' (extendMuEnv stk x) + u <- readUnifRef fs + writeUnifRef fs (u + 1) + y <- liftST $ UnionFind.fresh (UnitIdU u cid insts_u) + liftST $ UnionFind.union x y + return y + -- convertUnitId' stk (UnitIdVar i) = return (lookupMuEnv stk i) -convertModule' :: MuEnv s - -> OpenModule -> UnifyM s (ModuleU s) +convertModule' + :: MuEnv s + -> OpenModule + -> UnifyM s (ModuleU s) convertModule' _stk (OpenModuleVar mod_name) = do - hmap <- fmap unify_reqs getUnifEnv - hm <- readUnifRef hmap - case Map.lookup mod_name hm of - Nothing -> do mod <- liftST $ UnionFind.fresh (ModuleVarU mod_name) - writeUnifRef hmap (Map.insert mod_name mod hm) - return mod - Just mod -> return mod + hmap <- fmap unify_reqs getUnifEnv + hm <- readUnifRef hmap + case Map.lookup mod_name hm of + Nothing -> do + mod <- liftST $ UnionFind.fresh (ModuleVarU mod_name) + writeUnifRef hmap (Map.insert mod_name mod hm) + return mod + Just mod -> return mod convertModule' stk (OpenModule uid mod_name) = do - uid_u <- convertUnitId' stk uid - liftST $ UnionFind.fresh (ModuleU uid_u mod_name) + uid_u <- convertUnitId' stk uid + liftST $ UnionFind.fresh (ModuleU uid_u mod_name) convertUnitId :: OpenUnitId -> UnifyM s (UnitIdU s) convertUnitId = convertUnitId' emptyMuEnv @@ -346,8 +352,6 @@ convertUnitId = convertUnitId' emptyMuEnv convertModule :: OpenModule -> UnifyM s (ModuleU s) convertModule = convertModule' emptyMuEnv - - ----------------------------------------------------------------------- -- Substitutions @@ -380,9 +384,9 @@ extendMooEnv (m, i) k = (IntMap.insert k (i + 1) m, i + 1) lookupMooEnv :: MooEnv -> UnitIdUnique -> Maybe Int lookupMooEnv (m, i) k = - case IntMap.lookup k m of - Nothing -> Nothing - Just v -> Just (i-v) -- de Bruijn indexize + case IntMap.lookup k m of + Nothing -> Nothing + Just v -> Just (i - v) -- de Bruijn indexize -- The workhorse functions @@ -390,34 +394,36 @@ lookupMooEnv (m, i) k = -- | Otherwise returns a list of signatures instantiated by given `UnitIdU`. convertUnitIdU' :: MooEnv -> UnitIdU s -> Doc -> UnifyM s OpenUnitId convertUnitIdU' stk uid_u required_mod_name = do - x <- liftST $ UnionFind.find uid_u - case x of - UnitIdThunkU uid -> return $ DefiniteUnitId uid - UnitIdU u cid insts_u -> - case lookupMooEnv stk u of - Just _ -> - let mod_names = Map.keys insts_u - in failWithMutuallyRecursiveUnitsError required_mod_name mod_names - Nothing -> do - insts <- for insts_u $ convertModuleU' (extendMooEnv stk u) - return $ IndefFullUnitId cid insts + x <- liftST $ UnionFind.find uid_u + case x of + UnitIdThunkU uid -> return $ DefiniteUnitId uid + UnitIdU u cid insts_u -> + case lookupMooEnv stk u of + Just _ -> + let mod_names = Map.keys insts_u + in failWithMutuallyRecursiveUnitsError required_mod_name mod_names + Nothing -> do + insts <- for insts_u $ convertModuleU' (extendMooEnv stk u) + return $ IndefFullUnitId cid insts convertModuleU' :: MooEnv -> ModuleU s -> UnifyM s OpenModule convertModuleU' stk mod_u = do - mod <- liftST $ UnionFind.find mod_u - case mod of - ModuleVarU mod_name -> return (OpenModuleVar mod_name) - ModuleU uid_u mod_name -> do - uid <- convertUnitIdU' stk uid_u (pretty mod_name) - return (OpenModule uid mod_name) + mod <- liftST $ UnionFind.find mod_u + case mod of + ModuleVarU mod_name -> return (OpenModuleVar mod_name) + ModuleU uid_u mod_name -> do + uid <- convertUnitIdU' stk uid_u (pretty mod_name) + return (OpenModule uid mod_name) failWithMutuallyRecursiveUnitsError :: Doc -> [ModuleName] -> UnifyM s a failWithMutuallyRecursiveUnitsError required_mod_name mod_names = - let sigsList = hcat $ punctuate (text ", ") $ map (quotes . pretty) mod_names in - failWith $ - text "Cannot instantiate requirement" <+> quotes required_mod_name $$ - text "Ensure \"build-depends:\" doesn't include any library with signatures:" <+> sigsList $$ - text "as this creates a cyclic dependency, which GHC does not support." + let sigsList = hcat $ punctuate (text ", ") $ map (quotes . pretty) mod_names + in failWith $ + text "Cannot instantiate requirement" + <+> quotes required_mod_name + $$ text "Ensure \"build-depends:\" doesn't include any library with signatures:" + <+> sigsList + $$ text "as this creates a cyclic dependency, which GHC does not support." -- Helper functions @@ -431,11 +437,12 @@ convertModuleU = convertModuleU' emptyMooEnv emptyModuleScopeU :: ModuleScopeU s emptyModuleScopeU = (Map.empty, Map.empty) - -- | The mutable counterpart of 'ModuleScope'. type ModuleScopeU s = (ModuleProvidesU s, ModuleRequiresU s) + -- | The mutable counterpart of 'ModuleProvides' type ModuleProvidesU s = Map ModuleName [ModuleWithSourceU s] + type ModuleRequiresU s = ModuleProvidesU s type ModuleWithSourceU s = WithSource (ModuleU s) @@ -447,33 +454,41 @@ ci_msg ci where pn = pkgName (ci_pkgid ci) pp_pn = - case ci_cname ci of - CLibName LMainLibName -> pretty pn - CLibName (LSubLibName cn) -> pretty pn <<>> colon <<>> pretty cn - -- Shouldn't happen - cn -> pretty pn <+> parens (pretty cn) + case ci_cname ci of + CLibName LMainLibName -> pretty pn + CLibName (LSubLibName cn) -> pretty pn <<>> colon <<>> pretty cn + -- Shouldn't happen + cn -> pretty pn <+> parens (pretty cn) -- | Convert a 'ModuleShape' into a 'ModuleScopeU', so we can do -- unification on it. convertInclude - :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming - -> UnifyM s (ModuleScopeU s, - Either (ComponentInclude (UnitIdU s) ModuleRenaming) {- normal -} - (ComponentInclude (UnitIdU s) ModuleRenaming) {- sig -}) -convertInclude ci@(ComponentInclude { - ci_ann_id = AnnotatedId { - ann_id = (uid, ModuleShape provs reqs), - ann_pid = pid, - ann_cname = compname - }, - ci_renaming = incl@(IncludeRenaming prov_rns req_rns), - ci_implicit = implicit - }) = addErrContext (text "In" <+> ci_msg ci) $ do + :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming + -> UnifyM + s + ( ModuleScopeU s + , Either + (ComponentInclude (UnitIdU s) ModuleRenaming {- normal -}) + (ComponentInclude (UnitIdU s) ModuleRenaming {- sig -}) + ) +convertInclude + ci@( ComponentInclude + { ci_ann_id = + AnnotatedId + { ann_id = (uid, ModuleShape provs reqs) + , ann_pid = pid + , ann_cname = compname + } + , ci_renaming = incl@(IncludeRenaming prov_rns req_rns) + , ci_implicit = implicit + } + ) = addErrContext (text "In" <+> ci_msg ci) $ do let pn = packageName pid - the_source | implicit - = FromBuildDepends pn compname - | otherwise - = FromMixins pn compname incl + the_source + | implicit = + FromBuildDepends pn compname + | otherwise = + FromMixins pn compname incl source = WithSource the_source -- Suppose our package has two requirements A and B, and @@ -498,27 +513,31 @@ convertInclude ci@(ComponentInclude { case req_rns of DefaultRenaming -> return [] HidingRenaming _ -> do - -- Not valid here for requires! - addErr $ text "Unsupported syntax" <+> - quotes (text "requires hiding (...)") - return [] + -- Not valid here for requires! + addErr $ + text "Unsupported syntax" + <+> quotes (text "requires hiding (...)") + return [] ModuleRenaming rns -> return rns let req_rename_listmap :: Map ModuleName [ModuleName] req_rename_listmap = - Map.fromListWith (++) [ (k,[v]) | (k,v) <- req_rename_list ] + Map.fromListWith (++) [(k, [v]) | (k, v) <- req_rename_list] req_rename <- sequenceA . flip Map.mapWithKey req_rename_listmap $ \k vs0 -> case vs0 of - [] -> error "req_rename" + [] -> error "req_rename" [v] -> return v - v:vs -> do addErr $ - text "Conflicting renamings of requirement" <+> quotes (pretty k) $$ - text "Renamed to: " <+> vcat (map pretty (v:vs)) - return v + v : vs -> do + addErr $ + text "Conflicting renamings of requirement" + <+> quotes (pretty k) + $$ text "Renamed to: " + <+> vcat (map pretty (v : vs)) + return v let req_rename_fn k = case Map.lookup k req_rename of - Nothing -> k - Just v -> v + Nothing -> k + Just v -> v -- Requirement substitution. -- @@ -533,19 +552,25 @@ convertInclude ci@(ComponentInclude { -- mappings. -- -- A -> X ==> X -> , B -> - reqs_u <- convertModuleRequires . Map.fromList $ - [ (k, [source (OpenModuleVar k)]) - | k <- map req_rename_fn (Set.toList reqs) - ] + reqs_u <- + convertModuleRequires . Map.fromList $ + [ (k, [source (OpenModuleVar k)]) + | k <- map req_rename_fn (Set.toList reqs) + ] -- Report errors if there were unused renamings let leftover = Map.keysSet req_rename `Set.difference` reqs unless (Set.null leftover) $ - addErr $ - hang (text "The" <+> text (showComponentName compname) <+> - text "from package" <+> quotes (pretty pid) - <+> text "does not require:") 4 - (vcat (map pretty (Set.toList leftover))) + addErr $ + hang + ( text "The" + <+> text (showComponentName compname) + <+> text "from package" + <+> quotes (pretty pid) + <+> text "does not require:" + ) + 4 + (vcat (map pretty (Set.toList leftover))) -- Provision computation is more complex. -- For example, if we have: @@ -569,56 +594,72 @@ convertInclude ci@(ComponentInclude { -- Importantly, overlapping rename targets get accumulated -- together. It's not an (immediate) error. (pre_prov_scope, prov_rns') <- - case prov_rns of - DefaultRenaming -> return (Map.toList provs, prov_rns) - HidingRenaming hides -> - let hides_set = Set.fromList hides - in let r = [ (k,v) - | (k,v) <- Map.toList provs - , not (k `Set.member` hides_set) ] - -- GHC doesn't understand hiding, so expand it out! - in return (r, ModuleRenaming (map ((\x -> (x,x)).fst) r)) - ModuleRenaming rns -> do - r <- sequence - [ case Map.lookup from provs of - Just m -> return (to, m) - Nothing -> failWith $ - text "Package" <+> quotes (pretty pid) <+> - text "does not expose the module" <+> quotes (pretty from) - | (from, to) <- rns ] - return (r, prov_rns) - let prov_scope = modSubst req_subst - $ Map.fromListWith (++) - [ (k, [source v]) - | (k, v) <- pre_prov_scope ] + case prov_rns of + DefaultRenaming -> return (Map.toList provs, prov_rns) + HidingRenaming hides -> + let hides_set = Set.fromList hides + in let r = + [ (k, v) + | (k, v) <- Map.toList provs + , not (k `Set.member` hides_set) + ] + in -- GHC doesn't understand hiding, so expand it out! + return (r, ModuleRenaming (map ((\x -> (x, x)) . fst) r)) + ModuleRenaming rns -> do + r <- + sequence + [ case Map.lookup from provs of + Just m -> return (to, m) + Nothing -> + failWith $ + text "Package" + <+> quotes (pretty pid) + <+> text "does not expose the module" + <+> quotes (pretty from) + | (from, to) <- rns + ] + return (r, prov_rns) + let prov_scope = + modSubst req_subst $ + Map.fromListWith + (++) + [ (k, [source v]) + | (k, v) <- pre_prov_scope + ] provs_u <- convertModuleProvides prov_scope -- TODO: Assert that provs_u is empty if provs was empty - return ((provs_u, reqs_u), - -- NB: We test that requirements is not null so that - -- users can create packages with zero module exports - -- that cause some C library to linked in, etc. - (if Map.null provs && not (Set.null reqs) - then Right -- is sig - else Left) (ComponentInclude { - ci_ann_id = AnnotatedId { - ann_id = uid_u, - ann_pid = pid, - ann_cname = compname - }, - ci_renaming = prov_rns', - ci_implicit = ci_implicit ci - })) + return + ( (provs_u, reqs_u) + , -- NB: We test that requirements is not null so that + -- users can create packages with zero module exports + -- that cause some C library to linked in, etc. + ( if Map.null provs && not (Set.null reqs) + then Right -- is sig + else Left + ) + ( ComponentInclude + { ci_ann_id = + AnnotatedId + { ann_id = uid_u + , ann_pid = pid + , ann_cname = compname + } + , ci_renaming = prov_rns' + , ci_implicit = ci_implicit ci + } + ) + ) -- | Convert a 'ModuleScopeU' to a 'ModuleScope'. convertModuleScopeU :: ModuleScopeU s -> UnifyM s ModuleScope convertModuleScopeU (provs_u, reqs_u) = do - provs <- convertModuleProvidesU provs_u - reqs <- convertModuleRequiresU reqs_u - -- TODO: Test that the requirements are still free. If they - -- are not, they got unified, and that's dodgy at best. - return (ModuleScope provs reqs) + provs <- convertModuleProvidesU provs_u + reqs <- convertModuleRequiresU reqs_u + -- TODO: Test that the requirements are still free. If they + -- are not, they got unified, and that's dodgy at best. + return (ModuleScope provs reqs) -- | Convert a 'ModuleProvides' to a 'ModuleProvidesU' convertModuleProvides :: ModuleProvides -> UnifyM s (ModuleProvidesU s) diff --git a/Cabal/src/Distribution/Compat/Async.hs b/Cabal/src/Distribution/Compat/Async.hs index a2644974b09..dbc22c58359 100644 --- a/Cabal/src/Distribution/Compat/Async.hs +++ b/Cabal/src/Distribution/Compat/Async.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} + -- | 'Async', yet using 'MVar's. -- -- Adopted from @async@ library @@ -7,24 +8,38 @@ -- Licensed under BSD-3-Clause -- -- @since 3.2.0.0 --- -module Distribution.Compat.Async ( - AsyncM, - withAsync, waitCatch, - wait, asyncThreadId, - cancel, uninterruptibleCancel, AsyncCancelled (..), +module Distribution.Compat.Async + ( AsyncM + , withAsync + , waitCatch + , wait + , asyncThreadId + , cancel + , uninterruptibleCancel + , AsyncCancelled (..) + -- * Cabal extras - withAsyncNF, - ) where + , withAsyncNF + ) where -import Control.Concurrent (ThreadId, forkIO) +import Control.Concurrent (ThreadId, forkIO) import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar) -import Control.DeepSeq (NFData, force) +import Control.DeepSeq (NFData, force) import Control.Exception - (BlockedIndefinitelyOnMVar (..), Exception (..), SomeException (..), catch, evaluate, mask, throwIO, throwTo, try, uninterruptibleMask_) -import Control.Monad (void) -import Data.Typeable (Typeable) -import GHC.Exts (inline) + ( BlockedIndefinitelyOnMVar (..) + , Exception (..) + , SomeException (..) + , catch + , evaluate + , mask + , throwIO + , throwTo + , try + , uninterruptibleMask_ + ) +import Control.Monad (void) +import Data.Typeable (Typeable) +import GHC.Exts (inline) #if MIN_VERSION_base(4,7,0) import Control.Exception (asyncExceptionFromException, asyncExceptionToException) @@ -33,9 +48,9 @@ import Control.Exception (asyncExceptionFromException, asyncExceptionToException -- | Async, but based on 'MVar', as we don't depend on @stm@. data AsyncM a = Async { asyncThreadId :: {-# UNPACK #-} !ThreadId - -- ^ Returns the 'ThreadId' of the thread running - -- the given 'Async'. - , _asyncMVar :: MVar (Either SomeException a) + -- ^ Returns the 'ThreadId' of the thread running + -- the given 'Async'. + , _asyncMVar :: MVar (Either SomeException a) } -- | Spawn an asynchronous action in a separate thread, and pass its @@ -52,12 +67,12 @@ data AsyncM a = Async -- Note: a reference to the child thread is kept alive until the call -- to `withAsync` returns, so nesting many `withAsync` calls requires -- linear memory. --- withAsync :: IO a -> (AsyncM a -> IO b) -> IO b withAsync = inline withAsyncUsing forkIO withAsyncNF :: NFData a => IO a -> (AsyncM a -> IO b) -> IO b -withAsyncNF m = inline withAsyncUsing forkIO (m >>= evaluateNF) where +withAsyncNF m = inline withAsyncUsing forkIO (m >>= evaluateNF) + where evaluateNF = evaluate . force withAsyncUsing :: (IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b @@ -68,7 +83,8 @@ withAsyncUsing doFork = \action inner -> do mask $ \restore -> do t <- doFork $ try (restore action) >>= putMVar var let a = Async t var - r <- restore (inner a) `catchAll` \e -> do + r <- + restore (inner a) `catchAll` \e -> do uninterruptibleCancel a throwIO e uninterruptibleCancel a @@ -79,21 +95,19 @@ withAsyncUsing doFork = \action inner -> do -- exception is re-thrown by 'wait'. -- -- > wait = atomically . waitSTM --- {-# INLINE wait #-} wait :: AsyncM a -> IO a wait a = do - res <- waitCatch a - case res of - Left (SomeException e) -> throwIO e - Right x -> return x + res <- waitCatch a + case res of + Left (SomeException e) -> throwIO e + Right x -> return x -- | Wait for an asynchronous action to complete, and return either -- @Left e@ if the action raised an exception @e@, or @Right a@ if it -- returned a value @a@. -- -- > waitCatch = atomically . waitCatchSTM --- {-# INLINE waitCatch #-} waitCatch :: AsyncM a -> IO (Either SomeException a) waitCatch (Async _ var) = tryAgain (readMVar var) @@ -123,15 +137,18 @@ catchAll = catch {-# INLINE cancel #-} cancel :: AsyncM a -> IO () cancel a@(Async t _) = do - throwTo t AsyncCancelled - void (waitCatch a) + throwTo t AsyncCancelled + void (waitCatch a) -- | The exception thrown by `cancel` to terminate a thread. data AsyncCancelled = AsyncCancelled - deriving (Show, Eq + deriving + ( Show + , Eq , Typeable ) +{- FOURMOLU_DISABLE -} instance Exception AsyncCancelled where #if MIN_VERSION_base(4,7,0) -- wraps in SomeAsyncException @@ -139,6 +156,7 @@ instance Exception AsyncCancelled where fromException = asyncExceptionFromException toException = asyncExceptionToException #endif +{- FOURMOLU_ENABLE -} -- | Cancel an asynchronous action -- diff --git a/Cabal/src/Distribution/Compat/CopyFile.hs b/Cabal/src/Distribution/Compat/CopyFile.hs index 8bed37b630a..fccd593ef78 100644 --- a/Cabal/src/Distribution/Compat/CopyFile.hs +++ b/Cabal/src/Distribution/Compat/CopyFile.hs @@ -1,18 +1,19 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} -module Distribution.Compat.CopyFile ( - copyFile, - copyFileChanged, - filesEqual, - copyOrdinaryFile, - copyExecutableFile, - setFileOrdinary, - setFileExecutable, - setDirOrdinary, + +module Distribution.Compat.CopyFile + ( copyFile + , copyFileChanged + , filesEqual + , copyOrdinaryFile + , copyExecutableFile + , setFileOrdinary + , setFileExecutable + , setDirOrdinary ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () #ifndef mingw32_HOST_OS import Distribution.Compat.Internal.TempFile @@ -66,7 +67,7 @@ import qualified System.Win32.File as Win32 ( copyFile ) #endif /* mingw32_HOST_OS */ copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO () -copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest +copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO () @@ -93,7 +94,7 @@ copyFile :: FilePath -> FilePath -> IO () copyFile fromFPath toFPath = copy `catchIO` (\ioe -> throwIO (ioeSetLocation ioe "copyFile")) - where + where #ifndef mingw32_HOST_OS copy = withBinaryFile fromFPath ReadMode $ \hFrom -> bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) -> @@ -239,8 +240,9 @@ filesEqual :: FilePath -> FilePath -> IO Bool filesEqual f1 f2 = do ex1 <- doesFileExist f1 ex2 <- doesFileExist f2 - if not (ex1 && ex2) then return False else - withBinaryFile f1 ReadMode $ \h1 -> + if not (ex1 && ex2) + then return False + else withBinaryFile f1 ReadMode $ \h1 -> withBinaryFile f2 ReadMode $ \h2 -> do s1 <- hFileSize h1 s2 <- hFileSize h2 diff --git a/Cabal/src/Distribution/Compat/Directory.hs b/Cabal/src/Distribution/Compat/Directory.hs index 07330951c01..9698102842a 100644 --- a/Cabal/src/Distribution/Compat/Directory.hs +++ b/Cabal/src/Distribution/Compat/Directory.hs @@ -1,10 +1,10 @@ {-# LANGUAGE CPP #-} module Distribution.Compat.Directory -( listDirectory -, makeAbsolute -, doesPathExist -) where + ( listDirectory + , makeAbsolute + , doesPathExist + ) where #if MIN_VERSION_directory(1,2,7) import System.Directory as Dir hiding (doesPathExist) @@ -46,4 +46,3 @@ doesPathExist path = do else doesFileExist path #endif - diff --git a/Cabal/src/Distribution/Compat/Environment.hs b/Cabal/src/Distribution/Compat/Environment.hs index fbf9cf41c42..ffe278bcc54 100644 --- a/Cabal/src/Distribution/Compat/Environment.hs +++ b/Cabal/src/Distribution/Compat/Environment.hs @@ -3,16 +3,15 @@ {-# LANGUAGE RankNTypes #-} {-# OPTIONS_HADDOCK hide #-} -module Distribution.Compat.Environment - ( getEnvironment, lookupEnv, setEnv, unsetEnv ) - where +module Distribution.Compat.Environment (getEnvironment, lookupEnv, setEnv, unsetEnv) +where +import Distribution.Compat.Prelude import Prelude () import qualified Prelude -import Distribution.Compat.Prelude -import qualified System.Environment as System import System.Environment (lookupEnv, unsetEnv) +import qualified System.Environment as System import Distribution.Compat.Stack @@ -61,6 +60,7 @@ setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do where _ = callStack -- TODO: attach CallStack to exception +{- FOURMOLU_DISABLE -} # if defined(i386_HOST_ARCH) # define WINDOWS_CCONV stdcall # elif defined(x86_64_HOST_ARCH) @@ -83,3 +83,4 @@ setEnv_ key value = do foreign import ccall unsafe "setenv" c_setenv :: CString -> CString -> CInt -> Prelude.IO CInt #endif /* mingw32_HOST_OS */ +{- FOURMOLU_ENABLE -} diff --git a/Cabal/src/Distribution/Compat/FilePath.hs b/Cabal/src/Distribution/Compat/FilePath.hs index 8c5b11a7262..6e1c7961313 100644 --- a/Cabal/src/Distribution/Compat/FilePath.hs +++ b/Cabal/src/Distribution/Compat/FilePath.hs @@ -1,13 +1,12 @@ {-# LANGUAGE CPP #-} - {-# OPTIONS_GHC -fno-warn-unused-imports #-} module Distribution.Compat.FilePath -( isExtensionOf -, stripExtension -) where + ( isExtensionOf + , stripExtension + ) where -import Data.List ( isSuffixOf, stripPrefix ) +import Data.List (isSuffixOf, stripPrefix) import System.FilePath #if !MIN_VERSION_filepath(1,4,2) diff --git a/Cabal/src/Distribution/Compat/GetShortPathName.hs b/Cabal/src/Distribution/Compat/GetShortPathName.hs index baf402c326b..f6c9517dd71 100644 --- a/Cabal/src/Distribution/Compat/GetShortPathName.hs +++ b/Cabal/src/Distribution/Compat/GetShortPathName.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Compat.GetShortPathName -- @@ -8,12 +9,11 @@ -- Portability : Windows-only -- -- Win32 API 'GetShortPathName' function. +module Distribution.Compat.GetShortPathName (getShortPathName) +where -module Distribution.Compat.GetShortPathName ( getShortPathName ) - where - -import Prelude () import Distribution.Compat.Prelude +import Prelude () #ifdef mingw32_HOST_OS @@ -22,6 +22,7 @@ import qualified System.Win32 as Win32 import System.Win32 (LPCTSTR, LPTSTR, DWORD) import Foreign.Marshal.Array (allocaArray) +{- FOURMOLU_DISABLE -} #ifdef x86_64_HOST_ARCH #define WINAPI ccall #else @@ -57,3 +58,4 @@ getShortPathName :: FilePath -> IO FilePath getShortPathName path = return path #endif +{- FOURMOLU_ENABLE -} diff --git a/Cabal/src/Distribution/Compat/Internal/TempFile.hs b/Cabal/src/Distribution/Compat/Internal/TempFile.hs index bf967ec4dd8..805df700229 100644 --- a/Cabal/src/Distribution/Compat/Internal/TempFile.hs +++ b/Cabal/src/Distribution/Compat/Internal/TempFile.hs @@ -1,17 +1,18 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} -module Distribution.Compat.Internal.TempFile ( - openTempFile, - openBinaryTempFile, - openNewBinaryFile, - createTempDirectory, + +module Distribution.Compat.Internal.TempFile + ( openTempFile + , openBinaryTempFile + , openNewBinaryFile + , createTempDirectory ) where import Distribution.Compat.Exception -import System.FilePath (()) +import System.FilePath (()) -import System.IO (Handle, openTempFile, openBinaryTempFile) +import System.IO (Handle, openBinaryTempFile, openTempFile) #if defined(__IO_MANAGER_WINIO__) import System.IO (openBinaryTempFileWithDefaultPermissions) #else @@ -23,8 +24,8 @@ import System.Posix.Internals (c_open, c_close, o_EXCL, o_BINARY, withFilePath, o_CREAT, o_RDWR, o_NONBLOCK, o_NOCTTY) #endif +import System.IO.Error (isAlreadyExistsError) import System.Posix.Internals (c_getpid) -import System.IO.Error (isAlreadyExistsError) #if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) import System.Directory ( createDirectory ) @@ -33,7 +34,9 @@ import qualified System.Posix #endif -- ------------------------------------------------------------ + -- * temporary files + -- ------------------------------------------------------------ -- This is here for Haskell implementations that do not come with @@ -46,9 +49,10 @@ import qualified System.Posix -- Windows when the new IO manager is used. openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) openNewBinaryFile dir template = do - -- This method can't be used under WINIO. Also the current implementation has - -- thread safety issues depending on which GHC is used. On newer GHC's let's - -- use the built in one. + +-- This method can't be used under WINIO. Also the current implementation has +-- thread safety issues depending on which GHC is used. On newer GHC's let's +-- use the built in one. #if defined(__IO_MANAGER_WINIO__) openBinaryTempFileWithDefaultPermissions dir template #else @@ -126,8 +130,9 @@ createTempDirectory dir template = do r <- tryIO $ mkPrivateDir dirpath case r of Right _ -> return dirpath - Left e | isAlreadyExistsError e -> findTempName (x+1) - | otherwise -> ioError e + Left e + | isAlreadyExistsError e -> findTempName (x + 1) + | otherwise -> ioError e mkPrivateDir :: String -> IO () #if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) diff --git a/Cabal/src/Distribution/Compat/Prelude/Internal.hs b/Cabal/src/Distribution/Compat/Prelude/Internal.hs index b3f998d3313..e13d86284ce 100644 --- a/Cabal/src/Distribution/Compat/Prelude/Internal.hs +++ b/Cabal/src/Distribution/Compat/Prelude/Internal.hs @@ -7,8 +7,8 @@ -- for @Setup.hs@ scripts since its API is /not/ -- stable. module Distribution.Compat.Prelude.Internal - {-# WARNING "This modules' API is not stable. Use at your own risk, or better yet, use @base-compat@!" #-} - ( module Distribution.Compat.Prelude - ) where + {-# WARNING "This modules' API is not stable. Use at your own risk, or better yet, use @base-compat@!" #-} + ( module Distribution.Compat.Prelude + ) where import Distribution.Compat.Prelude diff --git a/Cabal/src/Distribution/Compat/Process.hs b/Cabal/src/Distribution/Compat/Process.hs index 24fc0c861c1..f82fc601287 100644 --- a/Cabal/src/Distribution/Compat/Process.hs +++ b/Cabal/src/Distribution/Compat/Process.hs @@ -1,12 +1,14 @@ {-# LANGUAGE CPP #-} -module Distribution.Compat.Process ( - -- * Redefined functions - proc, + +module Distribution.Compat.Process + ( -- * Redefined functions + proc + -- * Additions - enableProcessJobs, - ) where + , enableProcessJobs + ) where -import System.Process (CreateProcess) +import System.Process (CreateProcess) import qualified System.Process as Process #if defined(mingw32_HOST_OS) && MIN_VERSION_process(1,6,9) @@ -58,4 +60,4 @@ enableProcessJobs cp = cp -- | 'System.Process.proc' with process jobs enabled when appropriate, -- and defaulting 'delegate_ctlc' to 'True'. proc :: FilePath -> [String] -> CreateProcess -proc path args = enableProcessJobs (Process.proc path args) { Process.delegate_ctlc = True } +proc path args = enableProcessJobs (Process.proc path args){Process.delegate_ctlc = True} diff --git a/Cabal/src/Distribution/Compat/ResponseFile.hs b/Cabal/src/Distribution/Compat/ResponseFile.hs index db0a92994c8..d16275fb044 100644 --- a/Cabal/src/Distribution/Compat/ResponseFile.hs +++ b/Cabal/src/Distribution/Compat/ResponseFile.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE CPP, RankNTypes, FlexibleContexts #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} -- Compatibility layer for GHC.ResponseFile -- Implementation from base 4.12.0 is used. @@ -56,11 +58,11 @@ expandResponse = go recursionLimit "." go :: Int -> FilePath -> [String] -> IO [String] go n dir - | n >= 0 = fmap concat . traverse (expand n dir) + | n >= 0 = fmap concat . traverse (expand n dir) | otherwise = const $ hPutStrLn stderr "Error: response file recursion limit exceeded." >> exitFailure expand :: Int -> FilePath -> String -> IO [String] - expand n dir arg@('@':f) = readRecursively n (dir f) `catchIOError` (const $ print "?" >> return [arg]) + expand n dir arg@('@' : f) = readRecursively n (dir f) `catchIOError` (const $ print "?" >> return [arg]) expand _n _dir x = return [x] readRecursively :: Int -> FilePath -> IO [String] diff --git a/Cabal/src/Distribution/Compat/SnocList.hs b/Cabal/src/Distribution/Compat/SnocList.hs index c5679167aa1..d655b302881 100644 --- a/Cabal/src/Distribution/Compat/SnocList.hs +++ b/Cabal/src/Distribution/Compat/SnocList.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Compat.SnocList -- License : BSD3 @@ -8,14 +9,14 @@ -- Portability : portable -- -- A very reversed list. Has efficient `snoc` -module Distribution.Compat.SnocList ( - SnocList, - runSnocList, - snoc, -) where +module Distribution.Compat.SnocList + ( SnocList + , runSnocList + , snoc + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () newtype SnocList a = SnocList [a] @@ -26,8 +27,8 @@ runSnocList :: SnocList a -> [a] runSnocList (SnocList xs) = reverse xs instance Semigroup (SnocList a) where - SnocList xs <> SnocList ys = SnocList (ys <> xs) + SnocList xs <> SnocList ys = SnocList (ys <> xs) instance Monoid (SnocList a) where - mempty = SnocList [] - mappend = (<>) + mempty = SnocList [] + mappend = (<>) diff --git a/Cabal/src/Distribution/Compat/Stack.hs b/Cabal/src/Distribution/Compat/Stack.hs index 0ed0da2e43e..41d4ff8b460 100644 --- a/Cabal/src/Distribution/Compat/Stack.hs +++ b/Cabal/src/Distribution/Compat/Stack.hs @@ -1,16 +1,17 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ImplicitParams #-} -module Distribution.Compat.Stack ( - WithCallStack, - CallStack, - annotateCallStackIO, - withFrozenCallStack, - withLexicalCallStack, - callStack, - prettyCallStack, - parentSrcLocPrefix -) where +{-# LANGUAGE RankNTypes #-} + +module Distribution.Compat.Stack + ( WithCallStack + , CallStack + , annotateCallStackIO + , withFrozenCallStack + , withLexicalCallStack + , callStack + , prettyCallStack + , parentSrcLocPrefix + ) where import System.IO.Error @@ -106,8 +107,9 @@ withLexicalCallStack f = f annotateCallStackIO :: WithCallStack (IO a -> IO a) annotateCallStackIO = modifyIOError f where - f ioe = ioeSetErrorString ioe - . wrapCallStack - $ ioeGetErrorString ioe + f ioe = + ioeSetErrorString ioe + . wrapCallStack + $ ioeGetErrorString ioe wrapCallStack s = - prettyCallStack callStack ++ "\n" ++ s + prettyCallStack callStack ++ "\n" ++ s diff --git a/Cabal/src/Distribution/Compat/Time.hs b/Cabal/src/Distribution/Compat/Time.hs index ef73b4fc8a1..168c2d919b4 100644 --- a/Cabal/src/Distribution/Compat/Time.hs +++ b/Cabal/src/Distribution/Compat/Time.hs @@ -1,32 +1,33 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} module Distribution.Compat.Time - ( ModTime(..) -- Needed for testing - , getModTime, getFileAge, getCurTime - , posixSecondsToModTime - , calibrateMtimeChangeDelay ) - where + ( ModTime (..) -- Needed for testing + , getModTime + , getFileAge + , getCurTime + , posixSecondsToModTime + , calibrateMtimeChangeDelay + ) +where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import System.Directory ( getModificationTime ) +import System.Directory (getModificationTime) -import Distribution.Simple.Utils ( withTempDirectory ) -import Distribution.Verbosity ( silent ) +import Distribution.Simple.Utils (withTempDirectory) +import Distribution.Verbosity (silent) import System.FilePath -import Data.Time.Clock.POSIX ( POSIXTime, getPOSIXTime ) -import Data.Time ( diffUTCTime, getCurrentTime ) -import Data.Time.Clock.POSIX ( posixDayLength ) - +import Data.Time (diffUTCTime, getCurrentTime) +import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixDayLength) #if defined mingw32_HOST_OS @@ -57,7 +58,7 @@ import System.Posix.Files ( modificationTime ) -- | An opaque type representing a file's modification time, represented -- internally as a 64-bit unsigned integer in the Windows UTC format. newtype ModTime = ModTime Word64 - deriving (Binary, Generic, Bounded, Eq, Ord, Typeable) + deriving (Binary, Generic, Bounded, Eq, Ord, Typeable) instance Structured ModTime @@ -101,6 +102,7 @@ getModTime path = allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA $ \info -> do #endif return $! ModTime (qwTime :: Word64) +{- FOURMOLU_DISABLE -} #ifdef x86_64_HOST_ARCH #define CALLCONV ccall #else @@ -138,9 +140,10 @@ extractFileTime :: FileStatus -> ModTime extractFileTime x = posixTimeToModTime (modificationTimeHiRes x) #endif +{- FOURMOLU_ENABLE -} windowsTick, secToUnixEpoch :: Word64 -windowsTick = 10000000 +windowsTick = 10000000 secToUnixEpoch = 11644473600 -- | Convert POSIX seconds to ModTime. @@ -150,8 +153,10 @@ posixSecondsToModTime s = -- | Convert 'POSIXTime' to 'ModTime'. posixTimeToModTime :: POSIXTime -> ModTime -posixTimeToModTime p = ModTime $ (ceiling $ p * 1e7) -- 100 ns precision - + (secToUnixEpoch * windowsTick) +posixTimeToModTime p = + ModTime $ + (ceiling $ p * 1e7) -- 100 ns precision + + (secToUnixEpoch * windowsTick) -- | Return age of given file in days. getFileAge :: FilePath -> IO Double @@ -174,15 +179,15 @@ calibrateMtimeChangeDelay :: IO (Int, Int) calibrateMtimeChangeDelay = withTempDirectory silent "." "calibration-" $ \dir -> do let fileName = dir "probe" - mtimes <- for [1..25] $ \(i::Int) -> time $ do + mtimes <- for [1 .. 25] $ \(i :: Int) -> time $ do writeFile fileName $ show i t0 <- getModTime fileName let spin j = do - writeFile fileName $ show (i,j) + writeFile fileName $ show (i, j) t1 <- getModTime fileName unless (t0 < t1) (spin $ j + 1) - spin (0::Int) - let mtimeChange = maximum mtimes + spin (0 :: Int) + let mtimeChange = maximum mtimes mtimeChange' = min 1000000 $ (max 10000 mtimeChange) * 2 return (mtimeChange, mtimeChange') where diff --git a/Cabal/src/Distribution/GetOpt.hs b/Cabal/src/Distribution/GetOpt.hs index 3dd28a1e462..3a02fede464 100644 --- a/Cabal/src/Distribution/GetOpt.hs +++ b/Cabal/src/Distribution/GetOpt.hs @@ -1,4 +1,7 @@ +{-# LANGUAGE NamedFieldPuns #-} ----------------------------------------------------------------------------- +{-# LANGUAGE TupleSections #-} + -- | -- Module : Distribution.GetOpt -- Copyright : (c) Sven Panne 2002-2005 @@ -20,78 +23,84 @@ -- * Parsing of option arguments is allowed to fail. -- -- * 'ReturnInOrder' argument order is removed. --- -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE NamedFieldPuns #-} -module Distribution.GetOpt ( - -- * GetOpt - getOpt, getOpt', - usageInfo, - ArgOrder(..), - OptDescr(..), - ArgDescr(..), - - -- * Example - -- | See "System.Console.GetOpt" for examples -) where +module Distribution.GetOpt + ( -- * GetOpt + getOpt + , getOpt' + , usageInfo + , ArgOrder (..) + , OptDescr (..) + , ArgDescr (..) + + -- * Example + + -- | See "System.Console.GetOpt" for examples + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -- | What to do with options following non-options data ArgOrder a - = RequireOrder -- ^ no option processing after first non-option - | Permute -- ^ freely intersperse options and non-options - -data OptDescr a = -- description of a single options: - Option [Char] -- list of short option characters - [String] -- list of long option strings (without "--") - (ArgDescr a) -- argument descriptor - String -- explanation of option for user + = -- | no option processing after first non-option + RequireOrder + | -- | freely intersperse options and non-options + Permute + +data OptDescr a -- description of a single options: + = Option + [Char] -- list of short option characters + [String] -- list of long option strings (without "--") + (ArgDescr a) -- argument descriptor + String -- explanation of option for user instance Functor OptDescr where - fmap f (Option a b argDescr c) = Option a b (fmap f argDescr) c + fmap f (Option a b argDescr c) = Option a b (fmap f argDescr) c -- | Describes whether an option takes an argument or not, and if so -- how the argument is parsed to a value of type @a@. -- -- Compared to System.Console.GetOpt, we allow for parse errors. data ArgDescr a - = NoArg a -- ^ no argument expected - | ReqArg (String -> Either String a) String -- ^ option requires argument - | OptArg (Maybe String -> Either String a) String -- ^ optional argument + = -- | no argument expected + NoArg a + | -- | option requires argument + ReqArg (String -> Either String a) String + | -- | optional argument + OptArg (Maybe String -> Either String a) String instance Functor ArgDescr where - fmap f (NoArg a) = NoArg (f a) - fmap f (ReqArg g s) = ReqArg (fmap f . g) s - fmap f (OptArg g s) = OptArg (fmap f . g) s - -data OptKind a -- kind of cmd line arg (internal use only): - = Opt a -- an option - | UnreqOpt String -- an un-recognized option - | NonOpt String -- a non-option - | EndOfOpts -- end-of-options marker (i.e. "--") - | OptErr String -- something went wrong... - -data OptHelp = OptHelp { - optNames :: String, - optHelp :: String - } + fmap f (NoArg a) = NoArg (f a) + fmap f (ReqArg g s) = ReqArg (fmap f . g) s + fmap f (OptArg g s) = OptArg (fmap f . g) s + +data OptKind a -- kind of cmd line arg (internal use only): + = Opt a -- an option + | UnreqOpt String -- an un-recognized option + | NonOpt String -- a non-option + | EndOfOpts -- end-of-options marker (i.e. "--") + | OptErr String -- something went wrong... + +data OptHelp = OptHelp + { optNames :: String + , optHelp :: String + } -- | Return a string describing the usage of a command, derived from -- the header (first argument) and the options described by the -- second argument. -usageInfo :: String -- header - -> [OptDescr a] -- option descriptors - -> String -- nicely formatted description of options +usageInfo + :: String -- header + -> [OptDescr a] -- option descriptors + -> String -- nicely formatted description of options usageInfo header optDescr = unlines (header : table) where options = flip map optDescr $ \(Option sos los ad d) -> OptHelp { optNames = - intercalate ", " $ - map (fmtShort ad) sos ++ - map (fmtLong ad) (take 1 los) + intercalate ", " $ + map (fmtShort ad) sos + ++ map (fmtLong ad) (take 1 los) , optHelp = d } @@ -103,8 +112,9 @@ usageInfo header optDescr = unlines (header : table) OptHelp{optNames, optHelp} <- options let wrappedHelp = wrapText descolWidth optHelp if length optNames >= maxOptNameWidth - then [" " ++ optNames] ++ - renderColumns [] wrappedHelp + then + [" " ++ optNames] + ++ renderColumns [] wrappedHelp else renderColumns [optNames] wrappedHelp renderColumns :: [String] -> [String] -> [String] @@ -112,146 +122,155 @@ usageInfo header optDescr = unlines (header : table) (x, y) <- zipDefault "" "" xs ys return $ " " ++ padTo maxOptNameWidth x ++ " " ++ y - padTo n x = take n (x ++ repeat ' ') + padTo n x = take n (x ++ repeat ' ') -zipDefault :: a -> b -> [a] -> [b] -> [(a,b)] -zipDefault _ _ [] [] = [] -zipDefault _ bd (a:as) [] = (a,bd) : map (,bd) as -zipDefault ad _ [] (b:bs) = (ad,b) : map (ad,) bs -zipDefault ad bd (a:as) (b:bs) = (a,b) : zipDefault ad bd as bs +zipDefault :: a -> b -> [a] -> [b] -> [(a, b)] +zipDefault _ _ [] [] = [] +zipDefault _ bd (a : as) [] = (a, bd) : map (,bd) as +zipDefault ad _ [] (b : bs) = (ad, b) : map (ad,) bs +zipDefault ad bd (a : as) (b : bs) = (a, b) : zipDefault ad bd as bs fmtShort :: ArgDescr a -> Char -> String -fmtShort (NoArg _ ) so = "-" ++ [so] -fmtShort (ReqArg _ _) so = "-" ++ [so] -fmtShort (OptArg _ _) so = "-" ++ [so] - -- unlike upstream GetOpt we omit the arg name for short options +fmtShort (NoArg _) so = "-" ++ [so] +fmtShort (ReqArg _ _) so = "-" ++ [so] +fmtShort (OptArg _ _) so = "-" ++ [so] + +-- unlike upstream GetOpt we omit the arg name for short options fmtLong :: ArgDescr a -> String -> String -fmtLong (NoArg _ ) lo = "--" ++ lo +fmtLong (NoArg _) lo = "--" ++ lo fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" wrapText :: Int -> String -> [String] wrapText width = map unwords . wrap 0 [] . words - where wrap :: Int -> [String] -> [String] -> [[String]] - wrap 0 [] (w:ws) - | length w + 1 > width - = wrap (length w) [w] ws - wrap col line (w:ws) - | col + length w + 1 > width - = reverse line : wrap 0 [] (w:ws) - wrap col line (w:ws) - = let col' = col + length w + 1 - in wrap col' (w:line) ws - wrap _ [] [] = [] - wrap _ line [] = [reverse line] - -{-| -Process the command-line, and return the list of values that matched -(and those that didn\'t). The arguments are: - -* The order requirements (see 'ArgOrder') - -* The option descriptions (see 'OptDescr') - -* The actual command line arguments (presumably got from - 'System.Environment.getArgs'). - -'getOpt' returns a triple consisting of the option arguments, a list -of non-options, and a list of error messages. --} -getOpt :: ArgOrder a -- non-option handling - -> [OptDescr a] -- option descriptors - -> [String] -- the command-line arguments - -> ([a],[String],[String]) -- (options,non-options,error messages) -getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us) - where (os,xs,us,es) = getOpt' ordering optDescr args - -{-| -This is almost the same as 'getOpt', but returns a quadruple -consisting of the option arguments, a list of non-options, a list of -unrecognized options, and a list of error messages. --} -getOpt' :: ArgOrder a -- non-option handling - -> [OptDescr a] -- option descriptors - -> [String] -- the command-line arguments - -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages) -getOpt' _ _ [] = ([],[],[],[]) -getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering - where procNextOpt (Opt o) _ = (o:os,xs,us,es) - procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es) - procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[]) - procNextOpt (NonOpt x) Permute = (os,x:xs,us,es) - procNextOpt EndOfOpts RequireOrder = ([],rest,[],[]) - procNextOpt EndOfOpts Permute = ([],rest,[],[]) - procNextOpt (OptErr e) _ = (os,xs,us,e:es) - - (opt,rest) = getNext arg args optDescr - (os,xs,us,es) = getOpt' ordering optDescr rest + where + wrap :: Int -> [String] -> [String] -> [[String]] + wrap 0 [] (w : ws) + | length w + 1 > width = + wrap (length w) [w] ws + wrap col line (w : ws) + | col + length w + 1 > width = + reverse line : wrap 0 [] (w : ws) + wrap col line (w : ws) = + let col' = col + length w + 1 + in wrap col' (w : line) ws + wrap _ [] [] = [] + wrap _ line [] = [reverse line] + +-- | +-- Process the command-line, and return the list of values that matched +-- (and those that didn\'t). The arguments are: +-- +-- * The order requirements (see 'ArgOrder') +-- +-- * The option descriptions (see 'OptDescr') +-- +-- * The actual command line arguments (presumably got from +-- 'System.Environment.getArgs'). +-- +-- 'getOpt' returns a triple consisting of the option arguments, a list +-- of non-options, and a list of error messages. +getOpt + :: ArgOrder a -- non-option handling + -> [OptDescr a] -- option descriptors + -> [String] -- the command-line arguments + -> ([a], [String], [String]) -- (options,non-options,error messages) +getOpt ordering optDescr args = (os, xs, es ++ map errUnrec us) + where + (os, xs, us, es) = getOpt' ordering optDescr args + +-- | +-- This is almost the same as 'getOpt', but returns a quadruple +-- consisting of the option arguments, a list of non-options, a list of +-- unrecognized options, and a list of error messages. +getOpt' + :: ArgOrder a -- non-option handling + -> [OptDescr a] -- option descriptors + -> [String] -- the command-line arguments + -> ([a], [String], [String], [String]) -- (options,non-options,unrecognized,error messages) +getOpt' _ _ [] = ([], [], [], []) +getOpt' ordering optDescr (arg : args) = procNextOpt opt ordering + where + procNextOpt (Opt o) _ = (o : os, xs, us, es) + procNextOpt (UnreqOpt u) _ = (os, xs, u : us, es) + procNextOpt (NonOpt x) RequireOrder = ([], x : rest, [], []) + procNextOpt (NonOpt x) Permute = (os, x : xs, us, es) + procNextOpt EndOfOpts RequireOrder = ([], rest, [], []) + procNextOpt EndOfOpts Permute = ([], rest, [], []) + procNextOpt (OptErr e) _ = (os, xs, us, e : es) + + (opt, rest) = getNext arg args optDescr + (os, xs, us, es) = getOpt' ordering optDescr rest -- take a look at the next cmd line arg and decide what to do with it -getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) -getNext ('-':'-':[]) rest _ = (EndOfOpts,rest) -getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr -getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr -getNext a rest _ = (NonOpt a,rest) +getNext :: String -> [String] -> [OptDescr a] -> (OptKind a, [String]) +getNext ('-' : '-' : []) rest _ = (EndOfOpts, rest) +getNext ('-' : '-' : xs) rest optDescr = longOpt xs rest optDescr +getNext ('-' : x : xs) rest optDescr = shortOpt x xs rest optDescr +getNext a rest _ = (NonOpt a, rest) -- handle long option -longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a, [String]) longOpt ls rs optDescr = long ads arg rs - where (opt,arg) = break (=='=') ls - getWith p = [ o | o@(Option _ xs _ _) <- optDescr - , isJust (find (p opt) xs)] - exact = getWith (==) - options = if null exact then getWith isPrefixOf else exact - ads = [ ad | Option _ _ ad _ <- options ] - optStr = "--" ++ opt - fromRes = fromParseResult optStr - - long (_:_:_) _ rest = (errAmbig options optStr,rest) - long [NoArg a ] [] rest = (Opt a,rest) - long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest) - long [ReqArg _ d] [] [] = (errReq d optStr,[]) - long [ReqArg f _] [] (r:rest) = (fromRes (f r),rest) - long [ReqArg f _] ('=':xs) rest = (fromRes (f xs),rest) - long [OptArg f _] [] rest = (fromRes (f Nothing),rest) - long [OptArg f _] ('=':xs) rest = (fromRes (f (Just xs)),rest) - long _ _ rest = (UnreqOpt ("--"++ls),rest) + where + (opt, arg) = break (== '=') ls + getWith p = + [ o | o@(Option _ xs _ _) <- optDescr, isJust (find (p opt) xs) + ] + exact = getWith (==) + options = if null exact then getWith isPrefixOf else exact + ads = [ad | Option _ _ ad _ <- options] + optStr = "--" ++ opt + fromRes = fromParseResult optStr + + long (_ : _ : _) _ rest = (errAmbig options optStr, rest) + long [NoArg a] [] rest = (Opt a, rest) + long [NoArg _] ('=' : _) rest = (errNoArg optStr, rest) + long [ReqArg _ d] [] [] = (errReq d optStr, []) + long [ReqArg f _] [] (r : rest) = (fromRes (f r), rest) + long [ReqArg f _] ('=' : xs) rest = (fromRes (f xs), rest) + long [OptArg f _] [] rest = (fromRes (f Nothing), rest) + long [OptArg f _] ('=' : xs) rest = (fromRes (f (Just xs)), rest) + long _ _ rest = (UnreqOpt ("--" ++ ls), rest) -- handle short option -shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a, [String]) shortOpt y ys rs optDescr = short ads ys rs - where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ] - ads = [ ad | Option _ _ ad _ <- options ] - optStr = '-':[y] - fromRes = fromParseResult optStr - - short (_:_:_) _ rest = (errAmbig options optStr,rest) - short (NoArg a :_) [] rest = (Opt a,rest) - short (NoArg a :_) xs rest = (Opt a,('-':xs):rest) - short (ReqArg _ d:_) [] [] = (errReq d optStr,[]) - short (ReqArg f _:_) [] (r:rest) = (fromRes (f r),rest) - short (ReqArg f _:_) xs rest = (fromRes (f xs),rest) - short (OptArg f _:_) [] rest = (fromRes (f Nothing),rest) - short (OptArg f _:_) xs rest = (fromRes (f (Just xs)),rest) - short [] [] rest = (UnreqOpt optStr,rest) - short [] xs rest = (UnreqOpt (optStr++xs),rest) - -- This is different vs upstream = (UnreqOpt optStr,('-':xs):rest) - -- Apparently this was part of the change so that flags that are - -- not recognised as global flags are passed on to the sub-command. - -- But why was no equivalent change required for longOpt? So could - -- this change go upstream? + where + options = [o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s] + ads = [ad | Option _ _ ad _ <- options] + optStr = '-' : [y] + fromRes = fromParseResult optStr + + short (_ : _ : _) _ rest = (errAmbig options optStr, rest) + short (NoArg a : _) [] rest = (Opt a, rest) + short (NoArg a : _) xs rest = (Opt a, ('-' : xs) : rest) + short (ReqArg _ d : _) [] [] = (errReq d optStr, []) + short (ReqArg f _ : _) [] (r : rest) = (fromRes (f r), rest) + short (ReqArg f _ : _) xs rest = (fromRes (f xs), rest) + short (OptArg f _ : _) [] rest = (fromRes (f Nothing), rest) + short (OptArg f _ : _) xs rest = (fromRes (f (Just xs)), rest) + short [] [] rest = (UnreqOpt optStr, rest) + short [] xs rest = (UnreqOpt (optStr ++ xs), rest) + +-- This is different vs upstream = (UnreqOpt optStr,('-':xs):rest) +-- Apparently this was part of the change so that flags that are +-- not recognised as global flags are passed on to the sub-command. +-- But why was no equivalent change required for longOpt? So could +-- this change go upstream? fromParseResult :: String -> Either String a -> OptKind a fromParseResult optStr res = case res of - Right x -> Opt x - Left err -> OptErr ("invalid argument to option `" ++ optStr ++ "': " ++ err ++ "\n") + Right x -> Opt x + Left err -> OptErr ("invalid argument to option `" ++ optStr ++ "': " ++ err ++ "\n") -- miscellaneous error formatting errAmbig :: [OptDescr a] -> String -> OptKind b errAmbig ods optStr = OptErr (usageInfo header ods) - where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" + where + header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" errReq :: String -> String -> OptKind a errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n") diff --git a/Cabal/src/Distribution/Lex.hs b/Cabal/src/Distribution/Lex.hs index 4dbab5932fe..4ca1f512ce5 100644 --- a/Cabal/src/Distribution/Lex.hs +++ b/Cabal/src/Distribution/Lex.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Lex -- Copyright : Ben Gamari 2015-2019 @@ -7,34 +8,35 @@ -- Portability : portable -- -- This module contains a simple lexer supporting quoted strings +module Distribution.Lex + ( tokenizeQuotedWords + ) where -module Distribution.Lex ( - tokenizeQuotedWords - ) where - -import Prelude () -import Distribution.Compat.Prelude import Distribution.Compat.DList +import Distribution.Compat.Prelude +import Prelude () tokenizeQuotedWords :: String -> [String] tokenizeQuotedWords = filter (not . null) . go False mempty where - go :: Bool -- ^ in quoted region - -> DList Char -- ^ accumulator - -> String -- ^ string to be parsed - -> [String] -- ^ parse result + go + :: Bool + -- \^ in quoted region + -> DList Char + -- \^ accumulator + -> String + -- \^ string to be parsed + -> [String] + -- \^ parse result go _ accum [] | [] <- accum' = [] - | otherwise = [accum'] - where accum' = runDList accum - - go False accum (c:cs) + | otherwise = [accum'] + where + accum' = runDList accum + go False accum (c : cs) | isSpace c = runDList accum : go False mempty cs - | c == '"' = go True accum cs - - go True accum (c:cs) - | c == '"' = go False accum cs - - go quoted accum (c:cs) - = go quoted (accum `mappend` singleton c) cs - + | c == '"' = go True accum cs + go True accum (c : cs) + | c == '"' = go False accum cs + go quoted accum (c : cs) = + go quoted (accum `mappend` singleton c) cs diff --git a/Cabal/src/Distribution/Make.hs b/Cabal/src/Distribution/Make.hs index b5651d3b323..716033e42a3 100644 --- a/Cabal/src/Distribution/Make.hs +++ b/Cabal/src/Distribution/Make.hs @@ -2,6 +2,11 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + +-- copy : +-- $(MAKE) install prefix=$(destdir)/$(prefix) \ +-- bindir=$(destdir)/$(bindir) \ + -- | -- Module : Distribution.Make -- Copyright : Martin Sjögren 2004 @@ -51,32 +56,28 @@ -- [UnregisterCmd] We assume there is an @unregister@ target. -- -- [HaddockCmd] We assume there is a @docs@ or @doc@ target. - - --- copy : --- $(MAKE) install prefix=$(destdir)/$(prefix) \ --- bindir=$(destdir)/$(bindir) \ - -module Distribution.Make ( - module Distribution.Package, - License(..), Version, - defaultMain, defaultMainArgs +module Distribution.Make + ( module Distribution.Package + , License (..) + , Version + , defaultMain + , defaultMainArgs ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -- local import Distribution.Package +import Distribution.Simple.Command import Distribution.Simple.Program import Distribution.Simple.Setup -import Distribution.Simple.Command import Distribution.Simple.Utils import Distribution.License -import Distribution.Version import Distribution.Pretty +import Distribution.Version import System.Environment (getArgs, getProgName) @@ -89,18 +90,18 @@ defaultMainArgs = defaultMainHelper defaultMainHelper :: [String] -> IO () defaultMainHelper args = case commandsRun (globalCommand commands) commands args of - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo (flags, commandParse) -> + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (flags, commandParse) -> case commandParse of - _ | fromFlag (globalVersion flags) -> printVersion + _ + | fromFlag (globalVersion flags) -> printVersion | fromFlag (globalNumericVersion flags) -> printNumericVersion - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo action -> action - + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> action where printHelp help = getProgName >>= putStr . help printOptionsList = putStr . unlines @@ -108,20 +109,22 @@ defaultMainHelper args = putStr (intercalate "\n" errs) exitWith (ExitFailure 1) printNumericVersion = putStrLn $ prettyShow cabalVersion - printVersion = putStrLn $ "Cabal library version " - ++ prettyShow cabalVersion + printVersion = + putStrLn $ + "Cabal library version " + ++ prettyShow cabalVersion progs = defaultProgramDb commands = - [configureCommand progs `commandAddAction` configureAction - ,buildCommand progs `commandAddAction` buildAction - ,installCommand `commandAddAction` installAction - ,copyCommand `commandAddAction` copyAction - ,haddockCommand `commandAddAction` haddockAction - ,cleanCommand `commandAddAction` cleanAction - ,sdistCommand `commandAddAction` sdistAction - ,registerCommand `commandAddAction` registerAction - ,unregisterCommand `commandAddAction` unregisterAction + [ configureCommand progs `commandAddAction` configureAction + , buildCommand progs `commandAddAction` buildAction + , installCommand `commandAddAction` installAction + , copyCommand `commandAddAction` copyAction + , haddockCommand `commandAddAction` haddockAction + , cleanCommand `commandAddAction` cleanAction + , sdistCommand `commandAddAction` sdistAction + , registerCommand `commandAddAction` registerAction + , unregisterCommand `commandAddAction` unregisterAction ] configureAction :: ConfigFlags -> [String] -> IO () @@ -130,16 +133,17 @@ configureAction flags args = do let verbosity = fromFlag (configVerbosity flags) rawSystemExit verbosity "sh" $ "configure" - : configureArgs backwardsCompatHack flags - where backwardsCompatHack = True + : configureArgs backwardsCompatHack flags + where + backwardsCompatHack = True copyAction :: CopyFlags -> [String] -> IO () copyAction flags args = do noExtraFlags args let destArgs = case fromFlag $ copyDest flags of - NoCopyDest -> ["install"] - CopyTo path -> ["copy", "destdir=" ++ path] - CopyToDb _ -> error "CopyToDb not supported via Make" + NoCopyDest -> ["install"] + CopyTo path -> ["copy", "destdir=" ++ path] + CopyToDb _ -> error "CopyToDb not supported via Make" rawSystemExit (fromFlag $ copyVerbosity flags) "make" destArgs @@ -154,7 +158,7 @@ haddockAction flags args = do noExtraFlags args rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["docs"] `catchIO` \_ -> - rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"] + rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"] buildAction :: BuildFlags -> [String] -> IO () buildAction flags args = do @@ -172,7 +176,7 @@ sdistAction flags args = do rawSystemExit (fromFlag $ sDistVerbosity flags) "make" ["dist"] registerAction :: RegisterFlags -> [String] -> IO () -registerAction flags args = do +registerAction flags args = do noExtraFlags args rawSystemExit (fromFlag $ regVerbosity flags) "make" ["register"] diff --git a/Cabal/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs index e602a9a6ee3..edb5d039f87 100644 --- a/Cabal/src/Distribution/PackageDescription/Check.hs +++ b/Cabal/src/Distribution/PackageDescription/Check.hs @@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.PackageDescription.Check -- Copyright : Lennart Kolmodin 2008 @@ -21,86 +22,93 @@ -- reason for this is that we want to hold packages that are expected to be -- distributed to a higher standard than packages that are only ever expected -- to be used on the author's own environment. - -module Distribution.PackageDescription.Check ( - -- * Package Checking - CheckExplanation(..), - PackageCheck(..), - checkPackage, - checkConfiguredPackage, - wrapParseWarning, - ppPackageCheck, - isHackageDistError, - - -- ** Checking package contents - checkPackageFiles, - checkPackageContent, - CheckPackageContentOps(..), - checkPackageFileNames, +module Distribution.PackageDescription.Check + ( -- * Package Checking + CheckExplanation (..) + , PackageCheck (..) + , checkPackage + , checkConfiguredPackage + , wrapParseWarning + , ppPackageCheck + , isHackageDistError + + -- ** Checking package contents + , checkPackageFiles + , checkPackageContent + , CheckPackageContentOps (..) + , checkPackageFileNames ) where -import Data.Foldable (foldrM) +import Data.Foldable (foldrM) import Distribution.Compat.Prelude import Prelude () -import Data.List (delete, group) +import Data.List (delete, group) import Distribution.CabalSpecVersion import Distribution.Compat.Lens import Distribution.Compiler import Distribution.License -import Distribution.ModuleName (ModuleName) +import Distribution.ModuleName (ModuleName) import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Configuration -import Distribution.Parsec.Warning (PWarning, showPWarning) -import Distribution.Pretty (prettyShow) -import Distribution.Simple.BuildPaths (autogenPackageInfoModuleName, autogenPathsModuleName) +import Distribution.Parsec.Warning (PWarning, showPWarning) +import Distribution.Pretty (prettyShow) +import Distribution.Simple.BuildPaths (autogenPackageInfoModuleName, autogenPathsModuleName) import Distribution.Simple.BuildToolDepends import Distribution.Simple.CCompiler import Distribution.Simple.Glob -import Distribution.Simple.Utils hiding (findPackageDesc, notice) +import Distribution.Simple.Utils hiding (findPackageDesc, notice) import Distribution.System import Distribution.Types.ComponentRequestedSpec import Distribution.Types.PackageName.Magic -import Distribution.Utils.Generic (isAscii) +import Distribution.Utils.Generic (isAscii) +import Distribution.Utils.Path import Distribution.Verbosity import Distribution.Version -import Distribution.Utils.Path import Language.Haskell.Extension import System.FilePath - ( makeRelative, normalise, splitDirectories, splitExtension, splitPath - , takeExtension, takeFileName, (<.>), ()) - -import qualified Data.ByteString.Lazy as BS -import qualified Data.Map as Map + ( makeRelative + , normalise + , splitDirectories + , splitExtension + , splitPath + , takeExtension + , takeFileName + , (<.>) + , () + ) + +import qualified Data.ByteString.Lazy as BS +import qualified Data.Map as Map import qualified Distribution.Compat.DList as DList -import qualified Distribution.SPDX as SPDX -import qualified System.Directory as System +import qualified Distribution.SPDX as SPDX +import qualified System.Directory as System -import qualified System.Directory (getDirectoryContents) +import qualified System.Directory (getDirectoryContents) import qualified System.FilePath.Windows as FilePath.Windows (isValid) import qualified Data.Set as Set import qualified Distribution.Utils.ShortText as ShortText -import qualified Distribution.Types.BuildInfo.Lens as L +import qualified Distribution.Types.BuildInfo.Lens as L import qualified Distribution.Types.GenericPackageDescription.Lens as L -import qualified Distribution.Types.PackageDescription.Lens as L +import qualified Distribution.Types.PackageDescription.Lens as L -- $setup -- >>> import Control.Arrow ((&&&)) -- ------------------------------------------------------------ + -- * Warning messages + -- ------------------------------------------------------------ -- | Which stanza does `CheckExplanation` refer to? --- data CEType = CETLibrary | CETExecutable | CETTest | CETBenchmark - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show) -- | Pretty printing `CEType`. --- ppCE :: CEType -> String ppCE CETLibrary = "library" ppCE CETExecutable = "executable" @@ -108,13 +116,15 @@ ppCE CETTest = "test suite" ppCE CETBenchmark = "benchmark" -- | Which field does `CheckExplanation` refer to? --- -data CEField = CEFCategory | CEFMaintainer | CEFSynopsis - | CEFDescription | CEFSynOrDesc - deriving (Eq, Ord, Show) +data CEField + = CEFCategory + | CEFMaintainer + | CEFSynopsis + | CEFDescription + | CEFSynOrDesc + deriving (Eq, Ord, Show) -- | Pretty printing `CEField`. --- ppCEField :: CEField -> String ppCEField CEFCategory = "category" ppCEField CEFMaintainer = "maintainer" @@ -123,628 +133,745 @@ ppCEField CEFDescription = "description" ppCEField CEFSynOrDesc = "synopsis' or 'description" -- | Explanations of 'PackageCheck`'s errors/warnings. --- -data CheckExplanation = - ParseWarning FilePath PWarning - | NoNameField - | NoVersionField - | NoTarget - | UnnamedInternal - | DuplicateSections [UnqualComponentName] - | IllegalLibraryName PackageDescription - | NoModulesExposed Library - | SignaturesCabal2 - | AutogenNotExposed - | AutogenIncludesNotIncluded - | NoMainIs Executable - | NoHsLhsMain - | MainCCabal1_18 - | AutogenNoOther CEType UnqualComponentName - | AutogenIncludesNotIncludedExe - | TestsuiteTypeNotKnown TestType - | TestsuiteNotSupported TestType - | BenchmarkTypeNotKnown BenchmarkType - | BenchmarkNotSupported BenchmarkType - | NoHsLhsMainBench - | InvalidNameWin PackageDescription - | ZPrefix - | NoBuildType - | NoCustomSetup - | UnknownCompilers [String] - | UnknownLanguages [String] - | UnknownExtensions [String] - | LanguagesAsExtension [String] - | DeprecatedExtensions [(Extension, Maybe Extension)] - | MissingField CEField - | SynopsisTooLong - | ShortDesc - | InvalidTestWith [Dependency] - | ImpossibleInternalDep [Dependency] - | ImpossibleInternalExe [ExeDependency] - | MissingInternalExe [ExeDependency] - | NONELicense - | NoLicense - | AllRightsReservedLicense - | LicenseMessParse PackageDescription - | UnrecognisedLicense String - | UncommonBSD4 - | UnknownLicenseVersion License [Version] - | NoLicenseFile - | UnrecognisedSourceRepo String - | MissingType - | MissingLocation - | MissingModule - | MissingTag - | SubdirRelPath - | SubdirGoodRelPath String - | OptFasm String - | OptViaC String - | OptHpc String - | OptProf String - | OptO String - | OptHide String - | OptMake String - | OptONot String - | OptOOne String - | OptOTwo String - | OptSplitSections String - | OptSplitObjs String - | OptWls String - | OptExts String - | OptRts String - | OptWithRts String - | COptONumber String String - | COptCPP String - | OptAlternatives String String [(String, String)] - | RelativeOutside String FilePath - | AbsolutePath String FilePath - | BadRelativePAth String FilePath String - | DistPoint (Maybe String) FilePath - | GlobSyntaxError String String - | RecursiveGlobInRoot String FilePath - | InvalidOnWin [FilePath] - | FilePathTooLong FilePath - | FilePathNameTooLong FilePath - | FilePathSplitTooLong FilePath - | FilePathEmpty - | CVTestSuite - | CVDefaultLanguage - | CVDefaultLanguageComponent - | CVExtraDocFiles - | CVMultiLib - | CVReexported - | CVMixins - | CVExtraFrameworkDirs - | CVDefaultExtensions - | CVExtensionsDeprecated - | CVSources - | CVExtraDynamic [[String]] - | CVVirtualModules - | CVSourceRepository - | CVExtensions CabalSpecVersion [Extension] - | CVCustomSetup - | CVExpliticDepsCustomSetup - | CVAutogenPaths - | CVAutogenPackageInfo - | GlobNoMatch String String - | GlobExactMatch String String FilePath - | GlobNoDir String String FilePath - | UnknownOS [String] - | UnknownArch [String] - | UnknownCompiler [String] - | BaseNoUpperBounds - | MissingUpperBounds [PackageName] - | SuspiciousFlagName [String] - | DeclaredUsedFlags (Set FlagName) (Set FlagName) - | NonASCIICustomField [String] - | RebindableClashPaths - | RebindableClashPackageInfo - | WErrorUnneeded String - | JUnneeded String - | FDeferTypeErrorsUnneeded String - | DynamicUnneeded String - | ProfilingUnneeded String - | UpperBoundSetup String - | DuplicateModule String [ModuleName] - | PotentialDupModule String [ModuleName] - | BOMStart FilePath - | NotPackageName FilePath String - | NoDesc - | MultiDesc [String] - | UnknownFile String (SymbolicPath PackageDir LicenseFile) - | MissingSetupFile - | MissingConfigureScript - | UnknownDirectory String FilePath - | MissingSourceControl - | MissingExpectedDocFiles Bool [FilePath] - | WrongFieldForExpectedDocFiles Bool String [FilePath] - deriving (Eq, Ord, Show) +data CheckExplanation + = ParseWarning FilePath PWarning + | NoNameField + | NoVersionField + | NoTarget + | UnnamedInternal + | DuplicateSections [UnqualComponentName] + | IllegalLibraryName PackageDescription + | NoModulesExposed Library + | SignaturesCabal2 + | AutogenNotExposed + | AutogenIncludesNotIncluded + | NoMainIs Executable + | NoHsLhsMain + | MainCCabal1_18 + | AutogenNoOther CEType UnqualComponentName + | AutogenIncludesNotIncludedExe + | TestsuiteTypeNotKnown TestType + | TestsuiteNotSupported TestType + | BenchmarkTypeNotKnown BenchmarkType + | BenchmarkNotSupported BenchmarkType + | NoHsLhsMainBench + | InvalidNameWin PackageDescription + | ZPrefix + | NoBuildType + | NoCustomSetup + | UnknownCompilers [String] + | UnknownLanguages [String] + | UnknownExtensions [String] + | LanguagesAsExtension [String] + | DeprecatedExtensions [(Extension, Maybe Extension)] + | MissingField CEField + | SynopsisTooLong + | ShortDesc + | InvalidTestWith [Dependency] + | ImpossibleInternalDep [Dependency] + | ImpossibleInternalExe [ExeDependency] + | MissingInternalExe [ExeDependency] + | NONELicense + | NoLicense + | AllRightsReservedLicense + | LicenseMessParse PackageDescription + | UnrecognisedLicense String + | UncommonBSD4 + | UnknownLicenseVersion License [Version] + | NoLicenseFile + | UnrecognisedSourceRepo String + | MissingType + | MissingLocation + | MissingModule + | MissingTag + | SubdirRelPath + | SubdirGoodRelPath String + | OptFasm String + | OptViaC String + | OptHpc String + | OptProf String + | OptO String + | OptHide String + | OptMake String + | OptONot String + | OptOOne String + | OptOTwo String + | OptSplitSections String + | OptSplitObjs String + | OptWls String + | OptExts String + | OptRts String + | OptWithRts String + | COptONumber String String + | COptCPP String + | OptAlternatives String String [(String, String)] + | RelativeOutside String FilePath + | AbsolutePath String FilePath + | BadRelativePAth String FilePath String + | DistPoint (Maybe String) FilePath + | GlobSyntaxError String String + | RecursiveGlobInRoot String FilePath + | InvalidOnWin [FilePath] + | FilePathTooLong FilePath + | FilePathNameTooLong FilePath + | FilePathSplitTooLong FilePath + | FilePathEmpty + | CVTestSuite + | CVDefaultLanguage + | CVDefaultLanguageComponent + | CVExtraDocFiles + | CVMultiLib + | CVReexported + | CVMixins + | CVExtraFrameworkDirs + | CVDefaultExtensions + | CVExtensionsDeprecated + | CVSources + | CVExtraDynamic [[String]] + | CVVirtualModules + | CVSourceRepository + | CVExtensions CabalSpecVersion [Extension] + | CVCustomSetup + | CVExpliticDepsCustomSetup + | CVAutogenPaths + | CVAutogenPackageInfo + | GlobNoMatch String String + | GlobExactMatch String String FilePath + | GlobNoDir String String FilePath + | UnknownOS [String] + | UnknownArch [String] + | UnknownCompiler [String] + | BaseNoUpperBounds + | MissingUpperBounds [PackageName] + | SuspiciousFlagName [String] + | DeclaredUsedFlags (Set FlagName) (Set FlagName) + | NonASCIICustomField [String] + | RebindableClashPaths + | RebindableClashPackageInfo + | WErrorUnneeded String + | JUnneeded String + | FDeferTypeErrorsUnneeded String + | DynamicUnneeded String + | ProfilingUnneeded String + | UpperBoundSetup String + | DuplicateModule String [ModuleName] + | PotentialDupModule String [ModuleName] + | BOMStart FilePath + | NotPackageName FilePath String + | NoDesc + | MultiDesc [String] + | UnknownFile String (SymbolicPath PackageDir LicenseFile) + | MissingSetupFile + | MissingConfigureScript + | UnknownDirectory String FilePath + | MissingSourceControl + | MissingExpectedDocFiles Bool [FilePath] + | WrongFieldForExpectedDocFiles Bool String [FilePath] + deriving (Eq, Ord, Show) -- | Wraps `ParseWarning` into `PackageCheck`. --- wrapParseWarning :: FilePath -> PWarning -> PackageCheck wrapParseWarning fp pw = PackageDistSuspicious (ParseWarning fp pw) - -- TODO: as Jul 2022 there is no severity indication attached PWarnType. - -- Once that is added, we can output something more appropriate - -- than PackageDistSuspicious for every parse warning. - -- (see: Cabal-syntax/src/Distribution/Parsec/Warning.hs) + +-- TODO: as Jul 2022 there is no severity indication attached PWarnType. +-- Once that is added, we can output something more appropriate +-- than PackageDistSuspicious for every parse warning. +-- (see: Cabal-syntax/src/Distribution/Parsec/Warning.hs) -- | Pretty printing `CheckExplanation`. --- ppExplanation :: CheckExplanation -> String ppExplanation (ParseWarning fp pp) = showPWarning fp pp ppExplanation NoNameField = "No 'name' field." ppExplanation NoVersionField = "No 'version' field." ppExplanation NoTarget = - "No executables, libraries, tests, or benchmarks found. Nothing to do." + "No executables, libraries, tests, or benchmarks found. Nothing to do." ppExplanation UnnamedInternal = - "Found one or more unnamed internal libraries. Only the non-internal" - ++ " library can have the same name as the package." + "Found one or more unnamed internal libraries. Only the non-internal" + ++ " library can have the same name as the package." ppExplanation (DuplicateSections duplicateNames) = - "Duplicate sections: " - ++ commaSep (map unUnqualComponentName duplicateNames) - ++ ". The name of every library, executable, test suite," - ++ " and benchmark section in the package must be unique." + "Duplicate sections: " + ++ commaSep (map unUnqualComponentName duplicateNames) + ++ ". The name of every library, executable, test suite," + ++ " and benchmark section in the package must be unique." ppExplanation (IllegalLibraryName pkg) = - "Illegal internal library name " - ++ prettyShow (packageName pkg) - ++ ". Internal libraries cannot have the same name as the package." - ++ " Maybe you wanted a non-internal library?" - ++ " If so, rewrite the section stanza" - ++ " from 'library: '" ++ prettyShow (packageName pkg) - ++ "' to 'library'." + "Illegal internal library name " + ++ prettyShow (packageName pkg) + ++ ". Internal libraries cannot have the same name as the package." + ++ " Maybe you wanted a non-internal library?" + ++ " If so, rewrite the section stanza" + ++ " from 'library: '" + ++ prettyShow (packageName pkg) + ++ "' to 'library'." ppExplanation (NoModulesExposed lib) = - showLibraryName (libName lib) ++ " does not expose any modules" + showLibraryName (libName lib) ++ " does not expose any modules" ppExplanation SignaturesCabal2 = - "To use the 'signatures' field the package needs to specify " - ++ "at least 'cabal-version: 2.0'." + "To use the 'signatures' field the package needs to specify " + ++ "at least 'cabal-version: 2.0'." ppExplanation AutogenNotExposed = - "An 'autogen-module' is neither on 'exposed-modules' or 'other-modules'." + "An 'autogen-module' is neither on 'exposed-modules' or 'other-modules'." ppExplanation AutogenIncludesNotIncluded = - "An include in 'autogen-includes' is neither in 'includes' or " - ++ "'install-includes'." + "An include in 'autogen-includes' is neither in 'includes' or " + ++ "'install-includes'." ppExplanation (NoMainIs exe) = - "No 'main-is' field found for executable " ++ prettyShow (exeName exe) + "No 'main-is' field found for executable " ++ prettyShow (exeName exe) ppExplanation NoHsLhsMain = - "The 'main-is' field must specify a '.hs' or '.lhs' file " - ++ "(even if it is generated by a preprocessor), " - ++ "or it may specify a C/C++/obj-C source file." + "The 'main-is' field must specify a '.hs' or '.lhs' file " + ++ "(even if it is generated by a preprocessor), " + ++ "or it may specify a C/C++/obj-C source file." ppExplanation MainCCabal1_18 = - "The package uses a C/C++/obj-C source file for the 'main-is' field. " - ++ "To use this feature you need to specify 'cabal-version: 1.18' or" - ++ " higher." + "The package uses a C/C++/obj-C source file for the 'main-is' field. " + ++ "To use this feature you need to specify 'cabal-version: 1.18' or" + ++ " higher." ppExplanation (AutogenNoOther ct ucn) = - "On " ++ ppCE ct ++ " '" ++ prettyShow ucn ++ "' an 'autogen-module'" - ++ " is not on 'other-modules'" + "On " + ++ ppCE ct + ++ " '" + ++ prettyShow ucn + ++ "' an 'autogen-module'" + ++ " is not on 'other-modules'" ppExplanation AutogenIncludesNotIncludedExe = - "An include in 'autogen-includes' is not in 'includes'." + "An include in 'autogen-includes' is not in 'includes'." ppExplanation (TestsuiteTypeNotKnown tt) = - quote (prettyShow tt) ++ " is not a known type of test suite. " - ++ "Either remove the 'type' field or use a known type. " - ++ "The known test suite types are: " - ++ commaSep (map prettyShow knownTestTypes) + quote (prettyShow tt) + ++ " is not a known type of test suite. " + ++ "Either remove the 'type' field or use a known type. " + ++ "The known test suite types are: " + ++ commaSep (map prettyShow knownTestTypes) ppExplanation (TestsuiteNotSupported tt) = - quote (prettyShow tt) ++ " is not a supported test suite version. " - ++ "Either remove the 'type' field or use a known type. " - ++ "The known test suite types are: " - ++ commaSep (map prettyShow knownTestTypes) + quote (prettyShow tt) + ++ " is not a supported test suite version. " + ++ "Either remove the 'type' field or use a known type. " + ++ "The known test suite types are: " + ++ commaSep (map prettyShow knownTestTypes) ppExplanation (BenchmarkTypeNotKnown tt) = - quote (prettyShow tt) ++ " is not a known type of benchmark. " - ++ "Either remove the 'type' field or use a known type. " - ++ "The known benchmark types are: " - ++ commaSep (map prettyShow knownBenchmarkTypes) + quote (prettyShow tt) + ++ " is not a known type of benchmark. " + ++ "Either remove the 'type' field or use a known type. " + ++ "The known benchmark types are: " + ++ commaSep (map prettyShow knownBenchmarkTypes) ppExplanation (BenchmarkNotSupported tt) = - quote (prettyShow tt) ++ " is not a supported benchmark version. " - ++ "Either remove the 'type' field or use a known type. " - ++ "The known benchmark types are: " - ++ commaSep (map prettyShow knownBenchmarkTypes) + quote (prettyShow tt) + ++ " is not a supported benchmark version. " + ++ "Either remove the 'type' field or use a known type. " + ++ "The known benchmark types are: " + ++ commaSep (map prettyShow knownBenchmarkTypes) ppExplanation NoHsLhsMainBench = - "The 'main-is' field must specify a '.hs' or '.lhs' file " - ++ "(even if it is generated by a preprocessor)." + "The 'main-is' field must specify a '.hs' or '.lhs' file " + ++ "(even if it is generated by a preprocessor)." ppExplanation (InvalidNameWin pkg) = - "The package name '" ++ prettyShow (packageName pkg) ++ "' is " - ++ "invalid on Windows. Many tools need to convert package names to " - ++ "file names so using this name would cause problems." + "The package name '" + ++ prettyShow (packageName pkg) + ++ "' is " + ++ "invalid on Windows. Many tools need to convert package names to " + ++ "file names so using this name would cause problems." ppExplanation ZPrefix = - "Package names with the prefix 'z-' are reserved by Cabal and " - ++ "cannot be used." + "Package names with the prefix 'z-' are reserved by Cabal and " + ++ "cannot be used." ppExplanation NoBuildType = - "No 'build-type' specified. If you do not need a custom Setup.hs or " - ++ "./configure script then use 'build-type: Simple'." + "No 'build-type' specified. If you do not need a custom Setup.hs or " + ++ "./configure script then use 'build-type: Simple'." ppExplanation NoCustomSetup = - "Ignoring the 'custom-setup' section because the 'build-type' is " - ++ "not 'Custom'. Use 'build-type: Custom' if you need to use a " - ++ "custom Setup.hs script." + "Ignoring the 'custom-setup' section because the 'build-type' is " + ++ "not 'Custom'. Use 'build-type: Custom' if you need to use a " + ++ "custom Setup.hs script." ppExplanation (UnknownCompilers unknownCompilers) = - "Unknown compiler " ++ commaSep (map quote unknownCompilers) - ++ " in 'tested-with' field." + "Unknown compiler " + ++ commaSep (map quote unknownCompilers) + ++ " in 'tested-with' field." ppExplanation (UnknownLanguages unknownLanguages) = - "Unknown languages: " ++ commaSep unknownLanguages + "Unknown languages: " ++ commaSep unknownLanguages ppExplanation (UnknownExtensions unknownExtensions) = - "Unknown extensions: " ++ commaSep unknownExtensions + "Unknown extensions: " ++ commaSep unknownExtensions ppExplanation (LanguagesAsExtension languagesUsedAsExtensions) = - "Languages listed as extensions: " - ++ commaSep languagesUsedAsExtensions - ++ ". Languages must be specified in either the 'default-language' " - ++ " or the 'other-languages' field." + "Languages listed as extensions: " + ++ commaSep languagesUsedAsExtensions + ++ ". Languages must be specified in either the 'default-language' " + ++ " or the 'other-languages' field." ppExplanation (DeprecatedExtensions ourDeprecatedExtensions) = - "Deprecated extensions: " - ++ commaSep (map (quote . prettyShow . fst) ourDeprecatedExtensions) - ++ ". " ++ unwords - [ "Instead of '" ++ prettyShow ext - ++ "' use '" ++ prettyShow replacement ++ "'." - | (ext, Just replacement) <- ourDeprecatedExtensions ] + "Deprecated extensions: " + ++ commaSep (map (quote . prettyShow . fst) ourDeprecatedExtensions) + ++ ". " + ++ unwords + [ "Instead of '" + ++ prettyShow ext + ++ "' use '" + ++ prettyShow replacement + ++ "'." + | (ext, Just replacement) <- ourDeprecatedExtensions + ] ppExplanation (MissingField cef) = - "No '" ++ ppCEField cef ++ "' field." + "No '" ++ ppCEField cef ++ "' field." ppExplanation SynopsisTooLong = - "The 'synopsis' field is rather long (max 80 chars is recommended)." + "The 'synopsis' field is rather long (max 80 chars is recommended)." ppExplanation ShortDesc = - "The 'description' field should be longer than the 'synopsis' field. " - ++ "It's useful to provide an informative 'description' to allow " - ++ "Haskell programmers who have never heard about your package to " - ++ "understand the purpose of your package. " - ++ "The 'description' field content is typically shown by tooling " - ++ "(e.g. 'cabal info', Haddock, Hackage) below the 'synopsis' which " - ++ "serves as a headline. " - ++ "Please refer to for more details." + "The 'description' field should be longer than the 'synopsis' field. " + ++ "It's useful to provide an informative 'description' to allow " + ++ "Haskell programmers who have never heard about your package to " + ++ "understand the purpose of your package. " + ++ "The 'description' field content is typically shown by tooling " + ++ "(e.g. 'cabal info', Haddock, Hackage) below the 'synopsis' which " + ++ "serves as a headline. " + ++ "Please refer to for more details." ppExplanation (InvalidTestWith testedWithImpossibleRanges) = - "Invalid 'tested-with' version range: " - ++ commaSep (map prettyShow testedWithImpossibleRanges) - ++ ". To indicate that you have tested a package with multiple " - ++ "different versions of the same compiler use multiple entries, " - ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not " - ++ "'tested-with: GHC==6.10.4 && ==6.12.3'." + "Invalid 'tested-with' version range: " + ++ commaSep (map prettyShow testedWithImpossibleRanges) + ++ ". To indicate that you have tested a package with multiple " + ++ "different versions of the same compiler use multiple entries, " + ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not " + ++ "'tested-with: GHC==6.10.4 && ==6.12.3'." ppExplanation (ImpossibleInternalDep depInternalLibWithImpossibleVersion) = - "The package has an impossible version range for a dependency on an " - ++ "internal library: " - ++ commaSep (map prettyShow depInternalLibWithImpossibleVersion) - ++ ". This version range does not include the current package, and must " - ++ "be removed as the current package's library will always be used." + "The package has an impossible version range for a dependency on an " + ++ "internal library: " + ++ commaSep (map prettyShow depInternalLibWithImpossibleVersion) + ++ ". This version range does not include the current package, and must " + ++ "be removed as the current package's library will always be used." ppExplanation (ImpossibleInternalExe depInternalExecWithImpossibleVersion) = - "The package has an impossible version range for a dependency on an " - ++ "internal executable: " - ++ commaSep (map prettyShow depInternalExecWithImpossibleVersion) - ++ ". This version range does not include the current package, and must " - ++ "be removed as the current package's executable will always be used." + "The package has an impossible version range for a dependency on an " + ++ "internal executable: " + ++ commaSep (map prettyShow depInternalExecWithImpossibleVersion) + ++ ". This version range does not include the current package, and must " + ++ "be removed as the current package's executable will always be used." ppExplanation (MissingInternalExe depInternalExeWithImpossibleVersion) = - "The package depends on a missing internal executable: " - ++ commaSep (map prettyShow depInternalExeWithImpossibleVersion) + "The package depends on a missing internal executable: " + ++ commaSep (map prettyShow depInternalExeWithImpossibleVersion) ppExplanation NONELicense = "The 'license' field is missing or is NONE." ppExplanation NoLicense = "The 'license' field is missing." ppExplanation AllRightsReservedLicense = - "The 'license' is AllRightsReserved. Is that really what you want?" + "The 'license' is AllRightsReserved. Is that really what you want?" ppExplanation (LicenseMessParse pkg) = - "Unfortunately the license " ++ quote (prettyShow (license pkg)) - ++ " messes up the parser in earlier Cabal versions so you need to " - ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require " - ++ "compatibility with earlier Cabal versions then use 'OtherLicense'." + "Unfortunately the license " + ++ quote (prettyShow (license pkg)) + ++ " messes up the parser in earlier Cabal versions so you need to " + ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require " + ++ "compatibility with earlier Cabal versions then use 'OtherLicense'." ppExplanation (UnrecognisedLicense l) = - quote ("license: " ++ l) ++ " is not a recognised license. The " - ++ "known licenses are: " ++ commaSep (map prettyShow knownLicenses) + quote ("license: " ++ l) + ++ " is not a recognised license. The " + ++ "known licenses are: " + ++ commaSep (map prettyShow knownLicenses) ppExplanation UncommonBSD4 = - "Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' " - ++ "refers to the old 4-clause BSD license with the advertising " - ++ "clause. 'BSD3' refers the new 3-clause BSD license." + "Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' " + ++ "refers to the old 4-clause BSD license with the advertising " + ++ "clause. 'BSD3' refers the new 3-clause BSD license." ppExplanation (UnknownLicenseVersion lic known) = - "'license: " ++ prettyShow lic ++ "' is not a known " - ++ "version of that license. The known versions are " - ++ commaSep (map prettyShow known) - ++ ". If this is not a mistake and you think it should be a known " - ++ "version then please file a ticket." + "'license: " + ++ prettyShow lic + ++ "' is not a known " + ++ "version of that license. The known versions are " + ++ commaSep (map prettyShow known) + ++ ". If this is not a mistake and you think it should be a known " + ++ "version then please file a ticket." ppExplanation NoLicenseFile = "A 'license-file' is not specified." ppExplanation (UnrecognisedSourceRepo kind) = - quote kind ++ " is not a recognised kind of source-repository. " - ++ "The repo kind is usually 'head' or 'this'" + quote kind + ++ " is not a recognised kind of source-repository. " + ++ "The repo kind is usually 'head' or 'this'" ppExplanation MissingType = - "The source-repository 'type' is a required field." + "The source-repository 'type' is a required field." ppExplanation MissingLocation = - "The source-repository 'location' is a required field." + "The source-repository 'location' is a required field." ppExplanation MissingModule = - "For a CVS source-repository, the 'module' is a required field." + "For a CVS source-repository, the 'module' is a required field." ppExplanation MissingTag = - "For the 'this' kind of source-repository, the 'tag' is a required " - ++ "field. It should specify the tag corresponding to this version " - ++ "or release of the package." + "For the 'this' kind of source-repository, the 'tag' is a required " + ++ "field. It should specify the tag corresponding to this version " + ++ "or release of the package." ppExplanation SubdirRelPath = - "The 'subdir' field of a source-repository must be a relative path." + "The 'subdir' field of a source-repository must be a relative path." ppExplanation (SubdirGoodRelPath err) = - "The 'subdir' field of a source-repository is not a good relative path: " - ++ show err + "The 'subdir' field of a source-repository is not a good relative path: " + ++ show err ppExplanation (OptFasm fieldName) = - "'" ++ fieldName ++ ": -fasm' is unnecessary and will not work on CPU " - ++ "architectures other than x86, x86-64, ppc or sparc." + "'" + ++ fieldName + ++ ": -fasm' is unnecessary and will not work on CPU " + ++ "architectures other than x86, x86-64, ppc or sparc." ppExplanation (OptViaC fieldName) = - "'" ++ fieldName ++": -fvia-C' is usually unnecessary. If your package " - ++ "needs -via-C for correctness rather than performance then it " - ++ "is using the FFI incorrectly and will probably not work with GHC " - ++ "6.10 or later." + "'" + ++ fieldName + ++ ": -fvia-C' is usually unnecessary. If your package " + ++ "needs -via-C for correctness rather than performance then it " + ++ "is using the FFI incorrectly and will probably not work with GHC " + ++ "6.10 or later." ppExplanation (OptHpc fieldName) = - "'" ++ fieldName ++ ": -fhpc' is not necessary. Use the configure flag " - ++ " --enable-coverage instead." + "'" + ++ fieldName + ++ ": -fhpc' is not necessary. Use the configure flag " + ++ " --enable-coverage instead." ppExplanation (OptProf fieldName) = - "'" ++ fieldName ++ ": -prof' is not necessary and will lead to problems " - ++ "when used on a library. Use the configure flag " - ++ "--enable-library-profiling and/or --enable-profiling." + "'" + ++ fieldName + ++ ": -prof' is not necessary and will lead to problems " + ++ "when used on a library. Use the configure flag " + ++ "--enable-library-profiling and/or --enable-profiling." ppExplanation (OptO fieldName) = - "'" ++ fieldName ++ ": -o' is not needed. " - ++ "The output files are named automatically." + "'" + ++ fieldName + ++ ": -o' is not needed. " + ++ "The output files are named automatically." ppExplanation (OptHide fieldName) = - "'" ++ fieldName ++ ": -hide-package' is never needed. " - ++ "Cabal hides all packages." + "'" + ++ fieldName + ++ ": -hide-package' is never needed. " + ++ "Cabal hides all packages." ppExplanation (OptMake fieldName) = - "'" ++ fieldName - ++ ": --make' is never needed. Cabal uses this automatically." + "'" + ++ fieldName + ++ ": --make' is never needed. Cabal uses this automatically." ppExplanation (OptONot fieldName) = - "'" ++ fieldName ++ ": -O0' is not needed. " - ++ "Use the --disable-optimization configure flag." + "'" + ++ fieldName + ++ ": -O0' is not needed. " + ++ "Use the --disable-optimization configure flag." ppExplanation (OptOOne fieldName) = - "'" ++ fieldName ++ ": -O' is not needed. " - ++ "Cabal automatically adds the '-O' flag. " - ++ "Setting it yourself interferes with the --disable-optimization flag." + "'" + ++ fieldName + ++ ": -O' is not needed. " + ++ "Cabal automatically adds the '-O' flag. " + ++ "Setting it yourself interferes with the --disable-optimization flag." ppExplanation (OptOTwo fieldName) = - "'" ++ fieldName ++ ": -O2' is rarely needed. " - ++ "Check that it is giving a real benefit " - ++ "and not just imposing longer compile times on your users." + "'" + ++ fieldName + ++ ": -O2' is rarely needed. " + ++ "Check that it is giving a real benefit " + ++ "and not just imposing longer compile times on your users." ppExplanation (OptSplitSections fieldName) = - "'" ++ fieldName ++ ": -split-sections' is not needed. " - ++ "Use the --enable-split-sections configure flag." + "'" + ++ fieldName + ++ ": -split-sections' is not needed. " + ++ "Use the --enable-split-sections configure flag." ppExplanation (OptSplitObjs fieldName) = - "'" ++ fieldName ++ ": -split-objs' is not needed. " - ++ "Use the --enable-split-objs configure flag." + "'" + ++ fieldName + ++ ": -split-objs' is not needed. " + ++ "Use the --enable-split-objs configure flag." ppExplanation (OptWls fieldName) = - "'" ++ fieldName ++ ": -optl-Wl,-s' is not needed and is not portable to" - ++ " all operating systems. Cabal 1.4 and later automatically strip" - ++ " executables. Cabal also has a flag --disable-executable-stripping" - ++ " which is necessary when building packages for some Linux" - ++ " distributions and using '-optl-Wl,-s' prevents that from working." + "'" + ++ fieldName + ++ ": -optl-Wl,-s' is not needed and is not portable to" + ++ " all operating systems. Cabal 1.4 and later automatically strip" + ++ " executables. Cabal also has a flag --disable-executable-stripping" + ++ " which is necessary when building packages for some Linux" + ++ " distributions and using '-optl-Wl,-s' prevents that from working." ppExplanation (OptExts fieldName) = - "Instead of '" ++ fieldName ++ ": -fglasgow-exts' it is preferable to use " - ++ "the 'extensions' field." + "Instead of '" + ++ fieldName + ++ ": -fglasgow-exts' it is preferable to use " + ++ "the 'extensions' field." ppExplanation (OptRts fieldName) = - "'" ++ fieldName ++ ": -rtsopts' has no effect for libraries. It should " - ++ "only be used for executables." + "'" + ++ fieldName + ++ ": -rtsopts' has no effect for libraries. It should " + ++ "only be used for executables." ppExplanation (OptWithRts fieldName) = - "'" ++ fieldName ++ ": -with-rtsopts' has no effect for libraries. It " - ++ "should only be used for executables." + "'" + ++ fieldName + ++ ": -with-rtsopts' has no effect for libraries. It " + ++ "should only be used for executables." ppExplanation (COptONumber prefix label) = - "'" ++ prefix ++": -O[n]' is generally not needed. When building with " - ++ " optimisations Cabal automatically adds '-O2' for " ++ label - ++ " code. Setting it yourself interferes with the" - ++ " --disable-optimization flag." + "'" + ++ prefix + ++ ": -O[n]' is generally not needed. When building with " + ++ " optimisations Cabal automatically adds '-O2' for " + ++ label + ++ " code. Setting it yourself interferes with the" + ++ " --disable-optimization flag." ppExplanation (COptCPP opt) = - "'cpp-options: " ++ opt ++ "' is not a portable C-preprocessor flag." + "'cpp-options: " ++ opt ++ "' is not a portable C-preprocessor flag." ppExplanation (OptAlternatives badField goodField flags) = - "Instead of " ++ quote (badField ++ ": " ++ unwords badFlags) - ++ " use " ++ quote (goodField ++ ": " ++ unwords goodFlags) - where (badFlags, goodFlags) = unzip flags + "Instead of " + ++ quote (badField ++ ": " ++ unwords badFlags) + ++ " use " + ++ quote (goodField ++ ": " ++ unwords goodFlags) + where + (badFlags, goodFlags) = unzip flags ppExplanation (RelativeOutside field path) = - quote (field ++ ": " ++ path) - ++ " is a relative path outside of the source tree. " - ++ "This will not work when generating a tarball with 'sdist'." + quote (field ++ ": " ++ path) + ++ " is a relative path outside of the source tree. " + ++ "This will not work when generating a tarball with 'sdist'." ppExplanation (AbsolutePath field path) = - quote (field ++ ": " ++ path) ++ " specifies an absolute path, but the " - ++ quote field ++ " field must use relative paths." + quote (field ++ ": " ++ path) + ++ " specifies an absolute path, but the " + ++ quote field + ++ " field must use relative paths." ppExplanation (BadRelativePAth field path err) = - quote (field ++ ": " ++ path) - ++ " is not a good relative path: " ++ show err + quote (field ++ ": " ++ path) + ++ " is not a good relative path: " + ++ show err ppExplanation (DistPoint mfield path) = - incipit ++ " points inside the 'dist' " - ++ "directory. This is not reliable because the location of this " - ++ "directory is configurable by the user (or package manager). In " - ++ "addition the layout of the 'dist' directory is subject to change " - ++ "in future versions of Cabal." - where -- mfiled Nothing -> the path is inside `ghc-options` - incipit = maybe ("'ghc-options' path " ++ quote path) - (\field -> quote (field ++ ": " ++ path)) - mfield + incipit + ++ " points inside the 'dist' " + ++ "directory. This is not reliable because the location of this " + ++ "directory is configurable by the user (or package manager). In " + ++ "addition the layout of the 'dist' directory is subject to change " + ++ "in future versions of Cabal." + where + -- mfiled Nothing -> the path is inside `ghc-options` + incipit = + maybe + ("'ghc-options' path " ++ quote path) + (\field -> quote (field ++ ": " ++ path)) + mfield ppExplanation (GlobSyntaxError field expl) = - "In the '" ++ field ++ "' field: " ++ expl + "In the '" ++ field ++ "' field: " ++ expl ppExplanation (RecursiveGlobInRoot field glob) = - "In the '" ++ field ++ "': glob '" ++ glob + "In the '" + ++ field + ++ "': glob '" + ++ glob ++ "' starts at project root directory, this might " ++ "include `.git/`, ``dist-newstyle/``, or other large directories!" ppExplanation (InvalidOnWin paths) = - "The " ++ quotes paths ++ " invalid on Windows, which " - ++ "would cause portability problems for this package. Windows file " - ++ "names cannot contain any of the characters \":*?<>|\" and there " - ++ "a few reserved names including \"aux\", \"nul\", \"con\", " - ++ "\"prn\", \"com1-9\", \"lpt1-9\" and \"clock$\"." - where quotes [failed] = "path " ++ quote failed ++ " is" - quotes failed = "paths " ++ intercalate ", " (map quote failed) - ++ " are" + "The " + ++ quotes paths + ++ " invalid on Windows, which " + ++ "would cause portability problems for this package. Windows file " + ++ "names cannot contain any of the characters \":*?<>|\" and there " + ++ "a few reserved names including \"aux\", \"nul\", \"con\", " + ++ "\"prn\", \"com1-9\", \"lpt1-9\" and \"clock$\"." + where + quotes [failed] = "path " ++ quote failed ++ " is" + quotes failed = + "paths " + ++ intercalate ", " (map quote failed) + ++ " are" ppExplanation (FilePathTooLong path) = - "The following file name is too long to store in a portable POSIX " - ++ "format tar archive. The maximum length is 255 ASCII characters.\n" - ++ "The file in question is:\n " ++ path + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. The maximum length is 255 ASCII characters.\n" + ++ "The file in question is:\n " + ++ path ppExplanation (FilePathNameTooLong path) = - "The following file name is too long to store in a portable POSIX " - ++ "format tar archive. The maximum length for the name part (including " - ++ "extension) is 100 ASCII characters. The maximum length for any " - ++ "individual directory component is 155.\n" - ++ "The file in question is:\n " ++ path + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. The maximum length for the name part (including " + ++ "extension) is 100 ASCII characters. The maximum length for any " + ++ "individual directory component is 155.\n" + ++ "The file in question is:\n " + ++ path ppExplanation (FilePathSplitTooLong path) = - "The following file name is too long to store in a portable POSIX " - ++ "format tar archive. While the total length is less than 255 ASCII " - ++ "characters, there are unfortunately further restrictions. It has to " - ++ "be possible to split the file path on a directory separator into " - ++ "two parts such that the first part fits in 155 characters or less " - ++ "and the second part fits in 100 characters or less. Basically you " - ++ "have to make the file name or directory names shorter, or you could " - ++ "split a long directory name into nested subdirectories with shorter " - ++ "names.\nThe file in question is:\n " ++ path + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. While the total length is less than 255 ASCII " + ++ "characters, there are unfortunately further restrictions. It has to " + ++ "be possible to split the file path on a directory separator into " + ++ "two parts such that the first part fits in 155 characters or less " + ++ "and the second part fits in 100 characters or less. Basically you " + ++ "have to make the file name or directory names shorter, or you could " + ++ "split a long directory name into nested subdirectories with shorter " + ++ "names.\nThe file in question is:\n " + ++ path ppExplanation FilePathEmpty = - "Encountered a file with an empty name, something is very wrong! " - ++ "Files with an empty name cannot be stored in a tar archive or in " - ++ "standard file systems." + "Encountered a file with an empty name, something is very wrong! " + ++ "Files with an empty name cannot be stored in a tar archive or in " + ++ "standard file systems." ppExplanation CVTestSuite = - "The 'test-suite' section is new in Cabal 1.10. " - ++ "Unfortunately it messes up the parser in older Cabal versions " - ++ "so you must specify at least 'cabal-version: >= 1.8', but note " - ++ "that only Cabal 1.10 and later can actually run such test suites." + "The 'test-suite' section is new in Cabal 1.10. " + ++ "Unfortunately it messes up the parser in older Cabal versions " + ++ "so you must specify at least 'cabal-version: >= 1.8', but note " + ++ "that only Cabal 1.10 and later can actually run such test suites." ppExplanation CVDefaultLanguage = - "To use the 'default-language' field the package needs to specify " - ++ "at least 'cabal-version: >= 1.10'." + "To use the 'default-language' field the package needs to specify " + ++ "at least 'cabal-version: >= 1.10'." ppExplanation CVDefaultLanguageComponent = - "Packages using 'cabal-version: >= 1.10' and before 'cabal-version: 3.4' " - ++ "must specify the 'default-language' field for each component (e.g. " - ++ "Haskell98 or Haskell2010). If a component uses different languages " - ++ "in different modules then list the other ones in the " - ++ "'other-languages' field." + "Packages using 'cabal-version: >= 1.10' and before 'cabal-version: 3.4' " + ++ "must specify the 'default-language' field for each component (e.g. " + ++ "Haskell98 or Haskell2010). If a component uses different languages " + ++ "in different modules then list the other ones in the " + ++ "'other-languages' field." ppExplanation CVExtraDocFiles = - "To use the 'extra-doc-files' field the package needs to specify " - ++ "'cabal-version: 1.18' or higher." + "To use the 'extra-doc-files' field the package needs to specify " + ++ "'cabal-version: 1.18' or higher." ppExplanation CVMultiLib = - "To use multiple 'library' sections or a named library section " - ++ "the package needs to specify at least 'cabal-version: 2.0'." + "To use multiple 'library' sections or a named library section " + ++ "the package needs to specify at least 'cabal-version: 2.0'." ppExplanation CVReexported = - "To use the 'reexported-module' field the package needs to specify " - ++ "'cabal-version: 1.22' or higher." + "To use the 'reexported-module' field the package needs to specify " + ++ "'cabal-version: 1.22' or higher." ppExplanation CVMixins = - "To use the 'mixins' field the package needs to specify " - ++ "at least 'cabal-version: 2.0'." + "To use the 'mixins' field the package needs to specify " + ++ "at least 'cabal-version: 2.0'." ppExplanation CVExtraFrameworkDirs = - "To use the 'extra-framework-dirs' field the package needs to specify" - ++ " 'cabal-version: 1.24' or higher." + "To use the 'extra-framework-dirs' field the package needs to specify" + ++ " 'cabal-version: 1.24' or higher." ppExplanation CVDefaultExtensions = - "To use the 'default-extensions' field the package needs to specify " - ++ "at least 'cabal-version: >= 1.10'." + "To use the 'default-extensions' field the package needs to specify " + ++ "at least 'cabal-version: >= 1.10'." ppExplanation CVExtensionsDeprecated = - "For packages using 'cabal-version: >= 1.10' the 'extensions' " - ++ "field is deprecated. The new 'default-extensions' field lists " - ++ "extensions that are used in all modules in the component, while " - ++ "the 'other-extensions' field lists extensions that are used in " - ++ "some modules, e.g. via the {-# LANGUAGE #-} pragma." + "For packages using 'cabal-version: >= 1.10' the 'extensions' " + ++ "field is deprecated. The new 'default-extensions' field lists " + ++ "extensions that are used in all modules in the component, while " + ++ "the 'other-extensions' field lists extensions that are used in " + ++ "some modules, e.g. via the {-# LANGUAGE #-} pragma." ppExplanation CVSources = - "The use of 'asm-sources', 'cmm-sources', 'extra-bundled-libraries' " - ++ " and 'extra-library-flavours' requires the package " - ++ " to specify at least 'cabal-version: 3.0'." + "The use of 'asm-sources', 'cmm-sources', 'extra-bundled-libraries' " + ++ " and 'extra-library-flavours' requires the package " + ++ " to specify at least 'cabal-version: 3.0'." ppExplanation (CVExtraDynamic flavs) = - "The use of 'extra-dynamic-library-flavours' requires the package " - ++ " to specify at least 'cabal-version: 3.0'. The flavours are: " - ++ commaSep (concat flavs) + "The use of 'extra-dynamic-library-flavours' requires the package " + ++ " to specify at least 'cabal-version: 3.0'. The flavours are: " + ++ commaSep (concat flavs) ppExplanation CVVirtualModules = - "The use of 'virtual-modules' requires the package " - ++ " to specify at least 'cabal-version: 2.2'." + "The use of 'virtual-modules' requires the package " + ++ " to specify at least 'cabal-version: 2.2'." ppExplanation CVSourceRepository = - "The 'source-repository' section is new in Cabal 1.6. " - ++ "Unfortunately it messes up the parser in earlier Cabal versions " - ++ "so you need to specify 'cabal-version: >= 1.6'." + "The 'source-repository' section is new in Cabal 1.6. " + ++ "Unfortunately it messes up the parser in earlier Cabal versions " + ++ "so you need to specify 'cabal-version: >= 1.6'." ppExplanation (CVExtensions version extCab12) = - "Unfortunately the language extensions " - ++ commaSep (map (quote . prettyShow) extCab12) - ++ " break the parser in earlier Cabal versions so you need to " - ++ "specify 'cabal-version: >= " ++ showCabalSpecVersion version - ++ "'. Alternatively if you require compatibility with earlier " - ++ "Cabal versions then you may be able to use an equivalent " - ++ "compiler-specific flag." + "Unfortunately the language extensions " + ++ commaSep (map (quote . prettyShow) extCab12) + ++ " break the parser in earlier Cabal versions so you need to " + ++ "specify 'cabal-version: >= " + ++ showCabalSpecVersion version + ++ "'. Alternatively if you require compatibility with earlier " + ++ "Cabal versions then you may be able to use an equivalent " + ++ "compiler-specific flag." ppExplanation CVCustomSetup = - "Packages using 'cabal-version: 1.24' or higher with 'build-type: Custom' " - ++ "must use a 'custom-setup' section with a 'setup-depends' field " - ++ "that specifies the dependencies of the Setup.hs script itself. " - ++ "The 'setup-depends' field uses the same syntax as 'build-depends', " - ++ "so a simple example would be 'setup-depends: base, Cabal'." + "Packages using 'cabal-version: 1.24' or higher with 'build-type: Custom' " + ++ "must use a 'custom-setup' section with a 'setup-depends' field " + ++ "that specifies the dependencies of the Setup.hs script itself. " + ++ "The 'setup-depends' field uses the same syntax as 'build-depends', " + ++ "so a simple example would be 'setup-depends: base, Cabal'." ppExplanation CVExpliticDepsCustomSetup = - "From version 1.24 cabal supports specifying explicit dependencies " - ++ "for Custom setup scripts. Consider using 'cabal-version: 1.24' or " - ++ "higher and adding a 'custom-setup' section with a 'setup-depends' " - ++ "field that specifies the dependencies of the Setup.hs script " - ++ "itself. The 'setup-depends' field uses the same syntax as " - ++ "'build-depends', so a simple example would be 'setup-depends: base, " - ++ "Cabal'." + "From version 1.24 cabal supports specifying explicit dependencies " + ++ "for Custom setup scripts. Consider using 'cabal-version: 1.24' or " + ++ "higher and adding a 'custom-setup' section with a 'setup-depends' " + ++ "field that specifies the dependencies of the Setup.hs script " + ++ "itself. The 'setup-depends' field uses the same syntax as " + ++ "'build-depends', so a simple example would be 'setup-depends: base, " + ++ "Cabal'." ppExplanation CVAutogenPaths = - "Packages using 'cabal-version: 2.0' and the autogenerated " - ++ "module Paths_* must include it also on the 'autogen-modules' field " - ++ "besides 'exposed-modules' and 'other-modules'. This specifies that " - ++ "the module does not come with the package and is generated on " - ++ "setup. Modules built with a custom Setup.hs script also go here " - ++ "to ensure that commands like sdist don't fail." + "Packages using 'cabal-version: 2.0' and the autogenerated " + ++ "module Paths_* must include it also on the 'autogen-modules' field " + ++ "besides 'exposed-modules' and 'other-modules'. This specifies that " + ++ "the module does not come with the package and is generated on " + ++ "setup. Modules built with a custom Setup.hs script also go here " + ++ "to ensure that commands like sdist don't fail." ppExplanation CVAutogenPackageInfo = - "Packages using 'cabal-version: 2.0' and the autogenerated " - ++ "module PackageInfo_* must include it in 'autogen-modules' as well as" - ++ " 'exposed-modules' and 'other-modules'. This specifies that " - ++ "the module does not come with the package and is generated on " - ++ "setup. Modules built with a custom Setup.hs script also go here " - ++ "to ensure that commands like sdist don't fail." + "Packages using 'cabal-version: 2.0' and the autogenerated " + ++ "module PackageInfo_* must include it in 'autogen-modules' as well as" + ++ " 'exposed-modules' and 'other-modules'. This specifies that " + ++ "the module does not come with the package and is generated on " + ++ "setup. Modules built with a custom Setup.hs script also go here " + ++ "to ensure that commands like sdist don't fail." ppExplanation (GlobNoMatch field glob) = - "In '" ++ field ++ "': the pattern '" ++ glob ++ "' does not" - ++ " match any files." + "In '" + ++ field + ++ "': the pattern '" + ++ glob + ++ "' does not" + ++ " match any files." ppExplanation (GlobExactMatch field glob file) = - "In '" ++ field ++ "': the pattern '" ++ glob ++ "' does not" - ++ " match the file '" ++ file ++ "' because the extensions do not" - ++ " exactly match (e.g., foo.en.html does not exactly match *.html)." - ++ " To enable looser suffix-only matching, set 'cabal-version: 2.4' or" - ++ " higher." + "In '" + ++ field + ++ "': the pattern '" + ++ glob + ++ "' does not" + ++ " match the file '" + ++ file + ++ "' because the extensions do not" + ++ " exactly match (e.g., foo.en.html does not exactly match *.html)." + ++ " To enable looser suffix-only matching, set 'cabal-version: 2.4' or" + ++ " higher." ppExplanation (GlobNoDir field glob dir) = - "In '" ++ field ++ "': the pattern '" ++ glob ++ "' attempts to" - ++ " match files in the directory '" ++ dir ++ "', but there is no" - ++ " directory by that name." + "In '" + ++ field + ++ "': the pattern '" + ++ glob + ++ "' attempts to" + ++ " match files in the directory '" + ++ dir + ++ "', but there is no" + ++ " directory by that name." ppExplanation (UnknownOS unknownOSs) = - "Unknown operating system name " ++ commaSep (map quote unknownOSs) + "Unknown operating system name " ++ commaSep (map quote unknownOSs) ppExplanation (UnknownArch unknownArches) = - "Unknown architecture name " ++ commaSep (map quote unknownArches) + "Unknown architecture name " ++ commaSep (map quote unknownArches) ppExplanation (UnknownCompiler unknownImpls) = - "Unknown compiler name " ++ commaSep (map quote unknownImpls) + "Unknown compiler name " ++ commaSep (map quote unknownImpls) ppExplanation (MissingUpperBounds names) = - let separator = "\n - " - in - "These packages miss upper bounds:" ++ separator - ++ (intercalate separator (unPackageName <$> names)) ++ "\n" - ++ "Please add them, using `cabal gen-bounds` for suggestions." - ++ " For more information see: " - ++ " https://pvp.haskell.org/" + let separator = "\n - " + in "These packages miss upper bounds:" + ++ separator + ++ (intercalate separator (unPackageName <$> names)) + ++ "\n" + ++ "Please add them, using `cabal gen-bounds` for suggestions." + ++ " For more information see: " + ++ " https://pvp.haskell.org/" ppExplanation BaseNoUpperBounds = - "The dependency 'build-depends: base' does not specify an upper " - ++ "bound on the version number. Each major release of the 'base' " - ++ "package changes the API in various ways and most packages will " - ++ "need some changes to compile with it. The recommended practice " - ++ "is to specify an upper bound on the version of the 'base' " - ++ "package. This ensures your package will continue to build when a " - ++ "new major version of the 'base' package is released. If you are " - ++ "not sure what upper bound to use then use the next major " - ++ "version. For example if you have tested your package with 'base' " - ++ "version 4.5 and 4.6 then use 'build-depends: base >= 4.5 && < 4.7'." + "The dependency 'build-depends: base' does not specify an upper " + ++ "bound on the version number. Each major release of the 'base' " + ++ "package changes the API in various ways and most packages will " + ++ "need some changes to compile with it. The recommended practice " + ++ "is to specify an upper bound on the version of the 'base' " + ++ "package. This ensures your package will continue to build when a " + ++ "new major version of the 'base' package is released. If you are " + ++ "not sure what upper bound to use then use the next major " + ++ "version. For example if you have tested your package with 'base' " + ++ "version 4.5 and 4.6 then use 'build-depends: base >= 4.5 && < 4.7'." ppExplanation (SuspiciousFlagName invalidFlagNames) = - "Suspicious flag names: " ++ unwords invalidFlagNames ++ ". " - ++ "To avoid ambiguity in command line interfaces, flag shouldn't " - ++ "start with a dash. Also for better compatibility, flag names " - ++ "shouldn't contain non-ascii characters." + "Suspicious flag names: " + ++ unwords invalidFlagNames + ++ ". " + ++ "To avoid ambiguity in command line interfaces, flag shouldn't " + ++ "start with a dash. Also for better compatibility, flag names " + ++ "shouldn't contain non-ascii characters." ppExplanation (DeclaredUsedFlags declared used) = - "Declared and used flag sets differ: " - ++ s declared ++ " /= " ++ s used ++ ". " - where s :: Set.Set FlagName -> String - s = commaSep . map unFlagName . Set.toList + "Declared and used flag sets differ: " + ++ s declared + ++ " /= " + ++ s used + ++ ". " + where + s :: Set.Set FlagName -> String + s = commaSep . map unFlagName . Set.toList ppExplanation (NonASCIICustomField nonAsciiXFields) = - "Non ascii custom fields: " ++ unwords nonAsciiXFields ++ ". " - ++ "For better compatibility, custom field names " - ++ "shouldn't contain non-ascii characters." + "Non ascii custom fields: " + ++ unwords nonAsciiXFields + ++ ". " + ++ "For better compatibility, custom field names " + ++ "shouldn't contain non-ascii characters." ppExplanation RebindableClashPaths = - "Packages using RebindableSyntax with OverloadedStrings or" - ++ " OverloadedLists in default-extensions, in conjunction with the" - ++ " autogenerated module Paths_*, are known to cause compile failures" - ++ " with Cabal < 2.2. To use these default-extensions with a Paths_*" - ++ " autogen module, specify at least 'cabal-version: 2.2'." + "Packages using RebindableSyntax with OverloadedStrings or" + ++ " OverloadedLists in default-extensions, in conjunction with the" + ++ " autogenerated module Paths_*, are known to cause compile failures" + ++ " with Cabal < 2.2. To use these default-extensions with a Paths_*" + ++ " autogen module, specify at least 'cabal-version: 2.2'." ppExplanation RebindableClashPackageInfo = - "Packages using RebindableSyntax with OverloadedStrings or" - ++ " OverloadedLists in default-extensions, in conjunction with the" - ++ " autogenerated module PackageInfo_*, are known to cause compile failures" - ++ " with Cabal < 2.2. To use these default-extensions with a PackageInfo_*" - ++ " autogen module, specify at least 'cabal-version: 2.2'." -ppExplanation (WErrorUnneeded fieldName) = addConditionalExp $ - "'" ++ fieldName ++ ": -Werror' makes the package easy to " + "Packages using RebindableSyntax with OverloadedStrings or" + ++ " OverloadedLists in default-extensions, in conjunction with the" + ++ " autogenerated module PackageInfo_*, are known to cause compile failures" + ++ " with Cabal < 2.2. To use these default-extensions with a PackageInfo_*" + ++ " autogen module, specify at least 'cabal-version: 2.2'." +ppExplanation (WErrorUnneeded fieldName) = + addConditionalExp $ + "'" + ++ fieldName + ++ ": -Werror' makes the package easy to " ++ "break with future GHC versions because new GHC versions often " ++ "add new warnings." -ppExplanation (JUnneeded fieldName) = addConditionalExp $ - "'" ++ fieldName ++ ": -j[N]' can make sense for specific user's setup," +ppExplanation (JUnneeded fieldName) = + addConditionalExp $ + "'" + ++ fieldName + ++ ": -j[N]' can make sense for specific user's setup," ++ " but it is not appropriate for a distributed package." -ppExplanation (FDeferTypeErrorsUnneeded fieldName) = addConditionalExp $ - "'" ++ fieldName ++ ": -fdefer-type-errors' is fine during development " +ppExplanation (FDeferTypeErrorsUnneeded fieldName) = + addConditionalExp $ + "'" + ++ fieldName + ++ ": -fdefer-type-errors' is fine during development " ++ "but is not appropriate for a distributed package." -ppExplanation (DynamicUnneeded fieldName) = addConditionalExp $ - "'" ++ fieldName ++ ": -d*' debug flags are not appropriate " +ppExplanation (DynamicUnneeded fieldName) = + addConditionalExp $ + "'" + ++ fieldName + ++ ": -d*' debug flags are not appropriate " ++ "for a distributed package." -ppExplanation (ProfilingUnneeded fieldName) = addConditionalExp $ - "'" ++ fieldName ++ ": -fprof*' profiling flags are typically not " +ppExplanation (ProfilingUnneeded fieldName) = + addConditionalExp $ + "'" + ++ fieldName + ++ ": -fprof*' profiling flags are typically not " ++ "appropriate for a distributed library package. These flags are " ++ "useful to profile this package, but when profiling other packages " ++ "that use this one these flags clutter the profile output with " @@ -752,66 +879,93 @@ ppExplanation (ProfilingUnneeded fieldName) = addConditionalExp $ ++ "cost centres from this package then use '-fprof-auto-exported' " ++ "which puts cost centres only on exported functions." ppExplanation (UpperBoundSetup nm) = - "The dependency 'setup-depends: '"++nm++"' does not specify an " - ++ "upper bound on the version number. Each major release of the " - ++ "'"++nm++"' package changes the API in various ways and most " - ++ "packages will need some changes to compile with it. If you are " - ++ "not sure what upper bound to use then use the next major " - ++ "version." + "The dependency 'setup-depends: '" + ++ nm + ++ "' does not specify an " + ++ "upper bound on the version number. Each major release of the " + ++ "'" + ++ nm + ++ "' package changes the API in various ways and most " + ++ "packages will need some changes to compile with it. If you are " + ++ "not sure what upper bound to use then use the next major " + ++ "version." ppExplanation (DuplicateModule s dupLibsLax) = - "Duplicate modules in " ++ s ++ ": " - ++ commaSep (map prettyShow dupLibsLax) + "Duplicate modules in " + ++ s + ++ ": " + ++ commaSep (map prettyShow dupLibsLax) ppExplanation (PotentialDupModule s dupLibsStrict) = - "Potential duplicate modules (subject to conditionals) in " ++ s - ++ ": " ++ commaSep (map prettyShow dupLibsStrict) + "Potential duplicate modules (subject to conditionals) in " + ++ s + ++ ": " + ++ commaSep (map prettyShow dupLibsStrict) ppExplanation (BOMStart pdfile) = - pdfile ++ " starts with an Unicode byte order mark (BOM)." - ++ " This may cause problems with older cabal versions." + pdfile + ++ " starts with an Unicode byte order mark (BOM)." + ++ " This may cause problems with older cabal versions." ppExplanation (NotPackageName pdfile expectedCabalname) = - "The filename " ++ quote pdfile ++ " does not match package name " - ++ "(expected: " ++ quote expectedCabalname ++ ")" + "The filename " + ++ quote pdfile + ++ " does not match package name " + ++ "(expected: " + ++ quote expectedCabalname + ++ ")" ppExplanation NoDesc = - "No cabal file found.\n" - ++ "Please create a package description file .cabal" + "No cabal file found.\n" + ++ "Please create a package description file .cabal" ppExplanation (MultiDesc multiple) = - "Multiple cabal files found while checking.\n" - ++ "Please use only one of: " - ++ intercalate ", " multiple + "Multiple cabal files found while checking.\n" + ++ "Please use only one of: " + ++ intercalate ", " multiple ppExplanation (UnknownFile fieldname file) = - "The '" ++ fieldname ++ "' field refers to the file " - ++ quote (getSymbolicPath file) ++ " which does not exist." + "The '" + ++ fieldname + ++ "' field refers to the file " + ++ quote (getSymbolicPath file) + ++ " which does not exist." ppExplanation MissingSetupFile = - "The package is missing a Setup.hs or Setup.lhs script." + "The package is missing a Setup.hs or Setup.lhs script." ppExplanation MissingConfigureScript = - "The 'build-type' is 'Configure' but there is no 'configure' script. " - ++ "You probably need to run 'autoreconf -i' to generate it." + "The 'build-type' is 'Configure' but there is no 'configure' script. " + ++ "You probably need to run 'autoreconf -i' to generate it." ppExplanation (UnknownDirectory kind dir) = - quote (kind ++ ": " ++ dir) - ++ " specifies a directory which does not exist." + quote (kind ++ ": " ++ dir) + ++ " specifies a directory which does not exist." ppExplanation MissingSourceControl = - "When distributing packages it is encouraged to specify source " - ++ "control information in the .cabal file using one or more " - ++ "'source-repository' sections. See the Cabal user guide for " - ++ "details." + "When distributing packages it is encouraged to specify source " + ++ "control information in the .cabal file using one or more " + ++ "'source-repository' sections. See the Cabal user guide for " + ++ "details." ppExplanation (MissingExpectedDocFiles extraDocFileSupport paths) = - "Please consider including the " ++ quotes paths - ++ " in the '" ++ targetField ++ "' section of the .cabal file " - ++ "if it contains useful information for users of the package." - where quotes [p] = "file " ++ quote p - quotes ps = "files " ++ intercalate ", " (map quote ps) - targetField = if extraDocFileSupport - then "extra-doc-files" - else "extra-source-files" + "Please consider including the " + ++ quotes paths + ++ " in the '" + ++ targetField + ++ "' section of the .cabal file " + ++ "if it contains useful information for users of the package." + where + quotes [p] = "file " ++ quote p + quotes ps = "files " ++ intercalate ", " (map quote ps) + targetField = + if extraDocFileSupport + then "extra-doc-files" + else "extra-source-files" ppExplanation (WrongFieldForExpectedDocFiles extraDocFileSupport field paths) = - "Please consider moving the " ++ quotes paths - ++ " from the '" ++ field ++ "' section of the .cabal file " - ++ "to the section '" ++ targetField ++ "'." - where quotes [p] = "file " ++ quote p - quotes ps = "files " ++ intercalate ", " (map quote ps) - targetField = if extraDocFileSupport - then "extra-doc-files" - else "extra-source-files" - + "Please consider moving the " + ++ quotes paths + ++ " from the '" + ++ field + ++ "' section of the .cabal file " + ++ "to the section '" + ++ targetField + ++ "'." + where + quotes [p] = "file " ++ quote p + quotes ps = "files " ++ intercalate ", " (map quote ps) + targetField = + if extraDocFileSupport + then "extra-doc-files" + else "extra-source-files" -- | Results of some kind of failed package check. -- @@ -819,65 +973,64 @@ ppExplanation (WrongFieldForExpectedDocFiles extraDocFileSupport field paths) = -- All of them come with a human readable explanation. In future we may augment -- them with more machine readable explanations, for example to help an IDE -- suggest automatic corrections. --- -data PackageCheck = - - -- | This package description is no good. There's no way it's going to - -- build sensibly. This should give an error at configure time. - PackageBuildImpossible { explanation :: CheckExplanation } - - -- | A problem that is likely to affect building the package, or an - -- issue that we'd like every package author to be aware of, even if - -- the package is never distributed. - | PackageBuildWarning { explanation :: CheckExplanation } - - -- | An issue that might not be a problem for the package author but - -- might be annoying or detrimental when the package is distributed to - -- users. We should encourage distributed packages to be free from these - -- issues, but occasionally there are justifiable reasons so we cannot - -- ban them entirely. - | PackageDistSuspicious { explanation :: CheckExplanation } - - -- | Like PackageDistSuspicious but will only display warnings - -- rather than causing abnormal exit when you run 'cabal check'. - | PackageDistSuspiciousWarn { explanation :: CheckExplanation } - - -- | An issue that is OK in the author's environment but is almost - -- certain to be a portability problem for other environments. We can - -- quite legitimately refuse to publicly distribute packages with these - -- problems. - | PackageDistInexcusable { explanation :: CheckExplanation } +data PackageCheck + = -- | This package description is no good. There's no way it's going to + -- build sensibly. This should give an error at configure time. + PackageBuildImpossible {explanation :: CheckExplanation} + | -- | A problem that is likely to affect building the package, or an + -- issue that we'd like every package author to be aware of, even if + -- the package is never distributed. + PackageBuildWarning {explanation :: CheckExplanation} + | -- | An issue that might not be a problem for the package author but + -- might be annoying or detrimental when the package is distributed to + -- users. We should encourage distributed packages to be free from these + -- issues, but occasionally there are justifiable reasons so we cannot + -- ban them entirely. + PackageDistSuspicious {explanation :: CheckExplanation} + | -- | Like PackageDistSuspicious but will only display warnings + -- rather than causing abnormal exit when you run 'cabal check'. + PackageDistSuspiciousWarn {explanation :: CheckExplanation} + | -- | An issue that is OK in the author's environment but is almost + -- certain to be a portability problem for other environments. We can + -- quite legitimately refuse to publicly distribute packages with these + -- problems. + PackageDistInexcusable {explanation :: CheckExplanation} deriving (Eq, Ord) -- | Would Hackage refuse a package because of this error? isHackageDistError :: PackageCheck -> Bool isHackageDistError = \case - (PackageBuildImpossible {}) -> True - (PackageBuildWarning {}) -> True - (PackageDistInexcusable {}) -> True - (PackageDistSuspicious {}) -> False - (PackageDistSuspiciousWarn {}) -> False + (PackageBuildImpossible{}) -> True + (PackageBuildWarning{}) -> True + (PackageDistInexcusable{}) -> True + (PackageDistSuspicious{}) -> False + (PackageDistSuspiciousWarn{}) -> False -- | Pretty printing 'PackageCheck'. --- ppPackageCheck :: PackageCheck -> String ppPackageCheck e = ppExplanation (explanation e) instance Show PackageCheck where - show notice = ppPackageCheck notice + show notice = ppPackageCheck notice check :: Bool -> PackageCheck -> Maybe PackageCheck -check False _ = Nothing -check True pc = Just pc - -checkSpecVersion :: PackageDescription -> CabalSpecVersion -> Bool -> PackageCheck - -> Maybe PackageCheck +check False _ = Nothing +check True pc = Just pc + +checkSpecVersion + :: PackageDescription + -> CabalSpecVersion + -> Bool + -> PackageCheck + -> Maybe PackageCheck checkSpecVersion pkg specver cond pc - | specVersion pkg >= specver = Nothing - | otherwise = check cond pc + | specVersion pkg >= specver = Nothing + | otherwise = check cond pc -- ------------------------------------------------------------ + -- * Standard checks + -- ------------------------------------------------------------ -- | Check for common mistakes and problems in package descriptions. @@ -889,84 +1042,85 @@ checkSpecVersion pkg specver cond pc -- It requires the 'GenericPackageDescription' and optionally a particular -- configuration of that package. If you pass 'Nothing' then we just check -- a version of the generic description using 'flattenPackageDescription'. --- -checkPackage :: GenericPackageDescription - -> Maybe PackageDescription - -> [PackageCheck] +checkPackage + :: GenericPackageDescription + -> Maybe PackageDescription + -> [PackageCheck] checkPackage gpkg mpkg = - checkConfiguredPackage pkg - ++ checkConditionals gpkg - ++ checkPackageVersions gpkg - ++ checkDevelopmentOnlyFlags gpkg - ++ checkFlagNames gpkg - ++ checkUnusedFlags gpkg - ++ checkUnicodeXFields gpkg - ++ checkPathsModuleExtensions pkg - ++ checkPackageInfoModuleExtensions pkg - ++ checkSetupVersions gpkg - ++ checkDuplicateModules gpkg + checkConfiguredPackage pkg + ++ checkConditionals gpkg + ++ checkPackageVersions gpkg + ++ checkDevelopmentOnlyFlags gpkg + ++ checkFlagNames gpkg + ++ checkUnusedFlags gpkg + ++ checkUnicodeXFields gpkg + ++ checkPathsModuleExtensions pkg + ++ checkPackageInfoModuleExtensions pkg + ++ checkSetupVersions gpkg + ++ checkDuplicateModules gpkg where pkg = fromMaybe (flattenPackageDescription gpkg) mpkg ---TODO: make this variant go away +-- TODO: make this variant go away -- we should always know the GenericPackageDescription checkConfiguredPackage :: PackageDescription -> [PackageCheck] checkConfiguredPackage pkg = - checkSanity pkg - ++ checkFields pkg - ++ checkLicense pkg - ++ checkSourceRepos pkg - ++ checkAllGhcOptions pkg - ++ checkCCOptions pkg - ++ checkCxxOptions pkg - ++ checkCPPOptions pkg - ++ checkPaths pkg - ++ checkCabalVersion pkg - + checkSanity pkg + ++ checkFields pkg + ++ checkLicense pkg + ++ checkSourceRepos pkg + ++ checkAllGhcOptions pkg + ++ checkCCOptions pkg + ++ checkCxxOptions pkg + ++ checkCPPOptions pkg + ++ checkPaths pkg + ++ checkCabalVersion pkg -- ------------------------------------------------------------ + -- * Basic sanity checks + -- ------------------------------------------------------------ -- | Check that this package description is sane. --- checkSanity :: PackageDescription -> [PackageCheck] checkSanity pkg = - catMaybes [ - - check (null . unPackageName . packageName $ pkg) $ - PackageBuildImpossible NoNameField - - , check (nullVersion == packageVersion pkg) $ - PackageBuildImpossible NoVersionField - - , check (all ($ pkg) [ null . executables - , null . testSuites - , null . benchmarks - , null . allLibraries - , null . foreignLibs ]) $ - PackageBuildImpossible NoTarget - - , check (any (== LMainLibName) (map libName $ subLibraries pkg)) $ - PackageBuildImpossible UnnamedInternal - - , check (not (null duplicateNames)) $ - PackageBuildImpossible (DuplicateSections duplicateNames) - - -- NB: but it's OK for executables to have the same name! - -- TODO shouldn't need to compare on the string level - , check (any (== prettyShow (packageName pkg)) - (prettyShow <$> subLibNames)) $ - PackageBuildImpossible (IllegalLibraryName pkg) - ] - --TODO: check for name clashes case insensitively: windows file systems cannot - --cope. - - ++ concatMap (checkLibrary pkg) (allLibraries pkg) - ++ concatMap (checkExecutable pkg) (executables pkg) - ++ concatMap (checkTestSuite pkg) (testSuites pkg) - ++ concatMap (checkBenchmark pkg) (benchmarks pkg) + catMaybes + [ check (null . unPackageName . packageName $ pkg) $ + PackageBuildImpossible NoNameField + , check (nullVersion == packageVersion pkg) $ + PackageBuildImpossible NoVersionField + , check + ( all + ($ pkg) + [ null . executables + , null . testSuites + , null . benchmarks + , null . allLibraries + , null . foreignLibs + ] + ) + $ PackageBuildImpossible NoTarget + , check (any (== LMainLibName) (map libName $ subLibraries pkg)) $ + PackageBuildImpossible UnnamedInternal + , check (not (null duplicateNames)) $ + PackageBuildImpossible (DuplicateSections duplicateNames) + , -- NB: but it's OK for executables to have the same name! + -- TODO shouldn't need to compare on the string level + check + ( any + (== prettyShow (packageName pkg)) + (prettyShow <$> subLibNames) + ) + $ PackageBuildImpossible (IllegalLibraryName pkg) + ] + -- TODO: check for name clashes case insensitively: windows file systems cannot + -- cope. + ++ concatMap (checkLibrary pkg) (allLibraries pkg) + ++ concatMap (checkExecutable pkg) (executables pkg) + ++ concatMap (checkTestSuite pkg) (testSuites pkg) + ++ concatMap (checkBenchmark pkg) (benchmarks pkg) where -- The public 'library' gets special dispensation, because it -- is common practice to export a library and name the executable @@ -979,251 +1133,228 @@ checkSanity pkg = checkLibrary :: PackageDescription -> Library -> [PackageCheck] checkLibrary pkg lib = - catMaybes [ - - -- TODO: This check is bogus if a required-signature was passed through - check (null (explicitLibModules lib) && null (reexportedModules lib)) $ - PackageDistSuspiciousWarn (NoModulesExposed lib) - - -- check use of signatures sections - , checkVersion CabalSpecV2_0 (not (null (signatures lib))) $ - PackageDistInexcusable SignaturesCabal2 - - -- check that all autogen-modules appear on other-modules or exposed-modules - , check - (not $ and $ map (flip elem (explicitLibModules lib)) (libModulesAutogen lib)) $ - PackageBuildImpossible AutogenNotExposed - - -- check that all autogen-includes appear on includes or install-includes - , check - (not $ and $ map (flip elem (allExplicitIncludes lib)) (view L.autogenIncludes lib)) $ - PackageBuildImpossible AutogenIncludesNotIncluded - ] - + catMaybes + [ -- TODO: This check is bogus if a required-signature was passed through + check (null (explicitLibModules lib) && null (reexportedModules lib)) $ + PackageDistSuspiciousWarn (NoModulesExposed lib) + , -- check use of signatures sections + checkVersion CabalSpecV2_0 (not (null (signatures lib))) $ + PackageDistInexcusable SignaturesCabal2 + , -- check that all autogen-modules appear on other-modules or exposed-modules + check + (not $ and $ map (flip elem (explicitLibModules lib)) (libModulesAutogen lib)) + $ PackageBuildImpossible AutogenNotExposed + , -- check that all autogen-includes appear on includes or install-includes + check + (not $ and $ map (flip elem (allExplicitIncludes lib)) (view L.autogenIncludes lib)) + $ PackageBuildImpossible AutogenIncludesNotIncluded + ] where checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck checkVersion ver cond pc | specVersion pkg >= ver = Nothing - | otherwise = check cond pc + | otherwise = check cond pc allExplicitIncludes :: L.HasBuildInfo a => a -> [FilePath] allExplicitIncludes x = view L.includes x ++ view L.installIncludes x checkExecutable :: PackageDescription -> Executable -> [PackageCheck] checkExecutable pkg exe = - catMaybes [ - - check (null (modulePath exe)) $ - PackageBuildImpossible (NoMainIs exe) - - -- This check does not apply to scripts. - , check (package pkg /= fakePackageId - && not (null (modulePath exe)) - && not (fileExtensionSupportedLanguage $ modulePath exe)) $ - PackageBuildImpossible NoHsLhsMain - - , checkSpecVersion pkg CabalSpecV1_18 - (fileExtensionSupportedLanguage (modulePath exe) - && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $ - PackageDistInexcusable MainCCabal1_18 - - -- check that all autogen-modules appear on other-modules - , check - (not $ and $ map (flip elem (exeModules exe)) (exeModulesAutogen exe)) $ - PackageBuildImpossible (AutogenNoOther CETExecutable (exeName exe)) - - -- check that all autogen-includes appear on includes - , check - (not $ and $ map (flip elem (view L.includes exe)) (view L.autogenIncludes exe)) $ - PackageBuildImpossible AutogenIncludesNotIncludedExe - ] + catMaybes + [ check (null (modulePath exe)) $ + PackageBuildImpossible (NoMainIs exe) + , -- This check does not apply to scripts. + check + ( package pkg /= fakePackageId + && not (null (modulePath exe)) + && not (fileExtensionSupportedLanguage $ modulePath exe) + ) + $ PackageBuildImpossible NoHsLhsMain + , checkSpecVersion + pkg + CabalSpecV1_18 + ( fileExtensionSupportedLanguage (modulePath exe) + && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"] + ) + $ PackageDistInexcusable MainCCabal1_18 + , -- check that all autogen-modules appear on other-modules + check + (not $ and $ map (flip elem (exeModules exe)) (exeModulesAutogen exe)) + $ PackageBuildImpossible (AutogenNoOther CETExecutable (exeName exe)) + , -- check that all autogen-includes appear on includes + check + (not $ and $ map (flip elem (view L.includes exe)) (view L.autogenIncludes exe)) + $ PackageBuildImpossible AutogenIncludesNotIncludedExe + ] checkTestSuite :: PackageDescription -> TestSuite -> [PackageCheck] checkTestSuite pkg test = - catMaybes [ - - case testInterface test of - TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> Just $ - PackageBuildWarning (TestsuiteTypeNotKnown tt) - - TestSuiteUnsupported tt -> Just $ - PackageBuildWarning (TestsuiteNotSupported tt) - _ -> Nothing - - , check mainIsWrongExt $ - PackageBuildImpossible NoHsLhsMain - - , checkSpecVersion pkg CabalSpecV1_18 (mainIsNotHsExt && not mainIsWrongExt) $ - PackageDistInexcusable MainCCabal1_18 - - -- check that all autogen-modules appear on other-modules - , check - (not $ and $ map (flip elem (testModules test)) (testModulesAutogen test)) $ - PackageBuildImpossible (AutogenNoOther CETTest (testName test)) - - -- check that all autogen-includes appear on includes - , check - (not $ and $ map (flip elem (view L.includes test)) (view L.autogenIncludes test)) $ - PackageBuildImpossible AutogenIncludesNotIncludedExe - ] + catMaybes + [ case testInterface test of + TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> + Just $ + PackageBuildWarning (TestsuiteTypeNotKnown tt) + TestSuiteUnsupported tt -> + Just $ + PackageBuildWarning (TestsuiteNotSupported tt) + _ -> Nothing + , check mainIsWrongExt $ + PackageBuildImpossible NoHsLhsMain + , checkSpecVersion pkg CabalSpecV1_18 (mainIsNotHsExt && not mainIsWrongExt) $ + PackageDistInexcusable MainCCabal1_18 + , -- check that all autogen-modules appear on other-modules + check + (not $ and $ map (flip elem (testModules test)) (testModulesAutogen test)) + $ PackageBuildImpossible (AutogenNoOther CETTest (testName test)) + , -- check that all autogen-includes appear on includes + check + (not $ and $ map (flip elem (view L.includes test)) (view L.autogenIncludes test)) + $ PackageBuildImpossible AutogenIncludesNotIncludedExe + ] where mainIsWrongExt = case testInterface test of TestSuiteExeV10 _ f -> not $ fileExtensionSupportedLanguage f - _ -> False + _ -> False mainIsNotHsExt = case testInterface test of TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] - _ -> False + _ -> False checkBenchmark :: PackageDescription -> Benchmark -> [PackageCheck] checkBenchmark _pkg bm = - catMaybes [ - - case benchmarkInterface bm of - BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) -> Just $ - PackageBuildWarning (BenchmarkTypeNotKnown tt) - - BenchmarkUnsupported tt -> Just $ - PackageBuildWarning (BenchmarkNotSupported tt) - _ -> Nothing - - , check mainIsWrongExt $ - PackageBuildImpossible NoHsLhsMainBench - - -- check that all autogen-modules appear on other-modules - , check - (not $ and $ map (flip elem (benchmarkModules bm)) (benchmarkModulesAutogen bm)) $ - PackageBuildImpossible (AutogenNoOther CETBenchmark (benchmarkName bm)) - - -- check that all autogen-includes appear on includes - , check - (not $ and $ map (flip elem (view L.includes bm)) (view L.autogenIncludes bm)) $ - PackageBuildImpossible AutogenIncludesNotIncludedExe - ] + catMaybes + [ case benchmarkInterface bm of + BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) -> + Just $ + PackageBuildWarning (BenchmarkTypeNotKnown tt) + BenchmarkUnsupported tt -> + Just $ + PackageBuildWarning (BenchmarkNotSupported tt) + _ -> Nothing + , check mainIsWrongExt $ + PackageBuildImpossible NoHsLhsMainBench + , -- check that all autogen-modules appear on other-modules + check + (not $ and $ map (flip elem (benchmarkModules bm)) (benchmarkModulesAutogen bm)) + $ PackageBuildImpossible (AutogenNoOther CETBenchmark (benchmarkName bm)) + , -- check that all autogen-includes appear on includes + check + (not $ and $ map (flip elem (view L.includes bm)) (view L.autogenIncludes bm)) + $ PackageBuildImpossible AutogenIncludesNotIncludedExe + ] where mainIsWrongExt = case benchmarkInterface bm of BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] - _ -> False + _ -> False -- ------------------------------------------------------------ + -- * Additional pure checks + -- ------------------------------------------------------------ checkFields :: PackageDescription -> [PackageCheck] checkFields pkg = - catMaybes [ - - check (not . FilePath.Windows.isValid . prettyShow . packageName $ pkg) $ - PackageDistInexcusable (InvalidNameWin pkg) - - , check (isPrefixOf "z-" . prettyShow . packageName $ pkg) $ - PackageDistInexcusable ZPrefix - - , check (isNothing (buildTypeRaw pkg) && specVersion pkg < CabalSpecV2_2) $ - PackageBuildWarning NoBuildType - - , check (isJust (setupBuildInfo pkg) && buildType pkg /= Custom) $ - PackageBuildWarning NoCustomSetup - - , check (not (null unknownCompilers)) $ - PackageBuildWarning (UnknownCompilers unknownCompilers) - - , check (not (null unknownLanguages)) $ - PackageBuildWarning (UnknownLanguages unknownLanguages) - - , check (not (null unknownExtensions)) $ - PackageBuildWarning (UnknownExtensions unknownExtensions) - - , check (not (null languagesUsedAsExtensions)) $ - PackageBuildWarning (LanguagesAsExtension languagesUsedAsExtensions) - - , check (not (null ourDeprecatedExtensions)) $ - PackageDistSuspicious (DeprecatedExtensions ourDeprecatedExtensions) - - , check (ShortText.null (category pkg)) $ - PackageDistSuspicious (MissingField CEFCategory) - - , check (ShortText.null (maintainer pkg)) $ - PackageDistSuspicious (MissingField CEFMaintainer) - - , check (ShortText.null (synopsis pkg) && ShortText.null (description pkg)) $ - PackageDistInexcusable (MissingField CEFSynOrDesc) - - , check (ShortText.null (description pkg) && not (ShortText.null (synopsis pkg))) $ - PackageDistSuspicious (MissingField CEFDescription) - - , check (ShortText.null (synopsis pkg) && not (ShortText.null (description pkg))) $ - PackageDistSuspicious (MissingField CEFSynopsis) - - --TODO: recommend the bug reports URL, author and homepage fields - --TODO: recommend not using the stability field - --TODO: recommend specifying a source repo - - , check (ShortText.length (synopsis pkg) > 80) $ - PackageDistSuspicious SynopsisTooLong - - -- See also https://github.com/haskell/cabal/pull/3479 - , check (not (ShortText.null (description pkg)) - && ShortText.length (description pkg) <= ShortText.length (synopsis pkg)) $ - PackageDistSuspicious ShortDesc - - -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12" - , check (not (null testedWithImpossibleRanges)) $ - PackageDistInexcusable (InvalidTestWith testedWithImpossibleRanges) - - -- for more details on why the following was commented out, - -- check https://github.com/haskell/cabal/pull/7470#issuecomment-875878507 - -- , check (not (null depInternalLibraryWithExtraVersion)) $ - -- PackageBuildWarning $ - -- "The package has an extraneous version range for a dependency on an " - -- ++ "internal library: " - -- ++ commaSep (map prettyShow depInternalLibraryWithExtraVersion) - -- ++ ". This version range includes the current package but isn't needed " - -- ++ "as the current package's library will always be used." - - , check (not (null depInternalLibraryWithImpossibleVersion)) $ - PackageBuildImpossible - (ImpossibleInternalDep depInternalLibraryWithImpossibleVersion) - - -- , check (not (null depInternalExecutableWithExtraVersion)) $ - -- PackageBuildWarning $ - -- "The package has an extraneous version range for a dependency on an " - -- ++ "internal executable: " - -- ++ commaSep (map prettyShow depInternalExecutableWithExtraVersion) - -- ++ ". This version range includes the current package but isn't needed " - -- ++ "as the current package's executable will always be used." - - , check (not (null depInternalExecutableWithImpossibleVersion)) $ - PackageBuildImpossible - (ImpossibleInternalExe depInternalExecutableWithImpossibleVersion) - - , check (not (null depMissingInternalExecutable)) $ - PackageBuildImpossible (MissingInternalExe depMissingInternalExecutable) - ] + catMaybes + [ check (not . FilePath.Windows.isValid . prettyShow . packageName $ pkg) $ + PackageDistInexcusable (InvalidNameWin pkg) + , check (isPrefixOf "z-" . prettyShow . packageName $ pkg) $ + PackageDistInexcusable ZPrefix + , check (isNothing (buildTypeRaw pkg) && specVersion pkg < CabalSpecV2_2) $ + PackageBuildWarning NoBuildType + , check (isJust (setupBuildInfo pkg) && buildType pkg /= Custom) $ + PackageBuildWarning NoCustomSetup + , check (not (null unknownCompilers)) $ + PackageBuildWarning (UnknownCompilers unknownCompilers) + , check (not (null unknownLanguages)) $ + PackageBuildWarning (UnknownLanguages unknownLanguages) + , check (not (null unknownExtensions)) $ + PackageBuildWarning (UnknownExtensions unknownExtensions) + , check (not (null languagesUsedAsExtensions)) $ + PackageBuildWarning (LanguagesAsExtension languagesUsedAsExtensions) + , check (not (null ourDeprecatedExtensions)) $ + PackageDistSuspicious (DeprecatedExtensions ourDeprecatedExtensions) + , check (ShortText.null (category pkg)) $ + PackageDistSuspicious (MissingField CEFCategory) + , check (ShortText.null (maintainer pkg)) $ + PackageDistSuspicious (MissingField CEFMaintainer) + , check (ShortText.null (synopsis pkg) && ShortText.null (description pkg)) $ + PackageDistInexcusable (MissingField CEFSynOrDesc) + , check (ShortText.null (description pkg) && not (ShortText.null (synopsis pkg))) $ + PackageDistSuspicious (MissingField CEFDescription) + , check (ShortText.null (synopsis pkg) && not (ShortText.null (description pkg))) $ + PackageDistSuspicious (MissingField CEFSynopsis) + , -- TODO: recommend the bug reports URL, author and homepage fields + -- TODO: recommend not using the stability field + -- TODO: recommend specifying a source repo + + check (ShortText.length (synopsis pkg) > 80) $ + PackageDistSuspicious SynopsisTooLong + , -- See also https://github.com/haskell/cabal/pull/3479 + check + ( not (ShortText.null (description pkg)) + && ShortText.length (description pkg) <= ShortText.length (synopsis pkg) + ) + $ PackageDistSuspicious ShortDesc + , -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12" + check (not (null testedWithImpossibleRanges)) $ + PackageDistInexcusable (InvalidTestWith testedWithImpossibleRanges) + , -- for more details on why the following was commented out, + -- check https://github.com/haskell/cabal/pull/7470#issuecomment-875878507 + -- , check (not (null depInternalLibraryWithExtraVersion)) $ + -- PackageBuildWarning $ + -- "The package has an extraneous version range for a dependency on an " + -- ++ "internal library: " + -- ++ commaSep (map prettyShow depInternalLibraryWithExtraVersion) + -- ++ ". This version range includes the current package but isn't needed " + -- ++ "as the current package's library will always be used." + + check (not (null depInternalLibraryWithImpossibleVersion)) $ + PackageBuildImpossible + (ImpossibleInternalDep depInternalLibraryWithImpossibleVersion) + , -- , check (not (null depInternalExecutableWithExtraVersion)) $ + -- PackageBuildWarning $ + -- "The package has an extraneous version range for a dependency on an " + -- ++ "internal executable: " + -- ++ commaSep (map prettyShow depInternalExecutableWithExtraVersion) + -- ++ ". This version range includes the current package but isn't needed " + -- ++ "as the current package's executable will always be used." + + check (not (null depInternalExecutableWithImpossibleVersion)) $ + PackageBuildImpossible + (ImpossibleInternalExe depInternalExecutableWithImpossibleVersion) + , check (not (null depMissingInternalExecutable)) $ + PackageBuildImpossible (MissingInternalExe depMissingInternalExecutable) + ] where - unknownCompilers = [ name | (OtherCompiler name, _) <- testedWith pkg ] - unknownLanguages = [ name | bi <- allBuildInfo pkg - , UnknownLanguage name <- allLanguages bi ] - unknownExtensions = [ name | bi <- allBuildInfo pkg - , UnknownExtension name <- allExtensions bi - , name `notElem` map prettyShow knownLanguages ] - ourDeprecatedExtensions = nub $ catMaybes - [ find ((==ext) . fst) deprecatedExtensions - | bi <- allBuildInfo pkg - , ext <- allExtensions bi ] + unknownCompilers = [name | (OtherCompiler name, _) <- testedWith pkg] + unknownLanguages = + [ name | bi <- allBuildInfo pkg, UnknownLanguage name <- allLanguages bi + ] + unknownExtensions = + [ name | bi <- allBuildInfo pkg, UnknownExtension name <- allExtensions bi, name `notElem` map prettyShow knownLanguages + ] + ourDeprecatedExtensions = + nub $ + catMaybes + [ find ((== ext) . fst) deprecatedExtensions + | bi <- allBuildInfo pkg + , ext <- allExtensions bi + ] languagesUsedAsExtensions = - [ name | bi <- allBuildInfo pkg - , UnknownExtension name <- allExtensions bi - , name `elem` map prettyShow knownLanguages ] + [ name | bi <- allBuildInfo pkg, UnknownExtension name <- allExtensions bi, name `elem` map prettyShow knownLanguages + ] testedWithImpossibleRanges = [ Dependency (mkPackageName (prettyShow compiler)) vr mainLibSet | (compiler, vr) <- testedWith pkg - , isNoVersion vr ] + , isNoVersion vr + ] internalLibraries = - map (maybe (packageName pkg) unqualComponentNameToPackageName . libraryNameString . libName) - (allLibraries pkg) + map + (maybe (packageName pkg) unqualComponentNameToPackageName . libraryNameString . libName) + (allLibraries pkg) internalExecutables = map exeName $ executables pkg @@ -1275,217 +1406,236 @@ checkFields pkg = checkLicense :: PackageDescription -> [PackageCheck] checkLicense pkg = case licenseRaw pkg of - Right l -> checkOldLicense pkg l - Left l -> checkNewLicense pkg l + Right l -> checkOldLicense pkg l + Left l -> checkNewLicense pkg l checkNewLicense :: PackageDescription -> SPDX.License -> [PackageCheck] -checkNewLicense _pkg lic = catMaybes +checkNewLicense _pkg lic = + catMaybes [ check (lic == SPDX.NONE) $ - PackageDistInexcusable NONELicense ] + PackageDistInexcusable NONELicense + ] checkOldLicense :: PackageDescription -> License -> [PackageCheck] -checkOldLicense pkg lic = catMaybes - [ check (lic == UnspecifiedLicense) $ - PackageDistInexcusable NoLicense - - , check (lic == AllRightsReserved) $ - PackageDistSuspicious AllRightsReservedLicense - - , checkVersion CabalSpecV1_4 (lic `notElem` compatLicenses) $ - PackageDistInexcusable (LicenseMessParse pkg) - - , case lic of - UnknownLicense l -> Just $ PackageBuildWarning (UnrecognisedLicense l) - _ -> Nothing - - , check (lic == BSD4) $ - PackageDistSuspicious UncommonBSD4 - - , case unknownLicenseVersion lic of - Just knownVersions -> Just $ - PackageDistSuspicious (UnknownLicenseVersion lic knownVersions) - _ -> Nothing - - , check (lic `notElem` [ AllRightsReserved - , UnspecifiedLicense, PublicDomain] - -- AllRightsReserved and PublicDomain are not strictly - -- licenses so don't need license files. - && null (licenseFiles pkg)) $ - PackageDistSuspicious NoLicenseFile - ] +checkOldLicense pkg lic = + catMaybes + [ check (lic == UnspecifiedLicense) $ + PackageDistInexcusable NoLicense + , check (lic == AllRightsReserved) $ + PackageDistSuspicious AllRightsReservedLicense + , checkVersion CabalSpecV1_4 (lic `notElem` compatLicenses) $ + PackageDistInexcusable (LicenseMessParse pkg) + , case lic of + UnknownLicense l -> Just $ PackageBuildWarning (UnrecognisedLicense l) + _ -> Nothing + , check (lic == BSD4) $ + PackageDistSuspicious UncommonBSD4 + , case unknownLicenseVersion lic of + Just knownVersions -> + Just $ + PackageDistSuspicious (UnknownLicenseVersion lic knownVersions) + _ -> Nothing + , check + ( lic + `notElem` [ AllRightsReserved + , UnspecifiedLicense + , PublicDomain + ] + -- AllRightsReserved and PublicDomain are not strictly + -- licenses so don't need license files. + && null (licenseFiles pkg) + ) + $ PackageDistSuspicious NoLicenseFile + ] where - unknownLicenseVersion (GPL (Just v)) + unknownLicenseVersion (GPL (Just v)) | v `notElem` knownVersions = Just knownVersions - where knownVersions = [ v' | GPL (Just v') <- knownLicenses ] + where + knownVersions = [v' | GPL (Just v') <- knownLicenses] unknownLicenseVersion (LGPL (Just v)) | v `notElem` knownVersions = Just knownVersions - where knownVersions = [ v' | LGPL (Just v') <- knownLicenses ] + where + knownVersions = [v' | LGPL (Just v') <- knownLicenses] unknownLicenseVersion (AGPL (Just v)) | v `notElem` knownVersions = Just knownVersions - where knownVersions = [ v' | AGPL (Just v') <- knownLicenses ] - unknownLicenseVersion (Apache (Just v)) + where + knownVersions = [v' | AGPL (Just v') <- knownLicenses] + unknownLicenseVersion (Apache (Just v)) | v `notElem` knownVersions = Just knownVersions - where knownVersions = [ v' | Apache (Just v') <- knownLicenses ] + where + knownVersions = [v' | Apache (Just v') <- knownLicenses] unknownLicenseVersion _ = Nothing checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck checkVersion ver cond pc - | specVersion pkg >= ver = Nothing - | otherwise = check cond pc - - compatLicenses = [ GPL Nothing, LGPL Nothing, AGPL Nothing, BSD3, BSD4 - , PublicDomain, AllRightsReserved - , UnspecifiedLicense, OtherLicense ] + | specVersion pkg >= ver = Nothing + | otherwise = check cond pc + + compatLicenses = + [ GPL Nothing + , LGPL Nothing + , AGPL Nothing + , BSD3 + , BSD4 + , PublicDomain + , AllRightsReserved + , UnspecifiedLicense + , OtherLicense + ] checkSourceRepos :: PackageDescription -> [PackageCheck] checkSourceRepos pkg = - catMaybes $ concat [[ - - case repoKind repo of - RepoKindUnknown kind -> Just $ PackageDistInexcusable $ - UnrecognisedSourceRepo kind - _ -> Nothing - - , check (isNothing (repoType repo)) $ - PackageDistInexcusable MissingType - - , check (isNothing (repoLocation repo)) $ - PackageDistInexcusable MissingLocation - - , check (repoType repo == Just (KnownRepoType CVS) && isNothing (repoModule repo)) $ - PackageDistInexcusable MissingModule - - , check (repoKind repo == RepoThis && isNothing (repoTag repo)) $ - PackageDistInexcusable MissingTag - - , check (maybe False isAbsoluteOnAnyPlatform (repoSubdir repo)) $ - PackageDistInexcusable SubdirRelPath - - , do - subdir <- repoSubdir repo - err <- isGoodRelativeDirectoryPath subdir - return $ PackageDistInexcusable (SubdirGoodRelPath err) - ] - | repo <- sourceRepos pkg ] + catMaybes $ + concat + [ [ case repoKind repo of + RepoKindUnknown kind -> + Just $ + PackageDistInexcusable $ + UnrecognisedSourceRepo kind + _ -> Nothing + , check (isNothing (repoType repo)) $ + PackageDistInexcusable MissingType + , check (isNothing (repoLocation repo)) $ + PackageDistInexcusable MissingLocation + , check (repoType repo == Just (KnownRepoType CVS) && isNothing (repoModule repo)) $ + PackageDistInexcusable MissingModule + , check (repoKind repo == RepoThis && isNothing (repoTag repo)) $ + PackageDistInexcusable MissingTag + , check (maybe False isAbsoluteOnAnyPlatform (repoSubdir repo)) $ + PackageDistInexcusable SubdirRelPath + , do + subdir <- repoSubdir repo + err <- isGoodRelativeDirectoryPath subdir + return $ PackageDistInexcusable (SubdirGoodRelPath err) + ] + | repo <- sourceRepos pkg + ] ---TODO: check location looks like a URL for some repo types. +-- TODO: check location looks like a URL for some repo types. -- | Checks GHC options from all ghc-*-options fields in the given -- PackageDescription and reports commonly misused or non-portable flags checkAllGhcOptions :: PackageDescription -> [PackageCheck] checkAllGhcOptions pkg = - checkGhcOptions "ghc-options" (hcOptions GHC) pkg - ++ checkGhcOptions "ghc-prof-options" (hcProfOptions GHC) pkg - ++ checkGhcOptions "ghc-shared-options" (hcSharedOptions GHC) pkg + checkGhcOptions "ghc-options" (hcOptions GHC) pkg + ++ checkGhcOptions "ghc-prof-options" (hcProfOptions GHC) pkg + ++ checkGhcOptions "ghc-shared-options" (hcSharedOptions GHC) pkg -- | Extracts GHC options belonging to the given field from the given -- PackageDescription using given function and checks them for commonly misused -- or non-portable flags checkGhcOptions :: String -> (BuildInfo -> [String]) -> PackageDescription -> [PackageCheck] checkGhcOptions fieldName getOptions pkg = - catMaybes [ - - checkFlags ["-fasm"] $ - PackageDistInexcusable (OptFasm fieldName) - - , checkFlags ["-fvia-C"] $ - PackageDistSuspicious (OptViaC fieldName) - - , checkFlags ["-fhpc"] $ - PackageDistInexcusable (OptHpc fieldName) - - , checkFlags ["-prof"] $ - PackageBuildWarning (OptProf fieldName) - - , checkFlags ["-o"] $ - PackageBuildWarning (OptO fieldName) - - , checkFlags ["-hide-package"] $ - PackageBuildWarning (OptHide fieldName) - - , checkFlags ["--make"] $ - PackageBuildWarning (OptMake fieldName) - - , checkNonTestAndBenchmarkFlags ["-O0", "-Onot"] $ - PackageDistSuspicious (OptONot fieldName) - - , checkTestAndBenchmarkFlags ["-O0", "-Onot"] $ - PackageDistSuspiciousWarn (OptONot fieldName) - - , checkFlags [ "-O", "-O1"] $ - PackageDistInexcusable (OptOOne fieldName) - - , checkFlags ["-O2"] $ - PackageDistSuspiciousWarn (OptOTwo fieldName) - - , checkFlags ["-split-sections"] $ - PackageBuildWarning (OptSplitSections fieldName) - - , checkFlags ["-split-objs"] $ - PackageBuildWarning (OptSplitObjs fieldName) - - , checkFlags ["-optl-Wl,-s", "-optl-s"] $ - PackageDistInexcusable (OptWls fieldName) - - , checkFlags ["-fglasgow-exts"] $ - PackageDistSuspicious (OptExts fieldName) - - , check ("-rtsopts" `elem` lib_ghc_options) $ - PackageBuildWarning (OptRts fieldName) - - , check (any (\opt -> "-with-rtsopts" `isPrefixOf` opt) lib_ghc_options) $ - PackageBuildWarning (OptWithRts fieldName) - - , checkAlternatives fieldName "extensions" - [ (flag, prettyShow extension) | flag <- ghc_options_no_rtsopts - , Just extension <- [ghcExtension flag] ] - - , checkAlternatives fieldName "extensions" - [ (flag, extension) | flag@('-':'X':extension) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "cpp-options" $ - [ (flag, flag) | flag@('-':'D':_) <- ghc_options_no_rtsopts ] - ++ [ (flag, flag) | flag@('-':'U':_) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "include-dirs" - [ (flag, dir) | flag@('-':'I':dir) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "extra-libraries" - [ (flag, lib) | flag@('-':'l':lib) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "extra-libraries-static" - [ (flag, lib) | flag@('-':'l':lib) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "extra-lib-dirs" - [ (flag, dir) | flag@('-':'L':dir) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "extra-lib-dirs-static" - [ (flag, dir) | flag@('-':'L':dir) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "frameworks" - [ (flag, fmwk) | (flag@"-framework", fmwk) <- - zip ghc_options_no_rtsopts (safeTail ghc_options_no_rtsopts) ] - - , checkAlternatives fieldName "extra-framework-dirs" - [ (flag, dir) | (flag@"-framework-path", dir) <- - zip ghc_options_no_rtsopts (safeTail ghc_options_no_rtsopts) ] - ] - + catMaybes + [ checkFlags ["-fasm"] $ + PackageDistInexcusable (OptFasm fieldName) + , checkFlags ["-fvia-C"] $ + PackageDistSuspicious (OptViaC fieldName) + , checkFlags ["-fhpc"] $ + PackageDistInexcusable (OptHpc fieldName) + , checkFlags ["-prof"] $ + PackageBuildWarning (OptProf fieldName) + , checkFlags ["-o"] $ + PackageBuildWarning (OptO fieldName) + , checkFlags ["-hide-package"] $ + PackageBuildWarning (OptHide fieldName) + , checkFlags ["--make"] $ + PackageBuildWarning (OptMake fieldName) + , checkNonTestAndBenchmarkFlags ["-O0", "-Onot"] $ + PackageDistSuspicious (OptONot fieldName) + , checkTestAndBenchmarkFlags ["-O0", "-Onot"] $ + PackageDistSuspiciousWarn (OptONot fieldName) + , checkFlags ["-O", "-O1"] $ + PackageDistInexcusable (OptOOne fieldName) + , checkFlags ["-O2"] $ + PackageDistSuspiciousWarn (OptOTwo fieldName) + , checkFlags ["-split-sections"] $ + PackageBuildWarning (OptSplitSections fieldName) + , checkFlags ["-split-objs"] $ + PackageBuildWarning (OptSplitObjs fieldName) + , checkFlags ["-optl-Wl,-s", "-optl-s"] $ + PackageDistInexcusable (OptWls fieldName) + , checkFlags ["-fglasgow-exts"] $ + PackageDistSuspicious (OptExts fieldName) + , check ("-rtsopts" `elem` lib_ghc_options) $ + PackageBuildWarning (OptRts fieldName) + , check (any (\opt -> "-with-rtsopts" `isPrefixOf` opt) lib_ghc_options) $ + PackageBuildWarning (OptWithRts fieldName) + , checkAlternatives + fieldName + "extensions" + [ (flag, prettyShow extension) | flag <- ghc_options_no_rtsopts, Just extension <- [ghcExtension flag] + ] + , checkAlternatives + fieldName + "extensions" + [(flag, extension) | flag@('-' : 'X' : extension) <- ghc_options_no_rtsopts] + , checkAlternatives fieldName "cpp-options" $ + [(flag, flag) | flag@('-' : 'D' : _) <- ghc_options_no_rtsopts] + ++ [(flag, flag) | flag@('-' : 'U' : _) <- ghc_options_no_rtsopts] + , checkAlternatives + fieldName + "include-dirs" + [(flag, dir) | flag@('-' : 'I' : dir) <- ghc_options_no_rtsopts] + , checkAlternatives + fieldName + "extra-libraries" + [(flag, lib) | flag@('-' : 'l' : lib) <- ghc_options_no_rtsopts] + , checkAlternatives + fieldName + "extra-libraries-static" + [(flag, lib) | flag@('-' : 'l' : lib) <- ghc_options_no_rtsopts] + , checkAlternatives + fieldName + "extra-lib-dirs" + [(flag, dir) | flag@('-' : 'L' : dir) <- ghc_options_no_rtsopts] + , checkAlternatives + fieldName + "extra-lib-dirs-static" + [(flag, dir) | flag@('-' : 'L' : dir) <- ghc_options_no_rtsopts] + , checkAlternatives + fieldName + "frameworks" + [ (flag, fmwk) + | (flag@"-framework", fmwk) <- + zip ghc_options_no_rtsopts (safeTail ghc_options_no_rtsopts) + ] + , checkAlternatives + fieldName + "extra-framework-dirs" + [ (flag, dir) + | (flag@"-framework-path", dir) <- + zip ghc_options_no_rtsopts (safeTail ghc_options_no_rtsopts) + ] + ] where - all_ghc_options = concatMap getOptions (allBuildInfo pkg) + all_ghc_options = concatMap getOptions (allBuildInfo pkg) ghc_options_no_rtsopts = rmRtsOpts all_ghc_options - lib_ghc_options = concatMap (getOptions . libBuildInfo) - (allLibraries pkg) - test_ghc_options = concatMap (getOptions . testBuildInfo) - (testSuites pkg) - benchmark_ghc_options = concatMap (getOptions . benchmarkBuildInfo) - (benchmarks pkg) - test_and_benchmark_ghc_options = test_ghc_options ++ - benchmark_ghc_options - non_test_and_benchmark_ghc_options = concatMap getOptions - (allBuildInfo (pkg { testSuites = [] - , benchmarks = [] - })) + lib_ghc_options = + concatMap + (getOptions . libBuildInfo) + (allLibraries pkg) + test_ghc_options = + concatMap + (getOptions . testBuildInfo) + (testSuites pkg) + benchmark_ghc_options = + concatMap + (getOptions . benchmarkBuildInfo) + (benchmarks pkg) + test_and_benchmark_ghc_options = + test_ghc_options + ++ benchmark_ghc_options + non_test_and_benchmark_ghc_options = + concatMap + getOptions + ( allBuildInfo + ( pkg + { testSuites = [] + , benchmarks = [] + } + ) + ) checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck checkFlags flags = check (any (`elem` flags) all_ghc_options) @@ -1496,50 +1646,49 @@ checkGhcOptions fieldName getOptions pkg = checkNonTestAndBenchmarkFlags :: [String] -> PackageCheck -> Maybe PackageCheck checkNonTestAndBenchmarkFlags flags = check (any (`elem` flags) non_test_and_benchmark_ghc_options) - ghcExtension ('-':'f':name) = case name of - "allow-overlapping-instances" -> enable OverlappingInstances + ghcExtension ('-' : 'f' : name) = case name of + "allow-overlapping-instances" -> enable OverlappingInstances "no-allow-overlapping-instances" -> disable OverlappingInstances - "th" -> enable TemplateHaskell - "no-th" -> disable TemplateHaskell - "ffi" -> enable ForeignFunctionInterface - "no-ffi" -> disable ForeignFunctionInterface - "fi" -> enable ForeignFunctionInterface - "no-fi" -> disable ForeignFunctionInterface - "monomorphism-restriction" -> enable MonomorphismRestriction - "no-monomorphism-restriction" -> disable MonomorphismRestriction - "mono-pat-binds" -> enable MonoPatBinds - "no-mono-pat-binds" -> disable MonoPatBinds - "allow-undecidable-instances" -> enable UndecidableInstances + "th" -> enable TemplateHaskell + "no-th" -> disable TemplateHaskell + "ffi" -> enable ForeignFunctionInterface + "no-ffi" -> disable ForeignFunctionInterface + "fi" -> enable ForeignFunctionInterface + "no-fi" -> disable ForeignFunctionInterface + "monomorphism-restriction" -> enable MonomorphismRestriction + "no-monomorphism-restriction" -> disable MonomorphismRestriction + "mono-pat-binds" -> enable MonoPatBinds + "no-mono-pat-binds" -> disable MonoPatBinds + "allow-undecidable-instances" -> enable UndecidableInstances "no-allow-undecidable-instances" -> disable UndecidableInstances - "allow-incoherent-instances" -> enable IncoherentInstances - "no-allow-incoherent-instances" -> disable IncoherentInstances - "arrows" -> enable Arrows - "no-arrows" -> disable Arrows - "generics" -> enable Generics - "no-generics" -> disable Generics - "implicit-prelude" -> enable ImplicitPrelude - "no-implicit-prelude" -> disable ImplicitPrelude - "implicit-params" -> enable ImplicitParams - "no-implicit-params" -> disable ImplicitParams - "bang-patterns" -> enable BangPatterns - "no-bang-patterns" -> disable BangPatterns - "scoped-type-variables" -> enable ScopedTypeVariables - "no-scoped-type-variables" -> disable ScopedTypeVariables - "extended-default-rules" -> enable ExtendedDefaultRules - "no-extended-default-rules" -> disable ExtendedDefaultRules - _ -> Nothing - ghcExtension "-cpp" = enable CPP - ghcExtension _ = Nothing - - enable e = Just (EnableExtension e) + "allow-incoherent-instances" -> enable IncoherentInstances + "no-allow-incoherent-instances" -> disable IncoherentInstances + "arrows" -> enable Arrows + "no-arrows" -> disable Arrows + "generics" -> enable Generics + "no-generics" -> disable Generics + "implicit-prelude" -> enable ImplicitPrelude + "no-implicit-prelude" -> disable ImplicitPrelude + "implicit-params" -> enable ImplicitParams + "no-implicit-params" -> disable ImplicitParams + "bang-patterns" -> enable BangPatterns + "no-bang-patterns" -> disable BangPatterns + "scoped-type-variables" -> enable ScopedTypeVariables + "no-scoped-type-variables" -> disable ScopedTypeVariables + "extended-default-rules" -> enable ExtendedDefaultRules + "no-extended-default-rules" -> disable ExtendedDefaultRules + _ -> Nothing + ghcExtension "-cpp" = enable CPP + ghcExtension _ = Nothing + + enable e = Just (EnableExtension e) disable e = Just (DisableExtension e) rmRtsOpts :: [String] -> [String] - rmRtsOpts ("-with-rtsopts":_:xs) = rmRtsOpts xs - rmRtsOpts (x:xs) = x : rmRtsOpts xs + rmRtsOpts ("-with-rtsopts" : _ : xs) = rmRtsOpts xs + rmRtsOpts (x : xs) = x : rmRtsOpts xs rmRtsOpts [] = [] - checkCCOptions :: PackageDescription -> [PackageCheck] checkCCOptions = checkCLikeOptions "C" "cc-options" ccOptions @@ -1548,283 +1697,294 @@ checkCxxOptions = checkCLikeOptions "C++" "cxx-options" cxxOptions checkCLikeOptions :: String -> String -> (BuildInfo -> [String]) -> PackageDescription -> [PackageCheck] checkCLikeOptions label prefix accessor pkg = - catMaybes [ - - checkAlternatives prefix "include-dirs" - [ (flag, dir) | flag@('-':'I':dir) <- all_cLikeOptions ] - - , checkAlternatives prefix "extra-libraries" - [ (flag, lib) | flag@('-':'l':lib) <- all_cLikeOptions ] - - , checkAlternatives prefix "extra-lib-dirs" - [ (flag, dir) | flag@('-':'L':dir) <- all_cLikeOptions ] - - , checkAlternatives "ld-options" "extra-libraries" - [ (flag, lib) | flag@('-':'l':lib) <- all_ldOptions ] - - , checkAlternatives "ld-options" "extra-lib-dirs" - [ (flag, dir) | flag@('-':'L':dir) <- all_ldOptions ] - - , checkCCFlags [ "-O", "-Os", "-O0", "-O1", "-O2", "-O3" ] $ - PackageDistSuspicious (COptONumber prefix label) - ] - - where all_cLikeOptions = [ opts | bi <- allBuildInfo pkg - , opts <- accessor bi ] - all_ldOptions = [ opts | bi <- allBuildInfo pkg - , opts <- ldOptions bi ] + catMaybes + [ checkAlternatives + prefix + "include-dirs" + [(flag, dir) | flag@('-' : 'I' : dir) <- all_cLikeOptions] + , checkAlternatives + prefix + "extra-libraries" + [(flag, lib) | flag@('-' : 'l' : lib) <- all_cLikeOptions] + , checkAlternatives + prefix + "extra-lib-dirs" + [(flag, dir) | flag@('-' : 'L' : dir) <- all_cLikeOptions] + , checkAlternatives + "ld-options" + "extra-libraries" + [(flag, lib) | flag@('-' : 'l' : lib) <- all_ldOptions] + , checkAlternatives + "ld-options" + "extra-lib-dirs" + [(flag, dir) | flag@('-' : 'L' : dir) <- all_ldOptions] + , checkCCFlags ["-O", "-Os", "-O0", "-O1", "-O2", "-O3"] $ + PackageDistSuspicious (COptONumber prefix label) + ] + where + all_cLikeOptions = + [ opts | bi <- allBuildInfo pkg, opts <- accessor bi + ] + all_ldOptions = + [ opts | bi <- allBuildInfo pkg, opts <- ldOptions bi + ] - checkCCFlags :: [String] -> PackageCheck -> Maybe PackageCheck - checkCCFlags flags = check (any (`elem` flags) all_cLikeOptions) + checkCCFlags :: [String] -> PackageCheck -> Maybe PackageCheck + checkCCFlags flags = check (any (`elem` flags) all_cLikeOptions) checkCPPOptions :: PackageDescription -> [PackageCheck] -checkCPPOptions pkg = catMaybes - [ checkAlternatives "cpp-options" "include-dirs" - [ (flag, dir) | flag@('-':'I':dir) <- all_cppOptions ] - ] - ++ - [ PackageBuildWarning (COptCPP opt) - | opt <- all_cppOptions - -- "-I" is handled above, we allow only -DNEWSTUFF and -UOLDSTUFF - , not $ any (`isPrefixOf` opt) ["-D", "-U", "-I" ] +checkCPPOptions pkg = + catMaybes + [ checkAlternatives + "cpp-options" + "include-dirs" + [(flag, dir) | flag@('-' : 'I' : dir) <- all_cppOptions] ] + ++ [ PackageBuildWarning (COptCPP opt) + | opt <- all_cppOptions + , -- "-I" is handled above, we allow only -DNEWSTUFF and -UOLDSTUFF + not $ any (`isPrefixOf` opt) ["-D", "-U", "-I"] + ] where - all_cppOptions = [ opts | bi <- allBuildInfo pkg, opts <- cppOptions bi ] + all_cppOptions = [opts | bi <- allBuildInfo pkg, opts <- cppOptions bi] -checkAlternatives :: String -> String -> [(String, String)] - -> Maybe PackageCheck +checkAlternatives + :: String + -> String + -> [(String, String)] + -> Maybe PackageCheck checkAlternatives badField goodField flags = check (not (null badFlags)) $ PackageBuildWarning (OptAlternatives badField goodField flags) - where (badFlags, _) = unzip flags + where + (badFlags, _) = unzip flags data PathKind - = PathKindFile - | PathKindDirectory - | PathKindGlob + = PathKindFile + | PathKindDirectory + | PathKindGlob deriving (Eq) checkPaths :: PackageDescription -> [PackageCheck] checkPaths pkg = checkPackageFileNamesWithGlob - [ (kind == PathKindGlob, path) - | (path, _, kind) <- relPaths ++ absPaths - ] - ++ - [ PackageBuildWarning (RelativeOutside field path) - | (path, field, _) <- relPaths ++ absPaths - , isOutsideTree path ] - ++ - [ PackageDistInexcusable (AbsolutePath field path) - | (path, field, _) <- relPaths - , isAbsoluteOnAnyPlatform path ] - ++ - [ PackageDistInexcusable (BadRelativePAth field path err) - | (path, field, kind) <- relPaths - -- these are not paths, but globs... - , err <- maybeToList $ case kind of - PathKindFile -> isGoodRelativeFilePath path - PathKindGlob -> isGoodRelativeGlob path - PathKindDirectory -> isGoodRelativeDirectoryPath path - ] - ++ - [ PackageDistInexcusable $ DistPoint (Just field) path - | (path, field, _) <- relPaths ++ absPaths - , isInsideDist path ] - ++ - [ PackageDistInexcusable (DistPoint Nothing path) - | bi <- allBuildInfo pkg - , (GHC, flags) <- perCompilerFlavorToList $ options bi - , path <- flags - , isInsideDist path ] - ++ - [ PackageDistInexcusable $ - GlobSyntaxError "data-files" (explainGlobSyntaxError pat err) - | (Left err, pat) <- zip globsDataFiles $ dataFiles pkg - ] - ++ - [ PackageDistInexcusable - (GlobSyntaxError "extra-source-files" (explainGlobSyntaxError pat err)) - | (Left err, pat) <- zip globsExtraSrcFiles $ extraSrcFiles pkg - ] - ++ - [ PackageDistInexcusable $ - GlobSyntaxError "extra-doc-files" (explainGlobSyntaxError pat err) - | (Left err, pat) <- zip globsExtraDocFiles $ extraDocFiles pkg - ] - ++ - [ PackageDistSuspiciousWarn $ - RecursiveGlobInRoot "data-files" pat - | (Right glob, pat) <- zip globsDataFiles $ dataFiles pkg - , isRecursiveInRoot glob - ] - ++ - [ PackageDistSuspiciousWarn $ - RecursiveGlobInRoot "extra-source-files" pat - | (Right glob, pat) <- zip globsExtraSrcFiles $ extraSrcFiles pkg - , isRecursiveInRoot glob - ] - ++ - [ PackageDistSuspiciousWarn $ - RecursiveGlobInRoot "extra-doc-files" pat - | (Right glob, pat) <- zip globsExtraDocFiles $ extraDocFiles pkg - , isRecursiveInRoot glob - ] + [ (kind == PathKindGlob, path) + | (path, _, kind) <- relPaths ++ absPaths + ] + ++ [ PackageBuildWarning (RelativeOutside field path) + | (path, field, _) <- relPaths ++ absPaths + , isOutsideTree path + ] + ++ [ PackageDistInexcusable (AbsolutePath field path) + | (path, field, _) <- relPaths + , isAbsoluteOnAnyPlatform path + ] + ++ [ PackageDistInexcusable (BadRelativePAth field path err) + | (path, field, kind) <- relPaths + , -- these are not paths, but globs... + err <- maybeToList $ case kind of + PathKindFile -> isGoodRelativeFilePath path + PathKindGlob -> isGoodRelativeGlob path + PathKindDirectory -> isGoodRelativeDirectoryPath path + ] + ++ [ PackageDistInexcusable $ DistPoint (Just field) path + | (path, field, _) <- relPaths ++ absPaths + , isInsideDist path + ] + ++ [ PackageDistInexcusable (DistPoint Nothing path) + | bi <- allBuildInfo pkg + , (GHC, flags) <- perCompilerFlavorToList $ options bi + , path <- flags + , isInsideDist path + ] + ++ [ PackageDistInexcusable $ + GlobSyntaxError "data-files" (explainGlobSyntaxError pat err) + | (Left err, pat) <- zip globsDataFiles $ dataFiles pkg + ] + ++ [ PackageDistInexcusable + (GlobSyntaxError "extra-source-files" (explainGlobSyntaxError pat err)) + | (Left err, pat) <- zip globsExtraSrcFiles $ extraSrcFiles pkg + ] + ++ [ PackageDistInexcusable $ + GlobSyntaxError "extra-doc-files" (explainGlobSyntaxError pat err) + | (Left err, pat) <- zip globsExtraDocFiles $ extraDocFiles pkg + ] + ++ [ PackageDistSuspiciousWarn $ + RecursiveGlobInRoot "data-files" pat + | (Right glob, pat) <- zip globsDataFiles $ dataFiles pkg + , isRecursiveInRoot glob + ] + ++ [ PackageDistSuspiciousWarn $ + RecursiveGlobInRoot "extra-source-files" pat + | (Right glob, pat) <- zip globsExtraSrcFiles $ extraSrcFiles pkg + , isRecursiveInRoot glob + ] + ++ [ PackageDistSuspiciousWarn $ + RecursiveGlobInRoot "extra-doc-files" pat + | (Right glob, pat) <- zip globsExtraDocFiles $ extraDocFiles pkg + , isRecursiveInRoot glob + ] where isOutsideTree path = case splitDirectories path of - "..":_ -> True - ".":"..":_ -> True - _ -> False + ".." : _ -> True + "." : ".." : _ -> True + _ -> False isInsideDist path = case map lowercase (splitDirectories path) of - "dist" :_ -> True - ".":"dist":_ -> True - _ -> False + "dist" : _ -> True + "." : "dist" : _ -> True + _ -> False -- paths that must be relative relPaths :: [(FilePath, String, PathKind)] relPaths = - [ (path, "extra-source-files", PathKindGlob) | path <- extraSrcFiles pkg ] ++ - [ (path, "extra-tmp-files", PathKindFile) | path <- extraTmpFiles pkg ] ++ - [ (path, "extra-doc-files", PathKindGlob) | path <- extraDocFiles pkg ] ++ - [ (path, "data-files", PathKindGlob) | path <- dataFiles pkg ] ++ - [ (path, "data-dir", PathKindDirectory) | path <- [dataDir pkg]] ++ - [ (path, "license-file", PathKindFile) | path <- map getSymbolicPath $ licenseFiles pkg ] ++ - concat - [ [ (path, "asm-sources", PathKindFile) | path <- asmSources bi ] ++ - [ (path, "cmm-sources", PathKindFile) | path <- cmmSources bi ] ++ - [ (path, "c-sources", PathKindFile) | path <- cSources bi ] ++ - [ (path, "cxx-sources", PathKindFile) | path <- cxxSources bi ] ++ - [ (path, "js-sources", PathKindFile) | path <- jsSources bi ] ++ - [ (path, "install-includes", PathKindFile) | path <- installIncludes bi ] ++ - [ (path, "hs-source-dirs", PathKindDirectory) | path <- map getSymbolicPath $ hsSourceDirs bi ] - | bi <- allBuildInfo pkg - ] + [(path, "extra-source-files", PathKindGlob) | path <- extraSrcFiles pkg] + ++ [(path, "extra-tmp-files", PathKindFile) | path <- extraTmpFiles pkg] + ++ [(path, "extra-doc-files", PathKindGlob) | path <- extraDocFiles pkg] + ++ [(path, "data-files", PathKindGlob) | path <- dataFiles pkg] + ++ [(path, "data-dir", PathKindDirectory) | path <- [dataDir pkg]] + ++ [(path, "license-file", PathKindFile) | path <- map getSymbolicPath $ licenseFiles pkg] + ++ concat + [ [(path, "asm-sources", PathKindFile) | path <- asmSources bi] + ++ [(path, "cmm-sources", PathKindFile) | path <- cmmSources bi] + ++ [(path, "c-sources", PathKindFile) | path <- cSources bi] + ++ [(path, "cxx-sources", PathKindFile) | path <- cxxSources bi] + ++ [(path, "js-sources", PathKindFile) | path <- jsSources bi] + ++ [(path, "install-includes", PathKindFile) | path <- installIncludes bi] + ++ [(path, "hs-source-dirs", PathKindDirectory) | path <- map getSymbolicPath $ hsSourceDirs bi] + | bi <- allBuildInfo pkg + ] -- paths that are allowed to be absolute absPaths :: [(FilePath, String, PathKind)] - absPaths = concat - [ [ (path, "includes", PathKindFile) | path <- includes bi ] ++ - [ (path, "include-dirs", PathKindDirectory) | path <- includeDirs bi ] ++ - [ (path, "extra-lib-dirs", PathKindDirectory) | path <- extraLibDirs bi ] ++ - [ (path, "extra-lib-dirs-static", PathKindDirectory) | path <- extraLibDirsStatic bi ] - | bi <- allBuildInfo pkg - ] + absPaths = + concat + [ [(path, "includes", PathKindFile) | path <- includes bi] + ++ [(path, "include-dirs", PathKindDirectory) | path <- includeDirs bi] + ++ [(path, "extra-lib-dirs", PathKindDirectory) | path <- extraLibDirs bi] + ++ [(path, "extra-lib-dirs-static", PathKindDirectory) | path <- extraLibDirsStatic bi] + | bi <- allBuildInfo pkg + ] globsDataFiles :: [Either GlobSyntaxError Glob] - globsDataFiles = parseFileGlob (specVersion pkg) <$> dataFiles pkg + globsDataFiles = parseFileGlob (specVersion pkg) <$> dataFiles pkg globsExtraSrcFiles :: [Either GlobSyntaxError Glob] - globsExtraSrcFiles = parseFileGlob (specVersion pkg) <$> extraSrcFiles pkg + globsExtraSrcFiles = parseFileGlob (specVersion pkg) <$> extraSrcFiles pkg globsExtraDocFiles :: [Either GlobSyntaxError Glob] - globsExtraDocFiles = parseFileGlob (specVersion pkg) <$> extraDocFiles pkg + globsExtraDocFiles = parseFileGlob (specVersion pkg) <$> extraDocFiles pkg ---TODO: check sets of paths that would be interpreted differently between Unix +-- TODO: check sets of paths that would be interpreted differently between Unix -- and windows, ie case-sensitive or insensitive. Things that might clash, or -- conversely be distinguished. ---TODO: use the tar path checks on all the above paths +-- TODO: use the tar path checks on all the above paths -- | Check that the package declares the version in the @\"cabal-version\"@ -- field correctly. --- checkCabalVersion :: PackageDescription -> [PackageCheck] checkCabalVersion pkg = - catMaybes [ - - -- check use of test suite sections - checkVersion CabalSpecV1_8 (not (null $ testSuites pkg)) $ - PackageDistInexcusable CVTestSuite - - -- check use of default-language field - -- note that we do not need to do an equivalent check for the - -- other-language field since that one does not change behaviour - , checkVersion CabalSpecV1_10 (any isJust (buildInfoField defaultLanguage)) $ - PackageBuildWarning CVDefaultLanguage - - , check (specVersion pkg >= CabalSpecV1_10 && specVersion pkg < CabalSpecV3_4 - && any isNothing (buildInfoField defaultLanguage)) $ - PackageBuildWarning CVDefaultLanguageComponent - - , checkVersion CabalSpecV1_18 - (not . null $ extraDocFiles pkg) $ - PackageDistInexcusable CVExtraDocFiles - - , checkVersion CabalSpecV2_0 - (not (null (subLibraries pkg))) $ - PackageDistInexcusable CVMultiLib - - -- check use of reexported-modules sections - , checkVersion CabalSpecV1_22 - (any (not.null.reexportedModules) (allLibraries pkg)) $ - PackageDistInexcusable CVReexported - - -- check use of thinning and renaming - , checkVersion CabalSpecV2_0 usesBackpackIncludes $ - PackageDistInexcusable CVMixins - - -- check use of 'extra-framework-dirs' field - , checkVersion CabalSpecV1_24 (any (not . null) (buildInfoField extraFrameworkDirs)) $ - -- Just a warning, because this won't break on old Cabal versions. - PackageDistSuspiciousWarn CVExtraFrameworkDirs - - -- check use of default-extensions field - -- don't need to do the equivalent check for other-extensions - , checkVersion CabalSpecV1_10 (any (not . null) (buildInfoField defaultExtensions)) $ - PackageBuildWarning CVDefaultExtensions - - -- check use of extensions field - , check (specVersion pkg >= CabalSpecV1_10 - && any (not . null) (buildInfoField oldExtensions)) $ - PackageBuildWarning CVExtensionsDeprecated - - , checkVersion CabalSpecV3_0 (any (not . null) - (concatMap buildInfoField - [ asmSources - , cmmSources - , extraBundledLibs - , extraLibFlavours ])) $ - PackageDistInexcusable CVSources - - , checkVersion CabalSpecV3_0 (any (not . null) $ buildInfoField extraDynLibFlavours) $ - PackageDistInexcusable - (CVExtraDynamic $ buildInfoField extraDynLibFlavours) - - , checkVersion CabalSpecV2_2 (any (not . null) - (buildInfoField virtualModules)) $ - PackageDistInexcusable CVVirtualModules - - -- check use of "source-repository" section - , checkVersion CabalSpecV1_6 (not (null (sourceRepos pkg))) $ - PackageDistInexcusable CVSourceRepository - - -- check for new language extensions - , checkVersion CabalSpecV1_2 (not (null mentionedExtensionsThatNeedCabal12)) $ - PackageDistInexcusable - (CVExtensions CabalSpecV1_2 mentionedExtensionsThatNeedCabal12) - - , checkVersion CabalSpecV1_4 (not (null mentionedExtensionsThatNeedCabal14)) $ - PackageDistInexcusable - (CVExtensions CabalSpecV1_4 mentionedExtensionsThatNeedCabal14) - - , check (specVersion pkg >= CabalSpecV1_24 - && isNothing (setupBuildInfo pkg) - && buildType pkg == Custom) $ - PackageBuildWarning CVCustomSetup - - , check (specVersion pkg < CabalSpecV1_24 - && isNothing (setupBuildInfo pkg) - && buildType pkg == Custom) $ - PackageDistSuspiciousWarn CVExpliticDepsCustomSetup - - , check (specVersion pkg >= CabalSpecV2_0 - && elem (autogenPathsModuleName pkg) allModuleNames - && not (elem (autogenPathsModuleName pkg) allModuleNamesAutogen) ) $ - PackageDistInexcusable CVAutogenPaths - - , check (specVersion pkg >= CabalSpecV2_0 - && elem (autogenPackageInfoModuleName pkg) allModuleNames - && not (elem (autogenPackageInfoModuleName pkg) allModuleNamesAutogen) ) $ - PackageDistInexcusable CVAutogenPackageInfo - - ] + catMaybes + [ -- check use of test suite sections + checkVersion CabalSpecV1_8 (not (null $ testSuites pkg)) $ + PackageDistInexcusable CVTestSuite + , -- check use of default-language field + -- note that we do not need to do an equivalent check for the + -- other-language field since that one does not change behaviour + checkVersion CabalSpecV1_10 (any isJust (buildInfoField defaultLanguage)) $ + PackageBuildWarning CVDefaultLanguage + , check + ( specVersion pkg >= CabalSpecV1_10 + && specVersion pkg < CabalSpecV3_4 + && any isNothing (buildInfoField defaultLanguage) + ) + $ PackageBuildWarning CVDefaultLanguageComponent + , checkVersion + CabalSpecV1_18 + (not . null $ extraDocFiles pkg) + $ PackageDistInexcusable CVExtraDocFiles + , checkVersion + CabalSpecV2_0 + (not (null (subLibraries pkg))) + $ PackageDistInexcusable CVMultiLib + , -- check use of reexported-modules sections + checkVersion + CabalSpecV1_22 + (any (not . null . reexportedModules) (allLibraries pkg)) + $ PackageDistInexcusable CVReexported + , -- check use of thinning and renaming + checkVersion CabalSpecV2_0 usesBackpackIncludes $ + PackageDistInexcusable CVMixins + , -- check use of 'extra-framework-dirs' field + checkVersion CabalSpecV1_24 (any (not . null) (buildInfoField extraFrameworkDirs)) $ + -- Just a warning, because this won't break on old Cabal versions. + PackageDistSuspiciousWarn CVExtraFrameworkDirs + , -- check use of default-extensions field + -- don't need to do the equivalent check for other-extensions + checkVersion CabalSpecV1_10 (any (not . null) (buildInfoField defaultExtensions)) $ + PackageBuildWarning CVDefaultExtensions + , -- check use of extensions field + check + ( specVersion pkg >= CabalSpecV1_10 + && any (not . null) (buildInfoField oldExtensions) + ) + $ PackageBuildWarning CVExtensionsDeprecated + , checkVersion + CabalSpecV3_0 + ( any + (not . null) + ( concatMap + buildInfoField + [ asmSources + , cmmSources + , extraBundledLibs + , extraLibFlavours + ] + ) + ) + $ PackageDistInexcusable CVSources + , checkVersion CabalSpecV3_0 (any (not . null) $ buildInfoField extraDynLibFlavours) $ + PackageDistInexcusable + (CVExtraDynamic $ buildInfoField extraDynLibFlavours) + , checkVersion + CabalSpecV2_2 + ( any + (not . null) + (buildInfoField virtualModules) + ) + $ PackageDistInexcusable CVVirtualModules + , -- check use of "source-repository" section + checkVersion CabalSpecV1_6 (not (null (sourceRepos pkg))) $ + PackageDistInexcusable CVSourceRepository + , -- check for new language extensions + checkVersion CabalSpecV1_2 (not (null mentionedExtensionsThatNeedCabal12)) $ + PackageDistInexcusable + (CVExtensions CabalSpecV1_2 mentionedExtensionsThatNeedCabal12) + , checkVersion CabalSpecV1_4 (not (null mentionedExtensionsThatNeedCabal14)) $ + PackageDistInexcusable + (CVExtensions CabalSpecV1_4 mentionedExtensionsThatNeedCabal14) + , check + ( specVersion pkg >= CabalSpecV1_24 + && isNothing (setupBuildInfo pkg) + && buildType pkg == Custom + ) + $ PackageBuildWarning CVCustomSetup + , check + ( specVersion pkg < CabalSpecV1_24 + && isNothing (setupBuildInfo pkg) + && buildType pkg == Custom + ) + $ PackageDistSuspiciousWarn CVExpliticDepsCustomSetup + , check + ( specVersion pkg >= CabalSpecV2_0 + && elem (autogenPathsModuleName pkg) allModuleNames + && not (elem (autogenPathsModuleName pkg) allModuleNamesAutogen) + ) + $ PackageDistInexcusable CVAutogenPaths + , check + ( specVersion pkg >= CabalSpecV2_0 + && elem (autogenPackageInfoModuleName pkg) allModuleNames + && not (elem (autogenPackageInfoModuleName pkg) allModuleNamesAutogen) + ) + $ PackageDistInexcusable CVAutogenPackageInfo + ] where -- Perform a check on packages that use a version of the spec less than -- the version given. This is for cases where a new Cabal version adds @@ -1833,14 +1993,15 @@ checkCabalVersion pkg = checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck checkVersion ver cond pc | specVersion pkg >= ver = Nothing - | otherwise = check cond pc + | otherwise = check cond pc - buildInfoField field = map field (allBuildInfo pkg) + buildInfoField field = map field (allBuildInfo pkg) usesBackpackIncludes = any (not . null . mixins) (allBuildInfo pkg) - mentionedExtensions = [ ext | bi <- allBuildInfo pkg - , ext <- allExtensions bi ] + mentionedExtensions = + [ ext | bi <- allBuildInfo pkg, ext <- allExtensions bi + ] mentionedExtensionsThatNeedCabal12 = nub (filter (`elem` compatExtensionsExtra) mentionedExtensions) @@ -1851,152 +2012,190 @@ checkCabalVersion pkg = -- The known extensions in Cabal-1.2.3 compatExtensions = - map EnableExtension - [ OverlappingInstances, UndecidableInstances, IncoherentInstances - , RecursiveDo, ParallelListComp, MultiParamTypeClasses - , FunctionalDependencies, Rank2Types - , RankNTypes, PolymorphicComponents, ExistentialQuantification - , ScopedTypeVariables, ImplicitParams, FlexibleContexts - , FlexibleInstances, EmptyDataDecls, CPP, BangPatterns - , TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface - , Arrows, Generics, NamedFieldPuns, PatternGuards - , GeneralizedNewtypeDeriving, ExtensibleRecords, RestrictedTypeSynonyms - , HereDocuments] ++ - map DisableExtension - [MonomorphismRestriction, ImplicitPrelude] ++ - compatExtensionsExtra + map + EnableExtension + [ OverlappingInstances + , UndecidableInstances + , IncoherentInstances + , RecursiveDo + , ParallelListComp + , MultiParamTypeClasses + , FunctionalDependencies + , Rank2Types + , RankNTypes + , PolymorphicComponents + , ExistentialQuantification + , ScopedTypeVariables + , ImplicitParams + , FlexibleContexts + , FlexibleInstances + , EmptyDataDecls + , CPP + , BangPatterns + , TypeSynonymInstances + , TemplateHaskell + , ForeignFunctionInterface + , Arrows + , Generics + , NamedFieldPuns + , PatternGuards + , GeneralizedNewtypeDeriving + , ExtensibleRecords + , RestrictedTypeSynonyms + , HereDocuments + ] + ++ map + DisableExtension + [MonomorphismRestriction, ImplicitPrelude] + ++ compatExtensionsExtra -- The extra known extensions in Cabal-1.2.3 vs Cabal-1.1.6 -- (Cabal-1.1.6 came with ghc-6.6. Cabal-1.2 came with ghc-6.8) compatExtensionsExtra = - map EnableExtension - [ KindSignatures, MagicHash, TypeFamilies, StandaloneDeriving - , UnicodeSyntax, PatternSignatures, UnliftedFFITypes, LiberalTypeSynonyms - , TypeOperators, RecordWildCards, RecordPuns, DisambiguateRecordFields - , OverloadedStrings, GADTs, RelaxedPolyRec - , ExtendedDefaultRules, UnboxedTuples, DeriveDataTypeable - , ConstrainedClassMethods - ] ++ - map DisableExtension - [MonoPatBinds] + map + EnableExtension + [ KindSignatures + , MagicHash + , TypeFamilies + , StandaloneDeriving + , UnicodeSyntax + , PatternSignatures + , UnliftedFFITypes + , LiberalTypeSynonyms + , TypeOperators + , RecordWildCards + , RecordPuns + , DisambiguateRecordFields + , OverloadedStrings + , GADTs + , RelaxedPolyRec + , ExtendedDefaultRules + , UnboxedTuples + , DeriveDataTypeable + , ConstrainedClassMethods + ] + ++ map + DisableExtension + [MonoPatBinds] allModuleNames = - (case library pkg of - Nothing -> [] - (Just lib) -> explicitLibModules lib - ) - ++ concatMap otherModules (allBuildInfo pkg) + ( case library pkg of + Nothing -> [] + (Just lib) -> explicitLibModules lib + ) + ++ concatMap otherModules (allBuildInfo pkg) allModuleNamesAutogen = concatMap autogenModules (allBuildInfo pkg) -- ------------------------------------------------------------ + -- * Checks on the GenericPackageDescription + -- ------------------------------------------------------------ -- | Check the build-depends fields for any weirdness or bad practice. --- checkPackageVersions :: GenericPackageDescription -> [PackageCheck] checkPackageVersions pkg = -- if others is empty, -- the error will still fire but listing no dependencies. -- so we have to check if length others > 0 - then - PackageDistSuspiciousWarn (MissingUpperBounds others) : baseErrors - else - baseErrors + then PackageDistSuspiciousWarn (MissingUpperBounds others) : baseErrors + else baseErrors where baseErrors = PackageDistInexcusable BaseNoUpperBounds <$ bases deps = toDependencyVersionsMap allBuildDepends pkg -- base gets special treatment (it's more critical) - (bases, others) = partition (("base" ==) . unPackageName) $ - [ name - | (name, vr) <- Map.toList deps - , not (hasUpperBound vr) - ] + (bases, others) = + partition (("base" ==) . unPackageName) $ + [ name + | (name, vr) <- Map.toList deps + , not (hasUpperBound vr) + ] checkConditionals :: GenericPackageDescription -> [PackageCheck] checkConditionals pkg = - catMaybes [ - - check (not $ null unknownOSs) $ - PackageDistInexcusable (UnknownOS unknownOSs) - - , check (not $ null unknownArches) $ - PackageDistInexcusable (UnknownArch unknownArches) - - , check (not $ null unknownImpls) $ - PackageDistInexcusable (UnknownCompiler unknownImpls) - ] + catMaybes + [ check (not $ null unknownOSs) $ + PackageDistInexcusable (UnknownOS unknownOSs) + , check (not $ null unknownArches) $ + PackageDistInexcusable (UnknownArch unknownArches) + , check (not $ null unknownImpls) $ + PackageDistInexcusable (UnknownCompiler unknownImpls) + ] where - unknownOSs = [ os | OS (OtherOS os) <- conditions ] - unknownArches = [ arch | Arch (OtherArch arch) <- conditions ] - unknownImpls = [ impl | Impl (OtherCompiler impl) _ <- conditions ] - conditions = concatMap fvs (maybeToList (condLibrary pkg)) - ++ concatMap (fvs . snd) (condSubLibraries pkg) - ++ concatMap (fvs . snd) (condForeignLibs pkg) - ++ concatMap (fvs . snd) (condExecutables pkg) - ++ concatMap (fvs . snd) (condTestSuites pkg) - ++ concatMap (fvs . snd) (condBenchmarks pkg) + unknownOSs = [os | OS (OtherOS os) <- conditions] + unknownArches = [arch | Arch (OtherArch arch) <- conditions] + unknownImpls = [impl | Impl (OtherCompiler impl) _ <- conditions] + conditions = + concatMap fvs (maybeToList (condLibrary pkg)) + ++ concatMap (fvs . snd) (condSubLibraries pkg) + ++ concatMap (fvs . snd) (condForeignLibs pkg) + ++ concatMap (fvs . snd) (condExecutables pkg) + ++ concatMap (fvs . snd) (condTestSuites pkg) + ++ concatMap (fvs . snd) (condBenchmarks pkg) fvs (CondNode _ _ ifs) = concatMap compfv ifs -- free variables compfv (CondBranch c ct mct) = condfv c ++ fvs ct ++ maybe [] fvs mct condfv c = case c of - Var v -> [v] - Lit _ -> [] - CNot c1 -> condfv c1 - COr c1 c2 -> condfv c1 ++ condfv c2 + Var v -> [v] + Lit _ -> [] + CNot c1 -> condfv c1 + COr c1 c2 -> condfv c1 ++ condfv c2 CAnd c1 c2 -> condfv c1 ++ condfv c2 checkFlagNames :: GenericPackageDescription -> [PackageCheck] checkFlagNames gpd - | null invalidFlagNames = [] - | otherwise = - [ PackageDistInexcusable (SuspiciousFlagName invalidFlagNames) ] + | null invalidFlagNames = [] + | otherwise = + [PackageDistInexcusable (SuspiciousFlagName invalidFlagNames)] where invalidFlagNames = - [ fn - | flag <- genPackageFlags gpd - , let fn = unFlagName (flagName flag) - , invalidFlagName fn - ] + [ fn + | flag <- genPackageFlags gpd + , let fn = unFlagName (flagName flag) + , invalidFlagName fn + ] -- starts with dash - invalidFlagName ('-':_) = True + invalidFlagName ('-' : _) = True -- mon ascii letter invalidFlagName cs = any (not . isAscii) cs checkUnusedFlags :: GenericPackageDescription -> [PackageCheck] checkUnusedFlags gpd - | declared == used = [] - | otherwise = - [ PackageDistSuspicious (DeclaredUsedFlags declared used) ] + | declared == used = [] + | otherwise = + [PackageDistSuspicious (DeclaredUsedFlags declared used)] where declared :: Set.Set FlagName declared = toSetOf (L.genPackageFlags . traverse . L.flagName) gpd used :: Set.Set FlagName - used = mconcat - [ toSetOf (L.condLibrary . traverse . traverseCondTreeV . L._PackageFlag) gpd + used = + mconcat + [ toSetOf (L.condLibrary . traverse . traverseCondTreeV . L._PackageFlag) gpd , toSetOf (L.condSubLibraries . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd - , toSetOf (L.condForeignLibs . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd - , toSetOf (L.condExecutables . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd - , toSetOf (L.condTestSuites . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd - , toSetOf (L.condBenchmarks . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condForeignLibs . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condExecutables . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condTestSuites . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condBenchmarks . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd ] checkUnicodeXFields :: GenericPackageDescription -> [PackageCheck] checkUnicodeXFields gpd - | null nonAsciiXFields = [] - | otherwise = - [ PackageDistInexcusable (NonASCIICustomField nonAsciiXFields) ] + | null nonAsciiXFields = [] + | otherwise = + [PackageDistInexcusable (NonASCIICustomField nonAsciiXFields)] where nonAsciiXFields :: [String] - nonAsciiXFields = [ n | (n, _) <- xfields, any (not . isAscii) n ] - - xfields :: [(String,String)] - xfields = DList.runDList $ mconcat - [ toDListOf (L.packageDescription . L.customFieldsPD . traverse) gpd - , toDListOf (L.traverseBuildInfos . L.customFieldsBI . traverse) gpd - ] + nonAsciiXFields = [n | (n, _) <- xfields, any (not . isAscii) n] + + xfields :: [(String, String)] + xfields = + DList.runDList $ + mconcat + [ toDListOf (L.packageDescription . L.customFieldsPD . traverse) gpd + , toDListOf (L.traverseBuildInfos . L.customFieldsBI . traverse) gpd + ] -- | cabal-version <2.2 + Paths_module + default-extensions: doesn't build. checkPathsModuleExtensions :: PackageDescription -> [PackageCheck] @@ -2007,16 +2206,16 @@ checkPackageInfoModuleExtensions :: PackageDescription -> [PackageCheck] checkPackageInfoModuleExtensions = checkAutogenModuleExtensions autogenPackageInfoModuleName RebindableClashPackageInfo -- | cabal-version <2.2 + *_module + default-extensions: doesn't build. -checkAutogenModuleExtensions :: - (PackageDescription -> ModuleName) -> - CheckExplanation -> - PackageDescription -> - [PackageCheck] +checkAutogenModuleExtensions + :: (PackageDescription -> ModuleName) + -> CheckExplanation + -> PackageDescription + -> [PackageCheck] checkAutogenModuleExtensions autogenModuleName rebindableClashExplanation pd - | specVersion pd >= CabalSpecV2_2 = [] - | any checkBI (allBuildInfo pd) || any checkLib (allLibraries pd) - = return (PackageBuildImpossible rebindableClashExplanation) - | otherwise = [] + | specVersion pd >= CabalSpecV2_2 = [] + | any checkBI (allBuildInfo pd) || any checkLib (allLibraries pd) = + return (PackageBuildImpossible rebindableClashExplanation) + | otherwise = [] where mn = autogenModuleName pd @@ -2025,137 +2224,148 @@ checkAutogenModuleExtensions autogenModuleName rebindableClashExplanation pd checkBI :: BuildInfo -> Bool checkBI bi = - (mn `elem` otherModules bi || mn `elem` autogenModules bi) && - checkExts (bi ^. L.defaultExtensions) + (mn `elem` otherModules bi || mn `elem` autogenModules bi) + && checkExts (bi ^. L.defaultExtensions) checkExts exts = rebind `elem` exts && (strings `elem` exts || lists `elem` exts) where - rebind = EnableExtension RebindableSyntax + rebind = EnableExtension RebindableSyntax strings = EnableExtension OverloadedStrings - lists = EnableExtension OverloadedLists + lists = EnableExtension OverloadedLists -- | Checks GHC options from all ghc-*-options fields from the given BuildInfo -- and reports flags that are OK during development process, but are -- unacceptable in a distributed package checkDevelopmentOnlyFlagsBuildInfo :: BuildInfo -> [PackageCheck] checkDevelopmentOnlyFlagsBuildInfo bi = - checkDevelopmentOnlyFlagsOptions "ghc-options" (hcOptions GHC bi) - ++ checkDevelopmentOnlyFlagsOptions "ghc-prof-options" (hcProfOptions GHC bi) - ++ checkDevelopmentOnlyFlagsOptions "ghc-shared-options" (hcSharedOptions GHC bi) + checkDevelopmentOnlyFlagsOptions "ghc-options" (hcOptions GHC bi) + ++ checkDevelopmentOnlyFlagsOptions "ghc-prof-options" (hcProfOptions GHC bi) + ++ checkDevelopmentOnlyFlagsOptions "ghc-shared-options" (hcSharedOptions GHC bi) -- | Checks the given list of flags belonging to the given field and reports -- flags that are OK during development process, but are unacceptable in a -- distributed package checkDevelopmentOnlyFlagsOptions :: String -> [String] -> [PackageCheck] checkDevelopmentOnlyFlagsOptions fieldName ghcOptions = - catMaybes [ - - check has_Werror $ - PackageDistInexcusable (WErrorUnneeded fieldName) - - , check has_J $ - PackageDistInexcusable (JUnneeded fieldName) - - , checkFlags ["-fdefer-type-errors"] $ - PackageDistInexcusable (FDeferTypeErrorsUnneeded fieldName) - - -- -dynamic is not a debug flag - , check (any (\opt -> "-d" `isPrefixOf` opt && opt /= "-dynamic") - ghcOptions) $ - PackageDistInexcusable (DynamicUnneeded fieldName) - - , checkFlags ["-fprof-auto", "-fprof-auto-top", "-fprof-auto-calls", - "-fprof-cafs", "-fno-prof-count-entries", - "-auto-all", "-auto", "-caf-all"] $ - PackageDistSuspicious (ProfilingUnneeded fieldName) - ] + catMaybes + [ check has_Werror $ + PackageDistInexcusable (WErrorUnneeded fieldName) + , check has_J $ + PackageDistInexcusable (JUnneeded fieldName) + , checkFlags ["-fdefer-type-errors"] $ + PackageDistInexcusable (FDeferTypeErrorsUnneeded fieldName) + , -- -dynamic is not a debug flag + check + ( any + (\opt -> "-d" `isPrefixOf` opt && opt /= "-dynamic") + ghcOptions + ) + $ PackageDistInexcusable (DynamicUnneeded fieldName) + , checkFlags + [ "-fprof-auto" + , "-fprof-auto-top" + , "-fprof-auto-calls" + , "-fprof-cafs" + , "-fno-prof-count-entries" + , "-auto-all" + , "-auto" + , "-caf-all" + ] + $ PackageDistSuspicious (ProfilingUnneeded fieldName) + ] where - - has_Werror = "-Werror" `elem` ghcOptions - has_J = any - (\o -> case o of - "-j" -> True - ('-' : 'j' : d : _) -> isDigit d - _ -> False - ) - ghcOptions + has_Werror = "-Werror" `elem` ghcOptions + has_J = + any + ( \o -> case o of + "-j" -> True + ('-' : 'j' : d : _) -> isDigit d + _ -> False + ) + ghcOptions checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck checkFlags flags = check (any (`elem` flags) ghcOptions) checkDevelopmentOnlyFlags :: GenericPackageDescription -> [PackageCheck] checkDevelopmentOnlyFlags pkg = - concatMap checkDevelopmentOnlyFlagsBuildInfo - [ bi - | (conditions, bi) <- allConditionalBuildInfo - , not (any guardedByManualFlag conditions) ] + concatMap + checkDevelopmentOnlyFlagsBuildInfo + [ bi + | (conditions, bi) <- allConditionalBuildInfo + , not (any guardedByManualFlag conditions) + ] where guardedByManualFlag = definitelyFalse -- We've basically got three-values logic here: True, False or unknown -- hence this pattern to propagate the unknown cases properly. definitelyFalse (Var (PackageFlag n)) = maybe False not (Map.lookup n manualFlags) - definitelyFalse (Var _) = False - definitelyFalse (Lit b) = not b - definitelyFalse (CNot c) = definitelyTrue c - definitelyFalse (COr c1 c2) = definitelyFalse c1 && definitelyFalse c2 - definitelyFalse (CAnd c1 c2) = definitelyFalse c1 || definitelyFalse c2 + definitelyFalse (Var _) = False + definitelyFalse (Lit b) = not b + definitelyFalse (CNot c) = definitelyTrue c + definitelyFalse (COr c1 c2) = definitelyFalse c1 && definitelyFalse c2 + definitelyFalse (CAnd c1 c2) = definitelyFalse c1 || definitelyFalse c2 definitelyTrue (Var (PackageFlag n)) = fromMaybe False (Map.lookup n manualFlags) - definitelyTrue (Var _) = False - definitelyTrue (Lit b) = b - definitelyTrue (CNot c) = definitelyFalse c - definitelyTrue (COr c1 c2) = definitelyTrue c1 || definitelyTrue c2 - definitelyTrue (CAnd c1 c2) = definitelyTrue c1 && definitelyTrue c2 - - manualFlags = Map.fromList - [ (flagName flag, flagDefault flag) - | flag <- genPackageFlags pkg - , flagManual flag ] + definitelyTrue (Var _) = False + definitelyTrue (Lit b) = b + definitelyTrue (CNot c) = definitelyFalse c + definitelyTrue (COr c1 c2) = definitelyTrue c1 || definitelyTrue c2 + definitelyTrue (CAnd c1 c2) = definitelyTrue c1 && definitelyTrue c2 + + manualFlags = + Map.fromList + [ (flagName flag, flagDefault flag) + | flag <- genPackageFlags pkg + , flagManual flag + ] allConditionalBuildInfo :: [([Condition ConfVar], BuildInfo)] allConditionalBuildInfo = - concatMap (collectCondTreePaths libBuildInfo) - (maybeToList (condLibrary pkg)) - - ++ concatMap (collectCondTreePaths libBuildInfo . snd) - (condSubLibraries pkg) - - ++ concatMap (collectCondTreePaths buildInfo . snd) - (condExecutables pkg) - - ++ concatMap (collectCondTreePaths testBuildInfo . snd) - (condTestSuites pkg) - - ++ concatMap (collectCondTreePaths benchmarkBuildInfo . snd) - (condBenchmarks pkg) + concatMap + (collectCondTreePaths libBuildInfo) + (maybeToList (condLibrary pkg)) + ++ concatMap + (collectCondTreePaths libBuildInfo . snd) + (condSubLibraries pkg) + ++ concatMap + (collectCondTreePaths buildInfo . snd) + (condExecutables pkg) + ++ concatMap + (collectCondTreePaths testBuildInfo . snd) + (condTestSuites pkg) + ++ concatMap + (collectCondTreePaths benchmarkBuildInfo . snd) + (condBenchmarks pkg) -- get all the leaf BuildInfo, paired up with the path (in the tree sense) -- of if-conditions that guard it - collectCondTreePaths :: (a -> b) - -> CondTree v c a - -> [([Condition v], b)] + collectCondTreePaths + :: (a -> b) + -> CondTree v c a + -> [([Condition v], b)] collectCondTreePaths mapData = go [] where go conditions condNode = - -- the data at this level in the tree: - (reverse conditions, mapData (condTreeData condNode)) - - : concat - [ go (condition:conditions) ifThen - | (CondBranch condition ifThen _) <- condTreeComponents condNode ] - - ++ concat - [ go (condition:conditions) elseThen - | (CondBranch condition _ (Just elseThen)) <- condTreeComponents condNode ] - + -- the data at this level in the tree: + (reverse conditions, mapData (condTreeData condNode)) + : concat + [ go (condition : conditions) ifThen + | (CondBranch condition ifThen _) <- condTreeComponents condNode + ] + ++ concat + [ go (condition : conditions) elseThen + | (CondBranch condition _ (Just elseThen)) <- condTreeComponents condNode + ] -- ------------------------------------------------------------ + -- * Checks involving files in the package + -- ------------------------------------------------------------ -- | Sanity check things that requires IO. It looks at the files in the -- package and expects to find the package unpacked in at the given file path. --- checkPackageFiles :: Verbosity -> PackageDescription -> FilePath -> IO [PackageCheck] checkPackageFiles verbosity pkg root = do contentChecks <- checkPackageContent checkFilesIO pkg @@ -2165,22 +2375,22 @@ checkPackageFiles verbosity pkg root = do -- stable for test output. return (sort contentChecks ++ sort preDistributionChecks) where - checkFilesIO = CheckPackageContentOps { - doesFileExist = System.doesFileExist . relative, - doesDirectoryExist = System.doesDirectoryExist . relative, - getDirectoryContents = System.Directory.getDirectoryContents . relative, - getFileContents = BS.readFile . relative - } + checkFilesIO = + CheckPackageContentOps + { doesFileExist = System.doesFileExist . relative + , doesDirectoryExist = System.doesDirectoryExist . relative + , getDirectoryContents = System.Directory.getDirectoryContents . relative + , getFileContents = BS.readFile . relative + } relative path = root path -- | A record of operations needed to check the contents of packages. -- Used by 'checkPackageContent'. --- -data CheckPackageContentOps m = CheckPackageContentOps { - doesFileExist :: FilePath -> m Bool, - doesDirectoryExist :: FilePath -> m Bool, - getDirectoryContents :: FilePath -> m [FilePath], - getFileContents :: FilePath -> m BS.ByteString +data CheckPackageContentOps m = CheckPackageContentOps + { doesFileExist :: FilePath -> m Bool + , doesDirectoryExist :: FilePath -> m Bool + , getDirectoryContents :: FilePath -> m [FilePath] + , getFileContents :: FilePath -> m BS.ByteString } -- | Sanity check things that requires looking at files in the package. @@ -2189,27 +2399,30 @@ data CheckPackageContentOps m = CheckPackageContentOps { -- -- The point of this extra generality is to allow doing checks in some virtual -- file system, for example a tarball in memory. --- -checkPackageContent :: (Monad m, Applicative m) - => CheckPackageContentOps m - -> PackageDescription - -> m [PackageCheck] +checkPackageContent + :: (Monad m, Applicative m) + => CheckPackageContentOps m + -> PackageDescription + -> m [PackageCheck] checkPackageContent ops pkg = do - cabalBomError <- checkCabalFileBOM ops - cabalNameError <- checkCabalFileName ops pkg - licenseErrors <- checkLicensesExist ops pkg - setupError <- checkSetupExists ops pkg - configureError <- checkConfigureExists ops pkg + cabalBomError <- checkCabalFileBOM ops + cabalNameError <- checkCabalFileName ops pkg + licenseErrors <- checkLicensesExist ops pkg + setupError <- checkSetupExists ops pkg + configureError <- checkConfigureExists ops pkg localPathErrors <- checkLocalPathsExist ops pkg - vcsLocation <- checkMissingVcsInfo ops pkg - - return $ licenseErrors - ++ catMaybes [cabalBomError, cabalNameError, setupError, configureError] - ++ localPathErrors - ++ vcsLocation - -checkCabalFileBOM :: Monad m => CheckPackageContentOps m - -> m (Maybe PackageCheck) + vcsLocation <- checkMissingVcsInfo ops pkg + + return $ + licenseErrors + ++ catMaybes [cabalBomError, cabalNameError, setupError, configureError] + ++ localPathErrors + ++ vcsLocation + +checkCabalFileBOM + :: Monad m + => CheckPackageContentOps m + -> m (Maybe PackageCheck) checkCabalFileBOM ops = do epdfile <- findPackageDesc ops case epdfile of @@ -2219,18 +2432,21 @@ checkCabalFileBOM ops = do -- But this can be an issue, see #3552 and also when -- --cabal-file is specified. So if you can't find the file, -- just don't bother with this check. - Left _ -> return Nothing - Right pdfile -> (flip check pc . BS.isPrefixOf bomUtf8) - `liftM` getFileContents ops pdfile - where pc = PackageDistInexcusable (BOMStart pdfile) - + Left _ -> return Nothing + Right pdfile -> + (flip check pc . BS.isPrefixOf bomUtf8) + `liftM` getFileContents ops pdfile + where + pc = PackageDistInexcusable (BOMStart pdfile) where bomUtf8 :: BS.ByteString - bomUtf8 = BS.pack [0xef,0xbb,0xbf] -- U+FEFF encoded as UTF8 + bomUtf8 = BS.pack [0xef, 0xbb, 0xbf] -- U+FEFF encoded as UTF8 -checkCabalFileName :: Monad m => CheckPackageContentOps m - -> PackageDescription - -> m (Maybe PackageCheck) +checkCabalFileName + :: Monad m + => CheckPackageContentOps m + -> PackageDescription + -> m (Maybe PackageCheck) checkCabalFileName ops pkg = do -- findPackageDesc already takes care to detect missing/multiple -- .cabal files; we don't include this check in 'findPackageDesc' in @@ -2238,121 +2454,152 @@ checkCabalFileName ops pkg = do epdfile <- findPackageDesc ops case epdfile of -- see "MASSIVE HACK" note in 'checkCabalFileBOM' - Left _ -> return Nothing + Left _ -> return Nothing Right pdfile | takeFileName pdfile == expectedCabalname -> return Nothing - | otherwise -> return $ Just $ PackageDistInexcusable - (NotPackageName pdfile expectedCabalname) + | otherwise -> + return $ + Just $ + PackageDistInexcusable + (NotPackageName pdfile expectedCabalname) where pkgname = unPackageName . packageName $ pkg expectedCabalname = pkgname <.> "cabal" +-- | Find a package description file in the given directory. Looks for +-- @.cabal@ files. Like 'Distribution.Simple.Utils.findPackageDesc', +-- but generalized over monads. +findPackageDesc + :: Monad m + => CheckPackageContentOps m + -> m (Either PackageCheck FilePath) + -- ^ .cabal +findPackageDesc ops = + do + let dir = "." + files <- getDirectoryContents ops dir + -- to make sure we do not mistake a ~/.cabal/ dir for a .cabal + -- file we filter to exclude dirs and null base file names: + cabalFiles <- + filterM + (doesFileExist ops) + [ dir file + | file <- files + , let (name, ext) = splitExtension file + , not (null name) && ext == ".cabal" + ] + case cabalFiles of + [] -> return (Left $ PackageBuildImpossible NoDesc) + [cabalFile] -> return (Right cabalFile) + multiple -> + return + ( Left $ + PackageBuildImpossible + (MultiDesc multiple) + ) --- |Find a package description file in the given directory. Looks for --- @.cabal@ files. Like 'Distribution.Simple.Utils.findPackageDesc', --- but generalized over monads. -findPackageDesc :: Monad m => CheckPackageContentOps m - -> m (Either PackageCheck FilePath) -- ^.cabal -findPackageDesc ops - = do let dir = "." - files <- getDirectoryContents ops dir - -- to make sure we do not mistake a ~/.cabal/ dir for a .cabal - -- file we filter to exclude dirs and null base file names: - cabalFiles <- filterM (doesFileExist ops) - [ dir file - | file <- files - , let (name, ext) = splitExtension file - , not (null name) && ext == ".cabal" ] - case cabalFiles of - [] -> return (Left $ PackageBuildImpossible NoDesc) - [cabalFile] -> return (Right cabalFile) - multiple -> return (Left $ PackageBuildImpossible - (MultiDesc multiple)) - -checkLicensesExist :: (Monad m, Applicative m) - => CheckPackageContentOps m - -> PackageDescription - -> m [PackageCheck] +checkLicensesExist + :: (Monad m, Applicative m) + => CheckPackageContentOps m + -> PackageDescription + -> m [PackageCheck] checkLicensesExist ops pkg = do - exists <- traverse (doesFileExist ops . getSymbolicPath) (licenseFiles pkg) - return - [ PackageBuildWarning (UnknownFile fieldname file) - | (file, False) <- zip (licenseFiles pkg) exists ] + exists <- traverse (doesFileExist ops . getSymbolicPath) (licenseFiles pkg) + return + [ PackageBuildWarning (UnknownFile fieldname file) + | (file, False) <- zip (licenseFiles pkg) exists + ] where - fieldname | length (licenseFiles pkg) == 1 = "license-file" - | otherwise = "license-files" - -checkSetupExists :: Monad m => CheckPackageContentOps m - -> PackageDescription - -> m (Maybe PackageCheck) + fieldname + | length (licenseFiles pkg) == 1 = "license-file" + | otherwise = "license-files" + +checkSetupExists + :: Monad m + => CheckPackageContentOps m + -> PackageDescription + -> m (Maybe PackageCheck) checkSetupExists ops pkg = do let simpleBuild = buildType pkg == Simple - hsexists <- doesFileExist ops "Setup.hs" + hsexists <- doesFileExist ops "Setup.hs" lhsexists <- doesFileExist ops "Setup.lhs" - return $ check (not simpleBuild && not hsexists && not lhsexists) $ - PackageDistInexcusable MissingSetupFile - -checkConfigureExists :: Monad m => CheckPackageContentOps m - -> PackageDescription - -> m (Maybe PackageCheck) + return $ + check (not simpleBuild && not hsexists && not lhsexists) $ + PackageDistInexcusable MissingSetupFile + +checkConfigureExists + :: Monad m + => CheckPackageContentOps m + -> PackageDescription + -> m (Maybe PackageCheck) checkConfigureExists ops pd | buildType pd == Configure = do exists <- doesFileExist ops "configure" - return $ check (not exists) $ - PackageBuildWarning MissingConfigureScript + return $ + check (not exists) $ + PackageBuildWarning MissingConfigureScript | otherwise = return Nothing -checkLocalPathsExist :: Monad m => CheckPackageContentOps m - -> PackageDescription - -> m [PackageCheck] +checkLocalPathsExist + :: Monad m + => CheckPackageContentOps m + -> PackageDescription + -> m [PackageCheck] checkLocalPathsExist ops pkg = do - let dirs = [ (dir, kind) - | bi <- allBuildInfo pkg - , (dir, kind) <- - [ (dir, "extra-lib-dirs") | dir <- extraLibDirs bi ] - ++ [ (dir, "extra-lib-dirs-static") | dir <- extraLibDirsStatic bi ] - ++ [ (dir, "extra-framework-dirs") - | dir <- extraFrameworkDirs bi ] - ++ [ (dir, "include-dirs") | dir <- includeDirs bi ] - ++ [ (getSymbolicPath dir, "hs-source-dirs") | dir <- hsSourceDirs bi ] - , isRelativeOnAnyPlatform dir ] + let dirs = + [ (dir, kind) + | bi <- allBuildInfo pkg + , (dir, kind) <- + [(dir, "extra-lib-dirs") | dir <- extraLibDirs bi] + ++ [(dir, "extra-lib-dirs-static") | dir <- extraLibDirsStatic bi] + ++ [ (dir, "extra-framework-dirs") + | dir <- extraFrameworkDirs bi + ] + ++ [(dir, "include-dirs") | dir <- includeDirs bi] + ++ [(getSymbolicPath dir, "hs-source-dirs") | dir <- hsSourceDirs bi] + , isRelativeOnAnyPlatform dir + ] missing <- filterM (liftM not . doesDirectoryExist ops . fst) dirs - return [ PackageBuildWarning (UnknownDirectory kind dir) - | (dir, kind) <- missing ] + return + [ PackageBuildWarning (UnknownDirectory kind dir) + | (dir, kind) <- missing + ] -checkMissingVcsInfo :: (Monad m, Applicative m) - => CheckPackageContentOps m - -> PackageDescription - -> m [PackageCheck] +checkMissingVcsInfo + :: (Monad m, Applicative m) + => CheckPackageContentOps m + -> PackageDescription + -> m [PackageCheck] checkMissingVcsInfo ops pkg | null (sourceRepos pkg) = do - vcsInUse <- liftM or $ traverse (doesDirectoryExist ops) repoDirnames - if vcsInUse - then return [ PackageDistSuspicious MissingSourceControl ] - else return [] + vcsInUse <- liftM or $ traverse (doesDirectoryExist ops) repoDirnames + if vcsInUse + then return [PackageDistSuspicious MissingSourceControl] + else return [] where - repoDirnames = [ dirname | repo <- knownRepoTypes - , dirname <- repoTypeDirname repo] - + repoDirnames = + [ dirname | repo <- knownRepoTypes, dirname <- repoTypeDirname repo + ] checkMissingVcsInfo _ _ = return [] repoTypeDirname :: KnownRepoType -> [FilePath] -repoTypeDirname Darcs = ["_darcs"] -repoTypeDirname Git = [".git"] -repoTypeDirname SVN = [".svn"] -repoTypeDirname CVS = ["CVS"] +repoTypeDirname Darcs = ["_darcs"] +repoTypeDirname Git = [".git"] +repoTypeDirname SVN = [".svn"] +repoTypeDirname CVS = ["CVS"] repoTypeDirname Mercurial = [".hg"] -repoTypeDirname GnuArch = [".arch-params"] -repoTypeDirname Bazaar = [".bzr"] -repoTypeDirname Monotone = ["_MTN"] -repoTypeDirname Pijul = [".pijul"] +repoTypeDirname GnuArch = [".arch-params"] +repoTypeDirname Bazaar = [".bzr"] +repoTypeDirname Monotone = ["_MTN"] +repoTypeDirname Pijul = [".pijul"] -- ------------------------------------------------------------ + -- * Checks involving files in the package + -- ------------------------------------------------------------ -- | Check the names of all files in a package for portability problems. This -- should be done for example when creating or validating a package tarball. --- checkPackageFileNames :: [FilePath] -> [PackageCheck] checkPackageFileNames = checkPackageFileNamesWithGlob . zip (repeat True) @@ -2360,24 +2607,26 @@ checkPackageFileNamesWithGlob :: [(Bool, FilePath)] -> [PackageCheck] checkPackageFileNamesWithGlob files = catMaybes $ checkWindowsPaths files - : - [ checkTarPath file - | (_, file) <- files - ] + : [ checkTarPath file + | (_, file) <- files + ] checkWindowsPaths :: [(Bool, FilePath)] -> Maybe PackageCheck checkWindowsPaths paths = - case filter (not . FilePath.Windows.isValid . escape) paths of - [] -> Nothing - ps -> Just $ + case filter (not . FilePath.Windows.isValid . escape) paths of + [] -> Nothing + ps -> + Just $ PackageDistInexcusable (InvalidOnWin $ map snd ps) where -- force a relative name to catch invalid file names like "f:oo" which -- otherwise parse as file "oo" in the current directory on the 'f' drive. - escape (isGlob, path) = (".\\" ++) - -- glob paths will be expanded before being dereferenced, so asterisks - -- shouldn't count against them. - $ map (\c -> if c == '*' && isGlob then 'x' else c) path + escape (isGlob, path) = + (".\\" ++) + -- glob paths will be expanded before being dereferenced, so asterisks + -- shouldn't count against them. + $ + map (\c -> if c == '*' && isGlob then 'x' else c) path -- | Check a file name is valid for the portable POSIX tar format. -- @@ -2386,36 +2635,36 @@ checkWindowsPaths paths = -- restriction is that either the whole path be 100 characters or less, or it -- be possible to split the path on a directory separator such that the first -- part is 155 characters or less and the second part 100 characters or less. --- checkTarPath :: FilePath -> Maybe PackageCheck checkTarPath path - | length path > 255 = Just longPath + | length path > 255 = Just longPath | otherwise = case pack nameMax (reverse (splitPath path)) of - Left err -> Just err - Right [] -> Nothing - Right (h:rest) -> case pack prefixMax remainder of - Left err -> Just err - Right [] -> Nothing - Right (_:_) -> Just noSplit - where - -- drop the '/' between the name and prefix: - remainder = safeInit h : rest - + Left err -> Just err + Right [] -> Nothing + Right (h : rest) -> case pack prefixMax remainder of + Left err -> Just err + Right [] -> Nothing + Right (_ : _) -> Just noSplit + where + -- drop the '/' between the name and prefix: + remainder = safeInit h : rest where nameMax, prefixMax :: Int - nameMax = 100 + nameMax = 100 prefixMax = 155 - pack _ [] = Left emptyName - pack maxLen (c:cs) - | n > maxLen = Left longName - | otherwise = Right (pack' maxLen n cs) - where n = length c + pack _ [] = Left emptyName + pack maxLen (c : cs) + | n > maxLen = Left longName + | otherwise = Right (pack' maxLen n cs) + where + n = length c - pack' maxLen n (c:cs) + pack' maxLen n (c : cs) | n' <= maxLen = pack' maxLen n' cs - where n' = n + length c - pack' _ _ cs = cs + where + n' = n + length c + pack' _ _ cs = cs longPath = PackageDistInexcusable (FilePathTooLong path) longName = PackageDistInexcusable (FilePathNameTooLong path) @@ -2423,7 +2672,9 @@ checkTarPath path emptyName = PackageDistInexcusable FilePathEmpty -- -------------------------------------------------------------- + -- * Checks for missing content and other pre-distribution checks + -- -------------------------------------------------------------- -- | Similar to 'checkPackageContent', 'checkPackageFilesPreDistribution' @@ -2442,49 +2693,56 @@ checkPackageFilesPreDistribution :: Verbosity -> PackageDescription -> FilePath checkPackageFilesPreDistribution = checkGlobFiles -- | Discover problems with the package's wildcards. -checkGlobFiles :: Verbosity - -> PackageDescription - -> FilePath - -> IO [PackageCheck] +checkGlobFiles + :: Verbosity + -> PackageDescription + -> FilePath + -> IO [PackageCheck] checkGlobFiles verbosity pkg root = do -- Get the desirable doc files from package’s directory rootContents <- System.Directory.getDirectoryContents root - docFiles0 <- filterM System.doesFileExist - [ file - | file <- rootContents - , isDesirableExtraDocFile desirableDocFiles file - ] + docFiles0 <- + filterM + System.doesFileExist + [ file + | file <- rootContents + , isDesirableExtraDocFile desirableDocFiles file + ] -- Check the globs (warnings, unlisted) <- foldrM checkGlob ([], docFiles0) allGlobs - return $ if null unlisted - -- No missing desirable file - then warnings - -- Some missing desirable files - else warnings ++ - let unlisted' = (root ) <$> unlisted - in [ PackageDistSuspiciousWarn - (MissingExpectedDocFiles extraDocFilesSupport unlisted') - ] + return $ + if null unlisted + then -- No missing desirable file + warnings + else -- Some missing desirable files + + warnings + ++ let unlisted' = (root ) <$> unlisted + in [ PackageDistSuspiciousWarn + (MissingExpectedDocFiles extraDocFilesSupport unlisted') + ] where -- `extra-doc-files` is supported only from version 1.18 extraDocFilesSupport = specVersion pkg >= CabalSpecV1_18 adjustedDataDir = if null (dataDir pkg) then root else root dataDir pkg -- Cabal fields with globs allGlobs :: [(String, Bool, FilePath, FilePath)] - allGlobs = concat - [ (,,,) "extra-source-files" (not extraDocFilesSupport) root <$> - extraSrcFiles pkg - , (,,,) "extra-doc-files" True root <$> extraDocFiles pkg - , (,,,) "data-files" False adjustedDataDir <$> dataFiles pkg - ] + allGlobs = + concat + [ (,,,) "extra-source-files" (not extraDocFilesSupport) root + <$> extraSrcFiles pkg + , (,,,) "extra-doc-files" True root <$> extraDocFiles pkg + , (,,,) "data-files" False adjustedDataDir <$> dataFiles pkg + ] -- For each field with globs (see allGlobs), look for: -- • errors (missing directory, no match) -- • omitted documentation files (changelog) - checkGlob :: (String, Bool, FilePath, FilePath) - -> ([PackageCheck], [FilePath]) - -> IO ([PackageCheck], [FilePath]) + checkGlob + :: (String, Bool, FilePath, FilePath) + -> ([PackageCheck], [FilePath]) + -> IO ([PackageCheck], [FilePath]) checkGlob (field, isDocField, dir, glob) acc@(warnings, docFiles1) = -- Note: we just skip over parse errors here; they're reported elsewhere. case parseFileGlob (specVersion pkg) glob of @@ -2494,64 +2752,72 @@ checkGlobFiles verbosity pkg root = do let acc0 = (warnings, True, docFiles1, []) return $ case foldr checkGlobResult acc0 results of (individualWarn, noMatchesWarn, docFiles1', wrongPaths) -> - let wrongFieldWarnings = [ PackageDistSuspiciousWarn - (WrongFieldForExpectedDocFiles - extraDocFilesSupport - field wrongPaths) - | not (null wrongPaths) ] - in - ( if noMatchesWarn - then [PackageDistSuspiciousWarn (GlobNoMatch field glob)] ++ - individualWarn ++ - wrongFieldWarnings - else individualWarn ++ wrongFieldWarnings - , docFiles1' - ) + let wrongFieldWarnings = + [ PackageDistSuspiciousWarn + ( WrongFieldForExpectedDocFiles + extraDocFilesSupport + field + wrongPaths + ) + | not (null wrongPaths) + ] + in ( if noMatchesWarn + then + [PackageDistSuspiciousWarn (GlobNoMatch field glob)] + ++ individualWarn + ++ wrongFieldWarnings + else individualWarn ++ wrongFieldWarnings + , docFiles1' + ) where - checkGlobResult :: GlobResult FilePath - -> ([PackageCheck], Bool, [FilePath], [FilePath]) - -> ([PackageCheck], Bool, [FilePath], [FilePath]) + checkGlobResult + :: GlobResult FilePath + -> ([PackageCheck], Bool, [FilePath], [FilePath]) + -> ([PackageCheck], Bool, [FilePath], [FilePath]) checkGlobResult result (ws, noMatchesWarn, docFiles2, wrongPaths) = - let noMatchesWarn' = noMatchesWarn && - not (suppressesNoMatchesWarning result) - in case getWarning field glob result of - -- No match: add warning and do no further check - Left w -> - ( w : ws - , noMatchesWarn' - , docFiles2 - , wrongPaths - ) - -- Match: check doc files - Right path -> - let path' = makeRelative root (normalise path) - (docFiles2', wrongPaths') = checkDoc isDocField - path' - docFiles2 - wrongPaths - in - ( ws - , noMatchesWarn' - , docFiles2' - , wrongPaths' - ) + let noMatchesWarn' = + noMatchesWarn + && not (suppressesNoMatchesWarning result) + in case getWarning field glob result of + -- No match: add warning and do no further check + Left w -> + ( w : ws + , noMatchesWarn' + , docFiles2 + , wrongPaths + ) + -- Match: check doc files + Right path -> + let path' = makeRelative root (normalise path) + (docFiles2', wrongPaths') = + checkDoc + isDocField + path' + docFiles2 + wrongPaths + in ( ws + , noMatchesWarn' + , docFiles2' + , wrongPaths' + ) -- Check whether a path is a desirable doc: if so, check if it is in the -- field "extra-doc-files". - checkDoc :: Bool -- Is it "extra-doc-files" ? - -> FilePath -- Path to test - -> [FilePath] -- Pending doc files to check - -> [FilePath] -- Previous wrong paths - -> ([FilePath], [FilePath]) -- Updated paths + checkDoc + :: Bool -- Is it "extra-doc-files" ? + -> FilePath -- Path to test + -> [FilePath] -- Pending doc files to check + -> [FilePath] -- Previous wrong paths + -> ([FilePath], [FilePath]) -- Updated paths checkDoc isDocField path docFiles wrongFieldPaths = if path `elem` docFiles - -- Found desirable doc file - then + then -- Found desirable doc file + ( delete path docFiles , if isDocField then wrongFieldPaths else path : wrongFieldPaths ) - -- Not a desirable doc file - else + else -- Not a desirable doc file + ( docFiles , wrongFieldPaths ) @@ -2591,10 +2857,11 @@ checkGlobFiles verbosity pkg root = do suppressesNoMatchesWarning (GlobWarnMultiDot _) = False suppressesNoMatchesWarning (GlobMissingDirectory _) = True - getWarning :: String - -> FilePath - -> GlobResult FilePath - -> Either PackageCheck FilePath + getWarning + :: String + -> FilePath + -> GlobResult FilePath + -> Either PackageCheck FilePath getWarning _ _ (GlobMatch path) = Right path -- Before Cabal 2.4, the extensions of globs had to match the file @@ -2610,12 +2877,12 @@ checkGlobFiles verbosity pkg root = do -- In particular, @base@ and @Cabal@ upper bounds are mandatory. checkSetupVersions :: GenericPackageDescription -> [PackageCheck] checkSetupVersions pkg = - [ emitError nameStr - | (name, vr) <- Map.toList deps - , not (hasUpperBound vr) - , let nameStr = unPackageName name - , nameStr `elem` criticalPkgs - ] + [ emitError nameStr + | (name, vr) <- Map.toList deps + , not (hasUpperBound vr) + , let nameStr = unPackageName name + , nameStr `elem` criticalPkgs + ] where criticalPkgs = ["Cabal", "base"] deps = toDependencyVersionsMap (foldMap setupDepends . setupBuildInfo) pkg @@ -2624,56 +2891,64 @@ checkSetupVersions pkg = checkDuplicateModules :: GenericPackageDescription -> [PackageCheck] checkDuplicateModules pkg = - concatMap checkLib (maybe id (:) (condLibrary pkg) . map snd $ condSubLibraries pkg) - ++ concatMap checkExe (map snd $ condExecutables pkg) - ++ concatMap checkTest (map snd $ condTestSuites pkg) - ++ concatMap checkBench (map snd $ condBenchmarks pkg) + concatMap checkLib (maybe id (:) (condLibrary pkg) . map snd $ condSubLibraries pkg) + ++ concatMap checkExe (map snd $ condExecutables pkg) + ++ concatMap checkTest (map snd $ condTestSuites pkg) + ++ concatMap checkBench (map snd $ condBenchmarks pkg) where -- the duplicate modules check is has not been thoroughly vetted for backpack - checkLib = checkDups "library" (\l -> explicitLibModules l ++ map moduleReexportName (reexportedModules l)) - checkExe = checkDups "executable" exeModules - checkTest = checkDups "test suite" testModules - checkBench = checkDups "benchmark" benchmarkModules + checkLib = checkDups "library" (\l -> explicitLibModules l ++ map moduleReexportName (reexportedModules l)) + checkExe = checkDups "executable" exeModules + checkTest = checkDups "test suite" testModules + checkBench = checkDups "benchmark" benchmarkModules checkDups s getModules t = - let sumPair (x,x') (y,y') = (x + x' :: Int, y + y' :: Int) - mergePair (x, x') (y, y') = (x + x', max y y') - maxPair (x, x') (y, y') = (max x x', max y y') - libMap = foldCondTree Map.empty - (\(_,v) -> Map.fromListWith sumPair . map (\x -> (x,(1, 1))) $ getModules v ) - (Map.unionWith mergePair) -- if a module may occur in nonexclusive branches count it twice strictly and once loosely. - (Map.unionWith maxPair) -- a module occurs the max of times it might appear in exclusive branches - t - dupLibsStrict = Map.keys $ Map.filter ((>1) . fst) libMap - dupLibsLax = Map.keys $ Map.filter ((>1) . snd) libMap - in if not (null dupLibsLax) - then [PackageBuildImpossible - (DuplicateModule s dupLibsLax)] - else if not (null dupLibsStrict) - then [PackageDistSuspicious - (PotentialDupModule s dupLibsStrict)] - else [] + let sumPair (x, x') (y, y') = (x + x' :: Int, y + y' :: Int) + mergePair (x, x') (y, y') = (x + x', max y y') + maxPair (x, x') (y, y') = (max x x', max y y') + libMap = + foldCondTree + Map.empty + (\(_, v) -> Map.fromListWith sumPair . map (\x -> (x, (1, 1))) $ getModules v) + (Map.unionWith mergePair) -- if a module may occur in nonexclusive branches count it twice strictly and once loosely. + (Map.unionWith maxPair) -- a module occurs the max of times it might appear in exclusive branches + t + dupLibsStrict = Map.keys $ Map.filter ((> 1) . fst) libMap + dupLibsLax = Map.keys $ Map.filter ((> 1) . snd) libMap + in if not (null dupLibsLax) + then + [ PackageBuildImpossible + (DuplicateModule s dupLibsLax) + ] + else + if not (null dupLibsStrict) + then + [ PackageDistSuspicious + (PotentialDupModule s dupLibsStrict) + ] + else [] -- ------------------------------------------------------------ + -- * Utils + -- ------------------------------------------------------------ toDependencyVersionsMap :: (PackageDescription -> [Dependency]) -> GenericPackageDescription -> Map PackageName VersionRange toDependencyVersionsMap selectDependencies pkg = case typicalPkg pkg of - Right (pkgs', _) -> - let - self :: PackageName - self = pkgName $ package pkgs' - in - Map.fromListWith intersectVersionRanges $ - [ (pname, vr) - | Dependency pname vr _ <- selectDependencies pkgs' - , pname /= self - ] - -- Just in case finalizePD fails for any reason, - -- or if the package doesn't depend on the base package at all, - -- no deps is no checks. - _ -> Map.empty - + Right (pkgs', _) -> + let + self :: PackageName + self = pkgName $ package pkgs' + in + Map.fromListWith intersectVersionRanges $ + [ (pname, vr) + | Dependency pname vr _ <- selectDependencies pkgs' + , pname /= self + ] + -- Just in case finalizePD fails for any reason, + -- or if the package doesn't depend on the base package at all, + -- no deps is no checks. + _ -> Map.empty quote :: String -> String quote s = "'" ++ s ++ "'" @@ -2682,15 +2957,15 @@ commaSep :: [String] -> String commaSep = intercalate ", " dups :: Ord a => [a] -> [a] -dups xs = [ x | (x:_:_) <- group (sort xs) ] +dups xs = [x | (x : _ : _) <- group (sort xs)] fileExtensionSupportedLanguage :: FilePath -> Bool fileExtensionSupportedLanguage path = - isHaskell || isC + isHaskell || isC where extension = takeExtension path isHaskell = extension `elem` [".hs", ".lhs"] - isC = isJust (filenameCDialect extension) + isC = isJust (filenameCDialect extension) -- | Whether a path is a good relative path. We aren't worried about perfect -- cross-platform compatibility here; this function just checks the paths in @@ -2731,94 +3006,106 @@ fileExtensionSupportedLanguage path = -- -- >>> traverse_ (print . isGoodRelativeGlob) ["foo/../bar"] -- Just "parent directory segment: .." --- isGoodRelativeFilePath :: FilePath -> Maybe String isGoodRelativeFilePath = state0 where -- initial state - state0 [] = Just "empty path" - state0 (c:cs) | c == '.' = state1 cs - | c == '/' = Just "posix absolute path" - | otherwise = state5 cs + state0 [] = Just "empty path" + state0 (c : cs) + | c == '.' = state1 cs + | c == '/' = Just "posix absolute path" + | otherwise = state5 cs -- after initial . - state1 [] = Just "trailing dot segment" - state1 (c:cs) | c == '.' = state4 cs - | c == '/' = state2 cs - | otherwise = state5 cs + state1 [] = Just "trailing dot segment" + state1 (c : cs) + | c == '.' = state4 cs + | c == '/' = state2 cs + | otherwise = state5 cs -- after ./ or after / between segments - state2 [] = Just "trailing slash" - state2 (c:cs) | c == '.' = state3 cs - | c == '/' = Just "empty path segment" - | otherwise = state5 cs + state2 [] = Just "trailing slash" + state2 (c : cs) + | c == '.' = state3 cs + | c == '/' = Just "empty path segment" + | otherwise = state5 cs -- after non-first segment's . - state3 [] = Just "trailing same directory segment: ." - state3 (c:cs) | c == '.' = state4 cs - | c == '/' = Just "same directory segment: ." - | otherwise = state5 cs + state3 [] = Just "trailing same directory segment: ." + state3 (c : cs) + | c == '.' = state4 cs + | c == '/' = Just "same directory segment: ." + | otherwise = state5 cs -- after .. - state4 [] = Just "trailing parent directory segment: .." - state4 (c:cs) | c == '.' = state5 cs - | c == '/' = Just "parent directory segment: .." - | otherwise = state5 cs + state4 [] = Just "trailing parent directory segment: .." + state4 (c : cs) + | c == '.' = state5 cs + | c == '/' = Just "parent directory segment: .." + | otherwise = state5 cs -- in a segment which is ok. - state5 [] = Nothing - state5 (c:cs) | c == '.' = state5 cs - | c == '/' = state2 cs - | otherwise = state5 cs + state5 [] = Nothing + state5 (c : cs) + | c == '.' = state5 cs + | c == '/' = state2 cs + | otherwise = state5 cs -- | See 'isGoodRelativeFilePath'. -- -- This is barebones function. We check whether the glob is a valid file -- by replacing stars @*@ with @x@ses. isGoodRelativeGlob :: FilePath -> Maybe String -isGoodRelativeGlob = isGoodRelativeFilePath . map f where +isGoodRelativeGlob = isGoodRelativeFilePath . map f + where f '*' = 'x' - f c = c + f c = c -- | See 'isGoodRelativeFilePath'. isGoodRelativeDirectoryPath :: FilePath -> Maybe String isGoodRelativeDirectoryPath = state0 where -- initial state - state0 [] = Just "empty path" - state0 (c:cs) | c == '.' = state5 cs - | c == '/' = Just "posix absolute path" - | otherwise = state4 cs + state0 [] = Just "empty path" + state0 (c : cs) + | c == '.' = state5 cs + | c == '/' = Just "posix absolute path" + | otherwise = state4 cs -- after initial ./ or after / between segments - state1 [] = Nothing - state1 (c:cs) | c == '.' = state2 cs - | c == '/' = Just "empty path segment" - | otherwise = state4 cs + state1 [] = Nothing + state1 (c : cs) + | c == '.' = state2 cs + | c == '/' = Just "empty path segment" + | otherwise = state4 cs -- after non-first setgment's . - state2 [] = Just "trailing same directory segment: ." - state2 (c:cs) | c == '.' = state3 cs - | c == '/' = Just "same directory segment: ." - | otherwise = state4 cs + state2 [] = Just "trailing same directory segment: ." + state2 (c : cs) + | c == '.' = state3 cs + | c == '/' = Just "same directory segment: ." + | otherwise = state4 cs -- after .. - state3 [] = Just "trailing parent directory segment: .." - state3 (c:cs) | c == '.' = state4 cs - | c == '/' = Just "parent directory segment: .." - | otherwise = state4 cs + state3 [] = Just "trailing parent directory segment: .." + state3 (c : cs) + | c == '.' = state4 cs + | c == '/' = Just "parent directory segment: .." + | otherwise = state4 cs -- in a segment which is ok. - state4 [] = Nothing - state4 (c:cs) | c == '.' = state4 cs - | c == '/' = state1 cs - | otherwise = state4 cs + state4 [] = Nothing + state4 (c : cs) + | c == '.' = state4 cs + | c == '/' = state1 cs + | otherwise = state4 cs -- after initial . - state5 [] = Nothing -- "." - state5 (c:cs) | c == '.' = state3 cs - | c == '/' = state1 cs - | otherwise = state4 cs + state5 [] = Nothing -- "." + state5 (c : cs) + | c == '.' = state3 cs + | c == '/' = state1 cs + | otherwise = state4 cs -- [Note: Good relative paths] -- @@ -2913,18 +3200,24 @@ isGoodRelativeDirectoryPath = state0 -- pick a single "typical" configuration and check if that has an -- open upper bound. To get a typical configuration we finalise -- using no package index and the current platform. -typicalPkg :: GenericPackageDescription - -> Either [Dependency] (PackageDescription, FlagAssignment) -typicalPkg = finalizePD - mempty defaultComponentRequestedSpec (const True) - buildPlatform - (unknownCompilerInfo - (CompilerId buildCompilerFlavor nullVersion) - NoAbiTag) - [] +typicalPkg + :: GenericPackageDescription + -> Either [Dependency] (PackageDescription, FlagAssignment) +typicalPkg = + finalizePD + mempty + defaultComponentRequestedSpec + (const True) + buildPlatform + ( unknownCompilerInfo + (CompilerId buildCompilerFlavor nullVersion) + NoAbiTag + ) + [] addConditionalExp :: String -> String -addConditionalExp expl = expl ++ - " Alternatively, if you want to use this, make it conditional based " - ++ "on a Cabal configuration flag (with 'manual: True' and 'default: " - ++ "False') and enable that flag during development." +addConditionalExp expl = + expl + ++ " Alternatively, if you want to use this, make it conditional based " + ++ "on a Cabal configuration flag (with 'manual: True' and 'default: " + ++ "False') and enable that flag during development." diff --git a/Cabal/src/Distribution/ReadE.hs b/Cabal/src/Distribution/ReadE.hs index a3d60fe6813..072dee99044 100644 --- a/Cabal/src/Distribution/ReadE.hs +++ b/Cabal/src/Distribution/ReadE.hs @@ -1,5 +1,7 @@ {-# LANGUAGE LambdaCase #-} + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.ReadE -- Copyright : Jose Iborra 2008 @@ -9,32 +11,37 @@ -- Portability : portable -- -- Simple parsing with failure +module Distribution.ReadE + ( -- * ReadE + ReadE (..) + , succeedReadE + , failReadE + + -- * Projections + , parsecToReadE + , parsecToReadEErr -module Distribution.ReadE ( - -- * ReadE - ReadE(..), succeedReadE, failReadE, - -- * Projections - parsecToReadE, parsecToReadEErr, - -- * Parse Errors - unexpectMsgString, + -- * Parse Errors + , unexpectMsgString ) where +import qualified Data.Bifunctor as Bi (first) import Distribution.Compat.Prelude import Prelude () -import qualified Data.Bifunctor as Bi (first) import Distribution.Parsec -import qualified Text.Parsec.Error as Parsec import Distribution.Parsec.FieldLineStream +import qualified Text.Parsec.Error as Parsec -- | Parser with simple error reporting newtype ReadE a = ReadE {runReadE :: String -> Either ErrorMsg a} -type ErrorMsg = String + +type ErrorMsg = String instance Functor ReadE where fmap f (ReadE p) = ReadE $ \txt -> case p txt of - Right a -> Right (f a) - Left err -> Left err + Right a -> Right (f a) + Left err -> Left err succeedReadE :: (String -> a) -> ReadE a succeedReadE f = ReadE (Right . f) @@ -44,20 +51,21 @@ failReadE = ReadE . const . Left runParsecFromString :: ParsecParser a -> String -> Either Parsec.ParseError a runParsecFromString p txt = - runParsecParser p "" (fieldLineStreamFromString txt) + runParsecParser p "" (fieldLineStreamFromString txt) parsecToReadE :: (String -> ErrorMsg) -> ParsecParser a -> ReadE a parsecToReadE err p = ReadE $ \txt -> - (const $ err txt) `Bi.first` runParsecFromString p txt + (const $ err txt) `Bi.first` runParsecFromString p txt parsecToReadEErr :: (Parsec.ParseError -> ErrorMsg) -> ParsecParser a -> ReadE a -parsecToReadEErr err p = ReadE $ +parsecToReadEErr err p = + ReadE $ Bi.first err . runParsecFromString p -- Show only unexpected error messages unexpectMsgString :: Parsec.ParseError -> String -unexpectMsgString = unlines - . map Parsec.messageString - . filter (\case { Parsec.UnExpect _ -> True; _ -> False }) - . Parsec.errorMessages - +unexpectMsgString = + unlines + . map Parsec.messageString + . filter (\case Parsec.UnExpect _ -> True; _ -> False) + . Parsec.errorMessages diff --git a/Cabal/src/Distribution/Simple.hs b/Cabal/src/Distribution/Simple.hs index 77ba089fa98..10b1c9fb50e 100644 --- a/Cabal/src/Distribution/Simple.hs +++ b/Cabal/src/Distribution/Simple.hs @@ -1,8 +1,17 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- +{- +Work around this warning: +libraries/Cabal/Distribution/Simple.hs:78:0: + Warning: In the use of `runTests' + (imported from Distribution.Simple.UserHooks): + Deprecated: "Please use the new testing interface instead!" +-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} + -- | -- Module : Distribution.Simple -- Copyright : Isaac Jones 2003-2005 @@ -28,79 +37,83 @@ -- The original idea was that there could be different build systems that all -- presented the same compatible command line interfaces. There is still a -- "Distribution.Make" system but in practice no packages use it. - -{- -Work around this warning: -libraries/Cabal/Distribution/Simple.hs:78:0: - Warning: In the use of `runTests' - (imported from Distribution.Simple.UserHooks): - Deprecated: "Please use the new testing interface instead!" --} -{-# OPTIONS_GHC -fno-warn-deprecations #-} - -module Distribution.Simple ( - module Distribution.Package, - module Distribution.Version, - module Distribution.License, - module Distribution.Simple.Compiler, - module Language.Haskell.Extension, - -- * Simple interface - defaultMain, defaultMainNoRead, defaultMainArgs, - -- * Customization - UserHooks(..), Args, - defaultMainWithHooks, defaultMainWithHooksArgs, - defaultMainWithHooksNoRead, defaultMainWithHooksNoReadArgs, - -- ** Standard sets of hooks - simpleUserHooks, - autoconfUserHooks, - emptyUserHooks, +module Distribution.Simple + ( module Distribution.Package + , module Distribution.Version + , module Distribution.License + , module Distribution.Simple.Compiler + , module Language.Haskell.Extension + + -- * Simple interface + , defaultMain + , defaultMainNoRead + , defaultMainArgs + + -- * Customization + , UserHooks (..) + , Args + , defaultMainWithHooks + , defaultMainWithHooksArgs + , defaultMainWithHooksNoRead + , defaultMainWithHooksNoReadArgs + + -- ** Standard sets of hooks + , simpleUserHooks + , autoconfUserHooks + , emptyUserHooks ) where import Control.Exception (try) -import Prelude () import Distribution.Compat.Prelude +import Prelude () -- local -import Distribution.Simple.Compiler -import Distribution.Simple.UserHooks + import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Configuration +import Distribution.Simple.Command +import Distribution.Simple.Compiler import Distribution.Simple.PackageDescription -import Distribution.Simple.Program import Distribution.Simple.PreProcess +import Distribution.Simple.Program import Distribution.Simple.Setup -import Distribution.Simple.Command +import Distribution.Simple.UserHooks import Distribution.Simple.Build -import Distribution.Simple.SrcDist import Distribution.Simple.Register +import Distribution.Simple.SrcDist import Distribution.Simple.Configure -import Distribution.Simple.ConfigureScript -import Distribution.Simple.LocalBuildInfo +import Distribution.License +import Distribution.Pretty import Distribution.Simple.Bench import Distribution.Simple.BuildPaths -import Distribution.Simple.Test -import Distribution.Simple.Install +import Distribution.Simple.ConfigureScript import Distribution.Simple.Haddock +import Distribution.Simple.Install +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Test import Distribution.Simple.Utils import Distribution.Verbosity -import Language.Haskell.Extension import Distribution.Version -import Distribution.License -import Distribution.Pretty +import Language.Haskell.Extension -- Base -import System.Environment (getArgs, getProgName) -import System.Directory (removeFile, doesFileExist - ,doesDirectoryExist, removeDirectoryRecursive) -import System.FilePath (takeDirectory, ()) + import Distribution.Compat.ResponseFile (expandResponse) +import System.Directory + ( doesDirectoryExist + , doesFileExist + , removeDirectoryRecursive + , removeFile + ) +import System.Environment (getArgs, getProgName) +import System.FilePath (takeDirectory, ()) -import Data.List (unionBy, (\\)) +import Data.List (unionBy, (\\)) -- | A simple implementation of @main@ for a Cabal setup script. -- It reads the package description file using IO, and performs the @@ -130,8 +143,8 @@ defaultMainNoRead = defaultMainWithHooksNoRead simpleUserHooks -- | A customizable version of 'defaultMainNoRead'. defaultMainWithHooksNoRead :: UserHooks -> GenericPackageDescription -> IO () defaultMainWithHooksNoRead hooks pkg_descr = - getArgs >>= - defaultMainHelper hooks { readDesc = return (Just pkg_descr) } + getArgs + >>= defaultMainHelper hooks{readDesc = return (Just pkg_descr)} -- | A customizable version of 'defaultMainNoRead' that also takes the -- command line arguments. @@ -139,24 +152,24 @@ defaultMainWithHooksNoRead hooks pkg_descr = -- @since 2.2.0.0 defaultMainWithHooksNoReadArgs :: UserHooks -> GenericPackageDescription -> [String] -> IO () defaultMainWithHooksNoReadArgs hooks pkg_descr = - defaultMainHelper hooks { readDesc = return (Just pkg_descr) } + defaultMainHelper hooks{readDesc = return (Just pkg_descr)} defaultMainHelper :: UserHooks -> Args -> IO () defaultMainHelper hooks args = topHandler $ do args' <- expandResponse args case commandsRun (globalCommand commands) commands args' of - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo (flags, commandParse) -> + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (flags, commandParse) -> case commandParse of - _ | fromFlag (globalVersion flags) -> printVersion + _ + | fromFlag (globalVersion flags) -> printVersion | fromFlag (globalNumericVersion flags) -> printNumericVersion - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo action -> action - + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> action where printHelp help = getProgName >>= putStr . help printOptionsList = putStr . unlines @@ -164,109 +177,135 @@ defaultMainHelper hooks args = topHandler $ do putStr (intercalate "\n" errs) exitWith (ExitFailure 1) printNumericVersion = putStrLn $ prettyShow cabalVersion - printVersion = putStrLn $ "Cabal library version " - ++ prettyShow cabalVersion + printVersion = + putStrLn $ + "Cabal library version " + ++ prettyShow cabalVersion progs = addKnownPrograms (hookedPrograms hooks) defaultProgramDb commands = - [configureCommand progs `commandAddAction` - \fs as -> configureAction hooks fs as >> return () - ,buildCommand progs `commandAddAction` buildAction hooks - ,replCommand progs `commandAddAction` replAction hooks - ,installCommand `commandAddAction` installAction hooks - ,copyCommand `commandAddAction` copyAction hooks - ,haddockCommand `commandAddAction` haddockAction hooks - ,cleanCommand `commandAddAction` cleanAction hooks - ,sdistCommand `commandAddAction` sdistAction hooks - ,hscolourCommand `commandAddAction` hscolourAction hooks - ,registerCommand `commandAddAction` registerAction hooks - ,unregisterCommand `commandAddAction` unregisterAction hooks - ,testCommand `commandAddAction` testAction hooks - ,benchmarkCommand `commandAddAction` benchAction hooks + [ configureCommand progs + `commandAddAction` \fs as -> configureAction hooks fs as >> return () + , buildCommand progs `commandAddAction` buildAction hooks + , replCommand progs `commandAddAction` replAction hooks + , installCommand `commandAddAction` installAction hooks + , copyCommand `commandAddAction` copyAction hooks + , haddockCommand `commandAddAction` haddockAction hooks + , cleanCommand `commandAddAction` cleanAction hooks + , sdistCommand `commandAddAction` sdistAction hooks + , hscolourCommand `commandAddAction` hscolourAction hooks + , registerCommand `commandAddAction` registerAction hooks + , unregisterCommand `commandAddAction` unregisterAction hooks + , testCommand `commandAddAction` testAction hooks + , benchmarkCommand `commandAddAction` benchAction hooks ] -- | Combine the preprocessors in the given hooks with the -- preprocessors built into cabal. -allSuffixHandlers :: UserHooks - -> [PPSuffixHandler] -allSuffixHandlers hooks - = overridesPP (hookedPreProcessors hooks) knownSuffixHandlers - where - overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] - overridesPP = unionBy (\x y -> fst x == fst y) +allSuffixHandlers + :: UserHooks + -> [PPSuffixHandler] +allSuffixHandlers hooks = + overridesPP (hookedPreProcessors hooks) knownSuffixHandlers + where + overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] + overridesPP = unionBy (\x y -> fst x == fst y) configureAction :: UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo configureAction hooks flags args = do - distPref <- findDistPrefOrDefault (configDistPref flags) - let flags' = flags { configDistPref = toFlag distPref - , configArgs = args } + distPref <- findDistPrefOrDefault (configDistPref flags) + let flags' = + flags + { configDistPref = toFlag distPref + , configArgs = args + } - -- See docs for 'HookedBuildInfo' - pbi <- preConf hooks args flags' + -- See docs for 'HookedBuildInfo' + pbi <- preConf hooks args flags' - (mb_pd_file, pkg_descr0) <- confPkgDescr hooks verbosity - (flagToMaybe (configCabalFilePath flags)) + (mb_pd_file, pkg_descr0) <- + confPkgDescr + hooks + verbosity + (flagToMaybe (configCabalFilePath flags)) - let epkg_descr = (pkg_descr0, pbi) + let epkg_descr = (pkg_descr0, pbi) - localbuildinfo0 <- confHook hooks epkg_descr flags' + localbuildinfo0 <- confHook hooks epkg_descr flags' - -- remember the .cabal filename if we know it - -- and all the extra command line args - let localbuildinfo = localbuildinfo0 { - pkgDescrFile = mb_pd_file, - extraConfigArgs = args - } - writePersistBuildConfig distPref localbuildinfo + -- remember the .cabal filename if we know it + -- and all the extra command line args + let localbuildinfo = + localbuildinfo0 + { pkgDescrFile = mb_pd_file + , extraConfigArgs = args + } + writePersistBuildConfig distPref localbuildinfo - let pkg_descr = localPkgDescr localbuildinfo - postConf hooks args flags' pkg_descr localbuildinfo - return localbuildinfo + let pkg_descr = localPkgDescr localbuildinfo + postConf hooks args flags' pkg_descr localbuildinfo + return localbuildinfo where verbosity = fromFlag (configVerbosity flags) -confPkgDescr :: UserHooks -> Verbosity -> Maybe FilePath - -> IO (Maybe FilePath, GenericPackageDescription) +confPkgDescr + :: UserHooks + -> Verbosity + -> Maybe FilePath + -> IO (Maybe FilePath, GenericPackageDescription) confPkgDescr hooks verbosity mb_path = do mdescr <- readDesc hooks case mdescr of Just descr -> return (Nothing, descr) Nothing -> do - pdfile <- case mb_path of - Nothing -> defaultPackageDesc verbosity - Just path -> return path - info verbosity "Using Parsec parser" - descr <- readGenericPackageDescription verbosity pdfile - return (Just pdfile, descr) + pdfile <- case mb_path of + Nothing -> defaultPackageDesc verbosity + Just path -> return path + info verbosity "Using Parsec parser" + descr <- readGenericPackageDescription verbosity pdfile + return (Just pdfile, descr) buildAction :: UserHooks -> BuildFlags -> Args -> IO () buildAction hooks flags args = do distPref <- findDistPrefOrDefault (buildDistPref flags) let verbosity = fromFlag $ buildVerbosity flags lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { buildDistPref = toFlag distPref - , buildCabalFilePath = maybeToFlag (cabalFilePath lbi)} - - progs <- reconfigurePrograms verbosity - (buildProgramPaths flags') - (buildProgramArgs flags') - (withPrograms lbi) + let flags' = + flags + { buildDistPref = toFlag distPref + , buildCabalFilePath = maybeToFlag (cabalFilePath lbi) + } - hookedAction verbosity preBuild buildHook postBuild - (return lbi { withPrograms = progs }) - hooks flags' { buildArgs = args } args + progs <- + reconfigurePrograms + verbosity + (buildProgramPaths flags') + (buildProgramArgs flags') + (withPrograms lbi) + + hookedAction + verbosity + preBuild + buildHook + postBuild + (return lbi{withPrograms = progs}) + hooks + flags'{buildArgs = args} + args replAction :: UserHooks -> ReplFlags -> Args -> IO () replAction hooks flags args = do distPref <- findDistPrefOrDefault (replDistPref flags) let verbosity = fromFlag $ replVerbosity flags - flags' = flags { replDistPref = toFlag distPref } + flags' = flags{replDistPref = toFlag distPref} lbi <- getBuildConfig hooks verbosity distPref - progs <- reconfigurePrograms verbosity - (replProgramPaths flags') - (replProgramArgs flags') - (withPrograms lbi) + progs <- + reconfigurePrograms + verbosity + (replProgramPaths flags') + (replProgramArgs flags') + (withPrograms lbi) -- As far as I can tell, the only reason this doesn't use -- 'hookedActionWithArgs' is because the arguments of 'replHook' @@ -275,211 +314,329 @@ replAction hooks flags args = do let pkg_descr0 = localPkgDescr lbi sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi let pkg_descr = updatePackageDescription pbi pkg_descr0 - lbi' = lbi { withPrograms = progs - , localPkgDescr = pkg_descr } + lbi' = + lbi + { withPrograms = progs + , localPkgDescr = pkg_descr + } replHook hooks pkg_descr lbi' hooks flags' args postRepl hooks args flags' pkg_descr lbi' hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO () hscolourAction hooks flags args = do - distPref <- findDistPrefOrDefault (hscolourDistPref flags) - let verbosity = fromFlag $ hscolourVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { hscolourDistPref = toFlag distPref - , hscolourCabalFilePath = maybeToFlag (cabalFilePath lbi)} + distPref <- findDistPrefOrDefault (hscolourDistPref flags) + let verbosity = fromFlag $ hscolourVerbosity flags + lbi <- getBuildConfig hooks verbosity distPref + let flags' = + flags + { hscolourDistPref = toFlag distPref + , hscolourCabalFilePath = maybeToFlag (cabalFilePath lbi) + } - hookedAction verbosity preHscolour hscolourHook postHscolour - (getBuildConfig hooks verbosity distPref) - hooks flags' args + hookedAction + verbosity + preHscolour + hscolourHook + postHscolour + (getBuildConfig hooks verbosity distPref) + hooks + flags' + args haddockAction :: UserHooks -> HaddockFlags -> Args -> IO () haddockAction hooks flags args = do distPref <- findDistPrefOrDefault (haddockDistPref flags) let verbosity = fromFlag $ haddockVerbosity flags lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { haddockDistPref = toFlag distPref - , haddockCabalFilePath = maybeToFlag (cabalFilePath lbi)} - - progs <- reconfigurePrograms verbosity - (haddockProgramPaths flags') - (haddockProgramArgs flags') - (withPrograms lbi) + let flags' = + flags + { haddockDistPref = toFlag distPref + , haddockCabalFilePath = maybeToFlag (cabalFilePath lbi) + } - hookedAction verbosity preHaddock haddockHook postHaddock - (return lbi { withPrograms = progs }) - hooks flags' { haddockArgs = args } args + progs <- + reconfigurePrograms + verbosity + (haddockProgramPaths flags') + (haddockProgramArgs flags') + (withPrograms lbi) + + hookedAction + verbosity + preHaddock + haddockHook + postHaddock + (return lbi{withPrograms = progs}) + hooks + flags'{haddockArgs = args} + args cleanAction :: UserHooks -> CleanFlags -> Args -> IO () cleanAction hooks flags args = do - distPref <- findDistPrefOrDefault (cleanDistPref flags) - - elbi <- tryGetBuildConfig hooks verbosity distPref - let flags' = flags { cleanDistPref = toFlag distPref - , cleanCabalFilePath = case elbi of - Left _ -> mempty - Right lbi -> maybeToFlag (cabalFilePath lbi)} - - pbi <- preClean hooks args flags' - - (_, ppd) <- confPkgDescr hooks verbosity Nothing - -- It might seem like we are doing something clever here - -- but we're really not: if you look at the implementation - -- of 'clean' in the end all the package description is - -- used for is to clear out @extra-tmp-files@. IMO, - -- the configure script goo should go into @dist@ too! - -- -- ezyang - let pkg_descr0 = flattenPackageDescription ppd - -- We don't sanity check for clean as an error - -- here would prevent cleaning: - --sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi - let pkg_descr = updatePackageDescription pbi pkg_descr0 + distPref <- findDistPrefOrDefault (cleanDistPref flags) + + elbi <- tryGetBuildConfig hooks verbosity distPref + let flags' = + flags + { cleanDistPref = toFlag distPref + , cleanCabalFilePath = case elbi of + Left _ -> mempty + Right lbi -> maybeToFlag (cabalFilePath lbi) + } + + pbi <- preClean hooks args flags' + + (_, ppd) <- confPkgDescr hooks verbosity Nothing + -- It might seem like we are doing something clever here + -- but we're really not: if you look at the implementation + -- of 'clean' in the end all the package description is + -- used for is to clear out @extra-tmp-files@. IMO, + -- the configure script goo should go into @dist@ too! + -- -- ezyang + let pkg_descr0 = flattenPackageDescription ppd + -- We don't sanity check for clean as an error + -- here would prevent cleaning: + -- sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi + let pkg_descr = updatePackageDescription pbi pkg_descr0 - cleanHook hooks pkg_descr () hooks flags' - postClean hooks args flags' pkg_descr () + cleanHook hooks pkg_descr () hooks flags' + postClean hooks args flags' pkg_descr () where verbosity = fromFlag (cleanVerbosity flags) copyAction :: UserHooks -> CopyFlags -> Args -> IO () copyAction hooks flags args = do - distPref <- findDistPrefOrDefault (copyDistPref flags) - let verbosity = fromFlag $ copyVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { copyDistPref = toFlag distPref - , copyCabalFilePath = maybeToFlag (cabalFilePath lbi)} - hookedAction verbosity preCopy copyHook postCopy - (getBuildConfig hooks verbosity distPref) - hooks flags' { copyArgs = args } args + distPref <- findDistPrefOrDefault (copyDistPref flags) + let verbosity = fromFlag $ copyVerbosity flags + lbi <- getBuildConfig hooks verbosity distPref + let flags' = + flags + { copyDistPref = toFlag distPref + , copyCabalFilePath = maybeToFlag (cabalFilePath lbi) + } + hookedAction + verbosity + preCopy + copyHook + postCopy + (getBuildConfig hooks verbosity distPref) + hooks + flags'{copyArgs = args} + args installAction :: UserHooks -> InstallFlags -> Args -> IO () installAction hooks flags args = do - distPref <- findDistPrefOrDefault (installDistPref flags) - let verbosity = fromFlag $ installVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { installDistPref = toFlag distPref - , installCabalFilePath = maybeToFlag (cabalFilePath lbi)} - hookedAction verbosity preInst instHook postInst - (getBuildConfig hooks verbosity distPref) - hooks flags' args + distPref <- findDistPrefOrDefault (installDistPref flags) + let verbosity = fromFlag $ installVerbosity flags + lbi <- getBuildConfig hooks verbosity distPref + let flags' = + flags + { installDistPref = toFlag distPref + , installCabalFilePath = maybeToFlag (cabalFilePath lbi) + } + hookedAction + verbosity + preInst + instHook + postInst + (getBuildConfig hooks verbosity distPref) + hooks + flags' + args -- Since Cabal-3.4 UserHooks are completely ignored sdistAction :: UserHooks -> SDistFlags -> Args -> IO () sdistAction _hooks flags _args = do - (_, ppd) <- confPkgDescr emptyUserHooks verbosity Nothing - let pkg_descr = flattenPackageDescription ppd - sdist pkg_descr flags srcPref knownSuffixHandlers + (_, ppd) <- confPkgDescr emptyUserHooks verbosity Nothing + let pkg_descr = flattenPackageDescription ppd + sdist pkg_descr flags srcPref knownSuffixHandlers where verbosity = fromFlag (sDistVerbosity flags) testAction :: UserHooks -> TestFlags -> Args -> IO () testAction hooks flags args = do - distPref <- findDistPrefOrDefault (testDistPref flags) - let verbosity = fromFlag $ testVerbosity flags - flags' = flags { testDistPref = toFlag distPref } - - hookedActionWithArgs verbosity preTest testHook postTest - (getBuildConfig hooks verbosity distPref) - hooks flags' args + distPref <- findDistPrefOrDefault (testDistPref flags) + let verbosity = fromFlag $ testVerbosity flags + flags' = flags{testDistPref = toFlag distPref} + + hookedActionWithArgs + verbosity + preTest + testHook + postTest + (getBuildConfig hooks verbosity distPref) + hooks + flags' + args benchAction :: UserHooks -> BenchmarkFlags -> Args -> IO () benchAction hooks flags args = do - distPref <- findDistPrefOrDefault (benchmarkDistPref flags) - let verbosity = fromFlag $ benchmarkVerbosity flags - flags' = flags { benchmarkDistPref = toFlag distPref } - hookedActionWithArgs verbosity preBench benchHook postBench - (getBuildConfig hooks verbosity distPref) - hooks flags' args + distPref <- findDistPrefOrDefault (benchmarkDistPref flags) + let verbosity = fromFlag $ benchmarkVerbosity flags + flags' = flags{benchmarkDistPref = toFlag distPref} + hookedActionWithArgs + verbosity + preBench + benchHook + postBench + (getBuildConfig hooks verbosity distPref) + hooks + flags' + args registerAction :: UserHooks -> RegisterFlags -> Args -> IO () registerAction hooks flags args = do - distPref <- findDistPrefOrDefault (regDistPref flags) - let verbosity = fromFlag $ regVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { regDistPref = toFlag distPref - , regCabalFilePath = maybeToFlag (cabalFilePath lbi)} - hookedAction verbosity preReg regHook postReg - (getBuildConfig hooks verbosity distPref) - hooks flags' { regArgs = args } args + distPref <- findDistPrefOrDefault (regDistPref flags) + let verbosity = fromFlag $ regVerbosity flags + lbi <- getBuildConfig hooks verbosity distPref + let flags' = + flags + { regDistPref = toFlag distPref + , regCabalFilePath = maybeToFlag (cabalFilePath lbi) + } + hookedAction + verbosity + preReg + regHook + postReg + (getBuildConfig hooks verbosity distPref) + hooks + flags'{regArgs = args} + args unregisterAction :: UserHooks -> RegisterFlags -> Args -> IO () unregisterAction hooks flags args = do - distPref <- findDistPrefOrDefault (regDistPref flags) - let verbosity = fromFlag $ regVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { regDistPref = toFlag distPref - , regCabalFilePath = maybeToFlag (cabalFilePath lbi)} - hookedAction verbosity preUnreg unregHook postUnreg - (getBuildConfig hooks verbosity distPref) - hooks flags' args + distPref <- findDistPrefOrDefault (regDistPref flags) + let verbosity = fromFlag $ regVerbosity flags + lbi <- getBuildConfig hooks verbosity distPref + let flags' = + flags + { regDistPref = toFlag distPref + , regCabalFilePath = maybeToFlag (cabalFilePath lbi) + } + hookedAction + verbosity + preUnreg + unregHook + postUnreg + (getBuildConfig hooks verbosity distPref) + hooks + flags' + args hookedAction :: Verbosity -> (UserHooks -> Args -> flags -> IO HookedBuildInfo) - -> (UserHooks -> PackageDescription -> LocalBuildInfo - -> UserHooks -> flags -> IO ()) - -> (UserHooks -> Args -> flags -> PackageDescription - -> LocalBuildInfo -> IO ()) + -> ( UserHooks + -> PackageDescription + -> LocalBuildInfo + -> UserHooks + -> flags + -> IO () + ) + -> ( UserHooks + -> Args + -> flags + -> PackageDescription + -> LocalBuildInfo + -> IO () + ) -> IO LocalBuildInfo - -> UserHooks -> flags -> Args -> IO () + -> UserHooks + -> flags + -> Args + -> IO () hookedAction verbosity pre_hook cmd_hook = - hookedActionWithArgs verbosity pre_hook - (\h _ pd lbi uh flags -> - cmd_hook h pd lbi uh flags) + hookedActionWithArgs + verbosity + pre_hook + ( \h _ pd lbi uh flags -> + cmd_hook h pd lbi uh flags + ) hookedActionWithArgs :: Verbosity -> (UserHooks -> Args -> flags -> IO HookedBuildInfo) - -> (UserHooks -> Args -> PackageDescription -> LocalBuildInfo - -> UserHooks -> flags -> IO ()) - -> (UserHooks -> Args -> flags -> PackageDescription - -> LocalBuildInfo -> IO ()) + -> ( UserHooks + -> Args + -> PackageDescription + -> LocalBuildInfo + -> UserHooks + -> flags + -> IO () + ) + -> ( UserHooks + -> Args + -> flags + -> PackageDescription + -> LocalBuildInfo + -> IO () + ) -> IO LocalBuildInfo - -> UserHooks -> flags -> Args -> IO () -hookedActionWithArgs verbosity pre_hook cmd_hook post_hook - get_build_config hooks flags args = do - pbi <- pre_hook hooks args flags - lbi0 <- get_build_config - let pkg_descr0 = localPkgDescr lbi0 - sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi - let pkg_descr = updatePackageDescription pbi pkg_descr0 - lbi = lbi0 { localPkgDescr = pkg_descr } - cmd_hook hooks args pkg_descr lbi hooks flags - post_hook hooks args flags pkg_descr lbi + -> UserHooks + -> flags + -> Args + -> IO () +hookedActionWithArgs + verbosity + pre_hook + cmd_hook + post_hook + get_build_config + hooks + flags + args = do + pbi <- pre_hook hooks args flags + lbi0 <- get_build_config + let pkg_descr0 = localPkgDescr lbi0 + sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi + let pkg_descr = updatePackageDescription pbi pkg_descr0 + lbi = lbi0{localPkgDescr = pkg_descr} + cmd_hook hooks args pkg_descr lbi hooks flags + post_hook hooks args flags pkg_descr lbi sanityCheckHookedBuildInfo :: Verbosity -> PackageDescription -> HookedBuildInfo -> IO () -sanityCheckHookedBuildInfo verbosity - (PackageDescription { library = Nothing }) (Just _,_) - = die' verbosity $ "The buildinfo contains info for a library, " - ++ "but the package does not have a library." - +sanityCheckHookedBuildInfo + verbosity + (PackageDescription{library = Nothing}) + (Just _, _) = + die' verbosity $ + "The buildinfo contains info for a library, " + ++ "but the package does not have a library." sanityCheckHookedBuildInfo verbosity pkg_descr (_, hookExes) - | exe1 : _ <- nonExistant - = die' verbosity $ "The buildinfo contains info for an executable called '" - ++ prettyShow exe1 ++ "' but the package does not have a " - ++ "executable with that name." + | exe1 : _ <- nonExistant = + die' verbosity $ + "The buildinfo contains info for an executable called '" + ++ prettyShow exe1 + ++ "' but the package does not have a " + ++ "executable with that name." where - pkgExeNames = nub (map exeName (executables pkg_descr)) + pkgExeNames = nub (map exeName (executables pkg_descr)) hookExeNames = nub (map fst hookExes) - nonExistant = hookExeNames \\ pkgExeNames - + nonExistant = hookExeNames \\ pkgExeNames sanityCheckHookedBuildInfo _ _ _ = return () -- | Try to read the 'localBuildInfoFile' -tryGetBuildConfig :: UserHooks -> Verbosity -> FilePath - -> IO (Either ConfigStateFileError LocalBuildInfo) +tryGetBuildConfig + :: UserHooks + -> Verbosity + -> FilePath + -> IO (Either ConfigStateFileError LocalBuildInfo) tryGetBuildConfig u v = try . getBuildConfig u v - -- | Read the 'localBuildInfoFile' or throw an exception. getBuildConfig :: UserHooks -> Verbosity -> FilePath -> IO LocalBuildInfo getBuildConfig hooks verbosity distPref = do lbi_wo_programs <- getPersistBuildConfig distPref -- Restore info about unconfigured programs, since it is not serialized - let lbi = lbi_wo_programs { - withPrograms = restoreProgramDb - (builtinPrograms ++ hookedPrograms hooks) - (withPrograms lbi_wo_programs) - } + let lbi = + lbi_wo_programs + { withPrograms = + restoreProgramDb + (builtinPrograms ++ hookedPrograms hooks) + (withPrograms lbi_wo_programs) + } case pkgDescrFile lbi of Nothing -> return lbi @@ -488,60 +645,64 @@ getBuildConfig hooks verbosity distPref = do if outdated then reconfigure pkg_descr_file lbi else return lbi - where reconfigure :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo reconfigure pkg_descr_file lbi = do - notice verbosity $ pkg_descr_file ++ " has been changed. " - ++ "Re-configuring with most recently used options. " - ++ "If this fails, please run configure manually.\n" + notice verbosity $ + pkg_descr_file + ++ " has been changed. " + ++ "Re-configuring with most recently used options. " + ++ "If this fails, please run configure manually.\n" let cFlags = configFlags lbi - let cFlags' = cFlags { - -- Since the list of unconfigured programs is not serialized, - -- restore it to the same value as normally used at the beginning - -- of a configure run: - configPrograms_ = fmap (restoreProgramDb - (builtinPrograms ++ hookedPrograms hooks)) - `fmap` configPrograms_ cFlags, - - -- Use the current, not saved verbosity level: - configVerbosity = Flag verbosity - } + let cFlags' = + cFlags + { -- Since the list of unconfigured programs is not serialized, + -- restore it to the same value as normally used at the beginning + -- of a configure run: + configPrograms_ = + fmap + ( restoreProgramDb + (builtinPrograms ++ hookedPrograms hooks) + ) + `fmap` configPrograms_ cFlags + , -- Use the current, not saved verbosity level: + configVerbosity = Flag verbosity + } configureAction hooks cFlags' (extraConfigArgs lbi) - -- -------------------------------------------------------------------------- -- Cleaning clean :: PackageDescription -> CleanFlags -> IO () clean pkg_descr flags = do - let distPref = fromFlagOrDefault defaultDistPref $ cleanDistPref flags - notice verbosity "cleaning..." - - maybeConfig <- if fromFlag (cleanSaveConf flags) - then maybeGetPersistBuildConfig distPref - else return Nothing + let distPref = fromFlagOrDefault defaultDistPref $ cleanDistPref flags + notice verbosity "cleaning..." - -- remove the whole dist/ directory rather than tracking exactly what files - -- we created in there. - chattyTry "removing dist/" $ do - exists <- doesDirectoryExist distPref - when exists (removeDirectoryRecursive distPref) + maybeConfig <- + if fromFlag (cleanSaveConf flags) + then maybeGetPersistBuildConfig distPref + else return Nothing - -- Any extra files the user wants to remove - traverse_ removeFileOrDirectory (extraTmpFiles pkg_descr) + -- remove the whole dist/ directory rather than tracking exactly what files + -- we created in there. + chattyTry "removing dist/" $ do + exists <- doesDirectoryExist distPref + when exists (removeDirectoryRecursive distPref) - -- If the user wanted to save the config, write it back - traverse_ (writePersistBuildConfig distPref) maybeConfig + -- Any extra files the user wants to remove + traverse_ removeFileOrDirectory (extraTmpFiles pkg_descr) + -- If the user wanted to save the config, write it back + traverse_ (writePersistBuildConfig distPref) maybeConfig where - removeFileOrDirectory :: FilePath -> IO () - removeFileOrDirectory fname = do - isDir <- doesDirectoryExist fname - isFile <- doesFileExist fname - if isDir then removeDirectoryRecursive fname - else when isFile $ removeFile fname - verbosity = fromFlag (cleanVerbosity flags) + removeFileOrDirectory :: FilePath -> IO () + removeFileOrDirectory fname = do + isDir <- doesDirectoryExist fname + isFile <- doesFileExist fname + if isDir + then removeDirectoryRecursive fname + else when isFile $ removeFile fname + verbosity = fromFlag (cleanVerbosity flags) -- -------------------------------------------------------------------------- -- Default hooks @@ -550,22 +711,22 @@ clean pkg_descr flags = do -- \"simple\" build system simpleUserHooks :: UserHooks simpleUserHooks = - emptyUserHooks { - confHook = configure, - postConf = finalChecks, - buildHook = defaultBuildHook, - replHook = defaultReplHook, - copyHook = \desc lbi _ f -> install desc lbi f, - -- 'install' has correct 'copy' behavior with params - testHook = defaultTestHook, - benchHook = defaultBenchHook, - instHook = defaultInstallHook, - cleanHook = \p _ _ f -> clean p f, - hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f, - haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f, - regHook = defaultRegHook, - unregHook = \p l _ f -> unregister p l f - } + emptyUserHooks + { confHook = configure + , postConf = finalChecks + , buildHook = defaultBuildHook + , replHook = defaultReplHook + , copyHook = \desc lbi _ f -> install desc lbi f + , -- 'install' has correct 'copy' behavior with params + testHook = defaultTestHook + , benchHook = defaultBenchHook + , instHook = defaultInstallHook + , cleanHook = \p _ _ f -> clean p f + , hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f + , haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f + , regHook = defaultRegHook + , unregHook = \p l _ f -> unregister p l f + } where finalChecks _args flags pkg_descr lbi = checkForeignDeps pkg_descr lbi (lessVerbose verbosity) @@ -582,109 +743,155 @@ simpleUserHooks = -- -- Thus @configure@ can use local system information to generate -- /package/@.buildinfo@ and possibly other files. - autoconfUserHooks :: UserHooks -autoconfUserHooks - = simpleUserHooks - { - postConf = defaultPostConf, - preBuild = readHookWithArgs buildVerbosity buildDistPref, -- buildCabalFilePath, - preCopy = readHookWithArgs copyVerbosity copyDistPref, - preClean = readHook cleanVerbosity cleanDistPref, - preInst = readHook installVerbosity installDistPref, - preHscolour = readHook hscolourVerbosity hscolourDistPref, - preHaddock = readHookWithArgs haddockVerbosity haddockDistPref, - preReg = readHook regVerbosity regDistPref, - preUnreg = readHook regVerbosity regDistPref - } - where defaultPostConf :: Args -> ConfigFlags -> PackageDescription - -> LocalBuildInfo -> IO () - defaultPostConf args flags pkg_descr lbi - = do let verbosity = fromFlag (configVerbosity flags) - baseDir lbi' = fromMaybe "" - (takeDirectory <$> cabalFilePath lbi') - confExists <- doesFileExist $ (baseDir lbi) "configure" - if confExists - then runConfigureScript verbosity - flags lbi - else die' verbosity "configure script not found." - - pbi <- getHookedBuildInfo verbosity (buildDir lbi) - sanityCheckHookedBuildInfo verbosity pkg_descr pbi - let pkg_descr' = updatePackageDescription pbi pkg_descr - lbi' = lbi { localPkgDescr = pkg_descr' } - postConf simpleUserHooks args flags pkg_descr' lbi' - - readHookWithArgs :: (a -> Flag Verbosity) - -> (a -> Flag FilePath) - -> Args -> a - -> IO HookedBuildInfo - readHookWithArgs get_verbosity get_dist_pref _ flags = do - dist_dir <- findDistPrefOrDefault (get_dist_pref flags) - getHookedBuildInfo verbosity (dist_dir "build") - where - verbosity = fromFlag (get_verbosity flags) - - readHook :: (a -> Flag Verbosity) - -> (a -> Flag FilePath) - -> Args -> a -> IO HookedBuildInfo - readHook get_verbosity get_dist_pref a flags = do - noExtraFlags a - dist_dir <- findDistPrefOrDefault (get_dist_pref flags) - getHookedBuildInfo verbosity (dist_dir "build") - where - verbosity = fromFlag (get_verbosity flags) +autoconfUserHooks = + simpleUserHooks + { postConf = defaultPostConf + , preBuild = readHookWithArgs buildVerbosity buildDistPref -- buildCabalFilePath, + , preCopy = readHookWithArgs copyVerbosity copyDistPref + , preClean = readHook cleanVerbosity cleanDistPref + , preInst = readHook installVerbosity installDistPref + , preHscolour = readHook hscolourVerbosity hscolourDistPref + , preHaddock = readHookWithArgs haddockVerbosity haddockDistPref + , preReg = readHook regVerbosity regDistPref + , preUnreg = readHook regVerbosity regDistPref + } + where + defaultPostConf + :: Args + -> ConfigFlags + -> PackageDescription + -> LocalBuildInfo + -> IO () + defaultPostConf args flags pkg_descr lbi = + do + let verbosity = fromFlag (configVerbosity flags) + baseDir lbi' = + fromMaybe + "" + (takeDirectory <$> cabalFilePath lbi') + confExists <- doesFileExist $ (baseDir lbi) "configure" + if confExists + then + runConfigureScript + verbosity + flags + lbi + else die' verbosity "configure script not found." + + pbi <- getHookedBuildInfo verbosity (buildDir lbi) + sanityCheckHookedBuildInfo verbosity pkg_descr pbi + let pkg_descr' = updatePackageDescription pbi pkg_descr + lbi' = lbi{localPkgDescr = pkg_descr'} + postConf simpleUserHooks args flags pkg_descr' lbi' + + readHookWithArgs + :: (a -> Flag Verbosity) + -> (a -> Flag FilePath) + -> Args + -> a + -> IO HookedBuildInfo + readHookWithArgs get_verbosity get_dist_pref _ flags = do + dist_dir <- findDistPrefOrDefault (get_dist_pref flags) + getHookedBuildInfo verbosity (dist_dir "build") + where + verbosity = fromFlag (get_verbosity flags) + + readHook + :: (a -> Flag Verbosity) + -> (a -> Flag FilePath) + -> Args + -> a + -> IO HookedBuildInfo + readHook get_verbosity get_dist_pref a flags = do + noExtraFlags a + dist_dir <- findDistPrefOrDefault (get_dist_pref flags) + getHookedBuildInfo verbosity (dist_dir "build") + where + verbosity = fromFlag (get_verbosity flags) getHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo getHookedBuildInfo verbosity build_dir = do maybe_infoFile <- findHookedPackageDesc verbosity build_dir case maybe_infoFile of - Nothing -> return emptyHookedBuildInfo + Nothing -> return emptyHookedBuildInfo Just infoFile -> do info verbosity $ "Reading parameters from " ++ infoFile readHookedBuildInfo verbosity infoFile -defaultTestHook :: Args -> PackageDescription -> LocalBuildInfo - -> UserHooks -> TestFlags -> IO () +defaultTestHook + :: Args + -> PackageDescription + -> LocalBuildInfo + -> UserHooks + -> TestFlags + -> IO () defaultTestHook args pkg_descr localbuildinfo _ flags = - test args pkg_descr localbuildinfo flags - -defaultBenchHook :: Args -> PackageDescription -> LocalBuildInfo - -> UserHooks -> BenchmarkFlags -> IO () + test args pkg_descr localbuildinfo flags + +defaultBenchHook + :: Args + -> PackageDescription + -> LocalBuildInfo + -> UserHooks + -> BenchmarkFlags + -> IO () defaultBenchHook args pkg_descr localbuildinfo _ flags = - bench args pkg_descr localbuildinfo flags - -defaultInstallHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> InstallFlags -> IO () + bench args pkg_descr localbuildinfo flags + +defaultInstallHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> InstallFlags + -> IO () defaultInstallHook pkg_descr localbuildinfo _ flags = do - let copyFlags = defaultCopyFlags { - copyDistPref = installDistPref flags, - copyDest = installDest flags, - copyVerbosity = installVerbosity flags - } + let copyFlags = + defaultCopyFlags + { copyDistPref = installDistPref flags + , copyDest = installDest flags + , copyVerbosity = installVerbosity flags + } install pkg_descr localbuildinfo copyFlags - let registerFlags = defaultRegisterFlags { - regDistPref = installDistPref flags, - regInPlace = installInPlace flags, - regPackageDB = installPackageDB flags, - regVerbosity = installVerbosity flags - } + let registerFlags = + defaultRegisterFlags + { regDistPref = installDistPref flags + , regInPlace = installInPlace flags + , regPackageDB = installPackageDB flags + , regVerbosity = installVerbosity flags + } when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags -defaultBuildHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> BuildFlags -> IO () +defaultBuildHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> BuildFlags + -> IO () defaultBuildHook pkg_descr localbuildinfo hooks flags = build pkg_descr localbuildinfo flags (allSuffixHandlers hooks) -defaultReplHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> ReplFlags -> [String] -> IO () +defaultReplHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> ReplFlags + -> [String] + -> IO () defaultReplHook pkg_descr localbuildinfo hooks flags args = repl pkg_descr localbuildinfo flags (allSuffixHandlers hooks) args -defaultRegHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> RegisterFlags -> IO () +defaultRegHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> RegisterFlags + -> IO () defaultRegHook pkg_descr localbuildinfo _ flags = - if hasLibs pkg_descr + if hasLibs pkg_descr then register pkg_descr localbuildinfo flags - else setupMessage (fromFlag (regVerbosity flags)) - "Package contains no library to register:" (packageId pkg_descr) + else + setupMessage + (fromFlag (regVerbosity flags)) + "Package contains no library to register:" + (packageId pkg_descr) diff --git a/Cabal/src/Distribution/Simple/Bench.hs b/Cabal/src/Distribution/Simple/Bench.hs index 6484654c0ca..77b3d1a1227 100644 --- a/Cabal/src/Distribution/Simple/Bench.hs +++ b/Cabal/src/Distribution/Simple/Bench.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Bench -- Copyright : Johan Tibell 2011 @@ -13,114 +14,135 @@ -- This is the entry point into running the benchmarks in a built -- package. It performs the \"@.\/setup bench@\" action. It runs -- benchmarks designated in the package description. - module Distribution.Simple.Bench - ( bench - ) where + ( bench + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.UnqualComponentName import qualified Distribution.PackageDescription as PD +import Distribution.Pretty import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler +import Distribution.Simple.Flag (fromFlag) import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI -import Distribution.Simple.Flag ( fromFlag ) import Distribution.Simple.Setup.Benchmark import Distribution.Simple.UserHooks import Distribution.Simple.Utils -import Distribution.Pretty +import Distribution.Types.UnqualComponentName -import System.Directory ( doesFileExist ) -import System.FilePath ( (), (<.>) ) +import System.Directory (doesFileExist) +import System.FilePath ((<.>), ()) -- | Perform the \"@.\/setup bench@\" action. -bench :: Args -- ^positional command-line arguments - -> PD.PackageDescription -- ^information from the .cabal file - -> LBI.LocalBuildInfo -- ^information from the configure step - -> BenchmarkFlags -- ^flags sent to benchmark - -> IO () +bench + :: Args + -- ^ positional command-line arguments + -> PD.PackageDescription + -- ^ information from the .cabal file + -> LBI.LocalBuildInfo + -- ^ information from the configure step + -> BenchmarkFlags + -- ^ flags sent to benchmark + -> IO () bench args pkg_descr lbi flags = do - let verbosity = fromFlag $ benchmarkVerbosity flags - benchmarkNames = args - pkgBenchmarks = PD.benchmarks pkg_descr - enabledBenchmarks = map fst (LBI.enabledBenchLBIs pkg_descr lbi) + let verbosity = fromFlag $ benchmarkVerbosity flags + benchmarkNames = args + pkgBenchmarks = PD.benchmarks pkg_descr + enabledBenchmarks = map fst (LBI.enabledBenchLBIs pkg_descr lbi) - -- Run the benchmark - doBench :: PD.Benchmark -> IO ExitCode - doBench bm = - case PD.benchmarkInterface bm of - PD.BenchmarkExeV10 _ _ -> do - let cmd = LBI.buildDir lbi name name <.> exeExtension (LBI.hostPlatform lbi) - options = map (benchOption pkg_descr lbi bm) $ - benchmarkOptions flags - -- Check that the benchmark executable exists. - exists <- doesFileExist cmd - unless exists $ die' verbosity $ - "Could not find benchmark program \"" - ++ cmd ++ "\". Did you build the package first?" + -- Run the benchmark + doBench :: PD.Benchmark -> IO ExitCode + doBench bm = + case PD.benchmarkInterface bm of + PD.BenchmarkExeV10 _ _ -> do + let cmd = LBI.buildDir lbi name name <.> exeExtension (LBI.hostPlatform lbi) + options = + map (benchOption pkg_descr lbi bm) $ + benchmarkOptions flags + -- Check that the benchmark executable exists. + exists <- doesFileExist cmd + unless exists $ + die' verbosity $ + "Could not find benchmark program \"" + ++ cmd + ++ "\". Did you build the package first?" - notice verbosity $ startMessage name - -- This will redirect the child process - -- stdout/stderr to the parent process. - exitcode <- rawSystemExitCode verbosity cmd options - notice verbosity $ finishMessage name exitcode - return exitcode + notice verbosity $ startMessage name + -- This will redirect the child process + -- stdout/stderr to the parent process. + exitcode <- rawSystemExitCode verbosity cmd options + notice verbosity $ finishMessage name exitcode + return exitcode + _ -> do + notice verbosity $ + "No support for running " + ++ "benchmark " + ++ name + ++ " of type: " + ++ prettyShow (PD.benchmarkType bm) + exitFailure + where + name = unUnqualComponentName $ PD.benchmarkName bm - _ -> do - notice verbosity $ "No support for running " - ++ "benchmark " ++ name ++ " of type: " - ++ prettyShow (PD.benchmarkType bm) - exitFailure - where name = unUnqualComponentName $ PD.benchmarkName bm + unless (PD.hasBenchmarks pkg_descr) $ do + notice verbosity "Package has no benchmarks." + exitSuccess - unless (PD.hasBenchmarks pkg_descr) $ do - notice verbosity "Package has no benchmarks." - exitSuccess + when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $ + die' verbosity $ + "No benchmarks enabled. Did you remember to configure with " + ++ "\'--enable-benchmarks\'?" - when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $ - die' verbosity $ "No benchmarks enabled. Did you remember to configure with " - ++ "\'--enable-benchmarks\'?" + bmsToRun <- case benchmarkNames of + [] -> return enabledBenchmarks + names -> for names $ \bmName -> + let benchmarkMap = zip enabledNames enabledBenchmarks + enabledNames = map PD.benchmarkName enabledBenchmarks + allNames = map PD.benchmarkName pkgBenchmarks + in case lookup (mkUnqualComponentName bmName) benchmarkMap of + Just t -> return t + _ + | mkUnqualComponentName bmName `elem` allNames -> + die' verbosity $ + "Package configured with benchmark " + ++ bmName + ++ " disabled." + | otherwise -> die' verbosity $ "no such benchmark: " ++ bmName - bmsToRun <- case benchmarkNames of - [] -> return enabledBenchmarks - names -> for names $ \bmName -> - let benchmarkMap = zip enabledNames enabledBenchmarks - enabledNames = map PD.benchmarkName enabledBenchmarks - allNames = map PD.benchmarkName pkgBenchmarks - in case lookup (mkUnqualComponentName bmName) benchmarkMap of - Just t -> return t - _ | mkUnqualComponentName bmName `elem` allNames -> - die' verbosity $ "Package configured with benchmark " - ++ bmName ++ " disabled." - | otherwise -> die' verbosity $ "no such benchmark: " ++ bmName - - let totalBenchmarks = length bmsToRun - notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..." - exitcodes <- traverse doBench bmsToRun - let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes) - unless allOk exitFailure + let totalBenchmarks = length bmsToRun + notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..." + exitcodes <- traverse doBench bmsToRun + let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes) + unless allOk exitFailure where startMessage name = "Benchmark " ++ name ++ ": RUNNING...\n" - finishMessage name exitcode = "Benchmark " ++ name ++ ": " - ++ (case exitcode of - ExitSuccess -> "FINISH" - ExitFailure _ -> "ERROR") - + finishMessage name exitcode = + "Benchmark " + ++ name + ++ ": " + ++ ( case exitcode of + ExitSuccess -> "FINISH" + ExitFailure _ -> "ERROR" + ) -- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't -- necessarily a path. -benchOption :: PD.PackageDescription - -> LBI.LocalBuildInfo - -> PD.Benchmark - -> PathTemplate - -> String +benchOption + :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> PD.Benchmark + -> PathTemplate + -> String benchOption pkg_descr lbi bm template = - fromPathTemplate $ substPathTemplate env template + fromPathTemplate $ substPathTemplate env template where - env = initialPathTemplateEnv - (PD.package pkg_descr) (LBI.localUnitId lbi) - (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++ - [(BenchmarkNameVar, toPathTemplate $ unUnqualComponentName $ PD.benchmarkName bm)] + env = + initialPathTemplateEnv + (PD.package pkg_descr) + (LBI.localUnitId lbi) + (compilerInfo $ LBI.compiler lbi) + (LBI.hostPlatform lbi) + ++ [(BenchmarkNameVar, toPathTemplate $ unUnqualComponentName $ PD.benchmarkName bm)] diff --git a/Cabal/src/Distribution/Simple/Build.hs b/Cabal/src/Distribution/Simple/Build.hs index 04659830f12..c2e421045bf 100644 --- a/Cabal/src/Distribution/Simple/Build.hs +++ b/Cabal/src/Distribution/Simple/Build.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Build -- Copyright : Isaac Jones 2003-2005, @@ -16,21 +17,19 @@ -- doesn't actually do much itself, most of the work is delegated to -- compiler-specific actions. It does do some non-compiler specific bits like -- running pre-processors. --- - -module Distribution.Simple.Build ( - build, repl, - startInterpreter, - - initialBuildSteps, - createInternalPackageDB, - componentInitialBuildSteps, - writeAutogenFiles, +module Distribution.Simple.Build + ( build + , repl + , startInterpreter + , initialBuildSteps + , createInternalPackageDB + , componentInitialBuildSteps + , writeAutogenFiles ) where -import Prelude () import Distribution.Compat.Prelude import Distribution.Utils.Generic +import Prelude () import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.ComponentRequestedSpec @@ -39,79 +38,88 @@ import Distribution.Types.ExecutableScope import Distribution.Types.ForeignLib import Distribution.Types.LibraryVisibility import Distribution.Types.LocalBuildInfo +import Distribution.Types.ModuleRenaming import Distribution.Types.MungedPackageId import Distribution.Types.MungedPackageName -import Distribution.Types.ModuleRenaming import Distribution.Types.TargetInfo import Distribution.Utils.Path -import Distribution.Package import Distribution.Backpack import Distribution.Backpack.DescribeUnitId -import qualified Distribution.Simple.GHC as GHC +import Distribution.Package +import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.UHC as UHC import qualified Distribution.Simple.HaskellSuite as HaskellSuite import qualified Distribution.Simple.PackageIndex as Index +import qualified Distribution.Simple.UHC as UHC -import Distribution.Simple.Build.Macros (generateCabalMacrosHeader) +import Distribution.Simple.Build.Macros (generateCabalMacrosHeader) import Distribution.Simple.Build.PackageInfoModule (generatePackageInfoModule) import Distribution.Simple.Build.PathsModule (generatePathsModule) import qualified Distribution.Simple.Program.HcPkg as HcPkg -import Distribution.Simple.Compiler -import Distribution.PackageDescription -import qualified Distribution.InstalledPackageInfo as IPI import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as IPI import qualified Distribution.ModuleName as ModuleName +import Distribution.PackageDescription +import Distribution.Simple.Compiler -import Distribution.Simple.Flag -import Distribution.Simple.Setup.Build -import Distribution.Simple.Setup.Config -import Distribution.Simple.Setup.Repl +import Distribution.Simple.BuildPaths import Distribution.Simple.BuildTarget import Distribution.Simple.BuildToolDepends -import Distribution.Simple.PreProcess +import Distribution.Simple.Configure +import Distribution.Simple.Flag import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PreProcess import Distribution.Simple.Program import Distribution.Simple.Program.Builtin (haskellSuiteProgram) -import qualified Distribution.Simple.Program.GHC as GHC +import qualified Distribution.Simple.Program.GHC as GHC import Distribution.Simple.Program.Types -import Distribution.Simple.ShowBuildInfo -import Distribution.Simple.BuildPaths -import Distribution.Simple.Configure import Distribution.Simple.Register +import Distribution.Simple.Setup.Build +import Distribution.Simple.Setup.Config +import Distribution.Simple.Setup.Repl +import Distribution.Simple.ShowBuildInfo import Distribution.Simple.Test.LibV09 import Distribution.Simple.Utils import Distribution.Utils.Json -import Distribution.System import Distribution.Pretty +import Distribution.System import Distribution.Verbosity import Distribution.Version (thisVersion) -import Distribution.Compat.Graph (IsNode(..)) +import Distribution.Compat.Graph (IsNode (..)) import Control.Monad import qualified Data.ByteString.Lazy as LBS -import System.FilePath ( (), (<.>), takeDirectory ) -import System.Directory ( getCurrentDirectory, removeFile, doesFileExist ) +import System.Directory (doesFileExist, getCurrentDirectory, removeFile) +import System.FilePath (takeDirectory, (<.>), ()) -- ----------------------------------------------------------------------------- --- |Build the libraries and executables in this package. -build :: PackageDescription -- ^ Mostly information from the .cabal file - -> LocalBuildInfo -- ^ Configuration information - -> BuildFlags -- ^ Flags that the user passed to build - -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling - -> IO () +-- | Build the libraries and executables in this package. +build + :: PackageDescription + -- ^ Mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> BuildFlags + -- ^ Flags that the user passed to build + -> [PPSuffixHandler] + -- ^ preprocessors to run before compiling + -> IO () build pkg_descr lbi flags suffixes = do targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs flags) let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) - info verbosity $ "Component build order: " - ++ intercalate ", " - (map (showComponentName . componentLocalName . targetCLBI) - componentsToBuild) + info verbosity $ + "Component build order: " + ++ intercalate + ", " + ( map + (showComponentName . componentLocalName . targetCLBI) + componentsToBuild + ) when (null targets) $ -- Only bother with this message if we're building the whole package @@ -129,22 +137,30 @@ build pkg_descr lbi flags suffixes = do let comp = targetComponent target clbi = targetCLBI target componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity - let bi = componentBuildInfo comp + let bi = componentBuildInfo comp progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi) - lbi' = lbi { - withPrograms = progs', - withPackageDB = withPackageDB lbi ++ [internalPackageDB], - installedPkgs = index - } - mb_ipi <- buildComponent verbosity (buildNumJobs flags) pkg_descr - lbi' suffixes comp clbi distPref + lbi' = + lbi + { withPrograms = progs' + , withPackageDB = withPackageDB lbi ++ [internalPackageDB] + , installedPkgs = index + } + mb_ipi <- + buildComponent + verbosity + (buildNumJobs flags) + pkg_descr + lbi' + suffixes + comp + clbi + distPref return (maybe index (Index.insert `flip` index) mb_ipi) return () - where - distPref = fromFlag (buildDistPref flags) - verbosity = fromFlag (buildVerbosity flags) - + where + distPref = fromFlag (buildDistPref flags) + verbosity = fromFlag (buildVerbosity flags) -- | Write available build information for 'LocalBuildInfo' to disk. -- @@ -152,34 +168,47 @@ build pkg_descr lbi flags suffixes = do -- Build information contains basics such as compiler details, but also -- lists what modules a component contains and how to compile the component, assuming -- lib:Cabal made sure that dependencies are up-to-date. -dumpBuildInfo :: Verbosity - -> FilePath -- ^ To which directory should the build-info be dumped? - -> Flag DumpBuildInfo -- ^ Should we dump detailed build information for this component? - -> PackageDescription -- ^ Mostly information from the .cabal file - -> LocalBuildInfo -- ^ Configuration information - -> BuildFlags -- ^ Flags that the user passed to build - -> IO () +dumpBuildInfo + :: Verbosity + -> FilePath + -- ^ To which directory should the build-info be dumped? + -> Flag DumpBuildInfo + -- ^ Should we dump detailed build information for this component? + -> PackageDescription + -- ^ Mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> BuildFlags + -- ^ Flags that the user passed to build + -> IO () dumpBuildInfo verbosity distPref dumpBuildInfoFlag pkg_descr lbi flags = do when shouldDumpBuildInfo $ do -- Changing this line might break consumers of the dumped build info. -- Announce changes on mailing lists! let activeTargets = allTargetsInBuildOrder' pkg_descr lbi - info verbosity $ "Dump build information for: " - ++ intercalate ", " - (map (showComponentName . componentLocalName . targetCLBI) - activeTargets) + info verbosity $ + "Dump build information for: " + ++ intercalate + ", " + ( map + (showComponentName . componentLocalName . targetCLBI) + activeTargets + ) pwd <- getCurrentDirectory (compilerProg, _) <- case flavorToProgram (compilerFlavor (compiler lbi)) of - Nothing -> die' verbosity $ "dumpBuildInfo: Unknown compiler flavor: " - ++ show (compilerFlavor (compiler lbi)) + Nothing -> + die' verbosity $ + "dumpBuildInfo: Unknown compiler flavor: " + ++ show (compilerFlavor (compiler lbi)) Just program -> requireProgram verbosity program (withPrograms lbi) let (warns, json) = mkBuildInfo pwd pkg_descr lbi flags (compilerProg, compiler lbi) activeTargets buildInfoText = renderJson json unless (null warns) $ - warn verbosity $ "Encountered warnings while dumping build-info:\n" - ++ unlines warns + warn verbosity $ + "Encountered warnings while dumping build-info:\n" + ++ unlines warns LBS.writeFile (buildInfoPref distPref) buildInfoText when (not shouldDumpBuildInfo) $ do @@ -189,58 +218,80 @@ dumpBuildInfo verbosity distPref dumpBuildInfoFlag pkg_descr lbi flags = do where shouldDumpBuildInfo = fromFlagOrDefault NoDumpBuildInfo dumpBuildInfoFlag == DumpBuildInfo - -- | Given the flavor of the compiler, try to find out + -- \| Given the flavor of the compiler, try to find out -- which program we need. flavorToProgram :: CompilerFlavor -> Maybe Program - flavorToProgram GHC = Just ghcProgram - flavorToProgram GHCJS = Just ghcjsProgram - flavorToProgram UHC = Just uhcProgram - flavorToProgram JHC = Just jhcProgram - flavorToProgram HaskellSuite {} = Just haskellSuiteProgram - flavorToProgram _ = Nothing - - -repl :: PackageDescription -- ^ Mostly information from the .cabal file - -> LocalBuildInfo -- ^ Configuration information - -> ReplFlags -- ^ Flags that the user passed to build - -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling - -> [String] - -> IO () + flavorToProgram GHC = Just ghcProgram + flavorToProgram GHCJS = Just ghcjsProgram + flavorToProgram UHC = Just uhcProgram + flavorToProgram JHC = Just jhcProgram + flavorToProgram HaskellSuite{} = Just haskellSuiteProgram + flavorToProgram _ = Nothing + +repl + :: PackageDescription + -- ^ Mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> ReplFlags + -- ^ Flags that the user passed to build + -> [PPSuffixHandler] + -- ^ preprocessors to run before compiling + -> [String] + -> IO () repl pkg_descr lbi flags suffixes args = do - let distPref = fromFlag (replDistPref flags) + let distPref = fromFlag (replDistPref flags) verbosity = fromFlag (replVerbosity flags) - target <- readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of - -- This seems DEEPLY questionable. - [] -> case allTargetsInBuildOrder' pkg_descr lbi of - (target:_) -> return target - [] -> die' verbosity $ "Failed to determine target." - [target] -> return target - _ -> die' verbosity $ "The 'repl' command does not support multiple targets at once." + target <- + readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of + -- This seems DEEPLY questionable. + [] -> case allTargetsInBuildOrder' pkg_descr lbi of + (target : _) -> return target + [] -> die' verbosity $ "Failed to determine target." + [target] -> return target + _ -> die' verbosity $ "The 'repl' command does not support multiple targets at once." let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target] - debug verbosity $ "Component build order: " - ++ intercalate ", " - (map (showComponentName . componentLocalName . targetCLBI) - componentsToBuild) + debug verbosity $ + "Component build order: " + ++ intercalate + ", " + ( map + (showComponentName . componentLocalName . targetCLBI) + componentsToBuild + ) internalPackageDB <- createInternalPackageDB verbosity lbi distPref let lbiForComponent comp lbi' = - lbi' { - withPackageDB = withPackageDB lbi ++ [internalPackageDB], - withPrograms = addInternalBuildTools pkg_descr lbi' - (componentBuildInfo comp) (withPrograms lbi') - } + lbi' + { withPackageDB = withPackageDB lbi ++ [internalPackageDB] + , withPrograms = + addInternalBuildTools + pkg_descr + lbi' + (componentBuildInfo comp) + (withPrograms lbi') + } -- build any dependent components sequence_ - [ do let clbi = targetCLBI subtarget - comp = targetComponent subtarget - lbi' = lbiForComponent comp lbi - componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity - buildComponent verbosity NoFlag - pkg_descr lbi' suffixes comp clbi distPref - | subtarget <- safeInit componentsToBuild ] + [ do + let clbi = targetCLBI subtarget + comp = targetComponent subtarget + lbi' = lbiForComponent comp lbi + componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity + buildComponent + verbosity + NoFlag + pkg_descr + lbi' + suffixes + comp + clbi + distPref + | subtarget <- safeInit componentsToBuild + ] -- REPL for target components let clbi = targetCLBI target @@ -250,39 +301,58 @@ repl pkg_descr lbi flags suffixes args = do componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity replComponent replFlags verbosity pkg_descr lbi' suffixes comp clbi distPref - -- | Start an interpreter without loading any package files. -startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform - -> PackageDBStack -> IO () +startInterpreter + :: Verbosity + -> ProgramDb + -> Compiler + -> Platform + -> PackageDBStack + -> IO () startInterpreter verbosity programDb comp platform packageDBs = case compilerFlavor comp of - GHC -> GHC.startInterpreter verbosity programDb comp platform packageDBs + GHC -> GHC.startInterpreter verbosity programDb comp platform packageDBs GHCJS -> GHCJS.startInterpreter verbosity programDb comp platform packageDBs - _ -> die' verbosity "A REPL is not supported with this compiler." - -buildComponent :: Verbosity - -> Flag (Maybe Int) - -> PackageDescription - -> LocalBuildInfo - -> [PPSuffixHandler] - -> Component - -> ComponentLocalBuildInfo - -> FilePath - -> IO (Maybe InstalledPackageInfo) -buildComponent verbosity numJobs pkg_descr lbi suffixes - comp@(CLib lib) clbi distPref = do + _ -> die' verbosity "A REPL is not supported with this compiler." + +buildComponent + :: Verbosity + -> Flag (Maybe Int) + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> Component + -> ComponentLocalBuildInfo + -> FilePath + -> IO (Maybe InstalledPackageInfo) +buildComponent + verbosity + numJobs + pkg_descr + lbi + suffixes + comp@(CLib lib) + clbi + distPref = do preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes extras <- preprocessExtras verbosity comp lbi - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) + setupMessage' + verbosity + "Building" + (packageId pkg_descr) + (componentLocalName clbi) + (maybeComponentInstantiatedWith clbi) let libbi = libBuildInfo lib - lib' = lib { libBuildInfo = flip addExtraAsmSources extras - $ flip addExtraCmmSources extras - $ flip addExtraCxxSources extras - $ flip addExtraCSources extras - $ flip addExtraJsSources extras - $ libbi - } + lib' = + lib + { libBuildInfo = + flip addExtraAsmSources extras $ + flip addExtraCmmSources extras $ + flip addExtraCxxSources extras $ + flip addExtraCSources extras $ + flip addExtraJsSources extras $ + libbi + } buildLib verbosity numJobs pkg_descr lbi lib' clbi @@ -296,262 +366,382 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes -- Register the library in-place, so exes can depend -- on internally defined libraries. pwd <- getCurrentDirectory - let -- The in place registration uses the "-inplace" suffix, not an ABI hash - installedPkgInfo = inplaceInstalledPackageInfo pwd distPref pkg_descr - -- NB: Use a fake ABI hash to avoid - -- needing to recompute it every build. - (mkAbiHash "inplace") lib' lbi clbi + let + -- The in place registration uses the "-inplace" suffix, not an ABI hash + installedPkgInfo = + inplaceInstalledPackageInfo + pwd + distPref + pkg_descr + -- NB: Use a fake ABI hash to avoid + -- needing to recompute it every build. + (mkAbiHash "inplace") + lib' + lbi + clbi debug verbosity $ "Registering inplace:\n" ++ (IPI.showInstalledPackageInfo installedPkgInfo) - registerPackage verbosity (compiler lbi) (withPrograms lbi) - (withPackageDB lbi) installedPkgInfo - HcPkg.defaultRegisterOptions { - HcPkg.registerMultiInstance = True - } + registerPackage + verbosity + (compiler lbi) + (withPrograms lbi) + (withPackageDB lbi) + installedPkgInfo + HcPkg.defaultRegisterOptions + { HcPkg.registerMultiInstance = True + } return (Just installedPkgInfo) else return Nothing - -buildComponent verbosity numJobs pkg_descr lbi suffixes - comp@(CFLib flib) clbi _distPref = do +buildComponent + verbosity + numJobs + pkg_descr + lbi + suffixes + comp@(CFLib flib) + clbi + _distPref = do preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) + setupMessage' + verbosity + "Building" + (packageId pkg_descr) + (componentLocalName clbi) + (maybeComponentInstantiatedWith clbi) buildFLib verbosity numJobs pkg_descr lbi flib clbi return Nothing - -buildComponent verbosity numJobs pkg_descr lbi suffixes - comp@(CExe exe) clbi _ = do +buildComponent + verbosity + numJobs + pkg_descr + lbi + suffixes + comp@(CExe exe) + clbi + _ = do preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes extras <- preprocessExtras verbosity comp lbi - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) + setupMessage' + verbosity + "Building" + (packageId pkg_descr) + (componentLocalName clbi) + (maybeComponentInstantiatedWith clbi) let ebi = buildInfo exe - exe' = exe { buildInfo = addExtraCSources ebi extras } + exe' = exe{buildInfo = addExtraCSources ebi extras} buildExe verbosity numJobs pkg_descr lbi exe' clbi return Nothing - - -buildComponent verbosity numJobs pkg_descr lbi suffixes - comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} }) - clbi _distPref = do +buildComponent + verbosity + numJobs + pkg_descr + lbi + suffixes + comp@(CTest test@TestSuite{testInterface = TestSuiteExeV10{}}) + clbi + _distPref = do let exe = testSuiteExeV10AsExe test preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes extras <- preprocessExtras verbosity comp lbi (genDir, generatedExtras) <- generateCode (testCodeGenerators test) (testName test) pkg_descr (testBuildInfo test) lbi clbi verbosity - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) + setupMessage' + verbosity + "Building" + (packageId pkg_descr) + (componentLocalName clbi) + (maybeComponentInstantiatedWith clbi) let ebi = buildInfo exe - exe' = exe { buildInfo = addSrcDir (addExtraOtherModules (addExtraCSources ebi extras) generatedExtras) genDir } -- todo extend hssrcdirs + exe' = exe{buildInfo = addSrcDir (addExtraOtherModules (addExtraCSources ebi extras) generatedExtras) genDir} -- todo extend hssrcdirs buildExe verbosity numJobs pkg_descr lbi exe' clbi return Nothing - -buildComponent verbosity numJobs pkg_descr lbi0 suffixes - comp@(CTest - test@TestSuite { testInterface = TestSuiteLibV09{} }) - clbi -- This ComponentLocalBuildInfo corresponds to a detailed - -- test suite and not a real component. It should not - -- be used, except to construct the CLBIs for the - -- library and stub executable that will actually be - -- built. - distPref = do +buildComponent + verbosity + numJobs + pkg_descr + lbi0 + suffixes + comp@( CTest + test@TestSuite{testInterface = TestSuiteLibV09{}} + ) + clbi -- This ComponentLocalBuildInfo corresponds to a detailed + -- test suite and not a real component. It should not + -- be used, except to construct the CLBIs for the + -- library and stub executable that will actually be + -- built. + distPref = do pwd <- getCurrentDirectory let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) = testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes extras <- preprocessExtras verbosity comp lbi -- TODO find cpphs processed files (genDir, generatedExtras) <- generateCode (testCodeGenerators test) (testName test) pkg_descr (testBuildInfo test) lbi clbi verbosity - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) + setupMessage' + verbosity + "Building" + (packageId pkg_descr) + (componentLocalName clbi) + (maybeComponentInstantiatedWith clbi) let libbi = libBuildInfo lib - lib' = lib { libBuildInfo = addSrcDir (addExtraOtherModules libbi generatedExtras) genDir } + lib' = lib{libBuildInfo = addSrcDir (addExtraOtherModules libbi generatedExtras) genDir} buildLib verbosity numJobs pkg lbi lib' libClbi -- NB: need to enable multiple instances here, because on 7.10+ -- the package name is the same as the library, and we still -- want the registration to go through. - registerPackage verbosity (compiler lbi) (withPrograms lbi) - (withPackageDB lbi) ipi - HcPkg.defaultRegisterOptions { - HcPkg.registerMultiInstance = True - } + registerPackage + verbosity + (compiler lbi) + (withPrograms lbi) + (withPackageDB lbi) + ipi + HcPkg.defaultRegisterOptions + { HcPkg.registerMultiInstance = True + } let ebi = buildInfo exe -- NB: The stub executable is linked against the test-library -- which already contains all `other-modules`, so we need -- to remove those from the stub-exe's build-info - exe' = exe { buildInfo = (addExtraCSources ebi extras) { otherModules = [] } } + exe' = exe{buildInfo = (addExtraCSources ebi extras){otherModules = []}} buildExe verbosity numJobs pkg_descr lbi exe' exeClbi return Nothing -- Can't depend on test suite - - -buildComponent verbosity _ _ _ _ - (CTest TestSuite { testInterface = TestSuiteUnsupported tt }) - _ _ = +buildComponent + verbosity + _ + _ + _ + _ + (CTest TestSuite{testInterface = TestSuiteUnsupported tt}) + _ + _ = die' verbosity $ "No support for building test suite type " ++ prettyShow tt - - -buildComponent verbosity numJobs pkg_descr lbi suffixes - comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} }) - clbi _distPref = do +buildComponent + verbosity + numJobs + pkg_descr + lbi + suffixes + comp@(CBench bm@Benchmark{benchmarkInterface = BenchmarkExeV10{}}) + clbi + _distPref = do let exe = benchmarkExeV10asExe bm preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes extras <- preprocessExtras verbosity comp lbi - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) + setupMessage' + verbosity + "Building" + (packageId pkg_descr) + (componentLocalName clbi) + (maybeComponentInstantiatedWith clbi) let ebi = buildInfo exe - exe' = exe { buildInfo = addExtraCSources ebi extras } + exe' = exe{buildInfo = addExtraCSources ebi extras} buildExe verbosity numJobs pkg_descr lbi exe' clbi return Nothing - - -buildComponent verbosity _ _ _ _ - (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt }) - _ _ = +buildComponent + verbosity + _ + _ + _ + _ + (CBench Benchmark{benchmarkInterface = BenchmarkUnsupported tt}) + _ + _ = die' verbosity $ "No support for building benchmark type " ++ prettyShow tt - - generateCode - :: [String] - -> UnqualComponentName - -> PackageDescription - -> BuildInfo - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Verbosity - -> IO (FilePath, [ModuleName.ModuleName]) + :: [String] + -> UnqualComponentName + -> PackageDescription + -> BuildInfo + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Verbosity + -> IO (FilePath, [ModuleName.ModuleName]) generateCode codeGens nm pdesc bi lbi clbi verbosity = do - when (not . null $ codeGens) $ createDirectoryIfMissingVerbose verbosity True tgtDir - (\x -> (tgtDir,x)) . concat <$> mapM go codeGens - where - allLibs = (maybe id (:) $ library pdesc) (subLibraries pdesc) - dependencyLibs = filter (const True) allLibs -- intersect with componentPackageDeps of clbi - srcDirs = concatMap (hsSourceDirs . libBuildInfo) dependencyLibs - nm' = unUnqualComponentName nm - tgtDir = buildDir lbi nm' nm' ++ "-gen" - go :: String -> IO [ModuleName.ModuleName] - go codeGenProg = fmap fromString . lines <$> getDbProgramOutput verbosity (simpleProgram codeGenProg) (withPrograms lbi) - ((tgtDir : map getSymbolicPath srcDirs) ++ - ("--" : - GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) (GHC.componentGhcOptions verbosity lbi bi clbi tgtDir))) - + when (not . null $ codeGens) $ createDirectoryIfMissingVerbose verbosity True tgtDir + (\x -> (tgtDir, x)) . concat <$> mapM go codeGens + where + allLibs = (maybe id (:) $ library pdesc) (subLibraries pdesc) + dependencyLibs = filter (const True) allLibs -- intersect with componentPackageDeps of clbi + srcDirs = concatMap (hsSourceDirs . libBuildInfo) dependencyLibs + nm' = unUnqualComponentName nm + tgtDir = buildDir lbi nm' nm' ++ "-gen" + go :: String -> IO [ModuleName.ModuleName] + go codeGenProg = + fmap fromString . lines + <$> getDbProgramOutput + verbosity + (simpleProgram codeGenProg) + (withPrograms lbi) + ( (tgtDir : map getSymbolicPath srcDirs) + ++ ( "--" + : GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) (GHC.componentGhcOptions verbosity lbi bi clbi tgtDir) + ) + ) -- | Add extra C sources generated by preprocessing to build -- information. addExtraCSources :: BuildInfo -> [FilePath] -> BuildInfo -addExtraCSources bi extras = bi { cSources = new } - where new = ordNub (extras ++ cSources bi) +addExtraCSources bi extras = bi{cSources = new} + where + new = ordNub (extras ++ cSources bi) -- | Add extra C++ sources generated by preprocessing to build -- information. addExtraCxxSources :: BuildInfo -> [FilePath] -> BuildInfo -addExtraCxxSources bi extras = bi { cxxSources = new } - where new = ordNub (extras ++ cxxSources bi) +addExtraCxxSources bi extras = bi{cxxSources = new} + where + new = ordNub (extras ++ cxxSources bi) -- | Add extra C-- sources generated by preprocessing to build -- information. addExtraCmmSources :: BuildInfo -> [FilePath] -> BuildInfo -addExtraCmmSources bi extras = bi { cmmSources = new } - where new = ordNub (extras ++ cmmSources bi) +addExtraCmmSources bi extras = bi{cmmSources = new} + where + new = ordNub (extras ++ cmmSources bi) -- | Add extra ASM sources generated by preprocessing to build -- information. addExtraAsmSources :: BuildInfo -> [FilePath] -> BuildInfo -addExtraAsmSources bi extras = bi { asmSources = new } - where new = ordNub (extras ++ asmSources bi) +addExtraAsmSources bi extras = bi{asmSources = new} + where + new = ordNub (extras ++ asmSources bi) -- | Add extra JS sources generated by preprocessing to build -- information. addExtraJsSources :: BuildInfo -> [FilePath] -> BuildInfo -addExtraJsSources bi extras = bi { jsSources = new } - where new = ordNub (extras ++ jsSources bi) - +addExtraJsSources bi extras = bi{jsSources = new} + where + new = ordNub (extras ++ jsSources bi) -- | Add extra HS modules generated by preprocessing to build -- information. addExtraOtherModules :: BuildInfo -> [ModuleName.ModuleName] -> BuildInfo -addExtraOtherModules bi extras = bi { otherModules = new } - where new = ordNub (extras ++ otherModules bi) +addExtraOtherModules bi extras = bi{otherModules = new} + where + new = ordNub (extras ++ otherModules bi) -- | Add extra source dir for generated modules. addSrcDir :: BuildInfo -> FilePath -> BuildInfo -addSrcDir bi extra = bi { hsSourceDirs = new } - where new = ordNub (unsafeMakeSymbolicPath extra : hsSourceDirs bi) - -replComponent :: ReplOptions - -> Verbosity - -> PackageDescription - -> LocalBuildInfo - -> [PPSuffixHandler] - -> Component - -> ComponentLocalBuildInfo - -> FilePath - -> IO () -replComponent replFlags verbosity pkg_descr lbi suffixes - comp@(CLib lib) clbi _ = do +addSrcDir bi extra = bi{hsSourceDirs = new} + where + new = ordNub (unsafeMakeSymbolicPath extra : hsSourceDirs bi) + +replComponent + :: ReplOptions + -> Verbosity + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> Component + -> ComponentLocalBuildInfo + -> FilePath + -> IO () +replComponent + replFlags + verbosity + pkg_descr + lbi + suffixes + comp@(CLib lib) + clbi + _ = do preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes extras <- preprocessExtras verbosity comp lbi let libbi = libBuildInfo lib - lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } } + lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ extras}} replLib replFlags verbosity pkg_descr lbi lib' clbi - -replComponent replFlags verbosity pkg_descr lbi suffixes - comp@(CFLib flib) clbi _ = do +replComponent + replFlags + verbosity + pkg_descr + lbi + suffixes + comp@(CFLib flib) + clbi + _ = do preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes replFLib replFlags verbosity pkg_descr lbi flib clbi - -replComponent replFlags verbosity pkg_descr lbi suffixes - comp@(CExe exe) clbi _ = do +replComponent + replFlags + verbosity + pkg_descr + lbi + suffixes + comp@(CExe exe) + clbi + _ = do preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes extras <- preprocessExtras verbosity comp lbi let ebi = buildInfo exe - exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } } + exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}} replExe replFlags verbosity pkg_descr lbi exe' clbi - - -replComponent replFlags verbosity pkg_descr lbi suffixes - comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} }) - clbi _distPref = do +replComponent + replFlags + verbosity + pkg_descr + lbi + suffixes + comp@(CTest test@TestSuite{testInterface = TestSuiteExeV10{}}) + clbi + _distPref = do let exe = testSuiteExeV10AsExe test preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes extras <- preprocessExtras verbosity comp lbi let ebi = buildInfo exe - exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } } + exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}} replExe replFlags verbosity pkg_descr lbi exe' clbi - - -replComponent replFlags verbosity pkg_descr lbi0 suffixes - comp@(CTest - test@TestSuite { testInterface = TestSuiteLibV09{} }) - clbi distPref = do +replComponent + replFlags + verbosity + pkg_descr + lbi0 + suffixes + comp@( CTest + test@TestSuite{testInterface = TestSuiteLibV09{}} + ) + clbi + distPref = do pwd <- getCurrentDirectory let (pkg, lib, libClbi, lbi, _, _, _) = testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes extras <- preprocessExtras verbosity comp lbi let libbi = libBuildInfo lib - lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } } + lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ extras}} replLib replFlags verbosity pkg lbi lib' libClbi - - -replComponent _ verbosity _ _ _ - (CTest TestSuite { testInterface = TestSuiteUnsupported tt }) - _ _ = +replComponent + _ + verbosity + _ + _ + _ + (CTest TestSuite{testInterface = TestSuiteUnsupported tt}) + _ + _ = die' verbosity $ "No support for building test suite type " ++ prettyShow tt - - -replComponent replFlags verbosity pkg_descr lbi suffixes - comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} }) - clbi _distPref = do +replComponent + replFlags + verbosity + pkg_descr + lbi + suffixes + comp@(CBench bm@Benchmark{benchmarkInterface = BenchmarkExeV10{}}) + clbi + _distPref = do let exe = benchmarkExeV10asExe bm preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes extras <- preprocessExtras verbosity comp lbi let ebi = buildInfo exe - exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } } + exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}} replExe replFlags verbosity pkg_descr lbi exe' clbi - - -replComponent _ verbosity _ _ _ - (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt }) - _ _ = +replComponent + _ + verbosity + _ + _ + _ + (CBench Benchmark{benchmarkInterface = BenchmarkUnsupported tt}) + _ + _ = die' verbosity $ "No support for building benchmark type " ++ prettyShow tt ---------------------------------------------------- @@ -560,272 +750,349 @@ replComponent _ verbosity _ _ _ -- | Translate a exe-style 'TestSuite' component into an exe for building testSuiteExeV10AsExe :: TestSuite -> Executable -testSuiteExeV10AsExe test@TestSuite { testInterface = TestSuiteExeV10 _ mainFile } = - Executable { - exeName = testName test, - modulePath = mainFile, - exeScope = ExecutablePublic, - buildInfo = testBuildInfo test +testSuiteExeV10AsExe test@TestSuite{testInterface = TestSuiteExeV10 _ mainFile} = + Executable + { exeName = testName test + , modulePath = mainFile + , exeScope = ExecutablePublic + , buildInfo = testBuildInfo test } testSuiteExeV10AsExe TestSuite{} = error "testSuiteExeV10AsExe: wrong kind" -- | Translate a exe-style 'Benchmark' component into an exe for building benchmarkExeV10asExe :: Benchmark -> Executable -benchmarkExeV10asExe bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ mainFile } = - Executable { - exeName = benchmarkName bm, - modulePath = mainFile, - exeScope = ExecutablePublic, - buildInfo = benchmarkBuildInfo bm +benchmarkExeV10asExe bm@Benchmark{benchmarkInterface = BenchmarkExeV10 _ mainFile} = + Executable + { exeName = benchmarkName bm + , modulePath = mainFile + , exeScope = ExecutablePublic + , buildInfo = benchmarkBuildInfo bm } benchmarkExeV10asExe Benchmark{} = error "benchmarkExeV10asExe: wrong kind" -- | Translate a lib-style 'TestSuite' component into a lib + exe for building -testSuiteLibV09AsLibAndExe :: PackageDescription - -> TestSuite - -> ComponentLocalBuildInfo - -> LocalBuildInfo - -> FilePath - -> FilePath - -> (PackageDescription, - Library, ComponentLocalBuildInfo, - LocalBuildInfo, - IPI.InstalledPackageInfo, - Executable, ComponentLocalBuildInfo) -testSuiteLibV09AsLibAndExe pkg_descr - test@TestSuite { testInterface = TestSuiteLibV09 _ m } - clbi lbi distPref pwd = +testSuiteLibV09AsLibAndExe + :: PackageDescription + -> TestSuite + -> ComponentLocalBuildInfo + -> LocalBuildInfo + -> FilePath + -> FilePath + -> ( PackageDescription + , Library + , ComponentLocalBuildInfo + , LocalBuildInfo + , IPI.InstalledPackageInfo + , Executable + , ComponentLocalBuildInfo + ) +testSuiteLibV09AsLibAndExe + pkg_descr + test@TestSuite{testInterface = TestSuiteLibV09 _ m} + clbi + lbi + distPref + pwd = (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) - where - bi = testBuildInfo test - lib = Library { - libName = LMainLibName, - exposedModules = [ m ], - reexportedModules = [], - signatures = [], - libExposed = True, - libVisibility = LibraryVisibilityPrivate, - libBuildInfo = bi + where + bi = testBuildInfo test + lib = + Library + { libName = LMainLibName + , exposedModules = [m] + , reexportedModules = [] + , signatures = [] + , libExposed = True + , libVisibility = LibraryVisibilityPrivate + , libBuildInfo = bi } - -- This is, like, the one place where we use a CTestName for a library. - -- Should NOT use library name, since that could conflict! - PackageIdentifier pkg_name pkg_ver = package pkg_descr - -- Note: we do make internal library from the test! - compat_name = MungedPackageName pkg_name (LSubLibName (testName test)) - compat_key = computeCompatPackageKey (compiler lbi) compat_name pkg_ver (componentUnitId clbi) - libClbi = LibComponentLocalBuildInfo - { componentPackageDeps = componentPackageDeps clbi - , componentInternalDeps = componentInternalDeps clbi - , componentIsIndefinite_ = False - , componentExeDeps = componentExeDeps clbi - , componentLocalName = CLibName $ LSubLibName $ testName test - , componentIsPublic = False - , componentIncludes = componentIncludes clbi - , componentUnitId = componentUnitId clbi - , componentComponentId = componentComponentId clbi - , componentInstantiatedWith = [] - , componentCompatPackageName = compat_name - , componentCompatPackageKey = compat_key - , componentExposedModules = [IPI.ExposedModule m Nothing] - } - pkgName' = mkPackageName $ prettyShow compat_name - pkg = pkg_descr { - package = (package pkg_descr) { pkgName = pkgName' } - , executables = [] - , testSuites = [] + -- This is, like, the one place where we use a CTestName for a library. + -- Should NOT use library name, since that could conflict! + PackageIdentifier pkg_name pkg_ver = package pkg_descr + -- Note: we do make internal library from the test! + compat_name = MungedPackageName pkg_name (LSubLibName (testName test)) + compat_key = computeCompatPackageKey (compiler lbi) compat_name pkg_ver (componentUnitId clbi) + libClbi = + LibComponentLocalBuildInfo + { componentPackageDeps = componentPackageDeps clbi + , componentInternalDeps = componentInternalDeps clbi + , componentIsIndefinite_ = False + , componentExeDeps = componentExeDeps clbi + , componentLocalName = CLibName $ LSubLibName $ testName test + , componentIsPublic = False + , componentIncludes = componentIncludes clbi + , componentUnitId = componentUnitId clbi + , componentComponentId = componentComponentId clbi + , componentInstantiatedWith = [] + , componentCompatPackageName = compat_name + , componentCompatPackageKey = compat_key + , componentExposedModules = [IPI.ExposedModule m Nothing] + } + pkgName' = mkPackageName $ prettyShow compat_name + pkg = + pkg_descr + { package = (package pkg_descr){pkgName = pkgName'} + , executables = [] + , testSuites = [] , subLibraries = [lib] } - ipi = inplaceInstalledPackageInfo pwd distPref pkg (mkAbiHash "") lib lbi libClbi - testDir = buildDir lbi stubName test - stubName test ++ "-tmp" - testLibDep = Dependency - pkgName' - (thisVersion $ pkgVersion $ package pkg_descr) - mainLibSet - exe = Executable { - exeName = mkUnqualComponentName $ stubName test, - modulePath = stubFilePath test, - exeScope = ExecutablePublic, - buildInfo = (testBuildInfo test) { - hsSourceDirs = [ unsafeMakeSymbolicPath testDir ], - targetBuildDepends = testLibDep - : (targetBuildDepends $ testBuildInfo test) - } + ipi = inplaceInstalledPackageInfo pwd distPref pkg (mkAbiHash "") lib lbi libClbi + testDir = + buildDir lbi + stubName test + stubName test + ++ "-tmp" + testLibDep = + Dependency + pkgName' + (thisVersion $ pkgVersion $ package pkg_descr) + mainLibSet + exe = + Executable + { exeName = mkUnqualComponentName $ stubName test + , modulePath = stubFilePath test + , exeScope = ExecutablePublic + , buildInfo = + (testBuildInfo test) + { hsSourceDirs = [unsafeMakeSymbolicPath testDir] + , targetBuildDepends = + testLibDep + : (targetBuildDepends $ testBuildInfo test) + } + } + -- \| The stub executable needs a new 'ComponentLocalBuildInfo' + -- that exposes the relevant test suite library. + deps = + (IPI.installedUnitId ipi, mungedId ipi) + : ( filter + ( \(_, x) -> + let name = prettyShow $ mungedName x + in name == "Cabal" || name == "base" + ) + (componentPackageDeps clbi) + ) + exeClbi = + ExeComponentLocalBuildInfo + { -- TODO: this is a hack, but as long as this is unique + -- (doesn't clobber something) we won't run into trouble + componentUnitId = mkUnitId (stubName test) + , componentComponentId = mkComponentId (stubName test) + , componentInternalDeps = [componentUnitId clbi] + , componentExeDeps = [] + , componentLocalName = CExeName $ mkUnqualComponentName $ stubName test + , componentPackageDeps = deps + , -- Assert DefUnitId invariant! + -- Executable can't be indefinite, so dependencies must + -- be definite packages. + componentIncludes = + zip + (map (DefiniteUnitId . unsafeMkDefUnitId . fst) deps) + (repeat defaultRenaming) } - -- | The stub executable needs a new 'ComponentLocalBuildInfo' - -- that exposes the relevant test suite library. - deps = (IPI.installedUnitId ipi, mungedId ipi) - : (filter (\(_, x) -> let name = prettyShow $ mungedName x - in name == "Cabal" || name == "base") - (componentPackageDeps clbi)) - exeClbi = ExeComponentLocalBuildInfo { - -- TODO: this is a hack, but as long as this is unique - -- (doesn't clobber something) we won't run into trouble - componentUnitId = mkUnitId (stubName test), - componentComponentId = mkComponentId (stubName test), - componentInternalDeps = [componentUnitId clbi], - componentExeDeps = [], - componentLocalName = CExeName $ mkUnqualComponentName $ stubName test, - componentPackageDeps = deps, - -- Assert DefUnitId invariant! - -- Executable can't be indefinite, so dependencies must - -- be definite packages. - componentIncludes = zip (map (DefiniteUnitId . unsafeMkDefUnitId . fst) deps) - (repeat defaultRenaming) - } testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind" - -- | Initialize a new package db file for libraries defined -- internally to the package. -createInternalPackageDB :: Verbosity -> LocalBuildInfo -> FilePath - -> IO PackageDB +createInternalPackageDB + :: Verbosity + -> LocalBuildInfo + -> FilePath + -> IO PackageDB createInternalPackageDB verbosity lbi distPref = do - existsAlready <- doesPackageDBExist dbPath - when existsAlready $ deletePackageDB dbPath - createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath - return (SpecificPackageDB dbPath) + existsAlready <- doesPackageDBExist dbPath + when existsAlready $ deletePackageDB dbPath + createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath + return (SpecificPackageDB dbPath) where dbPath = internalPackageDBPath lbi distPref -addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo - -> ProgramDb -> ProgramDb +addInternalBuildTools + :: PackageDescription + -> LocalBuildInfo + -> BuildInfo + -> ProgramDb + -> ProgramDb addInternalBuildTools pkg lbi bi progs = - foldr updateProgram progs internalBuildTools + foldr updateProgram progs internalBuildTools where internalBuildTools = [ simpleConfiguredProgram toolName' (FoundOnSystem toolLocation) | toolName <- getAllInternalToolDependencies pkg bi , let toolName' = unUnqualComponentName toolName - , let toolLocation = buildDir lbi toolName' toolName' <.> exeExtension (hostPlatform lbi) ] - + , let toolLocation = buildDir lbi toolName' toolName' <.> exeExtension (hostPlatform lbi) + ] -- TODO: build separate libs in separate dirs so that we can build -- multiple libs, e.g. for 'LibTest' library-style test suites -buildLib :: Verbosity -> Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () +buildLib + :: Verbosity + -> Flag (Maybe Int) + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () buildLib verbosity numJobs pkg_descr lbi lib clbi = case compilerFlavor (compiler lbi) of - GHC -> GHC.buildLib verbosity numJobs pkg_descr lbi lib clbi + GHC -> GHC.buildLib verbosity numJobs pkg_descr lbi lib clbi GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi - UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi - HaskellSuite {} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi - _ -> die' verbosity "Building is not supported with this compiler." + UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi + HaskellSuite{} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi + _ -> die' verbosity "Building is not supported with this compiler." -- | Build a foreign library -- -- NOTE: We assume that we already checked that we can actually build the -- foreign library in configure. -buildFLib :: Verbosity -> Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> ForeignLib -> ComponentLocalBuildInfo -> IO () +buildFLib + :: Verbosity + -> Flag (Maybe Int) + -> PackageDescription + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO () buildFLib verbosity numJobs pkg_descr lbi flib clbi = - case compilerFlavor (compiler lbi) of - GHC -> GHC.buildFLib verbosity numJobs pkg_descr lbi flib clbi - _ -> die' verbosity "Building is not supported with this compiler." - -buildExe :: Verbosity -> Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () + case compilerFlavor (compiler lbi) of + GHC -> GHC.buildFLib verbosity numJobs pkg_descr lbi flib clbi + _ -> die' verbosity "Building is not supported with this compiler." + +buildExe + :: Verbosity + -> Flag (Maybe Int) + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () buildExe verbosity numJobs pkg_descr lbi exe clbi = case compilerFlavor (compiler lbi) of - GHC -> GHC.buildExe verbosity numJobs pkg_descr lbi exe clbi + GHC -> GHC.buildExe verbosity numJobs pkg_descr lbi exe clbi GHCJS -> GHCJS.buildExe verbosity numJobs pkg_descr lbi exe clbi - UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi - _ -> die' verbosity "Building is not supported with this compiler." - -replLib :: ReplOptions -> Verbosity -> PackageDescription - -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo - -> IO () + UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi + _ -> die' verbosity "Building is not supported with this compiler." + +replLib + :: ReplOptions + -> Verbosity + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () replLib replFlags verbosity pkg_descr lbi lib clbi = case compilerFlavor (compiler lbi) of -- 'cabal repl' doesn't need to support 'ghc --make -j', so we just pass -- NoFlag as the numJobs parameter. - GHC -> GHC.replLib replFlags verbosity NoFlag pkg_descr lbi lib clbi + GHC -> GHC.replLib replFlags verbosity NoFlag pkg_descr lbi lib clbi GHCJS -> GHCJS.replLib (replOptionsFlags replFlags) verbosity NoFlag pkg_descr lbi lib clbi - _ -> die' verbosity "A REPL is not supported for this compiler." - -replExe :: ReplOptions -> Verbosity -> PackageDescription - -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo - -> IO () + _ -> die' verbosity "A REPL is not supported for this compiler." + +replExe + :: ReplOptions + -> Verbosity + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () replExe replFlags verbosity pkg_descr lbi exe clbi = case compilerFlavor (compiler lbi) of - GHC -> GHC.replExe replFlags verbosity NoFlag pkg_descr lbi exe clbi + GHC -> GHC.replExe replFlags verbosity NoFlag pkg_descr lbi exe clbi GHCJS -> GHCJS.replExe (replOptionsFlags replFlags) verbosity NoFlag pkg_descr lbi exe clbi - _ -> die' verbosity "A REPL is not supported for this compiler." - -replFLib :: ReplOptions -> Verbosity -> PackageDescription - -> LocalBuildInfo -> ForeignLib -> ComponentLocalBuildInfo - -> IO () + _ -> die' verbosity "A REPL is not supported for this compiler." + +replFLib + :: ReplOptions + -> Verbosity + -> PackageDescription + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO () replFLib replFlags verbosity pkg_descr lbi exe clbi = case compilerFlavor (compiler lbi) of GHC -> GHC.replFLib replFlags verbosity NoFlag pkg_descr lbi exe clbi - _ -> die' verbosity "A REPL is not supported for this compiler." + _ -> die' verbosity "A REPL is not supported for this compiler." -- | Runs 'componentInitialBuildSteps' on every configured component. -initialBuildSteps :: FilePath -- ^"dist" prefix - -> PackageDescription -- ^mostly information from the .cabal file - -> LocalBuildInfo -- ^Configuration information - -> Verbosity -- ^The verbosity to use - -> IO () +initialBuildSteps + :: FilePath + -- ^ "dist" prefix + -> PackageDescription + -- ^ mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> Verbosity + -- ^ The verbosity to use + -> IO () initialBuildSteps distPref pkg_descr lbi verbosity = - withAllComponentsInBuildOrder pkg_descr lbi $ \_comp clbi -> - componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity + withAllComponentsInBuildOrder pkg_descr lbi $ \_comp clbi -> + componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity -- | Creates the autogenerated files for a particular configured component. -componentInitialBuildSteps :: FilePath -- ^"dist" prefix - -> PackageDescription -- ^mostly information from the .cabal file - -> LocalBuildInfo -- ^Configuration information - -> ComponentLocalBuildInfo - -> Verbosity -- ^The verbosity to use - -> IO () +componentInitialBuildSteps + :: FilePath + -- ^ "dist" prefix + -> PackageDescription + -- ^ mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> ComponentLocalBuildInfo + -> Verbosity + -- ^ The verbosity to use + -> IO () componentInitialBuildSteps _distPref pkg_descr lbi clbi verbosity = do createDirectoryIfMissingVerbose verbosity True (componentBuildDir lbi clbi) writeAutogenFiles verbosity pkg_descr lbi clbi -- | Generate and write out the Paths_.hs, PackageInfo_.hs, and cabal_macros.h files --- -writeAutogenFiles :: Verbosity - -> PackageDescription - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> IO () +writeAutogenFiles + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> IO () writeAutogenFiles verbosity pkg lbi clbi = do createDirectoryIfMissingVerbose verbosity True (autogenComponentModulesDir lbi clbi) - let pathsModulePath = autogenComponentModulesDir lbi clbi - ModuleName.toFilePath (autogenPathsModuleName pkg) <.> "hs" + let pathsModulePath = + autogenComponentModulesDir lbi clbi + ModuleName.toFilePath (autogenPathsModuleName pkg) <.> "hs" pathsModuleDir = takeDirectory pathsModulePath -- Ensure that the directory exists! createDirectoryIfMissingVerbose verbosity True pathsModuleDir rewriteFileEx verbosity pathsModulePath (generatePathsModule pkg lbi clbi) - let packageInfoModulePath = autogenComponentModulesDir lbi clbi - ModuleName.toFilePath (autogenPackageInfoModuleName pkg) <.> "hs" + let packageInfoModulePath = + autogenComponentModulesDir lbi clbi + ModuleName.toFilePath (autogenPackageInfoModuleName pkg) <.> "hs" packageInfoModuleDir = takeDirectory packageInfoModulePath -- Ensure that the directory exists! createDirectoryIfMissingVerbose verbosity True packageInfoModuleDir rewriteFileEx verbosity packageInfoModulePath (generatePackageInfoModule pkg lbi) - --TODO: document what we're doing here, and move it to its own function + -- TODO: document what we're doing here, and move it to its own function case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> - -- Write out empty hsig files for all requirements, so that GHC - -- has a source file to look at it when it needs to typecheck - -- a signature. It's harmless to write these out even when - -- there is a real hsig file written by the user, since - -- include path ordering ensures that the real hsig file - -- will always be picked up before the autogenerated one. - for_ (map fst insts) $ \mod_name -> do - let sigPath = autogenComponentModulesDir lbi clbi - ModuleName.toFilePath mod_name <.> "hsig" - createDirectoryIfMissingVerbose verbosity True (takeDirectory sigPath) - rewriteFileEx verbosity sigPath $ - "{-# OPTIONS_GHC -w #-}\n" ++ - "{-# LANGUAGE NoImplicitPrelude #-}\n" ++ - "signature " ++ prettyShow mod_name ++ " where" + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> + -- Write out empty hsig files for all requirements, so that GHC + -- has a source file to look at it when it needs to typecheck + -- a signature. It's harmless to write these out even when + -- there is a real hsig file written by the user, since + -- include path ordering ensures that the real hsig file + -- will always be picked up before the autogenerated one. + for_ (map fst insts) $ \mod_name -> do + let sigPath = + autogenComponentModulesDir lbi clbi + ModuleName.toFilePath mod_name <.> "hsig" + createDirectoryIfMissingVerbose verbosity True (takeDirectory sigPath) + rewriteFileEx verbosity sigPath $ + "{-# OPTIONS_GHC -w #-}\n" + ++ "{-# LANGUAGE NoImplicitPrelude #-}\n" + ++ "signature " + ++ prettyShow mod_name + ++ " where" _ -> return () let cppHeaderPath = autogenComponentModulesDir lbi clbi cppHeaderName diff --git a/Cabal/src/Distribution/Simple/Build/Macros.hs b/Cabal/src/Distribution/Simple/Build/Macros.hs index db0e75a8a0c..3dbce8616fc 100644 --- a/Cabal/src/Distribution/Simple/Build/Macros.hs +++ b/Cabal/src/Distribution/Simple/Build/Macros.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Build.Macros -- Copyright : Simon Marlow 2008 @@ -19,92 +20,95 @@ -- -- TODO Figure out what to do about backpack and internal libraries. It is very -- suspicious that this stuff works with munged package identifiers -module Distribution.Simple.Build.Macros ( - generateCabalMacrosHeader, - generatePackageVersionMacros, +module Distribution.Simple.Build.Macros + ( generateCabalMacrosHeader + , generatePackageVersionMacros ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Version import Distribution.PackageDescription +import Distribution.Pretty import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program.Db import Distribution.Simple.Program.Types import Distribution.Types.MungedPackageId import Distribution.Types.MungedPackageName -import Distribution.Pretty +import Distribution.Version import qualified Distribution.Simple.Build.Macros.Z as Z -- | The contents of the @cabal_macros.h@ for the given configured package. --- generateCabalMacrosHeader :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> String -generateCabalMacrosHeader pkg_descr lbi clbi = Z.render Z.Z - { Z.zPackages = map mkZPackage $ package pkg_descr : map getPid (componentPackageDeps clbi) - , Z.zTools = - [ Z.ZTool - { Z.ztoolName = programId prog +generateCabalMacrosHeader pkg_descr lbi clbi = + Z.render + Z.Z + { Z.zPackages = map mkZPackage $ package pkg_descr : map getPid (componentPackageDeps clbi) + , Z.zTools = + [ Z.ZTool + { Z.ztoolName = programId prog , Z.ztoolVersion = ver - , Z.ztoolX = major1 - , Z.ztoolY = major2 - , Z.ztoolZ = minor + , Z.ztoolX = major1 + , Z.ztoolY = major2 + , Z.ztoolZ = minor } - | prog <- configuredPrograms $ withPrograms lbi - , ver <- maybeToList (programVersion prog) - , let (major1,major2,minor) = majorMinor ver - ] - , Z.zPackageKey = case clbi of - LibComponentLocalBuildInfo{} -> componentCompatPackageKey clbi - _ -> "" - , Z.zComponentId = prettyShow (componentComponentId clbi) - , Z.zPackageVersion = pkgVersion (package pkg_descr) - , Z.zNotNull = not . null - , Z.zManglePkgName = map fixchar . unPackageName - , Z.zMangleStr = map fixchar - } + | prog <- configuredPrograms $ withPrograms lbi + , ver <- maybeToList (programVersion prog) + , let (major1, major2, minor) = majorMinor ver + ] + , Z.zPackageKey = case clbi of + LibComponentLocalBuildInfo{} -> componentCompatPackageKey clbi + _ -> "" + , Z.zComponentId = prettyShow (componentComponentId clbi) + , Z.zPackageVersion = pkgVersion (package pkg_descr) + , Z.zNotNull = not . null + , Z.zManglePkgName = map fixchar . unPackageName + , Z.zMangleStr = map fixchar + } where getPid (_, MungedPackageId (MungedPackageName pn _) v) = - -- NB: Drop the library name! We're just reporting package versions. - -- This would have to be revisited if you are allowed to depend - -- on different versions of the same package - PackageIdentifier pn v + -- NB: Drop the library name! We're just reporting package versions. + -- This would have to be revisited if you are allowed to depend + -- on different versions of the same package + PackageIdentifier pn v -- | Helper function that generates just the @VERSION_pkg@ and @MIN_VERSION_pkg@ -- macros for a list of package ids (usually used with the specific deps of -- a configured package). --- generatePackageVersionMacros :: Version -> [PackageId] -> String -generatePackageVersionMacros ver pkgids = Z.render Z.Z - { Z.zPackages = map mkZPackage pkgids - , Z.zTools = [] - , Z.zPackageKey = "" - , Z.zComponentId = "" - , Z.zPackageVersion = ver - , Z.zNotNull = not . null - , Z.zManglePkgName = map fixchar . unPackageName - , Z.zMangleStr = map fixchar - } +generatePackageVersionMacros ver pkgids = + Z.render + Z.Z + { Z.zPackages = map mkZPackage pkgids + , Z.zTools = [] + , Z.zPackageKey = "" + , Z.zComponentId = "" + , Z.zPackageVersion = ver + , Z.zNotNull = not . null + , Z.zManglePkgName = map fixchar . unPackageName + , Z.zMangleStr = map fixchar + } mkZPackage :: PackageId -> Z.ZPackage -mkZPackage (PackageIdentifier name ver) = Z.ZPackage - { Z.zpkgName = name +mkZPackage (PackageIdentifier name ver) = + Z.ZPackage + { Z.zpkgName = name , Z.zpkgVersion = ver - , Z.zpkgX = major1 - , Z.zpkgY = major2 - , Z.zpkgZ = minor + , Z.zpkgX = major1 + , Z.zpkgY = major2 + , Z.zpkgZ = minor } where - (major1,major2,minor) = majorMinor ver + (major1, major2, minor) = majorMinor ver majorMinor :: Version -> (String, String, String) majorMinor ver = case map show (versionNumbers ver) of - [] -> ("0", "0", "0") - [x] -> (x, "0", "0") - [x,y] -> (x, y, "0") - (x:y:z:_) -> (x, y, z) + [] -> ("0", "0", "0") + [x] -> (x, "0", "0") + [x, y] -> (x, y, "0") + (x : y : z : _) -> (x, y, z) fixchar :: Char -> Char fixchar '-' = '_' -fixchar c = c +fixchar c = c diff --git a/Cabal/src/Distribution/Simple/Build/PackageInfoModule.hs b/Cabal/src/Distribution/Simple/Build/PackageInfoModule.hs index 6b33c0c84c0..66b4af7b05b 100644 --- a/Cabal/src/Distribution/Simple/Build/PackageInfoModule.hs +++ b/Cabal/src/Distribution/Simple/Build/PackageInfoModule.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Build.PackageInfoModule -- Copyright : @@ -10,9 +11,8 @@ -- -- This is a module that Cabal generates for the benefit of packages. It -- enables them to find their package informations. --- -module Distribution.Simple.Build.PackageInfoModule ( - generatePackageInfoModule +module Distribution.Simple.Build.PackageInfoModule + ( generatePackageInfoModule ) where import Distribution.Compat.Prelude @@ -28,29 +28,33 @@ import Distribution.Version import qualified Distribution.Simple.Build.PackageInfoModule.Z as Z -- ------------------------------------------------------------ + -- * Building Paths_.hs + -- ------------------------------------------------------------ generatePackageInfoModule :: PackageDescription -> LocalBuildInfo -> String -generatePackageInfoModule pkg_descr lbi = Z.render Z.Z - { Z.zPackageName = showPkgName $ packageName pkg_descr - , Z.zVersionDigits = show $ versionNumbers $ packageVersion pkg_descr - , Z.zSynopsis = fromShortText $ synopsis pkg_descr - , Z.zCopyright = fromShortText $ copyright pkg_descr - , Z.zHomepage = fromShortText $ homepage pkg_descr - , Z.zSupportsNoRebindableSyntax = supports_rebindable_syntax - } +generatePackageInfoModule pkg_descr lbi = + Z.render + Z.Z + { Z.zPackageName = showPkgName $ packageName pkg_descr + , Z.zVersionDigits = show $ versionNumbers $ packageVersion pkg_descr + , Z.zSynopsis = fromShortText $ synopsis pkg_descr + , Z.zCopyright = fromShortText $ copyright pkg_descr + , Z.zHomepage = fromShortText $ homepage pkg_descr + , Z.zSupportsNoRebindableSyntax = supports_rebindable_syntax + } where - supports_rebindable_syntax = ghc_newer_than (mkVersion [7,0,1]) + supports_rebindable_syntax = ghc_newer_than (mkVersion [7, 0, 1]) ghc_newer_than minVersion = - case compilerCompatVersion GHC (compiler lbi) of - Nothing -> False - Just version -> version `withinRange` orLaterVersion minVersion + case compilerCompatVersion GHC (compiler lbi) of + Nothing -> False + Just version -> version `withinRange` orLaterVersion minVersion showPkgName :: PackageName -> String showPkgName = map fixchar . unPackageName fixchar :: Char -> Char fixchar '-' = '_' -fixchar c = c +fixchar c = c diff --git a/Cabal/src/Distribution/Simple/Build/PackageInfoModule/Z.hs b/Cabal/src/Distribution/Simple/Build/PackageInfoModule/Z.hs index e96ed923045..6bc97314809 100644 --- a/Cabal/src/Distribution/Simple/Build/PackageInfoModule/Z.hs +++ b/Cabal/src/Distribution/Simple/Build/PackageInfoModule/Z.hs @@ -5,23 +5,23 @@ module Distribution.Simple.Build.PackageInfoModule.Z (render, Z (..)) where import Distribution.ZinzaPrelude data Z = Z - { zPackageName :: String, - zVersionDigits :: String, - zSynopsis :: String, - zCopyright :: String, - zHomepage :: String, - zSupportsNoRebindableSyntax :: Bool + { zPackageName :: String + , zVersionDigits :: String + , zSynopsis :: String + , zCopyright :: String + , zHomepage :: String + , zSupportsNoRebindableSyntax :: Bool } deriving (Generic) render :: Z -> String render z_root = execWriter $ do if (zSupportsNoRebindableSyntax z_root) - then do - tell "{-# LANGUAGE NoRebindableSyntax #-}\n" - return () - else do - return () + then do + tell "{-# LANGUAGE NoRebindableSyntax #-}\n" + return () + else do + return () tell "{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}\n" tell "{-# OPTIONS_GHC -w #-}\n" tell "module PackageInfo_" diff --git a/Cabal/src/Distribution/Simple/Build/PathsModule.hs b/Cabal/src/Distribution/Simple/Build/PathsModule.hs index b2be7e1a8fc..892e5bd384f 100644 --- a/Cabal/src/Distribution/Simple/Build/PathsModule.hs +++ b/Cabal/src/Distribution/Simple/Build/PathsModule.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Build.Macros -- Copyright : Isaac Jones 2003-2005, @@ -13,9 +14,9 @@ -- This is a module that Cabal generates for the benefit of packages. It -- enables them to find their version number and find any installed data files -- at runtime. This code should probably be split off into another module. --- -module Distribution.Simple.Build.PathsModule ( - generatePathsModule, pkgPathEnvVar +module Distribution.Simple.Build.PathsModule + ( generatePathsModule + , pkgPathEnvVar ) where import Distribution.Compat.Prelude @@ -25,121 +26,124 @@ import Distribution.Package import Distribution.PackageDescription import Distribution.Simple.Compiler import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Utils (shortRelativePath) +import Distribution.Simple.Utils (shortRelativePath) import Distribution.System import Distribution.Version import qualified Distribution.Simple.Build.PathsModule.Z as Z -- ------------------------------------------------------------ + -- * Building Paths_.hs + -- ------------------------------------------------------------ generatePathsModule :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> String -generatePathsModule pkg_descr lbi clbi = Z.render Z.Z - { Z.zPackageName = packageName pkg_descr - , Z.zVersionDigits = show $ versionNumbers $ packageVersion pkg_descr - , Z.zSupportsCpp = supports_cpp - , Z.zSupportsNoRebindableSyntax = supports_rebindable_syntax - , Z.zAbsolute = absolute - , Z.zRelocatable = relocatable lbi - , Z.zIsWindows = isWindows - , Z.zIsI386 = buildArch == I386 - , Z.zIsX8664 = buildArch == X86_64 - , Z.zNot = not - , Z.zManglePkgName = showPkgName - - , Z.zPrefix = show flat_prefix - , Z.zBindir = zBindir - , Z.zLibdir = zLibdir - , Z.zDynlibdir = zDynlibdir - , Z.zDatadir = zDatadir - , Z.zLibexecdir = zLibexecdir - , Z.zSysconfdir = zSysconfdir - } +generatePathsModule pkg_descr lbi clbi = + Z.render + Z.Z + { Z.zPackageName = packageName pkg_descr + , Z.zVersionDigits = show $ versionNumbers $ packageVersion pkg_descr + , Z.zSupportsCpp = supports_cpp + , Z.zSupportsNoRebindableSyntax = supports_rebindable_syntax + , Z.zAbsolute = absolute + , Z.zRelocatable = relocatable lbi + , Z.zIsWindows = isWindows + , Z.zIsI386 = buildArch == I386 + , Z.zIsX8664 = buildArch == X86_64 + , Z.zNot = not + , Z.zManglePkgName = showPkgName + , Z.zPrefix = show flat_prefix + , Z.zBindir = zBindir + , Z.zLibdir = zLibdir + , Z.zDynlibdir = zDynlibdir + , Z.zDatadir = zDatadir + , Z.zLibexecdir = zLibexecdir + , Z.zSysconfdir = zSysconfdir + } where - supports_cpp = supports_language_pragma - supports_rebindable_syntax = ghc_newer_than (mkVersion [7,0,1]) - supports_language_pragma = ghc_newer_than (mkVersion [6,6,1]) + supports_cpp = supports_language_pragma + supports_rebindable_syntax = ghc_newer_than (mkVersion [7, 0, 1]) + supports_language_pragma = ghc_newer_than (mkVersion [6, 6, 1]) ghc_newer_than minVersion = - case compilerCompatVersion GHC (compiler lbi) of - Nothing -> False - Just version -> version `withinRange` orLaterVersion minVersion + case compilerCompatVersion GHC (compiler lbi) of + Nothing -> False + Just version -> version `withinRange` orLaterVersion minVersion -- In several cases we cannot make relocatable installations absolute = - hasLibs pkg_descr -- we can only make progs relocatable - || isNothing flat_bindirrel -- if the bin dir is an absolute path - || not (supportsRelocatableProgs (compilerFlavor (compiler lbi))) + hasLibs pkg_descr -- we can only make progs relocatable + || isNothing flat_bindirrel -- if the bin dir is an absolute path + || not (supportsRelocatableProgs (compilerFlavor (compiler lbi))) -- TODO: Here, and with zIsI386 & zIs8664 we should use TARGET platform isWindows = case buildOS of - Windows -> True - _ -> False + Windows -> True + _ -> False - supportsRelocatableProgs GHC = isWindows + supportsRelocatableProgs GHC = isWindows supportsRelocatableProgs GHCJS = isWindows - supportsRelocatableProgs _ = False + supportsRelocatableProgs _ = False cid = componentUnitId clbi InstallDirs - { bindir = flat_bindir - , libdir = flat_libdir - , dynlibdir = flat_dynlibdir - , datadir = flat_datadir - , libexecdir = flat_libexecdir - , sysconfdir = flat_sysconfdir - , prefix = flat_prefix - } = absoluteInstallCommandDirs pkg_descr lbi cid NoCopyDest + { bindir = flat_bindir + , libdir = flat_libdir + , dynlibdir = flat_dynlibdir + , datadir = flat_datadir + , libexecdir = flat_libexecdir + , sysconfdir = flat_sysconfdir + , prefix = flat_prefix + } = absoluteInstallCommandDirs pkg_descr lbi cid NoCopyDest InstallDirs - { bindir = flat_bindirrel - , libdir = flat_libdirrel - , dynlibdir = flat_dynlibdirrel - , datadir = flat_datadirrel - , libexecdir = flat_libexecdirrel - , sysconfdir = flat_sysconfdirrel - } = prefixRelativeComponentInstallDirs (packageId pkg_descr) lbi cid + { bindir = flat_bindirrel + , libdir = flat_libdirrel + , dynlibdir = flat_dynlibdirrel + , datadir = flat_datadirrel + , libexecdir = flat_libexecdirrel + , sysconfdir = flat_sysconfdirrel + } = prefixRelativeComponentInstallDirs (packageId pkg_descr) lbi cid zBindir, zLibdir, zDynlibdir, zDatadir, zLibexecdir, zSysconfdir :: String (zBindir, zLibdir, zDynlibdir, zDatadir, zLibexecdir, zSysconfdir) - | relocatable lbi = - ( show flat_bindir_reloc - , show flat_libdir_reloc - , show flat_dynlibdir_reloc - , show flat_datadir_reloc - , show flat_libexecdir_reloc - , show flat_sysconfdir_reloc - ) - | absolute = - ( show flat_bindir - , show flat_libdir - , show flat_dynlibdir - , show flat_datadir - , show flat_libexecdir - , show flat_sysconfdir - ) - | isWindows = - ( "maybe (error \"PathsModule.generate\") id (" ++ show flat_bindirrel ++ ")" - , mkGetDir flat_libdir flat_libdirrel - , mkGetDir flat_dynlibdir flat_dynlibdirrel - , mkGetDir flat_datadir flat_datadirrel - , mkGetDir flat_libexecdir flat_libexecdirrel - , mkGetDir flat_sysconfdir flat_sysconfdirrel - ) - | otherwise = - error "panic! generatePathsModule: should never happen" + | relocatable lbi = + ( show flat_bindir_reloc + , show flat_libdir_reloc + , show flat_dynlibdir_reloc + , show flat_datadir_reloc + , show flat_libexecdir_reloc + , show flat_sysconfdir_reloc + ) + | absolute = + ( show flat_bindir + , show flat_libdir + , show flat_dynlibdir + , show flat_datadir + , show flat_libexecdir + , show flat_sysconfdir + ) + | isWindows = + ( "maybe (error \"PathsModule.generate\") id (" ++ show flat_bindirrel ++ ")" + , mkGetDir flat_libdir flat_libdirrel + , mkGetDir flat_dynlibdir flat_dynlibdirrel + , mkGetDir flat_datadir flat_datadirrel + , mkGetDir flat_libexecdir flat_libexecdirrel + , mkGetDir flat_sysconfdir flat_sysconfdirrel + ) + | otherwise = + error "panic! generatePathsModule: should never happen" mkGetDir :: FilePath -> Maybe FilePath -> String - mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel - mkGetDir dir Nothing = "return " ++ show dir + mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel + mkGetDir dir Nothing = "return " ++ show dir - flat_bindir_reloc = shortRelativePath flat_prefix flat_bindir - flat_libdir_reloc = shortRelativePath flat_prefix flat_libdir - flat_dynlibdir_reloc = shortRelativePath flat_prefix flat_dynlibdir - flat_datadir_reloc = shortRelativePath flat_prefix flat_datadir + flat_bindir_reloc = shortRelativePath flat_prefix flat_bindir + flat_libdir_reloc = shortRelativePath flat_prefix flat_libdir + flat_dynlibdir_reloc = shortRelativePath flat_prefix flat_dynlibdir + flat_datadir_reloc = shortRelativePath flat_prefix flat_datadir flat_libexecdir_reloc = shortRelativePath flat_prefix flat_libexecdir flat_sysconfdir_reloc = shortRelativePath flat_prefix flat_sysconfdir @@ -149,15 +153,17 @@ generatePathsModule pkg_descr lbi clbi = Z.render Z.Z -- Note: The format of these strings is part of Cabal's public API; -- changing this function constitutes a *backwards-compatibility* break. pkgPathEnvVar - :: PackageDescription - -> String -- ^ path component; one of \"bindir\", \"libdir\", -- \"datadir\", \"libexecdir\", or \"sysconfdir\" - -> String -- ^ environment variable name + :: PackageDescription + -> String + -- ^ path component; one of \"bindir\", \"libdir\", -- \"datadir\", \"libexecdir\", or \"sysconfdir\" + -> String + -- ^ environment variable name pkgPathEnvVar pkg_descr var = - showPkgName (packageName pkg_descr) ++ "_" ++ var + showPkgName (packageName pkg_descr) ++ "_" ++ var showPkgName :: PackageName -> String showPkgName = map fixchar . unPackageName fixchar :: Char -> Char fixchar '-' = '_' -fixchar c = c +fixchar c = c diff --git a/Cabal/src/Distribution/Simple/BuildPaths.hs b/Cabal/src/Distribution/Simple/BuildPaths.hs index f909078a1bf..ce1b350d8c5 100644 --- a/Cabal/src/Distribution/Simple/BuildPaths.hs +++ b/Cabal/src/Distribution/Simple/BuildPaths.hs @@ -1,6 +1,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.BuildPaths -- Copyright : Isaac Jones 2003-2004, @@ -11,54 +13,58 @@ -- Portability : portable -- -- A bunch of dirs, paths and file names used for intermediate build steps. --- +module Distribution.Simple.BuildPaths + ( defaultDistPref + , srcPref + , buildInfoPref + , haddockDirName + , hscolourPref + , haddockPref + , autogenPackageModulesDir + , autogenComponentModulesDir + , autogenPathsModuleName + , autogenPackageInfoModuleName + , cppHeaderName + , haddockName + , mkGenericStaticLibName + , mkLibName + , mkProfLibName + , mkGenericSharedLibName + , mkSharedLibName + , mkStaticLibName + , mkGenericSharedBundledLibName + , exeExtension + , objExtension + , dllExtension + , staticLibExtension -module Distribution.Simple.BuildPaths ( - defaultDistPref, srcPref, - buildInfoPref, haddockDirName, hscolourPref, haddockPref, - autogenPackageModulesDir, - autogenComponentModulesDir, - - autogenPathsModuleName, - autogenPackageInfoModuleName, - cppHeaderName, - haddockName, - - mkGenericStaticLibName, - mkLibName, - mkProfLibName, - mkGenericSharedLibName, - mkSharedLibName, - mkStaticLibName, - mkGenericSharedBundledLibName, - - exeExtension, - objExtension, - dllExtension, - staticLibExtension, -- * Source files & build directories - getSourceFiles, getLibSourceFiles, getExeSourceFiles, - getFLibSourceFiles, exeBuildDir, flibBuildDir, + , getSourceFiles + , getLibSourceFiles + , getExeSourceFiles + , getFLibSourceFiles + , exeBuildDir + , flibBuildDir ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Package -import Distribution.ModuleName as ModuleName import Distribution.Compiler +import Distribution.ModuleName as ModuleName +import Distribution.Package import Distribution.PackageDescription +import Distribution.Pretty import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Setup.Haddock (HaddockTarget(..)) import Distribution.Simple.Setup.Common (defaultDistPref) -import Distribution.Pretty -import Distribution.System -import Distribution.Verbosity +import Distribution.Simple.Setup.Haddock (HaddockTarget (..)) import Distribution.Simple.Utils +import Distribution.System import Distribution.Utils.Path +import Distribution.Verbosity import Data.List (stripPrefix) -import System.FilePath ((), (<.>), normalise) +import System.FilePath (normalise, (<.>), ()) -- --------------------------------------------------------------------------- -- Build directories and files @@ -81,8 +87,8 @@ haddockDirName ForHackage = (++ "-docs") . prettyShow . packageId -- | The directory to which generated haddock documentation should be written. haddockPref :: HaddockTarget -> FilePath -> PackageDescription -> FilePath -haddockPref haddockTarget distPref pkg_descr - = distPref "doc" "html" haddockDirName haddockTarget pkg_descr +haddockPref haddockTarget distPref pkg_descr = + distPref "doc" "html" haddockDirName haddockTarget pkg_descr -- | The directory in which we put auto-generated modules for EVERY -- component in the package. @@ -93,6 +99,7 @@ autogenPackageModulesDir lbi = buildDir lbi "global-autogen" -- particular component. autogenComponentModulesDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> String autogenComponentModulesDir lbi clbi = componentBuildDir lbi clbi "autogen" + -- NB: Look at 'checkForeignDeps' for where a simplified version of this -- has been copy-pasted. @@ -104,16 +111,18 @@ autogenPathsModuleName :: PackageDescription -> ModuleName autogenPathsModuleName pkg_descr = ModuleName.fromString $ "Paths_" ++ map fixchar (prettyShow (packageName pkg_descr)) - where fixchar '-' = '_' - fixchar c = c + where + fixchar '-' = '_' + fixchar c = c -- | The name of the auto-generated PackageInfo_* module associated with a package autogenPackageInfoModuleName :: PackageDescription -> ModuleName autogenPackageInfoModuleName pkg_descr = ModuleName.fromString $ "PackageInfo_" ++ map fixchar (prettyShow (packageName pkg_descr)) - where fixchar '-' = '_' - fixchar c = c + where + fixchar '-' = '_' + fixchar c = c haddockName :: PackageDescription -> FilePath haddockName pkg_descr = prettyShow (packageName pkg_descr) <.> "haddock" @@ -121,52 +130,65 @@ haddockName pkg_descr = prettyShow (packageName pkg_descr) <.> "haddock" -- ----------------------------------------------------------------------------- -- Source File helper -getLibSourceFiles :: Verbosity - -> LocalBuildInfo - -> Library - -> ComponentLocalBuildInfo - -> IO [(ModuleName.ModuleName, FilePath)] +getLibSourceFiles + :: Verbosity + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO [(ModuleName.ModuleName, FilePath)] getLibSourceFiles verbosity lbi lib clbi = getSourceFiles verbosity searchpaths modules where - bi = libBuildInfo lib - modules = allLibModules lib clbi - searchpaths = componentBuildDir lbi clbi : map getSymbolicPath (hsSourceDirs bi) ++ - [ autogenComponentModulesDir lbi clbi - , autogenPackageModulesDir lbi ] - -getExeSourceFiles :: Verbosity - -> LocalBuildInfo - -> Executable - -> ComponentLocalBuildInfo - -> IO [(ModuleName.ModuleName, FilePath)] + bi = libBuildInfo lib + modules = allLibModules lib clbi + searchpaths = + componentBuildDir lbi clbi + : map getSymbolicPath (hsSourceDirs bi) + ++ [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + ] + +getExeSourceFiles + :: Verbosity + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO [(ModuleName.ModuleName, FilePath)] getExeSourceFiles verbosity lbi exe clbi = do - moduleFiles <- getSourceFiles verbosity searchpaths modules - srcMainPath <- findFileEx verbosity (map getSymbolicPath $ hsSourceDirs bi) (modulePath exe) - return ((ModuleName.main, srcMainPath) : moduleFiles) + moduleFiles <- getSourceFiles verbosity searchpaths modules + srcMainPath <- findFileEx verbosity (map getSymbolicPath $ hsSourceDirs bi) (modulePath exe) + return ((ModuleName.main, srcMainPath) : moduleFiles) where - bi = buildInfo exe - modules = otherModules bi - searchpaths = autogenComponentModulesDir lbi clbi - : autogenPackageModulesDir lbi - : exeBuildDir lbi exe : map getSymbolicPath (hsSourceDirs bi) - -getFLibSourceFiles :: Verbosity - -> LocalBuildInfo - -> ForeignLib - -> ComponentLocalBuildInfo - -> IO [(ModuleName.ModuleName, FilePath)] + bi = buildInfo exe + modules = otherModules bi + searchpaths = + autogenComponentModulesDir lbi clbi + : autogenPackageModulesDir lbi + : exeBuildDir lbi exe + : map getSymbolicPath (hsSourceDirs bi) + +getFLibSourceFiles + :: Verbosity + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO [(ModuleName.ModuleName, FilePath)] getFLibSourceFiles verbosity lbi flib clbi = getSourceFiles verbosity searchpaths modules where - bi = foreignLibBuildInfo flib - modules = otherModules bi - searchpaths = autogenComponentModulesDir lbi clbi - : autogenPackageModulesDir lbi - : flibBuildDir lbi flib : map getSymbolicPath (hsSourceDirs bi) - -getSourceFiles :: Verbosity -> [FilePath] - -> [ModuleName.ModuleName] - -> IO [(ModuleName.ModuleName, FilePath)] -getSourceFiles verbosity dirs modules = flip traverse modules $ \m -> fmap ((,) m) $ + bi = foreignLibBuildInfo flib + modules = otherModules bi + searchpaths = + autogenComponentModulesDir lbi clbi + : autogenPackageModulesDir lbi + : flibBuildDir lbi flib + : map getSymbolicPath (hsSourceDirs bi) + +getSourceFiles + :: Verbosity + -> [FilePath] + -> [ModuleName.ModuleName] + -> IO [(ModuleName.ModuleName, FilePath)] +getSourceFiles verbosity dirs modules = flip traverse modules $ \m -> + fmap ((,) m) $ findFileWithExtension ["hs", "lhs", "hsig", "lhsig"] dirs (ModuleName.toFilePath m) >>= maybe (notFound m) (return . normalise) where @@ -196,29 +218,31 @@ mkLibName :: UnitId -> String mkLibName lib = mkGenericStaticLibName (getHSLibraryName lib) mkProfLibName :: UnitId -> String -mkProfLibName lib = mkGenericStaticLibName (getHSLibraryName lib ++ "_p") +mkProfLibName lib = mkGenericStaticLibName (getHSLibraryName lib ++ "_p") -- | Create a library name for a shared library from a given name. -- Prepends @lib@ and appends the @-\\@ -- as well as the shared library extension. mkGenericSharedLibName :: Platform -> CompilerId -> String -> String -mkGenericSharedLibName platform (CompilerId compilerFlavor compilerVersion) lib - = mconcat [ "lib", lib, "-", comp <.> dllExtension platform ] - where comp = prettyShow compilerFlavor ++ prettyShow compilerVersion +mkGenericSharedLibName platform (CompilerId compilerFlavor compilerVersion) lib = + mconcat ["lib", lib, "-", comp <.> dllExtension platform] + where + comp = prettyShow compilerFlavor ++ prettyShow compilerVersion -- Implement proper name mangling for dynamical shared objects -- @libHS\-\\@ -- e.g. @libHSbase-2.1-ghc6.6.1.so@ mkSharedLibName :: Platform -> CompilerId -> UnitId -> String -mkSharedLibName platform comp lib - = mkGenericSharedLibName platform comp (getHSLibraryName lib) +mkSharedLibName platform comp lib = + mkGenericSharedLibName platform comp (getHSLibraryName lib) -- Static libs are named the same as shared libraries, only with -- a different extension. mkStaticLibName :: Platform -> CompilerId -> UnitId -> String -mkStaticLibName platform (CompilerId compilerFlavor compilerVersion) lib - = "lib" ++ getHSLibraryName lib ++ "-" ++ comp <.> staticLibExtension platform - where comp = prettyShow compilerFlavor ++ prettyShow compilerVersion +mkStaticLibName platform (CompilerId compilerFlavor compilerVersion) lib = + "lib" ++ getHSLibraryName lib ++ "-" ++ comp <.> staticLibExtension platform + where + comp = prettyShow compilerFlavor ++ prettyShow compilerVersion -- | Create a library name for a bundled shared library from a given name. -- This matches the naming convention for shared libraries as implemented in @@ -231,24 +255,26 @@ mkStaticLibName platform (CompilerId compilerFlavor compilerVersion) lib -- "Cffi" -> "libffi.so" mkGenericSharedBundledLibName :: Platform -> CompilerId -> String -> String mkGenericSharedBundledLibName platform comp lib - | "HS" `isPrefixOf` lib - = mkGenericSharedLibName platform comp lib - | Just lib' <- stripPrefix "C" lib - = "lib" ++ lib' <.> dllExtension platform - | otherwise - = error ("Don't understand library name " ++ lib) + | "HS" `isPrefixOf` lib = + mkGenericSharedLibName platform comp lib + | Just lib' <- stripPrefix "C" lib = + "lib" ++ lib' <.> dllExtension platform + | otherwise = + error ("Don't understand library name " ++ lib) -- ------------------------------------------------------------ + -- * Platform file extensions + -- ------------------------------------------------------------ -- | Default extension for executable files on the current platform. -- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2) exeExtension :: Platform -> String exeExtension platform = case platform of - Platform _ Windows -> "exe" - Platform Wasm32 _ -> "wasm" - _ -> "" + Platform _ Windows -> "exe" + Platform Wasm32 _ -> "wasm" + _ -> "" -- | Extension for object files. For GHC the extension is @\"o\"@. objExtension :: String @@ -257,10 +283,10 @@ objExtension = "o" -- | Extension for dynamically linked (or shared) libraries -- (typically @\"so\"@ on Unix and @\"dll\"@ on Windows) dllExtension :: Platform -> String -dllExtension (Platform _arch os)= case os of - Windows -> "dll" - OSX -> "dylib" - _ -> "so" +dllExtension (Platform _arch os) = case os of + Windows -> "dll" + OSX -> "dylib" + _ -> "so" -- | Extension for static libraries -- @@ -268,5 +294,5 @@ dllExtension (Platform _arch os)= case os of -- interested in, not the build OS. staticLibExtension :: Platform -> String staticLibExtension (Platform _arch os) = case os of - Windows -> "lib" - _ -> "a" + Windows -> "lib" + _ -> "a" diff --git a/Cabal/src/Distribution/Simple/BuildTarget.hs b/Cabal/src/Distribution/Simple/BuildTarget.hs index 71f1cf402ba..00964878130 100644 --- a/Cabal/src/Distribution/Simple/BuildTarget.hs +++ b/Cabal/src/Distribution/Simple/BuildTarget.hs @@ -3,6 +3,9 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.BuildTargets -- Copyright : (c) Duncan Coutts 2012 @@ -11,133 +14,126 @@ -- Maintainer : duncan@community.haskell.org -- -- Handling for user-specified build targets ------------------------------------------------------------------------------ -module Distribution.Simple.BuildTarget ( - -- * Main interface - readTargetInfos, - readBuildTargets, -- in case you don't have LocalBuildInfo +module Distribution.Simple.BuildTarget + ( -- * Main interface + readTargetInfos + , readBuildTargets -- in case you don't have LocalBuildInfo -- * Build targets - BuildTarget(..), - showBuildTarget, - QualLevel(..), - buildTargetComponentName, + , BuildTarget (..) + , showBuildTarget + , QualLevel (..) + , buildTargetComponentName -- * Parsing user build targets - UserBuildTarget, - readUserBuildTargets, - showUserBuildTarget, - UserBuildTargetProblem(..), - reportUserBuildTargetProblems, + , UserBuildTarget + , readUserBuildTargets + , showUserBuildTarget + , UserBuildTargetProblem (..) + , reportUserBuildTargetProblems -- * Resolving build targets - resolveBuildTargets, - BuildTargetProblem(..), - reportBuildTargetProblems, + , resolveBuildTargets + , BuildTargetProblem (..) + , reportBuildTargetProblems ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.TargetInfo -import Distribution.Types.LocalBuildInfo import Distribution.Types.ComponentRequestedSpec import Distribution.Types.ForeignLib +import Distribution.Types.LocalBuildInfo +import Distribution.Types.TargetInfo import Distribution.Types.UnqualComponentName +import Distribution.ModuleName import Distribution.Package import Distribution.PackageDescription -import Distribution.ModuleName -import Distribution.Simple.LocalBuildInfo -import Distribution.Pretty import Distribution.Parsec +import Distribution.Pretty +import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Utils -import Distribution.Verbosity import Distribution.Utils.Path +import Distribution.Verbosity import qualified Distribution.Compat.CharParsing as P -import Control.Arrow ( (&&&) ) -import Control.Monad ( msum ) -import Data.List ( stripPrefix, groupBy ) +import Control.Arrow ((&&&)) +import Control.Monad (msum) +import Data.List (groupBy, stripPrefix) import qualified Data.List.NonEmpty as NE -import System.FilePath as FilePath - ( dropExtension, normalise, splitDirectories, joinPath, splitPath - , hasTrailingPathSeparator ) -import System.Directory ( doesFileExist, doesDirectoryExist ) import qualified Data.Map as Map +import System.Directory (doesDirectoryExist, doesFileExist) +import System.FilePath as FilePath + ( dropExtension + , hasTrailingPathSeparator + , joinPath + , normalise + , splitDirectories + , splitPath + ) -- | Take a list of 'String' build targets, and parse and validate them -- into actual 'TargetInfo's to be built/registered/whatever. readTargetInfos :: Verbosity -> PackageDescription -> LocalBuildInfo -> [String] -> IO [TargetInfo] readTargetInfos verbosity pkg_descr lbi args = do - build_targets <- readBuildTargets verbosity pkg_descr args - checkBuildTargets verbosity pkg_descr lbi build_targets + build_targets <- readBuildTargets verbosity pkg_descr args + checkBuildTargets verbosity pkg_descr lbi build_targets -- ------------------------------------------------------------ + -- * User build targets + -- ------------------------------------------------------------ -- | Various ways that a user may specify a build target. --- -data UserBuildTarget = - - -- | A target specified by a single name. This could be a component - -- module or file. - -- - -- > cabal build foo - -- > cabal build Data.Foo - -- > cabal build Data/Foo.hs Data/Foo.hsc - -- - UserBuildTargetSingle String - - -- | A target specified by a qualifier and name. This could be a component - -- name qualified by the component namespace kind, or a module or file - -- qualified by the component name. - -- - -- > cabal build lib:foo exe:foo - -- > cabal build foo:Data.Foo - -- > cabal build foo:Data/Foo.hs - -- - | UserBuildTargetDouble String String - - -- | A fully qualified target, either a module or file qualified by a - -- component name with the component namespace kind. - -- - -- > cabal build lib:foo:Data/Foo.hs exe:foo:Data/Foo.hs - -- > cabal build lib:foo:Data.Foo exe:foo:Data.Foo - -- - | UserBuildTargetTriple String String String +data UserBuildTarget + = -- | A target specified by a single name. This could be a component + -- module or file. + -- + -- > cabal build foo + -- > cabal build Data.Foo + -- > cabal build Data/Foo.hs Data/Foo.hsc + UserBuildTargetSingle String + | -- | A target specified by a qualifier and name. This could be a component + -- name qualified by the component namespace kind, or a module or file + -- qualified by the component name. + -- + -- > cabal build lib:foo exe:foo + -- > cabal build foo:Data.Foo + -- > cabal build foo:Data/Foo.hs + UserBuildTargetDouble String String + | -- | A fully qualified target, either a module or file qualified by a + -- component name with the component namespace kind. + -- + -- > cabal build lib:foo:Data/Foo.hs exe:foo:Data/Foo.hs + -- > cabal build lib:foo:Data.Foo exe:foo:Data.Foo + UserBuildTargetTriple String String String deriving (Show, Eq, Ord) - -- ------------------------------------------------------------ + -- * Resolved build targets + -- ------------------------------------------------------------ -- | A fully resolved build target. --- -data BuildTarget = - - -- | A specific component - -- - BuildTargetComponent ComponentName - - -- | A specific module within a specific component. - -- - | BuildTargetModule ComponentName ModuleName - - -- | A specific file within a specific component. - -- - | BuildTargetFile ComponentName FilePath +data BuildTarget + = -- | A specific component + BuildTargetComponent ComponentName + | -- | A specific module within a specific component. + BuildTargetModule ComponentName ModuleName + | -- | A specific file within a specific component. + BuildTargetFile ComponentName FilePath deriving (Eq, Show, Generic) instance Binary BuildTarget buildTargetComponentName :: BuildTarget -> ComponentName -buildTargetComponentName (BuildTargetComponent cn) = cn -buildTargetComponentName (BuildTargetModule cn _) = cn -buildTargetComponentName (BuildTargetFile cn _) = cn +buildTargetComponentName (BuildTargetComponent cn) = cn +buildTargetComponentName (BuildTargetModule cn _) = cn +buildTargetComponentName (BuildTargetFile cn _) = cn -- | Read a list of user-supplied build target strings and resolve them to -- 'BuildTarget's according to a 'PackageDescription'. If there are problems @@ -145,40 +141,43 @@ buildTargetComponentName (BuildTargetFile cn _) = cn -- 'IOException'. readBuildTargets :: Verbosity -> PackageDescription -> [String] -> IO [BuildTarget] readBuildTargets verbosity pkg targetStrs = do - let (uproblems, utargets) = readUserBuildTargets targetStrs - reportUserBuildTargetProblems verbosity uproblems + let (uproblems, utargets) = readUserBuildTargets targetStrs + reportUserBuildTargetProblems verbosity uproblems - utargets' <- traverse checkTargetExistsAsFile utargets + utargets' <- traverse checkTargetExistsAsFile utargets - let (bproblems, btargets) = resolveBuildTargets pkg utargets' - reportBuildTargetProblems verbosity bproblems + let (bproblems, btargets) = resolveBuildTargets pkg utargets' + reportBuildTargetProblems verbosity bproblems - return btargets + return btargets checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool) checkTargetExistsAsFile t = do - fexists <- existsAsFile (fileComponentOfTarget t) - return (t, fexists) - + fexists <- existsAsFile (fileComponentOfTarget t) + return (t, fexists) where existsAsFile f = do exists <- doesFileExist f case splitPath f of - (d:_) | hasTrailingPathSeparator d -> doesDirectoryExist d - (d:_:_) | not exists -> doesDirectoryExist d - _ -> return exists + (d : _) | hasTrailingPathSeparator d -> doesDirectoryExist d + (d : _ : _) | not exists -> doesDirectoryExist d + _ -> return exists - fileComponentOfTarget (UserBuildTargetSingle s1) = s1 - fileComponentOfTarget (UserBuildTargetDouble _ s2) = s2 + fileComponentOfTarget (UserBuildTargetSingle s1) = s1 + fileComponentOfTarget (UserBuildTargetDouble _ s2) = s2 fileComponentOfTarget (UserBuildTargetTriple _ _ s3) = s3 - -- ------------------------------------------------------------ + -- * Parsing user targets + -- ------------------------------------------------------------ -readUserBuildTargets :: [String] -> ([UserBuildTargetProblem] - ,[UserBuildTarget]) +readUserBuildTargets + :: [String] + -> ( [UserBuildTargetProblem] + , [UserBuildTarget] + ) readUserBuildTargets = partitionEithers . map readUserBuildTarget -- | @@ -206,81 +205,87 @@ readUserBuildTargets = partitionEithers . map readUserBuildTarget -- -- >>> readUserBuildTarget "pkg:\"lib\":comp" -- Left (UserBuildTargetUnrecognised "pkg:\"lib\":comp") --- -readUserBuildTarget :: String -> Either UserBuildTargetProblem - UserBuildTarget +readUserBuildTarget + :: String + -> Either + UserBuildTargetProblem + UserBuildTarget readUserBuildTarget targetstr = - case explicitEitherParsec parseTargetApprox targetstr of - Left _ -> Left (UserBuildTargetUnrecognised targetstr) - Right tgt -> Right tgt - + case explicitEitherParsec parseTargetApprox targetstr of + Left _ -> Left (UserBuildTargetUnrecognised targetstr) + Right tgt -> Right tgt where parseTargetApprox :: CabalParsing m => m UserBuildTarget parseTargetApprox = do - -- read one, two, or three tokens, where last could be "hs-string" - ts <- tokens - return $ case ts of - (a, Nothing) -> UserBuildTargetSingle a - (a, Just (b, Nothing)) -> UserBuildTargetDouble a b - (a, Just (b, Just c)) -> UserBuildTargetTriple a b c + -- read one, two, or three tokens, where last could be "hs-string" + ts <- tokens + return $ case ts of + (a, Nothing) -> UserBuildTargetSingle a + (a, Just (b, Nothing)) -> UserBuildTargetDouble a b + (a, Just (b, Just c)) -> UserBuildTargetTriple a b c tokens :: CabalParsing m => m (String, Maybe (String, Maybe String)) - tokens = (\s -> (s, Nothing)) <$> parsecHaskellString + tokens = + (\s -> (s, Nothing)) <$> parsecHaskellString <|> (,) <$> token <*> P.optional (P.char ':' *> tokens2) tokens2 :: CabalParsing m => m (String, Maybe String) - tokens2 = (\s -> (s, Nothing)) <$> parsecHaskellString + tokens2 = + (\s -> (s, Nothing)) <$> parsecHaskellString <|> (,) <$> token <*> P.optional (P.char ':' *> (parsecHaskellString <|> token)) token :: CabalParsing m => m String - token = P.munch1 (\x -> not (isSpace x) && x /= ':') + token = P.munch1 (\x -> not (isSpace x) && x /= ':') data UserBuildTargetProblem - = UserBuildTargetUnrecognised String - deriving Show + = UserBuildTargetUnrecognised String + deriving (Show) reportUserBuildTargetProblems :: Verbosity -> [UserBuildTargetProblem] -> IO () reportUserBuildTargetProblems verbosity problems = do - case [ target | UserBuildTargetUnrecognised target <- problems ] of - [] -> return () - target -> - die' verbosity $ unlines - [ "Unrecognised build target '" ++ name ++ "'." - | name <- target ] - ++ "Examples:\n" - ++ " - build foo -- component name " - ++ "(library, executable, test-suite or benchmark)\n" - ++ " - build Data.Foo -- module name\n" - ++ " - build Data/Foo.hsc -- file name\n" - ++ " - build lib:foo exe:foo -- component qualified by kind\n" - ++ " - build foo:Data.Foo -- module qualified by component\n" - ++ " - build foo:Data/Foo.hsc -- file qualified by component" + case [target | UserBuildTargetUnrecognised target <- problems] of + [] -> return () + target -> + die' verbosity $ + unlines + [ "Unrecognised build target '" ++ name ++ "'." + | name <- target + ] + ++ "Examples:\n" + ++ " - build foo -- component name " + ++ "(library, executable, test-suite or benchmark)\n" + ++ " - build Data.Foo -- module name\n" + ++ " - build Data/Foo.hsc -- file name\n" + ++ " - build lib:foo exe:foo -- component qualified by kind\n" + ++ " - build foo:Data.Foo -- module qualified by component\n" + ++ " - build foo:Data/Foo.hsc -- file qualified by component" showUserBuildTarget :: UserBuildTarget -> String showUserBuildTarget = intercalate ":" . getComponents where - getComponents (UserBuildTargetSingle s1) = [s1] - getComponents (UserBuildTargetDouble s1 s2) = [s1,s2] - getComponents (UserBuildTargetTriple s1 s2 s3) = [s1,s2,s3] + getComponents (UserBuildTargetSingle s1) = [s1] + getComponents (UserBuildTargetDouble s1 s2) = [s1, s2] + getComponents (UserBuildTargetTriple s1 s2 s3) = [s1, s2, s3] -- | Unless you use 'QL1', this function is PARTIAL; -- use 'showBuildTarget' instead. showBuildTarget' :: QualLevel -> PackageId -> BuildTarget -> String showBuildTarget' ql pkgid bt = - showUserBuildTarget (renderBuildTarget ql bt pkgid) + showUserBuildTarget (renderBuildTarget ql bt pkgid) -- | Unambiguously render a 'BuildTarget', so that it can -- be parsed in all situations. showBuildTarget :: PackageId -> BuildTarget -> String showBuildTarget pkgid t = - showBuildTarget' (qlBuildTarget t) pkgid t + showBuildTarget' (qlBuildTarget t) pkgid t where qlBuildTarget BuildTargetComponent{} = QL2 - qlBuildTarget _ = QL3 - + qlBuildTarget _ = QL3 -- ------------------------------------------------------------ + -- * Resolving user targets to build targets + -- ------------------------------------------------------------ {- @@ -299,219 +304,253 @@ Just ex_pkgid = simpleParse "thelib" -- | Given a bunch of user-specified targets, try to resolve what it is they -- refer to. --- -resolveBuildTargets :: PackageDescription - -> [(UserBuildTarget, Bool)] - -> ([BuildTargetProblem], [BuildTarget]) -resolveBuildTargets pkg = partitionEithers - . map (uncurry (resolveBuildTarget pkg)) - -resolveBuildTarget :: PackageDescription -> UserBuildTarget -> Bool - -> Either BuildTargetProblem BuildTarget +resolveBuildTargets + :: PackageDescription + -> [(UserBuildTarget, Bool)] + -> ([BuildTargetProblem], [BuildTarget]) +resolveBuildTargets pkg = + partitionEithers + . map (uncurry (resolveBuildTarget pkg)) + +resolveBuildTarget + :: PackageDescription + -> UserBuildTarget + -> Bool + -> Either BuildTargetProblem BuildTarget resolveBuildTarget pkg userTarget fexists = - case findMatch (matchBuildTarget pkg userTarget fexists) of - Unambiguous target -> Right target - Ambiguous targets -> Left (BuildTargetAmbiguous userTarget targets') - where targets' = disambiguateBuildTargets - (packageId pkg) - userTarget - targets - None errs -> Left (classifyMatchErrors errs) - + case findMatch (matchBuildTarget pkg userTarget fexists) of + Unambiguous target -> Right target + Ambiguous targets -> Left (BuildTargetAmbiguous userTarget targets') + where + targets' = + disambiguateBuildTargets + (packageId pkg) + userTarget + targets + None errs -> Left (classifyMatchErrors errs) where classifyMatchErrors errs - | Just expected' <- NE.nonEmpty expected - = let unzip' = fmap fst &&& fmap snd - (things, got:|_) = unzip' expected' in - BuildTargetExpected userTarget (NE.toList things) got - | not (null nosuch) = BuildTargetNoSuch userTarget nosuch + | Just expected' <- NE.nonEmpty expected = + let unzip' = fmap fst &&& fmap snd + (things, got :| _) = unzip' expected' + in BuildTargetExpected userTarget (NE.toList things) got + | not (null nosuch) = BuildTargetNoSuch userTarget nosuch | otherwise = error $ "resolveBuildTarget: internal error in matching" where - expected = [ (thing, got) | MatchErrorExpected thing got <- errs ] - nosuch = [ (thing, got) | MatchErrorNoSuch thing got <- errs ] - + expected = [(thing, got) | MatchErrorExpected thing got <- errs] + nosuch = [(thing, got) | MatchErrorNoSuch thing got <- errs] data BuildTargetProblem - = BuildTargetExpected UserBuildTarget [String] String - -- ^ [expected thing] (actually got) - | BuildTargetNoSuch UserBuildTarget [(String, String)] - -- ^ [(no such thing, actually got)] - | BuildTargetAmbiguous UserBuildTarget [(UserBuildTarget, BuildTarget)] - deriving Show - - -disambiguateBuildTargets :: PackageId -> UserBuildTarget -> [BuildTarget] - -> [(UserBuildTarget, BuildTarget)] + = -- | [expected thing] (actually got) + BuildTargetExpected UserBuildTarget [String] String + | -- | [(no such thing, actually got)] + BuildTargetNoSuch UserBuildTarget [(String, String)] + | BuildTargetAmbiguous UserBuildTarget [(UserBuildTarget, BuildTarget)] + deriving (Show) + +disambiguateBuildTargets + :: PackageId + -> UserBuildTarget + -> [BuildTarget] + -> [(UserBuildTarget, BuildTarget)] disambiguateBuildTargets pkgid original = - disambiguate (userTargetQualLevel original) + disambiguate (userTargetQualLevel original) where disambiguate ql ts - | null amb = unamb - | otherwise = unamb ++ disambiguate (succ ql) amb + | null amb = unamb + | otherwise = unamb ++ disambiguate (succ ql) amb where (amb, unamb) = step ql ts - userTargetQualLevel (UserBuildTargetSingle _ ) = QL1 - userTargetQualLevel (UserBuildTargetDouble _ _ ) = QL2 + userTargetQualLevel (UserBuildTargetSingle _) = QL1 + userTargetQualLevel (UserBuildTargetDouble _ _) = QL2 userTargetQualLevel (UserBuildTargetTriple _ _ _) = QL3 - step :: QualLevel -> [BuildTarget] - -> ([BuildTarget], [(UserBuildTarget, BuildTarget)]) - step ql = (\(amb, unamb) -> (map snd $ concat amb, concat unamb)) - . partition (\g -> length g > 1) - . groupBy (equating fst) - . sortBy (comparing fst) - . map (\t -> (renderBuildTarget ql t pkgid, t)) + step + :: QualLevel + -> [BuildTarget] + -> ([BuildTarget], [(UserBuildTarget, BuildTarget)]) + step ql = + (\(amb, unamb) -> (map snd $ concat amb, concat unamb)) + . partition (\g -> length g > 1) + . groupBy (equating fst) + . sortBy (comparing fst) + . map (\t -> (renderBuildTarget ql t pkgid, t)) data QualLevel = QL1 | QL2 | QL3 deriving (Enum, Show) renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget renderBuildTarget ql target pkgid = - case ql of - QL1 -> UserBuildTargetSingle s1 where s1 = single target - QL2 -> UserBuildTargetDouble s1 s2 where (s1, s2) = double target - QL3 -> UserBuildTargetTriple s1 s2 s3 where (s1, s2, s3) = triple target - + case ql of + QL1 -> UserBuildTargetSingle s1 where s1 = single target + QL2 -> UserBuildTargetDouble s1 s2 where (s1, s2) = double target + QL3 -> UserBuildTargetTriple s1 s2 s3 where (s1, s2, s3) = triple target where - single (BuildTargetComponent cn ) = dispCName cn - single (BuildTargetModule _ m) = prettyShow m - single (BuildTargetFile _ f) = f + single (BuildTargetComponent cn) = dispCName cn + single (BuildTargetModule _ m) = prettyShow m + single (BuildTargetFile _ f) = f - double (BuildTargetComponent cn ) = (dispKind cn, dispCName cn) - double (BuildTargetModule cn m) = (dispCName cn, prettyShow m) - double (BuildTargetFile cn f) = (dispCName cn, f) + double (BuildTargetComponent cn) = (dispKind cn, dispCName cn) + double (BuildTargetModule cn m) = (dispCName cn, prettyShow m) + double (BuildTargetFile cn f) = (dispCName cn, f) - triple (BuildTargetComponent _ ) = error "triple BuildTargetComponent" - triple (BuildTargetModule cn m) = (dispKind cn, dispCName cn, prettyShow m) - triple (BuildTargetFile cn f) = (dispKind cn, dispCName cn, f) + triple (BuildTargetComponent _) = error "triple BuildTargetComponent" + triple (BuildTargetModule cn m) = (dispKind cn, dispCName cn, prettyShow m) + triple (BuildTargetFile cn f) = (dispKind cn, dispCName cn, f) dispCName = componentStringName pkgid - dispKind = showComponentKindShort . componentKind + dispKind = showComponentKindShort . componentKind reportBuildTargetProblems :: Verbosity -> [BuildTargetProblem] -> IO () reportBuildTargetProblems verbosity problems = do - - case [ (t, e, g) | BuildTargetExpected t e g <- problems ] of - [] -> return () - targets -> - die' verbosity $ unlines - [ "Unrecognised build target '" ++ showUserBuildTarget target + case [(t, e, g) | BuildTargetExpected t e g <- problems] of + [] -> return () + targets -> + die' verbosity $ + unlines + [ "Unrecognised build target '" + ++ showUserBuildTarget target ++ "'.\n" - ++ "Expected a " ++ intercalate " or " expected - ++ ", rather than '" ++ got ++ "'." - | (target, expected, got) <- targets ] - - case [ (t, e) | BuildTargetNoSuch t e <- problems ] of - [] -> return () - targets -> - die' verbosity $ unlines - [ "Unknown build target '" ++ showUserBuildTarget target + ++ "Expected a " + ++ intercalate " or " expected + ++ ", rather than '" + ++ got + ++ "'." + | (target, expected, got) <- targets + ] + + case [(t, e) | BuildTargetNoSuch t e <- problems] of + [] -> return () + targets -> + die' verbosity $ + unlines + [ "Unknown build target '" + ++ showUserBuildTarget target ++ "'.\nThere is no " - ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'" - | (thing, got) <- nosuch ] ++ "." - | (target, nosuch) <- targets ] - where - mungeThing "file" = "file target" - mungeThing thing = thing - - case [ (t, ts) | BuildTargetAmbiguous t ts <- problems ] of - [] -> return () - targets -> - die' verbosity $ unlines - [ "Ambiguous build target '" ++ showUserBuildTarget target + ++ intercalate + " or " + [ mungeThing thing ++ " '" ++ got ++ "'" + | (thing, got) <- nosuch + ] + ++ "." + | (target, nosuch) <- targets + ] + where + mungeThing "file" = "file target" + mungeThing thing = thing + + case [(t, ts) | BuildTargetAmbiguous t ts <- problems] of + [] -> return () + targets -> + die' verbosity $ + unlines + [ "Ambiguous build target '" + ++ showUserBuildTarget target ++ "'. It could be:\n " - ++ unlines [ " "++ showUserBuildTarget ut ++ - " (" ++ showBuildTargetKind bt ++ ")" - | (ut, bt) <- amb ] - | (target, amb) <- targets ] - + ++ unlines + [ " " + ++ showUserBuildTarget ut + ++ " (" + ++ showBuildTargetKind bt + ++ ")" + | (ut, bt) <- amb + ] + | (target, amb) <- targets + ] where - showBuildTargetKind (BuildTargetComponent _ ) = "component" - showBuildTargetKind (BuildTargetModule _ _) = "module" - showBuildTargetKind (BuildTargetFile _ _) = "file" - + showBuildTargetKind (BuildTargetComponent _) = "component" + showBuildTargetKind (BuildTargetModule _ _) = "module" + showBuildTargetKind (BuildTargetFile _ _) = "file" ---------------------------------- -- Top level BuildTarget matcher -- -matchBuildTarget :: PackageDescription - -> UserBuildTarget -> Bool -> Match BuildTarget +matchBuildTarget + :: PackageDescription + -> UserBuildTarget + -> Bool + -> Match BuildTarget matchBuildTarget pkg = \utarget fexists -> - case utarget of - UserBuildTargetSingle str1 -> - matchBuildTarget1 cinfo str1 fexists - - UserBuildTargetDouble str1 str2 -> - matchBuildTarget2 cinfo str1 str2 fexists - - UserBuildTargetTriple str1 str2 str3 -> - matchBuildTarget3 cinfo str1 str2 str3 fexists + case utarget of + UserBuildTargetSingle str1 -> + matchBuildTarget1 cinfo str1 fexists + UserBuildTargetDouble str1 str2 -> + matchBuildTarget2 cinfo str1 str2 fexists + UserBuildTargetTriple str1 str2 str3 -> + matchBuildTarget3 cinfo str1 str2 str3 fexists where cinfo = pkgComponentInfo pkg matchBuildTarget1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget matchBuildTarget1 cinfo str1 fexists = - matchComponent1 cinfo str1 - `matchPlusShadowing` matchModule1 cinfo str1 - `matchPlusShadowing` matchFile1 cinfo str1 fexists - - -matchBuildTarget2 :: [ComponentInfo] -> String -> String -> Bool - -> Match BuildTarget + matchComponent1 cinfo str1 + `matchPlusShadowing` matchModule1 cinfo str1 + `matchPlusShadowing` matchFile1 cinfo str1 fexists + +matchBuildTarget2 + :: [ComponentInfo] + -> String + -> String + -> Bool + -> Match BuildTarget matchBuildTarget2 cinfo str1 str2 fexists = - matchComponent2 cinfo str1 str2 - `matchPlusShadowing` matchModule2 cinfo str1 str2 - `matchPlusShadowing` matchFile2 cinfo str1 str2 fexists - - -matchBuildTarget3 :: [ComponentInfo] -> String -> String -> String -> Bool - -> Match BuildTarget + matchComponent2 cinfo str1 str2 + `matchPlusShadowing` matchModule2 cinfo str1 str2 + `matchPlusShadowing` matchFile2 cinfo str1 str2 fexists + +matchBuildTarget3 + :: [ComponentInfo] + -> String + -> String + -> String + -> Bool + -> Match BuildTarget matchBuildTarget3 cinfo str1 str2 str3 fexists = - matchModule3 cinfo str1 str2 str3 - `matchPlusShadowing` matchFile3 cinfo str1 str2 str3 fexists - - -data ComponentInfo = ComponentInfo { - cinfoName :: ComponentName, - cinfoStrName :: ComponentStringName, - cinfoSrcDirs :: [FilePath], - cinfoModules :: [ModuleName], - cinfoHsFiles :: [FilePath], -- other hs files (like main.hs) - cinfoAsmFiles:: [FilePath], - cinfoCmmFiles:: [FilePath], - cinfoCFiles :: [FilePath], - cinfoCxxFiles:: [FilePath], - cinfoJsFiles :: [FilePath] - } + matchModule3 cinfo str1 str2 str3 + `matchPlusShadowing` matchFile3 cinfo str1 str2 str3 fexists + +data ComponentInfo = ComponentInfo + { cinfoName :: ComponentName + , cinfoStrName :: ComponentStringName + , cinfoSrcDirs :: [FilePath] + , cinfoModules :: [ModuleName] + , cinfoHsFiles :: [FilePath] -- other hs files (like main.hs) + , cinfoAsmFiles :: [FilePath] + , cinfoCmmFiles :: [FilePath] + , cinfoCFiles :: [FilePath] + , cinfoCxxFiles :: [FilePath] + , cinfoJsFiles :: [FilePath] + } type ComponentStringName = String pkgComponentInfo :: PackageDescription -> [ComponentInfo] pkgComponentInfo pkg = - [ ComponentInfo { - cinfoName = componentName c, - cinfoStrName = componentStringName pkg (componentName c), - cinfoSrcDirs = map getSymbolicPath $ hsSourceDirs bi, - cinfoModules = componentModules c, - cinfoHsFiles = componentHsFiles c, - cinfoAsmFiles= asmSources bi, - cinfoCmmFiles= cmmSources bi, - cinfoCFiles = cSources bi, - cinfoCxxFiles= cxxSources bi, - cinfoJsFiles = jsSources bi - } - | c <- pkgComponents pkg - , let bi = componentBuildInfo c ] + [ ComponentInfo + { cinfoName = componentName c + , cinfoStrName = componentStringName pkg (componentName c) + , cinfoSrcDirs = map getSymbolicPath $ hsSourceDirs bi + , cinfoModules = componentModules c + , cinfoHsFiles = componentHsFiles c + , cinfoAsmFiles = asmSources bi + , cinfoCmmFiles = cmmSources bi + , cinfoCFiles = cSources bi + , cinfoCxxFiles = cxxSources bi + , cinfoJsFiles = jsSources bi + } + | c <- pkgComponents pkg + , let bi = componentBuildInfo c + ] componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName -componentStringName pkg (CLibName LMainLibName ) = prettyShow (packageName pkg) -componentStringName _ (CLibName (LSubLibName name)) = unUnqualComponentName name -componentStringName _ (CFLibName name) = unUnqualComponentName name -componentStringName _ (CExeName name) = unUnqualComponentName name -componentStringName _ (CTestName name) = unUnqualComponentName name -componentStringName _ (CBenchName name) = unUnqualComponentName name +componentStringName pkg (CLibName LMainLibName) = prettyShow (packageName pkg) +componentStringName _ (CLibName (LSubLibName name)) = unUnqualComponentName name +componentStringName _ (CFLibName name) = unUnqualComponentName name +componentStringName _ (CExeName name) = unUnqualComponentName name +componentStringName _ (CTestName name) = unUnqualComponentName name +componentStringName _ (CBenchName name) = unUnqualComponentName name componentModules :: Component -> [ModuleName] -- TODO: Use of 'explicitLibModules' here is a bit wrong: @@ -521,21 +560,27 @@ componentModules :: Component -> [ModuleName] -- Fortunately, this is only used by 'pkgComponentInfo' -- Please don't export this function unless you plan on fixing -- this. -componentModules (CLib lib) = explicitLibModules lib -componentModules (CFLib flib) = foreignLibModules flib -componentModules (CExe exe) = exeModules exe -componentModules (CTest test) = testModules test +componentModules (CLib lib) = explicitLibModules lib +componentModules (CFLib flib) = foreignLibModules flib +componentModules (CExe exe) = exeModules exe +componentModules (CTest test) = testModules test componentModules (CBench bench) = benchmarkModules bench componentHsFiles :: Component -> [FilePath] componentHsFiles (CExe exe) = [modulePath exe] -componentHsFiles (CTest TestSuite { - testInterface = TestSuiteExeV10 _ mainfile - }) = [mainfile] -componentHsFiles (CBench Benchmark { - benchmarkInterface = BenchmarkExeV10 _ mainfile - }) = [mainfile] -componentHsFiles _ = [] +componentHsFiles + ( CTest + TestSuite + { testInterface = TestSuiteExeV10 _ mainfile + } + ) = [mainfile] +componentHsFiles + ( CBench + Benchmark + { benchmarkInterface = BenchmarkExeV10 _ mainfile + } + ) = [mainfile] +componentHsFiles _ = [] {- ex_cs :: [ComponentInfo] @@ -559,10 +604,10 @@ data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind deriving (Eq, Ord, Show, Enum, Bounded) componentKind :: ComponentName -> ComponentKind -componentKind (CLibName _) = LibKind -componentKind (CFLibName _) = FLibKind -componentKind (CExeName _) = ExeKind -componentKind (CTestName _) = TestKind +componentKind (CLibName _) = LibKind +componentKind (CFLibName _) = FLibKind +componentKind (CExeName _) = ExeKind +componentKind (CTestName _) = TestKind componentKind (CBenchName _) = BenchKind cinfoKind :: ComponentInfo -> ComponentKind @@ -570,27 +615,27 @@ cinfoKind = componentKind . cinfoName matchComponentKind :: String -> Match ComponentKind matchComponentKind s - | s `elem` ["lib", "library"] = return' LibKind + | s `elem` ["lib", "library"] = return' LibKind | s `elem` ["flib", "foreign-lib", "foreign-library"] = return' FLibKind - | s `elem` ["exe", "executable"] = return' ExeKind - | s `elem` ["tst", "test", "test-suite"] = return' TestKind - | s `elem` ["bench", "benchmark"] = return' BenchKind + | s `elem` ["exe", "executable"] = return' ExeKind + | s `elem` ["tst", "test", "test-suite"] = return' TestKind + | s `elem` ["bench", "benchmark"] = return' BenchKind | otherwise = matchErrorExpected "component kind" s where return' ck = increaseConfidence >> return ck showComponentKind :: ComponentKind -> String -showComponentKind LibKind = "library" -showComponentKind FLibKind = "foreign-library" -showComponentKind ExeKind = "executable" -showComponentKind TestKind = "test-suite" +showComponentKind LibKind = "library" +showComponentKind FLibKind = "foreign-library" +showComponentKind ExeKind = "executable" +showComponentKind TestKind = "test-suite" showComponentKind BenchKind = "benchmark" showComponentKindShort :: ComponentKind -> String -showComponentKindShort LibKind = "lib" -showComponentKindShort FLibKind = "flib" -showComponentKindShort ExeKind = "exe" -showComponentKindShort TestKind = "test" +showComponentKindShort LibKind = "lib" +showComponentKindShort FLibKind = "flib" +showComponentKindShort ExeKind = "exe" +showComponentKindShort TestKind = "test" showComponentKindShort BenchKind = "bench" ------------------------------ @@ -599,45 +644,54 @@ showComponentKindShort BenchKind = "bench" matchComponent1 :: [ComponentInfo] -> String -> Match BuildTarget matchComponent1 cs = \str1 -> do - guardComponentName str1 - c <- matchComponentName cs str1 - return (BuildTargetComponent (cinfoName c)) + guardComponentName str1 + c <- matchComponentName cs str1 + return (BuildTargetComponent (cinfoName c)) matchComponent2 :: [ComponentInfo] -> String -> String -> Match BuildTarget matchComponent2 cs = \str1 str2 -> do - ckind <- matchComponentKind str1 - guardComponentName str2 - c <- matchComponentKindAndName cs ckind str2 - return (BuildTargetComponent (cinfoName c)) + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + return (BuildTargetComponent (cinfoName c)) -- utils: guardComponentName :: String -> Match () guardComponentName s | all validComponentChar s - && not (null s) = increaseConfidence - | otherwise = matchErrorExpected "component name" s + && not (null s) = + increaseConfidence + | otherwise = matchErrorExpected "component name" s where - validComponentChar c = isAlphaNum c || c == '.' - || c == '_' || c == '-' || c == '\'' + validComponentChar c = + isAlphaNum c + || c == '.' + || c == '_' + || c == '-' + || c == '\'' matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo matchComponentName cs str = - orNoSuchThing "component" str - $ increaseConfidenceFor - $ matchInexactly caseFold - [ (cinfoStrName c, c) | c <- cs ] - str - -matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String - -> Match ComponentInfo + orNoSuchThing "component" str $ + increaseConfidenceFor $ + matchInexactly + caseFold + [(cinfoStrName c, c) | c <- cs] + str + +matchComponentKindAndName + :: [ComponentInfo] + -> ComponentKind + -> String + -> Match ComponentInfo matchComponentKindAndName cs ckind str = - orNoSuchThing (showComponentKind ckind ++ " component") str - $ increaseConfidenceFor - $ matchInexactly (\(ck, cn) -> (ck, caseFold cn)) - [ ((cinfoKind c, cinfoStrName c), c) | c <- cs ] - (ckind, str) - + orNoSuchThing (showComponentKind ckind ++ " component") str $ + increaseConfidenceFor $ + matchInexactly + (\(ck, cn) -> (ck, caseFold cn)) + [((cinfoKind c, cinfoStrName c), c) | c <- cs] + (ckind, str) ------------------------------ -- Matching module targets @@ -645,52 +699,58 @@ matchComponentKindAndName cs ckind str = matchModule1 :: [ComponentInfo] -> String -> Match BuildTarget matchModule1 cs = \str1 -> do - guardModuleName str1 - nubMatchErrors $ do - c <- tryEach cs - let ms = cinfoModules c - m <- matchModuleName ms str1 - return (BuildTargetModule (cinfoName c) m) - -matchModule2 :: [ComponentInfo] -> String -> String -> Match BuildTarget -matchModule2 cs = \str1 str2 -> do - guardComponentName str1 - guardModuleName str2 - c <- matchComponentName cs str1 + guardModuleName str1 + nubMatchErrors $ do + c <- tryEach cs let ms = cinfoModules c - m <- matchModuleName ms str2 + m <- matchModuleName ms str1 return (BuildTargetModule (cinfoName c) m) -matchModule3 :: [ComponentInfo] -> String -> String -> String - -> Match BuildTarget +matchModule2 :: [ComponentInfo] -> String -> String -> Match BuildTarget +matchModule2 cs = \str1 str2 -> do + guardComponentName str1 + guardModuleName str2 + c <- matchComponentName cs str1 + let ms = cinfoModules c + m <- matchModuleName ms str2 + return (BuildTargetModule (cinfoName c) m) + +matchModule3 + :: [ComponentInfo] + -> String + -> String + -> String + -> Match BuildTarget matchModule3 cs str1 str2 str3 = do - ckind <- matchComponentKind str1 - guardComponentName str2 - c <- matchComponentKindAndName cs ckind str2 - guardModuleName str3 - let ms = cinfoModules c - m <- matchModuleName ms str3 - return (BuildTargetModule (cinfoName c) m) + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + guardModuleName str3 + let ms = cinfoModules c + m <- matchModuleName ms str3 + return (BuildTargetModule (cinfoName c) m) -- utils: guardModuleName :: String -> Match () guardModuleName s | all validModuleChar s - && not (null s) = increaseConfidence - | otherwise = matchErrorExpected "module name" s + && not (null s) = + increaseConfidence + | otherwise = matchErrorExpected "module name" s where validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\'' matchModuleName :: [ModuleName] -> String -> Match ModuleName matchModuleName ms str = - orNoSuchThing "module" str - $ increaseConfidenceFor - $ matchInexactly caseFold - [ (prettyShow m, m) - | m <- ms ] - str - + orNoSuchThing "module" str $ + increaseConfidenceFor $ + matchInexactly + caseFold + [ (prettyShow m, m) + | m <- ms + ] + str ------------------------------ -- Matching file targets @@ -698,105 +758,115 @@ matchModuleName ms str = matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget matchFile1 cs str1 exists = - nubMatchErrors $ do - c <- tryEach cs - filepath <- matchComponentFile c str1 exists - return (BuildTargetFile (cinfoName c) filepath) - + nubMatchErrors $ do + c <- tryEach cs + filepath <- matchComponentFile c str1 exists + return (BuildTargetFile (cinfoName c) filepath) matchFile2 :: [ComponentInfo] -> String -> String -> Bool -> Match BuildTarget matchFile2 cs str1 str2 exists = do - guardComponentName str1 - c <- matchComponentName cs str1 - filepath <- matchComponentFile c str2 exists - return (BuildTargetFile (cinfoName c) filepath) - - -matchFile3 :: [ComponentInfo] -> String -> String -> String -> Bool - -> Match BuildTarget + guardComponentName str1 + c <- matchComponentName cs str1 + filepath <- matchComponentFile c str2 exists + return (BuildTargetFile (cinfoName c) filepath) + +matchFile3 + :: [ComponentInfo] + -> String + -> String + -> String + -> Bool + -> Match BuildTarget matchFile3 cs str1 str2 str3 exists = do - ckind <- matchComponentKind str1 - guardComponentName str2 - c <- matchComponentKindAndName cs ckind str2 - filepath <- matchComponentFile c str3 exists - return (BuildTargetFile (cinfoName c) filepath) - + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + filepath <- matchComponentFile c str3 exists + return (BuildTargetFile (cinfoName c) filepath) matchComponentFile :: ComponentInfo -> String -> Bool -> Match FilePath matchComponentFile c str fexists = - expecting "file" str $ - matchPlus - (matchFileExists str fexists) - (matchPlusShadowing - (msum [ matchModuleFileRooted dirs ms str - , matchOtherFileRooted dirs hsFiles str ]) - (msum [ matchModuleFileUnrooted ms str - , matchOtherFileUnrooted hsFiles str - , matchOtherFileUnrooted cFiles str - , matchOtherFileUnrooted jsFiles str ])) + expecting "file" str $ + matchPlus + (matchFileExists str fexists) + ( matchPlusShadowing + ( msum + [ matchModuleFileRooted dirs ms str + , matchOtherFileRooted dirs hsFiles str + ] + ) + ( msum + [ matchModuleFileUnrooted ms str + , matchOtherFileUnrooted hsFiles str + , matchOtherFileUnrooted cFiles str + , matchOtherFileUnrooted jsFiles str + ] + ) + ) where dirs = cinfoSrcDirs c - ms = cinfoModules c + ms = cinfoModules c hsFiles = cinfoHsFiles c - cFiles = cinfoCFiles c + cFiles = cinfoCFiles c jsFiles = cinfoJsFiles c - -- utils matchFileExists :: FilePath -> Bool -> Match a -matchFileExists _ False = mzero -matchFileExists fname True = do increaseConfidence - matchErrorNoSuch "file" fname +matchFileExists _ False = mzero +matchFileExists fname True = do + increaseConfidence + matchErrorNoSuch "file" fname matchModuleFileUnrooted :: [ModuleName] -> String -> Match FilePath matchModuleFileUnrooted ms str = do - let filepath = normalise str - _ <- matchModuleFileStem ms filepath - return filepath + let filepath = normalise str + _ <- matchModuleFileStem ms filepath + return filepath matchModuleFileRooted :: [FilePath] -> [ModuleName] -> String -> Match FilePath matchModuleFileRooted dirs ms str = nubMatches $ do - let filepath = normalise str - filepath' <- matchDirectoryPrefix dirs filepath - _ <- matchModuleFileStem ms filepath' - return filepath + let filepath = normalise str + filepath' <- matchDirectoryPrefix dirs filepath + _ <- matchModuleFileStem ms filepath' + return filepath matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName matchModuleFileStem ms = - increaseConfidenceFor - . matchInexactly caseFold - [ (toFilePath m, m) | m <- ms ] + increaseConfidenceFor + . matchInexactly + caseFold + [(toFilePath m, m) | m <- ms] . dropExtension matchOtherFileRooted :: [FilePath] -> [FilePath] -> FilePath -> Match FilePath matchOtherFileRooted dirs fs str = do - let filepath = normalise str - filepath' <- matchDirectoryPrefix dirs filepath - _ <- matchFile fs filepath' - return filepath + let filepath = normalise str + filepath' <- matchDirectoryPrefix dirs filepath + _ <- matchFile fs filepath' + return filepath matchOtherFileUnrooted :: [FilePath] -> FilePath -> Match FilePath matchOtherFileUnrooted fs str = do - let filepath = normalise str - _ <- matchFile fs filepath - return filepath + let filepath = normalise str + _ <- matchFile fs filepath + return filepath matchFile :: [FilePath] -> FilePath -> Match FilePath -matchFile fs = increaseConfidenceFor - . matchInexactly caseFold [ (f, f) | f <- fs ] +matchFile fs = + increaseConfidenceFor + . matchInexactly caseFold [(f, f) | f <- fs] matchDirectoryPrefix :: [FilePath] -> FilePath -> Match FilePath matchDirectoryPrefix dirs filepath = - exactMatches $ - catMaybes - [ stripDirectory (normalise dir) filepath | dir <- dirs ] + exactMatches $ + catMaybes + [stripDirectory (normalise dir) filepath | dir <- dirs] where stripDirectory :: FilePath -> FilePath -> Maybe FilePath stripDirectory dir fp = joinPath `fmap` stripPrefix (splitDirectories dir) (splitDirectories fp) - ------------------------------ -- Matching monad -- @@ -807,23 +877,22 @@ matchDirectoryPrefix dirs filepath = -- There are various matcher primitives ('matchExactly', 'matchInexactly'), -- ways to combine matchers ('ambiguousWith', 'shadows') and finally we can -- run a matcher against an input using 'findMatch'. --- - -data Match a = NoMatch Confidence [MatchError] - | ExactMatch Confidence [a] - | InexactMatch Confidence [a] - deriving Show +data Match a + = NoMatch Confidence [MatchError] + | ExactMatch Confidence [a] + | InexactMatch Confidence [a] + deriving (Show) type Confidence = Int -data MatchError = MatchErrorExpected String String - | MatchErrorNoSuch String String +data MatchError + = MatchErrorExpected String String + | MatchErrorNoSuch String String deriving (Show, Eq) - instance Alternative Match where - empty = mzero - (<|>) = mplus + empty = mzero + (<|>) = mplus instance MonadPlus Match where mzero = matchZero @@ -835,34 +904,32 @@ matchZero = NoMatch 0 [] -- | Combine two matchers. Exact matches are used over inexact matches -- but if we have multiple exact, or inexact then the we collect all the -- ambiguous matches. --- matchPlus :: Match a -> Match a -> Match a -matchPlus (ExactMatch d1 xs) (ExactMatch d2 xs') = +matchPlus (ExactMatch d1 xs) (ExactMatch d2 xs') = ExactMatch (max d1 d2) (xs ++ xs') -matchPlus a@(ExactMatch _ _ ) (InexactMatch _ _ ) = a -matchPlus a@(ExactMatch _ _ ) (NoMatch _ _ ) = a -matchPlus (InexactMatch _ _ ) b@(ExactMatch _ _ ) = b -matchPlus (InexactMatch d1 xs) (InexactMatch d2 xs') = +matchPlus a@(ExactMatch _ _) (InexactMatch _ _) = a +matchPlus a@(ExactMatch _ _) (NoMatch _ _) = a +matchPlus (InexactMatch _ _) b@(ExactMatch _ _) = b +matchPlus (InexactMatch d1 xs) (InexactMatch d2 xs') = InexactMatch (max d1 d2) (xs ++ xs') -matchPlus a@(InexactMatch _ _ ) (NoMatch _ _ ) = a -matchPlus (NoMatch _ _ ) b@(ExactMatch _ _ ) = b -matchPlus (NoMatch _ _ ) b@(InexactMatch _ _ ) = b -matchPlus a@(NoMatch d1 ms) b@(NoMatch d2 ms') - | d1 > d2 = a - | d1 < d2 = b - | otherwise = NoMatch d1 (ms ++ ms') +matchPlus a@(InexactMatch _ _) (NoMatch _ _) = a +matchPlus (NoMatch _ _) b@(ExactMatch _ _) = b +matchPlus (NoMatch _ _) b@(InexactMatch _ _) = b +matchPlus a@(NoMatch d1 ms) b@(NoMatch d2 ms') + | d1 > d2 = a + | d1 < d2 = b + | otherwise = NoMatch d1 (ms ++ ms') -- | Combine two matchers. This is similar to 'ambiguousWith' with the -- difference that an exact match from the left matcher shadows any exact -- match on the right. Inexact matches are still collected however. --- matchPlusShadowing :: Match a -> Match a -> Match a matchPlusShadowing a@(ExactMatch _ _) (ExactMatch _ _) = a -matchPlusShadowing a b = matchPlus a b +matchPlusShadowing a b = matchPlus a b instance Functor Match where - fmap _ (NoMatch d ms) = NoMatch d ms - fmap f (ExactMatch d xs) = ExactMatch d (fmap f xs) + fmap _ (NoMatch d ms) = NoMatch d ms + fmap f (ExactMatch d xs) = ExactMatch d (fmap f xs) fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs) instance Applicative Match where @@ -872,20 +939,22 @@ instance Applicative Match where instance Monad Match where return = pure - NoMatch d ms >>= _ = NoMatch d ms - ExactMatch d xs >>= f = addDepth d - $ foldr matchPlus matchZero (map f xs) - InexactMatch d xs >>= f = addDepth d . forceInexact - $ foldr matchPlus matchZero (map f xs) + NoMatch d ms >>= _ = NoMatch d ms + ExactMatch d xs >>= f = + addDepth d $ + foldr matchPlus matchZero (map f xs) + InexactMatch d xs >>= f = + addDepth d . forceInexact $ + foldr matchPlus matchZero (map f xs) addDepth :: Confidence -> Match a -> Match a -addDepth d' (NoMatch d msgs) = NoMatch (d'+d) msgs -addDepth d' (ExactMatch d xs) = ExactMatch (d'+d) xs -addDepth d' (InexactMatch d xs) = InexactMatch (d'+d) xs +addDepth d' (NoMatch d msgs) = NoMatch (d' + d) msgs +addDepth d' (ExactMatch d xs) = ExactMatch (d' + d) xs +addDepth d' (InexactMatch d xs) = InexactMatch (d' + d) xs forceInexact :: Match a -> Match a forceInexact (ExactMatch d ys) = InexactMatch d ys -forceInexact m = m +forceInexact m = m ------------------------------ -- Various match primitives @@ -893,15 +962,15 @@ forceInexact m = m matchErrorExpected, matchErrorNoSuch :: String -> String -> Match a matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got] -matchErrorNoSuch thing got = NoMatch 0 [MatchErrorNoSuch thing got] +matchErrorNoSuch thing got = NoMatch 0 [MatchErrorNoSuch thing got] expecting :: String -> String -> Match a -> Match a expecting thing got (NoMatch 0 _) = matchErrorExpected thing got -expecting _ _ m = m +expecting _ _ m = m orNoSuchThing :: String -> String -> Match a -> Match a orNoSuchThing thing got (NoMatch 0 _) = matchErrorNoSuch thing got -orNoSuchThing _ _ m = m +orNoSuchThing _ _ m = m increaseConfidence :: Match () increaseConfidence = ExactMatch 1 [()] @@ -910,29 +979,25 @@ increaseConfidenceFor :: Match a -> Match a increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r nubMatches :: Eq a => Match a -> Match a -nubMatches (NoMatch d msgs) = NoMatch d msgs -nubMatches (ExactMatch d xs) = ExactMatch d (nub xs) -nubMatches (InexactMatch d xs) = InexactMatch d (nub xs) +nubMatches (NoMatch d msgs) = NoMatch d msgs +nubMatches (ExactMatch d xs) = ExactMatch d (nub xs) +nubMatches (InexactMatch d xs) = InexactMatch d (nub xs) nubMatchErrors :: Match a -> Match a -nubMatchErrors (NoMatch d msgs) = NoMatch d (nub msgs) -nubMatchErrors (ExactMatch d xs) = ExactMatch d xs -nubMatchErrors (InexactMatch d xs) = InexactMatch d xs +nubMatchErrors (NoMatch d msgs) = NoMatch d (nub msgs) +nubMatchErrors (ExactMatch d xs) = ExactMatch d xs +nubMatchErrors (InexactMatch d xs) = InexactMatch d xs -- | Lift a list of matches to an exact match. --- exactMatches, inexactMatches :: [a] -> Match a - exactMatches [] = matchZero exactMatches xs = ExactMatch 0 xs - inexactMatches [] = matchZero inexactMatches xs = InexactMatch 0 xs tryEach :: [a] -> Match a tryEach = exactMatches - ------------------------------ -- Top level match runner -- @@ -940,21 +1005,19 @@ tryEach = exactMatches -- | Given a matcher and a key to look up, use the matcher to find all the -- possible matches. There may be 'None', a single 'Unambiguous' match or -- you may have an 'Ambiguous' match with several possibilities. --- findMatch :: Eq b => Match b -> MaybeAmbiguous b findMatch match = - case match of - NoMatch _ msgs -> None (nub msgs) - ExactMatch _ xs -> checkAmbiguous xs - InexactMatch _ xs -> checkAmbiguous xs + case match of + NoMatch _ msgs -> None (nub msgs) + ExactMatch _ xs -> checkAmbiguous xs + InexactMatch _ xs -> checkAmbiguous xs where checkAmbiguous xs = case nub xs of - [x] -> Unambiguous x - xs' -> Ambiguous xs' + [x] -> Unambiguous x + xs' -> Ambiguous xs' data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous [a] - deriving Show - + deriving (Show) ------------------------------ -- Basic matchers @@ -982,24 +1045,23 @@ matchExactly xs = -- So for example if we used string case fold as the canonicalisation -- function, then we would get case insensitive matching (but it will still -- report an exact match when the case matches too). --- -matchInexactly :: (Ord a, Ord a') => - (a -> a') -> - [(a, b)] -> (a -> Match b) +matchInexactly + :: (Ord a, Ord a') + => (a -> a') + -> [(a, b)] + -> (a -> Match b) matchInexactly cannonicalise xs = - \x -> case Map.lookup x m of - Just ys -> exactMatches ys - Nothing -> case Map.lookup (cannonicalise x) m' of - Just ys -> inexactMatches ys - Nothing -> matchZero + \x -> case Map.lookup x m of + Just ys -> exactMatches ys + Nothing -> case Map.lookup (cannonicalise x) m' of + Just ys -> inexactMatches ys + Nothing -> matchZero where - m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ] + m = Map.fromListWith (++) [(k, [x]) | (k, x) <- xs] -- the map of canonicalised keys to groups of inexact matches m' = Map.mapKeysWith (++) cannonicalise m - - ------------------------------ -- Utils -- @@ -1007,60 +1069,75 @@ matchInexactly cannonicalise xs = caseFold :: String -> String caseFold = lowercase - -- | Check that the given build targets are valid in the current context. -- -- Also swizzle into a more convenient form. --- -checkBuildTargets :: Verbosity -> PackageDescription -> LocalBuildInfo -> [BuildTarget] - -> IO [TargetInfo] -checkBuildTargets _ pkg_descr lbi [] = - return (allTargetsInBuildOrder' pkg_descr lbi) - +checkBuildTargets + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> [BuildTarget] + -> IO [TargetInfo] +checkBuildTargets _ pkg_descr lbi [] = + return (allTargetsInBuildOrder' pkg_descr lbi) checkBuildTargets verbosity pkg_descr lbi targets = do - - let (enabled, disabled) = - partitionEithers - [ case componentDisabledReason (componentEnabledSpec lbi) comp of - Nothing -> Left target' - Just reason -> Right (cname, reason) - | target <- targets - , let target'@(cname,_) = swizzleTarget target - , let comp = getComponent pkg_descr cname ] - - case disabled of - [] -> return () - ((cname,reason):_) -> die' verbosity $ formatReason (showComponentName cname) reason - - for_ [ (c, t) | (c, Just t) <- enabled ] $ \(c, t) -> - warn verbosity $ "Ignoring '" ++ either prettyShow id t ++ ". The whole " - ++ showComponentName c ++ " will be processed. (Support for " - ++ "module and file targets has not been implemented yet.)" - - -- Pick out the actual CLBIs for each of these cnames - enabled' <- for enabled $ \(cname, _) -> do - case componentNameTargets' pkg_descr lbi cname of - [] -> error "checkBuildTargets: nothing enabled" - [target] -> return target - _targets -> error "checkBuildTargets: multiple copies enabled" - - return enabled' - + let (enabled, disabled) = + partitionEithers + [ case componentDisabledReason (componentEnabledSpec lbi) comp of + Nothing -> Left target' + Just reason -> Right (cname, reason) + | target <- targets + , let target'@(cname, _) = swizzleTarget target + , let comp = getComponent pkg_descr cname + ] + + case disabled of + [] -> return () + ((cname, reason) : _) -> die' verbosity $ formatReason (showComponentName cname) reason + + for_ [(c, t) | (c, Just t) <- enabled] $ \(c, t) -> + warn verbosity $ + "Ignoring '" + ++ either prettyShow id t + ++ ". The whole " + ++ showComponentName c + ++ " will be processed. (Support for " + ++ "module and file targets has not been implemented yet.)" + + -- Pick out the actual CLBIs for each of these cnames + enabled' <- for enabled $ \(cname, _) -> do + case componentNameTargets' pkg_descr lbi cname of + [] -> error "checkBuildTargets: nothing enabled" + [target] -> return target + _targets -> error "checkBuildTargets: multiple copies enabled" + + return enabled' where - swizzleTarget (BuildTargetComponent c) = (c, Nothing) - swizzleTarget (BuildTargetModule c m) = (c, Just (Left m)) - swizzleTarget (BuildTargetFile c f) = (c, Just (Right f)) + swizzleTarget (BuildTargetComponent c) = (c, Nothing) + swizzleTarget (BuildTargetModule c m) = (c, Just (Left m)) + swizzleTarget (BuildTargetFile c f) = (c, Just (Right f)) formatReason cn DisabledComponent = - "Cannot process the " ++ cn ++ " because the component is marked " - ++ "as disabled in the .cabal file." + "Cannot process the " + ++ cn + ++ " because the component is marked " + ++ "as disabled in the .cabal file." formatReason cn DisabledAllTests = - "Cannot process the " ++ cn ++ " because test suites are not " - ++ "enabled. Run configure with the flag --enable-tests" + "Cannot process the " + ++ cn + ++ " because test suites are not " + ++ "enabled. Run configure with the flag --enable-tests" formatReason cn DisabledAllBenchmarks = - "Cannot process the " ++ cn ++ " because benchmarks are not " - ++ "enabled. Re-run configure with the flag --enable-benchmarks" + "Cannot process the " + ++ cn + ++ " because benchmarks are not " + ++ "enabled. Re-run configure with the flag --enable-benchmarks" formatReason cn (DisabledAllButOne cn') = - "Cannot process the " ++ cn ++ " because this package was " - ++ "configured only to build " ++ cn' ++ ". Re-run configure " - ++ "with the argument " ++ cn + "Cannot process the " + ++ cn + ++ " because this package was " + ++ "configured only to build " + ++ cn' + ++ ". Re-run configure " + ++ "with the argument " + ++ cn diff --git a/Cabal/src/Distribution/Simple/BuildToolDepends.hs b/Cabal/src/Distribution/Simple/BuildToolDepends.hs index d482bfb65bc..486cd2049d9 100644 --- a/Cabal/src/Distribution/Simple/BuildToolDepends.hs +++ b/Cabal/src/Distribution/Simple/BuildToolDepends.hs @@ -5,13 +5,13 @@ -- the functions contained to access those fields directly. module Distribution.Simple.BuildToolDepends where -import Prelude () -import Distribution.Compat.Prelude +import Distribution.Compat.Prelude +import Prelude () import qualified Data.Map as Map -import Distribution.Package -import Distribution.PackageDescription +import Distribution.Package +import Distribution.PackageDescription -- | Desugar a "build-tools" entry into proper a executable dependency if -- possible. @@ -26,21 +26,30 @@ import Distribution.PackageDescription -- the same, but the hard-coding could just as well be per-key. -- -- The first cases matches first. -desugarBuildTool :: PackageDescription - -> LegacyExeDependency - -> Maybe ExeDependency +desugarBuildTool + :: PackageDescription + -> LegacyExeDependency + -> Maybe ExeDependency desugarBuildTool pkg led = if foundLocal - then Just $ ExeDependency (packageName pkg) toolName reqVer - else Map.lookup name whiteMap + then Just $ ExeDependency (packageName pkg) toolName reqVer + else Map.lookup name whiteMap where LegacyExeDependency name reqVer = led toolName = mkUnqualComponentName name foundLocal = toolName `elem` map exeName (executables pkg) - whitelist = [ "hscolour", "haddock", "happy", "alex", "hsc2hs", "c2hs" - , "cpphs", "greencard", "hspec-discover" - ] - whiteMap = Map.fromList $ flip map whitelist $ \n -> + whitelist = + [ "hscolour" + , "haddock" + , "happy" + , "alex" + , "hsc2hs" + , "c2hs" + , "cpphs" + , "greencard" + , "hspec-discover" + ] + whiteMap = Map.fromList $ flip map whitelist $ \n -> (n, ExeDependency (mkPackageName n) (mkUnqualComponentName n) reqVer) -- | Get everything from "build-tool-depends", along with entries from @@ -48,9 +57,10 @@ desugarBuildTool pkg led = -- -- This should almost always be used instead of just accessing the -- `buildToolDepends` field directly. -getAllToolDependencies :: PackageDescription - -> BuildInfo - -> [ExeDependency] +getAllToolDependencies + :: PackageDescription + -> BuildInfo + -> [ExeDependency] getAllToolDependencies pkg bi = buildToolDepends bi ++ mapMaybe (desugarBuildTool pkg) (buildTools bi) @@ -78,14 +88,14 @@ getAllToolDependencies pkg bi = isInternal :: PackageDescription -> ExeDependency -> Bool isInternal pkg (ExeDependency n _ _) = n == packageName pkg - -- | Get internal "build-tool-depends", along with internal "build-tools" -- -- This is a tiny function, but used in a number of places. The same -- restrictions that apply to `isInternal` also apply to this function. -getAllInternalToolDependencies :: PackageDescription - -> BuildInfo - -> [UnqualComponentName] +getAllInternalToolDependencies + :: PackageDescription + -> BuildInfo + -> [UnqualComponentName] getAllInternalToolDependencies pkg bi = [ toolname | dep@(ExeDependency _ toolname _) <- getAllToolDependencies pkg bi diff --git a/Cabal/src/Distribution/Simple/CCompiler.hs b/Cabal/src/Distribution/Simple/CCompiler.hs index 6ed7895a374..1b2c63ceb69 100644 --- a/Cabal/src/Distribution/Simple/CCompiler.hs +++ b/Cabal/src/Distribution/Simple/CCompiler.hs @@ -1,14 +1,4 @@ ----------------------------------------------------------------------------- --- | --- Module : Distribution.Simple.CCompiler --- Copyright : 2011, Dan Knapp --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This simple package provides types and functions for interacting with --- C compilers. Currently it's just a type enumerating extant C-like --- languages, which we call dialects. {- Redistribution and use in source and binary forms, with or without @@ -39,85 +29,109 @@ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} -module Distribution.Simple.CCompiler ( - CDialect(..), - cSourceExtensions, - cDialectFilenameExtension, - filenameCDialect +-- | +-- Module : Distribution.Simple.CCompiler +-- Copyright : 2011, Dan Knapp +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This simple package provides types and functions for interacting with +-- C compilers. Currently it's just a type enumerating extant C-like +-- languages, which we call dialects. +module Distribution.Simple.CCompiler + ( CDialect (..) + , cSourceExtensions + , cDialectFilenameExtension + , filenameCDialect ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import System.FilePath - ( takeExtension ) - + ( takeExtension + ) -- | Represents a dialect of C. The Monoid instance expresses backward -- compatibility, in the sense that 'mappend a b' is the least inclusive -- dialect which both 'a' and 'b' can be correctly interpreted as. -data CDialect = C - | ObjectiveC - | CPlusPlus - | ObjectiveCPlusPlus - deriving (Eq, Show) +data CDialect + = C + | ObjectiveC + | CPlusPlus + | ObjectiveCPlusPlus + deriving (Eq, Show) instance Monoid CDialect where mempty = C mappend = (<>) instance Semigroup CDialect where - C <> anything = anything - ObjectiveC <> CPlusPlus = ObjectiveCPlusPlus - CPlusPlus <> ObjectiveC = ObjectiveCPlusPlus - _ <> ObjectiveCPlusPlus = ObjectiveCPlusPlus - ObjectiveC <> _ = ObjectiveC - CPlusPlus <> _ = CPlusPlus - ObjectiveCPlusPlus <> _ = ObjectiveCPlusPlus + C <> anything = anything + ObjectiveC <> CPlusPlus = ObjectiveCPlusPlus + CPlusPlus <> ObjectiveC = ObjectiveCPlusPlus + _ <> ObjectiveCPlusPlus = ObjectiveCPlusPlus + ObjectiveC <> _ = ObjectiveC + CPlusPlus <> _ = CPlusPlus + ObjectiveCPlusPlus <> _ = ObjectiveCPlusPlus -- | A list of all file extensions which are recognized as possibly containing -- some dialect of C code. Note that this list is only for source files, -- not for header files. cSourceExtensions :: [String] -cSourceExtensions = ["c", "i", "ii", "m", "mi", "mm", "M", "mii", "cc", "cp", - "cxx", "cpp", "CPP", "c++", "C"] - +cSourceExtensions = + [ "c" + , "i" + , "ii" + , "m" + , "mi" + , "mm" + , "M" + , "mii" + , "cc" + , "cp" + , "cxx" + , "cpp" + , "CPP" + , "c++" + , "C" + ] -- | Takes a dialect of C and whether code is intended to be passed through -- the preprocessor, and returns a filename extension for containing that -- code. cDialectFilenameExtension :: CDialect -> Bool -> String -cDialectFilenameExtension C True = "c" +cDialectFilenameExtension C True = "c" cDialectFilenameExtension C False = "i" -cDialectFilenameExtension ObjectiveC True = "m" +cDialectFilenameExtension ObjectiveC True = "m" cDialectFilenameExtension ObjectiveC False = "mi" -cDialectFilenameExtension CPlusPlus True = "cpp" -cDialectFilenameExtension CPlusPlus False = "ii" -cDialectFilenameExtension ObjectiveCPlusPlus True = "mm" +cDialectFilenameExtension CPlusPlus True = "cpp" +cDialectFilenameExtension CPlusPlus False = "ii" +cDialectFilenameExtension ObjectiveCPlusPlus True = "mm" cDialectFilenameExtension ObjectiveCPlusPlus False = "mii" - -- | Infers from a filename's extension the dialect of C which it contains, -- and whether it is intended to be passed through the preprocessor. filenameCDialect :: String -> Maybe (CDialect, Bool) filenameCDialect filename = do extension <- case takeExtension filename of - '.':ext -> Just ext - _ -> Nothing + '.' : ext -> Just ext + _ -> Nothing case extension of - "c" -> return (C, True) - "i" -> return (C, False) - "ii" -> return (CPlusPlus, False) - "m" -> return (ObjectiveC, True) - "mi" -> return (ObjectiveC, False) - "mm" -> return (ObjectiveCPlusPlus, True) - "M" -> return (ObjectiveCPlusPlus, True) + "c" -> return (C, True) + "i" -> return (C, False) + "ii" -> return (CPlusPlus, False) + "m" -> return (ObjectiveC, True) + "mi" -> return (ObjectiveC, False) + "mm" -> return (ObjectiveCPlusPlus, True) + "M" -> return (ObjectiveCPlusPlus, True) "mii" -> return (ObjectiveCPlusPlus, False) - "cc" -> return (CPlusPlus, True) - "cp" -> return (CPlusPlus, True) + "cc" -> return (CPlusPlus, True) + "cp" -> return (CPlusPlus, True) "cxx" -> return (CPlusPlus, True) "cpp" -> return (CPlusPlus, True) "CPP" -> return (CPlusPlus, True) "c++" -> return (CPlusPlus, True) - "C" -> return (CPlusPlus, True) - _ -> Nothing + "C" -> return (CPlusPlus, True) + _ -> Nothing diff --git a/Cabal/src/Distribution/Simple/Command.hs b/Cabal/src/Distribution/Simple/Command.hs index 505d3d0d584..f4ba63f991c 100644 --- a/Cabal/src/Distribution/Simple/Command.hs +++ b/Cabal/src/Distribution/Simple/Command.hs @@ -3,6 +3,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Command -- Copyright : Duncan Coutts 2007 @@ -18,88 +19,99 @@ -- run. It handles some common stuff automatically, like the @--help@ and -- command line completion flags. It is designed to allow other tools make -- derived commands. This feature is used heavily in @cabal-install@. - -module Distribution.Simple.Command ( - - -- * Command interface - CommandUI(..), - commandShowOptions, - CommandParse(..), - commandParseArgs, - getNormalCommandDescriptions, - helpCommandUI, - - -- ** Constructing commands - ShowOrParseArgs(..), - usageDefault, - usageAlternatives, - mkCommandUI, - hiddenCommand, - - -- ** Associating actions with commands - Command, - commandAddAction, - noExtraFlags, - - -- ** Building lists of commands - CommandType(..), - CommandSpec(..), - commandFromSpec, - - -- ** Running commands - commandsRun, - --- * Option Fields - OptionField(..), Name, - --- ** Constructing Option Fields - option, multiOption, - --- ** Liftings & Projections - liftOption, liftOptionL, - --- * Option Descriptions - OptDescr(..), Description, SFlags, LFlags, OptFlags, ArgPlaceHolder, - --- ** OptDescr 'smart' constructors - MkOptDescr, - reqArg, reqArg', optArg, optArg', noArg, - boolOpt, boolOpt', choiceOpt, choiceOptFromEnum - +module Distribution.Simple.Command + ( -- * Command interface + CommandUI (..) + , commandShowOptions + , CommandParse (..) + , commandParseArgs + , getNormalCommandDescriptions + , helpCommandUI + + -- ** Constructing commands + , ShowOrParseArgs (..) + , usageDefault + , usageAlternatives + , mkCommandUI + , hiddenCommand + + -- ** Associating actions with commands + , Command + , commandAddAction + , noExtraFlags + + -- ** Building lists of commands + , CommandType (..) + , CommandSpec (..) + , commandFromSpec + + -- ** Running commands + , commandsRun + + -- * Option Fields + , OptionField (..) + , Name + + -- ** Constructing Option Fields + , option + , multiOption + + -- ** Liftings & Projections + , liftOption + , liftOptionL + + -- * Option Descriptions + , OptDescr (..) + , Description + , SFlags + , LFlags + , OptFlags + , ArgPlaceHolder + + -- ** OptDescr 'smart' constructors + , MkOptDescr + , reqArg + , reqArg' + , optArg + , optArg' + , noArg + , boolOpt + , boolOpt' + , choiceOpt + , choiceOptFromEnum ) where -import Prelude () import Distribution.Compat.Prelude hiding (get) +import Prelude () import qualified Data.Array as Array import qualified Data.List as List +import Distribution.Compat.Lens (ALens', (#~), (^#)) import qualified Distribution.GetOpt as GetOpt import Distribution.ReadE import Distribution.Simple.Utils -import Distribution.Compat.Lens (ALens', (^#), (#~)) - - -data CommandUI flags = CommandUI { - -- | The name of the command as it would be entered on the command line. - -- For example @\"build\"@. - commandName :: String, - -- | A short, one line description of the command to use in help texts. - commandSynopsis :: String, - -- | A function that maps a program name to a usage summary for this - -- command. - commandUsage :: String -> String, - -- | Additional explanation of the command to use in help texts. - commandDescription :: Maybe (String -> String), - -- | Post-Usage notes and examples in help texts - commandNotes :: Maybe (String -> String), - -- | Initial \/ empty flags - commandDefaultFlags :: flags, - -- | All the Option fields for this command - commandOptions :: ShowOrParseArgs -> [OptionField flags] + +data CommandUI flags = CommandUI + { commandName :: String + -- ^ The name of the command as it would be entered on the command line. + -- For example @\"build\"@. + , commandSynopsis :: String + -- ^ A short, one line description of the command to use in help texts. + , commandUsage :: String -> String + -- ^ A function that maps a program name to a usage summary for this + -- command. + , commandDescription :: Maybe (String -> String) + -- ^ Additional explanation of the command to use in help texts. + , commandNotes :: Maybe (String -> String) + -- ^ Post-Usage notes and examples in help texts + , commandDefaultFlags :: flags + -- ^ Initial \/ empty flags + , commandOptions :: ShowOrParseArgs -> [OptionField flags] + -- ^ All the Option fields for this command } data ShowOrParseArgs = ShowArgs | ParseArgs -type Name = String +type Name = String type Description = String -- | We usually have a data type for storing configuration values, where @@ -107,30 +119,43 @@ type Description = String -- the value either via command line flags or a configuration file. -- An individual OptionField models such a field, and we usually -- build a list of options associated to a configuration data type. -data OptionField a = OptionField { - optionName :: Name, - optionDescr :: [OptDescr a] } +data OptionField a = OptionField + { optionName :: Name + , optionDescr :: [OptDescr a] + } -- | An OptionField takes one or more OptDescrs, describing the command line -- interface for the field. -data OptDescr a = ReqArg Description OptFlags ArgPlaceHolder - (ReadE (a->a)) (a -> [String]) - - | OptArg Description OptFlags ArgPlaceHolder - (ReadE (a->a)) (a->a) (a -> [Maybe String]) - - | ChoiceOpt [(Description, OptFlags, a->a, a -> Bool)] - - | BoolOpt Description OptFlags{-True-} OptFlags{-False-} - (Bool -> a -> a) (a-> Maybe Bool) +data OptDescr a + = ReqArg + Description + OptFlags + ArgPlaceHolder + (ReadE (a -> a)) + (a -> [String]) + | OptArg + Description + OptFlags + ArgPlaceHolder + (ReadE (a -> a)) + (a -> a) + (a -> [Maybe String]) + | ChoiceOpt [(Description, OptFlags, a -> a, a -> Bool)] + | BoolOpt + Description + OptFlags {-True-} + OptFlags {-False-} + (Bool -> a -> a) + (a -> Maybe Bool) -- | Short command line option strings -type SFlags = [Char] +type SFlags = [Char] + -- | Long command line option strings -type LFlags = [String] -type OptFlags = (SFlags,LFlags) -type ArgPlaceHolder = String +type LFlags = [String] +type OptFlags = (SFlags, LFlags) +type ArgPlaceHolder = String -- | Create an option taking a single OptDescr. -- No explicit Name is given for the Option, the name is the first LFlag given. @@ -142,23 +167,40 @@ type ArgPlaceHolder = String -- * @get@: Get the current value of the flag. -- * @set@: Set the value of the flag. Gets the current value of the flag as a -- parameter. -option :: SFlags -> LFlags -> Description -> get -> set -> MkOptDescr get set a - -> OptionField a -option sf lf@(n:_) d get set arg = OptionField n [arg sf lf d get set] -option _ _ _ _ _ _ = error $ "Distribution.command.option: " - ++ "An OptionField must have at least one LFlag" +option + :: SFlags + -> LFlags + -> Description + -> get + -> set + -> MkOptDescr get set a + -> OptionField a +option sf lf@(n : _) d get set arg = OptionField n [arg sf lf d get set] +option _ _ _ _ _ _ = + error $ + "Distribution.command.option: " + ++ "An OptionField must have at least one LFlag" -- | Create an option taking several OptDescrs. -- You will have to give the flags and description individually to the -- OptDescr constructor. -multiOption :: Name -> get -> set - -> [get -> set -> OptDescr a] -- ^MkOptDescr constructors partially - -- applied to flags and description. - -> OptionField a +multiOption + :: Name + -> get + -> set + -> [get -> set -> OptDescr a] + -- ^ MkOptDescr constructors partially + -- applied to flags and description. + -> OptionField a multiOption n get set args = OptionField n [arg get set | arg <- args] -type MkOptDescr get set a = SFlags -> LFlags -> Description -> get -> set - -> OptDescr a +type MkOptDescr get set a = + SFlags + -> LFlags + -> Description + -> get + -> set + -> OptDescr a -- | Create a string-valued command line interface. -- Usually called in the context of 'option' or 'multiOption'. @@ -170,296 +212,391 @@ type MkOptDescr get set a = SFlags -> LFlags -> Description -> get -> set -- * @mkflag@: How to parse the argument into the option. -- * @showflag@: If parsing goes wrong, display a useful error message to -- the user. -reqArg :: Monoid b => ArgPlaceHolder -> ReadE b -> (b -> [String]) - -> MkOptDescr (a -> b) (b -> a -> a) a +reqArg + :: Monoid b + => ArgPlaceHolder + -> ReadE b + -> (b -> [String]) + -> MkOptDescr (a -> b) (b -> a -> a) a reqArg ad mkflag showflag sf lf d get set = - ReqArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) - (showflag . get) + ReqArg + d + (sf, lf) + ad + (fmap (\a b -> set (get b `mappend` a) b) mkflag) + (showflag . get) -- | Create a string-valued command line interface with a default value. -optArg :: Monoid b => ArgPlaceHolder -> ReadE b -> b -> (b -> [Maybe String]) - -> MkOptDescr (a -> b) (b -> a -> a) a -optArg ad mkflag def showflag sf lf d get set = - OptArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) - (\b -> set (get b `mappend` def) b) - (showflag . get) +optArg + :: Monoid b + => ArgPlaceHolder + -> ReadE b + -> b + -> (b -> [Maybe String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +optArg ad mkflag def showflag sf lf d get set = + OptArg + d + (sf, lf) + ad + (fmap (\a b -> set (get b `mappend` a) b) mkflag) + (\b -> set (get b `mappend` def) b) + (showflag . get) -- | (String -> a) variant of "reqArg" -reqArg' :: Monoid b => ArgPlaceHolder -> (String -> b) -> (b -> [String]) - -> MkOptDescr (a -> b) (b -> a -> a) a +reqArg' + :: Monoid b + => ArgPlaceHolder + -> (String -> b) + -> (b -> [String]) + -> MkOptDescr (a -> b) (b -> a -> a) a reqArg' ad mkflag showflag = - reqArg ad (succeedReadE mkflag) showflag + reqArg ad (succeedReadE mkflag) showflag -- | (String -> a) variant of "optArg" -optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b) - -> (b -> [Maybe String]) - -> MkOptDescr (a -> b) (b -> a -> a) a +optArg' + :: Monoid b + => ArgPlaceHolder + -> (Maybe String -> b) + -> (b -> [Maybe String]) + -> MkOptDescr (a -> b) (b -> a -> a) a optArg' ad mkflag showflag = - optArg ad (succeedReadE (mkflag . Just)) def showflag - where def = mkflag Nothing - -noArg :: (Eq b) => b -> MkOptDescr (a -> b) (b -> a -> a) a -noArg flag sf lf d = choiceOpt [(flag, (sf,lf), d)] sf lf d - -boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags - -> MkOptDescr (a -> b) (b -> a -> a) a -boolOpt g s sfT sfF _sf _lf@(n:_) d get set = - BoolOpt d (sfT, ["enable-"++n]) (sfF, ["disable-"++n]) (set.s) (g.get) -boolOpt _ _ _ _ _ _ _ _ _ = error - "Distribution.Simple.Setup.boolOpt: unreachable" - -boolOpt' :: (b -> Maybe Bool) -> (Bool -> b) -> OptFlags -> OptFlags - -> MkOptDescr (a -> b) (b -> a -> a) a -boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set.s) (g . get) + optArg ad (succeedReadE (mkflag . Just)) def showflag + where + def = mkflag Nothing + +noArg :: Eq b => b -> MkOptDescr (a -> b) (b -> a -> a) a +noArg flag sf lf d = choiceOpt [(flag, (sf, lf), d)] sf lf d + +boolOpt + :: (b -> Maybe Bool) + -> (Bool -> b) + -> SFlags + -> SFlags + -> MkOptDescr (a -> b) (b -> a -> a) a +boolOpt g s sfT sfF _sf _lf@(n : _) d get set = + BoolOpt d (sfT, ["enable-" ++ n]) (sfF, ["disable-" ++ n]) (set . s) (g . get) +boolOpt _ _ _ _ _ _ _ _ _ = + error + "Distribution.Simple.Setup.boolOpt: unreachable" + +boolOpt' + :: (b -> Maybe Bool) + -> (Bool -> b) + -> OptFlags + -> OptFlags + -> MkOptDescr (a -> b) (b -> a -> a) a +boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set . s) (g . get) -- | create a Choice option -choiceOpt :: Eq b => [(b,OptFlags,Description)] - -> MkOptDescr (a -> b) (b -> a -> a) a -choiceOpt aa_ff _sf _lf _d get set = ChoiceOpt alts - where alts = [(d,flags, set alt, (==alt) . get) | (alt,flags,d) <- aa_ff] +choiceOpt + :: Eq b + => [(b, OptFlags, Description)] + -> MkOptDescr (a -> b) (b -> a -> a) a +choiceOpt aa_ff _sf _lf _d get set = ChoiceOpt alts + where + alts = [(d, flags, set alt, (== alt) . get) | (alt, flags, d) <- aa_ff] -- | create a Choice option out of an enumeration type. -- As long flags, the Show output is used. As short flags, the first character -- which does not conflict with a previous one is used. -choiceOptFromEnum :: (Bounded b, Enum b, Show b, Eq b) => - MkOptDescr (a -> b) (b -> a -> a) a +choiceOptFromEnum + :: (Bounded b, Enum b, Show b, Eq b) + => MkOptDescr (a -> b) (b -> a -> a) a choiceOptFromEnum _sf _lf d get = - choiceOpt [ (x, (sf, [map toLower $ show x]), d') - | (x, sf) <- sflags' - , let d' = d ++ show x] - _sf _lf d get - where sflags' = foldl f [] [firstOne..] - f prev x = let prevflags = concatMap snd prev in - prev ++ take 1 [(x, [toLower sf]) - | sf <- show x, isAlpha sf - , toLower sf `notElem` prevflags] - firstOne = minBound `asTypeOf` get undefined - -commandGetOpts :: ShowOrParseArgs -> CommandUI flags - -> [GetOpt.OptDescr (flags -> flags)] + choiceOpt + [ (x, (sf, [map toLower $ show x]), d') + | (x, sf) <- sflags' + , let d' = d ++ show x + ] + _sf + _lf + d + get + where + sflags' = foldl f [] [firstOne ..] + f prev x = + let prevflags = concatMap snd prev + in prev + ++ take + 1 + [ (x, [toLower sf]) + | sf <- show x + , isAlpha sf + , toLower sf `notElem` prevflags + ] + firstOne = minBound `asTypeOf` get undefined + +commandGetOpts + :: ShowOrParseArgs + -> CommandUI flags + -> [GetOpt.OptDescr (flags -> flags)] commandGetOpts showOrParse command = - concatMap viewAsGetOpt (commandOptions command showOrParse) + concatMap viewAsGetOpt (commandOptions command showOrParse) viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a -> a)] viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa where - optDescrToGetOpt (ReqArg d (cs,ss) arg_desc set _) = - [GetOpt.Option cs ss (GetOpt.ReqArg (runReadE set) arg_desc) d] - optDescrToGetOpt (OptArg d (cs,ss) arg_desc set def _) = - [GetOpt.Option cs ss (GetOpt.OptArg set' arg_desc) d] - where set' Nothing = Right def - set' (Just txt) = runReadE set txt + optDescrToGetOpt (ReqArg d (cs, ss) arg_desc set _) = + [GetOpt.Option cs ss (GetOpt.ReqArg (runReadE set) arg_desc) d] + optDescrToGetOpt (OptArg d (cs, ss) arg_desc set def _) = + [GetOpt.Option cs ss (GetOpt.OptArg set' arg_desc) d] + where + set' Nothing = Right def + set' (Just txt) = runReadE set txt optDescrToGetOpt (ChoiceOpt alts) = - [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d,(sf,lf),set,_) <- alts ] - optDescrToGetOpt (BoolOpt d (sfT, lfT) ([], []) set _) = - [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) d ] - optDescrToGetOpt (BoolOpt d ([], []) (sfF, lfF) set _) = - [ GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) d ] - optDescrToGetOpt (BoolOpt d (sfT,lfT) (sfF, lfF) set _) = - [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d) - , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) ] + [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d, (sf, lf), set, _) <- alts] + optDescrToGetOpt (BoolOpt d (sfT, lfT) ([], []) set _) = + [GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) d] + optDescrToGetOpt (BoolOpt d ([], []) (sfF, lfF) set _) = + [GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) d] + optDescrToGetOpt (BoolOpt d (sfT, lfT) (sfF, lfF) set _) = + [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d) + , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) + ] getCurrentChoice :: OptDescr a -> a -> [String] getCurrentChoice (ChoiceOpt alts) a = - [ lf | (_,(_sf,lf:_), _, currentChoice) <- alts, currentChoice a] - + [lf | (_, (_sf, lf : _), _, currentChoice) <- alts, currentChoice a] getCurrentChoice _ _ = error "Command.getChoice: expected a Choice OptDescr" - liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b liftOption get' set' opt = - opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt} + opt{optionDescr = liftOptDescr get' set' `map` optionDescr opt} -- | @since 3.4.0.0 liftOptionL :: ALens' b a -> OptionField a -> OptionField b liftOptionL l = liftOption (^# l) (l #~) - liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b liftOptDescr get' set' (ChoiceOpt opts) = - ChoiceOpt [ (d, ff, liftSet get' set' set , (get . get')) - | (d, ff, set, get) <- opts] - + ChoiceOpt + [ (d, ff, liftSet get' set' set, (get . get')) + | (d, ff, set, get) <- opts + ] liftOptDescr get' set' (OptArg d ff ad set def get) = - OptArg d ff ad (liftSet get' set' `fmap` set) - (liftSet get' set' def) (get . get') - + OptArg + d + ff + ad + (liftSet get' set' `fmap` set) + (liftSet get' set' def) + (get . get') liftOptDescr get' set' (ReqArg d ff ad set get) = - ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get') - + ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get') liftOptDescr get' set' (BoolOpt d ffT ffF set get) = - BoolOpt d ffT ffF (liftSet get' set' . set) (get . get') + BoolOpt d ffT ffF (liftSet get' set' . set) (get . get') liftSet :: (b -> a) -> (a -> (b -> b)) -> (a -> a) -> b -> b liftSet get' set' set x = set' (set $ get' x) x -- | Show flags in the standard long option command line format commandShowOptions :: CommandUI flags -> flags -> [String] -commandShowOptions command v = concat - [ showOptDescr v od | o <- commandOptions command ParseArgs - , od <- optionDescr o] +commandShowOptions command v = + concat + [ showOptDescr v od | o <- commandOptions command ParseArgs, od <- optionDescr o + ] where - maybePrefix [] = [] - maybePrefix (lOpt:_) = ["--" ++ lOpt] + maybePrefix [] = [] + maybePrefix (lOpt : _) = ["--" ++ lOpt] showOptDescr :: a -> OptDescr a -> [String] - showOptDescr x (BoolOpt _ (_,lfTs) (_,lfFs) _ enabled) - = case enabled x of - Nothing -> [] - Just True -> maybePrefix lfTs - Just False -> maybePrefix lfFs - showOptDescr x c@ChoiceOpt{} - = ["--" ++ val | val <- getCurrentChoice c x] - showOptDescr x (ReqArg _ (_ssff,lf:_) _ _ showflag) - = [ "--"++lf++"="++flag - | flag <- showflag x ] - showOptDescr x (OptArg _ (_ssff,lf:_) _ _ _ showflag) - = [ case flag of - Just s -> "--"++lf++"="++s - Nothing -> "--"++lf - | flag <- showflag x ] - showOptDescr _ _ - = error "Distribution.Simple.Command.showOptDescr: unreachable" - + showOptDescr x (BoolOpt _ (_, lfTs) (_, lfFs) _ enabled) = + case enabled x of + Nothing -> [] + Just True -> maybePrefix lfTs + Just False -> maybePrefix lfFs + showOptDescr x c@ChoiceOpt{} = + ["--" ++ val | val <- getCurrentChoice c x] + showOptDescr x (ReqArg _ (_ssff, lf : _) _ _ showflag) = + [ "--" ++ lf ++ "=" ++ flag + | flag <- showflag x + ] + showOptDescr x (OptArg _ (_ssff, lf : _) _ _ _ showflag) = + [ case flag of + Just s -> "--" ++ lf ++ "=" ++ s + Nothing -> "--" ++ lf + | flag <- showflag x + ] + showOptDescr _ _ = + error "Distribution.Simple.Command.showOptDescr: unreachable" commandListOptions :: CommandUI flags -> [String] commandListOptions command = concatMap listOption $ addCommonFlags ShowArgs $ -- This is a slight hack, we don't want - -- "--list-options" showing up in the - -- list options output, so use ShowArgs + -- "--list-options" showing up in the + -- list options output, so use ShowArgs commandGetOpts ShowArgs command where listOption (GetOpt.Option shortNames longNames _ _) = - [ "-" ++ [name] | name <- shortNames ] - ++ [ "--" ++ name | name <- longNames ] + ["-" ++ [name] | name <- shortNames] + ++ ["--" ++ name | name <- longNames] -- | The help text for this command with descriptions of all the options. commandHelp :: CommandUI flags -> String -> String commandHelp command pname = - commandSynopsis command - ++ "\n\n" - ++ commandUsage command pname - ++ ( case commandDescription command of - Nothing -> "" - Just desc -> '\n': desc pname) - ++ "\n" - ++ ( if cname == "" - then "Global flags:" - else "Flags for " ++ cname ++ ":" ) - ++ ( GetOpt.usageInfo "" - . addCommonFlags ShowArgs - $ commandGetOpts ShowArgs command ) - ++ ( case commandNotes command of - Nothing -> "" - Just notes -> '\n': notes pname) - where cname = commandName command + commandSynopsis command + ++ "\n\n" + ++ commandUsage command pname + ++ ( case commandDescription command of + Nothing -> "" + Just desc -> '\n' : desc pname + ) + ++ "\n" + ++ ( if cname == "" + then "Global flags:" + else "Flags for " ++ cname ++ ":" + ) + ++ ( GetOpt.usageInfo "" + . addCommonFlags ShowArgs + $ commandGetOpts ShowArgs command + ) + ++ ( case commandNotes command of + Nothing -> "" + Just notes -> '\n' : notes pname + ) + where + cname = commandName command -- | Default "usage" documentation text for commands. usageDefault :: String -> String -> String usageDefault name pname = - "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n" - ++ "Flags for " ++ name ++ ":" + "Usage: " + ++ pname + ++ " " + ++ name + ++ " [FLAGS]\n\n" + ++ "Flags for " + ++ name + ++ ":" -- | Create "usage" documentation from a list of parameter -- configurations. usageAlternatives :: String -> [String] -> String -> String -usageAlternatives name strs pname = unlines - [ start ++ pname ++ " " ++ name ++ " " ++ s - | let starts = "Usage: " : repeat " or: " - , (start, s) <- zip starts strs - ] +usageAlternatives name strs pname = + unlines + [ start ++ pname ++ " " ++ name ++ " " ++ s + | let starts = "Usage: " : repeat " or: " + , (start, s) <- zip starts strs + ] -- | Make a Command from standard 'GetOpt' options. -mkCommandUI :: String -- ^ name - -> String -- ^ synopsis - -> [String] -- ^ usage alternatives - -> flags -- ^ initial\/empty flags - -> (ShowOrParseArgs -> [OptionField flags]) -- ^ options - -> CommandUI flags -mkCommandUI name synopsis usages flags options = CommandUI - { commandName = name - , commandSynopsis = synopsis - , commandDescription = Nothing - , commandNotes = Nothing - , commandUsage = usageAlternatives name usages - , commandDefaultFlags = flags - , commandOptions = options - } +mkCommandUI + :: String + -- ^ name + -> String + -- ^ synopsis + -> [String] + -- ^ usage alternatives + -> flags + -- ^ initial\/empty flags + -> (ShowOrParseArgs -> [OptionField flags]) + -- ^ options + -> CommandUI flags +mkCommandUI name synopsis usages flags options = + CommandUI + { commandName = name + , commandSynopsis = synopsis + , commandDescription = Nothing + , commandNotes = Nothing + , commandUsage = usageAlternatives name usages + , commandDefaultFlags = flags + , commandOptions = options + } -- | Common flags that apply to every command data CommonFlag = HelpFlag | ListOptionsFlag commonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr CommonFlag] commonFlags showOrParseArgs = case showOrParseArgs of - ShowArgs -> [help] + ShowArgs -> [help] ParseArgs -> [help, list] - where - help = GetOpt.Option helpShortFlags ["help"] (GetOpt.NoArg HelpFlag) - "Show this help text" + where + help = + GetOpt.Option + helpShortFlags + ["help"] + (GetOpt.NoArg HelpFlag) + "Show this help text" helpShortFlags = case showOrParseArgs of - ShowArgs -> ['h'] + ShowArgs -> ['h'] ParseArgs -> ['h', '?'] - list = GetOpt.Option [] ["list-options"] (GetOpt.NoArg ListOptionsFlag) - "Print a list of command line flags" - -addCommonFlags :: ShowOrParseArgs - -> [GetOpt.OptDescr a] - -> [GetOpt.OptDescr (Either CommonFlag a)] + list = + GetOpt.Option + [] + ["list-options"] + (GetOpt.NoArg ListOptionsFlag) + "Print a list of command line flags" + +addCommonFlags + :: ShowOrParseArgs + -> [GetOpt.OptDescr a] + -> [GetOpt.OptDescr (Either CommonFlag a)] addCommonFlags showOrParseArgs options = - map (fmap Left) (commonFlags showOrParseArgs) - ++ map (fmap Right) options + map (fmap Left) (commonFlags showOrParseArgs) + ++ map (fmap Right) options -- | Parse a bunch of command line arguments --- -commandParseArgs :: CommandUI flags - -> Bool -- ^ Is the command a global or subcommand? - -> [String] - -> CommandParse (flags -> flags, [String]) +commandParseArgs + :: CommandUI flags + -> Bool + -- ^ Is the command a global or subcommand? + -> [String] + -> CommandParse (flags -> flags, [String]) commandParseArgs command global args = - let options = addCommonFlags ParseArgs - $ commandGetOpts ParseArgs command - order | global = GetOpt.RequireOrder - | otherwise = GetOpt.Permute - in case GetOpt.getOpt' order options args of - (flags, _, _, _) - | any listFlag flags -> CommandList (commandListOptions command) - | any helpFlag flags -> CommandHelp (commandHelp command) - where listFlag (Left ListOptionsFlag) = True; listFlag _ = False - helpFlag (Left HelpFlag) = True; helpFlag _ = False - (flags, opts, opts', []) - | global || null opts' -> CommandReadyToGo (accum flags, mix opts opts') - | otherwise -> CommandErrors (unrecognised opts') - (_, _, _, errs) -> CommandErrors errs - - where -- Note: It is crucial to use reverse function composition here or to - -- reverse the flags here as we want to process the flags left to right - -- but data flow in function composition is right to left. - accum flags = foldr (flip (.)) id [ f | Right f <- flags ] - unrecognised opts = [ "unrecognized " - ++ "'" ++ (commandName command) ++ "'" - ++ " option `" ++ opt ++ "'\n" - | opt <- opts ] - -- For unrecognised global flags we put them in the position just after - -- the command, if there is one. This gives us a chance to parse them - -- as sub-command rather than global flags. - mix [] ys = ys - mix (x:xs) ys = x:ys++xs - -data CommandParse flags = CommandHelp (String -> String) - | CommandList [String] - | CommandErrors [String] - | CommandReadyToGo flags + let options = + addCommonFlags ParseArgs $ + commandGetOpts ParseArgs command + order + | global = GetOpt.RequireOrder + | otherwise = GetOpt.Permute + in case GetOpt.getOpt' order options args of + (flags, _, _, _) + | any listFlag flags -> CommandList (commandListOptions command) + | any helpFlag flags -> CommandHelp (commandHelp command) + where + listFlag (Left ListOptionsFlag) = True; listFlag _ = False + helpFlag (Left HelpFlag) = True; helpFlag _ = False + (flags, opts, opts', []) + | global || null opts' -> CommandReadyToGo (accum flags, mix opts opts') + | otherwise -> CommandErrors (unrecognised opts') + (_, _, _, errs) -> CommandErrors errs + where + -- Note: It is crucial to use reverse function composition here or to + -- reverse the flags here as we want to process the flags left to right + -- but data flow in function composition is right to left. + accum flags = foldr (flip (.)) id [f | Right f <- flags] + unrecognised opts = + [ "unrecognized " + ++ "'" + ++ (commandName command) + ++ "'" + ++ " option `" + ++ opt + ++ "'\n" + | opt <- opts + ] + -- For unrecognised global flags we put them in the position just after + -- the command, if there is one. This gives us a chance to parse them + -- as sub-command rather than global flags. + mix [] ys = ys + mix (x : xs) ys = x : ys ++ xs + +data CommandParse flags + = CommandHelp (String -> String) + | CommandList [String] + | CommandErrors [String] + | CommandReadyToGo flags instance Functor CommandParse where - fmap _ (CommandHelp help) = CommandHelp help - fmap _ (CommandList opts) = CommandList opts - fmap _ (CommandErrors errs) = CommandErrors errs + fmap _ (CommandHelp help) = CommandHelp help + fmap _ (CommandList opts) = CommandList opts + fmap _ (CommandErrors errs) = CommandErrors errs fmap f (CommandReadyToGo flags) = CommandReadyToGo (f flags) - data CommandType = NormalCommand | HiddenCommand -data Command action = - Command String String ([String] -> CommandParse action) CommandType +data Command action + = Command String String ([String] -> CommandParse action) CommandType -- | Mark command as hidden. Hidden commands don't show up in the 'progname -- help' or 'progname --help' output. @@ -467,132 +604,145 @@ hiddenCommand :: Command action -> Command action hiddenCommand (Command name synopsys f _cmdType) = Command name synopsys f HiddenCommand -commandAddAction :: CommandUI flags - -> (flags -> [String] -> action) - -> Command action +commandAddAction + :: CommandUI flags + -> (flags -> [String] -> action) + -> Command action commandAddAction command action = - Command (commandName command) - (commandSynopsis command) - (fmap (uncurry applyDefaultArgs) . commandParseArgs command False) - NormalCommand - - where applyDefaultArgs mkflags args = - let flags = mkflags (commandDefaultFlags command) - in action flags args - -commandsRun :: CommandUI a - -> [Command action] - -> [String] - -> CommandParse (a, CommandParse action) + Command + (commandName command) + (commandSynopsis command) + (fmap (uncurry applyDefaultArgs) . commandParseArgs command False) + NormalCommand + where + applyDefaultArgs mkflags args = + let flags = mkflags (commandDefaultFlags command) + in action flags args + +commandsRun + :: CommandUI a + -> [Command action] + -> [String] + -> CommandParse (a, CommandParse action) commandsRun globalCommand commands args = case commandParseArgs globalCommand True args of - CommandHelp help -> CommandHelp help - CommandList opts -> CommandList (opts ++ commandNames) - CommandErrors errs -> CommandErrors errs + CommandHelp help -> CommandHelp help + CommandList opts -> CommandList (opts ++ commandNames) + CommandErrors errs -> CommandErrors errs CommandReadyToGo (mkflags, args') -> case args' of - ("help":cmdArgs) -> handleHelpCommand cmdArgs - (name:cmdArgs) -> case lookupCommand name of - [Command _ _ action _] - -> CommandReadyToGo (flags, action cmdArgs) + ("help" : cmdArgs) -> handleHelpCommand cmdArgs + (name : cmdArgs) -> case lookupCommand name of + [Command _ _ action _] -> + CommandReadyToGo (flags, action cmdArgs) _ -> CommandReadyToGo (flags, badCommand name) - [] -> CommandReadyToGo (flags, noCommand) - where flags = mkflags (commandDefaultFlags globalCommand) - - where - lookupCommand cname = [ cmd | cmd@(Command cname' _ _ _) <- commands' - , cname' == cname ] - noCommand = CommandErrors ["no command given (try --help)\n"] + [] -> CommandReadyToGo (flags, noCommand) + where + flags = mkflags (commandDefaultFlags globalCommand) + where + lookupCommand cname = + [ cmd | cmd@(Command cname' _ _ _) <- commands', cname' == cname + ] + noCommand = CommandErrors ["no command given (try --help)\n"] -- Print suggested command if edit distance is < 5 badCommand :: String -> CommandParse a badCommand cname = case eDists of [] -> CommandErrors [unErr] - (s:_) -> CommandErrors [ unErr - , "Maybe you meant `" ++ s ++ "`?\n"] + (s : _) -> + CommandErrors + [ unErr + , "Maybe you meant `" ++ s ++ "`?\n" + ] where - eDists = map fst . List.sortBy (comparing snd) $ - [ (cname', dist) - | (Command cname' _ _ _) <- commands' - , let dist = editDistance cname' cname - , dist < 5 ] + eDists = + map fst . List.sortBy (comparing snd) $ + [ (cname', dist) + | (Command cname' _ _ _) <- commands' + , let dist = editDistance cname' cname + , dist < 5 + ] unErr = "unrecognised command: " ++ cname ++ " (try --help)" - commands' = commands ++ [commandAddAction helpCommandUI undefined] - commandNames = [ name | (Command name _ _ NormalCommand) <- commands' ] + commands' = commands ++ [commandAddAction helpCommandUI undefined] + commandNames = [name | (Command name _ _ NormalCommand) <- commands'] -- A bit of a hack: support "prog help" as a synonym of "prog --help" -- furthermore, support "prog help command" as "prog command --help" handleHelpCommand cmdArgs = case commandParseArgs helpCommandUI True cmdArgs of - CommandHelp help -> CommandHelp help - CommandList list -> CommandList (list ++ commandNames) - CommandErrors _ -> CommandHelp globalHelp - CommandReadyToGo (_,[]) -> CommandHelp globalHelp - CommandReadyToGo (_,(name:cmdArgs')) -> + CommandHelp help -> CommandHelp help + CommandList list -> CommandList (list ++ commandNames) + CommandErrors _ -> CommandHelp globalHelp + CommandReadyToGo (_, []) -> CommandHelp globalHelp + CommandReadyToGo (_, (name : cmdArgs')) -> case lookupCommand name of [Command _ _ action _] -> - case action ("--help":cmdArgs') of + case action ("--help" : cmdArgs') of CommandHelp help -> CommandHelp help - CommandList _ -> CommandList [] - _ -> CommandHelp globalHelp - _ -> badCommand name - - where globalHelp = commandHelp globalCommand + CommandList _ -> CommandList [] + _ -> CommandHelp globalHelp + _ -> badCommand name + where + globalHelp = commandHelp globalCommand -- Levenshtein distance, from https://wiki.haskell.org/Edit_distance -- (Author: JeanPhilippeBernardy, Simple Permissive Licence) editDistance :: Eq a => [a] -> [a] -> Int -editDistance xs ys = table Array.! (m,n) +editDistance xs ys = table Array.! (m, n) where - (m,n) = (length xs, length ys) - x = Array.array (1,m) (zip [1..] xs) - y = Array.array (1,n) (zip [1..] ys) + (m, n) = (length xs, length ys) + x = Array.array (1, m) (zip [1 ..] xs) + y = Array.array (1, n) (zip [1 ..] ys) - table :: Array.Array (Int,Int) Int + table :: Array.Array (Int, Int) Int table = Array.array bnds [(ij, dist ij) | ij <- Array.range bnds] - bnds = ((0,0),(m,n)) - - dist (0,j) = j - dist (i,0) = i - dist (i,j) = minimum - [ table Array.! (i-1,j) + 1 - , table Array.! (i,j-1) + 1 - , if x Array.! i == y Array.! j - then table Array.! (i-1,j-1) - else 1 + table Array.! (i-1,j-1) - ] + bnds = ((0, 0), (m, n)) + + dist (0, j) = j + dist (i, 0) = i + dist (i, j) = + minimum + [ table Array.! (i - 1, j) + 1 + , table Array.! (i, j - 1) + 1 + , if x Array.! i == y Array.! j + then table Array.! (i - 1, j - 1) + else 1 + table Array.! (i - 1, j - 1) + ] -- | Utility function, many commands do not accept additional flags. This -- action fails with a helpful error message if the user supplies any extra. --- noExtraFlags :: [String] -> IO () noExtraFlags [] = return () noExtraFlags extraFlags = dieNoVerbosity $ "Unrecognised flags: " ++ intercalate ", " extraFlags ---TODO: eliminate this function and turn it into a variant on commandAddAction + +-- TODO: eliminate this function and turn it into a variant on commandAddAction -- instead like commandAddActionNoArgs that doesn't supply the [String] -- | Helper function for creating globalCommand description getNormalCommandDescriptions :: [Command action] -> [(String, String)] getNormalCommandDescriptions cmds = [ (name, description) - | Command name description _ NormalCommand <- cmds ] + | Command name description _ NormalCommand <- cmds + ] helpCommandUI :: CommandUI () helpCommandUI = - (mkCommandUI - "help" - "Help about commands." - ["[FLAGS]", "COMMAND [FLAGS]"] - () - (const [])) - { - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " help help\n" - ++ " Oh, apparently you already know this.\n" - } + ( mkCommandUI + "help" + "Help about commands." + ["[FLAGS]", "COMMAND [FLAGS]"] + () + (const []) + ) + { commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " + ++ pname + ++ " help help\n" + ++ " Oh, apparently you already know this.\n" + } -- | wraps a @CommandUI@ together with a function that turns it into a @Command@. -- By hiding the type of flags for the UI allows construction of a list of all UIs at the diff --git a/Cabal/src/Distribution/Simple/Compiler.hs b/Cabal/src/Distribution/Simple/Compiler.hs index 71275e52a8a..074f2f38b5c 100644 --- a/Cabal/src/Distribution/Simple/Compiler.hs +++ b/Cabal/src/Distribution/Simple/Compiler.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Compiler -- Copyright : Isaac Jones 2003-2004 @@ -20,88 +21,89 @@ -- only know about a single global package collection but GHC has a global and -- per-user one and it lets you create arbitrary other package databases. We do -- not yet fully support this latter feature. - -module Distribution.Simple.Compiler ( - -- * Haskell implementations - module Distribution.Compiler, - Compiler(..), - showCompilerId, showCompilerIdWithAbi, - compilerFlavor, compilerVersion, - compilerCompatFlavor, - compilerCompatVersion, - compilerInfo, - - -- * Support for package databases - PackageDB(..), - PackageDBStack, - registrationPackageDB, - absolutePackageDBPaths, - absolutePackageDBPath, - - -- * Support for optimisation levels - OptimisationLevel(..), - flagToOptimisationLevel, - - -- * Support for debug info levels - DebugInfoLevel(..), - flagToDebugInfoLevel, - - -- * Support for language extensions - CompilerFlag, - languageToFlags, - unsupportedLanguages, - extensionsToFlags, - unsupportedExtensions, - parmakeSupported, - reexportedModulesSupported, - renamingPackageFlagsSupported, - unifiedIPIDRequired, - packageKeySupported, - unitIdSupported, - coverageSupported, - profilingSupported, - backpackSupported, - arResponseFilesSupported, - arDashLSupported, - libraryDynDirSupported, - libraryVisibilitySupported, - - -- * Support for profiling detail levels - ProfDetailLevel(..), - knownProfDetailLevels, - flagToProfDetailLevel, - showProfDetailLevel, +module Distribution.Simple.Compiler + ( -- * Haskell implementations + module Distribution.Compiler + , Compiler (..) + , showCompilerId + , showCompilerIdWithAbi + , compilerFlavor + , compilerVersion + , compilerCompatFlavor + , compilerCompatVersion + , compilerInfo + + -- * Support for package databases + , PackageDB (..) + , PackageDBStack + , registrationPackageDB + , absolutePackageDBPaths + , absolutePackageDBPath + + -- * Support for optimisation levels + , OptimisationLevel (..) + , flagToOptimisationLevel + + -- * Support for debug info levels + , DebugInfoLevel (..) + , flagToDebugInfoLevel + + -- * Support for language extensions + , CompilerFlag + , languageToFlags + , unsupportedLanguages + , extensionsToFlags + , unsupportedExtensions + , parmakeSupported + , reexportedModulesSupported + , renamingPackageFlagsSupported + , unifiedIPIDRequired + , packageKeySupported + , unitIdSupported + , coverageSupported + , profilingSupported + , backpackSupported + , arResponseFilesSupported + , arDashLSupported + , libraryDynDirSupported + , libraryVisibilitySupported + + -- * Support for profiling detail levels + , ProfDetailLevel (..) + , knownProfDetailLevels + , flagToProfDetailLevel + , showProfDetailLevel ) where -import Prelude () import Distribution.Compat.Prelude import Distribution.Pretty +import Prelude () import Distribution.Compiler +import Distribution.Simple.Utils import Distribution.Version import Language.Haskell.Extension -import Distribution.Simple.Utils import qualified Data.Map as Map (lookup) import System.Directory (canonicalizePath) -data Compiler = Compiler { - compilerId :: CompilerId, - -- ^ Compiler flavour and version. - compilerAbiTag :: AbiTag, - -- ^ Tag for distinguishing incompatible ABI's on the same - -- architecture/os. - compilerCompat :: [CompilerId], - -- ^ Other implementations that this compiler claims to be - -- compatible with. - compilerLanguages :: [(Language, CompilerFlag)], - -- ^ Supported language standards. - compilerExtensions :: [(Extension, Maybe CompilerFlag)], - -- ^ Supported extensions. - compilerProperties :: Map String String - -- ^ A key-value map for properties not covered by the above fields. - } - deriving (Eq, Generic, Typeable, Show, Read) +data Compiler = Compiler + { compilerId :: CompilerId + -- ^ Compiler flavour and version. + , compilerAbiTag :: AbiTag + -- ^ Tag for distinguishing incompatible ABI's on the same + -- architecture/os. + , compilerCompat :: [CompilerId] + -- ^ Other implementations that this compiler claims to be + -- compatible with. + , compilerLanguages :: [(Language, CompilerFlag)] + -- ^ Supported language standards. + , compilerExtensions :: [(Extension, Maybe CompilerFlag)] + -- ^ Supported extensions. + , compilerProperties :: Map String String + -- ^ A key-value map for properties not covered by the above fields. + } + deriving (Eq, Generic, Typeable, Show, Read) instance Binary Compiler instance Structured Compiler @@ -111,30 +113,27 @@ showCompilerId = prettyShow . compilerId showCompilerIdWithAbi :: Compiler -> String showCompilerIdWithAbi comp = - prettyShow (compilerId comp) ++ - case compilerAbiTag comp of - NoAbiTag -> [] - AbiTag xs -> '-':xs + prettyShow (compilerId comp) + ++ case compilerAbiTag comp of + NoAbiTag -> [] + AbiTag xs -> '-' : xs -compilerFlavor :: Compiler -> CompilerFlavor +compilerFlavor :: Compiler -> CompilerFlavor compilerFlavor = (\(CompilerId f _) -> f) . compilerId compilerVersion :: Compiler -> Version compilerVersion = (\(CompilerId _ v) -> v) . compilerId - -- | Is this compiler compatible with the compiler flavour we're interested in? -- -- For example this checks if the compiler is actually GHC or is another -- compiler that claims to be compatible with some version of GHC, e.g. GHCJS. -- -- > if compilerCompatFlavor GHC compiler then ... else ... --- compilerCompatFlavor :: CompilerFlavor -> Compiler -> Bool compilerCompatFlavor flavor comp = - flavor == compilerFlavor comp - || flavor `elem` [ flavor' | CompilerId flavor' _ <- compilerCompat comp ] - + flavor == compilerFlavor comp + || flavor `elem` [flavor' | CompilerId flavor' _ <- compilerCompat comp] -- | Is this compiler compatible with the compiler flavour we're interested in, -- and if so what version does it claim to be compatible with. @@ -145,35 +144,38 @@ compilerCompatFlavor flavor comp = -- > case compilerCompatVersion GHC compiler of -- > Just (Version (7:_)) -> ... -- > _ -> ... --- compilerCompatVersion :: CompilerFlavor -> Compiler -> Maybe Version compilerCompatVersion flavor comp | compilerFlavor comp == flavor = Just (compilerVersion comp) - | otherwise = - listToMaybe [ v | CompilerId fl v <- compilerCompat comp, fl == flavor ] + | otherwise = + listToMaybe [v | CompilerId fl v <- compilerCompat comp, fl == flavor] compilerInfo :: Compiler -> CompilerInfo -compilerInfo c = CompilerInfo (compilerId c) - (compilerAbiTag c) - (Just . compilerCompat $ c) - (Just . map fst . compilerLanguages $ c) - (Just . map fst . compilerExtensions $ c) +compilerInfo c = + CompilerInfo + (compilerId c) + (compilerAbiTag c) + (Just . compilerCompat $ c) + (Just . map fst . compilerLanguages $ c) + (Just . map fst . compilerExtensions $ c) -- ------------------------------------------------------------ + -- * Package databases + -- ------------------------------------------------------------ --- |Some compilers have a notion of a database of available packages. --- For some there is just one global db of packages, other compilers --- support a per-user or an arbitrary db specified at some location in --- the file system. This can be used to build isolated environments of --- packages, for example to build a collection of related packages --- without installing them globally. --- -data PackageDB = GlobalPackageDB - | UserPackageDB - | SpecificPackageDB FilePath - deriving (Eq, Generic, Ord, Show, Read, Typeable) +-- | Some compilers have a notion of a database of available packages. +-- For some there is just one global db of packages, other compilers +-- support a per-user or an arbitrary db specified at some location in +-- the file system. This can be used to build isolated environments of +-- packages, for example to build a collection of related packages +-- without installing them globally. +data PackageDB + = GlobalPackageDB + | UserPackageDB + | SpecificPackageDB FilePath + deriving (Eq, Generic, Ord, Show, Read, Typeable) instance Binary PackageDB instance Structured PackageDB @@ -193,114 +195,126 @@ instance Structured PackageDB -- we can use several custom package dbs and the user package db together. -- -- When it comes to writing, the top most (last) package is used. --- type PackageDBStack = [PackageDB] -- | Return the package that we should register into. This is the package db at -- the top of the stack. --- registrationPackageDB :: PackageDBStack -> PackageDB -registrationPackageDB dbs = case safeLast dbs of +registrationPackageDB dbs = case safeLast dbs of Nothing -> error "internal error: empty package db set" - Just p -> p + Just p -> p -- | Make package paths absolute - - absolutePackageDBPaths :: PackageDBStack -> IO PackageDBStack absolutePackageDBPaths = traverse absolutePackageDBPath absolutePackageDBPath :: PackageDB -> IO PackageDB -absolutePackageDBPath GlobalPackageDB = return GlobalPackageDB -absolutePackageDBPath UserPackageDB = return UserPackageDB +absolutePackageDBPath GlobalPackageDB = return GlobalPackageDB +absolutePackageDBPath UserPackageDB = return UserPackageDB absolutePackageDBPath (SpecificPackageDB db) = SpecificPackageDB `liftM` canonicalizePath db -- ------------------------------------------------------------ + -- * Optimisation levels + -- ------------------------------------------------------------ -- | Some compilers support optimising. Some have different levels. -- For compilers that do not the level is just capped to the level -- they do support. --- -data OptimisationLevel = NoOptimisation - | NormalOptimisation - | MaximumOptimisation - deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable) +data OptimisationLevel + = NoOptimisation + | NormalOptimisation + | MaximumOptimisation + deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable) instance Binary OptimisationLevel instance Structured OptimisationLevel flagToOptimisationLevel :: Maybe String -> OptimisationLevel -flagToOptimisationLevel Nothing = NormalOptimisation +flagToOptimisationLevel Nothing = NormalOptimisation flagToOptimisationLevel (Just s) = case reads s of [(i, "")] | i >= fromEnum (minBound :: OptimisationLevel) - && i <= fromEnum (maxBound :: OptimisationLevel) - -> toEnum i - | otherwise -> error $ "Bad optimisation level: " ++ show i - ++ ". Valid values are 0..2" - _ -> error $ "Can't parse optimisation level " ++ s + && i <= fromEnum (maxBound :: OptimisationLevel) -> + toEnum i + | otherwise -> + error $ + "Bad optimisation level: " + ++ show i + ++ ". Valid values are 0..2" + _ -> error $ "Can't parse optimisation level " ++ s -- ------------------------------------------------------------ + -- * Debug info levels + -- ------------------------------------------------------------ -- | Some compilers support emitting debug info. Some have different -- levels. For compilers that do not the level is just capped to the -- level they do support. --- -data DebugInfoLevel = NoDebugInfo - | MinimalDebugInfo - | NormalDebugInfo - | MaximalDebugInfo - deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable) +data DebugInfoLevel + = NoDebugInfo + | MinimalDebugInfo + | NormalDebugInfo + | MaximalDebugInfo + deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable) instance Binary DebugInfoLevel instance Structured DebugInfoLevel flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel -flagToDebugInfoLevel Nothing = NormalDebugInfo +flagToDebugInfoLevel Nothing = NormalDebugInfo flagToDebugInfoLevel (Just s) = case reads s of [(i, "")] | i >= fromEnum (minBound :: DebugInfoLevel) - && i <= fromEnum (maxBound :: DebugInfoLevel) - -> toEnum i - | otherwise -> error $ "Bad debug info level: " ++ show i - ++ ". Valid values are 0..3" - _ -> error $ "Can't parse debug info level " ++ s + && i <= fromEnum (maxBound :: DebugInfoLevel) -> + toEnum i + | otherwise -> + error $ + "Bad debug info level: " + ++ show i + ++ ". Valid values are 0..3" + _ -> error $ "Can't parse debug info level " ++ s -- ------------------------------------------------------------ + -- * Languages and Extensions + -- ------------------------------------------------------------ unsupportedLanguages :: Compiler -> [Language] -> [Language] unsupportedLanguages comp langs = - [ lang | lang <- langs - , isNothing (languageToFlag comp lang) ] + [ lang | lang <- langs, isNothing (languageToFlag comp lang) + ] languageToFlags :: Compiler -> Maybe Language -> [CompilerFlag] -languageToFlags comp = filter (not . null) - . catMaybes . map (languageToFlag comp) - . maybe [Haskell98] (\x->[x]) +languageToFlags comp = + filter (not . null) + . catMaybes + . map (languageToFlag comp) + . maybe [Haskell98] (\x -> [x]) languageToFlag :: Compiler -> Language -> Maybe CompilerFlag languageToFlag comp ext = lookup ext (compilerLanguages comp) - --- |For the given compiler, return the extensions it does not support. +-- | For the given compiler, return the extensions it does not support. unsupportedExtensions :: Compiler -> [Extension] -> [Extension] unsupportedExtensions comp exts = - [ ext | ext <- exts - , isNothing (extensionToFlag' comp ext) ] + [ ext | ext <- exts, isNothing (extensionToFlag' comp ext) + ] type CompilerFlag = String --- |For the given compiler, return the flags for the supported extensions. +-- | For the given compiler, return the flags for the supported extensions. extensionsToFlags :: Compiler -> [Extension] -> [CompilerFlag] -extensionsToFlags comp = nub . filter (not . null) - . catMaybes . map (extensionToFlag comp) +extensionsToFlags comp = + nub + . filter (not . null) + . catMaybes + . map (extensionToFlag comp) -- | Looks up the flag for a given extension, for a given compiler. -- Ignores the subtlety of extensions which lack associated flags. @@ -329,8 +343,9 @@ reexportedModulesSupported = ghcSupported "Support reexported-modules" -- | Does this compiler support thinning/renaming on package flags? renamingPackageFlagsSupported :: Compiler -> Bool -renamingPackageFlagsSupported = ghcSupported - "Support thinning and renaming package flags" +renamingPackageFlagsSupported = + ghcSupported + "Support thinning and renaming package flags" -- | Does this compiler have unified IPIDs (so no package keys) unifiedIPIDRequired :: Compiler -> Bool @@ -353,13 +368,14 @@ backpackSupported = ghcSupported "Support Backpack" libraryDynDirSupported :: Compiler -> Bool libraryDynDirSupported comp = case compilerFlavor comp of GHC -> - -- Not just v >= mkVersion [8,0,1,20161022], as there - -- are many GHC 8.1 nightlies which don't support this. - ((v >= mkVersion [8,0,1,20161022] && v < mkVersion [8,1]) || - v >= mkVersion [8,1,20161021]) - _ -> False - where - v = compilerVersion comp + -- Not just v >= mkVersion [8,0,1,20161022], as there + -- are many GHC 8.1 nightlies which don't support this. + ( (v >= mkVersion [8, 0, 1, 20161022] && v < mkVersion [8, 1]) + || v >= mkVersion [8, 1, 20161021] + ) + _ -> False + where + v = compilerVersion comp -- | Does this compiler's "ar" command supports response file -- arguments (i.e. @file-style arguments). @@ -376,41 +392,44 @@ arDashLSupported = ghcSupported "ar supports -L" coverageSupported :: Compiler -> Bool coverageSupported comp = case compilerFlavor comp of - GHC -> True + GHC -> True GHCJS -> True - _ -> False + _ -> False -- | Does this compiler support profiling? profilingSupported :: Compiler -> Bool profilingSupported comp = case compilerFlavor comp of - GHC -> True + GHC -> True GHCJS -> True - _ -> False + _ -> False -- | Does this compiler support a package database entry with: -- "visibility"? libraryVisibilitySupported :: Compiler -> Bool libraryVisibilitySupported comp = case compilerFlavor comp of - GHC -> v >= mkVersion [8,8] - _ -> False - where - v = compilerVersion comp + GHC -> v >= mkVersion [8, 8] + _ -> False + where + v = compilerVersion comp -- | Utility function for GHC only features ghcSupported :: String -> Compiler -> Bool ghcSupported key comp = case compilerFlavor comp of - GHC -> checkProp + GHC -> checkProp GHCJS -> checkProp - _ -> False - where checkProp = - case Map.lookup key (compilerProperties comp) of - Just "YES" -> True - _ -> False + _ -> False + where + checkProp = + case Map.lookup key (compilerProperties comp) of + Just "YES" -> True + _ -> False -- ------------------------------------------------------------ + -- * Profiling detail level + -- ------------------------------------------------------------ -- | Some compilers (notably GHC) support profiling and can instrument @@ -419,45 +438,47 @@ ghcSupported key comp = -- For compilers that do not support this notion or the particular detail -- levels, this is either ignored or just capped to some similar level -- they do support. --- -data ProfDetailLevel = ProfDetailNone - | ProfDetailDefault - | ProfDetailExportedFunctions - | ProfDetailToplevelFunctions - | ProfDetailAllFunctions - | ProfDetailTopLate - | ProfDetailOther String - deriving (Eq, Generic, Read, Show, Typeable) +data ProfDetailLevel + = ProfDetailNone + | ProfDetailDefault + | ProfDetailExportedFunctions + | ProfDetailToplevelFunctions + | ProfDetailAllFunctions + | ProfDetailTopLate + | ProfDetailOther String + deriving (Eq, Generic, Read, Show, Typeable) instance Binary ProfDetailLevel instance Structured ProfDetailLevel flagToProfDetailLevel :: String -> ProfDetailLevel flagToProfDetailLevel "" = ProfDetailDefault -flagToProfDetailLevel s = - case lookup (lowercase s) - [ (name, value) - | (primary, aliases, value) <- knownProfDetailLevels - , name <- primary : aliases ] - of Just value -> value - Nothing -> ProfDetailOther s +flagToProfDetailLevel s = + case lookup + (lowercase s) + [ (name, value) + | (primary, aliases, value) <- knownProfDetailLevels + , name <- primary : aliases + ] of + Just value -> value + Nothing -> ProfDetailOther s knownProfDetailLevels :: [(String, [String], ProfDetailLevel)] knownProfDetailLevels = - [ ("default", [], ProfDetailDefault) - , ("none", [], ProfDetailNone) - , ("exported-functions", ["exported"], ProfDetailExportedFunctions) + [ ("default", [], ProfDetailDefault) + , ("none", [], ProfDetailNone) + , ("exported-functions", ["exported"], ProfDetailExportedFunctions) , ("toplevel-functions", ["toplevel", "top"], ProfDetailToplevelFunctions) - , ("all-functions", ["all"], ProfDetailAllFunctions) - , ("late-toplevel", ["late"], ProfDetailTopLate) + , ("all-functions", ["all"], ProfDetailAllFunctions) + , ("late-toplevel", ["late"], ProfDetailTopLate) ] showProfDetailLevel :: ProfDetailLevel -> String showProfDetailLevel dl = case dl of - ProfDetailNone -> "none" - ProfDetailDefault -> "default" - ProfDetailExportedFunctions -> "exported-functions" - ProfDetailToplevelFunctions -> "toplevel-functions" - ProfDetailAllFunctions -> "all-functions" - ProfDetailTopLate -> "late-toplevel" - ProfDetailOther other -> other + ProfDetailNone -> "none" + ProfDetailDefault -> "default" + ProfDetailExportedFunctions -> "exported-functions" + ProfDetailToplevelFunctions -> "toplevel-functions" + ProfDetailAllFunctions -> "all-functions" + ProfDetailTopLate -> "late-toplevel" + ProfDetailOther other -> other diff --git a/Cabal/src/Distribution/Simple/Configure.hs b/Cabal/src/Distribution/Simple/Configure.hs index 03a1d45973d..1224661a36e 100644 --- a/Cabal/src/Distribution/Simple/Configure.hs +++ b/Cabal/src/Distribution/Simple/Configure.hs @@ -6,6 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Configure -- Copyright : Isaac Jones 2003-2005 @@ -27,7 +28,6 @@ -- it out to the @dist\/setup-config@ file. It also displays various details to -- the user, the amount of information displayed depending on the verbosity -- level. - module Distribution.Simple.Configure ( configure , writePersistBuildConfig @@ -36,7 +36,8 @@ module Distribution.Simple.Configure , checkPersistBuildConfigOutdated , tryGetPersistBuildConfig , maybeGetPersistBuildConfig - , findDistPref, findDistPrefOrDefault + , findDistPref + , findDistPrefOrDefault , getInternalLibraries , computeComponentId , computeCompatPackageKey @@ -44,203 +45,258 @@ module Distribution.Simple.Configure , getInstalledPackages , getInstalledPackagesMonitorFiles , getPackageDBContents - , configCompilerEx, configCompilerAuxEx + , configCompilerEx + , configCompilerAuxEx , computeEffectiveProfiling , ccLdOptionsBuildInfo , checkForeignDeps , interpretPackageDbFlags - , ConfigStateFileError(..) + , ConfigStateFileError (..) , tryGetConfigStateFile - , platformDefines, + , platformDefines ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () +import Distribution.Backpack.Configure +import Distribution.Backpack.ConfiguredComponent (newPackageDepsBehaviour) +import Distribution.Backpack.DescribeUnitId +import Distribution.Backpack.Id +import Distribution.Backpack.PreExistingComponent +import qualified Distribution.Compat.Graph as Graph +import Distribution.Compat.Stack import Distribution.Compiler -import Distribution.Types.IncludeRenaming -import Distribution.Utils.NubList -import Distribution.Simple.Compiler -import Distribution.Simple.PreProcess -import Distribution.Package -import qualified Distribution.InstalledPackageInfo as IPI import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.Package import Distribution.PackageDescription -import Distribution.PackageDescription.PrettyPrint -import Distribution.PackageDescription.Configuration import Distribution.PackageDescription.Check hiding (doesFileExist) +import Distribution.PackageDescription.Configuration +import Distribution.PackageDescription.PrettyPrint +import Distribution.Simple.BuildTarget import Distribution.Simple.BuildToolDepends +import Distribution.Simple.Compiler +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PreProcess import Distribution.Simple.Program -import Distribution.Simple.Setup.Config as Setup import Distribution.Simple.Setup.Common as Setup -import Distribution.Simple.BuildTarget -import Distribution.Simple.LocalBuildInfo -import Distribution.Types.PackageVersionConstraint -import Distribution.Types.LocalBuildInfo -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.GivenComponent +import Distribution.Simple.Setup.Config as Setup import Distribution.Simple.Utils import Distribution.System -import Distribution.Version -import Distribution.Verbosity -import qualified Distribution.Compat.Graph as Graph -import Distribution.Compat.Stack -import Distribution.Backpack.Configure -import Distribution.Backpack.DescribeUnitId -import Distribution.Backpack.PreExistingComponent -import Distribution.Backpack.ConfiguredComponent (newPackageDepsBehaviour) -import Distribution.Backpack.Id +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.GivenComponent +import Distribution.Types.LocalBuildInfo +import Distribution.Types.PackageVersionConstraint import Distribution.Utils.LogProgress +import Distribution.Utils.NubList +import Distribution.Verbosity +import Distribution.Version -import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.UHC as UHC import qualified Distribution.Simple.HaskellSuite as HaskellSuite +import qualified Distribution.Simple.UHC as UHC import Control.Exception - ( try ) -import Distribution.Utils.Structured ( structuredDecodeOrFailIO, structuredEncode ) -import Distribution.Compat.Directory ( listDirectory ) -import Data.ByteString.Lazy ( ByteString ) -import qualified Data.ByteString as BS + ( try + ) +import qualified Data.ByteString as BS +import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy.Char8 as BLC8 import Data.List - ( (\\), stripPrefix, intersect) + ( intersect + , stripPrefix + , (\\) + ) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map +import Distribution.Compat.Directory + ( doesPathExist + , listDirectory + ) +import Distribution.Compat.Environment (lookupEnv) +import Distribution.Parsec + ( simpleParsec + ) +import Distribution.Pretty + ( defaultStyle + , pretty + , prettyShow + ) +import Distribution.Utils.Structured (structuredDecodeOrFailIO, structuredEncode) import System.Directory - ( canonicalizePath, createDirectoryIfMissing, doesFileExist - , getTemporaryDirectory, removeFile) + ( canonicalizePath + , createDirectoryIfMissing + , doesFileExist + , getTemporaryDirectory + , removeFile + ) import System.FilePath - ( (), isAbsolute, takeDirectory ) -import Distribution.Compat.Directory - ( doesPathExist ) -import qualified System.Info - ( compilerName, compilerVersion ) + ( isAbsolute + , takeDirectory + , () + ) import System.IO - ( hPutStrLn, hClose ) -import Distribution.Pretty - ( pretty, defaultStyle, prettyShow ) -import Distribution.Parsec - ( simpleParsec ) + ( hClose + , hPutStrLn + ) +import qualified System.Info + ( compilerName + , compilerVersion + ) import Text.PrettyPrint - ( Doc, ($+$), char, comma, hsep, nest - , punctuate, quotes, render, renderStyle, sep, text ) -import Distribution.Compat.Environment ( lookupEnv ) + ( Doc + , char + , comma + , hsep + , nest + , punctuate + , quotes + , render + , renderStyle + , sep + , text + , ($+$) + ) import qualified Data.Maybe as M import qualified Data.Set as Set import qualified Distribution.Compat.NonEmptySet as NES - type UseExternalInternalDeps = Bool -- | The errors that can be thrown when reading the @setup-config@ file. data ConfigStateFileError - = ConfigStateFileNoHeader -- ^ No header found. - | ConfigStateFileBadHeader -- ^ Incorrect header. - | ConfigStateFileNoParse -- ^ Cannot parse file contents. - | ConfigStateFileMissing -- ^ No file! - | ConfigStateFileBadVersion PackageIdentifier PackageIdentifier - (Either ConfigStateFileError LocalBuildInfo) -- ^ Mismatched version. + = -- | No header found. + ConfigStateFileNoHeader + | -- | Incorrect header. + ConfigStateFileBadHeader + | -- | Cannot parse file contents. + ConfigStateFileNoParse + | -- | No file! + ConfigStateFileMissing + | -- | Mismatched version. + ConfigStateFileBadVersion + PackageIdentifier + PackageIdentifier + (Either ConfigStateFileError LocalBuildInfo) deriving (Typeable) -- | Format a 'ConfigStateFileError' as a user-facing error message. dispConfigStateFileError :: ConfigStateFileError -> Doc dispConfigStateFileError ConfigStateFileNoHeader = - text "Saved package config file header is missing." + text "Saved package config file header is missing." <+> text "Re-run the 'configure' command." dispConfigStateFileError ConfigStateFileBadHeader = - text "Saved package config file header is corrupt." + text "Saved package config file header is corrupt." <+> text "Re-run the 'configure' command." dispConfigStateFileError ConfigStateFileNoParse = - text "Saved package config file is corrupt." + text "Saved package config file is corrupt." <+> text "Re-run the 'configure' command." dispConfigStateFileError ConfigStateFileMissing = - text "Run the 'configure' command first." + text "Run the 'configure' command first." dispConfigStateFileError (ConfigStateFileBadVersion oldCabal oldCompiler _) = - text "Saved package config file is outdated:" - $+$ badCabal $+$ badCompiler + text "Saved package config file is outdated:" + $+$ badCabal + $+$ badCompiler $+$ text "Re-run the 'configure' command." - where - badCabal = - text "• the Cabal version changed from" - <+> pretty oldCabal <+> "to" <+> pretty currentCabalId - badCompiler - | oldCompiler == currentCompilerId = mempty - | otherwise = - text "• the compiler changed from" - <+> pretty oldCompiler <+> "to" <+> pretty currentCompilerId + where + badCabal = + text "• the Cabal version changed from" + <+> pretty oldCabal + <+> "to" + <+> pretty currentCabalId + badCompiler + | oldCompiler == currentCompilerId = mempty + | otherwise = + text "• the compiler changed from" + <+> pretty oldCompiler + <+> "to" + <+> pretty currentCompilerId instance Show ConfigStateFileError where - show = renderStyle defaultStyle . dispConfigStateFileError + show = renderStyle defaultStyle . dispConfigStateFileError instance Exception ConfigStateFileError -- | Read the 'localBuildInfoFile'. Throw an exception if the file is -- missing, if the file cannot be read, or if the file was created by an older -- version of Cabal. -getConfigStateFile :: FilePath -- ^ The file path of the @setup-config@ file. - -> IO LocalBuildInfo +getConfigStateFile + :: FilePath + -- ^ The file path of the @setup-config@ file. + -> IO LocalBuildInfo getConfigStateFile filename = do - exists <- doesFileExist filename - unless exists $ throwIO ConfigStateFileMissing - -- Read the config file into a strict ByteString to avoid problems with - -- lazy I/O, then convert to lazy because the binary package needs that. - contents <- BS.readFile filename - let (header, body) = BLC8.span (/='\n') (BLC8.fromChunks [contents]) - - (cabalId, compId) <- parseHeader header - - let getStoredValue = do - result <- structuredDecodeOrFailIO (BLC8.tail body) - case result of - Left _ -> throwIO ConfigStateFileNoParse - Right x -> return x - deferErrorIfBadVersion act - | cabalId /= currentCabalId = do - eResult <- try act - throwIO $ ConfigStateFileBadVersion cabalId compId eResult - | otherwise = act - deferErrorIfBadVersion getStoredValue + exists <- doesFileExist filename + unless exists $ throwIO ConfigStateFileMissing + -- Read the config file into a strict ByteString to avoid problems with + -- lazy I/O, then convert to lazy because the binary package needs that. + contents <- BS.readFile filename + let (header, body) = BLC8.span (/= '\n') (BLC8.fromChunks [contents]) + + (cabalId, compId) <- parseHeader header + + let getStoredValue = do + result <- structuredDecodeOrFailIO (BLC8.tail body) + case result of + Left _ -> throwIO ConfigStateFileNoParse + Right x -> return x + deferErrorIfBadVersion act + | cabalId /= currentCabalId = do + eResult <- try act + throwIO $ ConfigStateFileBadVersion cabalId compId eResult + | otherwise = act + deferErrorIfBadVersion getStoredValue where _ = callStack -- TODO: attach call stack to exception -- | Read the 'localBuildInfoFile', returning either an error or the local build -- info. -tryGetConfigStateFile :: FilePath -- ^ The file path of the @setup-config@ file. - -> IO (Either ConfigStateFileError LocalBuildInfo) +tryGetConfigStateFile + :: FilePath + -- ^ The file path of the @setup-config@ file. + -> IO (Either ConfigStateFileError LocalBuildInfo) tryGetConfigStateFile = try . getConfigStateFile -- | Try to read the 'localBuildInfoFile'. -tryGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path. - -> IO (Either ConfigStateFileError LocalBuildInfo) +tryGetPersistBuildConfig + :: FilePath + -- ^ The @dist@ directory path. + -> IO (Either ConfigStateFileError LocalBuildInfo) tryGetPersistBuildConfig = try . getPersistBuildConfig -- | Read the 'localBuildInfoFile'. Throw an exception if the file is -- missing, if the file cannot be read, or if the file was created by an older -- version of Cabal. -getPersistBuildConfig :: FilePath -- ^ The @dist@ directory path. - -> IO LocalBuildInfo +getPersistBuildConfig + :: FilePath + -- ^ The @dist@ directory path. + -> IO LocalBuildInfo getPersistBuildConfig = getConfigStateFile . localBuildInfoFile -- | Try to read the 'localBuildInfoFile'. -maybeGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path. - -> IO (Maybe LocalBuildInfo) +maybeGetPersistBuildConfig + :: FilePath + -- ^ The @dist@ directory path. + -> IO (Maybe LocalBuildInfo) maybeGetPersistBuildConfig = - liftM (either (const Nothing) Just) . tryGetPersistBuildConfig + liftM (either (const Nothing) Just) . tryGetPersistBuildConfig -- | After running configure, output the 'LocalBuildInfo' to the -- 'localBuildInfoFile'. -writePersistBuildConfig :: FilePath -- ^ The @dist@ directory path. - -> LocalBuildInfo -- ^ The 'LocalBuildInfo' to write. - -> IO () +writePersistBuildConfig + :: FilePath + -- ^ The @dist@ directory path. + -> LocalBuildInfo + -- ^ The 'LocalBuildInfo' to write. + -> IO () writePersistBuildConfig distPref lbi = do - createDirectoryIfMissing False distPref - writeFileAtomic (localBuildInfoFile distPref) $ - BLC8.unlines [showHeader pkgId, structuredEncode lbi] + createDirectoryIfMissing False distPref + writeFileAtomic (localBuildInfoFile distPref) $ + BLC8.unlines [showHeader pkgId, structuredEncode lbi] where pkgId = localPackage lbi @@ -250,30 +306,50 @@ currentCabalId = PackageIdentifier (mkPackageName "Cabal") cabalVersion -- | Identifier of the current compiler package. currentCompilerId :: PackageIdentifier -currentCompilerId = PackageIdentifier (mkPackageName System.Info.compilerName) - (mkVersion' System.Info.compilerVersion) +currentCompilerId = + PackageIdentifier + (mkPackageName System.Info.compilerName) + (mkVersion' System.Info.compilerVersion) -- | Parse the @setup-config@ file header, returning the package identifiers -- for Cabal and the compiler. -parseHeader :: ByteString -- ^ The file contents. - -> IO (PackageIdentifier, PackageIdentifier) +parseHeader + :: ByteString + -- ^ The file contents. + -> IO (PackageIdentifier, PackageIdentifier) parseHeader header = case BLC8.words header of - ["Saved", "package", "config", "for", pkgId, "written", "by", cabalId, - "using", compId] -> + [ "Saved" + , "package" + , "config" + , "for" + , pkgId + , "written" + , "by" + , cabalId + , "using" + , compId + ] -> maybe (throwIO ConfigStateFileBadHeader) return $ do - _ <- simpleParsec (fromUTF8LBS pkgId) :: Maybe PackageIdentifier - cabalId' <- simpleParsec (BLC8.unpack cabalId) - compId' <- simpleParsec (BLC8.unpack compId) - return (cabalId', compId') + _ <- simpleParsec (fromUTF8LBS pkgId) :: Maybe PackageIdentifier + cabalId' <- simpleParsec (BLC8.unpack cabalId) + compId' <- simpleParsec (BLC8.unpack compId) + return (cabalId', compId') _ -> throwIO ConfigStateFileNoHeader -- | Generate the @setup-config@ file header. -showHeader :: PackageIdentifier -- ^ The processed package. - -> ByteString -showHeader pkgId = BLC8.unwords - [ "Saved", "package", "config", "for" +showHeader + :: PackageIdentifier + -- ^ The processed package. + -> ByteString +showHeader pkgId = + BLC8.unwords + [ "Saved" + , "package" + , "config" + , "for" , toUTF8LBS $ prettyShow pkgId - , "written", "by" + , "written" + , "by" , BLC8.pack $ prettyShow currentCabalId , "using" , BLC8.pack $ prettyShow currentCompilerId @@ -286,23 +362,30 @@ checkPersistBuildConfigOutdated distPref pkg_descr_file = pkg_descr_file `moreRecentFile` localBuildInfoFile distPref -- | Get the path of @dist\/setup-config@. -localBuildInfoFile :: FilePath -- ^ The @dist@ directory path. - -> FilePath +localBuildInfoFile + :: FilePath + -- ^ The @dist@ directory path. + -> FilePath localBuildInfoFile distPref = distPref "setup-config" -- ----------------------------------------------------------------------------- + -- * Configuration + -- ----------------------------------------------------------------------------- -- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken -- from (in order of highest to lowest preference) the override prefix, the -- \"CABAL_BUILDDIR\" environment variable, or the default prefix. -findDistPref :: FilePath -- ^ default \"dist\" prefix - -> Setup.Flag FilePath -- ^ override \"dist\" prefix - -> IO FilePath +findDistPref + :: FilePath + -- ^ default \"dist\" prefix + -> Setup.Flag FilePath + -- ^ override \"dist\" prefix + -> IO FilePath findDistPref defDistPref overrideDistPref = do - envDistPref <- liftM parseEnvDistPref (lookupEnv "CABAL_BUILDDIR") - return $ fromFlagOrDefault defDistPref (mappend envDistPref overrideDistPref) + envDistPref <- liftM parseEnvDistPref (lookupEnv "CABAL_BUILDDIR") + return $ fromFlagOrDefault defDistPref (mappend envDistPref overrideDistPref) where parseEnvDistPref env = case env of @@ -315,376 +398,441 @@ findDistPref defDistPref overrideDistPref = do -- this function to resolve a @*DistPref@ flag whenever it is not known to be -- set. (The @*DistPref@ flags are always set to a definite value before -- invoking 'UserHooks'.) -findDistPrefOrDefault :: Setup.Flag FilePath -- ^ override \"dist\" prefix - -> IO FilePath +findDistPrefOrDefault + :: Setup.Flag FilePath + -- ^ override \"dist\" prefix + -> IO FilePath findDistPrefOrDefault = findDistPref defaultDistPref --- |Perform the \"@.\/setup configure@\" action. --- Returns the @.setup-config@ file. -configure :: (GenericPackageDescription, HookedBuildInfo) - -> ConfigFlags -> IO LocalBuildInfo +-- | Perform the \"@.\/setup configure@\" action. +-- Returns the @.setup-config@ file. +configure + :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags + -> IO LocalBuildInfo configure (pkg_descr0, pbi) cfg = do - -- Determine the component we are configuring, if a user specified - -- one on the command line. We use a fake, flattened version of - -- the package since at this point, we're not really sure what - -- components we *can* configure. @Nothing@ means that we should - -- configure everything (the old behavior). - (mb_cname :: Maybe ComponentName) <- do - let flat_pkg_descr = flattenPackageDescription pkg_descr0 - targets <- readBuildTargets verbosity flat_pkg_descr (configArgs cfg) - -- TODO: bleat if you use the module/file syntax - let targets' = [ cname | BuildTargetComponent cname <- targets ] - case targets' of - _ | null (configArgs cfg) -> return Nothing - [cname] -> return (Just cname) - [] -> die' verbosity "No valid component targets found" - _ -> die' verbosity - "Can only configure either single component or all of them" - - let use_external_internal_deps = isJust mb_cname - case mb_cname of - Nothing -> setupMessage verbosity "Configuring" (packageId pkg_descr0) - Just cname -> setupMessage' verbosity "Configuring" (packageId pkg_descr0) - cname (Just (configInstantiateWith cfg)) - - -- configCID is only valid for per-component configure - when (isJust (flagToMaybe (configCID cfg)) && isNothing mb_cname) $ - die' verbosity "--cid is only supported for per-component configure" - - checkDeprecatedFlags verbosity cfg - checkExactConfiguration verbosity pkg_descr0 cfg - - -- Where to build the package - let buildDir :: FilePath -- e.g. dist/build - -- fromFlag OK due to Distribution.Simple calling - -- findDistPrefOrDefault to fill it in - buildDir = fromFlag (configDistPref cfg) "build" - createDirectoryIfMissingVerbose (lessVerbose verbosity) True buildDir - - -- What package database(s) to use - let packageDbs :: PackageDBStack - packageDbs - = interpretPackageDbFlags - (fromFlag (configUserInstall cfg)) - (configPackageDBs cfg) - - -- comp: the compiler we're building with - -- compPlatform: the platform we're building for - -- programDb: location and args of all programs we're - -- building with - (comp :: Compiler, - compPlatform :: Platform, - programDb :: ProgramDb) - <- configCompilerEx - (flagToMaybe (configHcFlavor cfg)) - (flagToMaybe (configHcPath cfg)) - (flagToMaybe (configHcPkg cfg)) - (mkProgramDb cfg (configPrograms cfg)) - (lessVerbose verbosity) - - -- The InstalledPackageIndex of all installed packages - installedPackageSet :: InstalledPackageIndex - <- getInstalledPackages (lessVerbose verbosity) comp - packageDbs programDb - - -- The set of package names which are "shadowed" by internal - -- packages, and which component they map to - let internalPackageSet :: Set LibraryName - internalPackageSet = getInternalLibraries pkg_descr0 - - -- Make a data structure describing what components are enabled. - let enabled :: ComponentRequestedSpec - enabled = case mb_cname of - Just cname -> OneComponentRequestedSpec cname - Nothing -> ComponentRequestedSpec - -- The flag name (@--enable-tests@) is a - -- little bit of a misnomer, because - -- just passing this flag won't - -- "enable", in our internal - -- nomenclature; it's just a request; a - -- @buildable: False@ might make it - -- not possible to enable. - { testsRequested = fromFlag (configTests cfg) - , benchmarksRequested = - fromFlag (configBenchmarks cfg) } - -- Some sanity checks related to enabling components. - when (isJust mb_cname - && (fromFlag (configTests cfg) || fromFlag (configBenchmarks cfg))) $ - die' verbosity $ - "--enable-tests/--enable-benchmarks are incompatible with" ++ - " explicitly specifying a component to configure." - - -- Some sanity checks related to dynamic/static linking. - when (fromFlag (configDynExe cfg) && fromFlag (configFullyStaticExe cfg)) $ - die' verbosity $ - "--enable-executable-dynamic and --enable-executable-static" ++ - " are incompatible with each other." - - -- allConstraints: The set of all 'Dependency's we have. Used ONLY - -- to 'configureFinalizedPackage'. - -- requiredDepsMap: A map from 'PackageName' to the specifically - -- required 'InstalledPackageInfo', due to --dependency - -- - -- NB: These constraints are to be applied to ALL components of - -- a package. Thus, it's not an error if allConstraints contains - -- more constraints than is necessary for a component (another - -- component might need it.) - -- - -- NB: The fact that we bundle all the constraints together means - -- that is not possible to configure a test-suite to use one - -- version of a dependency, and the executable to use another. - (allConstraints :: [PackageVersionConstraint], - requiredDepsMap :: Map (PackageName, ComponentName) InstalledPackageInfo) - <- either (die' verbosity) return $ - combinedConstraints (configConstraints cfg) - (configDependencies cfg) - installedPackageSet - - -- pkg_descr: The resolved package description, that does not contain any - -- conditionals, because we have an assignment for - -- every flag, either picking them ourselves using a - -- simple naive algorithm, or having them be passed to - -- us by 'configConfigurationsFlags') - -- flags: The 'FlagAssignment' that the conditionals were - -- resolved with. - -- - -- NB: Why doesn't finalizing a package also tell us what the - -- dependencies are (e.g. when we run the naive algorithm, - -- we are checking if dependencies are satisfiable)? The - -- primary reason is that we may NOT have done any solving: - -- if the flags are all chosen for us, this step is a simple - -- matter of flattening according to that assignment. It's - -- cleaner to then configure the dependencies afterwards. - (pkg_descr :: PackageDescription, - flags :: FlagAssignment) - <- configureFinalizedPackage verbosity cfg enabled - allConstraints - (dependencySatisfiable - use_external_internal_deps - (fromFlagOrDefault False (configExactConfiguration cfg)) - (fromFlagOrDefault False (configAllowDependingOnPrivateLibs cfg)) - (packageName pkg_descr0) - installedPackageSet - internalPackageSet - requiredDepsMap) - comp - compPlatform - pkg_descr0 - - debug verbosity $ "Finalized package description:\n" - ++ showPackageDescription pkg_descr - - let cabalFileDir = maybe "." takeDirectory $ + -- Determine the component we are configuring, if a user specified + -- one on the command line. We use a fake, flattened version of + -- the package since at this point, we're not really sure what + -- components we *can* configure. @Nothing@ means that we should + -- configure everything (the old behavior). + (mb_cname :: Maybe ComponentName) <- do + let flat_pkg_descr = flattenPackageDescription pkg_descr0 + targets <- readBuildTargets verbosity flat_pkg_descr (configArgs cfg) + -- TODO: bleat if you use the module/file syntax + let targets' = [cname | BuildTargetComponent cname <- targets] + case targets' of + _ | null (configArgs cfg) -> return Nothing + [cname] -> return (Just cname) + [] -> die' verbosity "No valid component targets found" + _ -> + die' + verbosity + "Can only configure either single component or all of them" + + let use_external_internal_deps = isJust mb_cname + case mb_cname of + Nothing -> setupMessage verbosity "Configuring" (packageId pkg_descr0) + Just cname -> + setupMessage' + verbosity + "Configuring" + (packageId pkg_descr0) + cname + (Just (configInstantiateWith cfg)) + + -- configCID is only valid for per-component configure + when (isJust (flagToMaybe (configCID cfg)) && isNothing mb_cname) $ + die' verbosity "--cid is only supported for per-component configure" + + checkDeprecatedFlags verbosity cfg + checkExactConfiguration verbosity pkg_descr0 cfg + + -- Where to build the package + let buildDir :: FilePath -- e.g. dist/build + -- fromFlag OK due to Distribution.Simple calling + -- findDistPrefOrDefault to fill it in + buildDir = fromFlag (configDistPref cfg) "build" + createDirectoryIfMissingVerbose (lessVerbose verbosity) True buildDir + + -- What package database(s) to use + let packageDbs :: PackageDBStack + packageDbs = + interpretPackageDbFlags + (fromFlag (configUserInstall cfg)) + (configPackageDBs cfg) + + -- comp: the compiler we're building with + -- compPlatform: the platform we're building for + -- programDb: location and args of all programs we're + -- building with + ( comp :: Compiler + , compPlatform :: Platform + , programDb :: ProgramDb + ) <- + configCompilerEx + (flagToMaybe (configHcFlavor cfg)) + (flagToMaybe (configHcPath cfg)) + (flagToMaybe (configHcPkg cfg)) + (mkProgramDb cfg (configPrograms cfg)) + (lessVerbose verbosity) + + -- The InstalledPackageIndex of all installed packages + installedPackageSet :: InstalledPackageIndex <- + getInstalledPackages + (lessVerbose verbosity) + comp + packageDbs + programDb + + -- The set of package names which are "shadowed" by internal + -- packages, and which component they map to + let internalPackageSet :: Set LibraryName + internalPackageSet = getInternalLibraries pkg_descr0 + + -- Make a data structure describing what components are enabled. + let enabled :: ComponentRequestedSpec + enabled = case mb_cname of + Just cname -> OneComponentRequestedSpec cname + Nothing -> + ComponentRequestedSpec + { -- The flag name (@--enable-tests@) is a + -- little bit of a misnomer, because + -- just passing this flag won't + -- "enable", in our internal + -- nomenclature; it's just a request; a + -- @buildable: False@ might make it + -- not possible to enable. + testsRequested = fromFlag (configTests cfg) + , benchmarksRequested = + fromFlag (configBenchmarks cfg) + } + -- Some sanity checks related to enabling components. + when + ( isJust mb_cname + && (fromFlag (configTests cfg) || fromFlag (configBenchmarks cfg)) + ) + $ die' verbosity + $ "--enable-tests/--enable-benchmarks are incompatible with" + ++ " explicitly specifying a component to configure." + + -- Some sanity checks related to dynamic/static linking. + when (fromFlag (configDynExe cfg) && fromFlag (configFullyStaticExe cfg)) $ + die' verbosity $ + "--enable-executable-dynamic and --enable-executable-static" + ++ " are incompatible with each other." + + -- allConstraints: The set of all 'Dependency's we have. Used ONLY + -- to 'configureFinalizedPackage'. + -- requiredDepsMap: A map from 'PackageName' to the specifically + -- required 'InstalledPackageInfo', due to --dependency + -- + -- NB: These constraints are to be applied to ALL components of + -- a package. Thus, it's not an error if allConstraints contains + -- more constraints than is necessary for a component (another + -- component might need it.) + -- + -- NB: The fact that we bundle all the constraints together means + -- that is not possible to configure a test-suite to use one + -- version of a dependency, and the executable to use another. + ( allConstraints :: [PackageVersionConstraint] + , requiredDepsMap :: Map (PackageName, ComponentName) InstalledPackageInfo + ) <- + either (die' verbosity) return $ + combinedConstraints + (configConstraints cfg) + (configDependencies cfg) + installedPackageSet + + -- pkg_descr: The resolved package description, that does not contain any + -- conditionals, because we have an assignment for + -- every flag, either picking them ourselves using a + -- simple naive algorithm, or having them be passed to + -- us by 'configConfigurationsFlags') + -- flags: The 'FlagAssignment' that the conditionals were + -- resolved with. + -- + -- NB: Why doesn't finalizing a package also tell us what the + -- dependencies are (e.g. when we run the naive algorithm, + -- we are checking if dependencies are satisfiable)? The + -- primary reason is that we may NOT have done any solving: + -- if the flags are all chosen for us, this step is a simple + -- matter of flattening according to that assignment. It's + -- cleaner to then configure the dependencies afterwards. + ( pkg_descr :: PackageDescription + , flags :: FlagAssignment + ) <- + configureFinalizedPackage + verbosity + cfg + enabled + allConstraints + ( dependencySatisfiable + use_external_internal_deps + (fromFlagOrDefault False (configExactConfiguration cfg)) + (fromFlagOrDefault False (configAllowDependingOnPrivateLibs cfg)) + (packageName pkg_descr0) + installedPackageSet + internalPackageSet + requiredDepsMap + ) + comp + compPlatform + pkg_descr0 + + debug verbosity $ + "Finalized package description:\n" + ++ showPackageDescription pkg_descr + + let cabalFileDir = + maybe "." takeDirectory $ flagToMaybe (configCabalFilePath cfg) - checkCompilerProblems verbosity comp pkg_descr enabled - checkPackageProblems verbosity cabalFileDir pkg_descr0 - (updatePackageDescription pbi pkg_descr) - - -- The list of 'InstalledPackageInfo' recording the selected - -- dependencies on external packages. - -- - -- Invariant: For any package name, there is at most one package - -- in externalPackageDeps which has that name. - -- - -- NB: The dependency selection is global over ALL components - -- in the package (similar to how allConstraints and - -- requiredDepsMap are global over all components). In particular, - -- if *any* component (post-flag resolution) has an unsatisfiable - -- dependency, we will fail. This can sometimes be undesirable - -- for users, see #1786 (benchmark conflicts with executable), - -- - -- In the presence of Backpack, these package dependencies are - -- NOT complete: they only ever include the INDEFINITE - -- dependencies. After we apply an instantiation, we'll get - -- definite references which constitute extra dependencies. - -- (Why not have cabal-install pass these in explicitly? - -- For one it's deterministic; for two, we need to associate - -- them with renamings which would require a far more complicated - -- input scheme than what we have today.) - externalPkgDeps :: [PreExistingComponent] - <- configureDependencies - verbosity - use_external_internal_deps - internalPackageSet - installedPackageSet - requiredDepsMap - pkg_descr - enabled - - -- Compute installation directory templates, based on user - -- configuration. - -- - -- TODO: Move this into a helper function. - defaultDirs :: InstallDirTemplates - <- defaultInstallDirs' use_external_internal_deps - (compilerFlavor comp) - (fromFlag (configUserInstall cfg)) - (hasLibs pkg_descr) - let installDirs :: InstallDirTemplates - installDirs = combineInstallDirs fromFlagOrDefault - defaultDirs (configInstallDirs cfg) - - -- Check languages and extensions - -- TODO: Move this into a helper function. - let langlist = nub $ catMaybes $ map defaultLanguage - (enabledBuildInfos pkg_descr enabled) - let langs = unsupportedLanguages comp langlist - when (not (null langs)) $ - die' verbosity $ "The package " ++ prettyShow (packageId pkg_descr0) - ++ " requires the following languages which are not " - ++ "supported by " ++ prettyShow (compilerId comp) ++ ": " - ++ intercalate ", " (map prettyShow langs) - let extlist = nub $ concatMap allExtensions - (enabledBuildInfos pkg_descr enabled) - let exts = unsupportedExtensions comp extlist - when (not (null exts)) $ - die' verbosity $ "The package " ++ prettyShow (packageId pkg_descr0) - ++ " requires the following language extensions which are not " - ++ "supported by " ++ prettyShow (compilerId comp) ++ ": " - ++ intercalate ", " (map prettyShow exts) - - -- Check foreign library build requirements - let flibs = [flib | CFLib flib <- enabledComponents pkg_descr enabled] - let unsupportedFLibs = unsupportedForeignLibs comp compPlatform flibs - when (not (null unsupportedFLibs)) $ - die' verbosity $ "Cannot build some foreign libraries: " - ++ intercalate "," unsupportedFLibs - - -- Configure certain external build tools, see below for which ones. - let requiredBuildTools = do - bi <- enabledBuildInfos pkg_descr enabled - -- First, we collect any tool dep that we know is external. This is, - -- in practice: - -- - -- 1. `build-tools` entries on the whitelist - -- - -- 2. `build-tool-depends` that aren't from the current package. - let externBuildToolDeps = - [ LegacyExeDependency (unUnqualComponentName eName) versionRange - | buildTool@(ExeDependency _ eName versionRange) - <- getAllToolDependencies pkg_descr bi - , not $ isInternal pkg_descr buildTool ] - -- Second, we collect any build-tools entry we don't know how to - -- desugar. We'll never have any idea how to build them, so we just - -- hope they are already on the PATH. - let unknownBuildTools = - [ buildTool - | buildTool <- buildTools bi - , Nothing == desugarBuildTool pkg_descr buildTool ] - externBuildToolDeps ++ unknownBuildTools - - programDb' <- - configureAllKnownPrograms (lessVerbose verbosity) programDb + checkCompilerProblems verbosity comp pkg_descr enabled + checkPackageProblems + verbosity + cabalFileDir + pkg_descr0 + (updatePackageDescription pbi pkg_descr) + + -- The list of 'InstalledPackageInfo' recording the selected + -- dependencies on external packages. + -- + -- Invariant: For any package name, there is at most one package + -- in externalPackageDeps which has that name. + -- + -- NB: The dependency selection is global over ALL components + -- in the package (similar to how allConstraints and + -- requiredDepsMap are global over all components). In particular, + -- if *any* component (post-flag resolution) has an unsatisfiable + -- dependency, we will fail. This can sometimes be undesirable + -- for users, see #1786 (benchmark conflicts with executable), + -- + -- In the presence of Backpack, these package dependencies are + -- NOT complete: they only ever include the INDEFINITE + -- dependencies. After we apply an instantiation, we'll get + -- definite references which constitute extra dependencies. + -- (Why not have cabal-install pass these in explicitly? + -- For one it's deterministic; for two, we need to associate + -- them with renamings which would require a far more complicated + -- input scheme than what we have today.) + externalPkgDeps :: [PreExistingComponent] <- + configureDependencies + verbosity + use_external_internal_deps + internalPackageSet + installedPackageSet + requiredDepsMap + pkg_descr + enabled + + -- Compute installation directory templates, based on user + -- configuration. + -- + -- TODO: Move this into a helper function. + defaultDirs :: InstallDirTemplates <- + defaultInstallDirs' + use_external_internal_deps + (compilerFlavor comp) + (fromFlag (configUserInstall cfg)) + (hasLibs pkg_descr) + let installDirs :: InstallDirTemplates + installDirs = + combineInstallDirs + fromFlagOrDefault + defaultDirs + (configInstallDirs cfg) + + -- Check languages and extensions + -- TODO: Move this into a helper function. + let langlist = + nub $ + catMaybes $ + map + defaultLanguage + (enabledBuildInfos pkg_descr enabled) + let langs = unsupportedLanguages comp langlist + when (not (null langs)) $ + die' verbosity $ + "The package " + ++ prettyShow (packageId pkg_descr0) + ++ " requires the following languages which are not " + ++ "supported by " + ++ prettyShow (compilerId comp) + ++ ": " + ++ intercalate ", " (map prettyShow langs) + let extlist = + nub $ + concatMap + allExtensions + (enabledBuildInfos pkg_descr enabled) + let exts = unsupportedExtensions comp extlist + when (not (null exts)) $ + die' verbosity $ + "The package " + ++ prettyShow (packageId pkg_descr0) + ++ " requires the following language extensions which are not " + ++ "supported by " + ++ prettyShow (compilerId comp) + ++ ": " + ++ intercalate ", " (map prettyShow exts) + + -- Check foreign library build requirements + let flibs = [flib | CFLib flib <- enabledComponents pkg_descr enabled] + let unsupportedFLibs = unsupportedForeignLibs comp compPlatform flibs + when (not (null unsupportedFLibs)) $ + die' verbosity $ + "Cannot build some foreign libraries: " + ++ intercalate "," unsupportedFLibs + + -- Configure certain external build tools, see below for which ones. + let requiredBuildTools = do + bi <- enabledBuildInfos pkg_descr enabled + -- First, we collect any tool dep that we know is external. This is, + -- in practice: + -- + -- 1. `build-tools` entries on the whitelist + -- + -- 2. `build-tool-depends` that aren't from the current package. + let externBuildToolDeps = + [ LegacyExeDependency (unUnqualComponentName eName) versionRange + | buildTool@(ExeDependency _ eName versionRange) <- + getAllToolDependencies pkg_descr bi + , not $ isInternal pkg_descr buildTool + ] + -- Second, we collect any build-tools entry we don't know how to + -- desugar. We'll never have any idea how to build them, so we just + -- hope they are already on the PATH. + let unknownBuildTools = + [ buildTool + | buildTool <- buildTools bi + , Nothing == desugarBuildTool pkg_descr buildTool + ] + externBuildToolDeps ++ unknownBuildTools + + programDb' <- + configureAllKnownPrograms (lessVerbose verbosity) programDb >>= configureRequiredPrograms verbosity requiredBuildTools - (pkg_descr', programDb'') <- - configurePkgconfigPackages verbosity pkg_descr programDb' enabled + (pkg_descr', programDb'') <- + configurePkgconfigPackages verbosity pkg_descr programDb' enabled - -- Compute internal component graph - -- - -- The general idea is that we take a look at all the source level - -- components (which may build-depends on each other) and form a graph. - -- From there, we build a ComponentLocalBuildInfo for each of the - -- components, which lets us actually build each component. - -- internalPackageSet - -- use_external_internal_deps - (buildComponents :: [ComponentLocalBuildInfo], - packageDependsIndex :: InstalledPackageIndex) <- - runLogProgress verbosity $ configureComponentLocalBuildInfos + -- Compute internal component graph + -- + -- The general idea is that we take a look at all the source level + -- components (which may build-depends on each other) and form a graph. + -- From there, we build a ComponentLocalBuildInfo for each of the + -- components, which lets us actually build each component. + -- internalPackageSet + -- use_external_internal_deps + ( buildComponents :: [ComponentLocalBuildInfo] + , packageDependsIndex :: InstalledPackageIndex + ) <- + runLogProgress verbosity $ + configureComponentLocalBuildInfos + verbosity + use_external_internal_deps + enabled + (fromFlagOrDefault False (configDeterministic cfg)) + (configIPID cfg) + (configCID cfg) + pkg_descr + externalPkgDeps + (configConfigurationsFlags cfg) + (configInstantiateWith cfg) + installedPackageSet + comp + + -- Decide if we're going to compile with split sections. + split_sections :: Bool <- + if not (fromFlag $ configSplitSections cfg) + then return False + else case compilerFlavor comp of + GHC + | compilerVersion comp >= mkVersion [8, 0] -> + return True + GHCJS -> + return True + _ -> do + warn verbosity - use_external_internal_deps - enabled - (fromFlagOrDefault False (configDeterministic cfg)) - (configIPID cfg) - (configCID cfg) - pkg_descr - externalPkgDeps - (configConfigurationsFlags cfg) - (configInstantiateWith cfg) - installedPackageSet - comp - - -- Decide if we're going to compile with split sections. - split_sections :: Bool <- - if not (fromFlag $ configSplitSections cfg) - then return False - else case compilerFlavor comp of - GHC | compilerVersion comp >= mkVersion [8,0] - -> return True - GHCJS - -> return True - _ -> do warn verbosity - ("this compiler does not support " ++ - "--enable-split-sections; ignoring") - return False - - -- Decide if we're going to compile with split objects. - split_objs :: Bool <- - if not (fromFlag $ configSplitObjs cfg) - then return False - else case compilerFlavor comp of - _ | split_sections - -> do warn verbosity - ("--enable-split-sections and " ++ - "--enable-split-objs are mutually " ++ - "exclusive; ignoring the latter") - return False - GHC - -> return True - GHCJS - -> return True - _ -> do warn verbosity - ("this compiler does not support " ++ - "--enable-split-objs; ignoring") - return False - - let compilerSupportsGhciLibs :: Bool - compilerSupportsGhciLibs = - case compilerId comp of - CompilerId GHC version - | version > mkVersion [9,3] && windows -> - False - CompilerId GHC _ -> - True - CompilerId GHCJS _ -> - True - _ -> False - where - windows = case compPlatform of - Platform _ Windows -> True - Platform _ _ -> False - - let ghciLibByDefault = - case compilerId comp of - CompilerId GHC _ -> - -- If ghc is non-dynamic, then ghci needs object files, - -- so we build one by default. - -- - -- Technically, archive files should be sufficient for ghci, - -- but because of GHC bug #8942, it has never been safe to - -- rely on them. By the time that bug was fixed, ghci had - -- been changed to read shared libraries instead of archive - -- files (see next code block). - not (GHC.isDynamic comp) - CompilerId GHCJS _ -> - not (GHCJS.isDynamic comp) - _ -> False + ( "this compiler does not support " + ++ "--enable-split-sections; ignoring" + ) + return False - withGHCiLib_ <- - case fromFlagOrDefault ghciLibByDefault (configGHCiLib cfg) of - True | not compilerSupportsGhciLibs -> do - warn verbosity $ - "--enable-library-for-ghci is no longer supported on Windows with" - ++ " GHC 9.4 and later; ignoring..." + -- Decide if we're going to compile with split objects. + split_objs :: Bool <- + if not (fromFlag $ configSplitObjs cfg) + then return False + else case compilerFlavor comp of + _ | split_sections -> + do + warn + verbosity + ( "--enable-split-sections and " + ++ "--enable-split-objs are mutually " + ++ "exclusive; ignoring the latter" + ) + return False + GHC -> + return True + GHCJS -> + return True + _ -> do + warn + verbosity + ( "this compiler does not support " + ++ "--enable-split-objs; ignoring" + ) return False - v -> return v - - let sharedLibsByDefault - | fromFlag (configDynExe cfg) = - -- build a shared library if dynamically-linked - -- executables are requested - True - | otherwise = case compilerId comp of + + let compilerSupportsGhciLibs :: Bool + compilerSupportsGhciLibs = + case compilerId comp of + CompilerId GHC version + | version > mkVersion [9, 3] && windows -> + False + CompilerId GHC _ -> + True + CompilerId GHCJS _ -> + True + _ -> False + where + windows = case compPlatform of + Platform _ Windows -> True + Platform _ _ -> False + + let ghciLibByDefault = + case compilerId comp of + CompilerId GHC _ -> + -- If ghc is non-dynamic, then ghci needs object files, + -- so we build one by default. + -- + -- Technically, archive files should be sufficient for ghci, + -- but because of GHC bug #8942, it has never been safe to + -- rely on them. By the time that bug was fixed, ghci had + -- been changed to read shared libraries instead of archive + -- files (see next code block). + not (GHC.isDynamic comp) + CompilerId GHCJS _ -> + not (GHCJS.isDynamic comp) + _ -> False + + withGHCiLib_ <- + case fromFlagOrDefault ghciLibByDefault (configGHCiLib cfg) of + True | not compilerSupportsGhciLibs -> do + warn verbosity $ + "--enable-library-for-ghci is no longer supported on Windows with" + ++ " GHC 9.4 and later; ignoring..." + return False + v -> return v + + let sharedLibsByDefault + | fromFlag (configDynExe cfg) = + -- build a shared library if dynamically-linked + -- executables are requested + True + | otherwise = case compilerId comp of CompilerId GHC _ -> -- if ghc is dynamic, then ghci needs a shared -- library, so we build one by default. @@ -692,168 +840,189 @@ configure (pkg_descr0, pbi) cfg = do CompilerId GHCJS _ -> GHCJS.isDynamic comp _ -> False - withSharedLib_ = - -- build shared libraries if required by GHC or by the - -- executable linking mode, but allow the user to force - -- building only static library archives with - -- --disable-shared. - fromFlagOrDefault sharedLibsByDefault $ configSharedLib cfg + withSharedLib_ = + -- build shared libraries if required by GHC or by the + -- executable linking mode, but allow the user to force + -- building only static library archives with + -- --disable-shared. + fromFlagOrDefault sharedLibsByDefault $ configSharedLib cfg - withStaticLib_ = - -- build a static library (all dependent libraries rolled - -- into a huge .a archive) via GHCs -staticlib flag. - fromFlagOrDefault False $ configStaticLib cfg + withStaticLib_ = + -- build a static library (all dependent libraries rolled + -- into a huge .a archive) via GHCs -staticlib flag. + fromFlagOrDefault False $ configStaticLib cfg - withDynExe_ = fromFlag $ configDynExe cfg + withDynExe_ = fromFlag $ configDynExe cfg - withFullyStaticExe_ = fromFlag $ configFullyStaticExe cfg + withFullyStaticExe_ = fromFlag $ configFullyStaticExe cfg - when (withDynExe_ && not withSharedLib_) $ warn verbosity $ - "Executables will use dynamic linking, but a shared library " + when (withDynExe_ && not withSharedLib_) $ + warn verbosity $ + "Executables will use dynamic linking, but a shared library " ++ "is not being built. Linking will fail if any executables " ++ "depend on the library." - setProfLBI <- configureProfiling verbosity cfg comp - - setCoverageLBI <- configureCoverage verbosity cfg comp - - - - -- Turn off library and executable stripping when `debug-info` is set - -- to anything other than zero. - let - strip_libexe s f = - let defaultStrip = fromFlagOrDefault True (f cfg) - in case fromFlag (configDebugInfo cfg) of - NoDebugInfo -> return defaultStrip - _ -> case f cfg of - Flag True -> do - warn verbosity $ "Setting debug-info implies " - ++ s ++ "-stripping: False" - return False - - _ -> return False - - strip_lib <- strip_libexe "library" configStripLibs - strip_exe <- strip_libexe "executable" configStripExes - - - let reloc = fromFlagOrDefault False $ configRelocatable cfg - - let buildComponentsMap = - foldl' (\m clbi -> Map.insertWith (++) - (componentLocalName clbi) [clbi] m) - Map.empty buildComponents - - let lbi = (setCoverageLBI . setProfLBI) - LocalBuildInfo { - configFlags = cfg, - flagAssignment = flags, - componentEnabledSpec = enabled, - extraConfigArgs = [], -- Currently configure does not - -- take extra args, but if it - -- did they would go here. - installDirTemplates = installDirs, - compiler = comp, - hostPlatform = compPlatform, - buildDir = buildDir, - cabalFilePath = flagToMaybe (configCabalFilePath cfg), - componentGraph = Graph.fromDistinctList buildComponents, - componentNameMap = buildComponentsMap, - installedPkgs = packageDependsIndex, - pkgDescrFile = Nothing, - localPkgDescr = pkg_descr', - withPrograms = programDb'', - withVanillaLib = fromFlag $ configVanillaLib cfg, - withSharedLib = withSharedLib_, - withStaticLib = withStaticLib_, - withDynExe = withDynExe_, - withFullyStaticExe = withFullyStaticExe_, - withProfLib = False, - withProfLibDetail = ProfDetailNone, - withProfExe = False, - withProfExeDetail = ProfDetailNone, - withOptimization = fromFlag $ configOptimization cfg, - withDebugInfo = fromFlag $ configDebugInfo cfg, - withGHCiLib = withGHCiLib_, - splitSections = split_sections, - splitObjs = split_objs, - stripExes = strip_exe, - stripLibs = strip_lib, - exeCoverage = False, - libCoverage = False, - withPackageDB = packageDbs, - progPrefix = fromFlag $ configProgPrefix cfg, - progSuffix = fromFlag $ configProgSuffix cfg, - relocatable = reloc - } - - when reloc (checkRelocatable verbosity pkg_descr lbi) - - -- TODO: This is not entirely correct, because the dirs may vary - -- across libraries/executables - let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest - relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi - - -- PKGROOT: allowing ${pkgroot} to be passed as --prefix to - -- cabal configure, is only a hidden option. It allows packages - -- to be relocatable with their package database. This however - -- breaks when the Paths_* or other includes are used that - -- contain hard coded paths. This is still an open TODO. - -- - -- Allowing ${pkgroot} here, however requires less custom hooks - -- in scripts that *really* want ${pkgroot}. See haskell/cabal/#4872 - unless (isAbsolute (prefix dirs) - || "${pkgroot}" `isPrefixOf` prefix dirs) $ die' verbosity $ - "expected an absolute directory name for --prefix: " ++ prefix dirs - - when ("${pkgroot}" `isPrefixOf` prefix dirs) $ - warn verbosity $ "Using ${pkgroot} in prefix " ++ prefix dirs - ++ " will not work if you rely on the Path_* module " - ++ " or other hard coded paths. Cabal does not yet " - ++ " support fully relocatable builds! " - ++ " See #462 #2302 #2994 #3305 #3473 #3586 #3909" - ++ " #4097 #4291 #4872" - - info verbosity $ "Using " ++ prettyShow currentCabalId - ++ " compiled by " ++ prettyShow currentCompilerId - info verbosity $ "Using compiler: " ++ showCompilerId comp - info verbosity $ "Using install prefix: " ++ prefix dirs - - let dirinfo name dir isPrefixRelative = - info verbosity $ name ++ " installed in: " ++ dir ++ relNote - where relNote = case buildOS of - Windows | not (hasLibs pkg_descr) - && isNothing isPrefixRelative - -> " (fixed location)" - _ -> "" - - dirinfo "Executables" (bindir dirs) (bindir relative) - dirinfo "Libraries" (libdir dirs) (libdir relative) - dirinfo "Dynamic Libraries" (dynlibdir dirs) (dynlibdir relative) - dirinfo "Private executables" (libexecdir dirs) (libexecdir relative) - dirinfo "Data files" (datadir dirs) (datadir relative) - dirinfo "Documentation" (docdir dirs) (docdir relative) - dirinfo "Configuration files" (sysconfdir dirs) (sysconfdir relative) - - sequence_ [ reportProgram verbosity prog configuredProg - | (prog, configuredProg) <- knownPrograms programDb'' ] - - return lbi + setProfLBI <- configureProfiling verbosity cfg comp + + setCoverageLBI <- configureCoverage verbosity cfg comp + + -- Turn off library and executable stripping when `debug-info` is set + -- to anything other than zero. + let + strip_libexe s f = + let defaultStrip = fromFlagOrDefault True (f cfg) + in case fromFlag (configDebugInfo cfg) of + NoDebugInfo -> return defaultStrip + _ -> case f cfg of + Flag True -> do + warn verbosity $ + "Setting debug-info implies " + ++ s + ++ "-stripping: False" + return False + _ -> return False + + strip_lib <- strip_libexe "library" configStripLibs + strip_exe <- strip_libexe "executable" configStripExes + + let reloc = fromFlagOrDefault False $ configRelocatable cfg + + let buildComponentsMap = + foldl' + ( \m clbi -> + Map.insertWith + (++) + (componentLocalName clbi) + [clbi] + m + ) + Map.empty + buildComponents + + let lbi = + (setCoverageLBI . setProfLBI) + LocalBuildInfo + { configFlags = cfg + , flagAssignment = flags + , componentEnabledSpec = enabled + , extraConfigArgs = [] -- Currently configure does not + -- take extra args, but if it + -- did they would go here. + , installDirTemplates = installDirs + , compiler = comp + , hostPlatform = compPlatform + , buildDir = buildDir + , cabalFilePath = flagToMaybe (configCabalFilePath cfg) + , componentGraph = Graph.fromDistinctList buildComponents + , componentNameMap = buildComponentsMap + , installedPkgs = packageDependsIndex + , pkgDescrFile = Nothing + , localPkgDescr = pkg_descr' + , withPrograms = programDb'' + , withVanillaLib = fromFlag $ configVanillaLib cfg + , withSharedLib = withSharedLib_ + , withStaticLib = withStaticLib_ + , withDynExe = withDynExe_ + , withFullyStaticExe = withFullyStaticExe_ + , withProfLib = False + , withProfLibDetail = ProfDetailNone + , withProfExe = False + , withProfExeDetail = ProfDetailNone + , withOptimization = fromFlag $ configOptimization cfg + , withDebugInfo = fromFlag $ configDebugInfo cfg + , withGHCiLib = withGHCiLib_ + , splitSections = split_sections + , splitObjs = split_objs + , stripExes = strip_exe + , stripLibs = strip_lib + , exeCoverage = False + , libCoverage = False + , withPackageDB = packageDbs + , progPrefix = fromFlag $ configProgPrefix cfg + , progSuffix = fromFlag $ configProgSuffix cfg + , relocatable = reloc + } + + when reloc (checkRelocatable verbosity pkg_descr lbi) + + -- TODO: This is not entirely correct, because the dirs may vary + -- across libraries/executables + let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest + relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi + + -- PKGROOT: allowing ${pkgroot} to be passed as --prefix to + -- cabal configure, is only a hidden option. It allows packages + -- to be relocatable with their package database. This however + -- breaks when the Paths_* or other includes are used that + -- contain hard coded paths. This is still an open TODO. + -- + -- Allowing ${pkgroot} here, however requires less custom hooks + -- in scripts that *really* want ${pkgroot}. See haskell/cabal/#4872 + unless + ( isAbsolute (prefix dirs) + || "${pkgroot}" `isPrefixOf` prefix dirs + ) + $ die' verbosity + $ "expected an absolute directory name for --prefix: " ++ prefix dirs + + when ("${pkgroot}" `isPrefixOf` prefix dirs) $ + warn verbosity $ + "Using ${pkgroot} in prefix " + ++ prefix dirs + ++ " will not work if you rely on the Path_* module " + ++ " or other hard coded paths. Cabal does not yet " + ++ " support fully relocatable builds! " + ++ " See #462 #2302 #2994 #3305 #3473 #3586 #3909" + ++ " #4097 #4291 #4872" + + info verbosity $ + "Using " + ++ prettyShow currentCabalId + ++ " compiled by " + ++ prettyShow currentCompilerId + info verbosity $ "Using compiler: " ++ showCompilerId comp + info verbosity $ "Using install prefix: " ++ prefix dirs + + let dirinfo name dir isPrefixRelative = + info verbosity $ name ++ " installed in: " ++ dir ++ relNote + where + relNote = case buildOS of + Windows + | not (hasLibs pkg_descr) + && isNothing isPrefixRelative -> + " (fixed location)" + _ -> "" + + dirinfo "Executables" (bindir dirs) (bindir relative) + dirinfo "Libraries" (libdir dirs) (libdir relative) + dirinfo "Dynamic Libraries" (dynlibdir dirs) (dynlibdir relative) + dirinfo "Private executables" (libexecdir dirs) (libexecdir relative) + dirinfo "Data files" (datadir dirs) (datadir relative) + dirinfo "Documentation" (docdir dirs) (docdir relative) + dirinfo "Configuration files" (sysconfdir dirs) (sysconfdir relative) + + sequence_ + [ reportProgram verbosity prog configuredProg + | (prog, configuredProg) <- knownPrograms programDb'' + ] - where - verbosity = fromFlag (configVerbosity cfg) + return lbi + where + verbosity = fromFlag (configVerbosity cfg) mkProgramDb :: ConfigFlags -> ProgramDb -> ProgramDb mkProgramDb cfg initialProgramDb = programDb where - programDb = userSpecifyArgss (configProgramArgs cfg) - . userSpecifyPaths (configProgramPaths cfg) - . setProgramSearchPath searchpath - $ initialProgramDb - searchpath = map ProgramSearchPathDir - (fromNubList $ configProgramPathExtra cfg) - ++ getProgramSearchPath initialProgramDb + programDb = + userSpecifyArgss (configProgramArgs cfg) + . userSpecifyPaths (configProgramPaths cfg) + . setProgramSearchPath searchpath + $ initialProgramDb + searchpath = + map + ProgramSearchPathDir + (fromNubList $ configProgramPathExtra cfg) + ++ getProgramSearchPath initialProgramDb -- ----------------------------------------------------------------------------- -- Helper functions for configure @@ -861,33 +1030,48 @@ mkProgramDb cfg initialProgramDb = programDb -- | Check if the user used any deprecated flags. checkDeprecatedFlags :: Verbosity -> ConfigFlags -> IO () checkDeprecatedFlags verbosity cfg = do - unless (configProfExe cfg == NoFlag) $ do - let enable | fromFlag (configProfExe cfg) = "enable" - | otherwise = "disable" - warn verbosity - ("The flag --" ++ enable ++ "-executable-profiling is deprecated. " - ++ "Please use --" ++ enable ++ "-profiling instead.") - - unless (configLibCoverage cfg == NoFlag) $ do - let enable | fromFlag (configLibCoverage cfg) = "enable" - | otherwise = "disable" - warn verbosity - ("The flag --" ++ enable ++ "-library-coverage is deprecated. " - ++ "Please use --" ++ enable ++ "-coverage instead.") + unless (configProfExe cfg == NoFlag) $ do + let enable + | fromFlag (configProfExe cfg) = "enable" + | otherwise = "disable" + warn + verbosity + ( "The flag --" + ++ enable + ++ "-executable-profiling is deprecated. " + ++ "Please use --" + ++ enable + ++ "-profiling instead." + ) + + unless (configLibCoverage cfg == NoFlag) $ do + let enable + | fromFlag (configLibCoverage cfg) = "enable" + | otherwise = "disable" + warn + verbosity + ( "The flag --" + ++ enable + ++ "-library-coverage is deprecated. " + ++ "Please use --" + ++ enable + ++ "-coverage instead." + ) -- | Sanity check: if '--exact-configuration' was given, ensure that the -- complete flag assignment was specified on the command line. checkExactConfiguration :: Verbosity -> GenericPackageDescription -> ConfigFlags -> IO () checkExactConfiguration verbosity pkg_descr0 cfg = - when (fromFlagOrDefault False (configExactConfiguration cfg)) $ do - let cmdlineFlags = map fst (unFlagAssignment (configConfigurationsFlags cfg)) - allFlags = map flagName . genPackageFlags $ pkg_descr0 - diffFlags = allFlags \\ cmdlineFlags - when (not . null $ diffFlags) $ - die' verbosity $ "'--exact-configuration' was given, " - ++ "but the following flags were not specified: " - ++ intercalate ", " (map show diffFlags) + when (fromFlagOrDefault False (configExactConfiguration cfg)) $ do + let cmdlineFlags = map fst (unFlagAssignment (configConfigurationsFlags cfg)) + allFlags = map flagName . genPackageFlags $ pkg_descr0 + diffFlags = allFlags \\ cmdlineFlags + when (not . null $ diffFlags) $ + die' verbosity $ + "'--exact-configuration' was given, " + ++ "but the following flags were not specified: " + ++ intercalate ", " (map show diffFlags) -- | Create a PackageIndex that makes *any libraries that might be* -- defined internally to this package look like installed packages, in @@ -898,97 +1082,110 @@ checkExactConfiguration verbosity pkg_descr0 cfg = -- file, and we haven't resolved them yet. finalizePD -- does the resolution of conditionals, and it takes internalPackageSet -- as part of its input. -getInternalLibraries :: GenericPackageDescription - -> Set LibraryName +getInternalLibraries + :: GenericPackageDescription + -> Set LibraryName getInternalLibraries pkg_descr0 = - -- TODO: some day, executables will be fair game here too! - let pkg_descr = flattenPackageDescription pkg_descr0 - in Set.fromList (map libName (allLibraries pkg_descr)) + -- TODO: some day, executables will be fair game here too! + let pkg_descr = flattenPackageDescription pkg_descr0 + in Set.fromList (map libName (allLibraries pkg_descr)) -- | Returns true if a dependency is satisfiable. This function may -- report a dependency satisfiable even when it is not, but not vice -- versa. This is to be passed to finalize dependencySatisfiable - :: Bool -- ^ use external internal deps? - -> Bool -- ^ exact configuration? - -> Bool -- ^ allow depending on private libs? - -> PackageName - -> InstalledPackageIndex -- ^ installed set - -> Set LibraryName -- ^ library components - -> Map (PackageName, ComponentName) InstalledPackageInfo - -- ^ required dependencies - -> (Dependency -> Bool) + :: Bool + -- ^ use external internal deps? + -> Bool + -- ^ exact configuration? + -> Bool + -- ^ allow depending on private libs? + -> PackageName + -> InstalledPackageIndex + -- ^ installed set + -> Set LibraryName + -- ^ library components + -> Map (PackageName, ComponentName) InstalledPackageInfo + -- ^ required dependencies + -> (Dependency -> Bool) dependencySatisfiable use_external_internal_deps exact_config allow_private_deps - pn installedPackageSet packageLibraries requiredDepsMap + pn + installedPackageSet + packageLibraries + requiredDepsMap (Dependency depName vr sublibs) - | exact_config - -- When we're given '--exact-configuration', we assume that all - -- dependencies and flags are exactly specified on the command - -- line. Thus we only consult the 'requiredDepsMap'. Note that - -- we're not doing the version range check, so if there's some - -- dependency that wasn't specified on the command line, - -- 'finalizePD' will fail. - -- TODO: mention '--exact-configuration' in the error message - -- when this fails? - = if isInternalDep && not use_external_internal_deps - -- Except for internal deps, when we're NOT per-component mode; - -- those are just True. - then internalDepSatisfiable - else - -- Backward compatibility for the old sublibrary syntax - (sublibs == mainLibSet - && Map.member - (pn, CLibName $ LSubLibName $ - packageNameToUnqualComponentName depName) - requiredDepsMap) - - || all visible sublibs - - | isInternalDep - = if use_external_internal_deps - -- When we are doing per-component configure, we now need to - -- test if the internal dependency is in the index. This has - -- DIFFERENT semantics from normal dependency satisfiability. - then internalDepSatisfiableExternally - -- If a 'PackageName' is defined by an internal component, the dep is - -- satisfiable (we're going to build it ourselves) - else internalDepSatisfiable - - | otherwise - = depSatisfiable - - where - -- Internal dependency is when dependency is the same as package. - isInternalDep = pn == depName + | exact_config = + -- When we're given '--exact-configuration', we assume that all + -- dependencies and flags are exactly specified on the command + -- line. Thus we only consult the 'requiredDepsMap'. Note that + -- we're not doing the version range check, so if there's some + -- dependency that wasn't specified on the command line, + -- 'finalizePD' will fail. + -- TODO: mention '--exact-configuration' in the error message + -- when this fails? + if isInternalDep && not use_external_internal_deps + then -- Except for internal deps, when we're NOT per-component mode; + -- those are just True. + internalDepSatisfiable + else -- Backward compatibility for the old sublibrary syntax + + ( sublibs == mainLibSet + && Map.member + ( pn + , CLibName $ + LSubLibName $ + packageNameToUnqualComponentName depName + ) + requiredDepsMap + ) + || all visible sublibs + | isInternalDep = + if use_external_internal_deps + then -- When we are doing per-component configure, we now need to + -- test if the internal dependency is in the index. This has + -- DIFFERENT semantics from normal dependency satisfiability. + internalDepSatisfiableExternally + else -- If a 'PackageName' is defined by an internal component, the dep is + -- satisfiable (we're going to build it ourselves) + internalDepSatisfiable + | otherwise = + depSatisfiable + where + -- Internal dependency is when dependency is the same as package. + isInternalDep = pn == depName - depSatisfiable = + depSatisfiable = not . null $ PackageIndex.lookupDependency installedPackageSet depName vr - internalDepSatisfiable = + internalDepSatisfiable = Set.isSubsetOf (NES.toSet sublibs) packageLibraries - internalDepSatisfiableExternally = + internalDepSatisfiableExternally = all (\ln -> not $ null $ PackageIndex.lookupInternalDependency installedPackageSet pn vr ln) sublibs - -- Check whether a library exists and is visible. - -- We don't disambiguate between dependency on non-existent or private - -- library yet, so we just return a bool and later report a generic error. - visible lib = maybe - False -- Does not even exist (wasn't in the depsMap) - (\ipi -> IPI.libVisibility ipi == LibraryVisibilityPublic - -- If the override is enabled, the visibility does - -- not matter (it's handled externally) - || allow_private_deps - -- If it's a library of the same package then it's - -- always visible. - -- This is only triggered when passing a component - -- of the same package as --dependency, such as in: - -- cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit.test.hs - || pkgName (IPI.sourcePackageId ipi) == pn) - maybeIPI - where maybeIPI = Map.lookup (depName, CLibName lib) requiredDepsMap + -- Check whether a library exists and is visible. + -- We don't disambiguate between dependency on non-existent or private + -- library yet, so we just return a bool and later report a generic error. + visible lib = + maybe + False -- Does not even exist (wasn't in the depsMap) + ( \ipi -> + IPI.libVisibility ipi == LibraryVisibilityPublic + -- If the override is enabled, the visibility does + -- not matter (it's handled externally) + || allow_private_deps + -- If it's a library of the same package then it's + -- always visible. + -- This is only triggered when passing a component + -- of the same package as --dependency, such as in: + -- cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit.test.hs + || pkgName (IPI.sourcePackageId ipi) == pn + ) + maybeIPI + where + maybeIPI = Map.lookup (depName, CLibName lib) requiredDepsMap -- | Finalize a generic package description. The workhorse is -- 'finalizePD' but there's a bit of other nattering @@ -997,130 +1194,199 @@ dependencySatisfiable -- TODO: what exactly is the business with @flaggedTests@ and -- @flaggedBenchmarks@? configureFinalizedPackage - :: Verbosity - -> ConfigFlags - -> ComponentRequestedSpec - -> [PackageVersionConstraint] - -> (Dependency -> Bool) -- ^ tests if a dependency is satisfiable. - -- Might say it's satisfiable even when not. - -> Compiler - -> Platform - -> GenericPackageDescription - -> IO (PackageDescription, FlagAssignment) -configureFinalizedPackage verbosity cfg enabled - allConstraints satisfies comp compPlatform pkg_descr0 = do - + :: Verbosity + -> ConfigFlags + -> ComponentRequestedSpec + -> [PackageVersionConstraint] + -> (Dependency -> Bool) + -- ^ tests if a dependency is satisfiable. + -- Might say it's satisfiable even when not. + -> Compiler + -> Platform + -> GenericPackageDescription + -> IO (PackageDescription, FlagAssignment) +configureFinalizedPackage + verbosity + cfg + enabled + allConstraints + satisfies + comp + compPlatform + pkg_descr0 = do (pkg_descr0', flags) <- - case finalizePD - (configConfigurationsFlags cfg) - enabled - satisfies - compPlatform - (compilerInfo comp) - allConstraints - pkg_descr0 - of Right r -> return r - Left missing -> - die' verbosity $ "Encountered missing or private dependencies:\n" - ++ (render . nest 4 . sep . punctuate comma - . map (pretty . simplifyDependency) - $ missing) + case finalizePD + (configConfigurationsFlags cfg) + enabled + satisfies + compPlatform + (compilerInfo comp) + allConstraints + pkg_descr0 of + Right r -> return r + Left missing -> + die' verbosity $ + "Encountered missing or private dependencies:\n" + ++ ( render + . nest 4 + . sep + . punctuate comma + . map (pretty . simplifyDependency) + $ missing + ) -- add extra include/lib dirs as specified in cfg -- we do it here so that those get checked too let pkg_descr = addExtraIncludeLibDirs pkg_descr0' unless (nullFlagAssignment flags) $ - info verbosity $ "Flags chosen: " - ++ intercalate ", " [ unFlagName fn ++ "=" ++ prettyShow value - | (fn, value) <- unFlagAssignment flags ] + info verbosity $ + "Flags chosen: " + ++ intercalate + ", " + [ unFlagName fn ++ "=" ++ prettyShow value + | (fn, value) <- unFlagAssignment flags + ] return (pkg_descr, flags) - where - addExtraIncludeLibDirs pkg_descr = - let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg - , extraLibDirsStatic = configExtraLibDirsStatic cfg - , extraFrameworkDirs = configExtraFrameworkDirs cfg - , includeDirs = configExtraIncludeDirs cfg} - modifyLib l = l{ libBuildInfo = libBuildInfo l - `mappend` extraBi } - modifyExecutable e = e{ buildInfo = buildInfo e - `mappend` extraBi} - modifyForeignLib f = f{ foreignLibBuildInfo = foreignLibBuildInfo f - `mappend` extraBi} - modifyTestsuite t = t{ testBuildInfo = testBuildInfo t - `mappend` extraBi} - modifyBenchmark b = b{ benchmarkBuildInfo = benchmarkBuildInfo b - `mappend` extraBi} - in pkg_descr - { library = modifyLib `fmap` library pkg_descr - , subLibraries = modifyLib `map` subLibraries pkg_descr - , executables = modifyExecutable `map` executables pkg_descr - , foreignLibs = modifyForeignLib `map` foreignLibs pkg_descr - , testSuites = modifyTestsuite `map` testSuites pkg_descr - , benchmarks = modifyBenchmark `map` benchmarks pkg_descr - } + where + addExtraIncludeLibDirs pkg_descr = + let extraBi = + mempty + { extraLibDirs = configExtraLibDirs cfg + , extraLibDirsStatic = configExtraLibDirsStatic cfg + , extraFrameworkDirs = configExtraFrameworkDirs cfg + , includeDirs = configExtraIncludeDirs cfg + } + modifyLib l = + l + { libBuildInfo = + libBuildInfo l + `mappend` extraBi + } + modifyExecutable e = + e + { buildInfo = + buildInfo e + `mappend` extraBi + } + modifyForeignLib f = + f + { foreignLibBuildInfo = + foreignLibBuildInfo f + `mappend` extraBi + } + modifyTestsuite t = + t + { testBuildInfo = + testBuildInfo t + `mappend` extraBi + } + modifyBenchmark b = + b + { benchmarkBuildInfo = + benchmarkBuildInfo b + `mappend` extraBi + } + in pkg_descr + { library = modifyLib `fmap` library pkg_descr + , subLibraries = modifyLib `map` subLibraries pkg_descr + , executables = modifyExecutable `map` executables pkg_descr + , foreignLibs = modifyForeignLib `map` foreignLibs pkg_descr + , testSuites = modifyTestsuite `map` testSuites pkg_descr + , benchmarks = modifyBenchmark `map` benchmarks pkg_descr + } -- | Check for use of Cabal features which require compiler support checkCompilerProblems :: Verbosity -> Compiler -> PackageDescription -> ComponentRequestedSpec -> IO () checkCompilerProblems verbosity comp pkg_descr enabled = do - unless (renamingPackageFlagsSupported comp || - all (all (isDefaultIncludeRenaming . mixinIncludeRenaming) . mixins) - (enabledBuildInfos pkg_descr enabled)) $ - die' verbosity $ - "Your compiler does not support thinning and renaming on " - ++ "package flags. To use this feature you must use " - ++ "GHC 7.9 or later." - - when (any (not.null.reexportedModules) (allLibraries pkg_descr) - && not (reexportedModulesSupported comp)) $ - die' verbosity $ - "Your compiler does not support module re-exports. To use " - ++ "this feature you must use GHC 7.9 or later." - - when (any (not.null.signatures) (allLibraries pkg_descr) - && not (backpackSupported comp)) $ - die' verbosity $ - "Your compiler does not support Backpack. To use " - ++ "this feature you must use GHC 8.1 or later." + unless + ( renamingPackageFlagsSupported comp + || all + (all (isDefaultIncludeRenaming . mixinIncludeRenaming) . mixins) + (enabledBuildInfos pkg_descr enabled) + ) + $ die' verbosity + $ "Your compiler does not support thinning and renaming on " + ++ "package flags. To use this feature you must use " + ++ "GHC 7.9 or later." + + when + ( any (not . null . reexportedModules) (allLibraries pkg_descr) + && not (reexportedModulesSupported comp) + ) + $ die' verbosity + $ "Your compiler does not support module re-exports. To use " + ++ "this feature you must use GHC 7.9 or later." + + when + ( any (not . null . signatures) (allLibraries pkg_descr) + && not (backpackSupported comp) + ) + $ die' verbosity + $ "Your compiler does not support Backpack. To use " + ++ "this feature you must use GHC 8.1 or later." -- | Select dependencies for the package. configureDependencies - :: Verbosity - -> UseExternalInternalDeps - -> Set LibraryName - -> InstalledPackageIndex -- ^ installed packages - -> Map (PackageName, ComponentName) InstalledPackageInfo -- ^ required deps - -> PackageDescription - -> ComponentRequestedSpec - -> IO [PreExistingComponent] -configureDependencies verbosity use_external_internal_deps - packageLibraries installedPackageSet requiredDepsMap pkg_descr enableSpec = do + :: Verbosity + -> UseExternalInternalDeps + -> Set LibraryName + -> InstalledPackageIndex + -- ^ installed packages + -> Map (PackageName, ComponentName) InstalledPackageInfo + -- ^ required deps + -> PackageDescription + -> ComponentRequestedSpec + -> IO [PreExistingComponent] +configureDependencies + verbosity + use_external_internal_deps + packageLibraries + installedPackageSet + requiredDepsMap + pkg_descr + enableSpec = do let failedDeps :: [FailedDependency] allPkgDeps :: [ResolvedDependency] - (failedDeps, allPkgDeps) = partitionEithers $ concat - [ fmap (\s -> (dep, s)) <$> status - | dep <- enabledBuildDepends pkg_descr enableSpec - , let status = selectDependency (package pkg_descr) - packageLibraries installedPackageSet - requiredDepsMap use_external_internal_deps dep ] - - internalPkgDeps = [ pkgid - | (_, InternalDependency pkgid) <- allPkgDeps ] + (failedDeps, allPkgDeps) = + partitionEithers $ + concat + [ fmap (\s -> (dep, s)) <$> status + | dep <- enabledBuildDepends pkg_descr enableSpec + , let status = + selectDependency + (package pkg_descr) + packageLibraries + installedPackageSet + requiredDepsMap + use_external_internal_deps + dep + ] + + internalPkgDeps = + [ pkgid + | (_, InternalDependency pkgid) <- allPkgDeps + ] -- NB: we have to SAVE the package name, because this is the only -- way we can be able to resolve package names in the package -- description. - externalPkgDeps = [ pec - | (_, ExternalDependency pec) <- allPkgDeps ] + externalPkgDeps = + [ pec + | (_, ExternalDependency pec) <- allPkgDeps + ] - when (not (null internalPkgDeps) - && not (newPackageDepsBehaviour pkg_descr)) $ - die' verbosity $ "The field 'build-depends: " - ++ intercalate ", " (map (prettyShow . packageName) internalPkgDeps) - ++ "' refers to a library which is defined within the same " - ++ "package. To use this feature the package must specify at " - ++ "least 'cabal-version: >= 1.8'." + when + ( not (null internalPkgDeps) + && not (newPackageDepsBehaviour pkg_descr) + ) + $ die' verbosity + $ "The field 'build-depends: " + ++ intercalate ", " (map (prettyShow . packageName) internalPkgDeps) + ++ "' refers to a library which is defined within the same " + ++ "package. To use this feature the package must specify at " + ++ "least 'cabal-version: >= 1.8'." reportFailedDependencies verbosity failedDeps reportSelectedDependencies verbosity allPkgDeps @@ -1129,26 +1395,40 @@ configureDependencies verbosity use_external_internal_deps -- | Select and apply coverage settings for the build based on the -- 'ConfigFlags' and 'Compiler'. -configureCoverage :: Verbosity -> ConfigFlags -> Compiler - -> IO (LocalBuildInfo -> LocalBuildInfo) +configureCoverage + :: Verbosity + -> ConfigFlags + -> Compiler + -> IO (LocalBuildInfo -> LocalBuildInfo) configureCoverage verbosity cfg comp = do - let tryExeCoverage = fromFlagOrDefault False (configCoverage cfg) - tryLibCoverage = fromFlagOrDefault tryExeCoverage - (mappend (configCoverage cfg) (configLibCoverage cfg)) - if coverageSupported comp - then do - let apply lbi = lbi { libCoverage = tryLibCoverage - , exeCoverage = tryExeCoverage - } - return apply - else do - let apply lbi = lbi { libCoverage = False - , exeCoverage = False - } - when (tryExeCoverage || tryLibCoverage) $ warn verbosity - ("The compiler " ++ showCompilerId comp ++ " does not support " - ++ "program coverage. Program coverage has been disabled.") - return apply + let tryExeCoverage = fromFlagOrDefault False (configCoverage cfg) + tryLibCoverage = + fromFlagOrDefault + tryExeCoverage + (mappend (configCoverage cfg) (configLibCoverage cfg)) + if coverageSupported comp + then do + let apply lbi = + lbi + { libCoverage = tryLibCoverage + , exeCoverage = tryExeCoverage + } + return apply + else do + let apply lbi = + lbi + { libCoverage = False + , exeCoverage = False + } + when (tryExeCoverage || tryLibCoverage) $ + warn + verbosity + ( "The compiler " + ++ showCompilerId comp + ++ " does not support " + ++ "program coverage. Program coverage has been disabled." + ) + return apply -- | Compute the effective value of the profiling flags -- @--enable-library-profiling@ and @--enable-executable-profiling@ @@ -1168,61 +1448,89 @@ computeEffectiveProfiling cfg = -- -- The --profiling-detail and --library-profiling-detail flags behave -- similarly - let tryExeProfiling = fromFlagOrDefault False - (mappend (configProf cfg) (configProfExe cfg)) - tryLibProfiling = fromFlagOrDefault tryExeProfiling - (mappend (configProf cfg) (configProfLib cfg)) - in (tryLibProfiling, tryExeProfiling) + let tryExeProfiling = + fromFlagOrDefault + False + (mappend (configProf cfg) (configProfExe cfg)) + tryLibProfiling = + fromFlagOrDefault + tryExeProfiling + (mappend (configProf cfg) (configProfLib cfg)) + in (tryLibProfiling, tryExeProfiling) -- | Select and apply profiling settings for the build based on the -- 'ConfigFlags' and 'Compiler'. -configureProfiling :: Verbosity -> ConfigFlags -> Compiler - -> IO (LocalBuildInfo -> LocalBuildInfo) +configureProfiling + :: Verbosity + -> ConfigFlags + -> Compiler + -> IO (LocalBuildInfo -> LocalBuildInfo) configureProfiling verbosity cfg comp = do let (tryLibProfiling, tryExeProfiling) = computeEffectiveProfiling cfg - tryExeProfileLevel = fromFlagOrDefault ProfDetailDefault - (configProfDetail cfg) - tryLibProfileLevel = fromFlagOrDefault ProfDetailDefault - (mappend - (configProfDetail cfg) - (configProfLibDetail cfg)) + tryExeProfileLevel = + fromFlagOrDefault + ProfDetailDefault + (configProfDetail cfg) + tryLibProfileLevel = + fromFlagOrDefault + ProfDetailDefault + ( mappend + (configProfDetail cfg) + (configProfLibDetail cfg) + ) checkProfileLevel (ProfDetailOther other) = do - warn verbosity - ("Unknown profiling detail level '" ++ other - ++ "', using default.\nThe profiling detail levels are: " - ++ intercalate ", " - [ name | (name, _, _) <- knownProfDetailLevels ]) + warn + verbosity + ( "Unknown profiling detail level '" + ++ other + ++ "', using default.\nThe profiling detail levels are: " + ++ intercalate + ", " + [name | (name, _, _) <- knownProfDetailLevels] + ) return ProfDetailDefault checkProfileLevel other = return other (exeProfWithoutLibProf, applyProfiling) <- if profilingSupported comp - then do - exeLevel <- checkProfileLevel tryExeProfileLevel - libLevel <- checkProfileLevel tryLibProfileLevel - let apply lbi = lbi { withProfLib = tryLibProfiling - , withProfLibDetail = libLevel - , withProfExe = tryExeProfiling - , withProfExeDetail = exeLevel - } - return (tryExeProfiling && not tryLibProfiling, apply) - else do - let apply lbi = lbi { withProfLib = False - , withProfLibDetail = ProfDetailNone - , withProfExe = False - , withProfExeDetail = ProfDetailNone - } - when (tryExeProfiling || tryLibProfiling) $ warn verbosity - ("The compiler " ++ showCompilerId comp ++ " does not support " - ++ "profiling. Profiling has been disabled.") - return (False, apply) - - when exeProfWithoutLibProf $ warn verbosity - ("Executables will be built with profiling, but library " - ++ "profiling is disabled. Linking will fail if any executables " - ++ "depend on the library.") + then do + exeLevel <- checkProfileLevel tryExeProfileLevel + libLevel <- checkProfileLevel tryLibProfileLevel + let apply lbi = + lbi + { withProfLib = tryLibProfiling + , withProfLibDetail = libLevel + , withProfExe = tryExeProfiling + , withProfExeDetail = exeLevel + } + return (tryExeProfiling && not tryLibProfiling, apply) + else do + let apply lbi = + lbi + { withProfLib = False + , withProfLibDetail = ProfDetailNone + , withProfExe = False + , withProfExeDetail = ProfDetailNone + } + when (tryExeProfiling || tryLibProfiling) $ + warn + verbosity + ( "The compiler " + ++ showCompilerId comp + ++ " does not support " + ++ "profiling. Profiling has been disabled." + ) + return (False, apply) + + when exeProfWithoutLibProf $ + warn + verbosity + ( "Executables will be built with profiling, but library " + ++ "profiling is disabled. Linking will fail if any executables " + ++ "depend on the library." + ) return applyProfiling @@ -1230,16 +1538,17 @@ configureProfiling verbosity cfg comp = do -- Configuring package dependencies reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO () -reportProgram verbosity prog Nothing - = info verbosity $ "No " ++ programName prog ++ " found" -reportProgram verbosity prog (Just configuredProg) - = info verbosity $ "Using " ++ programName prog ++ version ++ location - where location = case programLocation configuredProg of - FoundOnSystem p -> " found on system at: " ++ p - UserSpecified p -> " given by user at: " ++ p - version = case programVersion configuredProg of - Nothing -> "" - Just v -> " version " ++ prettyShow v +reportProgram verbosity prog Nothing = + info verbosity $ "No " ++ programName prog ++ " found" +reportProgram verbosity prog (Just configuredProg) = + info verbosity $ "Using " ++ programName prog ++ version ++ location + where + location = case programLocation configuredProg of + FoundOnSystem p -> " found on system at: " ++ p + UserSpecified p -> " given by user at: " ++ p + version = case programVersion configuredProg of + Nothing -> "" + Just v -> " version " ++ prettyShow v hackageUrl :: String hackageUrl = "http://hackage.haskell.org/package/" @@ -1247,157 +1556,183 @@ hackageUrl = "http://hackage.haskell.org/package/" type ResolvedDependency = (Dependency, DependencyResolution) data DependencyResolution - -- | An external dependency from the package database, OR an + = -- | An external dependency from the package database, OR an -- internal dependency which we are getting from the package -- database. - = ExternalDependency PreExistingComponent - -- | An internal dependency ('PackageId' should be a library name) + ExternalDependency PreExistingComponent + | -- | An internal dependency ('PackageId' should be a library name) -- which we are going to have to build. (The -- 'PackageId' here is a hack to get a modest amount of -- polymorphism out of the 'Package' typeclass.) - | InternalDependency PackageId + InternalDependency PackageId -data FailedDependency = DependencyNotExists PackageName - | DependencyMissingInternal PackageName LibraryName - | DependencyNoVersion Dependency +data FailedDependency + = DependencyNotExists PackageName + | DependencyMissingInternal PackageName LibraryName + | DependencyNoVersion Dependency -- | Test for a package dependency and record the version we have installed. -selectDependency :: PackageId -- ^ Package id of current package - -> Set LibraryName -- ^ package libraries - -> InstalledPackageIndex -- ^ Installed packages - -> Map (PackageName, ComponentName) InstalledPackageInfo - -- ^ Packages for which we have been given specific deps to - -- use - -> UseExternalInternalDeps -- ^ Are we configuring a - -- single component? - -> Dependency - -> [Either FailedDependency DependencyResolution] -selectDependency pkgid internalIndex installedIndex requiredDepsMap +selectDependency + :: PackageId + -- ^ Package id of current package + -> Set LibraryName + -- ^ package libraries + -> InstalledPackageIndex + -- ^ Installed packages + -> Map (PackageName, ComponentName) InstalledPackageInfo + -- ^ Packages for which we have been given specific deps to + -- use + -> UseExternalInternalDeps + -- ^ Are we configuring a + -- single component? + -> Dependency + -> [Either FailedDependency DependencyResolution] +selectDependency + pkgid + internalIndex + installedIndex + requiredDepsMap use_external_internal_deps (Dependency dep_pkgname vr libs) = - -- If the dependency specification matches anything in the internal package - -- index, then we prefer that match to anything in the second. - -- For example: - -- - -- Name: MyLibrary - -- Version: 0.1 - -- Library - -- .. - -- Executable my-exec - -- build-depends: MyLibrary - -- - -- We want "build-depends: MyLibrary" always to match the internal library - -- even if there is a newer installed library "MyLibrary-0.2". - if dep_pkgname == pn - then - if use_external_internal_deps - then do_external_internal <$> NES.toList libs - else do_internal <$> NES.toList libs - else - do_external_external <$> NES.toList libs - where - pn = packageName pkgid - - -- It's an internal library, and we're not per-component build - do_internal lib - | Set.member lib internalIndex - = Right $ InternalDependency $ PackageIdentifier dep_pkgname $ packageVersion pkgid - - | otherwise - = Left $ DependencyMissingInternal dep_pkgname lib - - -- We have to look it up externally - do_external_external :: LibraryName -> Either FailedDependency DependencyResolution - do_external_external lib = do - ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of - -- If we know the exact pkg to use, then use it. - Just pkginstance -> Right pkginstance - -- Otherwise we just pick an arbitrary instance of the latest version. - Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex dep_pkgname vr lib of - Nothing -> Left (DependencyNotExists dep_pkgname) - Just pkg -> Right pkg - return $ ExternalDependency $ ipiToPreExistingComponent ipi - - do_external_internal :: LibraryName -> Either FailedDependency DependencyResolution - do_external_internal lib = do - ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of - -- If we know the exact pkg to use, then use it. - Just pkginstance -> Right pkginstance - Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex pn vr lib of - -- It's an internal library, being looked up externally - Nothing -> Left (DependencyMissingInternal dep_pkgname lib) - Just pkg -> Right pkg - return $ ExternalDependency $ ipiToPreExistingComponent ipi - - pickLastIPI :: [(Version, [InstalledPackageInfo])] -> Maybe InstalledPackageInfo - pickLastIPI pkgs = safeHead . snd . last =<< nonEmpty pkgs - -reportSelectedDependencies :: Verbosity - -> [ResolvedDependency] -> IO () + -- If the dependency specification matches anything in the internal package + -- index, then we prefer that match to anything in the second. + -- For example: + -- + -- Name: MyLibrary + -- Version: 0.1 + -- Library + -- .. + -- Executable my-exec + -- build-depends: MyLibrary + -- + -- We want "build-depends: MyLibrary" always to match the internal library + -- even if there is a newer installed library "MyLibrary-0.2". + if dep_pkgname == pn + then + if use_external_internal_deps + then do_external_internal <$> NES.toList libs + else do_internal <$> NES.toList libs + else do_external_external <$> NES.toList libs + where + pn = packageName pkgid + + -- It's an internal library, and we're not per-component build + do_internal lib + | Set.member lib internalIndex = + Right $ InternalDependency $ PackageIdentifier dep_pkgname $ packageVersion pkgid + | otherwise = + Left $ DependencyMissingInternal dep_pkgname lib + + -- We have to look it up externally + do_external_external :: LibraryName -> Either FailedDependency DependencyResolution + do_external_external lib = do + ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of + -- If we know the exact pkg to use, then use it. + Just pkginstance -> Right pkginstance + -- Otherwise we just pick an arbitrary instance of the latest version. + Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex dep_pkgname vr lib of + Nothing -> Left (DependencyNotExists dep_pkgname) + Just pkg -> Right pkg + return $ ExternalDependency $ ipiToPreExistingComponent ipi + + do_external_internal :: LibraryName -> Either FailedDependency DependencyResolution + do_external_internal lib = do + ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of + -- If we know the exact pkg to use, then use it. + Just pkginstance -> Right pkginstance + Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex pn vr lib of + -- It's an internal library, being looked up externally + Nothing -> Left (DependencyMissingInternal dep_pkgname lib) + Just pkg -> Right pkg + return $ ExternalDependency $ ipiToPreExistingComponent ipi + + pickLastIPI :: [(Version, [InstalledPackageInfo])] -> Maybe InstalledPackageInfo + pickLastIPI pkgs = safeHead . snd . last =<< nonEmpty pkgs + +reportSelectedDependencies + :: Verbosity + -> [ResolvedDependency] + -> IO () reportSelectedDependencies verbosity deps = - info verbosity $ unlines - [ "Dependency " ++ prettyShow (simplifyDependency dep) - ++ ": using " ++ prettyShow pkgid - | (dep, resolution) <- deps - , let pkgid = case resolution of - ExternalDependency pkg' -> packageId pkg' - InternalDependency pkgid' -> pkgid' ] + info verbosity $ + unlines + [ "Dependency " + ++ prettyShow (simplifyDependency dep) + ++ ": using " + ++ prettyShow pkgid + | (dep, resolution) <- deps + , let pkgid = case resolution of + ExternalDependency pkg' -> packageId pkg' + InternalDependency pkgid' -> pkgid' + ] reportFailedDependencies :: Verbosity -> [FailedDependency] -> IO () -reportFailedDependencies _ [] = return () +reportFailedDependencies _ [] = return () reportFailedDependencies verbosity failed = - die' verbosity (intercalate "\n\n" (map reportFailedDependency failed)) - + die' verbosity (intercalate "\n\n" (map reportFailedDependency failed)) where reportFailedDependency (DependencyNotExists pkgname) = - "there is no version of " ++ prettyShow pkgname ++ " installed.\n" - ++ "Perhaps you need to download and install it from\n" - ++ hackageUrl ++ prettyShow pkgname ++ "?" - + "there is no version of " + ++ prettyShow pkgname + ++ " installed.\n" + ++ "Perhaps you need to download and install it from\n" + ++ hackageUrl + ++ prettyShow pkgname + ++ "?" reportFailedDependency (DependencyMissingInternal pkgname lib) = - "internal dependency " ++ prettyShow (prettyLibraryNameComponent lib) ++ " not installed.\n" - ++ "Perhaps you need to configure and install it first?\n" - ++ "(This library was defined by " ++ prettyShow pkgname ++ ")" - + "internal dependency " + ++ prettyShow (prettyLibraryNameComponent lib) + ++ " not installed.\n" + ++ "Perhaps you need to configure and install it first?\n" + ++ "(This library was defined by " + ++ prettyShow pkgname + ++ ")" reportFailedDependency (DependencyNoVersion dep) = - "cannot satisfy dependency " ++ prettyShow (simplifyDependency dep) ++ "\n" + "cannot satisfy dependency " ++ prettyShow (simplifyDependency dep) ++ "\n" -- | List all installed packages in the given package databases. -- Non-existent package databases do not cause errors, they just get skipped -- with a warning and treated as empty ones, since technically they do not -- contain any package. -getInstalledPackages :: Verbosity -> Compiler - -> PackageDBStack -- ^ The stack of package databases. - -> ProgramDb - -> IO InstalledPackageIndex +getInstalledPackages + :: Verbosity + -> Compiler + -> PackageDBStack + -- ^ The stack of package databases. + -> ProgramDb + -> IO InstalledPackageIndex getInstalledPackages verbosity comp packageDBs progdb = do when (null packageDBs) $ - die' verbosity $ "No package databases have been specified. If you use " - ++ "--package-db=clear, you must follow it with --package-db= " - ++ "with 'global', 'user' or a specific file." + die' verbosity $ + "No package databases have been specified. If you use " + ++ "--package-db=clear, you must follow it with --package-db= " + ++ "with 'global', 'user' or a specific file." info verbosity "Reading installed packages..." -- do not check empty packagedbs (ghc-pkg would error out) packageDBs' <- filterM packageDBExists packageDBs case compilerFlavor comp of - GHC -> GHC.getInstalledPackages verbosity comp packageDBs' progdb + GHC -> GHC.getInstalledPackages verbosity comp packageDBs' progdb GHCJS -> GHCJS.getInstalledPackages verbosity packageDBs' progdb - UHC -> UHC.getInstalledPackages verbosity comp packageDBs' progdb - HaskellSuite {} -> + UHC -> UHC.getInstalledPackages verbosity comp packageDBs' progdb + HaskellSuite{} -> HaskellSuite.getInstalledPackages verbosity packageDBs' progdb - flv -> die' verbosity $ "don't know how to find the installed packages for " - ++ prettyShow flv + flv -> + die' verbosity $ + "don't know how to find the installed packages for " + ++ prettyShow flv where packageDBExists (SpecificPackageDB path) = do exists <- doesPathExist path unless exists $ - warn verbosity $ "Package db " <> path <> " does not exist yet" + warn verbosity $ + "Package db " <> path <> " does not exist yet" return exists -- Checking the user and global package dbs is more complicated and needs -- way more data. Also ghc-pkg won't error out unless the user/global -- pkgdb is overridden with an empty one, so we just don't check for them. - packageDBExists UserPackageDB = pure True - packageDBExists GlobalPackageDB = pure True + packageDBExists UserPackageDB = pure True + packageDBExists GlobalPackageDB = pure True -- | Like 'getInstalledPackages', but for a single package DB. -- @@ -1405,49 +1740,59 @@ getInstalledPackages verbosity comp packageDBs progdb = do -- That is because 'getInstalledPackages' performs some sanity checks -- on the package database stack in question. However, when sandboxes -- are involved these sanity checks are not desirable. -getPackageDBContents :: Verbosity -> Compiler - -> PackageDB -> ProgramDb - -> IO InstalledPackageIndex +getPackageDBContents + :: Verbosity + -> Compiler + -> PackageDB + -> ProgramDb + -> IO InstalledPackageIndex getPackageDBContents verbosity comp packageDB progdb = do info verbosity "Reading installed packages..." case compilerFlavor comp of GHC -> GHC.getPackageDBContents verbosity packageDB progdb GHCJS -> GHCJS.getPackageDBContents verbosity packageDB progdb -- For other compilers, try to fall back on 'getInstalledPackages'. - _ -> getInstalledPackages verbosity comp [packageDB] progdb - + _ -> getInstalledPackages verbosity comp [packageDB] progdb -- | A set of files (or directories) that can be monitored to detect when -- there might have been a change in the installed packages. --- -getInstalledPackagesMonitorFiles :: Verbosity -> Compiler - -> PackageDBStack - -> ProgramDb -> Platform - -> IO [FilePath] +getInstalledPackagesMonitorFiles + :: Verbosity + -> Compiler + -> PackageDBStack + -> ProgramDb + -> Platform + -> IO [FilePath] getInstalledPackagesMonitorFiles verbosity comp packageDBs progdb platform = case compilerFlavor comp of - GHC -> GHC.getInstalledPackagesMonitorFiles - verbosity platform progdb packageDBs + GHC -> + GHC.getInstalledPackagesMonitorFiles + verbosity + platform + progdb + packageDBs other -> do - warn verbosity $ "don't know how to find change monitoring files for " - ++ "the installed package databases for " ++ prettyShow other + warn verbosity $ + "don't know how to find change monitoring files for " + ++ "the installed package databases for " + ++ prettyShow other return [] -- | The user interface specifies the package dbs to use with a combination of -- @--global@, @--user@ and @--package-db=global|user|clear|$file@. -- This function combines the global/user flag and interprets the package-db -- flag into a single package db stack. --- interpretPackageDbFlags :: Bool -> [Maybe PackageDB] -> PackageDBStack interpretPackageDbFlags userInstall specificDBs = - extra initialStack specificDBs + extra initialStack specificDBs where - initialStack | userInstall = [GlobalPackageDB, UserPackageDB] - | otherwise = [GlobalPackageDB] + initialStack + | userInstall = [GlobalPackageDB, UserPackageDB] + | otherwise = [GlobalPackageDB] - extra dbs' [] = dbs' - extra _ (Nothing:dbs) = extra [] dbs - extra dbs' (Just db:dbs) = extra (dbs' ++ [db]) dbs + extra dbs' [] = dbs' + extra _ (Nothing : dbs) = extra [] dbs + extra dbs' (Just db : dbs) = extra (dbs' ++ [db]) dbs -- We are given both --constraint="foo < 2.0" style constraints and also -- specific packages to pick via --dependency="foo=foo-2.0-177d5cdf20962d0581". @@ -1463,40 +1808,54 @@ combinedConstraints :: [PackageVersionConstraint] -> [GivenComponent] -> InstalledPackageIndex - -> Either String ([PackageVersionConstraint], - Map (PackageName, ComponentName) InstalledPackageInfo) + -> Either + String + ( [PackageVersionConstraint] + , Map (PackageName, ComponentName) InstalledPackageInfo + ) combinedConstraints constraints dependencies installedPackages = do + when (not (null badComponentIds)) $ + Left $ + render $ + text "The following package dependencies were requested" + $+$ nest 4 (dispDependencies badComponentIds) + $+$ text "however the given installed package instance does not exist." - when (not (null badComponentIds)) $ - Left $ render $ text "The following package dependencies were requested" - $+$ nest 4 (dispDependencies badComponentIds) - $+$ text "however the given installed package instance does not exist." - - --TODO: we don't check that all dependencies are used! - - return (allConstraints, idConstraintMap) + -- TODO: we don't check that all dependencies are used! + return (allConstraints, idConstraintMap) where allConstraints :: [PackageVersionConstraint] - allConstraints = constraints - ++ [ thisPackageVersionConstraint (packageId pkg) - | (_, _, _, Just pkg) <- dependenciesPkgInfo ] + allConstraints = + constraints + ++ [ thisPackageVersionConstraint (packageId pkg) + | (_, _, _, Just pkg) <- dependenciesPkgInfo + ] idConstraintMap :: Map (PackageName, ComponentName) InstalledPackageInfo - idConstraintMap = Map.fromList - -- NB: do NOT use the packageName from - -- dependenciesPkgInfo! - [ ((pn, cname), pkg) - | (pn, cname, _, Just pkg) <- dependenciesPkgInfo ] + idConstraintMap = + Map.fromList + -- NB: do NOT use the packageName from + -- dependenciesPkgInfo! + [ ((pn, cname), pkg) + | (pn, cname, _, Just pkg) <- dependenciesPkgInfo + ] -- The dependencies along with the installed package info, if it exists - dependenciesPkgInfo :: [(PackageName, ComponentName, ComponentId, - Maybe InstalledPackageInfo)] + dependenciesPkgInfo + :: [ ( PackageName + , ComponentName + , ComponentId + , Maybe InstalledPackageInfo + ) + ] dependenciesPkgInfo = [ (pkgname, CLibName lname, cid, mpkg) | GivenComponent pkgname lname cid <- dependencies - , let mpkg = PackageIndex.lookupComponentId - installedPackages cid + , let mpkg = + PackageIndex.lookupComponentId + installedPackages + cid ] -- If we looked up a package specified by an installed package id @@ -1504,25 +1863,32 @@ combinedConstraints constraints dependencies installedPackages = do -- an error. badComponentIds = [ (pkgname, cname, cid) - | (pkgname, cname, cid, Nothing) <- dependenciesPkgInfo ] + | (pkgname, cname, cid, Nothing) <- dependenciesPkgInfo + ] dispDependencies deps = - hsep [ text "--dependency=" - <<>> quotes - (pretty pkgname - <<>> case cname of - CLibName LMainLibName -> "" - CLibName (LSubLibName n) -> ":" <<>> pretty n - _ -> ":" <<>> pretty cname - <<>> char '=' - <<>> pretty cid) - | (pkgname, cname, cid) <- deps ] + hsep + [ text "--dependency=" + <<>> quotes + ( pretty pkgname + <<>> case cname of + CLibName LMainLibName -> "" + CLibName (LSubLibName n) -> ":" <<>> pretty n + _ -> ":" <<>> pretty cname + <<>> char '=' + <<>> pretty cid + ) + | (pkgname, cname, cid) <- deps + ] -- ----------------------------------------------------------------------------- -- Configuring program dependencies -configureRequiredPrograms :: Verbosity -> [LegacyExeDependency] -> ProgramDb - -> IO ProgramDb +configureRequiredPrograms + :: Verbosity + -> [LegacyExeDependency] + -> ProgramDb + -> IO ProgramDb configureRequiredPrograms verbosity deps progdb = foldM (configureRequiredProgram verbosity) progdb deps @@ -1532,111 +1898,140 @@ configureRequiredPrograms verbosity deps progdb = -- known (exists in the input 'ProgramDb'), we will make sure that the -- program matches the required version; otherwise we will accept -- any version of the program and assume that it is a simpleProgram. -configureRequiredProgram :: Verbosity -> ProgramDb -> LegacyExeDependency - -> IO ProgramDb -configureRequiredProgram verbosity progdb +configureRequiredProgram + :: Verbosity + -> ProgramDb + -> LegacyExeDependency + -> IO ProgramDb +configureRequiredProgram + verbosity + progdb (LegacyExeDependency progName verRange) = - case lookupKnownProgram progName progdb of - Nothing -> - -- Try to configure it as a 'simpleProgram' automatically - -- - -- There's a bit of a story behind this line. In old versions - -- of Cabal, there were only internal build-tools dependencies. So the - -- behavior in this case was: - -- - -- - If a build-tool dependency was internal, don't do - -- any checking. - -- - -- - If it was external, call 'configureRequiredProgram' to - -- "configure" the executable. In particular, if - -- the program was not "known" (present in 'ProgramDb'), - -- then we would just error. This was fine, because - -- the only way a program could be executed from 'ProgramDb' - -- is if some library code from Cabal actually called it, - -- and the pre-existing Cabal code only calls known - -- programs from 'defaultProgramDb', and so if it - -- is calling something else, you have a Custom setup - -- script, and in that case you are expected to register - -- the program you want to call in the ProgramDb. - -- - -- OK, so that was fine, until I (ezyang, in 2016) refactored - -- Cabal to support per-component builds. In this case, what - -- was previously an internal build-tool dependency now became - -- an external one, and now previously "internal" dependencies - -- are now external. But these are permitted to exist even - -- when they are not previously configured (something that - -- can only occur by a Custom script.) - -- - -- So, I decided, "Fine, let's just accept these in any - -- case." Thus this line. The alternative would have been to - -- somehow detect when a build-tools dependency was "internal" (by - -- looking at the unflattened package description) but this - -- would also be incompatible with future work to support - -- external executable dependencies: we definitely cannot - -- assume they will be preinitialized in the 'ProgramDb'. - configureProgram verbosity (simpleProgram progName) progdb - Just prog - -- requireProgramVersion always requires the program have a version - -- but if the user says "build-depends: foo" ie no version constraint - -- then we should not fail if we cannot discover the program version. - | verRange == anyVersion -> do - (_, progdb') <- requireProgram verbosity prog progdb - return progdb' - | otherwise -> do - (_, _, progdb') <- requireProgramVersion verbosity prog verRange progdb - return progdb' + case lookupKnownProgram progName progdb of + Nothing -> + -- Try to configure it as a 'simpleProgram' automatically + -- + -- There's a bit of a story behind this line. In old versions + -- of Cabal, there were only internal build-tools dependencies. So the + -- behavior in this case was: + -- + -- - If a build-tool dependency was internal, don't do + -- any checking. + -- + -- - If it was external, call 'configureRequiredProgram' to + -- "configure" the executable. In particular, if + -- the program was not "known" (present in 'ProgramDb'), + -- then we would just error. This was fine, because + -- the only way a program could be executed from 'ProgramDb' + -- is if some library code from Cabal actually called it, + -- and the pre-existing Cabal code only calls known + -- programs from 'defaultProgramDb', and so if it + -- is calling something else, you have a Custom setup + -- script, and in that case you are expected to register + -- the program you want to call in the ProgramDb. + -- + -- OK, so that was fine, until I (ezyang, in 2016) refactored + -- Cabal to support per-component builds. In this case, what + -- was previously an internal build-tool dependency now became + -- an external one, and now previously "internal" dependencies + -- are now external. But these are permitted to exist even + -- when they are not previously configured (something that + -- can only occur by a Custom script.) + -- + -- So, I decided, "Fine, let's just accept these in any + -- case." Thus this line. The alternative would have been to + -- somehow detect when a build-tools dependency was "internal" (by + -- looking at the unflattened package description) but this + -- would also be incompatible with future work to support + -- external executable dependencies: we definitely cannot + -- assume they will be preinitialized in the 'ProgramDb'. + configureProgram verbosity (simpleProgram progName) progdb + Just prog + -- requireProgramVersion always requires the program have a version + -- but if the user says "build-depends: foo" ie no version constraint + -- then we should not fail if we cannot discover the program version. + | verRange == anyVersion -> do + (_, progdb') <- requireProgram verbosity prog progdb + return progdb' + | otherwise -> do + (_, _, progdb') <- requireProgramVersion verbosity prog verRange progdb + return progdb' -- ----------------------------------------------------------------------------- -- Configuring pkg-config package dependencies -configurePkgconfigPackages :: Verbosity -> PackageDescription - -> ProgramDb -> ComponentRequestedSpec - -> IO (PackageDescription, ProgramDb) +configurePkgconfigPackages + :: Verbosity + -> PackageDescription + -> ProgramDb + -> ComponentRequestedSpec + -> IO (PackageDescription, ProgramDb) configurePkgconfigPackages verbosity pkg_descr progdb enabled | null allpkgs = return (pkg_descr, progdb) - | otherwise = do - (_, _, progdb') <- requireProgramVersion - (lessVerbose verbosity) pkgConfigProgram - (orLaterVersion $ mkVersion [0,9,0]) progdb - traverse_ requirePkg allpkgs - mlib' <- traverse addPkgConfigBILib (library pkg_descr) - libs' <- traverse addPkgConfigBILib (subLibraries pkg_descr) - exes' <- traverse addPkgConfigBIExe (executables pkg_descr) - tests' <- traverse addPkgConfigBITest (testSuites pkg_descr) - benches' <- traverse addPkgConfigBIBench (benchmarks pkg_descr) - let pkg_descr' = pkg_descr { library = mlib', - subLibraries = libs', executables = exes', - testSuites = tests', benchmarks = benches' } - return (pkg_descr', progdb') - + | otherwise = do + (_, _, progdb') <- + requireProgramVersion + (lessVerbose verbosity) + pkgConfigProgram + (orLaterVersion $ mkVersion [0, 9, 0]) + progdb + traverse_ requirePkg allpkgs + mlib' <- traverse addPkgConfigBILib (library pkg_descr) + libs' <- traverse addPkgConfigBILib (subLibraries pkg_descr) + exes' <- traverse addPkgConfigBIExe (executables pkg_descr) + tests' <- traverse addPkgConfigBITest (testSuites pkg_descr) + benches' <- traverse addPkgConfigBIBench (benchmarks pkg_descr) + let pkg_descr' = + pkg_descr + { library = mlib' + , subLibraries = libs' + , executables = exes' + , testSuites = tests' + , benchmarks = benches' + } + return (pkg_descr', progdb') where allpkgs = concatMap pkgconfigDepends (enabledBuildInfos pkg_descr enabled) - pkgconfig = getDbProgramOutput (lessVerbose verbosity) - pkgConfigProgram progdb + pkgconfig = + getDbProgramOutput + (lessVerbose verbosity) + pkgConfigProgram + progdb requirePkg dep@(PkgconfigDependency pkgn range) = do - version <- pkgconfig ["--modversion", pkg] - `catchIO` (\_ -> die' verbosity notFound) - `catchExit` (\_ -> die' verbosity notFound) + version <- + pkgconfig ["--modversion", pkg] + `catchIO` (\_ -> die' verbosity notFound) + `catchExit` (\_ -> die' verbosity notFound) let trim = dropWhile isSpace . dropWhileEnd isSpace let v = PkgconfigVersion (toUTF8BS $ trim version) if not (withinPkgconfigVersionRange v range) - then die' verbosity (badVersion v) - else info verbosity (depSatisfied v) + then die' verbosity (badVersion v) + else info verbosity (depSatisfied v) where - notFound = "The pkg-config package '" ++ pkg ++ "'" - ++ versionRequirement - ++ " is required but it could not be found." - badVersion v = "The pkg-config package '" ++ pkg ++ "'" - ++ versionRequirement - ++ " is required but the version installed on the" - ++ " system is version " ++ prettyShow v - depSatisfied v = "Dependency " ++ prettyShow dep - ++ ": using version " ++ prettyShow v + notFound = + "The pkg-config package '" + ++ pkg + ++ "'" + ++ versionRequirement + ++ " is required but it could not be found." + badVersion v = + "The pkg-config package '" + ++ pkg + ++ "'" + ++ versionRequirement + ++ " is required but the version installed on the" + ++ " system is version " + ++ prettyShow v + depSatisfied v = + "Dependency " + ++ prettyShow dep + ++ ": using version " + ++ prettyShow v versionRequirement | isAnyPkgconfigVersion range = "" - | otherwise = " version " ++ prettyShow range + | otherwise = " version " ++ prettyShow range pkg = unPkgconfigName pkgn @@ -1647,27 +2042,27 @@ configurePkgconfigPackages verbosity pkg_descr progdb enabled -- Adds pkgconfig dependencies to the build info for a library addPkgConfigBILib = addPkgConfigBI libBuildInfo $ - \lib bi -> lib { libBuildInfo = bi } + \lib bi -> lib{libBuildInfo = bi} -- Adds pkgconfig dependencies to the build info for an executable addPkgConfigBIExe = addPkgConfigBI buildInfo $ - \exe bi -> exe { buildInfo = bi } + \exe bi -> exe{buildInfo = bi} -- Adds pkgconfig dependencies to the build info for a test suite addPkgConfigBITest = addPkgConfigBI testBuildInfo $ - \test bi -> test { testBuildInfo = bi } + \test bi -> test{testBuildInfo = bi} -- Adds pkgconfig dependencies to the build info for a benchmark addPkgConfigBIBench = addPkgConfigBI benchmarkBuildInfo $ - \bench bi -> bench { benchmarkBuildInfo = bi } + \bench bi -> bench{benchmarkBuildInfo = bi} pkgconfigBuildInfo :: [PkgconfigDependency] -> IO BuildInfo - pkgconfigBuildInfo [] = return mempty + pkgconfigBuildInfo [] = return mempty pkgconfigBuildInfo pkgdeps = do - let pkgs = nub [ prettyShow pkg | PkgconfigDependency pkg _ <- pkgdeps ] + let pkgs = nub [prettyShow pkg | PkgconfigDependency pkg _ <- pkgdeps] ccflags <- pkgconfig ("--cflags" : pkgs) - ldflags <- pkgconfig ("--libs" : pkgs) - ldflags_static <- pkgconfig ("--libs" : "--static" : pkgs) + ldflags <- pkgconfig ("--libs" : pkgs) + ldflags_static <- pkgconfig ("--libs" : "--static" : pkgs) return (ccLdOptionsBuildInfo (words ccflags) (words ldflags) (words ldflags_static)) -- | Makes a 'BuildInfo' from C compiler and linker flags. @@ -1680,48 +2075,54 @@ configurePkgconfigPackages verbosity pkg_descr progdb enabled -- > ldflags <- getDbProgramOutput verbosity prog progdb ["--libs"] -- > ldflags_static <- getDbProgramOutput verbosity prog progdb ["--libs", "--static"] -- > return (ccldOptionsBuildInfo (words ccflags) (words ldflags) (words ldflags_static)) --- ccLdOptionsBuildInfo :: [String] -> [String] -> [String] -> BuildInfo ccLdOptionsBuildInfo cflags ldflags ldflags_static = - let (includeDirs', cflags') = partition ("-I" `isPrefixOf`) cflags - (extraLibs', ldflags') = partition ("-l" `isPrefixOf`) ldflags + let (includeDirs', cflags') = partition ("-I" `isPrefixOf`) cflags + (extraLibs', ldflags') = partition ("-l" `isPrefixOf`) ldflags (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags' - (extraLibsStatic') = filter ("-l" `isPrefixOf`) ldflags_static - (extraLibDirsStatic') = filter ("-L" `isPrefixOf`) ldflags_static - in mempty { - includeDirs = map (drop 2) includeDirs', - extraLibs = map (drop 2) extraLibs', - extraLibDirs = map (drop 2) extraLibDirs', - extraLibsStatic = map (drop 2) extraLibsStatic', - extraLibDirsStatic = map (drop 2) extraLibDirsStatic', - ccOptions = cflags', - ldOptions = ldflags'' - } + (extraLibsStatic') = filter ("-l" `isPrefixOf`) ldflags_static + (extraLibDirsStatic') = filter ("-L" `isPrefixOf`) ldflags_static + in mempty + { includeDirs = map (drop 2) includeDirs' + , extraLibs = map (drop 2) extraLibs' + , extraLibDirs = map (drop 2) extraLibDirs' + , extraLibsStatic = map (drop 2) extraLibsStatic' + , extraLibDirsStatic = map (drop 2) extraLibDirsStatic' + , ccOptions = cflags' + , ldOptions = ldflags'' + } -- ----------------------------------------------------------------------------- -- Determining the compiler details -configCompilerAuxEx :: ConfigFlags - -> IO (Compiler, Platform, ProgramDb) -configCompilerAuxEx cfg = configCompilerEx (flagToMaybe $ configHcFlavor cfg) - (flagToMaybe $ configHcPath cfg) - (flagToMaybe $ configHcPkg cfg) - programDb - (fromFlag (configVerbosity cfg)) +configCompilerAuxEx + :: ConfigFlags + -> IO (Compiler, Platform, ProgramDb) +configCompilerAuxEx cfg = + configCompilerEx + (flagToMaybe $ configHcFlavor cfg) + (flagToMaybe $ configHcPath cfg) + (flagToMaybe $ configHcPkg cfg) + programDb + (fromFlag (configVerbosity cfg)) where programDb = mkProgramDb cfg defaultProgramDb -configCompilerEx :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath - -> ProgramDb -> Verbosity - -> IO (Compiler, Platform, ProgramDb) +configCompilerEx + :: Maybe CompilerFlavor + -> Maybe FilePath + -> Maybe FilePath + -> ProgramDb + -> Verbosity + -> IO (Compiler, Platform, ProgramDb) configCompilerEx Nothing _ _ _ verbosity = die' verbosity "Unknown compiler" configCompilerEx (Just hcFlavor) hcPath hcPkg progdb verbosity = do (comp, maybePlatform, programDb) <- case hcFlavor of - GHC -> GHC.configure verbosity hcPath hcPkg progdb + GHC -> GHC.configure verbosity hcPath hcPkg progdb GHCJS -> GHCJS.configure verbosity hcPath hcPkg progdb - UHC -> UHC.configure verbosity hcPath hcPkg progdb - HaskellSuite {} -> HaskellSuite.configure verbosity hcPath hcPkg progdb - _ -> die' verbosity "Unknown compiler" + UHC -> UHC.configure verbosity hcPath hcPkg progdb + HaskellSuite{} -> HaskellSuite.configure verbosity hcPath hcPkg progdb + _ -> die' verbosity "Unknown compiler" return (comp, fromMaybe buildPlatform maybePlatform, programDb) -- ----------------------------------------------------------------------------- @@ -1734,235 +2135,282 @@ configCompilerEx (Just hcFlavor) hcPath hcPkg progdb verbosity = do -- TODO: produce a log file from the compiler errors, if any. checkForeignDeps :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () checkForeignDeps pkg lbi verbosity = - ifBuildsWith allHeaders (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling - -- lucky - (return ()) - (do missingLibs <- findMissingLibs - missingHdr <- findOffendingHdr - explainErrors missingHdr missingLibs) - where - allHeaders = collectField includes - allLibs = collectField $ - if withFullyStaticExe lbi + ifBuildsWith + allHeaders + (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling + -- lucky + (return ()) + ( do + missingLibs <- findMissingLibs + missingHdr <- findOffendingHdr + explainErrors missingHdr missingLibs + ) + where + allHeaders = collectField includes + allLibs = + collectField $ + if withFullyStaticExe lbi then extraLibsStatic else extraLibs - ifBuildsWith headers args success failure = do - checkDuplicateHeaders - ok <- builds (makeProgram headers) args - if ok then success else failure + ifBuildsWith headers args success failure = do + checkDuplicateHeaders + ok <- builds (makeProgram headers) args + if ok then success else failure - -- Ensure that there is only one header with a given name - -- in either the generated (most likely by `configure`) - -- build directory (e.g. `dist/build`) or in the source directory. - -- - -- If it exists in both, we'll remove the one in the source - -- directory, as the generated should take precedence. - -- - -- C compilers like to prefer source local relative includes, - -- so the search paths provided to the compiler via -I are - -- ignored if the included file can be found relative to the - -- including file. As such we need to take drastic measures - -- and delete the offending file in the source directory. - checkDuplicateHeaders = do - let relIncDirs = filter (not . isAbsolute) (collectField includeDirs) - isHeader = isSuffixOf ".h" - genHeaders <- for relIncDirs $ \dir -> - fmap (dir ) . filter isHeader <$> - listDirectory (buildDir lbi dir) `catchIO` (\_ -> return []) - srcHeaders <- for relIncDirs $ \dir -> - fmap (dir ) . filter isHeader <$> - listDirectory (baseDir lbi dir) `catchIO` (\_ -> return []) - let commonHeaders = concat genHeaders `intersect` concat srcHeaders - for_ commonHeaders $ \hdr -> do - warn verbosity $ "Duplicate header found in " - ++ (buildDir lbi hdr) - ++ " and " - ++ (baseDir lbi hdr) - ++ "; removing " - ++ (baseDir lbi hdr) - removeFile (baseDir lbi hdr) - - findOffendingHdr = - ifBuildsWith allHeaders ccArgs - (return Nothing) - (go . tail . NEL.inits $ allHeaders) - where - go [] = return Nothing -- cannot happen - go (hdrs:hdrsInits) = - -- Try just preprocessing first - ifBuildsWith hdrs cppArgs - -- If that works, try compiling too - (ifBuildsWith hdrs ccArgs - (go hdrsInits) - (return . fmap Right . safeLast $ hdrs)) - (return . fmap Left . safeLast $ hdrs) - - - cppArgs = "-E":commonCppArgs -- preprocess only - ccArgs = "-c":commonCcArgs -- don't try to link - - findMissingLibs = ifBuildsWith [] (makeLdArgs allLibs) - (return []) - (filterM (fmap not . libExists) allLibs) - - libExists lib = builds (makeProgram []) (makeLdArgs [lib]) - - baseDir lbi' = fromMaybe "." (takeDirectory <$> cabalFilePath lbi') - - commonCppArgs = platformDefines lbi - -- TODO: This is a massive hack, to work around the - -- fact that the test performed here should be - -- PER-component (c.f. the "I'm Feeling Lucky"; we - -- should NOT be glomming everything together.) - ++ [ "-I" ++ buildDir lbi "autogen" ] - -- `configure' may generate headers in the build directory - ++ [ "-I" ++ buildDir lbi dir - | dir <- ordNub (collectField includeDirs) - , not (isAbsolute dir)] - -- we might also reference headers from the - -- packages directory. - ++ [ "-I" ++ baseDir lbi dir - | dir <- ordNub (collectField includeDirs) - , not (isAbsolute dir)] - ++ [ "-I" ++ dir | dir <- ordNub (collectField includeDirs) - , isAbsolute dir] - ++ ["-I" ++ baseDir lbi] - ++ collectField cppOptions - ++ collectField ccOptions - ++ [ "-I" ++ dir - | dir <- ordNub [ dir - | dep <- deps - , dir <- IPI.includeDirs dep ] - -- dedupe include dirs of dependencies - -- to prevent quadratic blow-up - ] - ++ [ opt - | dep <- deps - , opt <- IPI.ccOptions dep ] - - commonCcArgs = commonCppArgs - ++ collectField ccOptions - ++ [ opt - | dep <- deps - , opt <- IPI.ccOptions dep ] - - commonLdArgs = [ "-L" ++ dir - | dir <- ordNub $ collectField (if withFullyStaticExe lbi - then extraLibDirsStatic - else extraLibDirs - ) ] - ++ collectField ldOptions - ++ [ "-L" ++ dir - | dir <- ordNub [ dir - | dep <- deps - , dir <- if withFullyStaticExe lbi - then IPI.libraryDirsStatic dep - else IPI.libraryDirs dep ] - ] - --TODO: do we also need dependent packages' ld options? - makeLdArgs libs = [ "-l"++lib | lib <- libs ] ++ commonLdArgs - - makeProgram hdrs = unlines $ - [ "#include \"" ++ hdr ++ "\"" | hdr <- hdrs ] ++ - ["int main(int argc, char** argv) { return 0; }"] - - collectField f = concatMap f allBi - allBi = enabledBuildInfos pkg (componentEnabledSpec lbi) - deps = PackageIndex.topologicalOrder (installedPkgs lbi) - - builds program args = do - tempDir <- getTemporaryDirectory - withTempFile tempDir ".c" $ \cName cHnd -> - withTempFile tempDir "" $ \oNname oHnd -> do - hPutStrLn cHnd program - hClose cHnd - hClose oHnd - _ <- getDbProgramOutput verbosity - gccProgram (withPrograms lbi) (cName:"-o":oNname:args) - return True - `catchIO` (\_ -> return False) - `catchExit` (\_ -> return False) - - explainErrors Nothing [] = return () -- should be impossible! - explainErrors _ _ - | isNothing . lookupProgram gccProgram . withPrograms $ lbi - - = die' verbosity $ unlines - [ "No working gcc", - "This package depends on foreign library but we cannot " - ++ "find a working C compiler. If you have it in a " - ++ "non-standard location you can use the --with-gcc " - ++ "flag to specify it." ] - - explainErrors hdr libs = die' verbosity $ unlines $ - [ if plural - then "Missing dependencies on foreign libraries:" - else "Missing dependency on a foreign library:" - | missing ] - ++ case hdr of - Just (Left h) -> ["* Missing (or bad) header file: " ++ h ] - _ -> [] - ++ case libs of - [] -> [] - [lib] -> ["* Missing (or bad) C library: " ++ lib] - _ -> ["* Missing (or bad) C libraries: " ++ - intercalate ", " libs] - ++ [if plural then messagePlural else messageSingular | missing] - ++ case hdr of - Just (Left _) -> [ headerCppMessage ] - Just (Right h) -> [ (if missing then "* " else "") - ++ "Bad header file: " ++ h - , headerCcMessage ] - _ -> [] - - where - plural = length libs >= 2 - -- Is there something missing? (as opposed to broken) - missing = not (null libs) - || case hdr of Just (Left _) -> True; _ -> False - - messageSingular = - "This problem can usually be solved by installing the system " - ++ "package that provides this library (you may need the " - ++ "\"-dev\" version). If the library is already installed " - ++ "but in a non-standard location then you can use the flags " - ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " - ++ "where it is." - ++ "If the library file does exist, it may contain errors that " - ++ "are caught by the C compiler at the preprocessing stage. " - ++ "In this case you can re-run configure with the verbosity " - ++ "flag -v3 to see the error messages." - messagePlural = - "This problem can usually be solved by installing the system " - ++ "packages that provide these libraries (you may need the " - ++ "\"-dev\" versions). If the libraries are already installed " - ++ "but in a non-standard location then you can use the flags " - ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " - ++ "where they are." - ++ "If the library files do exist, it may contain errors that " - ++ "are caught by the C compiler at the preprocessing stage. " - ++ "In this case you can re-run configure with the verbosity " - ++ "flag -v3 to see the error messages." - headerCppMessage = - "If the header file does exist, it may contain errors that " - ++ "are caught by the C compiler at the preprocessing stage. " - ++ "In this case you can re-run configure with the verbosity " - ++ "flag -v3 to see the error messages." - headerCcMessage = - "The header file contains a compile error. " - ++ "You can re-run configure with the verbosity flag " - ++ "-v3 to see the error messages from the C compiler." + -- Ensure that there is only one header with a given name + -- in either the generated (most likely by `configure`) + -- build directory (e.g. `dist/build`) or in the source directory. + -- + -- If it exists in both, we'll remove the one in the source + -- directory, as the generated should take precedence. + -- + -- C compilers like to prefer source local relative includes, + -- so the search paths provided to the compiler via -I are + -- ignored if the included file can be found relative to the + -- including file. As such we need to take drastic measures + -- and delete the offending file in the source directory. + checkDuplicateHeaders = do + let relIncDirs = filter (not . isAbsolute) (collectField includeDirs) + isHeader = isSuffixOf ".h" + genHeaders <- for relIncDirs $ \dir -> + fmap (dir ) . filter isHeader + <$> listDirectory (buildDir lbi dir) `catchIO` (\_ -> return []) + srcHeaders <- for relIncDirs $ \dir -> + fmap (dir ) . filter isHeader + <$> listDirectory (baseDir lbi dir) `catchIO` (\_ -> return []) + let commonHeaders = concat genHeaders `intersect` concat srcHeaders + for_ commonHeaders $ \hdr -> do + warn verbosity $ + "Duplicate header found in " + ++ (buildDir lbi hdr) + ++ " and " + ++ (baseDir lbi hdr) + ++ "; removing " + ++ (baseDir lbi hdr) + removeFile (baseDir lbi hdr) + + findOffendingHdr = + ifBuildsWith + allHeaders + ccArgs + (return Nothing) + (go . tail . NEL.inits $ allHeaders) + where + go [] = return Nothing -- cannot happen + go (hdrs : hdrsInits) = + -- Try just preprocessing first + ifBuildsWith + hdrs + cppArgs + -- If that works, try compiling too + ( ifBuildsWith + hdrs + ccArgs + (go hdrsInits) + (return . fmap Right . safeLast $ hdrs) + ) + (return . fmap Left . safeLast $ hdrs) + + cppArgs = "-E" : commonCppArgs -- preprocess only + ccArgs = "-c" : commonCcArgs -- don't try to link + findMissingLibs = + ifBuildsWith + [] + (makeLdArgs allLibs) + (return []) + (filterM (fmap not . libExists) allLibs) + + libExists lib = builds (makeProgram []) (makeLdArgs [lib]) + + baseDir lbi' = fromMaybe "." (takeDirectory <$> cabalFilePath lbi') + + commonCppArgs = + platformDefines lbi + -- TODO: This is a massive hack, to work around the + -- fact that the test performed here should be + -- PER-component (c.f. the "I'm Feeling Lucky"; we + -- should NOT be glomming everything together.) + ++ ["-I" ++ buildDir lbi "autogen"] + -- `configure' may generate headers in the build directory + ++ [ "-I" ++ buildDir lbi dir + | dir <- ordNub (collectField includeDirs) + , not (isAbsolute dir) + ] + -- we might also reference headers from the + -- packages directory. + ++ [ "-I" ++ baseDir lbi dir + | dir <- ordNub (collectField includeDirs) + , not (isAbsolute dir) + ] + ++ [ "-I" ++ dir | dir <- ordNub (collectField includeDirs), isAbsolute dir + ] + ++ ["-I" ++ baseDir lbi] + ++ collectField cppOptions + ++ collectField ccOptions + ++ [ "-I" ++ dir + | dir <- + ordNub + [ dir + | dep <- deps + , dir <- IPI.includeDirs dep + ] + -- dedupe include dirs of dependencies + -- to prevent quadratic blow-up + ] + ++ [ opt + | dep <- deps + , opt <- IPI.ccOptions dep + ] + + commonCcArgs = + commonCppArgs + ++ collectField ccOptions + ++ [ opt + | dep <- deps + , opt <- IPI.ccOptions dep + ] + + commonLdArgs = + [ "-L" ++ dir + | dir <- + ordNub $ + collectField + ( if withFullyStaticExe lbi + then extraLibDirsStatic + else extraLibDirs + ) + ] + ++ collectField ldOptions + ++ [ "-L" ++ dir + | dir <- + ordNub + [ dir + | dep <- deps + , dir <- + if withFullyStaticExe lbi + then IPI.libraryDirsStatic dep + else IPI.libraryDirs dep + ] + ] + -- TODO: do we also need dependent packages' ld options? + makeLdArgs libs = ["-l" ++ lib | lib <- libs] ++ commonLdArgs + + makeProgram hdrs = + unlines $ + ["#include \"" ++ hdr ++ "\"" | hdr <- hdrs] + ++ ["int main(int argc, char** argv) { return 0; }"] + + collectField f = concatMap f allBi + allBi = enabledBuildInfos pkg (componentEnabledSpec lbi) + deps = PackageIndex.topologicalOrder (installedPkgs lbi) + + builds program args = + do + tempDir <- getTemporaryDirectory + withTempFile tempDir ".c" $ \cName cHnd -> + withTempFile tempDir "" $ \oNname oHnd -> do + hPutStrLn cHnd program + hClose cHnd + hClose oHnd + _ <- + getDbProgramOutput + verbosity + gccProgram + (withPrograms lbi) + (cName : "-o" : oNname : args) + return True + `catchIO` (\_ -> return False) + `catchExit` (\_ -> return False) + + explainErrors Nothing [] = return () -- should be impossible! + explainErrors _ _ + | isNothing . lookupProgram gccProgram . withPrograms $ lbi = + die' verbosity $ + unlines + [ "No working gcc" + , "This package depends on foreign library but we cannot " + ++ "find a working C compiler. If you have it in a " + ++ "non-standard location you can use the --with-gcc " + ++ "flag to specify it." + ] + explainErrors hdr libs = + die' verbosity $ + unlines $ + [ if plural + then "Missing dependencies on foreign libraries:" + else "Missing dependency on a foreign library:" + | missing + ] + ++ case hdr of + Just (Left h) -> ["* Missing (or bad) header file: " ++ h] + _ -> [] + ++ case libs of + [] -> [] + [lib] -> ["* Missing (or bad) C library: " ++ lib] + _ -> + [ "* Missing (or bad) C libraries: " + ++ intercalate ", " libs + ] + ++ [if plural then messagePlural else messageSingular | missing] + ++ case hdr of + Just (Left _) -> [headerCppMessage] + Just (Right h) -> + [ (if missing then "* " else "") + ++ "Bad header file: " + ++ h + , headerCcMessage + ] + _ -> [] + where + plural = length libs >= 2 + -- Is there something missing? (as opposed to broken) + missing = + not (null libs) + || case hdr of Just (Left _) -> True; _ -> False + + messageSingular = + "This problem can usually be solved by installing the system " + ++ "package that provides this library (you may need the " + ++ "\"-dev\" version). If the library is already installed " + ++ "but in a non-standard location then you can use the flags " + ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " + ++ "where it is." + ++ "If the library file does exist, it may contain errors that " + ++ "are caught by the C compiler at the preprocessing stage. " + ++ "In this case you can re-run configure with the verbosity " + ++ "flag -v3 to see the error messages." + messagePlural = + "This problem can usually be solved by installing the system " + ++ "packages that provide these libraries (you may need the " + ++ "\"-dev\" versions). If the libraries are already installed " + ++ "but in a non-standard location then you can use the flags " + ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " + ++ "where they are." + ++ "If the library files do exist, it may contain errors that " + ++ "are caught by the C compiler at the preprocessing stage. " + ++ "In this case you can re-run configure with the verbosity " + ++ "flag -v3 to see the error messages." + headerCppMessage = + "If the header file does exist, it may contain errors that " + ++ "are caught by the C compiler at the preprocessing stage. " + ++ "In this case you can re-run configure with the verbosity " + ++ "flag -v3 to see the error messages." + headerCcMessage = + "The header file contains a compile error. " + ++ "You can re-run configure with the verbosity flag " + ++ "-v3 to see the error messages from the C compiler." -- | Output package check warnings and errors. Exit if any errors. -checkPackageProblems :: Verbosity - -> FilePath - -- ^ Path to the @.cabal@ file's directory - -> GenericPackageDescription - -> PackageDescription - -> IO () +checkPackageProblems + :: Verbosity + -> FilePath + -- ^ Path to the @.cabal@ file's directory + -> GenericPackageDescription + -> PackageDescription + -> IO () checkPackageProblems verbosity dir gpkg pkg = do - ioChecks <- checkPackageFiles verbosity pkg dir + ioChecks <- checkPackageFiles verbosity pkg dir let pureChecks = checkPackage gpkg (Just pkg) (errors, warnings) = partitionEithers (M.mapMaybe classEW $ pureChecks ++ ioChecks) @@ -1979,158 +2427,193 @@ checkPackageProblems verbosity dir gpkg pkg = do classEW (PackageDistInexcusable _) = Nothing -- | Preform checks if a relocatable build is allowed -checkRelocatable :: Verbosity - -> PackageDescription - -> LocalBuildInfo - -> IO () -checkRelocatable verbosity pkg lbi - = sequence_ [ checkOS - , checkCompiler - , packagePrefixRelative - , depsPrefixRelative - ] +checkRelocatable + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> IO () +checkRelocatable verbosity pkg lbi = + sequence_ + [ checkOS + , checkCompiler + , packagePrefixRelative + , depsPrefixRelative + ] where -- Check if the OS support relocatable builds. -- -- If you add new OS' to this list, and your OS supports dynamic libraries -- and RPATH, make sure you add your OS to RPATH-support list of: -- Distribution.Simple.GHC.getRPaths - checkOS - = unless (os `elem` [ OSX, Linux ]) - $ die' verbosity $ "Operating system: " ++ prettyShow os ++ - ", does not support relocatable builds" + checkOS = + unless (os `elem` [OSX, Linux]) $ + die' verbosity $ + "Operating system: " + ++ prettyShow os + ++ ", does not support relocatable builds" where (Platform _ os) = hostPlatform lbi -- Check if the Compiler support relocatable builds - checkCompiler - = unless (compilerFlavor comp `elem` [ GHC ]) - $ die' verbosity $ "Compiler: " ++ show comp ++ - ", does not support relocatable builds" + checkCompiler = + unless (compilerFlavor comp `elem` [GHC]) $ + die' verbosity $ + "Compiler: " + ++ show comp + ++ ", does not support relocatable builds" where comp = compiler lbi -- Check if all the install dirs are relative to same prefix - packagePrefixRelative - = unless (relativeInstallDirs installDirs) - $ die' verbosity $ "Installation directories are not prefix_relative:\n" ++ - show installDirs + packagePrefixRelative = + unless (relativeInstallDirs installDirs) $ + die' verbosity $ + "Installation directories are not prefix_relative:\n" + ++ show installDirs where -- NB: should be good enough to check this against the default -- component ID, but if we wanted to be strictly correct we'd -- check for each ComponentId. installDirs = absoluteInstallDirs pkg lbi NoCopyDest - p = prefix installDirs - relativeInstallDirs (InstallDirs {..}) = - all isJust - (fmap (stripPrefix p) - [ bindir, libdir, dynlibdir, libexecdir, includedir, datadir - , docdir, mandir, htmldir, haddockdir, sysconfdir] ) + p = prefix installDirs + relativeInstallDirs (InstallDirs{..}) = + all + isJust + ( fmap + (stripPrefix p) + [ bindir + , libdir + , dynlibdir + , libexecdir + , includedir + , datadir + , docdir + , mandir + , htmldir + , haddockdir + , sysconfdir + ] + ) -- Check if the library dirs of the dependencies that are in the package -- database to which the package is installed are relative to the -- prefix of the package depsPrefixRelative = do - pkgr <- GHC.pkgRoot verbosity lbi (registrationPackageDB (withPackageDB lbi)) - traverse_ (doCheck pkgr) ipkgs + pkgr <- GHC.pkgRoot verbosity lbi (registrationPackageDB (withPackageDB lbi)) + traverse_ (doCheck pkgr) ipkgs where doCheck pkgr ipkg - | maybe False (== pkgr) (IPI.pkgRoot ipkg) - = for_ (IPI.libraryDirs ipkg) $ \libdir -> do - -- When @prefix@ is not under @pkgroot@, - -- @shortRelativePath prefix pkgroot@ will return a path with - -- @..@s and following check will fail without @canonicalizePath@. - canonicalized <- canonicalizePath libdir - unless (p `isPrefixOf` canonicalized) $ - die' verbosity $ msg libdir - | otherwise - = return () + | maybe False (== pkgr) (IPI.pkgRoot ipkg) = + for_ (IPI.libraryDirs ipkg) $ \libdir -> do + -- When @prefix@ is not under @pkgroot@, + -- @shortRelativePath prefix pkgroot@ will return a path with + -- @..@s and following check will fail without @canonicalizePath@. + canonicalized <- canonicalizePath libdir + unless (p `isPrefixOf` canonicalized) $ + die' verbosity $ + msg libdir + | otherwise = + return () -- NB: should be good enough to check this against the default -- component ID, but if we wanted to be strictly correct we'd -- check for each ComponentId. - installDirs = absoluteInstallDirs pkg lbi NoCopyDest - p = prefix installDirs - ipkgs = PackageIndex.allPackages (installedPkgs lbi) - msg l = "Library directory of a dependency: " ++ show l ++ - "\nis not relative to the installation prefix:\n" ++ - show p + installDirs = absoluteInstallDirs pkg lbi NoCopyDest + p = prefix installDirs + ipkgs = PackageIndex.allPackages (installedPkgs lbi) + msg l = + "Library directory of a dependency: " + ++ show l + ++ "\nis not relative to the installation prefix:\n" + ++ show p -- ----------------------------------------------------------------------------- -- Testing foreign library requirements unsupportedForeignLibs :: Compiler -> Platform -> [ForeignLib] -> [String] unsupportedForeignLibs comp platform = - mapMaybe (checkForeignLibSupported comp platform) + mapMaybe (checkForeignLibSupported comp platform) checkForeignLibSupported :: Compiler -> Platform -> ForeignLib -> Maybe String checkForeignLibSupported comp platform flib = go (compilerFlavor comp) where go :: CompilerFlavor -> Maybe String go GHC - | compilerVersion comp < mkVersion [7,8] = unsupported [ - "Building foreign libraries is only supported with GHC >= 7.8" - ] + | compilerVersion comp < mkVersion [7, 8] = + unsupported + [ "Building foreign libraries is only supported with GHC >= 7.8" + ] | otherwise = goGhcPlatform platform - go _ = unsupported [ - "Building foreign libraries is currently only supported with ghc" - ] + go _ = + unsupported + [ "Building foreign libraries is currently only supported with ghc" + ] goGhcPlatform :: Platform -> Maybe String - goGhcPlatform (Platform _ OSX ) = goGhcOsx (foreignLibType flib) - goGhcPlatform (Platform _ Linux ) = goGhcLinux (foreignLibType flib) - goGhcPlatform (Platform I386 Windows) = goGhcWindows (foreignLibType flib) + goGhcPlatform (Platform _ OSX) = goGhcOsx (foreignLibType flib) + goGhcPlatform (Platform _ Linux) = goGhcLinux (foreignLibType flib) + goGhcPlatform (Platform I386 Windows) = goGhcWindows (foreignLibType flib) goGhcPlatform (Platform X86_64 Windows) = goGhcWindows (foreignLibType flib) - goGhcPlatform _ = unsupported [ - "Building foreign libraries is currently only supported on Mac OS, " - , "Linux and Windows" - ] + goGhcPlatform _ = + unsupported + [ "Building foreign libraries is currently only supported on Mac OS, " + , "Linux and Windows" + ] goGhcOsx :: ForeignLibType -> Maybe String goGhcOsx ForeignLibNativeShared - | not (null (foreignLibModDefFile flib)) = unsupported [ - "Module definition file not supported on OSX" - ] - | not (null (foreignLibVersionInfo flib)) = unsupported [ - "Foreign library versioning not currently supported on OSX" - ] + | not (null (foreignLibModDefFile flib)) = + unsupported + [ "Module definition file not supported on OSX" + ] + | not (null (foreignLibVersionInfo flib)) = + unsupported + [ "Foreign library versioning not currently supported on OSX" + ] | otherwise = Nothing - goGhcOsx _ = unsupported [ - "We can currently only build shared foreign libraries on OSX" - ] + goGhcOsx _ = + unsupported + [ "We can currently only build shared foreign libraries on OSX" + ] goGhcLinux :: ForeignLibType -> Maybe String goGhcLinux ForeignLibNativeShared - | not (null (foreignLibModDefFile flib)) = unsupported [ - "Module definition file not supported on Linux" - ] + | not (null (foreignLibModDefFile flib)) = + unsupported + [ "Module definition file not supported on Linux" + ] | not (null (foreignLibVersionInfo flib)) - && not (null (foreignLibVersionLinux flib)) = unsupported [ - "You must not specify both lib-version-info and lib-version-linux" - ] + && not (null (foreignLibVersionLinux flib)) = + unsupported + [ "You must not specify both lib-version-info and lib-version-linux" + ] | otherwise = Nothing - goGhcLinux _ = unsupported [ - "We can currently only build shared foreign libraries on Linux" - ] + goGhcLinux _ = + unsupported + [ "We can currently only build shared foreign libraries on Linux" + ] goGhcWindows :: ForeignLibType -> Maybe String goGhcWindows ForeignLibNativeShared - | not standalone = unsupported [ - "We can currently only build standalone libraries on Windows. Use\n" - , " if os(Windows)\n" - , " options: standalone\n" - , "in your foreign-library stanza." - ] - | not (null (foreignLibVersionInfo flib)) = unsupported [ - "Foreign library versioning not currently supported on Windows.\n" - , "You can specify module definition files in the mod-def-file field." - ] + | not standalone = + unsupported + [ "We can currently only build standalone libraries on Windows. Use\n" + , " if os(Windows)\n" + , " options: standalone\n" + , "in your foreign-library stanza." + ] + | not (null (foreignLibVersionInfo flib)) = + unsupported + [ "Foreign library versioning not currently supported on Windows.\n" + , "You can specify module definition files in the mod-def-file field." + ] | otherwise = - Nothing - goGhcWindows _ = unsupported [ - "We can currently only build shared foreign libraries on Windows" - ] + Nothing + goGhcWindows _ = + unsupported + [ "We can currently only build shared foreign libraries on Windows" + ] standalone :: Bool standalone = ForeignLibStandalone `elem` foreignLibOptions flib diff --git a/Cabal/src/Distribution/Simple/ConfigureScript.hs b/Cabal/src/Distribution/Simple/ConfigureScript.hs index 23ad94f0d75..a97e9dbed46 100644 --- a/Cabal/src/Distribution/Simple/ConfigureScript.hs +++ b/Cabal/src/Distribution/Simple/ConfigureScript.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -fno-warn-deprecations #-} + -- | -- Module : Distribution.Simple.ConfigureScript -- Copyright : Isaac Jones 2003-2005 @@ -11,15 +13,12 @@ -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable --- -{-# OPTIONS_GHC -fno-warn-deprecations #-} - -module Distribution.Simple.ConfigureScript ( - runConfigureScript +module Distribution.Simple.ConfigureScript + ( runConfigureScript ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -- local import Distribution.PackageDescription @@ -28,28 +27,36 @@ import Distribution.Simple.Program.Db import Distribution.Simple.Setup.Common import Distribution.Simple.Setup.Config +import Distribution.Pretty import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Utils +import Distribution.System (buildPlatform) import Distribution.Utils.NubList import Distribution.Verbosity -import Distribution.Pretty -import Distribution.System (buildPlatform) -- Base -import System.FilePath (searchPathSeparator, takeDirectory, (), - splitDirectories, dropDrive) +import System.FilePath + ( dropDrive + , searchPathSeparator + , splitDirectories + , takeDirectory + , () + ) #ifdef mingw32_HOST_OS import System.FilePath (normalise, splitDrive) #endif -import Distribution.Compat.Directory (makeAbsolute) -import Distribution.Compat.Environment (getEnvironment) +import Distribution.Compat.Directory (makeAbsolute) +import Distribution.Compat.Environment (getEnvironment) import Distribution.Compat.GetShortPathName (getShortPathName) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map -runConfigureScript :: Verbosity -> ConfigFlags -> LocalBuildInfo - -> IO () +runConfigureScript + :: Verbosity + -> ConfigFlags + -> LocalBuildInfo + -> IO () runConfigureScript verbosity flags lbi = do env <- getEnvironment let programDb = withPrograms lbi @@ -61,8 +68,9 @@ runConfigureScript verbosity flags lbi = do -- to ccFlags -- We don't try and tell configure which ld to use, as we don't have -- a way to pass its flags too - configureFile <- makeAbsolute $ - fromMaybe "." (takeDirectory <$> cabalFilePath lbi) "configure" + configureFile <- + makeAbsolute $ + fromMaybe "." (takeDirectory <$> cabalFilePath lbi) "configure" -- autoconf is fussy about filenames, and has a set of forbidden -- characters that can't appear in the build directory, etc: -- https://www.gnu.org/software/autoconf/manual/autoconf.html#File-System-Conventions @@ -79,30 +87,40 @@ runConfigureScript verbosity flags lbi = do let configureFile' = toUnix configureFile for_ badAutoconfCharacters $ \(c, cname) -> when (c `elem` dropDrive configureFile') $ - warn verbosity $ concat - [ "The path to the './configure' script, '", configureFile' - , "', contains the character '", [c], "' (", cname, ")." - , " This may cause the script to fail with an obscure error, or for" - , " building the package to fail later." - ] + warn verbosity $ + concat + [ "The path to the './configure' script, '" + , configureFile' + , "', contains the character '" + , [c] + , "' (" + , cname + , ")." + , " This may cause the script to fail with an obscure error, or for" + , " building the package to fail later." + ] - let -- Convert a flag name to name of environment variable to represent its - -- value for the configure script. - flagEnvVar :: FlagName -> String - flagEnvVar flag = "CABAL_FLAG_" ++ map f (unFlagName flag) - where f c - | isAlphaNum c = c - | otherwise = '_' - -- A map from such env vars to every flag name and value where the name - -- name maps to that that env var. - cabalFlagMap :: Map String (NonEmpty (FlagName, Bool)) - cabalFlagMap = Map.fromListWith (<>) - [ (flagEnvVar flag, (flag, bool) :| []) - | (flag, bool) <- unFlagAssignment $ flagAssignment lbi - ] + let + -- Convert a flag name to name of environment variable to represent its + -- value for the configure script. + flagEnvVar :: FlagName -> String + flagEnvVar flag = "CABAL_FLAG_" ++ map f (unFlagName flag) + where + f c + | isAlphaNum c = c + | otherwise = '_' + -- A map from such env vars to every flag name and value where the name + -- name maps to that that env var. + cabalFlagMap :: Map String (NonEmpty (FlagName, Bool)) + cabalFlagMap = + Map.fromListWith + (<>) + [ (flagEnvVar flag, (flag, bool) :| []) + | (flag, bool) <- unFlagAssignment $ flagAssignment lbi + ] -- A map from env vars to flag names to the single flag we will go with cabalFlagMapDeconflicted :: Map String (FlagName, Bool) <- - flip Map.traverseWithKey cabalFlagMap $ \ envVar -> \case + flip Map.traverseWithKey cabalFlagMap $ \envVar -> \case -- No conflict: no problem singleFlag :| [] -> pure singleFlag -- Conflict: warn and discard all but first @@ -110,52 +128,71 @@ runConfigureScript verbosity flags lbi = do let quote s = "'" ++ s ++ "'" toName = quote . unFlagName . fst renderedList = intercalate ", " $ NonEmpty.toList $ toName <$> collidingFlags - warn verbosity $ unwords - [ "Flags", renderedList, "all map to the same environment variable" - , quote envVar, "causing a collision." - , "The value first flag", toName firstFlag, "will be used." - ] + warn verbosity $ + unwords + [ "Flags" + , renderedList + , "all map to the same environment variable" + , quote envVar + , "causing a collision." + , "The value first flag" + , toName firstFlag + , "will be used." + ] pure firstFlag - let cabalFlagEnv = [ (envVar, Just val) - | (envVar, (_, bool)) <- Map.toList cabalFlagMapDeconflicted - , let val = if bool then "1" else "0" - ] ++ - [ ( "CABAL_FLAGS" - , Just $ unwords [ showFlagValue fv | fv <- unFlagAssignment $ flagAssignment lbi ] - ) - ] + let cabalFlagEnv = + [ (envVar, Just val) + | (envVar, (_, bool)) <- Map.toList cabalFlagMapDeconflicted + , let val = if bool then "1" else "0" + ] + ++ [ + ( "CABAL_FLAGS" + , Just $ unwords [showFlagValue fv | fv <- unFlagAssignment $ flagAssignment lbi] + ) + ] let extraPath = fromNubList $ configProgramPathExtra flags - let cflagsEnv = maybe (unwords ccFlags) (++ (" " ++ unwords ccFlags)) - $ lookup "CFLAGS" env + let cflagsEnv = + maybe (unwords ccFlags) (++ (" " ++ unwords ccFlags)) $ + lookup "CFLAGS" env spSep = [searchPathSeparator] - pathEnv = maybe (intercalate spSep extraPath) - ((intercalate spSep extraPath ++ spSep)++) $ lookup "PATH" env - overEnv = ("CFLAGS", Just cflagsEnv) : - [("PATH", Just pathEnv) | not (null extraPath)] ++ - cabalFlagEnv + pathEnv = + maybe + (intercalate spSep extraPath) + ((intercalate spSep extraPath ++ spSep) ++) + $ lookup "PATH" env + overEnv = + ("CFLAGS", Just cflagsEnv) + : [("PATH", Just pathEnv) | not (null extraPath)] + ++ cabalFlagEnv hp = hostPlatform lbi maybeHostFlag = if hp == buildPlatform then [] else ["--host=" ++ show (pretty hp)] - args' = configureFile':args ++ ["CC=" ++ ccProgShort] ++ maybeHostFlag + args' = configureFile' : args ++ ["CC=" ++ ccProgShort] ++ maybeHostFlag shProg = simpleProgram "sh" - progDb = modifyProgramSearchPath - (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb - shConfiguredProg <- lookupProgram shProg - `fmap` configureProgram verbosity shProg progDb + progDb = + modifyProgramSearchPath + (\p -> map ProgramSearchPathDir extraPath ++ p) + emptyProgramDb + shConfiguredProg <- + lookupProgram shProg + `fmap` configureProgram verbosity shProg progDb case shConfiguredProg of - Just sh -> runProgramInvocation verbosity $ - (programInvocation (sh {programOverrideEnv = overEnv}) args') - { progInvokeCwd = Just (buildDir lbi) } - Nothing -> die' verbosity notFoundMsg + Just sh -> + runProgramInvocation verbosity $ + (programInvocation (sh{programOverrideEnv = overEnv}) args') + { progInvokeCwd = Just (buildDir lbi) + } + Nothing -> die' verbosity notFoundMsg where args = configureArgs backwardsCompatHack flags backwardsCompatHack = False - notFoundMsg = "The package has a './configure' script. " - ++ "If you are on Windows, This requires a " - ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin. " - ++ "If you are not on Windows, ensure that an 'sh' command " - ++ "is discoverable in your path." + notFoundMsg = + "The package has a './configure' script. " + ++ "If you are on Windows, This requires a " + ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin. " + ++ "If you are not on Windows, ensure that an 'sh' command " + ++ "is discoverable in your path." -- | Convert Windows path to Unix ones toUnix :: String -> String diff --git a/Cabal/src/Distribution/Simple/Flag.hs b/Cabal/src/Distribution/Simple/Flag.hs index 705be2eb557..aa35c904c4f 100644 --- a/Cabal/src/Distribution/Simple/Flag.hs +++ b/Cabal/src/Distribution/Simple/Flag.hs @@ -2,7 +2,9 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Flag -- Copyright : Isaac Jones 2003-2004 @@ -17,24 +19,27 @@ -- for an explanation. -- -- Split off from "Distribution.Simple.Setup" to break import cycles. -module Distribution.Simple.Flag ( - Flag(..), - allFlags, - toFlag, - fromFlag, - fromFlagOrDefault, - flagElim, - flagToMaybe, - flagToList, - maybeToFlag, - BooleanFlag(..) ) where +module Distribution.Simple.Flag + ( Flag (..) + , allFlags + , toFlag + , fromFlag + , fromFlagOrDefault + , flagElim + , flagToMaybe + , flagToList + , maybeToFlag + , BooleanFlag (..) + ) where -import Prelude () import Distribution.Compat.Prelude hiding (get) import Distribution.Compat.Stack +import Prelude () -- ------------------------------------------------------------ + -- * Flag type + -- ------------------------------------------------------------ -- | All flags are monoids, they come in two flavours: @@ -53,7 +58,6 @@ import Distribution.Compat.Stack -- So this Flag type is for the latter singular kind of flag. -- Its monoid instance gives us the behaviour where it starts out as -- 'NoFlag' and later flags override earlier ones. --- data Flag a = Flag a | NoFlag deriving (Eq, Generic, Show, Read, Typeable, Foldable, Traversable) instance Binary a => Binary (Flag a) @@ -61,11 +65,11 @@ instance Structured a => Structured (Flag a) instance Functor Flag where fmap f (Flag x) = Flag (f x) - fmap _ NoFlag = NoFlag + fmap _ NoFlag = NoFlag instance Applicative Flag where (Flag x) <*> y = x <$> y - NoFlag <*> _ = NoFlag + NoFlag <*> _ = NoFlag pure = Flag instance Monoid (Flag a) where @@ -74,7 +78,7 @@ instance Monoid (Flag a) where instance Semigroup (Flag a) where _ <> f@(Flag _) = f - f <> NoFlag = f + f <> NoFlag = f instance Bounded a => Bounded (Flag a) where minBound = toFlag minBound @@ -82,52 +86,53 @@ instance Bounded a => Bounded (Flag a) where instance Enum a => Enum (Flag a) where fromEnum = fromEnum . fromFlag - toEnum = toFlag . toEnum + toEnum = toFlag . toEnum enumFrom (Flag a) = map toFlag . enumFrom $ a - enumFrom _ = [] + enumFrom _ = [] enumFromThen (Flag a) (Flag b) = toFlag `map` enumFromThen a b - enumFromThen _ _ = [] - enumFromTo (Flag a) (Flag b) = toFlag `map` enumFromTo a b - enumFromTo _ _ = [] + enumFromThen _ _ = [] + enumFromTo (Flag a) (Flag b) = toFlag `map` enumFromTo a b + enumFromTo _ _ = [] enumFromThenTo (Flag a) (Flag b) (Flag c) = toFlag `map` enumFromThenTo a b c - enumFromThenTo _ _ _ = [] + enumFromThenTo _ _ _ = [] toFlag :: a -> Flag a toFlag = Flag fromFlag :: WithCallStack (Flag a -> a) fromFlag (Flag x) = x -fromFlag NoFlag = error "fromFlag NoFlag. Use fromFlagOrDefault" +fromFlag NoFlag = error "fromFlag NoFlag. Use fromFlagOrDefault" fromFlagOrDefault :: a -> Flag a -> a -fromFlagOrDefault _ (Flag x) = x -fromFlagOrDefault def NoFlag = def +fromFlagOrDefault _ (Flag x) = x +fromFlagOrDefault def NoFlag = def flagToMaybe :: Flag a -> Maybe a flagToMaybe (Flag x) = Just x -flagToMaybe NoFlag = Nothing +flagToMaybe NoFlag = Nothing -- | @since 3.4.0.0 flagElim :: b -> (a -> b) -> Flag a -> b -flagElim n _ NoFlag = n +flagElim n _ NoFlag = n flagElim _ f (Flag x) = f x flagToList :: Flag a -> [a] flagToList (Flag x) = [x] -flagToList NoFlag = [] +flagToList NoFlag = [] allFlags :: [Flag Bool] -> Flag Bool -allFlags flags = if all (\f -> fromFlagOrDefault False f) flags - then Flag True - else NoFlag +allFlags flags = + if all (\f -> fromFlagOrDefault False f) flags + then Flag True + else NoFlag maybeToFlag :: Maybe a -> Flag a -maybeToFlag Nothing = NoFlag +maybeToFlag Nothing = NoFlag maybeToFlag (Just x) = Flag x -- | Types that represent boolean flags. class BooleanFlag a where - asBool :: a -> Bool + asBool :: a -> Bool instance BooleanFlag Bool where asBool = id diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs index 57102bfbdb6..9676cc27487 100644 --- a/Cabal/src/Distribution/Simple/GHC.hs +++ b/Cabal/src/Distribution/Simple/GHC.hs @@ -1,10 +1,11 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.GHC -- Copyright : Isaac Jones 2003-2007 @@ -35,93 +36,111 @@ -- remembering the layout of files in the build directory (which is not -- explicitly documented) and thus what search dirs are used for various kinds -- of files. +module Distribution.Simple.GHC + ( getGhcInfo + , configure + , getInstalledPackages + , getInstalledPackagesMonitorFiles + , getPackageDBContents + , buildLib + , buildFLib + , buildExe + , replLib + , replFLib + , replExe + , startInterpreter + , installLib + , installFLib + , installExe + , libAbiHash + , hcPkgInfo + , registerPackage + , componentGhcOptions + , componentCcGhcOptions + , getGhcAppDir + , getLibDir + , isDynamic + , getGlobalPackageDB + , pkgRoot + + -- * Constructing and deconstructing GHC environment files + , Internal.GhcEnvironmentFileEntry (..) + , Internal.simpleGhcEnvironmentFile + , Internal.renderGhcEnvironmentFile + , Internal.writeGhcEnvironmentFile + , Internal.ghcPlatformAndVersionString + , readGhcEnvironmentFile + , parseGhcEnvironmentFile + , ParseErrorExc (..) + + -- * Version-specific implementation quirks + , getImplInfo + , GhcImplInfo (..) + ) where -module Distribution.Simple.GHC ( - getGhcInfo, - configure, - getInstalledPackages, - getInstalledPackagesMonitorFiles, - getPackageDBContents, - buildLib, buildFLib, buildExe, - replLib, replFLib, replExe, - startInterpreter, - installLib, installFLib, installExe, - libAbiHash, - hcPkgInfo, - registerPackage, - componentGhcOptions, - componentCcGhcOptions, - getGhcAppDir, - getLibDir, - isDynamic, - getGlobalPackageDB, - pkgRoot, - -- * Constructing and deconstructing GHC environment files - Internal.GhcEnvironmentFileEntry(..), - Internal.simpleGhcEnvironmentFile, - Internal.renderGhcEnvironmentFile, - Internal.writeGhcEnvironmentFile, - Internal.ghcPlatformAndVersionString, - readGhcEnvironmentFile, - parseGhcEnvironmentFile, - ParseErrorExc(..), - -- * Version-specific implementation quirks - getImplInfo, - GhcImplInfo(..) - ) where - -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import qualified Distribution.Simple.GHC.Internal as Internal import Distribution.CabalSpecVersion -import Distribution.Simple.GHC.ImplInfo -import Distribution.Simple.GHC.EnvironmentParser -import Distribution.PackageDescription.Utils (cabalBug) -import Distribution.PackageDescription as PD import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Package +import Distribution.PackageDescription as PD +import Distribution.PackageDescription.Utils (cabalBug) +import Distribution.Pretty +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler +import Distribution.Simple.Flag (Flag (Flag), fromFlag, fromFlagOrDefault, toFlag) +import Distribution.Simple.GHC.EnvironmentParser +import Distribution.Simple.GHC.ImplInfo +import qualified Distribution.Simple.GHC.Internal as Internal +import qualified Distribution.Simple.Hpc as Hpc +import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.LocalBuildInfo -import Distribution.Types.ComponentLocalBuildInfo -import qualified Distribution.Simple.Hpc as Hpc -import Distribution.Simple.BuildPaths -import Distribution.Simple.Utils -import Distribution.Package -import qualified Distribution.ModuleName as ModuleName -import Distribution.ModuleName (ModuleName) import Distribution.Simple.Program +import qualified Distribution.Simple.Program.Ar as Ar import Distribution.Simple.Program.Builtin (runghcProgram) +import Distribution.Simple.Program.GHC import qualified Distribution.Simple.Program.HcPkg as HcPkg -import qualified Distribution.Simple.Program.Ar as Ar -import qualified Distribution.Simple.Program.Ld as Ld +import qualified Distribution.Simple.Program.Ld as Ld import qualified Distribution.Simple.Program.Strip as Strip -import Distribution.Simple.Program.GHC -import Distribution.Simple.Flag ( Flag(Flag), fromFlag, fromFlagOrDefault, toFlag ) import Distribution.Simple.Setup.Config import Distribution.Simple.Setup.Repl -import Distribution.Simple.Compiler -import Distribution.Version +import Distribution.Simple.Utils import Distribution.System +import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.PackageName.Magic -import Distribution.Verbosity -import Distribution.Pretty import Distribution.Utils.NubList import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version import Language.Haskell.Extension -import Control.Monad (msum, forM_) +import Control.Monad (forM_, msum) import Data.Char (isLower) import qualified Data.Map as Map import System.Directory - ( doesFileExist, doesDirectoryExist - , getAppUserDataDirectory, createDirectoryIfMissing - , canonicalizePath, removeFile, renameFile, getDirectoryContents - , makeRelativeToCurrentDirectory, doesDirectoryExist ) -import System.FilePath ( (), (<.>), takeExtension - , takeDirectory, replaceExtension - ,isRelative ) + ( canonicalizePath + , createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , getAppUserDataDirectory + , getDirectoryContents + , makeRelativeToCurrentDirectory + , removeFile + , renameFile + ) +import System.FilePath + ( isRelative + , replaceExtension + , takeDirectory + , takeExtension + , (<.>) + , () + ) import qualified System.Info #ifndef mingw32_HOST_OS import System.Posix (createSymbolicLink) @@ -130,86 +149,112 @@ import System.Posix (createSymbolicLink) -- ----------------------------------------------------------------------------- -- Configuring -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramDb - -> IO (Compiler, Maybe Platform, ProgramDb) +configure + :: Verbosity + -> Maybe FilePath + -> Maybe FilePath + -> ProgramDb + -> IO (Compiler, Maybe Platform, ProgramDb) configure verbosity hcPath hcPkgPath conf0 = do - (ghcProg, ghcVersion, progdb1) <- - requireProgramVersion verbosity ghcProgram - (orLaterVersion (mkVersion [7,0,1])) + requireProgramVersion + verbosity + ghcProgram + (orLaterVersion (mkVersion [7, 0, 1])) (userMaybeSpecifyPath "ghc" hcPath conf0) let implInfo = ghcVersionImplInfo ghcVersion -- Cabal currently supports ghc >= 7.0.1 && < 9.8 -- ... and the following odd development version - unless (ghcVersion < mkVersion [9,8]) $ + unless (ghcVersion < mkVersion [9, 8]) $ warn verbosity $ - "Unknown/unsupported 'ghc' version detected " - ++ "(Cabal " ++ prettyShow cabalVersion ++ " supports 'ghc' version < 9.8): " - ++ programPath ghcProg ++ " is version " ++ prettyShow ghcVersion + "Unknown/unsupported 'ghc' version detected " + ++ "(Cabal " + ++ prettyShow cabalVersion + ++ " supports 'ghc' version < 9.8): " + ++ programPath ghcProg + ++ " is version " + ++ prettyShow ghcVersion -- This is slightly tricky, we have to configure ghc first, then we use the -- location of ghc to help find ghc-pkg in the case that the user did not -- specify the location of ghc-pkg directly: (ghcPkgProg, ghcPkgVersion, progdb2) <- - requireProgramVersion verbosity ghcPkgProgram { - programFindLocation = guessGhcPkgFromGhcPath ghcProg - } - anyVersion (userMaybeSpecifyPath "ghc-pkg" hcPkgPath progdb1) - - when (ghcVersion /= ghcPkgVersion) $ die' verbosity $ - "Version mismatch between ghc and ghc-pkg: " - ++ programPath ghcProg ++ " is version " ++ prettyShow ghcVersion ++ " " - ++ programPath ghcPkgProg ++ " is version " ++ prettyShow ghcPkgVersion + requireProgramVersion + verbosity + ghcPkgProgram + { programFindLocation = guessGhcPkgFromGhcPath ghcProg + } + anyVersion + (userMaybeSpecifyPath "ghc-pkg" hcPkgPath progdb1) + + when (ghcVersion /= ghcPkgVersion) $ + die' verbosity $ + "Version mismatch between ghc and ghc-pkg: " + ++ programPath ghcProg + ++ " is version " + ++ prettyShow ghcVersion + ++ " " + ++ programPath ghcPkgProg + ++ " is version " + ++ prettyShow ghcPkgVersion -- Likewise we try to find the matching hsc2hs and haddock programs. - let hsc2hsProgram' = hsc2hsProgram { - programFindLocation = guessHsc2hsFromGhcPath ghcProg - } - haddockProgram' = haddockProgram { - programFindLocation = guessHaddockFromGhcPath ghcProg - } - hpcProgram' = hpcProgram { - programFindLocation = guessHpcFromGhcPath ghcProg - } - runghcProgram' = runghcProgram { - programFindLocation = guessRunghcFromGhcPath ghcProg - } - progdb3 = addKnownProgram haddockProgram' $ - addKnownProgram hsc2hsProgram' $ - addKnownProgram hpcProgram' $ + let hsc2hsProgram' = + hsc2hsProgram + { programFindLocation = guessHsc2hsFromGhcPath ghcProg + } + haddockProgram' = + haddockProgram + { programFindLocation = guessHaddockFromGhcPath ghcProg + } + hpcProgram' = + hpcProgram + { programFindLocation = guessHpcFromGhcPath ghcProg + } + runghcProgram' = + runghcProgram + { programFindLocation = guessRunghcFromGhcPath ghcProg + } + progdb3 = + addKnownProgram haddockProgram' $ + addKnownProgram hsc2hsProgram' $ + addKnownProgram hpcProgram' $ addKnownProgram runghcProgram' progdb2 - languages <- Internal.getLanguages verbosity implInfo ghcProg + languages <- Internal.getLanguages verbosity implInfo ghcProg extensions0 <- Internal.getExtensions verbosity implInfo ghcProg ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcProg let ghcInfoMap = Map.fromList ghcInfo - extensions = -- workaround https://gitlab.haskell.org/ghc/ghc/-/issues/11214 - filterExt JavaScriptFFI $ - -- see 'filterExtTH' comment below - filterExtTH $ extensions0 + extensions = + -- workaround https://gitlab.haskell.org/ghc/ghc/-/issues/11214 + filterExt JavaScriptFFI $ + -- see 'filterExtTH' comment below + filterExtTH $ + extensions0 -- starting with GHC 8.0, `TemplateHaskell` will be omitted from -- `--supported-extensions` when it's not available. -- for older GHCs we can use the "Have interpreter" property to -- filter out `TemplateHaskell` - filterExtTH | ghcVersion < mkVersion [8] - , Just "NO" <- Map.lookup "Have interpreter" ghcInfoMap - = filterExt TemplateHaskell - | otherwise = id + filterExtTH + | ghcVersion < mkVersion [8] + , Just "NO" <- Map.lookup "Have interpreter" ghcInfoMap = + filterExt TemplateHaskell + | otherwise = id filterExt ext = filter ((/= EnableExtension ext) . fst) - let comp = Compiler { - compilerId = CompilerId GHC ghcVersion, - compilerAbiTag = NoAbiTag, - compilerCompat = [], - compilerLanguages = languages, - compilerExtensions = extensions, - compilerProperties = ghcInfoMap - } + let comp = + Compiler + { compilerId = CompilerId GHC ghcVersion + , compilerAbiTag = NoAbiTag + , compilerCompat = [] + , compilerLanguages = languages + , compilerExtensions = extensions + , compilerProperties = ghcInfoMap + } compPlatform = Internal.targetPlatform ghcInfo -- configure gcc and ld progdb4 = Internal.configureToolchain implInfo ghcProg ghcInfoMap progdb3 @@ -222,52 +267,69 @@ configure verbosity hcPath hcPkgPath conf0 = do -- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe) -- > /usr/local/bin/ghc-pkg-6.6.1(.exe) -- > /usr/local/bin/ghc-pkg(.exe) --- -guessToolFromGhcPath :: Program -> ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessToolFromGhcPath tool ghcProg verbosity searchpath - = do let toolname = programName tool - given_path = programPath ghcProg - given_dir = takeDirectory given_path - real_path <- canonicalizePath given_path - let real_dir = takeDirectory real_path - versionSuffix path = takeVersionSuffix (dropExeExtension path) - given_suf = versionSuffix given_path - real_suf = versionSuffix real_path - guessNormal dir = dir toolname <.> exeExtension buildPlatform - guessGhcVersioned dir suf = dir (toolname ++ "-ghc" ++ suf) - <.> exeExtension buildPlatform - guessVersioned dir suf = dir (toolname ++ suf) - <.> exeExtension buildPlatform - mkGuesses dir suf | null suf = [guessNormal dir] - | otherwise = [guessGhcVersioned dir suf, - guessVersioned dir suf, - guessNormal dir] - -- order matters here, see https://github.com/haskell/cabal/issues/7390 - guesses = (if real_path == given_path - then [] - else mkGuesses real_dir real_suf) - ++ mkGuesses given_dir given_suf - info verbosity $ "looking for tool " ++ toolname - ++ " near compiler in " ++ given_dir - debug verbosity $ "candidate locations: " ++ show guesses - exists <- traverse doesFileExist guesses - case [ file | (file, True) <- zip guesses exists ] of - -- If we can't find it near ghc, fall back to the usual - -- method. - [] -> programFindLocation tool verbosity searchpath - (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp - let lookedAt = map fst - . takeWhile (\(_file, exist) -> not exist) - $ zip guesses exists - return (Just (fp, lookedAt)) - - where takeVersionSuffix :: FilePath -> String - takeVersionSuffix = takeWhileEndLE isSuffixChar - - isSuffixChar :: Char -> Bool - isSuffixChar c = isDigit c || c == '.' || c == '-' +guessToolFromGhcPath + :: Program + -> ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessToolFromGhcPath tool ghcProg verbosity searchpath = + do + let toolname = programName tool + given_path = programPath ghcProg + given_dir = takeDirectory given_path + real_path <- canonicalizePath given_path + let real_dir = takeDirectory real_path + versionSuffix path = takeVersionSuffix (dropExeExtension path) + given_suf = versionSuffix given_path + real_suf = versionSuffix real_path + guessNormal dir = dir toolname <.> exeExtension buildPlatform + guessGhcVersioned dir suf = + dir + (toolname ++ "-ghc" ++ suf) + <.> exeExtension buildPlatform + guessVersioned dir suf = + dir + (toolname ++ suf) + <.> exeExtension buildPlatform + mkGuesses dir suf + | null suf = [guessNormal dir] + | otherwise = + [ guessGhcVersioned dir suf + , guessVersioned dir suf + , guessNormal dir + ] + -- order matters here, see https://github.com/haskell/cabal/issues/7390 + guesses = + ( if real_path == given_path + then [] + else mkGuesses real_dir real_suf + ) + ++ mkGuesses given_dir given_suf + info verbosity $ + "looking for tool " + ++ toolname + ++ " near compiler in " + ++ given_dir + debug verbosity $ "candidate locations: " ++ show guesses + exists <- traverse doesFileExist guesses + case [file | (file, True) <- zip guesses exists] of + -- If we can't find it near ghc, fall back to the usual + -- method. + [] -> programFindLocation tool verbosity searchpath + (fp : _) -> do + info verbosity $ "found " ++ toolname ++ " in " ++ fp + let lookedAt = + map fst + . takeWhile (\(_file, exist) -> not exist) + $ zip guesses exists + return (Just (fp, lookedAt)) + where + takeVersionSuffix :: FilePath -> String + takeVersionSuffix = takeWhileEndLE isSuffixChar + + isSuffixChar :: Char -> Bool + isSuffixChar c = isDigit c || c == '.' || c == '-' -- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a -- corresponding ghc-pkg, we try looking for both a versioned and unversioned @@ -276,10 +338,11 @@ guessToolFromGhcPath tool ghcProg verbosity searchpath -- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe) -- > /usr/local/bin/ghc-pkg-6.6.1(.exe) -- > /usr/local/bin/ghc-pkg(.exe) --- -guessGhcPkgFromGhcPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) +guessGhcPkgFromGhcPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) guessGhcPkgFromGhcPath = guessToolFromGhcPath ghcPkgProgram -- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a @@ -289,10 +352,11 @@ guessGhcPkgFromGhcPath = guessToolFromGhcPath ghcPkgProgram -- > /usr/local/bin/hsc2hs-ghc-6.6.1(.exe) -- > /usr/local/bin/hsc2hs-6.6.1(.exe) -- > /usr/local/bin/hsc2hs(.exe) --- -guessHsc2hsFromGhcPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) +guessHsc2hsFromGhcPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) guessHsc2hsFromGhcPath = guessToolFromGhcPath hsc2hsProgram -- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a @@ -302,23 +366,27 @@ guessHsc2hsFromGhcPath = guessToolFromGhcPath hsc2hsProgram -- > /usr/local/bin/haddock-ghc-6.6.1(.exe) -- > /usr/local/bin/haddock-6.6.1(.exe) -- > /usr/local/bin/haddock(.exe) --- -guessHaddockFromGhcPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) +guessHaddockFromGhcPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) guessHaddockFromGhcPath = guessToolFromGhcPath haddockProgram -guessHpcFromGhcPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) +guessHpcFromGhcPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) guessHpcFromGhcPath = guessToolFromGhcPath hpcProgram -guessRunghcFromGhcPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) +guessRunghcFromGhcPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) guessRunghcFromGhcPath = guessToolFromGhcPath runghcProgram - getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg where @@ -326,47 +394,54 @@ getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg implInfo = ghcVersionImplInfo version -- | Given a single package DB, return all installed packages. -getPackageDBContents :: Verbosity -> PackageDB -> ProgramDb - -> IO InstalledPackageIndex +getPackageDBContents + :: Verbosity + -> PackageDB + -> ProgramDb + -> IO InstalledPackageIndex getPackageDBContents verbosity packagedb progdb = do pkgss <- getInstalledPackages' verbosity [packagedb] progdb toPackageIndex verbosity pkgss progdb -- | Given a package DB stack, return all installed packages. -getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack - -> ProgramDb - -> IO InstalledPackageIndex +getInstalledPackages + :: Verbosity + -> Compiler + -> PackageDBStack + -> ProgramDb + -> IO InstalledPackageIndex getInstalledPackages verbosity comp packagedbs progdb = do checkPackageDbEnvVar verbosity checkPackageDbStack verbosity comp packagedbs pkgss <- getInstalledPackages' verbosity packagedbs progdb index <- toPackageIndex verbosity pkgss progdb return $! hackRtsPackage index - where hackRtsPackage index = case PackageIndex.lookupPackageName index (mkPackageName "rts") of - [(_,[rts])] - -> PackageIndex.insert (removeMingwIncludeDir rts) index - _ -> index -- No (or multiple) ghc rts package is registered!! - -- Feh, whatever, the ghc test suite does some crazy stuff. + [(_, [rts])] -> + PackageIndex.insert (removeMingwIncludeDir rts) index + _ -> index -- No (or multiple) ghc rts package is registered!! + -- Feh, whatever, the ghc test suite does some crazy stuff. -- | Given a list of @(PackageDB, InstalledPackageInfo)@ pairs, produce a -- @PackageIndex@. Helper function used by 'getPackageDBContents' and -- 'getInstalledPackages'. -toPackageIndex :: Verbosity - -> [(PackageDB, [InstalledPackageInfo])] - -> ProgramDb - -> IO InstalledPackageIndex +toPackageIndex + :: Verbosity + -> [(PackageDB, [InstalledPackageInfo])] + -> ProgramDb + -> IO InstalledPackageIndex toPackageIndex verbosity pkgss progdb = do -- On Windows, various fields have $topdir/foo rather than full -- paths. We need to substitute the right value in so that when -- we, for example, call gcc, we have proper paths to give it. topDir <- getLibDir' verbosity ghcProg - let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) - | (_, pkgs) <- pkgss ] + let indices = + [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) + | (_, pkgs) <- pkgss + ] return $! mconcat indices - where ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb @@ -378,103 +453,114 @@ getGhcAppDir = getAppUserDataDirectory "ghc" getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath getLibDir verbosity lbi = - dropWhileEndLE isSpace `fmap` - getDbProgramOutput verbosity ghcProgram - (withPrograms lbi) ["--print-libdir"] + dropWhileEndLE isSpace + `fmap` getDbProgramOutput + verbosity + ghcProgram + (withPrograms lbi) + ["--print-libdir"] getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath getLibDir' verbosity ghcProg = - dropWhileEndLE isSpace `fmap` - getProgramOutput verbosity ghcProg ["--print-libdir"] - + dropWhileEndLE isSpace + `fmap` getProgramOutput verbosity ghcProg ["--print-libdir"] -- | Return the 'FilePath' to the global GHC package database. getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath getGlobalPackageDB verbosity ghcProg = - dropWhileEndLE isSpace `fmap` - getProgramOutput verbosity ghcProg ["--print-global-package-db"] + dropWhileEndLE isSpace + `fmap` getProgramOutput verbosity ghcProg ["--print-global-package-db"] -- | Return the 'FilePath' to the per-user GHC package database. getUserPackageDB :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath getUserPackageDB _verbosity ghcProg platform = do - -- It's rather annoying that we have to reconstruct this, because ghc - -- hides this information from us otherwise. But for certain use cases - -- like change monitoring it really can't remain hidden. - appdir <- getGhcAppDir - return (appdir platformAndVersion packageConfFileName) + -- It's rather annoying that we have to reconstruct this, because ghc + -- hides this information from us otherwise. But for certain use cases + -- like change monitoring it really can't remain hidden. + appdir <- getGhcAppDir + return (appdir platformAndVersion packageConfFileName) where - platformAndVersion = Internal.ghcPlatformAndVersionString - platform ghcVersion + platformAndVersion = + Internal.ghcPlatformAndVersionString + platform + ghcVersion packageConfFileName = "package.conf.d" ghcVersion = fromMaybe (error "GHC.getUserPackageDB: no ghc version") $ programVersion ghcProg checkPackageDbEnvVar :: Verbosity -> IO () checkPackageDbEnvVar verbosity = - Internal.checkPackageDbEnvVar verbosity "GHC" "GHC_PACKAGE_PATH" + Internal.checkPackageDbEnvVar verbosity "GHC" "GHC_PACKAGE_PATH" checkPackageDbStack :: Verbosity -> Compiler -> PackageDBStack -> IO () checkPackageDbStack verbosity comp = - if flagPackageConf implInfo - then checkPackageDbStackPre76 verbosity - else checkPackageDbStackPost76 verbosity - where implInfo = ghcVersionImplInfo (compilerVersion comp) + if flagPackageConf implInfo + then checkPackageDbStackPre76 verbosity + else checkPackageDbStackPost76 verbosity + where + implInfo = ghcVersionImplInfo (compilerVersion comp) checkPackageDbStackPost76 :: Verbosity -> PackageDBStack -> IO () -checkPackageDbStackPost76 _ (GlobalPackageDB:rest) +checkPackageDbStackPost76 _ (GlobalPackageDB : rest) | GlobalPackageDB `notElem` rest = return () checkPackageDbStackPost76 verbosity rest | GlobalPackageDB `elem` rest = - die' verbosity $ "If the global package db is specified, it must be " - ++ "specified first and cannot be specified multiple times" + die' verbosity $ + "If the global package db is specified, it must be " + ++ "specified first and cannot be specified multiple times" checkPackageDbStackPost76 _ _ = return () checkPackageDbStackPre76 :: Verbosity -> PackageDBStack -> IO () -checkPackageDbStackPre76 _ (GlobalPackageDB:rest) +checkPackageDbStackPre76 _ (GlobalPackageDB : rest) | GlobalPackageDB `notElem` rest = return () checkPackageDbStackPre76 verbosity rest | GlobalPackageDB `notElem` rest = - die' verbosity $ + die' verbosity $ "With current ghc versions the global package db is always used " - ++ "and must be listed first. This ghc limitation is lifted in GHC 7.6," - ++ "see https://gitlab.haskell.org/ghc/ghc/-/issues/5977" + ++ "and must be listed first. This ghc limitation is lifted in GHC 7.6," + ++ "see https://gitlab.haskell.org/ghc/ghc/-/issues/5977" checkPackageDbStackPre76 verbosity _ = - die' verbosity $ "If the global package db is specified, it must be " - ++ "specified first and cannot be specified multiple times" + die' verbosity $ + "If the global package db is specified, it must be " + ++ "specified first and cannot be specified multiple times" -- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This -- breaks when you want to use a different gcc, so we need to filter -- it out. removeMingwIncludeDir :: InstalledPackageInfo -> InstalledPackageInfo removeMingwIncludeDir pkg = - let ids = InstalledPackageInfo.includeDirs pkg - ids' = filter (not . ("mingw" `isSuffixOf`)) ids - in pkg { InstalledPackageInfo.includeDirs = ids' } + let ids = InstalledPackageInfo.includeDirs pkg + ids' = filter (not . ("mingw" `isSuffixOf`)) ids + in pkg{InstalledPackageInfo.includeDirs = ids'} -- | Get the packages from specific PackageDBs, not cumulative. --- -getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramDb - -> IO [(PackageDB, [InstalledPackageInfo])] +getInstalledPackages' + :: Verbosity + -> [PackageDB] + -> ProgramDb + -> IO [(PackageDB, [InstalledPackageInfo])] getInstalledPackages' verbosity packagedbs progdb = sequenceA - [ do pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb - return (packagedb, pkgs) - | packagedb <- packagedbs ] - -getInstalledPackagesMonitorFiles :: Verbosity -> Platform - -> ProgramDb - -> [PackageDB] - -> IO [FilePath] + [ do + pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb + return (packagedb, pkgs) + | packagedb <- packagedbs + ] + +getInstalledPackagesMonitorFiles + :: Verbosity + -> Platform + -> ProgramDb + -> [PackageDB] + -> IO [FilePath] getInstalledPackagesMonitorFiles verbosity platform progdb = - traverse getPackageDBPath + traverse getPackageDBPath where getPackageDBPath :: PackageDB -> IO FilePath getPackageDBPath GlobalPackageDB = selectMonitorFile =<< getGlobalPackageDB verbosity ghcProg - getPackageDBPath UserPackageDB = selectMonitorFile =<< getUserPackageDB verbosity ghcProg platform - getPackageDBPath (SpecificPackageDB path) = selectMonitorFile path -- GHC has old style file dbs, and new style directory dbs. @@ -483,30 +569,45 @@ getInstalledPackagesMonitorFiles verbosity platform progdb = -- so it's safe to only monitor this one file. selectMonitorFile path = do isFileStyle <- doesFileExist path - if isFileStyle then return path - else return (path "package.cache") + if isFileStyle + then return path + else return (path "package.cache") ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb - -- ----------------------------------------------------------------------------- -- Building a library -buildLib :: Verbosity -> Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () +buildLib + :: Verbosity + -> Flag (Maybe Int) + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () buildLib = buildOrReplLib Nothing -replLib :: ReplOptions -> Verbosity - -> Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Library - -> ComponentLocalBuildInfo -> IO () +replLib + :: ReplOptions + -> Verbosity + -> Flag (Maybe Int) + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () replLib = buildOrReplLib . Just -buildOrReplLib :: Maybe ReplOptions -> Verbosity - -> Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Library - -> ComponentLocalBuildInfo -> IO () +buildOrReplLib + :: Maybe ReplOptions + -> Verbosity + -> Flag (Maybe Int) + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do let uid = componentUnitId clbi libTargetDir = componentBuildDir lbi clbi @@ -523,7 +624,7 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do replFlags = fromMaybe mempty mReplFlags comp = compiler lbi ghcVersion = compilerVersion comp - implInfo = getImplInfo comp + implInfo = getImplInfo comp platform@(Platform hostArch hostOS) = hostPlatform lbi hasJsSupport = hostArch == JavaScript has_code = not (componentIsIndefinite clbi) @@ -539,13 +640,12 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do cleanedExtraLibDirs <- filterM doesDirectoryExist (extraLibDirs libBi) cleanedExtraLibDirsStatic <- filterM doesDirectoryExist (extraLibDirsStatic libBi) - - let isGhcDynamic = isDynamic comp + let isGhcDynamic = isDynamic comp dynamicTooSupported = supportsDynamicToo comp doingTH = usesTemplateHaskellOrQQ libBi forceVanillaLib = doingTH && not isGhcDynamic - forceSharedLib = doingTH && isGhcDynamic - -- TH always needs default libs, even when building for profiling + forceSharedLib = doingTH && isGhcDynamic + -- TH always needs default libs, even when building for profiling -- Determine if program coverage should be enabled and if so, what -- '-hpcdir' should be. @@ -557,262 +657,355 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do pkg_name = prettyShow (PD.package pkg_descr) distPref = fromFlag $ configDistPref $ configFlags lbi hpcdir way - | forRepl = mempty -- HPC is not supported in ghci + | forRepl = mempty -- HPC is not supported in ghci | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name | otherwise = mempty createDirectoryIfMissingVerbose verbosity True libTargetDir -- TODO: do we need to put hs-boot files into place for mutually recursive -- modules? - let cLikeSources = fromNubListR $ mconcat - [ toNubListR (cSources libBi) - , toNubListR (cxxSources libBi) - , toNubListR (cmmSources libBi) - , toNubListR (asmSources libBi) - , if hasJsSupport - -- JS files are C-like with GHC's JS backend: they are - -- "compiled" into `.o` files (renamed with a header). - -- This is a difference from GHCJS, for which we only - -- pass the JS files at link time. - then toNubListR (jsSources libBi) - else mempty - ] - cLikeObjs = map (`replaceExtension` objExtension) cLikeSources - baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir - vanillaOpts = baseOpts `mappend` mempty { - ghcOptMode = toFlag GhcModeMake, - ghcOptNumJobs = numJobs, - ghcOptInputModules = toNubListR $ allLibModules lib clbi, - ghcOptHPCDir = hpcdir Hpc.Vanilla - } - - profOpts = vanillaOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptProfilingAuto = Internal.profDetailLevelFlag True - (withProfLibDetail lbi), - ghcOptHiSuffix = toFlag "p_hi", - ghcOptObjSuffix = toFlag "p_o", - ghcOptExtra = hcProfOptions GHC libBi, - ghcOptHPCDir = hpcdir Hpc.Prof - } - - sharedOpts = vanillaOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "dyn_hi", - ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcSharedOptions GHC libBi, - ghcOptHPCDir = hpcdir Hpc.Dyn - } - linkerOpts = mempty { - ghcOptLinkOptions = PD.ldOptions libBi - ++ [ "-static" - | withFullyStaticExe lbi ] - -- Pass extra `ld-options` given - -- through to GHC's linker. - ++ maybe [] programOverrideArgs - (lookupProgram ldProgram (withPrograms lbi)), - ghcOptLinkLibs = if withFullyStaticExe lbi - then extraLibsStatic libBi - else extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ - if withFullyStaticExe lbi - then cleanedExtraLibDirsStatic - else cleanedExtraLibDirs, - ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, - ghcOptLinkFrameworkDirs = toNubListR $ - PD.extraFrameworkDirs libBi, - ghcOptInputFiles = toNubListR - [relLibTargetDir x | x <- cLikeObjs] - } - replOpts = vanillaOpts { - ghcOptExtra = Internal.filterGhciFlags - (ghcOptExtra vanillaOpts) - <> replOptionsFlags replFlags, - ghcOptNumJobs = mempty, - ghcOptInputModules = replNoLoad replFlags (ghcOptInputModules vanillaOpts) - } - `mappend` linkerOpts - `mappend` mempty { - ghcOptMode = toFlag GhcModeInteractive, - ghcOptOptimisation = toFlag GhcNoOptimisation - } - - vanillaSharedOpts = vanillaOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, - ghcOptDynHiSuffix = toFlag "dyn_hi", - ghcOptDynObjSuffix = toFlag "dyn_o", - ghcOptHPCDir = hpcdir Hpc.Dyn - } + let cLikeSources = + fromNubListR $ + mconcat + [ toNubListR (cSources libBi) + , toNubListR (cxxSources libBi) + , toNubListR (cmmSources libBi) + , toNubListR (asmSources libBi) + , if hasJsSupport + then -- JS files are C-like with GHC's JS backend: they are + -- "compiled" into `.o` files (renamed with a header). + -- This is a difference from GHCJS, for which we only + -- pass the JS files at link time. + toNubListR (jsSources libBi) + else mempty + ] + cLikeObjs = map (`replaceExtension` objExtension) cLikeSources + baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir + vanillaOpts = + baseOpts + `mappend` mempty + { ghcOptMode = toFlag GhcModeMake + , ghcOptNumJobs = numJobs + , ghcOptInputModules = toNubListR $ allLibModules lib clbi + , ghcOptHPCDir = hpcdir Hpc.Vanilla + } + + profOpts = + vanillaOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + , ghcOptProfilingAuto = + Internal.profDetailLevelFlag + True + (withProfLibDetail lbi) + , ghcOptHiSuffix = toFlag "p_hi" + , ghcOptObjSuffix = toFlag "p_o" + , ghcOptExtra = hcProfOptions GHC libBi + , ghcOptHPCDir = hpcdir Hpc.Prof + } + + sharedOpts = + vanillaOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptFPic = toFlag True + , ghcOptHiSuffix = toFlag "dyn_hi" + , ghcOptObjSuffix = toFlag "dyn_o" + , ghcOptExtra = hcSharedOptions GHC libBi + , ghcOptHPCDir = hpcdir Hpc.Dyn + } + linkerOpts = + mempty + { ghcOptLinkOptions = + PD.ldOptions libBi + ++ [ "-static" + | withFullyStaticExe lbi + ] + -- Pass extra `ld-options` given + -- through to GHC's linker. + ++ maybe + [] + programOverrideArgs + (lookupProgram ldProgram (withPrograms lbi)) + , ghcOptLinkLibs = + if withFullyStaticExe lbi + then extraLibsStatic libBi + else extraLibs libBi + , ghcOptLinkLibPath = + toNubListR $ + if withFullyStaticExe lbi + then cleanedExtraLibDirsStatic + else cleanedExtraLibDirs + , ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi + , ghcOptLinkFrameworkDirs = + toNubListR $ + PD.extraFrameworkDirs libBi + , ghcOptInputFiles = + toNubListR + [relLibTargetDir x | x <- cLikeObjs] + } + replOpts = + vanillaOpts + { ghcOptExtra = + Internal.filterGhciFlags + (ghcOptExtra vanillaOpts) + <> replOptionsFlags replFlags + , ghcOptNumJobs = mempty + , ghcOptInputModules = replNoLoad replFlags (ghcOptInputModules vanillaOpts) + } + `mappend` linkerOpts + `mappend` mempty + { ghcOptMode = toFlag GhcModeInteractive + , ghcOptOptimisation = toFlag GhcNoOptimisation + } + + vanillaSharedOpts = + vanillaOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic + , ghcOptDynHiSuffix = toFlag "dyn_hi" + , ghcOptDynObjSuffix = toFlag "dyn_o" + , ghcOptHPCDir = hpcdir Hpc.Dyn + } unless (forRepl || null (allLibModules lib clbi)) $ - do let vanilla = whenVanillaLib forceVanillaLib (runGhcProg vanillaOpts) - shared = whenSharedLib forceSharedLib (runGhcProg sharedOpts) - useDynToo = dynamicTooSupported && - (forceVanillaLib || withVanillaLib lbi) && - (forceSharedLib || withSharedLib lbi) && - null (hcSharedOptions GHC libBi) - if not has_code + do + let vanilla = whenVanillaLib forceVanillaLib (runGhcProg vanillaOpts) + shared = whenSharedLib forceSharedLib (runGhcProg sharedOpts) + useDynToo = + dynamicTooSupported + && (forceVanillaLib || withVanillaLib lbi) + && (forceSharedLib || withSharedLib lbi) + && null (hcSharedOptions GHC libBi) + if not has_code then vanilla else - if useDynToo - then do + if useDynToo + then do runGhcProg vanillaSharedOpts case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of (Flag dynDir, Flag vanillaDir) -> - -- When the vanilla and shared library builds are done - -- in one pass, only one set of HPC module interfaces - -- are generated. This set should suffice for both - -- static and dynamically linked executables. We copy - -- the modules interfaces so they are available under - -- both ways. - copyDirectoryRecursive verbosity dynDir vanillaDir + -- When the vanilla and shared library builds are done + -- in one pass, only one set of HPC module interfaces + -- are generated. This set should suffice for both + -- static and dynamically linked executables. We copy + -- the modules interfaces so they are available under + -- both ways. + copyDirectoryRecursive verbosity dynDir vanillaDir _ -> return () - else if isGhcDynamic - then do shared; vanilla - else do vanilla; shared - whenProfLib (runGhcProg profOpts) + else + if isGhcDynamic + then do shared; vanilla + else do vanilla; shared + whenProfLib (runGhcProg profOpts) -- Build any C++ sources separately. unless (not has_code || null (cxxSources libBi)) $ do info verbosity "Building C++ Sources..." sequence_ - [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo - lbi libBi clbi relLibTargetDir filename - vanillaCxxOpts = if isGhcDynamic - then baseCxxOpts { ghcOptFPic = toFlag True } - else baseCxxOpts - profCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaCxxOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded cxxOpts = do - needsRecomp <- checkNeedsRecompilation filename cxxOpts - when needsRecomp $ runGhcProg cxxOpts - runGhcProgIfNeeded vanillaCxxOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profCxxOpts) - | filename <- cxxSources libBi] + [ do + let baseCxxOpts = + Internal.componentCxxGhcOptions + verbosity + implInfo + lbi + libBi + clbi + relLibTargetDir + filename + vanillaCxxOpts = + if isGhcDynamic + then baseCxxOpts{ghcOptFPic = toFlag True} + else baseCxxOpts + profCxxOpts = + vanillaCxxOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + , ghcOptObjSuffix = toFlag "p_o" + } + sharedCxxOpts = + vanillaCxxOpts + `mappend` mempty + { ghcOptFPic = toFlag True + , ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptObjSuffix = toFlag "dyn_o" + } + odir = fromFlag (ghcOptObjDir vanillaCxxOpts) + createDirectoryIfMissingVerbose verbosity True odir + let runGhcProgIfNeeded cxxOpts = do + needsRecomp <- checkNeedsRecompilation filename cxxOpts + when needsRecomp $ runGhcProg cxxOpts + runGhcProgIfNeeded vanillaCxxOpts + unless forRepl $ + whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts) + unless forRepl $ whenProfLib (runGhcProgIfNeeded profCxxOpts) + | filename <- cxxSources libBi + ] -- build any C sources unless (not has_code || null (cSources libBi)) $ do info verbosity "Building C Sources..." sequence_ - [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo - lbi libBi clbi relLibTargetDir filename - vanillaCcOpts = if isGhcDynamic - -- Dynamic GHC requires C sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCcOpts { ghcOptFPic = toFlag True } - else baseCcOpts - profCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaCcOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded ccOpts = do - needsRecomp <- checkNeedsRecompilation filename ccOpts - when needsRecomp $ runGhcProg ccOpts - runGhcProgIfNeeded vanillaCcOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts) - | filename <- cSources libBi] + [ do + let baseCcOpts = + Internal.componentCcGhcOptions + verbosity + implInfo + lbi + libBi + clbi + relLibTargetDir + filename + vanillaCcOpts = + if isGhcDynamic + then -- Dynamic GHC requires C sources to be built + -- with -fPIC for REPL to work. See #2207. + baseCcOpts{ghcOptFPic = toFlag True} + else baseCcOpts + profCcOpts = + vanillaCcOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + , ghcOptObjSuffix = toFlag "p_o" + } + sharedCcOpts = + vanillaCcOpts + `mappend` mempty + { ghcOptFPic = toFlag True + , ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptObjSuffix = toFlag "dyn_o" + } + odir = fromFlag (ghcOptObjDir vanillaCcOpts) + createDirectoryIfMissingVerbose verbosity True odir + let runGhcProgIfNeeded ccOpts = do + needsRecomp <- checkNeedsRecompilation filename ccOpts + when needsRecomp $ runGhcProg ccOpts + runGhcProgIfNeeded vanillaCcOpts + unless forRepl $ + whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts) + unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts) + | filename <- cSources libBi + ] -- build any JS sources unless (not has_code || not hasJsSupport || null (jsSources libBi)) $ do info verbosity "Building JS Sources..." sequence_ - [ do let vanillaJsOpts = Internal.componentJsGhcOptions verbosity implInfo - lbi libBi clbi relLibTargetDir filename - profJsOpts = vanillaJsOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - odir = fromFlag (ghcOptObjDir vanillaJsOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded jsOpts = do - needsRecomp <- checkNeedsRecompilation filename jsOpts - when needsRecomp $ runGhcProg jsOpts - runGhcProgIfNeeded vanillaJsOpts - unless forRepl $ whenProfLib (runGhcProgIfNeeded profJsOpts) - | filename <- jsSources libBi] + [ do + let vanillaJsOpts = + Internal.componentJsGhcOptions + verbosity + implInfo + lbi + libBi + clbi + relLibTargetDir + filename + profJsOpts = + vanillaJsOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + , ghcOptObjSuffix = toFlag "p_o" + } + odir = fromFlag (ghcOptObjDir vanillaJsOpts) + createDirectoryIfMissingVerbose verbosity True odir + let runGhcProgIfNeeded jsOpts = do + needsRecomp <- checkNeedsRecompilation filename jsOpts + when needsRecomp $ runGhcProg jsOpts + runGhcProgIfNeeded vanillaJsOpts + unless forRepl $ whenProfLib (runGhcProgIfNeeded profJsOpts) + | filename <- jsSources libBi + ] -- build any ASM sources unless (not has_code || null (asmSources libBi)) $ do info verbosity "Building Assembler Sources..." sequence_ - [ do let baseAsmOpts = Internal.componentAsmGhcOptions verbosity implInfo - lbi libBi clbi relLibTargetDir filename - vanillaAsmOpts = if isGhcDynamic - -- Dynamic GHC requires objects to be built - -- with -fPIC for REPL to work. See #2207. - then baseAsmOpts { ghcOptFPic = toFlag True } - else baseAsmOpts - profAsmOpts = vanillaAsmOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedAsmOpts = vanillaAsmOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaAsmOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded asmOpts = do - needsRecomp <- checkNeedsRecompilation filename asmOpts - when needsRecomp $ runGhcProg asmOpts - runGhcProgIfNeeded vanillaAsmOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedAsmOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profAsmOpts) - | filename <- asmSources libBi] + [ do + let baseAsmOpts = + Internal.componentAsmGhcOptions + verbosity + implInfo + lbi + libBi + clbi + relLibTargetDir + filename + vanillaAsmOpts = + if isGhcDynamic + then -- Dynamic GHC requires objects to be built + -- with -fPIC for REPL to work. See #2207. + baseAsmOpts{ghcOptFPic = toFlag True} + else baseAsmOpts + profAsmOpts = + vanillaAsmOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + , ghcOptObjSuffix = toFlag "p_o" + } + sharedAsmOpts = + vanillaAsmOpts + `mappend` mempty + { ghcOptFPic = toFlag True + , ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptObjSuffix = toFlag "dyn_o" + } + odir = fromFlag (ghcOptObjDir vanillaAsmOpts) + createDirectoryIfMissingVerbose verbosity True odir + let runGhcProgIfNeeded asmOpts = do + needsRecomp <- checkNeedsRecompilation filename asmOpts + when needsRecomp $ runGhcProg asmOpts + runGhcProgIfNeeded vanillaAsmOpts + unless forRepl $ + whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedAsmOpts) + unless forRepl $ whenProfLib (runGhcProgIfNeeded profAsmOpts) + | filename <- asmSources libBi + ] -- build any Cmm sources unless (not has_code || null (cmmSources libBi)) $ do info verbosity "Building C-- Sources..." sequence_ - [ do let baseCmmOpts = Internal.componentCmmGhcOptions verbosity implInfo - lbi libBi clbi relLibTargetDir filename - vanillaCmmOpts = if isGhcDynamic - -- Dynamic GHC requires C sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCmmOpts { ghcOptFPic = toFlag True } - else baseCmmOpts - profCmmOpts = vanillaCmmOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedCmmOpts = vanillaCmmOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaCmmOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded cmmOpts = do - needsRecomp <- checkNeedsRecompilation filename cmmOpts - when needsRecomp $ runGhcProg cmmOpts - runGhcProgIfNeeded vanillaCmmOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCmmOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profCmmOpts) - | filename <- cmmSources libBi] + [ do + let baseCmmOpts = + Internal.componentCmmGhcOptions + verbosity + implInfo + lbi + libBi + clbi + relLibTargetDir + filename + vanillaCmmOpts = + if isGhcDynamic + then -- Dynamic GHC requires C sources to be built + -- with -fPIC for REPL to work. See #2207. + baseCmmOpts{ghcOptFPic = toFlag True} + else baseCmmOpts + profCmmOpts = + vanillaCmmOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + , ghcOptObjSuffix = toFlag "p_o" + } + sharedCmmOpts = + vanillaCmmOpts + `mappend` mempty + { ghcOptFPic = toFlag True + , ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptObjSuffix = toFlag "dyn_o" + } + odir = fromFlag (ghcOptObjDir vanillaCmmOpts) + createDirectoryIfMissingVerbose verbosity True odir + let runGhcProgIfNeeded cmmOpts = do + needsRecomp <- checkNeedsRecompilation filename cmmOpts + when needsRecomp $ runGhcProg cmmOpts + runGhcProgIfNeeded vanillaCmmOpts + unless forRepl $ + whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCmmOpts) + unless forRepl $ whenProfLib (runGhcProgIfNeeded profCmmOpts) + | filename <- cmmSources libBi + ] -- TODO: problem here is we need the .c files built first, so we can load them -- with ghci, but .c files can depend on .h files generated by ghc by ffi @@ -824,143 +1017,197 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do -- link: when has_code . unless forRepl $ do info verbosity "Linking..." - let cLikeProfObjs = map (`replaceExtension` ("p_" ++ objExtension)) - cLikeSources - cLikeSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) - cLikeSources - compiler_id = compilerId (compiler lbi) - vanillaLibFilePath = relLibTargetDir mkLibName uid - profileLibFilePath = relLibTargetDir mkProfLibName uid - sharedLibFilePath = relLibTargetDir - mkSharedLibName (hostPlatform lbi) compiler_id uid - staticLibFilePath = relLibTargetDir - mkStaticLibName (hostPlatform lbi) compiler_id uid - ghciLibFilePath = relLibTargetDir Internal.mkGHCiLibName uid - ghciProfLibFilePath = relLibTargetDir Internal.mkGHCiProfLibName uid - libInstallPath = libdir $ - absoluteComponentInstallDirs - pkg_descr lbi uid NoCopyDest - sharedLibInstallPath = libInstallPath - mkSharedLibName (hostPlatform lbi) compiler_id uid - - stubObjs <- catMaybes <$> sequenceA - [ findFileWithExtension [objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] - stubProfObjs <- catMaybes <$> sequenceA - [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] - stubSharedObjs <- catMaybes <$> sequenceA - [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] - - hObjs <- Internal.getHaskellObjects implInfo lib lbi clbi - relLibTargetDir objExtension True + let cLikeProfObjs = + map + (`replaceExtension` ("p_" ++ objExtension)) + cLikeSources + cLikeSharedObjs = + map + (`replaceExtension` ("dyn_" ++ objExtension)) + cLikeSources + compiler_id = compilerId (compiler lbi) + vanillaLibFilePath = relLibTargetDir mkLibName uid + profileLibFilePath = relLibTargetDir mkProfLibName uid + sharedLibFilePath = + relLibTargetDir + mkSharedLibName (hostPlatform lbi) compiler_id uid + staticLibFilePath = + relLibTargetDir + mkStaticLibName (hostPlatform lbi) compiler_id uid + ghciLibFilePath = relLibTargetDir Internal.mkGHCiLibName uid + ghciProfLibFilePath = relLibTargetDir Internal.mkGHCiProfLibName uid + libInstallPath = + libdir $ + absoluteComponentInstallDirs + pkg_descr + lbi + uid + NoCopyDest + sharedLibInstallPath = + libInstallPath + mkSharedLibName (hostPlatform lbi) compiler_id uid + + stubObjs <- + catMaybes + <$> sequenceA + [ findFileWithExtension + [objExtension] + [libTargetDir] + (ModuleName.toFilePath x ++ "_stub") + | ghcVersion < mkVersion [7, 2] -- ghc-7.2+ does not make _stub.o files + , x <- allLibModules lib clbi + ] + stubProfObjs <- + catMaybes + <$> sequenceA + [ findFileWithExtension + ["p_" ++ objExtension] + [libTargetDir] + (ModuleName.toFilePath x ++ "_stub") + | ghcVersion < mkVersion [7, 2] -- ghc-7.2+ does not make _stub.o files + , x <- allLibModules lib clbi + ] + stubSharedObjs <- + catMaybes + <$> sequenceA + [ findFileWithExtension + ["dyn_" ++ objExtension] + [libTargetDir] + (ModuleName.toFilePath x ++ "_stub") + | ghcVersion < mkVersion [7, 2] -- ghc-7.2+ does not make _stub.o files + , x <- allLibModules lib clbi + ] + + hObjs <- + Internal.getHaskellObjects + implInfo + lib + lbi + clbi + relLibTargetDir + objExtension + True hProfObjs <- if withProfLib lbi - then Internal.getHaskellObjects implInfo lib lbi clbi - relLibTargetDir ("p_" ++ objExtension) True - else return [] + then + Internal.getHaskellObjects + implInfo + lib + lbi + clbi + relLibTargetDir + ("p_" ++ objExtension) + True + else return [] hSharedObjs <- if withSharedLib lbi - then Internal.getHaskellObjects implInfo lib lbi clbi - relLibTargetDir ("dyn_" ++ objExtension) False - else return [] + then + Internal.getHaskellObjects + implInfo + lib + lbi + clbi + relLibTargetDir + ("dyn_" ++ objExtension) + False + else return [] unless (null hObjs && null cLikeObjs && null stubObjs) $ do rpaths <- getRPaths lbi clbi let staticObjectFiles = - hObjs + hObjs ++ map (relLibTargetDir ) cLikeObjs ++ stubObjs profObjectFiles = - hProfObjs + hProfObjs ++ map (relLibTargetDir ) cLikeProfObjs ++ stubProfObjs dynamicObjectFiles = - hSharedObjs + hSharedObjs ++ map (relLibTargetDir ) cLikeSharedObjs ++ stubSharedObjs -- After the relocation lib is created we invoke ghc -shared -- with the dependencies spelled out as -package arguments -- and ghc invokes the linker with the proper library paths ghcSharedLinkArgs = - mempty { - ghcOptShared = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptInputFiles = toNubListR dynamicObjectFiles, - ghcOptOutputFile = toFlag sharedLibFilePath, - ghcOptExtra = hcSharedOptions GHC libBi, - -- For dynamic libs, Mac OS/X needs to know the install location + mempty + { ghcOptShared = toFlag True + , ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptInputFiles = toNubListR dynamicObjectFiles + , ghcOptOutputFile = toFlag sharedLibFilePath + , ghcOptExtra = hcSharedOptions GHC libBi + , -- For dynamic libs, Mac OS/X needs to know the install location -- at build time. This only applies to GHC < 7.8 - see the -- discussion in #1660. - ghcOptDylibName = if hostOS == OSX - && ghcVersion < mkVersion [7,8] - then toFlag sharedLibInstallPath - else mempty, - ghcOptHideAllPackages = toFlag True, - ghcOptNoAutoLinkPackages = toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo { componentCompatPackageKey = pk } - -> toFlag pk - _ -> mempty, - ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo - { componentInstantiatedWith = insts } -> - if null insts - then mempty - else toFlag (componentComponentId clbi) - _ -> mempty, - ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo - { componentInstantiatedWith = insts } - -> insts - _ -> [], - ghcOptPackages = toNubListR $ - Internal.mkGhcOptPackages clbi , - ghcOptLinkLibs = extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs, - ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, - ghcOptLinkFrameworkDirs = - toNubListR $ PD.extraFrameworkDirs libBi, - ghcOptRPaths = rpaths + ghcOptDylibName = + if hostOS == OSX + && ghcVersion < mkVersion [7, 8] + then toFlag sharedLibInstallPath + else mempty + , ghcOptHideAllPackages = toFlag True + , ghcOptNoAutoLinkPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> + toFlag pk + _ -> mempty + , ghcOptThisComponentId = case clbi of + LibComponentLocalBuildInfo + { componentInstantiatedWith = insts + } -> + if null insts + then mempty + else toFlag (componentComponentId clbi) + _ -> mempty + , ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo + { componentInstantiatedWith = insts + } -> + insts + _ -> [] + , ghcOptPackages = + toNubListR $ + Internal.mkGhcOptPackages clbi + , ghcOptLinkLibs = extraLibs libBi + , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs + , ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi + , ghcOptLinkFrameworkDirs = + toNubListR $ PD.extraFrameworkDirs libBi + , ghcOptRPaths = rpaths } ghcStaticLinkArgs = - mempty { - ghcOptStaticLib = toFlag True, - ghcOptInputFiles = toNubListR staticObjectFiles, - ghcOptOutputFile = toFlag staticLibFilePath, - ghcOptExtra = hcStaticOptions GHC libBi, - ghcOptHideAllPackages = toFlag True, - ghcOptNoAutoLinkPackages = toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo { componentCompatPackageKey = pk } - -> toFlag pk - _ -> mempty, - ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo - { componentInstantiatedWith = insts } -> - if null insts - then mempty - else toFlag (componentComponentId clbi) - _ -> mempty, - ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo - { componentInstantiatedWith = insts } - -> insts - _ -> [], - ghcOptPackages = toNubListR $ - Internal.mkGhcOptPackages clbi , - ghcOptLinkLibs = extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs + mempty + { ghcOptStaticLib = toFlag True + , ghcOptInputFiles = toNubListR staticObjectFiles + , ghcOptOutputFile = toFlag staticLibFilePath + , ghcOptExtra = hcStaticOptions GHC libBi + , ghcOptHideAllPackages = toFlag True + , ghcOptNoAutoLinkPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> + toFlag pk + _ -> mempty + , ghcOptThisComponentId = case clbi of + LibComponentLocalBuildInfo + { componentInstantiatedWith = insts + } -> + if null insts + then mempty + else toFlag (componentComponentId clbi) + _ -> mempty + , ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo + { componentInstantiatedWith = insts + } -> + insts + _ -> [] + , ghcOptPackages = + toNubListR $ + Internal.mkGhcOptPackages clbi + , ghcOptLinkLibs = extraLibs libBi + , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs } info verbosity (show (ghcOptPackages ghcSharedLinkArgs)) @@ -969,15 +1216,23 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles whenGHCiLib $ do (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) - Ld.combineObjectFiles verbosity lbi ldProg - ghciLibFilePath staticObjectFiles + Ld.combineObjectFiles + verbosity + lbi + ldProg + ghciLibFilePath + staticObjectFiles whenProfLib $ do Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles whenGHCiLib $ do (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) - Ld.combineObjectFiles verbosity lbi ldProg - ghciProfLibFilePath profObjectFiles + Ld.combineObjectFiles + verbosity + lbi + ldProg + ghciProfLibFilePath + profObjectFiles whenSharedLib False $ runGhcProg ghcSharedLinkArgs @@ -986,13 +1241,19 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do runGhcProg ghcStaticLinkArgs -- | Start a REPL without loading any source files. -startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform - -> PackageDBStack -> IO () +startInterpreter + :: Verbosity + -> ProgramDb + -> Compiler + -> Platform + -> PackageDBStack + -> IO () startInterpreter verbosity progdb comp platform packageDBs = do - let replOpts = mempty { - ghcOptMode = toFlag GhcModeInteractive, - ghcOptPackageDBs = packageDBs - } + let replOpts = + mempty + { ghcOptMode = toFlag GhcModeInteractive + , ghcOptPackageDBs = packageDBs + } checkPackageDbStack verbosity comp packageDBs (ghcProg, _) <- requireProgram verbosity ghcProgram progdb runGHC verbosity ghcProg comp platform replOpts @@ -1002,61 +1263,76 @@ startInterpreter verbosity progdb comp platform packageDBs = do -- | Build a foreign library buildFLib - :: Verbosity -> Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> ForeignLib -> ComponentLocalBuildInfo -> IO () + :: Verbosity + -> Flag (Maybe Int) + -> PackageDescription + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO () buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib replFLib - :: ReplOptions -> Verbosity - -> Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> ForeignLib - -> ComponentLocalBuildInfo -> IO () -replFLib replFlags v njobs pkg lbi = + :: ReplOptions + -> Verbosity + -> Flag (Maybe Int) + -> PackageDescription + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO () +replFLib replFlags v njobs pkg lbi = gbuild v njobs pkg lbi . GReplFLib replFlags -- | Build an executable with GHC. --- buildExe - :: Verbosity -> Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () + :: Verbosity + -> Flag (Maybe Int) + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe replExe - :: ReplOptions -> Verbosity - -> Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Executable - -> ComponentLocalBuildInfo -> IO () + :: ReplOptions + -> Verbosity + -> Flag (Maybe Int) + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () replExe replFlags v njobs pkg lbi = gbuild v njobs pkg lbi . GReplExe replFlags -- | Building an executable, starting the REPL, and building foreign -- libraries are all very similar and implemented in 'gbuild'. The -- 'GBuildMode' distinguishes between the various kinds of operation. -data GBuildMode = - GBuildExe Executable - | GReplExe ReplOptions Executable +data GBuildMode + = GBuildExe Executable + | GReplExe ReplOptions Executable | GBuildFLib ForeignLib - | GReplFLib ReplOptions ForeignLib + | GReplFLib ReplOptions ForeignLib gbuildInfo :: GBuildMode -> BuildInfo -gbuildInfo (GBuildExe exe) = buildInfo exe -gbuildInfo (GReplExe _ exe) = buildInfo exe +gbuildInfo (GBuildExe exe) = buildInfo exe +gbuildInfo (GReplExe _ exe) = buildInfo exe gbuildInfo (GBuildFLib flib) = foreignLibBuildInfo flib -gbuildInfo (GReplFLib _ flib) = foreignLibBuildInfo flib +gbuildInfo (GReplFLib _ flib) = foreignLibBuildInfo flib gbuildName :: GBuildMode -> String -gbuildName (GBuildExe exe) = unUnqualComponentName $ exeName exe -gbuildName (GReplExe _ exe) = unUnqualComponentName $ exeName exe +gbuildName (GBuildExe exe) = unUnqualComponentName $ exeName exe +gbuildName (GReplExe _ exe) = unUnqualComponentName $ exeName exe gbuildName (GBuildFLib flib) = unUnqualComponentName $ foreignLibName flib -gbuildName (GReplFLib _ flib) = unUnqualComponentName $ foreignLibName flib +gbuildName (GReplFLib _ flib) = unUnqualComponentName $ foreignLibName flib gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String -gbuildTargetName lbi (GBuildExe exe) = exeTargetName (hostPlatform lbi) exe -gbuildTargetName lbi (GReplExe _ exe) = exeTargetName (hostPlatform lbi) exe +gbuildTargetName lbi (GBuildExe exe) = exeTargetName (hostPlatform lbi) exe +gbuildTargetName lbi (GReplExe _ exe) = exeTargetName (hostPlatform lbi) exe gbuildTargetName lbi (GBuildFLib flib) = flibTargetName lbi flib -gbuildTargetName lbi (GReplFLib _ flib) = flibTargetName lbi flib +gbuildTargetName lbi (GReplFLib _ flib) = flibTargetName lbi flib exeTargetName :: Platform -> Executable -> String exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeExtension platform @@ -1072,22 +1348,23 @@ exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeEx -- than the target OS (but this is wrong elsewhere in Cabal as well). flibTargetName :: LocalBuildInfo -> ForeignLib -> String flibTargetName lbi flib = - case (os, foreignLibType flib) of - (Windows, ForeignLibNativeShared) -> nm <.> "dll" - (Windows, ForeignLibNativeStatic) -> nm <.> "lib" - (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt - (_other, ForeignLibNativeShared) -> - "lib" ++ nm <.> dllExtension (hostPlatform lbi) - (_other, ForeignLibNativeStatic) -> - "lib" ++ nm <.> staticLibExtension (hostPlatform lbi) - (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type" + case (os, foreignLibType flib) of + (Windows, ForeignLibNativeShared) -> nm <.> "dll" + (Windows, ForeignLibNativeStatic) -> nm <.> "lib" + (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt + (_other, ForeignLibNativeShared) -> + "lib" ++ nm <.> dllExtension (hostPlatform lbi) + (_other, ForeignLibNativeStatic) -> + "lib" ++ nm <.> staticLibExtension (hostPlatform lbi) + (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type" where nm :: String nm = unUnqualComponentName $ foreignLibName flib os :: OS - os = let (Platform _ os') = hostPlatform lbi - in os' + os = + let (Platform _ os') = hostPlatform lbi + in os' -- If a foreign lib foo has lib-version-info 5:1:2 or -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1 @@ -1096,7 +1373,7 @@ flibTargetName lbi flib = versionedExt :: String versionedExt = let nums = foreignLibVersion flib os - in foldl (<.>) "so" (map show nums) + in foldl (<.>) "so" (map show nums) -- | Name for the library when building. -- @@ -1118,32 +1395,33 @@ flibBuildName :: LocalBuildInfo -> ForeignLib -> String flibBuildName lbi flib -- On linux, if a foreign-library has version data, the first digit is used -- to produce the SONAME. - | (os, foreignLibType flib) == - (Linux, ForeignLibNativeShared) - = let nums = foreignLibVersion flib os - in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums)) + | (os, foreignLibType flib) + == (Linux, ForeignLibNativeShared) = + let nums = foreignLibVersion flib os + in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums)) | otherwise = flibTargetName lbi flib where os :: OS - os = let (Platform _ os') = hostPlatform lbi - in os' + os = + let (Platform _ os') = hostPlatform lbi + in os' nm :: String nm = unUnqualComponentName $ foreignLibName flib gbuildIsRepl :: GBuildMode -> Bool -gbuildIsRepl (GBuildExe _) = False +gbuildIsRepl (GBuildExe _) = False gbuildIsRepl (GReplExe _ _) = True gbuildIsRepl (GBuildFLib _) = False gbuildIsRepl (GReplFLib _ _) = True gbuildNeedDynamic :: LocalBuildInfo -> GBuildMode -> Bool gbuildNeedDynamic lbi bm = - case bm of - GBuildExe _ -> withDynExe lbi - GReplExe _ _ -> withDynExe lbi - GBuildFLib flib -> withDynFLib flib - GReplFLib _ flib -> withDynFLib flib + case bm of + GBuildExe _ -> withDynExe lbi + GReplExe _ _ -> withDynExe lbi + GBuildFLib flib -> withDynFLib flib + GReplFLib _ flib -> withDynFLib flib where withDynFLib flib = case foreignLibType flib of @@ -1151,12 +1429,12 @@ gbuildNeedDynamic lbi bm = ForeignLibStandalone `notElem` foreignLibOptions flib ForeignLibNativeStatic -> False - ForeignLibTypeUnknown -> + ForeignLibTypeUnknown -> cabalBug "unknown foreign lib type" gbuildModDefFiles :: GBuildMode -> [FilePath] -gbuildModDefFiles (GBuildExe _) = [] -gbuildModDefFiles (GReplExe _ _) = [] +gbuildModDefFiles (GBuildExe _) = [] +gbuildModDefFiles (GReplExe _ _) = [] gbuildModDefFiles (GBuildFLib flib) = foreignLibModDefFile flib gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib @@ -1166,18 +1444,18 @@ gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib -- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed. exeMainModuleName :: Executable -> Maybe ModuleName exeMainModuleName Executable{buildInfo = bnfo} = - -- GHC honors the last occurrence of a module name updated via -main-is - -- - -- Moreover, -main-is when parsed left-to-right can update either - -- the "Main" module name, or the "main" function name, or both, - -- see also 'decodeMainIsArg'. - msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts + -- GHC honors the last occurrence of a module name updated via -main-is + -- + -- Moreover, -main-is when parsed left-to-right can update either + -- the "Main" module name, or the "main" function name, or both, + -- see also 'decodeMainIsArg'. + msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts where ghcopts = hcOptions GHC bnfo findIsMainArgs [] = [] - findIsMainArgs ("-main-is":arg:rest) = arg : findIsMainArgs rest - findIsMainArgs (_:rest) = findIsMainArgs rest + findIsMainArgs ("-main-is" : arg : rest) = arg : findIsMainArgs rest + findIsMainArgs (_ : rest) = findIsMainArgs rest -- | Decode argument to '-main-is' -- @@ -1189,25 +1467,28 @@ exeMainModuleName Executable{buildInfo = bnfo} = -- https://github.com/haskell/cabal/pull/4539#discussion_r118981753. decodeMainIsArg :: String -> Maybe ModuleName decodeMainIsArg arg - | headOf main_fn isLower - -- The arg looked like "Foo.Bar.baz" - = Just (ModuleName.fromString main_mod) - | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar" - = Just (ModuleName.fromString arg) - | otherwise -- The arg looked like "baz" - = Nothing + | headOf main_fn isLower = + -- The arg looked like "Foo.Bar.baz" + Just (ModuleName.fromString main_mod) + | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar" + = + Just (ModuleName.fromString arg) + | otherwise -- The arg looked like "baz" + = + Nothing where headOf :: String -> (Char -> Bool) -> Bool headOf str pred' = any pred' (safeHead str) (main_mod, main_fn) = splitLongestPrefix arg (== '.') - splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) + splitLongestPrefix :: String -> (Char -> Bool) -> (String, String) splitLongestPrefix str pred' - | null r_pre = (str, []) - | otherwise = (reverse (safeTail r_pre), reverse r_suf) - -- 'safeTail' drops the char satisfying 'pred' - where (r_suf, r_pre) = break pred' (reverse str) + | null r_pre = (str, []) + | otherwise = (reverse (safeTail r_pre), reverse r_suf) + where + -- 'safeTail' drops the char satisfying 'pred' + (r_suf, r_pre) = break pred' (reverse str) -- | A collection of: -- * C input files @@ -1216,26 +1497,27 @@ decodeMainIsArg arg -- * GHC input modules -- -- Used to correctly build and link sources. -data BuildSources = BuildSources { - cSourcesFiles :: [FilePath], - cxxSourceFiles :: [FilePath], - inputSourceFiles :: [FilePath], - inputSourceModules :: [ModuleName] - } +data BuildSources = BuildSources + { cSourcesFiles :: [FilePath] + , cxxSourceFiles :: [FilePath] + , inputSourceFiles :: [FilePath] + , inputSourceModules :: [ModuleName] + } -- | Locate and return the 'BuildSources' required to build and link. -gbuildSources :: Verbosity - -> PackageId - -> CabalSpecVersion - -> FilePath - -> GBuildMode - -> IO BuildSources +gbuildSources + :: Verbosity + -> PackageId + -> CabalSpecVersion + -> FilePath + -> GBuildMode + -> IO BuildSources gbuildSources verbosity pkgId specVer tmpDir bm = - case bm of - GBuildExe exe -> exeSources exe - GReplExe _ exe -> exeSources exe - GBuildFLib flib -> return $ flibSources flib - GReplFLib _ flib -> return $ flibSources flib + case bm of + GBuildExe exe -> exeSources exe + GReplExe _ exe -> exeSources exe + GBuildFLib flib -> return $ flibSources flib + GReplFLib _ flib -> return $ flibSources flib where exeSources :: Executable -> IO BuildSources exeSources exe@Executable{buildInfo = bnfo, modulePath = modPath} = do @@ -1247,57 +1529,62 @@ gbuildSources verbosity pkgId specVer tmpDir bm = if isHaskell main || pkgId == fakePackageId then if specVer < CabalSpecV2_0 && (mainModName `elem` otherModNames) - then do - -- The cabal manual clearly states that `other-modules` is - -- intended for non-main modules. However, there's at least one - -- important package on Hackage (happy-1.19.5) which - -- violates this. We workaround this here so that we don't - -- invoke GHC with e.g. 'ghc --make Main src/Main.hs' which - -- would result in GHC complaining about duplicate Main - -- modules. - -- - -- Finally, we only enable this workaround for - -- specVersion < 2, as 'cabal-version:>=2.0' cabal files - -- have no excuse anymore to keep doing it wrong... ;-) - warn verbosity $ "Enabling workaround for Main module '" - ++ prettyShow mainModName - ++ "' listed in 'other-modules' illegally!" - - return BuildSources { - cSourcesFiles = cSources bnfo, - cxxSourceFiles = cxxSources bnfo, - inputSourceFiles = [main], - inputSourceModules = filter (/= mainModName) $ - exeModules exe - } - - else return BuildSources { - cSourcesFiles = cSources bnfo, - cxxSourceFiles = cxxSources bnfo, - inputSourceFiles = [main], - inputSourceModules = exeModules exe - } - else let (csf, cxxsf) - | isCxx main = ( cSources bnfo, main : cxxSources bnfo) - -- if main is not a Haskell source - -- and main is not a C++ source - -- then we assume that it is a C source - | otherwise = (main : cSources bnfo, cxxSources bnfo) - - in return BuildSources { - cSourcesFiles = csf, - cxxSourceFiles = cxxsf, - inputSourceFiles = [], - inputSourceModules = exeModules exe - } + then do + -- The cabal manual clearly states that `other-modules` is + -- intended for non-main modules. However, there's at least one + -- important package on Hackage (happy-1.19.5) which + -- violates this. We workaround this here so that we don't + -- invoke GHC with e.g. 'ghc --make Main src/Main.hs' which + -- would result in GHC complaining about duplicate Main + -- modules. + -- + -- Finally, we only enable this workaround for + -- specVersion < 2, as 'cabal-version:>=2.0' cabal files + -- have no excuse anymore to keep doing it wrong... ;-) + warn verbosity $ + "Enabling workaround for Main module '" + ++ prettyShow mainModName + ++ "' listed in 'other-modules' illegally!" + + return + BuildSources + { cSourcesFiles = cSources bnfo + , cxxSourceFiles = cxxSources bnfo + , inputSourceFiles = [main] + , inputSourceModules = + filter (/= mainModName) $ + exeModules exe + } + else + return + BuildSources + { cSourcesFiles = cSources bnfo + , cxxSourceFiles = cxxSources bnfo + , inputSourceFiles = [main] + , inputSourceModules = exeModules exe + } + else + let (csf, cxxsf) + | isCxx main = (cSources bnfo, main : cxxSources bnfo) + -- if main is not a Haskell source + -- and main is not a C++ source + -- then we assume that it is a C source + | otherwise = (main : cSources bnfo, cxxSources bnfo) + in return + BuildSources + { cSourcesFiles = csf + , cxxSourceFiles = cxxsf + , inputSourceFiles = [] + , inputSourceModules = exeModules exe + } flibSources :: ForeignLib -> BuildSources flibSources flib@ForeignLib{foreignLibBuildInfo = bnfo} = - BuildSources { - cSourcesFiles = cSources bnfo, - cxxSourceFiles = cxxSources bnfo, - inputSourceFiles = [], - inputSourceModules = foreignLibModules flib + BuildSources + { cSourcesFiles = cSources bnfo + , cxxSourceFiles = cxxSources bnfo + , inputSourceFiles = [] + , inputSourceModules = foreignLibModules flib } isCxx :: FilePath -> Bool @@ -1309,31 +1596,36 @@ isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"] replNoLoad :: Ord a => ReplOptions -> NubListR a -> NubListR a replNoLoad replFlags l - | replOptionsNoLoad replFlags == Flag True = mempty - | otherwise = l + | replOptionsNoLoad replFlags == Flag True = mempty + | otherwise = l -- | Generic build function. See comment for 'GBuildMode'. -gbuild :: Verbosity -> Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> GBuildMode -> ComponentLocalBuildInfo -> IO () +gbuild + :: Verbosity + -> Flag (Maybe Int) + -> PackageDescription + -> LocalBuildInfo + -> GBuildMode + -> ComponentLocalBuildInfo + -> IO () gbuild verbosity numJobs pkg_descr lbi bm clbi = do (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) let replFlags = case bm of - GReplExe flags _ -> flags - GReplFLib flags _ -> flags - GBuildExe{} -> mempty - GBuildFLib{} -> mempty - comp = compiler lbi - platform = hostPlatform lbi - implInfo = getImplInfo comp + GReplExe flags _ -> flags + GReplFLib flags _ -> flags + GBuildExe{} -> mempty + GBuildFLib{} -> mempty + comp = compiler lbi + platform = hostPlatform lbi + implInfo = getImplInfo comp runGhcProg = runGHC verbosity ghcProg comp platform let bnfo = gbuildInfo bm -- the name that GHC really uses (e.g., with .exe on Windows for executables) let targetName = gbuildTargetName lbi bm - let targetDir = buildDir lbi (gbuildName bm) - let tmpDir = targetDir (gbuildName bm ++ "-tmp") + let targetDir = buildDir lbi (gbuildName bm) + let tmpDir = targetDir (gbuildName bm ++ "-tmp") createDirectoryIfMissingVerbose verbosity True targetDir createDirectoryIfMissingVerbose verbosity True tmpDir @@ -1345,9 +1637,9 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do let isCoverageEnabled = exeCoverage lbi distPref = fromFlag $ configDistPref $ configFlags lbi hpcdir way - | gbuildIsRepl bm = mempty -- HPC is not supported in ghci + | gbuildIsRepl bm = mempty -- HPC is not supported in ghci | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way (gbuildName bm) - | otherwise = mempty + | otherwise = mempty rpaths <- getRPaths lbi clbi buildSources <- gbuildSources verbosity (package pkg_descr) (specVersion pkg_descr) tmpDir bm @@ -1356,107 +1648,137 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do cleanedExtraLibDirs <- filterM doesDirectoryExist (extraLibDirs bnfo) cleanedExtraLibDirsStatic <- filterM doesDirectoryExist (extraLibDirsStatic bnfo) - - let cSrcs = cSourcesFiles buildSources - cxxSrcs = cxxSourceFiles buildSources - inputFiles = inputSourceFiles buildSources - inputModules = inputSourceModules buildSources - isGhcDynamic = isDynamic comp + let cSrcs = cSourcesFiles buildSources + cxxSrcs = cxxSourceFiles buildSources + inputFiles = inputSourceFiles buildSources + inputModules = inputSourceModules buildSources + isGhcDynamic = isDynamic comp dynamicTooSupported = supportsDynamicToo comp - cLikeObjs = map (`replaceExtension` objExtension) cSrcs - cxxObjs = map (`replaceExtension` objExtension) cxxSrcs - needDynamic = gbuildNeedDynamic lbi bm - needProfiling = withProfExe lbi - - -- build executables - baseOpts = (componentGhcOptions verbosity lbi bnfo clbi tmpDir) - `mappend` mempty { - ghcOptMode = toFlag GhcModeMake, - ghcOptInputFiles = toNubListR $ if package pkg_descr == fakePackageId - then filter isHaskell inputFiles - else inputFiles, - ghcOptInputScripts = toNubListR $ if package pkg_descr == fakePackageId - then filter (not . isHaskell) inputFiles - else [], - ghcOptInputModules = toNubListR inputModules - } - staticOpts = baseOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticOnly, - ghcOptHPCDir = hpcdir Hpc.Vanilla - } - profOpts = baseOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptProfilingAuto = Internal.profDetailLevelFlag False - (withProfExeDetail lbi), - ghcOptHiSuffix = toFlag "p_hi", - ghcOptObjSuffix = toFlag "p_o", - ghcOptExtra = hcProfOptions GHC bnfo, - ghcOptHPCDir = hpcdir Hpc.Prof - } - dynOpts = baseOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - -- TODO: Does it hurt to set -fPIC for executables? - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "dyn_hi", - ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcSharedOptions GHC bnfo, - ghcOptHPCDir = hpcdir Hpc.Dyn - } - dynTooOpts = staticOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, - ghcOptDynHiSuffix = toFlag "dyn_hi", - ghcOptDynObjSuffix = toFlag "dyn_o", - ghcOptHPCDir = hpcdir Hpc.Dyn - } - linkerOpts = mempty { - ghcOptLinkOptions = PD.ldOptions bnfo - ++ [ "-static" - | withFullyStaticExe lbi ] - -- Pass extra `ld-options` given - -- through to GHC's linker. - ++ maybe [] programOverrideArgs - (lookupProgram ldProgram (withPrograms lbi)), - ghcOptLinkLibs = if withFullyStaticExe lbi - then extraLibsStatic bnfo - else extraLibs bnfo, - ghcOptLinkLibPath = toNubListR $ - if withFullyStaticExe lbi - then cleanedExtraLibDirsStatic - else cleanedExtraLibDirs, - ghcOptLinkFrameworks = toNubListR $ - PD.frameworks bnfo, - ghcOptLinkFrameworkDirs = toNubListR $ - PD.extraFrameworkDirs bnfo, - ghcOptInputFiles = toNubListR - [tmpDir x | x <- cLikeObjs ++ cxxObjs] - } - dynLinkerOpts = mempty { - ghcOptRPaths = rpaths, - ghcOptInputFiles = toNubListR - [tmpDir x | x <- cLikeObjs ++ cxxObjs] - } - replOpts = baseOpts { - ghcOptExtra = Internal.filterGhciFlags - (ghcOptExtra baseOpts) - <> replOptionsFlags replFlags, - ghcOptInputModules = replNoLoad replFlags (ghcOptInputModules baseOpts), - ghcOptInputFiles = replNoLoad replFlags (ghcOptInputFiles baseOpts) - } - -- For a normal compile we do separate invocations of ghc for - -- compiling as for linking. But for repl we have to do just - -- the one invocation, so that one has to include all the - -- linker stuff too, like -l flags and any .o files from C - -- files etc. - `mappend` linkerOpts - `mappend` mempty { - ghcOptMode = toFlag GhcModeInteractive, - ghcOptOptimisation = toFlag GhcNoOptimisation - } - commonOpts | needProfiling = profOpts - | needDynamic = dynOpts - | otherwise = staticOpts - compileOpts | useDynToo = dynTooOpts - | otherwise = commonOpts + cLikeObjs = map (`replaceExtension` objExtension) cSrcs + cxxObjs = map (`replaceExtension` objExtension) cxxSrcs + needDynamic = gbuildNeedDynamic lbi bm + needProfiling = withProfExe lbi + + -- build executables + baseOpts = + (componentGhcOptions verbosity lbi bnfo clbi tmpDir) + `mappend` mempty + { ghcOptMode = toFlag GhcModeMake + , ghcOptInputFiles = + toNubListR $ + if package pkg_descr == fakePackageId + then filter isHaskell inputFiles + else inputFiles + , ghcOptInputScripts = + toNubListR $ + if package pkg_descr == fakePackageId + then filter (not . isHaskell) inputFiles + else [] + , ghcOptInputModules = toNubListR inputModules + } + staticOpts = + baseOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcStaticOnly + , ghcOptHPCDir = hpcdir Hpc.Vanilla + } + profOpts = + baseOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + , ghcOptProfilingAuto = + Internal.profDetailLevelFlag + False + (withProfExeDetail lbi) + , ghcOptHiSuffix = toFlag "p_hi" + , ghcOptObjSuffix = toFlag "p_o" + , ghcOptExtra = hcProfOptions GHC bnfo + , ghcOptHPCDir = hpcdir Hpc.Prof + } + dynOpts = + baseOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcDynamicOnly + , -- TODO: Does it hurt to set -fPIC for executables? + ghcOptFPic = toFlag True + , ghcOptHiSuffix = toFlag "dyn_hi" + , ghcOptObjSuffix = toFlag "dyn_o" + , ghcOptExtra = hcSharedOptions GHC bnfo + , ghcOptHPCDir = hpcdir Hpc.Dyn + } + dynTooOpts = + staticOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic + , ghcOptDynHiSuffix = toFlag "dyn_hi" + , ghcOptDynObjSuffix = toFlag "dyn_o" + , ghcOptHPCDir = hpcdir Hpc.Dyn + } + linkerOpts = + mempty + { ghcOptLinkOptions = + PD.ldOptions bnfo + ++ [ "-static" + | withFullyStaticExe lbi + ] + -- Pass extra `ld-options` given + -- through to GHC's linker. + ++ maybe + [] + programOverrideArgs + (lookupProgram ldProgram (withPrograms lbi)) + , ghcOptLinkLibs = + if withFullyStaticExe lbi + then extraLibsStatic bnfo + else extraLibs bnfo + , ghcOptLinkLibPath = + toNubListR $ + if withFullyStaticExe lbi + then cleanedExtraLibDirsStatic + else cleanedExtraLibDirs + , ghcOptLinkFrameworks = + toNubListR $ + PD.frameworks bnfo + , ghcOptLinkFrameworkDirs = + toNubListR $ + PD.extraFrameworkDirs bnfo + , ghcOptInputFiles = + toNubListR + [tmpDir x | x <- cLikeObjs ++ cxxObjs] + } + dynLinkerOpts = + mempty + { ghcOptRPaths = rpaths + , ghcOptInputFiles = + toNubListR + [tmpDir x | x <- cLikeObjs ++ cxxObjs] + } + replOpts = + baseOpts + { ghcOptExtra = + Internal.filterGhciFlags + (ghcOptExtra baseOpts) + <> replOptionsFlags replFlags + , ghcOptInputModules = replNoLoad replFlags (ghcOptInputModules baseOpts) + , ghcOptInputFiles = replNoLoad replFlags (ghcOptInputFiles baseOpts) + } + -- For a normal compile we do separate invocations of ghc for + -- compiling as for linking. But for repl we have to do just + -- the one invocation, so that one has to include all the + -- linker stuff too, like -l flags and any .o files from C + -- files etc. + `mappend` linkerOpts + `mappend` mempty + { ghcOptMode = toFlag GhcModeInteractive + , ghcOptOptimisation = toFlag GhcNoOptimisation + } + commonOpts + | needProfiling = profOpts + | needDynamic = dynOpts + | otherwise = staticOpts + compileOpts + | useDynToo = dynTooOpts + | otherwise = commonOpts withStaticExe = not needProfiling && not needDynamic -- For building exe's that use TH with -prof or -dynamic we actually have @@ -1468,171 +1790,218 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do -- need to be .dyn_o instead of .o. doingTH = usesTemplateHaskellOrQQ bnfo -- Should we use -dynamic-too instead of compiling twice? - useDynToo = dynamicTooSupported && isGhcDynamic - && doingTH && withStaticExe - && null (hcSharedOptions GHC bnfo) - compileTHOpts | isGhcDynamic = dynOpts - | otherwise = staticOpts + useDynToo = + dynamicTooSupported + && isGhcDynamic + && doingTH + && withStaticExe + && null (hcSharedOptions GHC bnfo) + compileTHOpts + | isGhcDynamic = dynOpts + | otherwise = staticOpts compileForTH | gbuildIsRepl bm = False - | useDynToo = False - | isGhcDynamic = doingTH && (needProfiling || withStaticExe) - | otherwise = doingTH && (needProfiling || needDynamic) + | useDynToo = False + | isGhcDynamic = doingTH && (needProfiling || withStaticExe) + | otherwise = doingTH && (needProfiling || needDynamic) - -- Build static/dynamic object files for TH, if needed. + -- Build static/dynamic object files for TH, if needed. when compileForTH $ - runGhcProg compileTHOpts { ghcOptNoLink = toFlag True - , ghcOptNumJobs = numJobs } + runGhcProg + compileTHOpts + { ghcOptNoLink = toFlag True + , ghcOptNumJobs = numJobs + } -- Do not try to build anything if there are no input files. -- This can happen if the cabal file ends up with only cSrcs -- but no Haskell modules. - unless ((null inputFiles && null inputModules) - || gbuildIsRepl bm) $ - runGhcProg compileOpts { ghcOptNoLink = toFlag True - , ghcOptNumJobs = numJobs } + unless + ( (null inputFiles && null inputModules) + || gbuildIsRepl bm + ) + $ runGhcProg + compileOpts + { ghcOptNoLink = toFlag True + , ghcOptNumJobs = numJobs + } -- build any C++ sources unless (null cxxSrcs) $ do - info verbosity "Building C++ Sources..." - sequence_ - [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo - lbi bnfo clbi tmpDir filename - vanillaCxxOpts = if isGhcDynamic - -- Dynamic GHC requires C++ sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCxxOpts { ghcOptFPic = toFlag True } - else baseCxxOpts - profCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True - } - sharedCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly - } - opts | needProfiling = profCxxOpts - | needDynamic = sharedCxxOpts - | otherwise = vanillaCxxOpts - -- TODO: Placing all Haskell, C, & C++ objects in a single directory - -- Has the potential for file collisions. In general we would - -- consider this a user error. However, we should strive to - -- add a warning if this occurs. - odir = fromFlag (ghcOptObjDir opts) - createDirectoryIfMissingVerbose verbosity True odir - needsRecomp <- checkNeedsRecompilation filename opts - when needsRecomp $ - runGhcProg opts - | filename <- cxxSrcs ] + info verbosity "Building C++ Sources..." + sequence_ + [ do + let baseCxxOpts = + Internal.componentCxxGhcOptions + verbosity + implInfo + lbi + bnfo + clbi + tmpDir + filename + vanillaCxxOpts = + if isGhcDynamic + then -- Dynamic GHC requires C++ sources to be built + -- with -fPIC for REPL to work. See #2207. + baseCxxOpts{ghcOptFPic = toFlag True} + else baseCxxOpts + profCxxOpts = + vanillaCxxOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + } + sharedCxxOpts = + vanillaCxxOpts + `mappend` mempty + { ghcOptFPic = toFlag True + , ghcOptDynLinkMode = toFlag GhcDynamicOnly + } + opts + | needProfiling = profCxxOpts + | needDynamic = sharedCxxOpts + | otherwise = vanillaCxxOpts + -- TODO: Placing all Haskell, C, & C++ objects in a single directory + -- Has the potential for file collisions. In general we would + -- consider this a user error. However, we should strive to + -- add a warning if this occurs. + odir = fromFlag (ghcOptObjDir opts) + createDirectoryIfMissingVerbose verbosity True odir + needsRecomp <- checkNeedsRecompilation filename opts + when needsRecomp $ + runGhcProg opts + | filename <- cxxSrcs + ] -- build any C sources unless (null cSrcs) $ do - info verbosity "Building C Sources..." - sequence_ - [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo - lbi bnfo clbi tmpDir filename - vanillaCcOpts = if isGhcDynamic - -- Dynamic GHC requires C sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCcOpts { ghcOptFPic = toFlag True } - else baseCcOpts - profCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True - } - sharedCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly - } - opts | needProfiling = profCcOpts - | needDynamic = sharedCcOpts - | otherwise = vanillaCcOpts - odir = fromFlag (ghcOptObjDir opts) - createDirectoryIfMissingVerbose verbosity True odir - needsRecomp <- checkNeedsRecompilation filename opts - when needsRecomp $ - runGhcProg opts - | filename <- cSrcs ] + info verbosity "Building C Sources..." + sequence_ + [ do + let baseCcOpts = + Internal.componentCcGhcOptions + verbosity + implInfo + lbi + bnfo + clbi + tmpDir + filename + vanillaCcOpts = + if isGhcDynamic + then -- Dynamic GHC requires C sources to be built + -- with -fPIC for REPL to work. See #2207. + baseCcOpts{ghcOptFPic = toFlag True} + else baseCcOpts + profCcOpts = + vanillaCcOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + } + sharedCcOpts = + vanillaCcOpts + `mappend` mempty + { ghcOptFPic = toFlag True + , ghcOptDynLinkMode = toFlag GhcDynamicOnly + } + opts + | needProfiling = profCcOpts + | needDynamic = sharedCcOpts + | otherwise = vanillaCcOpts + odir = fromFlag (ghcOptObjDir opts) + createDirectoryIfMissingVerbose verbosity True odir + needsRecomp <- checkNeedsRecompilation filename opts + when needsRecomp $ + runGhcProg opts + | filename <- cSrcs + ] -- TODO: problem here is we need the .c files built first, so we can load them -- with ghci, but .c files can depend on .h files generated by ghc by ffi -- exports. case bm of - GReplExe _ _ -> runGhcProg replOpts + GReplExe _ _ -> runGhcProg replOpts GReplFLib _ _ -> runGhcProg replOpts GBuildExe _ -> do - let linkOpts = commonOpts - `mappend` linkerOpts - `mappend` mempty { - ghcOptLinkNoHsMain = toFlag (null inputFiles) - } - `mappend` (if withDynExe lbi then dynLinkerOpts else mempty) + let linkOpts = + commonOpts + `mappend` linkerOpts + `mappend` mempty + { ghcOptLinkNoHsMain = toFlag (null inputFiles) + } + `mappend` (if withDynExe lbi then dynLinkerOpts else mempty) info verbosity "Linking..." -- Work around old GHCs not relinking in this -- situation, see #3294 let target = targetDir targetName - when (compilerVersion comp < mkVersion [7,7]) $ do + when (compilerVersion comp < mkVersion [7, 7]) $ do e <- doesFileExist target when e (removeFile target) - runGhcProg linkOpts { ghcOptOutputFile = toFlag target } + runGhcProg linkOpts{ghcOptOutputFile = toFlag target} GBuildFLib flib -> do - let -- Instruct GHC to link against libHSrts. - rtsLinkOpts :: GhcOptions - rtsLinkOpts - | supportsFLinkRts = - mempty { - ghcOptLinkRts = toFlag True - } - | otherwise = - mempty { - ghcOptLinkLibs = rtsOptLinkLibs, - ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo - } - where - threaded = hasThreaded (gbuildInfo bm) - supportsFLinkRts = compilerVersion comp >= mkVersion [9,0] - rtsInfo = extractRtsInfo lbi - rtsOptLinkLibs = [ - if needDynamic - then if threaded - then dynRtsThreadedLib (rtsDynamicInfo rtsInfo) - else dynRtsVanillaLib (rtsDynamicInfo rtsInfo) - else if threaded - then statRtsThreadedLib (rtsStaticInfo rtsInfo) - else statRtsVanillaLib (rtsStaticInfo rtsInfo) - ] - - - linkOpts :: GhcOptions - linkOpts = case foreignLibType flib of - ForeignLibNativeShared -> - commonOpts + let + -- Instruct GHC to link against libHSrts. + rtsLinkOpts :: GhcOptions + rtsLinkOpts + | supportsFLinkRts = + mempty + { ghcOptLinkRts = toFlag True + } + | otherwise = + mempty + { ghcOptLinkLibs = rtsOptLinkLibs + , ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo + } + where + threaded = hasThreaded (gbuildInfo bm) + supportsFLinkRts = compilerVersion comp >= mkVersion [9, 0] + rtsInfo = extractRtsInfo lbi + rtsOptLinkLibs = + [ if needDynamic + then + if threaded + then dynRtsThreadedLib (rtsDynamicInfo rtsInfo) + else dynRtsVanillaLib (rtsDynamicInfo rtsInfo) + else + if threaded + then statRtsThreadedLib (rtsStaticInfo rtsInfo) + else statRtsVanillaLib (rtsStaticInfo rtsInfo) + ] + + linkOpts :: GhcOptions + linkOpts = case foreignLibType flib of + ForeignLibNativeShared -> + commonOpts `mappend` linkerOpts `mappend` dynLinkerOpts `mappend` rtsLinkOpts - `mappend` mempty { - ghcOptLinkNoHsMain = toFlag True, - ghcOptShared = toFlag True, - ghcOptFPic = toFlag True, - ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm + `mappend` mempty + { ghcOptLinkNoHsMain = toFlag True + , ghcOptShared = toFlag True + , ghcOptFPic = toFlag True + , ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm } -- See Note [RPATH] - `mappend` ifNeedsRPathWorkaround lbi mempty { - ghcOptLinkOptions = ["-Wl,--no-as-needed"] - , ghcOptLinkLibs = ["ffi"] - } - ForeignLibNativeStatic -> - -- this should be caught by buildFLib - -- (and if we do implement this, we probably don't even want to call - -- ghc here, but rather Ar.createArLibArchive or something) - cabalBug "static libraries not yet implemented" - ForeignLibTypeUnknown -> - cabalBug "unknown foreign lib type" + `mappend` ifNeedsRPathWorkaround + lbi + mempty + { ghcOptLinkOptions = ["-Wl,--no-as-needed"] + , ghcOptLinkLibs = ["ffi"] + } + ForeignLibNativeStatic -> + -- this should be caught by buildFLib + -- (and if we do implement this, we probably don't even want to call + -- ghc here, but rather Ar.createArLibArchive or something) + cabalBug "static libraries not yet implemented" + ForeignLibTypeUnknown -> + cabalBug "unknown foreign lib type" -- We build under a (potentially) different filename to set a -- soname on supported platforms. See also the note for -- @flibBuildName@. info verbosity "Linking..." let buildName = flibBuildName lbi flib - runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir buildName) } + runGhcProg linkOpts{ghcOptOutputFile = toFlag (targetDir buildName)} renameFile (targetDir buildName) (targetDir targetName) {- @@ -1709,32 +2078,32 @@ ifNeedsRPathWorkaround :: Monoid a => LocalBuildInfo -> a -> a ifNeedsRPathWorkaround lbi a = case hostPlatform lbi of Platform _ Linux -> a - _otherwise -> mempty - -data DynamicRtsInfo = DynamicRtsInfo { - dynRtsVanillaLib :: FilePath - , dynRtsThreadedLib :: FilePath - , dynRtsDebugLib :: FilePath - , dynRtsEventlogLib :: FilePath - , dynRtsThreadedDebugLib :: FilePath + _otherwise -> mempty + +data DynamicRtsInfo = DynamicRtsInfo + { dynRtsVanillaLib :: FilePath + , dynRtsThreadedLib :: FilePath + , dynRtsDebugLib :: FilePath + , dynRtsEventlogLib :: FilePath + , dynRtsThreadedDebugLib :: FilePath , dynRtsThreadedEventlogLib :: FilePath } -data StaticRtsInfo = StaticRtsInfo { - statRtsVanillaLib :: FilePath - , statRtsThreadedLib :: FilePath - , statRtsDebugLib :: FilePath - , statRtsEventlogLib :: FilePath - , statRtsThreadedDebugLib :: FilePath - , statRtsThreadedEventlogLib :: FilePath - , statRtsProfilingLib :: FilePath +data StaticRtsInfo = StaticRtsInfo + { statRtsVanillaLib :: FilePath + , statRtsThreadedLib :: FilePath + , statRtsDebugLib :: FilePath + , statRtsEventlogLib :: FilePath + , statRtsThreadedDebugLib :: FilePath + , statRtsThreadedEventlogLib :: FilePath + , statRtsProfilingLib :: FilePath , statRtsThreadedProfilingLib :: FilePath } -data RtsInfo = RtsInfo { - rtsDynamicInfo :: DynamicRtsInfo - , rtsStaticInfo :: StaticRtsInfo - , rtsLibPaths :: [FilePath] +data RtsInfo = RtsInfo + { rtsDynamicInfo :: DynamicRtsInfo + , rtsStaticInfo :: StaticRtsInfo + , rtsLibPaths :: [FilePath] } -- | Extract (and compute) information about the RTS library @@ -1745,65 +2114,73 @@ data RtsInfo = RtsInfo { -- doesn't really help. extractRtsInfo :: LocalBuildInfo -> RtsInfo extractRtsInfo lbi = - case PackageIndex.lookupPackageName - (installedPkgs lbi) (mkPackageName "rts") of - [(_, [rts])] -> aux rts - _otherwise -> error "No (or multiple) ghc rts package is registered" + case PackageIndex.lookupPackageName + (installedPkgs lbi) + (mkPackageName "rts") of + [(_, [rts])] -> aux rts + _otherwise -> error "No (or multiple) ghc rts package is registered" where aux :: InstalledPackageInfo -> RtsInfo - aux rts = RtsInfo { - rtsDynamicInfo = DynamicRtsInfo { - dynRtsVanillaLib = withGhcVersion "HSrts" - , dynRtsThreadedLib = withGhcVersion "HSrts_thr" - , dynRtsDebugLib = withGhcVersion "HSrts_debug" - , dynRtsEventlogLib = withGhcVersion "HSrts_l" - , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug" - , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l" - } - , rtsStaticInfo = StaticRtsInfo { - statRtsVanillaLib = "HSrts" - , statRtsThreadedLib = "HSrts_thr" - , statRtsDebugLib = "HSrts_debug" - , statRtsEventlogLib = "HSrts_l" - , statRtsThreadedDebugLib = "HSrts_thr_debug" - , statRtsThreadedEventlogLib = "HSrts_thr_l" - , statRtsProfilingLib = "HSrts_p" - , statRtsThreadedProfilingLib = "HSrts_thr_p" - } - , rtsLibPaths = InstalledPackageInfo.libraryDirs rts - } + aux rts = + RtsInfo + { rtsDynamicInfo = + DynamicRtsInfo + { dynRtsVanillaLib = withGhcVersion "HSrts" + , dynRtsThreadedLib = withGhcVersion "HSrts_thr" + , dynRtsDebugLib = withGhcVersion "HSrts_debug" + , dynRtsEventlogLib = withGhcVersion "HSrts_l" + , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug" + , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l" + } + , rtsStaticInfo = + StaticRtsInfo + { statRtsVanillaLib = "HSrts" + , statRtsThreadedLib = "HSrts_thr" + , statRtsDebugLib = "HSrts_debug" + , statRtsEventlogLib = "HSrts_l" + , statRtsThreadedDebugLib = "HSrts_thr_debug" + , statRtsThreadedEventlogLib = "HSrts_thr_l" + , statRtsProfilingLib = "HSrts_p" + , statRtsThreadedProfilingLib = "HSrts_thr_p" + } + , rtsLibPaths = InstalledPackageInfo.libraryDirs rts + } withGhcVersion = (++ ("-ghc" ++ prettyShow (compilerVersion (compiler lbi)))) -- | Returns True if the modification date of the given source file is newer than -- the object file we last compiled for it, or if no object file exists yet. checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool checkNeedsRecompilation filename opts = filename `moreRecentFile` oname - where oname = getObjectFileName filename opts + where + oname = getObjectFileName filename opts -- | Finds the object file name of the given source file getObjectFileName :: FilePath -> GhcOptions -> FilePath getObjectFileName filename opts = oname - where odir = fromFlag (ghcOptObjDir opts) - oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts) - oname = odir replaceExtension filename oext + where + odir = fromFlag (ghcOptObjDir opts) + oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts) + oname = odir replaceExtension filename oext -- | Calculate the RPATHs for the component we are building. -- -- Calculates relative RPATHs when 'relocatable' is set. -getRPaths :: LocalBuildInfo - -> ComponentLocalBuildInfo -- ^ Component we are building - -> IO (NubListR FilePath) +getRPaths + :: LocalBuildInfo + -> ComponentLocalBuildInfo + -- ^ Component we are building + -> IO (NubListR FilePath) getRPaths lbi clbi | supportRPaths hostOS = do - libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi - let hostPref = case hostOS of - OSX -> "@loader_path" - _ -> "$ORIGIN" - relPath p = if isRelative p then hostPref p else p - rpaths = toNubListR (map relPath libraryPaths) - return rpaths + libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi + let hostPref = case hostOS of + OSX -> "@loader_path" + _ -> "$ORIGIN" + relPath p = if isRelative p then hostPref p else p + rpaths = toNubListR (map relPath libraryPaths) + return rpaths where (Platform _ hostOS) = hostPlatform lbi - compid = compilerId . compiler $ lbi + compid = compilerId . compiler $ lbi -- The list of RPath-supported operating systems below reflects the -- platforms on which Cabal's RPATH handling is tested. It does _NOT_ @@ -1812,29 +2189,29 @@ getRPaths lbi clbi | supportRPaths hostOS = do -- E.g. when this comment was written, the *BSD operating systems were -- untested with regards to Cabal RPATH handling, and were hence set to -- 'False', while those operating systems themselves do support RPATH. - supportRPaths Linux   = True - supportRPaths Windows = False - supportRPaths OSX   = True - supportRPaths FreeBSD   = + supportRPaths Linux = True + supportRPaths Windows = False + supportRPaths OSX = True + supportRPaths FreeBSD = case compid of - CompilerId GHC ver | ver >= mkVersion [7,10,2] -> True - _ -> False - supportRPaths OpenBSD   = False - supportRPaths NetBSD   = False - supportRPaths DragonFly = False - supportRPaths Solaris = False - supportRPaths AIX = False - supportRPaths HPUX = False - supportRPaths IRIX = False - supportRPaths HaLVM = False - supportRPaths IOS = False - supportRPaths Android = False - supportRPaths Ghcjs = False - supportRPaths Wasi = False - supportRPaths Hurd = False + CompilerId GHC ver | ver >= mkVersion [7, 10, 2] -> True + _ -> False + supportRPaths OpenBSD = False + supportRPaths NetBSD = False + supportRPaths DragonFly = False + supportRPaths Solaris = False + supportRPaths AIX = False + supportRPaths HPUX = False + supportRPaths IRIX = False + supportRPaths HaLVM = False + supportRPaths IOS = False + supportRPaths Android = False + supportRPaths Ghcjs = False + supportRPaths Wasi = False + supportRPaths Hurd = False supportRPaths (OtherOS _) = False - -- Do _not_ add a default case so that we get a warning here when a new OS - -- is added. +-- Do _not_ add a default case so that we get a warning here when a new OS +-- is added. getRPaths _ _ = return mempty @@ -1848,111 +2225,151 @@ hasThreaded bi = elem "-threaded" ghc -- | Extracts a String representing a hash of the ABI of a built -- library. It can fail if the library has not yet been built. --- -libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO String +libAbiHash + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO String libAbiHash verbosity _pkg_descr lbi lib clbi = do let - libBi = libBuildInfo lib - comp = compiler lbi - platform = hostPlatform lbi - vanillaArgs0 = - (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) - `mappend` mempty { - ghcOptMode = toFlag GhcModeAbiHash, - ghcOptInputModules = toNubListR $ exposedModules lib + libBi = libBuildInfo lib + comp = compiler lbi + platform = hostPlatform lbi + vanillaArgs0 = + (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) + `mappend` mempty + { ghcOptMode = toFlag GhcModeAbiHash + , ghcOptInputModules = toNubListR $ exposedModules lib + } + vanillaArgs = + -- Package DBs unnecessary, and break ghc-cabal. See #3633 + -- BUT, put at least the global database so that 7.4 doesn't + -- break. + vanillaArgs0 + { ghcOptPackageDBs = [GlobalPackageDB] + , ghcOptPackages = mempty } - vanillaArgs = - -- Package DBs unnecessary, and break ghc-cabal. See #3633 - -- BUT, put at least the global database so that 7.4 doesn't - -- break. - vanillaArgs0 { ghcOptPackageDBs = [GlobalPackageDB] - , ghcOptPackages = mempty } - sharedArgs = vanillaArgs `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "dyn_hi", - ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcSharedOptions GHC libBi - } - profArgs = vanillaArgs `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptProfilingAuto = Internal.profDetailLevelFlag True - (withProfLibDetail lbi), - ghcOptHiSuffix = toFlag "p_hi", - ghcOptObjSuffix = toFlag "p_o", - ghcOptExtra = hcProfOptions GHC libBi - } - ghcArgs - | withVanillaLib lbi = vanillaArgs - | withSharedLib lbi = sharedArgs - | withProfLib lbi = profArgs - | otherwise = error "libAbiHash: Can't find an enabled library way" + sharedArgs = + vanillaArgs + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptFPic = toFlag True + , ghcOptHiSuffix = toFlag "dyn_hi" + , ghcOptObjSuffix = toFlag "dyn_o" + , ghcOptExtra = hcSharedOptions GHC libBi + } + profArgs = + vanillaArgs + `mappend` mempty + { ghcOptProfilingMode = toFlag True + , ghcOptProfilingAuto = + Internal.profDetailLevelFlag + True + (withProfLibDetail lbi) + , ghcOptHiSuffix = toFlag "p_hi" + , ghcOptObjSuffix = toFlag "p_o" + , ghcOptExtra = hcProfOptions GHC libBi + } + ghcArgs + | withVanillaLib lbi = vanillaArgs + | withSharedLib lbi = sharedArgs + | withProfLib lbi = profArgs + | otherwise = error "libAbiHash: Can't find an enabled library way" (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) - hash <- getProgramInvocationOutput verbosity - (ghcInvocation ghcProg comp platform ghcArgs) + hash <- + getProgramInvocationOutput + verbosity + (ghcInvocation ghcProg comp platform ghcArgs) return (takeWhile (not . isSpace) hash) -componentGhcOptions :: Verbosity -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo -> FilePath - -> GhcOptions +componentGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> GhcOptions componentGhcOptions verbosity lbi = Internal.componentGhcOptions verbosity implInfo lbi where - comp = compiler lbi + comp = compiler lbi implInfo = getImplInfo comp -componentCcGhcOptions :: Verbosity -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions +componentCcGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> FilePath + -> GhcOptions componentCcGhcOptions verbosity lbi = - Internal.componentCcGhcOptions verbosity implInfo lbi + Internal.componentCcGhcOptions verbosity implInfo lbi where - comp = compiler lbi + comp = compiler lbi implInfo = getImplInfo comp -- ----------------------------------------------------------------------------- -- Installing --- |Install executables for GHC. -installExe :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^Where to copy the files to - -> FilePath -- ^Build location - -> (FilePath, FilePath) -- ^Executable (prefix,suffix) - -> PackageDescription - -> Executable - -> IO () -installExe verbosity lbi binDir buildPref - (progprefix, progsuffix) _pkg exe = do - createDirectoryIfMissingVerbose verbosity True binDir - let exeName' = unUnqualComponentName $ exeName exe - exeFileName = exeTargetName (hostPlatform lbi) exe - fixedExeBaseName = progprefix ++ exeName' ++ progsuffix - installBinary dest = do - installExecutableFile verbosity +-- | Install executables for GHC. +installExe + :: Verbosity + -> LocalBuildInfo + -> FilePath + -- ^ Where to copy the files to + -> FilePath + -- ^ Build location + -> (FilePath, FilePath) + -- ^ Executable (prefix,suffix) + -> PackageDescription + -> Executable + -> IO () +installExe + verbosity + lbi + binDir + buildPref + (progprefix, progsuffix) + _pkg + exe = do + createDirectoryIfMissingVerbose verbosity True binDir + let exeName' = unUnqualComponentName $ exeName exe + exeFileName = exeTargetName (hostPlatform lbi) exe + fixedExeBaseName = progprefix ++ exeName' ++ progsuffix + installBinary dest = do + installExecutableFile + verbosity (buildPref exeName' exeFileName) (dest <.> exeExtension (hostPlatform lbi)) when (stripExes lbi) $ - Strip.stripExe verbosity (hostPlatform lbi) (withPrograms lbi) - (dest <.> exeExtension (hostPlatform lbi)) - installBinary (binDir fixedExeBaseName) - --- |Install foreign library for GHC. -installFLib :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^install location - -> FilePath -- ^Build location - -> PackageDescription - -> ForeignLib - -> IO () + Strip.stripExe + verbosity + (hostPlatform lbi) + (withPrograms lbi) + (dest <.> exeExtension (hostPlatform lbi)) + installBinary (binDir fixedExeBaseName) + +-- | Install foreign library for GHC. +installFLib + :: Verbosity + -> LocalBuildInfo + -> FilePath + -- ^ install location + -> FilePath + -- ^ Build location + -> PackageDescription + -> ForeignLib + -> IO () installFLib verbosity lbi targetDir builtDir _pkg flib = - install (foreignLibIsShared flib) - builtDir - targetDir - (flibTargetName lbi flib) + install + (foreignLibIsShared flib) + builtDir + targetDir + (flibTargetName lbi flib) where install isShared srcDir dstDir name = do let src = srcDir name @@ -1961,49 +2378,54 @@ installFLib verbosity lbi targetDir builtDir _pkg flib = -- TODO: Should we strip? (stripLibs lbi) if isShared then installExecutableFile verbosity src dst - else installOrdinaryFile verbosity src dst + else installOrdinaryFile verbosity src dst -- Now install appropriate symlinks if library is versioned let (Platform _ os) = hostPlatform lbi when (not (null (foreignLibVersion flib os))) $ do - when (os /= Linux) $ die' verbosity + when (os /= Linux) $ + die' + verbosity -- It should be impossible to get here. "Can't install foreign-library symlink on non-Linux OS" #ifndef mingw32_HOST_OS - -- 'createSymbolicLink file1 file2' creates a symbolic link - -- named 'file2' which points to the file 'file1'. - -- Note that we do want a symlink to 'name' rather than - -- 'dst', because the symlink will be relative to the - -- directory it's created in. - -- Finally, we first create the symlinks in a temporary - -- directory and then rename to simulate 'ln --force'. - withTempDirectory verbosity dstDir nm $ \tmpDir -> do - let link1 = flibBuildName lbi flib - link2 = "lib" ++ nm <.> "so" - createSymbolicLink name (tmpDir link1) - renameFile (tmpDir link1) (dstDir link1) - createSymbolicLink name (tmpDir link2) - renameFile (tmpDir link2) (dstDir link2) - where - nm :: String - nm = unUnqualComponentName $ foreignLibName flib + -- 'createSymbolicLink file1 file2' creates a symbolic link + -- named 'file2' which points to the file 'file1'. + -- Note that we do want a symlink to 'name' rather than + -- 'dst', because the symlink will be relative to the + -- directory it's created in. + -- Finally, we first create the symlinks in a temporary + -- directory and then rename to simulate 'ln --force'. + withTempDirectory verbosity dstDir nm $ \tmpDir -> do + let link1 = flibBuildName lbi flib + link2 = "lib" ++ nm <.> "so" + createSymbolicLink name (tmpDir link1) + renameFile (tmpDir link1) (dstDir link1) + createSymbolicLink name (tmpDir link2) + renameFile (tmpDir link2) (dstDir link2) + where + nm :: String + nm = unUnqualComponentName $ foreignLibName flib #endif /* mingw32_HOST_OS */ - --- |Install for ghc, .hi, .a and, if --with-ghci given, .o -installLib :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^install location - -> FilePath -- ^install location for dynamic libraries - -> FilePath -- ^Build location - -> PackageDescription - -> Library - -> ComponentLocalBuildInfo - -> IO () +-- | Install for ghc, .hi, .a and, if --with-ghci given, .o +installLib + :: Verbosity + -> LocalBuildInfo + -> FilePath + -- ^ install location + -> FilePath + -- ^ install location for dynamic libraries + -> FilePath + -- ^ Build location + -> PackageDescription + -> Library + -> ComponentLocalBuildInfo + -> IO () installLib verbosity lbi targetDir dynlibTargetDir _builtDir pkg lib clbi = do -- copy .hi files over: whenVanilla $ copyModuleFiles "hi" - whenProf $ copyModuleFiles "p_hi" - whenShared $ copyModuleFiles "dyn_hi" + whenProf $ copyModuleFiles "p_hi" + whenShared $ copyModuleFiles "dyn_hi" -- copy extra compilation artifacts that ghc plugins may produce copyDirectoryIfExists "extra-compilation-artifacts" @@ -2011,54 +2433,64 @@ installLib verbosity lbi targetDir dynlibTargetDir _builtDir pkg lib clbi = do -- copy the built library files over: whenHasCode $ do whenVanilla $ do - sequence_ [ installOrdinary - builtDir - targetDir - (mkGenericStaticLibName (l ++ f)) - | l <- getHSLibraryName - (componentUnitId clbi):(extraBundledLibs (libBuildInfo lib)) - , f <- "":extraLibFlavours (libBuildInfo lib) - ] + sequence_ + [ installOrdinary + builtDir + targetDir + (mkGenericStaticLibName (l ++ f)) + | l <- + getHSLibraryName + (componentUnitId clbi) + : (extraBundledLibs (libBuildInfo lib)) + , f <- "" : extraLibFlavours (libBuildInfo lib) + ] whenGHCi $ installOrdinary builtDir targetDir ghciLibName whenProf $ do installOrdinary builtDir targetDir profileLibName whenGHCi $ installOrdinary builtDir targetDir ghciProfLibName - whenShared $ if - -- The behavior for "extra-bundled-libraries" changed in version 2.5.0. - -- See ghc issue #15837 and Cabal PR #5855. - | specVersion pkg < CabalSpecV3_0 -> do - sequence_ [ installShared builtDir dynlibTargetDir - (mkGenericSharedLibName platform compiler_id (l ++ f)) - | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib) - , f <- "":extraDynLibFlavours (libBuildInfo lib) - ] - | otherwise -> do - sequence_ [ installShared - builtDir - dynlibTargetDir - (mkGenericSharedLibName + whenShared $ + if + -- The behavior for "extra-bundled-libraries" changed in version 2.5.0. + -- See ghc issue #15837 and Cabal PR #5855. + | specVersion pkg < CabalSpecV3_0 -> do + sequence_ + [ installShared + builtDir + dynlibTargetDir + (mkGenericSharedLibName platform compiler_id (l ++ f)) + | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib) + , f <- "" : extraDynLibFlavours (libBuildInfo lib) + ] + | otherwise -> do + sequence_ + [ installShared + builtDir + dynlibTargetDir + ( mkGenericSharedLibName + platform + compiler_id + (getHSLibraryName uid ++ f) + ) + | f <- "" : extraDynLibFlavours (libBuildInfo lib) + ] + sequence_ + [ do + files <- getDirectoryContents builtDir + let l' = + mkGenericSharedBundledLibName platform compiler_id - (getHSLibraryName uid ++ f)) - | f <- "":extraDynLibFlavours (libBuildInfo lib) - ] - sequence_ [ do - files <- getDirectoryContents builtDir - let l' = mkGenericSharedBundledLibName - platform - compiler_id - l - forM_ files $ \ file -> - when (l' `isPrefixOf` file) $ do - isFile <- doesFileExist (builtDir file) - when isFile $ do - installShared - builtDir - dynlibTargetDir - file - | l <- extraBundledLibs (libBuildInfo lib) - ] - + l + forM_ files $ \file -> + when (l' `isPrefixOf` file) $ do + isFile <- doesFileExist (builtDir file) + when isFile $ do + installShared + builtDir + dynlibTargetDir + file + | l <- extraBundledLibs (libBuildInfo lib) + ] where builtDir = componentBuildDir lbi clbi @@ -2070,20 +2502,24 @@ installLib verbosity lbi targetDir dynlibTargetDir _builtDir pkg lib clbi = do if isShared then installExecutableFile verbosity src dst - else installOrdinaryFile verbosity src dst + else installOrdinaryFile verbosity src dst - when (stripLibs lbi) $ Strip.stripLib verbosity - platform (withPrograms lbi) dst + when (stripLibs lbi) $ + Strip.stripLib + verbosity + platform + (withPrograms lbi) + dst installOrdinary = install False - installShared = install True + installShared = install True copyModuleFiles ext = findModuleFilesEx verbosity [builtDir] [ext] (allLibModules lib clbi) - >>= installOrdinaryFiles verbosity targetDir + >>= installOrdinaryFiles verbosity targetDir copyDirectoryIfExists dirName = do - let src = builtDir dirName + let src = builtDir dirName dst = targetDir dirName dirExists <- doesDirectoryExist src when dirExists $ copyDirectoryRecursive verbosity src dst @@ -2091,45 +2527,48 @@ installLib verbosity lbi targetDir dynlibTargetDir _builtDir pkg lib clbi = do compiler_id = compilerId (compiler lbi) platform = hostPlatform lbi uid = componentUnitId clbi - profileLibName = mkProfLibName uid - ghciLibName = Internal.mkGHCiLibName uid + profileLibName = mkProfLibName uid + ghciLibName = Internal.mkGHCiLibName uid ghciProfLibName = Internal.mkGHCiProfLibName uid - hasLib = not $ null (allLibModules lib clbi) - && null (cSources (libBuildInfo lib)) - && null (cxxSources (libBuildInfo lib)) - && null (cmmSources (libBuildInfo lib)) - && null (asmSources (libBuildInfo lib)) - && (null (jsSources (libBuildInfo lib)) || not hasJsSupport) + hasLib = + not $ + null (allLibModules lib clbi) + && null (cSources (libBuildInfo lib)) + && null (cxxSources (libBuildInfo lib)) + && null (cmmSources (libBuildInfo lib)) + && null (asmSources (libBuildInfo lib)) + && (null (jsSources (libBuildInfo lib)) || not hasJsSupport) hasJsSupport = case hostPlatform lbi of Platform JavaScript _ -> True - _ -> False + _ -> False has_code = not (componentIsIndefinite clbi) whenHasCode = when has_code whenVanilla = when (hasLib && withVanillaLib lbi) - whenProf = when (hasLib && withProfLib lbi && has_code) - whenGHCi = when (hasLib && withGHCiLib lbi && has_code) - whenShared = when (hasLib && withSharedLib lbi && has_code) + whenProf = when (hasLib && withProfLib lbi && has_code) + whenGHCi = when (hasLib && withGHCiLib lbi && has_code) + whenShared = when (hasLib && withSharedLib lbi && has_code) -- ----------------------------------------------------------------------------- -- Registering hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo -hcPkgInfo progdb = HcPkg.HcPkgInfo - { HcPkg.hcPkgProgram = ghcPkgProg - , HcPkg.noPkgDbStack = v < [6,9] - , HcPkg.noVerboseFlag = v < [6,11] - , HcPkg.flagPackageConf = v < [7,5] - , HcPkg.supportsDirDbs = v >= [6,8] - , HcPkg.requiresDirDbs = v >= [7,10] - , HcPkg.nativeMultiInstance = v >= [7,10] - , HcPkg.recacheMultiInstance = v >= [6,12] - , HcPkg.suppressFilesCheck = v >= [6,6] - } +hcPkgInfo progdb = + HcPkg.HcPkgInfo + { HcPkg.hcPkgProgram = ghcPkgProg + , HcPkg.noPkgDbStack = v < [6, 9] + , HcPkg.noVerboseFlag = v < [6, 11] + , HcPkg.flagPackageConf = v < [7, 5] + , HcPkg.supportsDirDbs = v >= [6, 8] + , HcPkg.requiresDirDbs = v >= [7, 10] + , HcPkg.nativeMultiInstance = v >= [7, 10] + , HcPkg.recacheMultiInstance = v >= [6, 12] + , HcPkg.suppressFilesCheck = v >= [6, 6] + } where - v = versionNumbers ver + v = versionNumbers ver ghcPkgProg = fromMaybe (error "GHC.hcPkgInfo: no ghc program") $ lookupProgram ghcPkgProgram progdb - ver = fromMaybe (error "GHC.hcPkgInfo: no ghc version") $ programVersion ghcPkgProg + ver = fromMaybe (error "GHC.hcPkgInfo: no ghc version") $ programVersion ghcPkgProg registerPackage :: Verbosity @@ -2139,21 +2578,29 @@ registerPackage -> HcPkg.RegisterOptions -> IO () registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions = - HcPkg.register (hcPkgInfo progdb) verbosity packageDbs - installedPkgInfo registerOptions + HcPkg.register + (hcPkgInfo progdb) + verbosity + packageDbs + installedPkgInfo + registerOptions pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath pkgRoot verbosity lbi = pkgRoot' - where + where pkgRoot' GlobalPackageDB = let ghcProg = fromMaybe (error "GHC.pkgRoot: no ghc program") $ lookupProgram ghcProgram (withPrograms lbi) - in fmap takeDirectory (getGlobalPackageDB verbosity ghcProg) + in fmap takeDirectory (getGlobalPackageDB verbosity ghcProg) pkgRoot' UserPackageDB = do appDir <- getGhcAppDir - let ver = compilerVersion (compiler lbi) - subdir = System.Info.arch ++ '-':System.Info.os - ++ '-':prettyShow ver - rootDir = appDir subdir + let ver = compilerVersion (compiler lbi) + subdir = + System.Info.arch + ++ '-' + : System.Info.os + ++ '-' + : prettyShow ver + rootDir = appDir subdir -- We must create the root directory for the user package database if it -- does not yet exists. Otherwise '${pkgroot}' will resolve to a -- directory at the time of 'ghc-pkg register', and registration will @@ -2172,4 +2619,4 @@ supportsDynamicToo :: Compiler -> Bool supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" withExt :: FilePath -> String -> FilePath -withExt fp ext = fp <.> if takeExtension fp /= ('.':ext) then ext else "" +withExt fp ext = fp <.> if takeExtension fp /= ('.' : ext) then ext else "" diff --git a/Cabal/src/Distribution/Simple/GHC/EnvironmentParser.hs b/Cabal/src/Distribution/Simple/GHC/EnvironmentParser.hs index f0ff8bc9cba..38ec484fe28 100644 --- a/Cabal/src/Distribution/Simple/GHC/EnvironmentParser.hs +++ b/Cabal/src/Distribution/Simple/GHC/EnvironmentParser.hs @@ -4,39 +4,49 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} -module Distribution.Simple.GHC.EnvironmentParser - ( parseGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc(..) ) where -import Prelude () +module Distribution.Simple.GHC.EnvironmentParser (parseGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc (..)) where + import Distribution.Compat.Prelude +import Prelude () import Distribution.Simple.Compiler - ( PackageDB(..) ) + ( PackageDB (..) + ) import Distribution.Simple.GHC.Internal - ( GhcEnvironmentFileEntry(..) ) + ( GhcEnvironmentFileEntry (..) + ) import Distribution.Types.UnitId - ( mkUnitId ) + ( mkUnitId + ) import qualified Text.Parsec as P import Text.Parsec.String - ( Parser, parseFromFile ) + ( Parser + , parseFromFile + ) parseEnvironmentFileLine :: Parser GhcEnvironmentFileEntry -parseEnvironmentFileLine = GhcEnvFileComment <$> comment - <|> GhcEnvFilePackageId <$> unitId - <|> GhcEnvFilePackageDb <$> packageDb - <|> pure GhcEnvFileClearPackageDbStack <* clearDb - where - comment = P.string "--" *> P.many (P.noneOf "\r\n") - unitId = P.try $ P.string "package-id" *> P.spaces *> - (mkUnitId <$> P.many1 (P.satisfy $ \c -> isAlphaNum c || c `elem` "-_.+")) - packageDb = (P.string "global-package-db" *> pure GlobalPackageDB) - <|> (P.string "user-package-db" *> pure UserPackageDB) - <|> (P.string "package-db" *> P.spaces *> (SpecificPackageDB <$> P.many1 (P.noneOf "\r\n") <* P.lookAhead P.endOfLine)) - clearDb = P.string "clear-package-db" +parseEnvironmentFileLine = + GhcEnvFileComment <$> comment + <|> GhcEnvFilePackageId <$> unitId + <|> GhcEnvFilePackageDb <$> packageDb + <|> pure GhcEnvFileClearPackageDbStack <* clearDb + where + comment = P.string "--" *> P.many (P.noneOf "\r\n") + unitId = + P.try $ + P.string "package-id" + *> P.spaces + *> (mkUnitId <$> P.many1 (P.satisfy $ \c -> isAlphaNum c || c `elem` "-_.+")) + packageDb = + (P.string "global-package-db" *> pure GlobalPackageDB) + <|> (P.string "user-package-db" *> pure UserPackageDB) + <|> (P.string "package-db" *> P.spaces *> (SpecificPackageDB <$> P.many1 (P.noneOf "\r\n") <* P.lookAhead P.endOfLine)) + clearDb = P.string "clear-package-db" newtype ParseErrorExc = ParseErrorExc P.ParseError - deriving (Show, Typeable) + deriving (Show, Typeable) instance Exception ParseErrorExc @@ -45,5 +55,5 @@ parseGhcEnvironmentFile = parseEnvironmentFileLine `P.sepEndBy` P.endOfLine <* P readGhcEnvironmentFile :: FilePath -> IO [GhcEnvironmentFileEntry] readGhcEnvironmentFile path = - either (throwIO . ParseErrorExc) return =<< - parseFromFile parseGhcEnvironmentFile path + either (throwIO . ParseErrorExc) return + =<< parseFromFile parseGhcEnvironmentFile path diff --git a/Cabal/src/Distribution/Simple/GHC/ImplInfo.hs b/Cabal/src/Distribution/Simple/GHC/ImplInfo.hs index ea95aac50e6..04aaa598594 100644 --- a/Cabal/src/Distribution/Simple/GHC/ImplInfo.hs +++ b/Cabal/src/Distribution/Simple/GHC/ImplInfo.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.GHC.ImplInfo -- @@ -8,92 +9,115 @@ -- This module contains the data structure describing invocation -- details for a GHC or GHC-derived compiler, such as supported flags -- and workarounds for bugs. +module Distribution.Simple.GHC.ImplInfo + ( GhcImplInfo (..) + , getImplInfo + , ghcVersionImplInfo + , ghcjsVersionImplInfo + ) where -module Distribution.Simple.GHC.ImplInfo ( - GhcImplInfo(..), getImplInfo, - ghcVersionImplInfo, ghcjsVersionImplInfo - ) where - -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Simple.Compiler import Distribution.Version -{- | - Information about features and quirks of a GHC-based implementation. - - Compiler flavors based on GHC behave similarly enough that some of - the support code for them is shared. Every implementation has its - own peculiarities, that may or may not be a direct result of the - underlying GHC version. This record keeps track of these differences. - - All shared code (i.e. everything not in the Distribution.Simple.FLAVOR - module) should use implementation info rather than version numbers - to test for supported features. --} - +-- | +-- Information about features and quirks of a GHC-based implementation. +-- +-- Compiler flavors based on GHC behave similarly enough that some of +-- the support code for them is shared. Every implementation has its +-- own peculiarities, that may or may not be a direct result of the +-- underlying GHC version. This record keeps track of these differences. +-- +-- All shared code (i.e. everything not in the Distribution.Simple.FLAVOR +-- module) should use implementation info rather than version numbers +-- to test for supported features. data GhcImplInfo = GhcImplInfo - { supportsHaskell2010 :: Bool -- ^ -XHaskell2010 and -XHaskell98 flags - , supportsGHC2021 :: Bool -- ^ -XGHC2021 flag - , reportsNoExt :: Bool -- ^ --supported-languages gives Ext and NoExt - , alwaysNondecIndent :: Bool -- ^ NondecreasingIndentation is always on - , flagGhciScript :: Bool -- ^ -ghci-script flag supported - , flagProfAuto :: Bool -- ^ new style -fprof-auto* flags - , flagProfLate :: Bool -- ^ fprof-late flag - , flagPackageConf :: Bool -- ^ use package-conf instead of package-db - , flagDebugInfo :: Bool -- ^ -g flag supported - , supportsDebugLevels :: Bool -- ^ supports numeric @-g@ levels - , supportsPkgEnvFiles :: Bool -- ^ picks up @.ghc.environment@ files - , flagWarnMissingHomeModules :: Bool -- ^ -Wmissing-home-modules is supported + { supportsHaskell2010 :: Bool + -- ^ -XHaskell2010 and -XHaskell98 flags + , supportsGHC2021 :: Bool + -- ^ -XGHC2021 flag + , reportsNoExt :: Bool + -- ^ --supported-languages gives Ext and NoExt + , alwaysNondecIndent :: Bool + -- ^ NondecreasingIndentation is always on + , flagGhciScript :: Bool + -- ^ -ghci-script flag supported + , flagProfAuto :: Bool + -- ^ new style -fprof-auto* flags + , flagProfLate :: Bool + -- ^ fprof-late flag + , flagPackageConf :: Bool + -- ^ use package-conf instead of package-db + , flagDebugInfo :: Bool + -- ^ -g flag supported + , supportsDebugLevels :: Bool + -- ^ supports numeric @-g@ levels + , supportsPkgEnvFiles :: Bool + -- ^ picks up @.ghc.environment@ files + , flagWarnMissingHomeModules :: Bool + -- ^ -Wmissing-home-modules is supported } getImplInfo :: Compiler -> GhcImplInfo getImplInfo comp = case compilerFlavor comp of - GHC -> ghcVersionImplInfo (compilerVersion comp) + GHC -> ghcVersionImplInfo (compilerVersion comp) GHCJS -> case compilerCompatVersion GHC comp of - Just ghcVer -> ghcjsVersionImplInfo (compilerVersion comp) ghcVer - _ -> error ("Distribution.Simple.GHC.Props.getImplProps: " ++ - "could not find GHC version for GHCJS compiler") - x -> error ("Distribution.Simple.GHC.Props.getImplProps only works" ++ - "for GHC-like compilers (GHC, GHCJS)" ++ - ", but found " ++ show x) + Just ghcVer -> ghcjsVersionImplInfo (compilerVersion comp) ghcVer + _ -> + error + ( "Distribution.Simple.GHC.Props.getImplProps: " + ++ "could not find GHC version for GHCJS compiler" + ) + x -> + error + ( "Distribution.Simple.GHC.Props.getImplProps only works" + ++ "for GHC-like compilers (GHC, GHCJS)" + ++ ", but found " + ++ show x + ) ghcVersionImplInfo :: Version -> GhcImplInfo -ghcVersionImplInfo ver = GhcImplInfo - { supportsHaskell2010 = v >= [7] - , supportsGHC2021 = v >= [9,1] - , reportsNoExt = v >= [7] - , alwaysNondecIndent = v < [7,1] - , flagGhciScript = v >= [7,2] - , flagProfAuto = v >= [7,4] - , flagProfLate = v >= [9,4] - , flagPackageConf = v < [7,5] - , flagDebugInfo = v >= [7,10] - , supportsDebugLevels = v >= [8,0] - , supportsPkgEnvFiles = v >= [8,0,1,20160901] -- broken in 8.0.1, fixed in 8.0.2 - , flagWarnMissingHomeModules = v >= [8,2] - } +ghcVersionImplInfo ver = + GhcImplInfo + { supportsHaskell2010 = v >= [7] + , supportsGHC2021 = v >= [9, 1] + , reportsNoExt = v >= [7] + , alwaysNondecIndent = v < [7, 1] + , flagGhciScript = v >= [7, 2] + , flagProfAuto = v >= [7, 4] + , flagProfLate = v >= [9, 4] + , flagPackageConf = v < [7, 5] + , flagDebugInfo = v >= [7, 10] + , supportsDebugLevels = v >= [8, 0] + , supportsPkgEnvFiles = v >= [8, 0, 1, 20160901] -- broken in 8.0.1, fixed in 8.0.2 + , flagWarnMissingHomeModules = v >= [8, 2] + } where v = versionNumbers ver -ghcjsVersionImplInfo :: Version -- ^ The GHCJS version - -> Version -- ^ The GHC version - -> GhcImplInfo -ghcjsVersionImplInfo _ghcjsver ghcver = GhcImplInfo - { supportsHaskell2010 = True - , supportsGHC2021 = True - , reportsNoExt = True - , alwaysNondecIndent = False - , flagGhciScript = True - , flagProfAuto = True - , flagProfLate = True - , flagPackageConf = False - , flagDebugInfo = False - , supportsDebugLevels = ghcv >= [8,0] - , supportsPkgEnvFiles = ghcv >= [8,0,2] --TODO: check this works in ghcjs - , flagWarnMissingHomeModules = ghcv >= [8,2] - } +ghcjsVersionImplInfo + :: Version + -- ^ The GHCJS version + -> Version + -- ^ The GHC version + -> GhcImplInfo +ghcjsVersionImplInfo _ghcjsver ghcver = + GhcImplInfo + { supportsHaskell2010 = True + , supportsGHC2021 = True + , reportsNoExt = True + , alwaysNondecIndent = False + , flagGhciScript = True + , flagProfAuto = True + , flagProfLate = True + , flagPackageConf = False + , flagDebugInfo = False + , supportsDebugLevels = ghcv >= [8, 0] + , supportsPkgEnvFiles = ghcv >= [8, 0, 2] -- TODO: check this works in ghcjs + , flagWarnMissingHomeModules = ghcv >= [8, 2] + } where ghcv = versionNumbers ghcver diff --git a/Cabal/src/Distribution/Simple/GHC/Internal.hs b/Cabal/src/Distribution/Simple/GHC/Internal.hs index 332fe9cce17..64c6faf8d37 100644 --- a/Cabal/src/Distribution/Simple/GHC/Internal.hs +++ b/Cabal/src/Distribution/Simple/GHC/Internal.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.GHC.Internal -- Copyright : Isaac Jones 2003-2007 @@ -11,156 +12,173 @@ -- -- This module contains functions shared by GHC (Distribution.Simple.GHC) -- and GHC-derived compilers. +module Distribution.Simple.GHC.Internal + ( configureToolchain + , getLanguages + , getExtensions + , targetPlatform + , getGhcInfo + , componentCcGhcOptions + , componentCmmGhcOptions + , componentCxxGhcOptions + , componentAsmGhcOptions + , componentJsGhcOptions + , componentGhcOptions + , mkGHCiLibName + , mkGHCiProfLibName + , filterGhciFlags + , ghcLookupProperty + , getHaskellObjects + , mkGhcOptPackages + , substTopDir + , checkPackageDbEnvVar + , profDetailLevelFlag + + -- * GHC platform and version strings + , ghcArchString + , ghcOsString + , ghcPlatformAndVersionString + + -- * Constructing GHC environment files + , GhcEnvironmentFileEntry (..) + , writeGhcEnvironmentFile + , simpleGhcEnvironmentFile + , ghcEnvironmentFileName + , renderGhcEnvironmentFile + , renderGhcEnvironmentFileEntry + ) where -module Distribution.Simple.GHC.Internal ( - configureToolchain, - getLanguages, - getExtensions, - targetPlatform, - getGhcInfo, - componentCcGhcOptions, - componentCmmGhcOptions, - componentCxxGhcOptions, - componentAsmGhcOptions, - componentJsGhcOptions, - componentGhcOptions, - mkGHCiLibName, - mkGHCiProfLibName, - filterGhciFlags, - ghcLookupProperty, - getHaskellObjects, - mkGhcOptPackages, - substTopDir, - checkPackageDbEnvVar, - profDetailLevelFlag, - -- * GHC platform and version strings - ghcArchString, - ghcOsString, - ghcPlatformAndVersionString, - -- * Constructing GHC environment files - GhcEnvironmentFileEntry(..), - writeGhcEnvironmentFile, - simpleGhcEnvironmentFile, - ghcEnvironmentFileName, - renderGhcEnvironmentFile, - renderGhcEnvironmentFileEntry, - ) where - -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Simple.GHC.ImplInfo -import Distribution.Types.ComponentLocalBuildInfo import Distribution.Backpack +import Distribution.Compat.Stack import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.PackageDescription import Distribution.Lex -import Distribution.Simple.Compiler -import Distribution.Simple.Program.GHC -import Distribution.Simple.Flag ( Flag, maybeToFlag, toFlag ) import qualified Distribution.ModuleName as ModuleName -import Distribution.Simple.Program +import Distribution.PackageDescription +import Distribution.Parsec (simpleParsec) +import Distribution.Pretty (prettyShow) +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler +import Distribution.Simple.Flag (Flag, maybeToFlag, toFlag) +import Distribution.Simple.GHC.ImplInfo import Distribution.Simple.LocalBuildInfo -import Distribution.Types.UnitId -import Distribution.Types.LocalBuildInfo -import Distribution.Types.TargetInfo +import Distribution.Simple.Program +import Distribution.Simple.Program.GHC import Distribution.Simple.Utils -import Distribution.Simple.BuildPaths import Distribution.System -import Distribution.Pretty ( prettyShow ) -import Distribution.Parsec ( simpleParsec ) -import Distribution.Utils.NubList ( toNubListR ) +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.LocalBuildInfo +import Distribution.Types.TargetInfo +import Distribution.Types.UnitId +import Distribution.Utils.NubList (toNubListR) +import Distribution.Utils.Path import Distribution.Verbosity -import Distribution.Compat.Stack import Distribution.Version (Version) -import Distribution.Utils.Path import Language.Haskell.Extension -import qualified Data.Map as Map import qualified Data.ByteString.Lazy.Char8 as BS -import System.Directory ( getDirectoryContents, getTemporaryDirectory ) -import System.Environment ( getEnv ) -import System.FilePath ( (), (<.>), takeExtension - , takeDirectory, takeFileName) -import System.IO ( hClose, hPutStrLn ) +import qualified Data.Map as Map +import System.Directory (getDirectoryContents, getTemporaryDirectory) +import System.Environment (getEnv) +import System.FilePath + ( takeDirectory + , takeExtension + , takeFileName + , (<.>) + , () + ) +import System.IO (hClose, hPutStrLn) targetPlatform :: [(String, String)] -> Maybe Platform targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo -- | Adjust the way we find and configure gcc and ld --- -configureToolchain :: GhcImplInfo - -> ConfiguredProgram - -> Map String String - -> ProgramDb - -> ProgramDb +configureToolchain + :: GhcImplInfo + -> ConfiguredProgram + -> Map String String + -> ProgramDb + -> ProgramDb configureToolchain _implInfo ghcProg ghcInfo = - addKnownProgram gccProgram { - programFindLocation = findProg gccProgramName extraGccPath, - programPostConf = configureGcc - } - . addKnownProgram ldProgram { - programFindLocation = findProg ldProgramName extraLdPath, - programPostConf = configureLd - } - . addKnownProgram arProgram { - programFindLocation = findProg arProgramName extraArPath - } - . addKnownProgram stripProgram { - programFindLocation = findProg stripProgramName extraStripPath - } + addKnownProgram + gccProgram + { programFindLocation = findProg gccProgramName extraGccPath + , programPostConf = configureGcc + } + . addKnownProgram + ldProgram + { programFindLocation = findProg ldProgramName extraLdPath + , programPostConf = configureLd + } + . addKnownProgram + arProgram + { programFindLocation = findProg arProgramName extraArPath + } + . addKnownProgram + stripProgram + { programFindLocation = findProg stripProgramName extraStripPath + } where compilerDir = takeDirectory (programPath ghcProg) - base_dir = takeDirectory compilerDir + base_dir = takeDirectory compilerDir mingwBinDir = base_dir "mingw" "bin" - isWindows = case buildOS of Windows -> True; _ -> False - binPrefix = "" + isWindows = case buildOS of Windows -> True; _ -> False + binPrefix = "" maybeName :: Program -> Maybe FilePath -> String - maybeName prog = maybe (programName prog) (dropExeExtension . takeFileName) + maybeName prog = maybe (programName prog) (dropExeExtension . takeFileName) - gccProgramName = maybeName gccProgram mbGccLocation - ldProgramName = maybeName ldProgram mbLdLocation - arProgramName = maybeName arProgram mbArLocation + gccProgramName = maybeName gccProgram mbGccLocation + ldProgramName = maybeName ldProgram mbLdLocation + arProgramName = maybeName arProgram mbArLocation stripProgramName = maybeName stripProgram mbStripLocation mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath] - mkExtraPath mbPath mingwPath | isWindows = mbDir ++ [mingwPath] - | otherwise = mbDir + mkExtraPath mbPath mingwPath + | isWindows = mbDir ++ [mingwPath] + | otherwise = mbDir where mbDir = maybeToList . fmap takeDirectory $ mbPath - extraGccPath = mkExtraPath mbGccLocation windowsExtraGccDir - extraLdPath = mkExtraPath mbLdLocation windowsExtraLdDir - extraArPath = mkExtraPath mbArLocation windowsExtraArDir + extraGccPath = mkExtraPath mbGccLocation windowsExtraGccDir + extraLdPath = mkExtraPath mbLdLocation windowsExtraLdDir + extraArPath = mkExtraPath mbArLocation windowsExtraArDir extraStripPath = mkExtraPath mbStripLocation windowsExtraStripDir -- on Windows finding and configuring ghc's gcc & binutils is a bit special - (windowsExtraGccDir, windowsExtraLdDir, - windowsExtraArDir, windowsExtraStripDir) = - let b = mingwBinDir binPrefix - in (b, b, b, b) - - findProg :: String -> [FilePath] - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) + ( windowsExtraGccDir + , windowsExtraLdDir + , windowsExtraArDir + , windowsExtraStripDir + ) = + let b = mingwBinDir binPrefix + in (b, b, b, b) + + findProg + :: String + -> [FilePath] + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) findProg progName extraPath v searchpath = - findProgramOnSearchPath v searchpath' progName + findProgramOnSearchPath v searchpath' progName where searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath -- Read tool locations from the 'ghc --info' output. Useful when -- cross-compiling. - mbGccLocation = Map.lookup "C compiler command" ghcInfo - mbLdLocation = Map.lookup "ld command" ghcInfo - mbArLocation = Map.lookup "ar command" ghcInfo + mbGccLocation = Map.lookup "C compiler command" ghcInfo + mbLdLocation = Map.lookup "ld command" ghcInfo + mbArLocation = Map.lookup "ar command" ghcInfo mbStripLocation = Map.lookup "strip command" ghcInfo - ccFlags = getFlags "C compiler flags" + ccFlags = getFlags "C compiler flags" -- GHC 7.8 renamed "Gcc Linker flags" to "C compiler link flags" -- and "Ld Linker flags" to "ld flags" (GHC #4862). gccLinkerFlags = getFlags "Gcc Linker flags" ++ getFlags "C compiler link flags" - ldLinkerFlags = getFlags "Ld Linker flags" ++ getFlags "ld flags" + ldLinkerFlags = getFlags "Ld Linker flags" ++ getFlags "ld flags" -- It appears that GHC 7.6 and earlier encode the tokenized flags as a -- [String] in these settings whereas later versions just encode the flags as @@ -170,364 +188,460 @@ configureToolchain _implInfo ghcProg ghcInfo = -- flags ourself. getFlags :: String -> [String] getFlags key = - case Map.lookup key ghcInfo of - Nothing -> [] - Just flags - | (flags', ""):_ <- reads flags -> flags' - | otherwise -> tokenizeQuotedWords flags + case Map.lookup key ghcInfo of + Nothing -> [] + Just flags + | (flags', "") : _ <- reads flags -> flags' + | otherwise -> tokenizeQuotedWords flags configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram configureGcc _v gccProg = do - return gccProg { - programDefaultArgs = programDefaultArgs gccProg - ++ ccFlags ++ gccLinkerFlags - } + return + gccProg + { programDefaultArgs = + programDefaultArgs gccProg + ++ ccFlags + ++ gccLinkerFlags + } configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram configureLd v ldProg = do ldProg' <- configureLd' v ldProg - return ldProg' { - programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags - } + return + ldProg' + { programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags + } -- we need to find out if ld supports the -x flag configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram configureLd' verbosity ldProg = do tempDir <- getTemporaryDirectory ldx <- withTempFile tempDir ".c" $ \testcfile testchnd -> - withTempFile tempDir ".o" $ \testofile testohnd -> do - hPutStrLn testchnd "int foo() { return 0; }" - hClose testchnd; hClose testohnd - runProgram verbosity ghcProg - [ "-hide-all-packages" - , "-c", testcfile - , "-o", testofile - ] - withTempFile tempDir ".o" $ \testofile' testohnd' -> - do - hClose testohnd' - _ <- getProgramOutput verbosity ldProg - ["-x", "-r", testofile, "-o", testofile'] - return True - `catchIO` (\_ -> return False) - `catchExit` (\_ -> return False) + withTempFile tempDir ".o" $ \testofile testohnd -> do + hPutStrLn testchnd "int foo() { return 0; }" + hClose testchnd + hClose testohnd + runProgram + verbosity + ghcProg + [ "-hide-all-packages" + , "-c" + , testcfile + , "-o" + , testofile + ] + withTempFile tempDir ".o" $ \testofile' testohnd' -> + do + hClose testohnd' + _ <- + getProgramOutput + verbosity + ldProg + ["-x", "-r", testofile, "-o", testofile'] + return True + `catchIO` (\_ -> return False) + `catchExit` (\_ -> return False) if ldx - then return ldProg { programDefaultArgs = ["-x"] } + then return ldProg{programDefaultArgs = ["-x"]} else return ldProg -getLanguages :: Verbosity -> GhcImplInfo -> ConfiguredProgram - -> IO [(Language, String)] +getLanguages + :: Verbosity + -> GhcImplInfo + -> ConfiguredProgram + -> IO [(Language, String)] getLanguages _ implInfo _ -- TODO: should be using --supported-languages rather than hard coding - | supportsGHC2021 implInfo = return - [ (GHC2021, "-XGHC2021") - , (Haskell2010, "-XHaskell2010") - , (Haskell98, "-XHaskell98") - ] - | supportsHaskell2010 implInfo = return [(Haskell98, "-XHaskell98") - ,(Haskell2010, "-XHaskell2010")] - | otherwise = return [(Haskell98, "")] - -getGhcInfo :: Verbosity -> GhcImplInfo -> ConfiguredProgram - -> IO [(String, String)] + | supportsGHC2021 implInfo = + return + [ (GHC2021, "-XGHC2021") + , (Haskell2010, "-XHaskell2010") + , (Haskell98, "-XHaskell98") + ] + | supportsHaskell2010 implInfo = + return + [ (Haskell98, "-XHaskell98") + , (Haskell2010, "-XHaskell2010") + ] + | otherwise = return [(Haskell98, "")] + +getGhcInfo + :: Verbosity + -> GhcImplInfo + -> ConfiguredProgram + -> IO [(String, String)] getGhcInfo verbosity _implInfo ghcProg = do - xs <- getProgramOutput verbosity (suppressOverrideArgs ghcProg) - ["--info"] - case reads xs of - [(i, ss)] - | all isSpace ss -> - return i - _ -> - die' verbosity "Can't parse --info output of GHC" - -getExtensions :: Verbosity -> GhcImplInfo -> ConfiguredProgram - -> IO [(Extension, Maybe String)] + xs <- + getProgramOutput + verbosity + (suppressOverrideArgs ghcProg) + ["--info"] + case reads xs of + [(i, ss)] + | all isSpace ss -> + return i + _ -> + die' verbosity "Can't parse --info output of GHC" + +getExtensions + :: Verbosity + -> GhcImplInfo + -> ConfiguredProgram + -> IO [(Extension, Maybe String)] getExtensions verbosity implInfo ghcProg = do - str <- getProgramOutput verbosity (suppressOverrideArgs ghcProg) - ["--supported-languages"] - let extStrs = if reportsNoExt implInfo - then lines str - else -- Older GHCs only gave us either Foo or NoFoo, - -- so we have to work out the other one ourselves - [ extStr'' - | extStr <- lines str - , let extStr' = case extStr of - 'N' : 'o' : xs -> xs - _ -> "No" ++ extStr - , extStr'' <- [extStr, extStr'] - ] - let extensions0 = [ (ext, Just $ "-X" ++ prettyShow ext) - | Just ext <- map simpleParsec extStrs ] - extensions1 = if alwaysNondecIndent implInfo - then -- ghc-7.2 split NondecreasingIndentation off - -- into a proper extension. Before that it - -- was always on. - -- Since it was not a proper extension, it could - -- not be turned off, hence we omit a - -- DisableExtension entry here. - (EnableExtension NondecreasingIndentation, Nothing) : - extensions0 - else extensions0 - return extensions1 - -componentCcGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions + str <- + getProgramOutput + verbosity + (suppressOverrideArgs ghcProg) + ["--supported-languages"] + let extStrs = + if reportsNoExt implInfo + then lines str + else -- Older GHCs only gave us either Foo or NoFoo, + -- so we have to work out the other one ourselves + + [ extStr'' + | extStr <- lines str + , let extStr' = case extStr of + 'N' : 'o' : xs -> xs + _ -> "No" ++ extStr + , extStr'' <- [extStr, extStr'] + ] + let extensions0 = + [ (ext, Just $ "-X" ++ prettyShow ext) + | Just ext <- map simpleParsec extStrs + ] + extensions1 = + if alwaysNondecIndent implInfo + then -- ghc-7.2 split NondecreasingIndentation off + -- into a proper extension. Before that it + -- was always on. + -- Since it was not a proper extension, it could + -- not be turned off, hence we omit a + -- DisableExtension entry here. + + (EnableExtension NondecreasingIndentation, Nothing) + : extensions0 + else extensions0 + return extensions1 + +componentCcGhcOptions + :: Verbosity + -> GhcImplInfo + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> FilePath + -> GhcOptions componentCcGhcOptions verbosity _implInfo lbi bi clbi odir filename = - mempty { - -- Respect -v0, but don't crank up verbosity on GHC if + mempty + { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptMode = toFlag GhcModeCompile, - ghcOptInputFiles = toNubListR [filename], - - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptHideAllPackages= toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, - ghcOptCcOptions = (case withOptimization lbi of - NoOptimisation -> [] - _ -> ["-O2"]) ++ - (case withDebugInfo lbi of - NoDebugInfo -> [] - MinimalDebugInfo -> ["-g1"] - NormalDebugInfo -> ["-g"] - MaximalDebugInfo -> ["-g3"]) ++ - ccOptions bi, - ghcOptCcProgram = maybeToFlag $ programPath <$> - lookupProgram gccProgram (withPrograms lbi), - ghcOptObjDir = toFlag odir, - ghcOptExtra = hcOptions GHC bi + ghcOptVerbosity = toFlag (min verbosity normal) + , ghcOptMode = toFlag GhcModeCompile + , ghcOptInputFiles = toNubListR [filename] + , ghcOptCppIncludePath = + toNubListR $ + [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + , odir + ] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- includeDirs bi] + , ghcOptHideAllPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages clbi + , ghcOptCcOptions = + ( case withOptimization lbi of + NoOptimisation -> [] + _ -> ["-O2"] + ) + ++ ( case withDebugInfo lbi of + NoDebugInfo -> [] + MinimalDebugInfo -> ["-g1"] + NormalDebugInfo -> ["-g"] + MaximalDebugInfo -> ["-g3"] + ) + ++ ccOptions bi + , ghcOptCcProgram = + maybeToFlag $ + programPath + <$> lookupProgram gccProgram (withPrograms lbi) + , ghcOptObjDir = toFlag odir + , ghcOptExtra = hcOptions GHC bi } - -componentCxxGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions +componentCxxGhcOptions + :: Verbosity + -> GhcImplInfo + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> FilePath + -> GhcOptions componentCxxGhcOptions verbosity _implInfo lbi bi clbi odir filename = - mempty { - -- Respect -v0, but don't crank up verbosity on GHC if + mempty + { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptMode = toFlag GhcModeCompile, - ghcOptInputFiles = toNubListR [filename], - - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptHideAllPackages= toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, - ghcOptCxxOptions = (case withOptimization lbi of - NoOptimisation -> [] - _ -> ["-O2"]) ++ - (case withDebugInfo lbi of - NoDebugInfo -> [] - MinimalDebugInfo -> ["-g1"] - NormalDebugInfo -> ["-g"] - MaximalDebugInfo -> ["-g3"]) ++ - cxxOptions bi, - ghcOptCcProgram = maybeToFlag $ programPath <$> - lookupProgram gccProgram (withPrograms lbi), - ghcOptObjDir = toFlag odir, - ghcOptExtra = hcOptions GHC bi + ghcOptVerbosity = toFlag (min verbosity normal) + , ghcOptMode = toFlag GhcModeCompile + , ghcOptInputFiles = toNubListR [filename] + , ghcOptCppIncludePath = + toNubListR $ + [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + , odir + ] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- includeDirs bi] + , ghcOptHideAllPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages clbi + , ghcOptCxxOptions = + ( case withOptimization lbi of + NoOptimisation -> [] + _ -> ["-O2"] + ) + ++ ( case withDebugInfo lbi of + NoDebugInfo -> [] + MinimalDebugInfo -> ["-g1"] + NormalDebugInfo -> ["-g"] + MaximalDebugInfo -> ["-g3"] + ) + ++ cxxOptions bi + , ghcOptCcProgram = + maybeToFlag $ + programPath + <$> lookupProgram gccProgram (withPrograms lbi) + , ghcOptObjDir = toFlag odir + , ghcOptExtra = hcOptions GHC bi } - -componentAsmGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions +componentAsmGhcOptions + :: Verbosity + -> GhcImplInfo + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> FilePath + -> GhcOptions componentAsmGhcOptions verbosity _implInfo lbi bi clbi odir filename = - mempty { - -- Respect -v0, but don't crank up verbosity on GHC if + mempty + { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptMode = toFlag GhcModeCompile, - ghcOptInputFiles = toNubListR [filename], - - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptHideAllPackages= toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, - ghcOptAsmOptions = (case withOptimization lbi of - NoOptimisation -> [] - _ -> ["-O2"]) ++ - (case withDebugInfo lbi of - NoDebugInfo -> [] - MinimalDebugInfo -> ["-g1"] - NormalDebugInfo -> ["-g"] - MaximalDebugInfo -> ["-g3"]) ++ - asmOptions bi, - ghcOptObjDir = toFlag odir + ghcOptVerbosity = toFlag (min verbosity normal) + , ghcOptMode = toFlag GhcModeCompile + , ghcOptInputFiles = toNubListR [filename] + , ghcOptCppIncludePath = + toNubListR $ + [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + , odir + ] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- includeDirs bi] + , ghcOptHideAllPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages clbi + , ghcOptAsmOptions = + ( case withOptimization lbi of + NoOptimisation -> [] + _ -> ["-O2"] + ) + ++ ( case withDebugInfo lbi of + NoDebugInfo -> [] + MinimalDebugInfo -> ["-g1"] + NormalDebugInfo -> ["-g"] + MaximalDebugInfo -> ["-g3"] + ) + ++ asmOptions bi + , ghcOptObjDir = toFlag odir } -componentJsGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions +componentJsGhcOptions + :: Verbosity + -> GhcImplInfo + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> FilePath + -> GhcOptions componentJsGhcOptions verbosity _implInfo lbi bi clbi odir filename = - mempty { - -- Respect -v0, but don't crank up verbosity on GHC if + mempty + { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptMode = toFlag GhcModeCompile, - ghcOptInputFiles = toNubListR [filename], - - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptHideAllPackages= toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, - ghcOptObjDir = toFlag odir + ghcOptVerbosity = toFlag (min verbosity normal) + , ghcOptMode = toFlag GhcModeCompile + , ghcOptInputFiles = toNubListR [filename] + , ghcOptCppIncludePath = + toNubListR $ + [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + , odir + ] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- includeDirs bi] + , ghcOptHideAllPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages clbi + , ghcOptObjDir = toFlag odir } - -componentGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo -> FilePath - -> GhcOptions +componentGhcOptions + :: Verbosity + -> GhcImplInfo + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> GhcOptions componentGhcOptions verbosity implInfo lbi bi clbi odir = - mempty { - -- Respect -v0, but don't crank up verbosity on GHC if + mempty + { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptCabal = toFlag True, - ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo { componentCompatPackageKey = pk } - -> toFlag pk - _ -> mempty, - ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo { componentComponentId = cid - , componentInstantiatedWith = insts } -> - if null insts - then mempty - else toFlag cid - _ -> mempty, - ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } - -> insts - _ -> [], - ghcOptNoCode = toFlag $ componentIsIndefinite clbi, - ghcOptHideAllPackages = toFlag True, - ghcOptWarnMissingHomeModules = toFlag $ flagWarnMissingHomeModules implInfo, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, - ghcOptSplitSections = toFlag (splitSections lbi), - ghcOptSplitObjs = toFlag (splitObjs lbi), - ghcOptSourcePathClear = toFlag True, - ghcOptSourcePath = toNubListR $ map getSymbolicPath (hsSourceDirs bi) - ++ [odir] - ++ [autogenComponentModulesDir lbi clbi] - ++ [autogenPackageModulesDir lbi], - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptCppOptions = cppOptions bi, - ghcOptCppIncludes = toNubListR $ - [autogenComponentModulesDir lbi clbi cppHeaderName], - ghcOptFfiIncludes = toNubListR $ includes bi, - ghcOptObjDir = toFlag odir, - ghcOptHiDir = toFlag odir, - ghcOptStubDir = toFlag odir, - ghcOptOutputDir = toFlag odir, - ghcOptOptimisation = toGhcOptimisation (withOptimization lbi), - ghcOptDebugInfo = toFlag (withDebugInfo lbi), - ghcOptExtra = hcOptions GHC bi, - ghcOptExtraPath = toNubListR $ exe_paths, - ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi)), - -- Unsupported extensions have already been checked by configure - ghcOptExtensions = toNubListR $ usedExtensions bi, - ghcOptExtensionMap = Map.fromList . compilerExtensions $ (compiler lbi) + ghcOptVerbosity = toFlag (min verbosity normal) + , ghcOptCabal = toFlag True + , ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> + toFlag pk + _ -> mempty + , ghcOptThisComponentId = case clbi of + LibComponentLocalBuildInfo + { componentComponentId = cid + , componentInstantiatedWith = insts + } -> + if null insts + then mempty + else toFlag cid + _ -> mempty + , ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> + insts + _ -> [] + , ghcOptNoCode = toFlag $ componentIsIndefinite clbi + , ghcOptHideAllPackages = toFlag True + , ghcOptWarnMissingHomeModules = toFlag $ flagWarnMissingHomeModules implInfo + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages clbi + , ghcOptSplitSections = toFlag (splitSections lbi) + , ghcOptSplitObjs = toFlag (splitObjs lbi) + , ghcOptSourcePathClear = toFlag True + , ghcOptSourcePath = + toNubListR $ + map getSymbolicPath (hsSourceDirs bi) + ++ [odir] + ++ [autogenComponentModulesDir lbi clbi] + ++ [autogenPackageModulesDir lbi] + , ghcOptCppIncludePath = + toNubListR $ + [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + , odir + ] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- includeDirs bi] + , ghcOptCppOptions = cppOptions bi + , ghcOptCppIncludes = + toNubListR $ + [autogenComponentModulesDir lbi clbi cppHeaderName] + , ghcOptFfiIncludes = toNubListR $ includes bi + , ghcOptObjDir = toFlag odir + , ghcOptHiDir = toFlag odir + , ghcOptStubDir = toFlag odir + , ghcOptOutputDir = toFlag odir + , ghcOptOptimisation = toGhcOptimisation (withOptimization lbi) + , ghcOptDebugInfo = toFlag (withDebugInfo lbi) + , ghcOptExtra = hcOptions GHC bi + , ghcOptExtraPath = toNubListR $ exe_paths + , ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi)) + , -- Unsupported extensions have already been checked by configure + ghcOptExtensions = toNubListR $ usedExtensions bi + , ghcOptExtensionMap = Map.fromList . compilerExtensions $ (compiler lbi) } where - exe_paths = [ componentBuildDir lbi (targetCLBI exe_tgt) - | uid <- componentExeDeps clbi - -- TODO: Ugh, localPkgDescr - , Just exe_tgt <- [unitIdTarget' (localPkgDescr lbi) lbi uid] ] + exe_paths = + [ componentBuildDir lbi (targetCLBI exe_tgt) + | uid <- componentExeDeps clbi + , -- TODO: Ugh, localPkgDescr + Just exe_tgt <- [unitIdTarget' (localPkgDescr lbi) lbi uid] + ] toGhcOptimisation :: OptimisationLevel -> Flag GhcOptimisation -toGhcOptimisation NoOptimisation = mempty --TODO perhaps override? -toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation +toGhcOptimisation NoOptimisation = mempty -- TODO perhaps override? +toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation - -componentCmmGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions +componentCmmGhcOptions + :: Verbosity + -> GhcImplInfo + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> FilePath + -> GhcOptions componentCmmGhcOptions verbosity _implInfo lbi bi clbi odir filename = - mempty { - -- Respect -v0, but don't crank up verbosity on GHC if + mempty + { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptMode = toFlag GhcModeCompile, - ghcOptInputFiles = toNubListR [filename], - - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptCppOptions = cppOptions bi, - ghcOptCppIncludes = toNubListR $ - [autogenComponentModulesDir lbi clbi cppHeaderName], - ghcOptHideAllPackages= toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, - ghcOptOptimisation = toGhcOptimisation (withOptimization lbi), - ghcOptDebugInfo = toFlag (withDebugInfo lbi), - ghcOptExtra = cmmOptions bi, - ghcOptObjDir = toFlag odir + ghcOptVerbosity = toFlag (min verbosity normal) + , ghcOptMode = toFlag GhcModeCompile + , ghcOptInputFiles = toNubListR [filename] + , ghcOptCppIncludePath = + toNubListR $ + [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + , odir + ] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- includeDirs bi] + , ghcOptCppOptions = cppOptions bi + , ghcOptCppIncludes = + toNubListR $ + [autogenComponentModulesDir lbi clbi cppHeaderName] + , ghcOptHideAllPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages clbi + , ghcOptOptimisation = toGhcOptimisation (withOptimization lbi) + , ghcOptDebugInfo = toFlag (withDebugInfo lbi) + , ghcOptExtra = cmmOptions bi + , ghcOptObjDir = toFlag odir } - -- | Strip out flags that are not supported in ghci filterGhciFlags :: [String] -> [String] filterGhciFlags = filter supported where - supported ('-':'O':_) = False - supported "-debug" = False + supported ('-' : 'O' : _) = False + supported "-debug" = False supported "-threaded" = False - supported "-ticky" = False + supported "-ticky" = False supported "-eventlog" = False - supported "-prof" = False - supported "-unreg" = False - supported _ = True + supported "-prof" = False + supported "-unreg" = False + supported _ = True mkGHCiLibName :: UnitId -> String mkGHCiLibName lib = getHSLibraryName lib <.> "o" @@ -539,45 +653,60 @@ ghcLookupProperty :: String -> Compiler -> Bool ghcLookupProperty prop comp = case Map.lookup prop (compilerProperties comp) of Just "YES" -> True - _ -> False + _ -> False -- when using -split-objs, we need to search for object files in the -- Module_split directory for each module. -getHaskellObjects :: GhcImplInfo -> Library -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> FilePath -> String -> Bool -> IO [FilePath] +getHaskellObjects + :: GhcImplInfo + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> String + -> Bool + -> IO [FilePath] getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs | splitObjs lbi && allow_split_objs = do - let splitSuffix = "_" ++ wanted_obj_ext ++ "_split" - dirs = [ pref (ModuleName.toFilePath x ++ splitSuffix) - | x <- allLibModules lib clbi ] - objss <- traverse getDirectoryContents dirs - let objs = [ dir obj - | (objs',dir) <- zip objss dirs, obj <- objs', - let obj_ext = takeExtension obj, - '.':wanted_obj_ext == obj_ext ] - return objs - | otherwise = - return [ pref ModuleName.toFilePath x <.> wanted_obj_ext - | x <- allLibModules lib clbi ] - -mkGhcOptPackages :: ComponentLocalBuildInfo - -> [(OpenUnitId, ModuleRenaming)] + let splitSuffix = "_" ++ wanted_obj_ext ++ "_split" + dirs = + [ pref (ModuleName.toFilePath x ++ splitSuffix) + | x <- allLibModules lib clbi + ] + objss <- traverse getDirectoryContents dirs + let objs = + [ dir obj + | (objs', dir) <- zip objss dirs + , obj <- objs' + , let obj_ext = takeExtension obj + , '.' : wanted_obj_ext == obj_ext + ] + return objs + | otherwise = + return + [ pref ModuleName.toFilePath x <.> wanted_obj_ext + | x <- allLibModules lib clbi + ] + +mkGhcOptPackages + :: ComponentLocalBuildInfo + -> [(OpenUnitId, ModuleRenaming)] mkGhcOptPackages = componentIncludes substTopDir :: FilePath -> IPI.InstalledPackageInfo -> IPI.InstalledPackageInfo -substTopDir topDir ipo - = ipo { - IPI.importDirs = map f (IPI.importDirs ipo), - IPI.libraryDirs = map f (IPI.libraryDirs ipo), - IPI.libraryDirsStatic = map f (IPI.libraryDirsStatic ipo), - IPI.includeDirs = map f (IPI.includeDirs ipo), - IPI.frameworkDirs = map f (IPI.frameworkDirs ipo), - IPI.haddockInterfaces = map f (IPI.haddockInterfaces ipo), - IPI.haddockHTMLs = map f (IPI.haddockHTMLs ipo) - } - where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest - f x = x +substTopDir topDir ipo = + ipo + { IPI.importDirs = map f (IPI.importDirs ipo) + , IPI.libraryDirs = map f (IPI.libraryDirs ipo) + , IPI.libraryDirsStatic = map f (IPI.libraryDirsStatic ipo) + , IPI.includeDirs = map f (IPI.includeDirs ipo) + , IPI.frameworkDirs = map f (IPI.frameworkDirs ipo) + , IPI.haddockInterfaces = map f (IPI.haddockInterfaces ipo) + , IPI.haddockHTMLs = map f (IPI.haddockHTMLs ipo) + } + where + f ('$' : 't' : 'o' : 'p' : 'd' : 'i' : 'r' : rest) = topDir ++ rest + f x = x -- Cabal does not use the environment variable GHC{,JS}_PACKAGE_PATH; let -- users know that this is the case. See ticket #335. Simply ignoring it is @@ -591,132 +720,139 @@ substTopDir topDir ipo -- GHC{,JS}_PACKAGE_PATH. checkPackageDbEnvVar :: Verbosity -> String -> String -> IO () checkPackageDbEnvVar verbosity compilerName packagePathEnvVar = do - mPP <- lookupEnv packagePathEnvVar - when (isJust mPP) $ do - mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH" - unless (mPP == mcsPP) abort - where - lookupEnv :: String -> IO (Maybe String) - lookupEnv name = (Just `fmap` getEnv name) - `catchIO` const (return Nothing) - abort = - die' verbosity $ "Use of " ++ compilerName ++ "'s environment variable " - ++ packagePathEnvVar ++ " is incompatible with Cabal. Use the " - ++ "flag --package-db to specify a package database (it can be " - ++ "used multiple times)." - - _ = callStack -- TODO: output stack when erroring + mPP <- lookupEnv packagePathEnvVar + when (isJust mPP) $ do + mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH" + unless (mPP == mcsPP) abort + where + lookupEnv :: String -> IO (Maybe String) + lookupEnv name = + (Just `fmap` getEnv name) + `catchIO` const (return Nothing) + abort = + die' verbosity $ + "Use of " + ++ compilerName + ++ "'s environment variable " + ++ packagePathEnvVar + ++ " is incompatible with Cabal. Use the " + ++ "flag --package-db to specify a package database (it can be " + ++ "used multiple times)." + + _ = callStack -- TODO: output stack when erroring profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto profDetailLevelFlag forLib mpl = - case mpl of - ProfDetailNone -> mempty - ProfDetailDefault | forLib -> toFlag GhcProfAutoExported - | otherwise -> toFlag GhcProfAutoToplevel - ProfDetailExportedFunctions -> toFlag GhcProfAutoExported - ProfDetailToplevelFunctions -> toFlag GhcProfAutoToplevel - ProfDetailAllFunctions -> toFlag GhcProfAutoAll - ProfDetailTopLate -> toFlag GhcProfLate - ProfDetailOther _ -> mempty - + case mpl of + ProfDetailNone -> mempty + ProfDetailDefault + | forLib -> toFlag GhcProfAutoExported + | otherwise -> toFlag GhcProfAutoToplevel + ProfDetailExportedFunctions -> toFlag GhcProfAutoExported + ProfDetailToplevelFunctions -> toFlag GhcProfAutoToplevel + ProfDetailAllFunctions -> toFlag GhcProfAutoAll + ProfDetailTopLate -> toFlag GhcProfLate + ProfDetailOther _ -> mempty -- ----------------------------------------------------------------------------- -- GHC platform and version strings -- | GHC's rendering of its host or target 'Arch' as used in its platform -- strings and certain file locations (such as user package db location). --- ghcArchString :: Arch -> String -ghcArchString PPC = "powerpc" +ghcArchString PPC = "powerpc" ghcArchString PPC64 = "powerpc64" ghcArchString other = prettyShow other -- | GHC's rendering of its host or target 'OS' as used in its platform -- strings and certain file locations (such as user package db location). --- ghcOsString :: OS -> String ghcOsString Windows = "mingw32" -ghcOsString OSX = "darwin" +ghcOsString OSX = "darwin" ghcOsString Solaris = "solaris2" -ghcOsString other = prettyShow other +ghcOsString other = prettyShow other -- | GHC's rendering of its platform and compiler version string as used in -- certain file locations (such as user package db location). -- For example @x86_64-linux-7.10.4@ --- ghcPlatformAndVersionString :: Platform -> Version -> String ghcPlatformAndVersionString (Platform arch os) version = - intercalate "-" [ ghcArchString arch, ghcOsString os, prettyShow version ] - + intercalate "-" [ghcArchString arch, ghcOsString os, prettyShow version] -- ----------------------------------------------------------------------------- -- Constructing GHC environment files -- | The kinds of entries we can stick in a @.ghc.environment@ file. --- -data GhcEnvironmentFileEntry = - GhcEnvFileComment String -- ^ @-- a comment@ - | GhcEnvFilePackageId UnitId -- ^ @package-id foo-1.0-4fe301a...@ - | GhcEnvFilePackageDb PackageDB -- ^ @global-package-db@, - -- @user-package-db@ or - -- @package-db blah/package.conf.d/@ - | GhcEnvFileClearPackageDbStack -- ^ @clear-package-db@ - deriving (Eq, Ord, Show) +data GhcEnvironmentFileEntry + = -- | @-- a comment@ + GhcEnvFileComment String + | -- | @package-id foo-1.0-4fe301a...@ + GhcEnvFilePackageId UnitId + | -- | @global-package-db@, + -- @user-package-db@ or + -- @package-db blah/package.conf.d/@ + GhcEnvFilePackageDb PackageDB + | -- | @clear-package-db@ + GhcEnvFileClearPackageDbStack + deriving (Eq, Ord, Show) -- | Make entries for a GHC environment file based on a 'PackageDBStack' and -- a bunch of package (unit) ids. -- -- If you need to do anything more complicated then either use this as a basis -- and add more entries, or just make all the entries directly. --- -simpleGhcEnvironmentFile :: PackageDBStack - -> [UnitId] - -> [GhcEnvironmentFileEntry] +simpleGhcEnvironmentFile + :: PackageDBStack + -> [UnitId] + -> [GhcEnvironmentFileEntry] simpleGhcEnvironmentFile packageDBs pkgids = - GhcEnvFileClearPackageDbStack - : map GhcEnvFilePackageDb packageDBs - ++ map GhcEnvFilePackageId pkgids + GhcEnvFileClearPackageDbStack + : map GhcEnvFilePackageDb packageDBs + ++ map GhcEnvFilePackageId pkgids -- | Write a @.ghc.environment-$arch-$os-$ver@ file in the given directory. -- -- The 'Platform' and GHC 'Version' are needed as part of the file name. -- -- Returns the name of the file written. -writeGhcEnvironmentFile :: FilePath -- ^ directory in which to put it - -> Platform -- ^ the GHC target platform - -> Version -- ^ the GHC version - -> [GhcEnvironmentFileEntry] -- ^ the content - -> IO FilePath +writeGhcEnvironmentFile + :: FilePath + -- ^ directory in which to put it + -> Platform + -- ^ the GHC target platform + -> Version + -- ^ the GHC version + -> [GhcEnvironmentFileEntry] + -- ^ the content + -> IO FilePath writeGhcEnvironmentFile directory platform ghcversion entries = do - writeFileAtomic envfile . BS.pack . renderGhcEnvironmentFile $ entries - return envfile + writeFileAtomic envfile . BS.pack . renderGhcEnvironmentFile $ entries + return envfile where envfile = directory ghcEnvironmentFileName platform ghcversion -- | The @.ghc.environment-$arch-$os-$ver@ file name --- ghcEnvironmentFileName :: Platform -> Version -> FilePath ghcEnvironmentFileName platform ghcversion = - ".ghc.environment." ++ ghcPlatformAndVersionString platform ghcversion + ".ghc.environment." ++ ghcPlatformAndVersionString platform ghcversion -- | Render a bunch of GHC environment file entries --- renderGhcEnvironmentFile :: [GhcEnvironmentFileEntry] -> String renderGhcEnvironmentFile = - unlines . map renderGhcEnvironmentFileEntry + unlines . map renderGhcEnvironmentFileEntry -- | Render an individual GHC environment file entry --- renderGhcEnvironmentFileEntry :: GhcEnvironmentFileEntry -> String renderGhcEnvironmentFileEntry entry = case entry of - GhcEnvFileComment comment -> format comment - where format = intercalate "\n" . map ("--" <++>) . lines - pref <++> "" = pref - pref <++> str = pref ++ " " ++ str - GhcEnvFilePackageId pkgid -> "package-id " ++ prettyShow pkgid - GhcEnvFilePackageDb pkgdb -> - case pkgdb of - GlobalPackageDB -> "global-package-db" - UserPackageDB -> "user-package-db" - SpecificPackageDB dbfile -> "package-db " ++ dbfile - GhcEnvFileClearPackageDbStack -> "clear-package-db" + GhcEnvFileComment comment -> format comment + where + format = intercalate "\n" . map ("--" <++>) . lines + pref <++> "" = pref + pref <++> str = pref ++ " " ++ str + GhcEnvFilePackageId pkgid -> "package-id " ++ prettyShow pkgid + GhcEnvFilePackageDb pkgdb -> + case pkgdb of + GlobalPackageDB -> "global-package-db" + UserPackageDB -> "user-package-db" + SpecificPackageDB dbfile -> "package-db " ++ dbfile + GhcEnvFileClearPackageDbStack -> "clear-package-db" diff --git a/Cabal/src/Distribution/Simple/GHCJS.hs b/Cabal/src/Distribution/Simple/GHCJS.hs index 775948c74ac..3727f2d2449 100644 --- a/Cabal/src/Distribution/Simple/GHCJS.hs +++ b/Cabal/src/Distribution/Simple/GHCJS.hs @@ -1,109 +1,134 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE CPP #-} -module Distribution.Simple.GHCJS ( - getGhcInfo, - configure, - getInstalledPackages, - getInstalledPackagesMonitorFiles, - getPackageDBContents, - buildLib, buildFLib, buildExe, - replLib, replFLib, replExe, - startInterpreter, - installLib, installFLib, installExe, - libAbiHash, - hcPkgInfo, - registerPackage, - componentGhcOptions, - componentCcGhcOptions, - getLibDir, - isDynamic, - getGlobalPackageDB, - pkgRoot, - runCmd, - -- * Constructing and deconstructing GHC environment files - Internal.GhcEnvironmentFileEntry(..), - Internal.simpleGhcEnvironmentFile, - Internal.renderGhcEnvironmentFile, - Internal.writeGhcEnvironmentFile, - Internal.ghcPlatformAndVersionString, - readGhcEnvironmentFile, - parseGhcEnvironmentFile, - ParseErrorExc(..), - -- * Version-specific implementation quirks - getImplInfo, - GhcImplInfo(..) - ) where +module Distribution.Simple.GHCJS + ( getGhcInfo + , configure + , getInstalledPackages + , getInstalledPackagesMonitorFiles + , getPackageDBContents + , buildLib + , buildFLib + , buildExe + , replLib + , replFLib + , replExe + , startInterpreter + , installLib + , installFLib + , installExe + , libAbiHash + , hcPkgInfo + , registerPackage + , componentGhcOptions + , componentCcGhcOptions + , getLibDir + , isDynamic + , getGlobalPackageDB + , pkgRoot + , runCmd + + -- * Constructing and deconstructing GHC environment files + , Internal.GhcEnvironmentFileEntry (..) + , Internal.simpleGhcEnvironmentFile + , Internal.renderGhcEnvironmentFile + , Internal.writeGhcEnvironmentFile + , Internal.ghcPlatformAndVersionString + , readGhcEnvironmentFile + , parseGhcEnvironmentFile + , ParseErrorExc (..) + + -- * Version-specific implementation quirks + , getImplInfo + , GhcImplInfo (..) + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import qualified Distribution.Simple.GHC.Internal as Internal -import Distribution.Simple.GHC.ImplInfo -import Distribution.Simple.GHC.EnvironmentParser -import Distribution.PackageDescription.Utils (cabalBug) -import Distribution.PackageDescription as PD +import Distribution.CabalSpecVersion import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Package +import Distribution.PackageDescription as PD +import Distribution.PackageDescription.Utils (cabalBug) +import Distribution.Pretty +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler +import Distribution.Simple.Flag +import Distribution.Simple.GHC.EnvironmentParser +import Distribution.Simple.GHC.ImplInfo +import qualified Distribution.Simple.GHC.Internal as Internal +import qualified Distribution.Simple.Hpc as Hpc +import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.LocalBuildInfo -import Distribution.Types.ComponentLocalBuildInfo -import qualified Distribution.Simple.Hpc as Hpc -import Distribution.Simple.BuildPaths -import Distribution.Simple.Utils -import Distribution.Package -import qualified Distribution.ModuleName as ModuleName -import Distribution.ModuleName (ModuleName) import Distribution.Simple.Program +import Distribution.Simple.Program.GHC import qualified Distribution.Simple.Program.HcPkg as HcPkg import qualified Distribution.Simple.Program.Strip as Strip -import Distribution.Simple.Program.GHC -import Distribution.Simple.Flag import Distribution.Simple.Setup.Config -import Distribution.Simple.Compiler -import Distribution.CabalSpecVersion -import Distribution.Version +import Distribution.Simple.Utils import Distribution.System +import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.PackageName.Magic -import Distribution.Verbosity -import Distribution.Pretty import Distribution.Utils.NubList import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version import Control.Monad (msum) import Data.Char (isLower) import qualified Data.Map as Map import System.Directory - ( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing - , canonicalizePath, removeFile, renameFile ) -import System.FilePath ( (), (<.>), takeExtension - , takeDirectory, replaceExtension - ,isRelative ) + ( canonicalizePath + , createDirectoryIfMissing + , doesFileExist + , getAppUserDataDirectory + , removeFile + , renameFile + ) +import System.FilePath + ( isRelative + , replaceExtension + , takeDirectory + , takeExtension + , (<.>) + , () + ) import qualified System.Info -- ----------------------------------------------------------------------------- -- Configuring -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramDb - -> IO (Compiler, Maybe Platform, ProgramDb) +configure + :: Verbosity + -> Maybe FilePath + -> Maybe FilePath + -> ProgramDb + -> IO (Compiler, Maybe Platform, ProgramDb) configure verbosity hcPath hcPkgPath conf0 = do - (ghcjsProg, ghcjsVersion, progdb1) <- - requireProgramVersion verbosity ghcjsProgram - (orLaterVersion (mkVersion [0,1])) + requireProgramVersion + verbosity + ghcjsProgram + (orLaterVersion (mkVersion [0, 1])) (userMaybeSpecifyPath "ghcjs" hcPath conf0) Just ghcjsGhcVersion <- findGhcjsGhcVersion verbosity (programPath ghcjsProg) - unless (ghcjsGhcVersion < mkVersion [8,8]) $ + unless (ghcjsGhcVersion < mkVersion [8, 8]) $ warn verbosity $ - "Unknown/unsupported 'ghc' version detected " - ++ "(Cabal " ++ prettyShow cabalVersion ++ " supports 'ghc' version < 8.8): " - ++ programPath ghcjsProg ++ " is based on GHC version " ++ - prettyShow ghcjsGhcVersion + "Unknown/unsupported 'ghc' version detected " + ++ "(Cabal " + ++ prettyShow cabalVersion + ++ " supports 'ghc' version < 8.8): " + ++ programPath ghcjsProg + ++ " is based on GHC version " + ++ prettyShow ghcjsGhcVersion let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion @@ -111,131 +136,180 @@ configure verbosity hcPath hcPkgPath conf0 = do -- location of ghc to help find ghc-pkg in the case that the user did not -- specify the location of ghc-pkg directly: (ghcjsPkgProg, ghcjsPkgVersion, progdb2) <- - requireProgramVersion verbosity ghcjsPkgProgram { - programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg - } - anyVersion (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath progdb1) - - Just ghcjsPkgGhcjsVersion <- findGhcjsPkgGhcjsVersion - verbosity (programPath ghcjsPkgProg) - - when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $ die' verbosity $ - "Version mismatch between ghcjs and ghcjs-pkg: " - ++ programPath ghcjsProg ++ " is version " ++ prettyShow ghcjsVersion ++ " " - ++ programPath ghcjsPkgProg ++ " is version " ++ prettyShow ghcjsPkgGhcjsVersion - - when (ghcjsGhcVersion /= ghcjsPkgVersion) $ die' verbosity $ - "Version mismatch between ghcjs and ghcjs-pkg: " - ++ programPath ghcjsProg - ++ " was built with GHC version " ++ prettyShow ghcjsGhcVersion ++ " " - ++ programPath ghcjsPkgProg - ++ " was built with GHC version " ++ prettyShow ghcjsPkgVersion - + requireProgramVersion + verbosity + ghcjsPkgProgram + { programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg + } + anyVersion + (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath progdb1) + + Just ghcjsPkgGhcjsVersion <- + findGhcjsPkgGhcjsVersion + verbosity + (programPath ghcjsPkgProg) + + when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $ + die' verbosity $ + "Version mismatch between ghcjs and ghcjs-pkg: " + ++ programPath ghcjsProg + ++ " is version " + ++ prettyShow ghcjsVersion + ++ " " + ++ programPath ghcjsPkgProg + ++ " is version " + ++ prettyShow ghcjsPkgGhcjsVersion + + when (ghcjsGhcVersion /= ghcjsPkgVersion) $ + die' verbosity $ + "Version mismatch between ghcjs and ghcjs-pkg: " + ++ programPath ghcjsProg + ++ " was built with GHC version " + ++ prettyShow ghcjsGhcVersion + ++ " " + ++ programPath ghcjsPkgProg + ++ " was built with GHC version " + ++ prettyShow ghcjsPkgVersion -- Likewise we try to find the matching hsc2hs and haddock programs. - let hsc2hsProgram' = hsc2hsProgram { - programFindLocation = - guessHsc2hsFromGhcjsPath ghcjsProg - } - haddockProgram' = haddockProgram { - programFindLocation = - guessHaddockFromGhcjsPath ghcjsProg - } - hpcProgram' = hpcProgram { - programFindLocation = guessHpcFromGhcjsPath ghcjsProg - } - {- + let hsc2hsProgram' = + hsc2hsProgram + { programFindLocation = + guessHsc2hsFromGhcjsPath ghcjsProg + } + haddockProgram' = + haddockProgram + { programFindLocation = + guessHaddockFromGhcjsPath ghcjsProg + } + hpcProgram' = + hpcProgram + { programFindLocation = guessHpcFromGhcjsPath ghcjsProg + } + {- runghcProgram' = runghcProgram { programFindLocation = guessRunghcFromGhcjsPath ghcjsProg } -} - progdb3 = addKnownProgram haddockProgram' $ - addKnownProgram hsc2hsProgram' $ - addKnownProgram hpcProgram' $ + progdb3 = + addKnownProgram haddockProgram' $ + addKnownProgram hsc2hsProgram' $ + addKnownProgram hpcProgram' $ {- addKnownProgram runghcProgram' -} progdb2 - languages <- Internal.getLanguages verbosity implInfo ghcjsProg + languages <- Internal.getLanguages verbosity implInfo ghcjsProg extensions <- Internal.getExtensions verbosity implInfo ghcjsProg ghcjsInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg let ghcInfoMap = Map.fromList ghcjsInfo - let comp = Compiler { - compilerId = CompilerId GHCJS ghcjsVersion, - compilerAbiTag = AbiTag $ - "ghc" ++ intercalate "_" (map show . versionNumbers $ ghcjsGhcVersion), - compilerCompat = [CompilerId GHC ghcjsGhcVersion], - compilerLanguages = languages, - compilerExtensions = extensions, - compilerProperties = ghcInfoMap - } + let comp = + Compiler + { compilerId = CompilerId GHCJS ghcjsVersion + , compilerAbiTag = + AbiTag $ + "ghc" ++ intercalate "_" (map show . versionNumbers $ ghcjsGhcVersion) + , compilerCompat = [CompilerId GHC ghcjsGhcVersion] + , compilerLanguages = languages + , compilerExtensions = extensions + , compilerProperties = ghcInfoMap + } compPlatform = Internal.targetPlatform ghcjsInfo return (comp, compPlatform, progdb3) -guessGhcjsPkgFromGhcjsPath :: ConfiguredProgram -> Verbosity - -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) +guessGhcjsPkgFromGhcjsPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) guessGhcjsPkgFromGhcjsPath = guessToolFromGhcjsPath ghcjsPkgProgram -guessHsc2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity - -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) +guessHsc2hsFromGhcjsPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) guessHsc2hsFromGhcjsPath = guessToolFromGhcjsPath hsc2hsProgram -guessHaddockFromGhcjsPath :: ConfiguredProgram -> Verbosity - -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) +guessHaddockFromGhcjsPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) guessHaddockFromGhcjsPath = guessToolFromGhcjsPath haddockProgram -guessHpcFromGhcjsPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) +guessHpcFromGhcjsPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) guessHpcFromGhcjsPath = guessToolFromGhcjsPath hpcProgram +guessToolFromGhcjsPath + :: Program + -> ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath = + do + let toolname = programName tool + given_path = programPath ghcjsProg + given_dir = takeDirectory given_path + real_path <- canonicalizePath given_path + let real_dir = takeDirectory real_path + versionSuffix path = takeVersionSuffix (dropExeExtension path) + given_suf = versionSuffix given_path + real_suf = versionSuffix real_path + guessNormal dir = dir toolname <.> exeExtension buildPlatform + guessGhcjs dir = + dir + (toolname ++ "-ghcjs") + <.> exeExtension buildPlatform + guessGhcjsVersioned dir suf = + dir + (toolname ++ "-ghcjs" ++ suf) + <.> exeExtension buildPlatform + guessVersioned dir suf = + dir + (toolname ++ suf) + <.> exeExtension buildPlatform + mkGuesses dir suf + | null suf = [guessGhcjs dir, guessNormal dir] + | otherwise = + [ guessGhcjsVersioned dir suf + , guessVersioned dir suf + , guessGhcjs dir + , guessNormal dir + ] + guesses = + mkGuesses given_dir given_suf + ++ if real_path == given_path + then [] + else mkGuesses real_dir real_suf + info verbosity $ + "looking for tool " + ++ toolname + ++ " near compiler in " + ++ given_dir + debug verbosity $ "candidate locations: " ++ show guesses + exists <- traverse doesFileExist guesses + case [file | (file, True) <- zip guesses exists] of + -- If we can't find it near ghc, fall back to the usual + -- method. + [] -> programFindLocation tool verbosity searchpath + (fp : _) -> do + info verbosity $ "found " ++ toolname ++ " in " ++ fp + let lookedAt = + map fst + . takeWhile (\(_file, exist) -> not exist) + $ zip guesses exists + return (Just (fp, lookedAt)) + where + takeVersionSuffix :: FilePath -> String + takeVersionSuffix = takeWhileEndLE isSuffixChar -guessToolFromGhcjsPath :: Program -> ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath - = do let toolname = programName tool - given_path = programPath ghcjsProg - given_dir = takeDirectory given_path - real_path <- canonicalizePath given_path - let real_dir = takeDirectory real_path - versionSuffix path = takeVersionSuffix (dropExeExtension path) - given_suf = versionSuffix given_path - real_suf = versionSuffix real_path - guessNormal dir = dir toolname <.> exeExtension buildPlatform - guessGhcjs dir = dir (toolname ++ "-ghcjs") - <.> exeExtension buildPlatform - guessGhcjsVersioned dir suf = dir (toolname ++ "-ghcjs" ++ suf) - <.> exeExtension buildPlatform - guessVersioned dir suf = dir (toolname ++ suf) - <.> exeExtension buildPlatform - mkGuesses dir suf | null suf = [guessGhcjs dir, guessNormal dir] - | otherwise = [guessGhcjsVersioned dir suf, - guessVersioned dir suf, - guessGhcjs dir, - guessNormal dir] - guesses = mkGuesses given_dir given_suf ++ - if real_path == given_path - then [] - else mkGuesses real_dir real_suf - info verbosity $ "looking for tool " ++ toolname - ++ " near compiler in " ++ given_dir - debug verbosity $ "candidate locations: " ++ show guesses - exists <- traverse doesFileExist guesses - case [ file | (file, True) <- zip guesses exists ] of - -- If we can't find it near ghc, fall back to the usual - -- method. - [] -> programFindLocation tool verbosity searchpath - (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp - let lookedAt = map fst - . takeWhile (\(_file, exist) -> not exist) - $ zip guesses exists - return (Just (fp, lookedAt)) - - where takeVersionSuffix :: FilePath -> String - takeVersionSuffix = takeWhileEndLE isSuffixChar - - isSuffixChar :: Char -> Bool - isSuffixChar c = isDigit c || c == '.' || c == '-' + isSuffixChar :: Char -> Bool + isSuffixChar c = isDigit c || c == '.' || c == '-' getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] getGhcInfo verbosity ghcjsProg = Internal.getGhcInfo verbosity implInfo ghcjsProg @@ -244,15 +318,21 @@ getGhcInfo verbosity ghcjsProg = Internal.getGhcInfo verbosity implInfo ghcjsPro implInfo = ghcVersionImplInfo version -- | Given a single package DB, return all installed packages. -getPackageDBContents :: Verbosity -> PackageDB -> ProgramDb - -> IO InstalledPackageIndex +getPackageDBContents + :: Verbosity + -> PackageDB + -> ProgramDb + -> IO InstalledPackageIndex getPackageDBContents verbosity packagedb progdb = do pkgss <- getInstalledPackages' verbosity [packagedb] progdb toPackageIndex verbosity pkgss progdb -- | Given a package DB stack, return all installed packages. -getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb - -> IO InstalledPackageIndex +getInstalledPackages + :: Verbosity + -> PackageDBStack + -> ProgramDb + -> IO InstalledPackageIndex getInstalledPackages verbosity packagedbs progdb = do checkPackageDbEnvVar verbosity checkPackageDbStack verbosity packagedbs @@ -260,94 +340,106 @@ getInstalledPackages verbosity packagedbs progdb = do index <- toPackageIndex verbosity pkgss progdb return $! index -toPackageIndex :: Verbosity - -> [(PackageDB, [InstalledPackageInfo])] - -> ProgramDb - -> IO InstalledPackageIndex +toPackageIndex + :: Verbosity + -> [(PackageDB, [InstalledPackageInfo])] + -> ProgramDb + -> IO InstalledPackageIndex toPackageIndex verbosity pkgss progdb = do -- On Windows, various fields have $topdir/foo rather than full -- paths. We need to substitute the right value in so that when -- we, for example, call gcc, we have proper paths to give it. topDir <- getLibDir' verbosity ghcjsProg - let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) - | (_, pkgs) <- pkgss ] + let indices = + [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) + | (_, pkgs) <- pkgss + ] return $! (mconcat indices) - where ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath getLibDir verbosity lbi = - dropWhileEndLE isSpace `fmap` - getDbProgramOutput verbosity ghcjsProgram - (withPrograms lbi) ["--print-libdir"] + dropWhileEndLE isSpace + `fmap` getDbProgramOutput + verbosity + ghcjsProgram + (withPrograms lbi) + ["--print-libdir"] getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath getLibDir' verbosity ghcjsProg = - dropWhileEndLE isSpace `fmap` - getProgramOutput verbosity ghcjsProg ["--print-libdir"] - + dropWhileEndLE isSpace + `fmap` getProgramOutput verbosity ghcjsProg ["--print-libdir"] -- | Return the 'FilePath' to the global GHC package database. getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath getGlobalPackageDB verbosity ghcProg = - dropWhileEndLE isSpace `fmap` - getProgramOutput verbosity ghcProg ["--print-global-package-db"] + dropWhileEndLE isSpace + `fmap` getProgramOutput verbosity ghcProg ["--print-global-package-db"] -- | Return the 'FilePath' to the per-user GHC package database. getUserPackageDB :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath getUserPackageDB _verbosity ghcjsProg platform = do - -- It's rather annoying that we have to reconstruct this, because ghc - -- hides this information from us otherwise. But for certain use cases - -- like change monitoring it really can't remain hidden. - appdir <- getAppUserDataDirectory "ghcjs" - return (appdir platformAndVersion packageConfFileName) + -- It's rather annoying that we have to reconstruct this, because ghc + -- hides this information from us otherwise. But for certain use cases + -- like change monitoring it really can't remain hidden. + appdir <- getAppUserDataDirectory "ghcjs" + return (appdir platformAndVersion packageConfFileName) where - platformAndVersion = Internal.ghcPlatformAndVersionString - platform ghcjsVersion + platformAndVersion = + Internal.ghcPlatformAndVersionString + platform + ghcjsVersion packageConfFileName = "package.conf.d" ghcjsVersion = fromMaybe (error "GHCJS.getUserPackageDB: no version") $ programVersion ghcjsProg checkPackageDbEnvVar :: Verbosity -> IO () checkPackageDbEnvVar verbosity = - Internal.checkPackageDbEnvVar verbosity "GHCJS" "GHCJS_PACKAGE_PATH" + Internal.checkPackageDbEnvVar verbosity "GHCJS" "GHCJS_PACKAGE_PATH" checkPackageDbStack :: Verbosity -> PackageDBStack -> IO () -checkPackageDbStack _ (GlobalPackageDB:rest) +checkPackageDbStack _ (GlobalPackageDB : rest) | GlobalPackageDB `notElem` rest = return () checkPackageDbStack verbosity rest | GlobalPackageDB `notElem` rest = - die' verbosity $ "With current ghc versions the global package db is always used " - ++ "and must be listed first. This ghc limitation may be lifted in " - ++ "future, see https://gitlab.haskell.org/ghc/ghc/-/issues/5977" + die' verbosity $ + "With current ghc versions the global package db is always used " + ++ "and must be listed first. This ghc limitation may be lifted in " + ++ "future, see https://gitlab.haskell.org/ghc/ghc/-/issues/5977" checkPackageDbStack verbosity _ = - die' verbosity $ "If the global package db is specified, it must be " - ++ "specified first and cannot be specified multiple times" + die' verbosity $ + "If the global package db is specified, it must be " + ++ "specified first and cannot be specified multiple times" -getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramDb - -> IO [(PackageDB, [InstalledPackageInfo])] +getInstalledPackages' + :: Verbosity + -> [PackageDB] + -> ProgramDb + -> IO [(PackageDB, [InstalledPackageInfo])] getInstalledPackages' verbosity packagedbs progdb = sequenceA - [ do pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb - return (packagedb, pkgs) - | packagedb <- packagedbs ] + [ do + pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb + return (packagedb, pkgs) + | packagedb <- packagedbs + ] -- | Get the packages from specific PackageDBs, not cumulative. --- -getInstalledPackagesMonitorFiles :: Verbosity -> Platform - -> ProgramDb - -> [PackageDB] - -> IO [FilePath] +getInstalledPackagesMonitorFiles + :: Verbosity + -> Platform + -> ProgramDb + -> [PackageDB] + -> IO [FilePath] getInstalledPackagesMonitorFiles verbosity platform progdb = - traverse getPackageDBPath + traverse getPackageDBPath where getPackageDBPath :: PackageDB -> IO FilePath getPackageDBPath GlobalPackageDB = selectMonitorFile =<< getGlobalPackageDB verbosity ghcjsProg - getPackageDBPath UserPackageDB = selectMonitorFile =<< getUserPackageDB verbosity ghcjsProg platform - getPackageDBPath (SpecificPackageDB path) = selectMonitorFile path -- GHC has old style file dbs, and new style directory dbs. @@ -356,37 +448,52 @@ getInstalledPackagesMonitorFiles verbosity platform progdb = -- so it's safe to only monitor this one file. selectMonitorFile path = do isFileStyle <- doesFileExist path - if isFileStyle then return path - else return (path "package.cache") + if isFileStyle + then return path + else return (path "package.cache") ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb - toJSLibName :: String -> String toJSLibName lib - | takeExtension lib `elem` [".dll",".dylib",".so"] - = replaceExtension lib "js_so" + | takeExtension lib `elem` [".dll", ".dylib", ".so"] = + replaceExtension lib "js_so" | takeExtension lib == ".a" = replaceExtension lib "js_a" - | otherwise = lib <.> "js_a" + | otherwise = lib <.> "js_a" -- ----------------------------------------------------------------------------- -- Building a library -buildLib :: Verbosity -> Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo - -> IO () +buildLib + :: Verbosity + -> Flag (Maybe Int) + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () buildLib = buildOrReplLib Nothing -replLib :: [String] -> Verbosity - -> Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Library - -> ComponentLocalBuildInfo -> IO () +replLib + :: [String] + -> Verbosity + -> Flag (Maybe Int) + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () replLib = buildOrReplLib . Just -buildOrReplLib :: Maybe [String] -> Verbosity - -> Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Library - -> ComponentLocalBuildInfo -> IO () +buildOrReplLib + :: Maybe [String] + -> Verbosity + -> Flag (Maybe Int) + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do let uid = componentUnitId clbi libTargetDir = componentBuildDir lbi clbi @@ -401,7 +508,7 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do forRepl = maybe False (const True) mReplFlags -- ifReplLib = when forRepl comp = compiler lbi - implInfo = getImplInfo comp + implInfo = getImplInfo comp platform@(Platform _hostArch _hostOS) = hostPlatform lbi has_code = not (componentIsIndefinite clbi) @@ -411,12 +518,12 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do let libBi = libBuildInfo lib -- fixme flags shouldn't depend on ghcjs being dynamic or not - let isGhcjsDynamic = isDynamic comp + let isGhcjsDynamic = isDynamic comp dynamicTooSupported = supportsDynamicToo comp doingTH = usesTemplateHaskellOrQQ libBi forceVanillaLib = doingTH && not isGhcjsDynamic - forceSharedLib = doingTH && isGhcjsDynamic - -- TH always needs default libs, even when building for profiling + forceSharedLib = doingTH && isGhcjsDynamic + -- TH always needs default libs, even when building for profiling -- Determine if program coverage should be enabled and if so, what -- '-hpcdir' should be. @@ -428,152 +535,169 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do pkg_name = prettyShow (PD.package pkg_descr) distPref = fromFlag $ configDistPref $ configFlags lbi hpcdir way - | forRepl = mempty -- HPC is not supported in ghci + | forRepl = mempty -- HPC is not supported in ghci | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name | otherwise = mempty createDirectoryIfMissingVerbose verbosity True libTargetDir -- TODO: do we need to put hs-boot files into place for mutually recursive -- modules? - let cLikeFiles = fromNubListR $ toNubListR (cSources libBi) <> toNubListR (cxxSources libBi) - jsSrcs = jsSources libBi - cObjs = map (`replaceExtension` objExtension) cLikeFiles - baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir - linkJsLibOpts = mempty { - ghcOptExtra = - [ "-link-js-lib" , getHSLibraryName uid - , "-js-lib-outputdir", libTargetDir ] ++ - jsSrcs - } - vanillaOptsNoJsLib = baseOpts `mappend` mempty { - ghcOptMode = toFlag GhcModeMake, - ghcOptNumJobs = numJobs, - ghcOptInputModules = toNubListR $ allLibModules lib clbi, - ghcOptHPCDir = hpcdir Hpc.Vanilla - } + let cLikeFiles = fromNubListR $ toNubListR (cSources libBi) <> toNubListR (cxxSources libBi) + jsSrcs = jsSources libBi + cObjs = map (`replaceExtension` objExtension) cLikeFiles + baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir + linkJsLibOpts = + mempty + { ghcOptExtra = + [ "-link-js-lib" + , getHSLibraryName uid + , "-js-lib-outputdir" + , libTargetDir + ] + ++ jsSrcs + } + vanillaOptsNoJsLib = + baseOpts + `mappend` mempty + { ghcOptMode = toFlag GhcModeMake + , ghcOptNumJobs = numJobs + , ghcOptInputModules = toNubListR $ allLibModules lib clbi + , ghcOptHPCDir = hpcdir Hpc.Vanilla + } vanillaOpts = vanillaOptsNoJsLib `mappend` linkJsLibOpts - profOpts = adjustExts "p_hi" "p_o" vanillaOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptProfilingAuto = Internal.profDetailLevelFlag True - (withProfLibDetail lbi), - -- ghcOptHiSuffix = toFlag "p_hi", - -- ghcOptObjSuffix = toFlag "p_o", - ghcOptExtra = hcProfOptions GHC libBi, - ghcOptHPCDir = hpcdir Hpc.Prof - } - - sharedOpts = adjustExts "dyn_hi" "dyn_o" vanillaOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptFPic = toFlag True, - -- ghcOptHiSuffix = toFlag "dyn_hi", - -- ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcSharedOptions GHC libBi, - ghcOptHPCDir = hpcdir Hpc.Dyn - } - - vanillaSharedOpts = vanillaOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, - ghcOptDynHiSuffix = toFlag "js_dyn_hi", - ghcOptDynObjSuffix = toFlag "js_dyn_o", - ghcOptHPCDir = hpcdir Hpc.Dyn - } + profOpts = + adjustExts "p_hi" "p_o" vanillaOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + , ghcOptProfilingAuto = + Internal.profDetailLevelFlag + True + (withProfLibDetail lbi) + , -- ghcOptHiSuffix = toFlag "p_hi", + -- ghcOptObjSuffix = toFlag "p_o", + ghcOptExtra = hcProfOptions GHC libBi + , ghcOptHPCDir = hpcdir Hpc.Prof + } + + sharedOpts = + adjustExts "dyn_hi" "dyn_o" vanillaOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptFPic = toFlag True + , -- ghcOptHiSuffix = toFlag "dyn_hi", + -- ghcOptObjSuffix = toFlag "dyn_o", + ghcOptExtra = hcSharedOptions GHC libBi + , ghcOptHPCDir = hpcdir Hpc.Dyn + } + + vanillaSharedOpts = + vanillaOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic + , ghcOptDynHiSuffix = toFlag "js_dyn_hi" + , ghcOptDynObjSuffix = toFlag "js_dyn_o" + , ghcOptHPCDir = hpcdir Hpc.Dyn + } unless (forRepl || null (allLibModules lib clbi) && null jsSrcs && null cObjs) $ - do let vanilla = whenVanillaLib forceVanillaLib (runGhcjsProg vanillaOpts) - shared = whenSharedLib forceSharedLib (runGhcjsProg sharedOpts) - useDynToo = dynamicTooSupported && - (forceVanillaLib || withVanillaLib lbi) && - (forceSharedLib || withSharedLib lbi) && - null (hcSharedOptions GHC libBi) - if not has_code + do + let vanilla = whenVanillaLib forceVanillaLib (runGhcjsProg vanillaOpts) + shared = whenSharedLib forceSharedLib (runGhcjsProg sharedOpts) + useDynToo = + dynamicTooSupported + && (forceVanillaLib || withVanillaLib lbi) + && (forceSharedLib || withSharedLib lbi) + && null (hcSharedOptions GHC libBi) + if not has_code then vanilla else - if useDynToo - then do + if useDynToo + then do runGhcjsProg vanillaSharedOpts case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of (Flag dynDir, Flag vanillaDir) -> - -- When the vanilla and shared library builds are done - -- in one pass, only one set of HPC module interfaces - -- are generated. This set should suffice for both - -- static and dynamically linked executables. We copy - -- the modules interfaces so they are available under - -- both ways. - copyDirectoryRecursive verbosity dynDir vanillaDir + -- When the vanilla and shared library builds are done + -- in one pass, only one set of HPC module interfaces + -- are generated. This set should suffice for both + -- static and dynamically linked executables. We copy + -- the modules interfaces so they are available under + -- both ways. + copyDirectoryRecursive verbosity dynDir vanillaDir _ -> return () - else if isGhcjsDynamic - then do shared; vanilla - else do vanilla; shared - whenProfLib (runGhcjsProg profOpts) + else + if isGhcjsDynamic + then do shared; vanilla + else do vanilla; shared + whenProfLib (runGhcjsProg profOpts) -- Build any C++ sources separately. {- - unless (not has_code || null (cxxSources libBi) || not nativeToo) $ do - info verbosity "Building C++ Sources..." - sequence_ - [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo - lbi libBi clbi libTargetDir filename - vanillaCxxOpts = if isGhcjsDynamic - then baseCxxOpts { ghcOptFPic = toFlag True } - else baseCxxOpts - profCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaCxxOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded cxxOpts = do - needsRecomp <- checkNeedsRecompilation filename cxxOpts - when needsRecomp $ runGhcjsProg cxxOpts - runGhcProgIfNeeded vanillaCxxOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profCxxOpts) - | filename <- cxxSources libBi] - - ifReplLib $ do - when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules" - ifReplLib (runGhcjsProg replOpts) --} + unless (not has_code || null (cxxSources libBi) || not nativeToo) $ do + info verbosity "Building C++ Sources..." + sequence_ + [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo + lbi libBi clbi libTargetDir filename + vanillaCxxOpts = if isGhcjsDynamic + then baseCxxOpts { ghcOptFPic = toFlag True } + else baseCxxOpts + profCxxOpts = vanillaCxxOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptObjSuffix = toFlag "p_o" + } + sharedCxxOpts = vanillaCxxOpts `mappend` mempty { + ghcOptFPic = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptObjSuffix = toFlag "dyn_o" + } + odir = fromFlag (ghcOptObjDir vanillaCxxOpts) + createDirectoryIfMissingVerbose verbosity True odir + let runGhcProgIfNeeded cxxOpts = do + needsRecomp <- checkNeedsRecompilation filename cxxOpts + when needsRecomp $ runGhcjsProg cxxOpts + runGhcProgIfNeeded vanillaCxxOpts + unless forRepl $ + whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts) + unless forRepl $ whenProfLib (runGhcProgIfNeeded profCxxOpts) + | filename <- cxxSources libBi] + + ifReplLib $ do + when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules" + ifReplLib (runGhcjsProg replOpts) + -} -- build any C sources -- TODO: Add support for S and CMM files. {- - unless (not has_code || null (cSources libBi) || not nativeToo) $ do - info verbosity "Building C Sources..." - sequence_ - [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo - lbi libBi clbi libTargetDir filename - vanillaCcOpts = if isGhcjsDynamic - -- Dynamic GHC requires C sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCcOpts { ghcOptFPic = toFlag True } - else baseCcOpts - profCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaCcOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded ccOpts = do - needsRecomp <- checkNeedsRecompilation filename ccOpts - when needsRecomp $ runGhcjsProg ccOpts - runGhcProgIfNeeded vanillaCcOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts) - | filename <- cSources libBi] --} + unless (not has_code || null (cSources libBi) || not nativeToo) $ do + info verbosity "Building C Sources..." + sequence_ + [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo + lbi libBi clbi libTargetDir filename + vanillaCcOpts = if isGhcjsDynamic + -- Dynamic GHC requires C sources to be built + -- with -fPIC for REPL to work. See #2207. + then baseCcOpts { ghcOptFPic = toFlag True } + else baseCcOpts + profCcOpts = vanillaCcOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptObjSuffix = toFlag "p_o" + } + sharedCcOpts = vanillaCcOpts `mappend` mempty { + ghcOptFPic = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptObjSuffix = toFlag "dyn_o" + } + odir = fromFlag (ghcOptObjDir vanillaCcOpts) + createDirectoryIfMissingVerbose verbosity True odir + let runGhcProgIfNeeded ccOpts = do + needsRecomp <- checkNeedsRecompilation filename ccOpts + when needsRecomp $ runGhcjsProg ccOpts + runGhcProgIfNeeded vanillaCcOpts + unless forRepl $ + whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts) + unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts) + | filename <- cSources libBi] + -} -- TODO: problem here is we need the .c files built first, so we can load them -- with ghci, but .c files can depend on .h files generated by ghc by ffi -- exports. @@ -582,8 +706,10 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do when has_code . when False {- fixme nativeToo -} . unless forRepl $ do info verbosity "Linking..." - let cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) - (cSources libBi ++ cxxSources libBi) + let cSharedObjs = + map + (`replaceExtension` ("dyn_" ++ objExtension)) + (cSources libBi ++ cxxSources libBi) compiler_id = compilerId (compiler lbi) sharedLibFilePath = libTargetDir mkSharedLibName (hostPlatform lbi) compiler_id uid staticLibFilePath = libTargetDir mkStaticLibName (hostPlatform lbi) compiler_id uid @@ -591,132 +717,148 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do let stubObjs = [] stubSharedObjs = [] -{- - stubObjs <- catMaybes <$> sequenceA - [ findFileWithExtension [objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] - stubProfObjs <- catMaybes <$> sequenceA - [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] - stubSharedObjs <- catMaybes <$> sequenceA - [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] --} - hObjs <- Internal.getHaskellObjects implInfo lib lbi clbi - libTargetDir objExtension True + {- + stubObjs <- catMaybes <$> sequenceA + [ findFileWithExtension [objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files + , x <- allLibModules lib clbi ] + stubProfObjs <- catMaybes <$> sequenceA + [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files + , x <- allLibModules lib clbi ] + stubSharedObjs <- catMaybes <$> sequenceA + [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files + , x <- allLibModules lib clbi ] + -} + hObjs <- + Internal.getHaskellObjects + implInfo + lib + lbi + clbi + libTargetDir + objExtension + True hSharedObjs <- if withSharedLib lbi - then Internal.getHaskellObjects implInfo lib lbi clbi - libTargetDir ("dyn_" ++ objExtension) False - else return [] + then + Internal.getHaskellObjects + implInfo + lib + lbi + clbi + libTargetDir + ("dyn_" ++ objExtension) + False + else return [] unless (null hObjs && null cObjs && null stubObjs) $ do rpaths <- getRPaths lbi clbi let staticObjectFiles = - hObjs + hObjs ++ map (libTargetDir ) cObjs ++ stubObjs dynamicObjectFiles = - hSharedObjs + hSharedObjs ++ map (libTargetDir ) cSharedObjs ++ stubSharedObjs -- After the relocation lib is created we invoke ghc -shared -- with the dependencies spelled out as -package arguments -- and ghc invokes the linker with the proper library paths ghcSharedLinkArgs = - mempty { - ghcOptShared = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptInputFiles = toNubListR dynamicObjectFiles, - ghcOptOutputFile = toFlag sharedLibFilePath, - ghcOptExtra = hcSharedOptions GHC libBi, - -- For dynamic libs, Mac OS/X needs to know the install location + mempty + { ghcOptShared = toFlag True + , ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptInputFiles = toNubListR dynamicObjectFiles + , ghcOptOutputFile = toFlag sharedLibFilePath + , ghcOptExtra = hcSharedOptions GHC libBi + , -- For dynamic libs, Mac OS/X needs to know the install location -- at build time. This only applies to GHC < 7.8 - see the -- discussion in #1660. - {- - ghcOptDylibName = if hostOS == OSX - && ghcVersion < mkVersion [7,8] - then toFlag sharedLibInstallPath - else mempty, -} - ghcOptHideAllPackages = toFlag True, - ghcOptNoAutoLinkPackages = toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo { componentCompatPackageKey = pk } - -> toFlag pk - _ -> mempty, - ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> - if null insts - then mempty - else toFlag (componentComponentId clbi) - _ -> mempty, - ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } - -> insts - _ -> [], - ghcOptPackages = toNubListR $ - Internal.mkGhcOptPackages clbi , - ghcOptLinkLibs = extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, - ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, - ghcOptLinkFrameworkDirs = - toNubListR $ PD.extraFrameworkDirs libBi, - ghcOptRPaths = rpaths + {- + ghcOptDylibName = if hostOS == OSX + && ghcVersion < mkVersion [7,8] + then toFlag sharedLibInstallPath + else mempty, -} + ghcOptHideAllPackages = toFlag True + , ghcOptNoAutoLinkPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> + toFlag pk + _ -> mempty + , ghcOptThisComponentId = case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> + if null insts + then mempty + else toFlag (componentComponentId clbi) + _ -> mempty + , ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> + insts + _ -> [] + , ghcOptPackages = + toNubListR $ + Internal.mkGhcOptPackages clbi + , ghcOptLinkLibs = extraLibs libBi + , ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi + , ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi + , ghcOptLinkFrameworkDirs = + toNubListR $ PD.extraFrameworkDirs libBi + , ghcOptRPaths = rpaths } ghcStaticLinkArgs = - mempty { - ghcOptStaticLib = toFlag True, - ghcOptInputFiles = toNubListR staticObjectFiles, - ghcOptOutputFile = toFlag staticLibFilePath, - ghcOptExtra = hcStaticOptions GHC libBi, - ghcOptHideAllPackages = toFlag True, - ghcOptNoAutoLinkPackages = toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo { componentCompatPackageKey = pk } - -> toFlag pk - _ -> mempty, - ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> - if null insts - then mempty - else toFlag (componentComponentId clbi) - _ -> mempty, - ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } - -> insts - _ -> [], - ghcOptPackages = toNubListR $ - Internal.mkGhcOptPackages clbi , - ghcOptLinkLibs = extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi + mempty + { ghcOptStaticLib = toFlag True + , ghcOptInputFiles = toNubListR staticObjectFiles + , ghcOptOutputFile = toFlag staticLibFilePath + , ghcOptExtra = hcStaticOptions GHC libBi + , ghcOptHideAllPackages = toFlag True + , ghcOptNoAutoLinkPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> + toFlag pk + _ -> mempty + , ghcOptThisComponentId = case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> + if null insts + then mempty + else toFlag (componentComponentId clbi) + _ -> mempty + , ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> + insts + _ -> [] + , ghcOptPackages = + toNubListR $ + Internal.mkGhcOptPackages clbi + , ghcOptLinkLibs = extraLibs libBi + , ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi } info verbosity (show (ghcOptPackages ghcSharedLinkArgs)) -{- - whenVanillaLib False $ do - Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles - whenGHCiLib $ do - (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) - Ld.combineObjectFiles verbosity lbi ldProg - ghciLibFilePath staticObjectFiles - -} -{- - whenProfLib $ do - Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles - whenGHCiLib $ do - (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) - Ld.combineObjectFiles verbosity lbi ldProg - ghciProfLibFilePath profObjectFiles --} + {- + whenVanillaLib False $ do + Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles + whenGHCiLib $ do + (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) + Ld.combineObjectFiles verbosity lbi ldProg + ghciLibFilePath staticObjectFiles + -} + {- + whenProfLib $ do + Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles + whenGHCiLib $ do + (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) + Ld.combineObjectFiles verbosity lbi ldProg + ghciProfLibFilePath profObjectFiles + -} whenSharedLib False $ runGhcjsProg ghcSharedLinkArgs @@ -724,13 +866,19 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do runGhcjsProg ghcStaticLinkArgs -- | Start a REPL without loading any source files. -startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform - -> PackageDBStack -> IO () +startInterpreter + :: Verbosity + -> ProgramDb + -> Compiler + -> Platform + -> PackageDBStack + -> IO () startInterpreter verbosity progdb comp platform packageDBs = do - let replOpts = mempty { - ghcOptMode = toFlag GhcModeInteractive, - ghcOptPackageDBs = packageDBs - } + let replOpts = + mempty + { ghcOptMode = toFlag GhcModeInteractive + , ghcOptPackageDBs = packageDBs + } checkPackageDbStack verbosity packageDBs (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram progdb runGHC verbosity ghcjsProg comp platform replOpts @@ -740,61 +888,76 @@ startInterpreter verbosity progdb comp platform packageDBs = do -- | Build a foreign library buildFLib - :: Verbosity -> Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> ForeignLib -> ComponentLocalBuildInfo -> IO () + :: Verbosity + -> Flag (Maybe Int) + -> PackageDescription + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO () buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib replFLib - :: [String] -> Verbosity - -> Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> ForeignLib - -> ComponentLocalBuildInfo -> IO () -replFLib replFlags v njobs pkg lbi = + :: [String] + -> Verbosity + -> Flag (Maybe Int) + -> PackageDescription + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO () +replFLib replFlags v njobs pkg lbi = gbuild v njobs pkg lbi . GReplFLib replFlags -- | Build an executable with GHC. --- buildExe - :: Verbosity -> Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () + :: Verbosity + -> Flag (Maybe Int) + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe replExe - :: [String] -> Verbosity - -> Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Executable - -> ComponentLocalBuildInfo -> IO () + :: [String] + -> Verbosity + -> Flag (Maybe Int) + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () replExe replFlags v njobs pkg lbi = gbuild v njobs pkg lbi . GReplExe replFlags -- | Building an executable, starting the REPL, and building foreign -- libraries are all very similar and implemented in 'gbuild'. The -- 'GBuildMode' distinguishes between the various kinds of operation. -data GBuildMode = - GBuildExe Executable - | GReplExe [String] Executable +data GBuildMode + = GBuildExe Executable + | GReplExe [String] Executable | GBuildFLib ForeignLib - | GReplFLib [String] ForeignLib + | GReplFLib [String] ForeignLib gbuildInfo :: GBuildMode -> BuildInfo -gbuildInfo (GBuildExe exe) = buildInfo exe -gbuildInfo (GReplExe _ exe) = buildInfo exe +gbuildInfo (GBuildExe exe) = buildInfo exe +gbuildInfo (GReplExe _ exe) = buildInfo exe gbuildInfo (GBuildFLib flib) = foreignLibBuildInfo flib -gbuildInfo (GReplFLib _ flib) = foreignLibBuildInfo flib +gbuildInfo (GReplFLib _ flib) = foreignLibBuildInfo flib gbuildName :: GBuildMode -> String -gbuildName (GBuildExe exe) = unUnqualComponentName $ exeName exe -gbuildName (GReplExe _ exe) = unUnqualComponentName $ exeName exe +gbuildName (GBuildExe exe) = unUnqualComponentName $ exeName exe +gbuildName (GReplExe _ exe) = unUnqualComponentName $ exeName exe gbuildName (GBuildFLib flib) = unUnqualComponentName $ foreignLibName flib -gbuildName (GReplFLib _ flib) = unUnqualComponentName $ foreignLibName flib +gbuildName (GReplFLib _ flib) = unUnqualComponentName $ foreignLibName flib gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String -gbuildTargetName lbi (GBuildExe exe) = exeTargetName (hostPlatform lbi) exe -gbuildTargetName lbi (GReplExe _ exe) = exeTargetName (hostPlatform lbi) exe +gbuildTargetName lbi (GBuildExe exe) = exeTargetName (hostPlatform lbi) exe +gbuildTargetName lbi (GReplExe _ exe) = exeTargetName (hostPlatform lbi) exe gbuildTargetName lbi (GBuildFLib flib) = flibTargetName lbi flib -gbuildTargetName lbi (GReplFLib _ flib) = flibTargetName lbi flib +gbuildTargetName lbi (GReplFLib _ flib) = flibTargetName lbi flib exeTargetName :: Platform -> Executable -> String exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeExtension platform @@ -810,20 +973,21 @@ exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeEx -- than the target OS (but this is wrong elsewhere in Cabal as well). flibTargetName :: LocalBuildInfo -> ForeignLib -> String flibTargetName lbi flib = - case (os, foreignLibType flib) of - (Windows, ForeignLibNativeShared) -> nm <.> "dll" - (Windows, ForeignLibNativeStatic) -> nm <.> "lib" - (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt - (_other, ForeignLibNativeShared) -> "lib" ++ nm <.> dllExtension (hostPlatform lbi) - (_other, ForeignLibNativeStatic) -> "lib" ++ nm <.> staticLibExtension (hostPlatform lbi) - (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type" + case (os, foreignLibType flib) of + (Windows, ForeignLibNativeShared) -> nm <.> "dll" + (Windows, ForeignLibNativeStatic) -> nm <.> "lib" + (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt + (_other, ForeignLibNativeShared) -> "lib" ++ nm <.> dllExtension (hostPlatform lbi) + (_other, ForeignLibNativeStatic) -> "lib" ++ nm <.> staticLibExtension (hostPlatform lbi) + (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type" where nm :: String nm = unUnqualComponentName $ foreignLibName flib os :: OS - os = let (Platform _ os') = hostPlatform lbi - in os' + os = + let (Platform _ os') = hostPlatform lbi + in os' -- If a foreign lib foo has lib-version-info 5:1:2 or -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1 @@ -832,7 +996,7 @@ flibTargetName lbi flib = versionedExt :: String versionedExt = let nums = foreignLibVersion flib os - in foldl (<.>) "so" (map show nums) + in foldl (<.>) "so" (map show nums) -- | Name for the library when building. -- @@ -854,32 +1018,33 @@ flibBuildName :: LocalBuildInfo -> ForeignLib -> String flibBuildName lbi flib -- On linux, if a foreign-library has version data, the first digit is used -- to produce the SONAME. - | (os, foreignLibType flib) == - (Linux, ForeignLibNativeShared) - = let nums = foreignLibVersion flib os - in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums)) + | (os, foreignLibType flib) + == (Linux, ForeignLibNativeShared) = + let nums = foreignLibVersion flib os + in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums)) | otherwise = flibTargetName lbi flib where os :: OS - os = let (Platform _ os') = hostPlatform lbi - in os' + os = + let (Platform _ os') = hostPlatform lbi + in os' nm :: String nm = unUnqualComponentName $ foreignLibName flib gbuildIsRepl :: GBuildMode -> Bool -gbuildIsRepl (GBuildExe _) = False +gbuildIsRepl (GBuildExe _) = False gbuildIsRepl (GReplExe _ _) = True gbuildIsRepl (GBuildFLib _) = False gbuildIsRepl (GReplFLib _ _) = True gbuildNeedDynamic :: LocalBuildInfo -> GBuildMode -> Bool gbuildNeedDynamic lbi bm = - case bm of - GBuildExe _ -> withDynExe lbi - GReplExe _ _ -> withDynExe lbi - GBuildFLib flib -> withDynFLib flib - GReplFLib _ flib -> withDynFLib flib + case bm of + GBuildExe _ -> withDynExe lbi + GReplExe _ _ -> withDynExe lbi + GBuildFLib flib -> withDynFLib flib + GReplFLib _ flib -> withDynFLib flib where withDynFLib flib = case foreignLibType flib of @@ -887,12 +1052,12 @@ gbuildNeedDynamic lbi bm = ForeignLibStandalone `notElem` foreignLibOptions flib ForeignLibNativeStatic -> False - ForeignLibTypeUnknown -> + ForeignLibTypeUnknown -> cabalBug "unknown foreign lib type" gbuildModDefFiles :: GBuildMode -> [FilePath] -gbuildModDefFiles (GBuildExe _) = [] -gbuildModDefFiles (GReplExe _ _) = [] +gbuildModDefFiles (GBuildExe _) = [] +gbuildModDefFiles (GReplExe _ _) = [] gbuildModDefFiles (GBuildFLib flib) = foreignLibModDefFile flib gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib @@ -902,18 +1067,18 @@ gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib -- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed. exeMainModuleName :: Executable -> Maybe ModuleName exeMainModuleName Executable{buildInfo = bnfo} = - -- GHC honors the last occurrence of a module name updated via -main-is - -- - -- Moreover, -main-is when parsed left-to-right can update either - -- the "Main" module name, or the "main" function name, or both, - -- see also 'decodeMainIsArg'. - msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts + -- GHC honors the last occurrence of a module name updated via -main-is + -- + -- Moreover, -main-is when parsed left-to-right can update either + -- the "Main" module name, or the "main" function name, or both, + -- see also 'decodeMainIsArg'. + msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts where ghcopts = hcOptions GHC bnfo findIsMainArgs [] = [] - findIsMainArgs ("-main-is":arg:rest) = arg : findIsMainArgs rest - findIsMainArgs (_:rest) = findIsMainArgs rest + findIsMainArgs ("-main-is" : arg : rest) = arg : findIsMainArgs rest + findIsMainArgs (_ : rest) = findIsMainArgs rest -- | Decode argument to '-main-is' -- @@ -925,26 +1090,28 @@ exeMainModuleName Executable{buildInfo = bnfo} = -- https://github.com/haskell/cabal/pull/4539#discussion_r118981753. decodeMainIsArg :: String -> Maybe ModuleName decodeMainIsArg arg - | headOf main_fn isLower - -- The arg looked like "Foo.Bar.baz" - = Just (ModuleName.fromString main_mod) - | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar" - = Just (ModuleName.fromString arg) - | otherwise -- The arg looked like "baz" - = Nothing + | headOf main_fn isLower = + -- The arg looked like "Foo.Bar.baz" + Just (ModuleName.fromString main_mod) + | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar" + = + Just (ModuleName.fromString arg) + | otherwise -- The arg looked like "baz" + = + Nothing where headOf :: String -> (Char -> Bool) -> Bool headOf str pred' = any pred' (safeHead str) (main_mod, main_fn) = splitLongestPrefix arg (== '.') - splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) + splitLongestPrefix :: String -> (Char -> Bool) -> (String, String) splitLongestPrefix str pred' - | null r_pre = (str, []) - | otherwise = (reverse (safeTail r_pre), reverse r_suf) - -- 'safeTail' drops the char satisfying 'pred' - where (r_suf, r_pre) = break pred' (reverse str) - + | null r_pre = (str, []) + | otherwise = (reverse (safeTail r_pre), reverse r_suf) + where + -- 'safeTail' drops the char satisfying 'pred' + (r_suf, r_pre) = break pred' (reverse str) -- | A collection of: -- * C input files @@ -953,26 +1120,27 @@ decodeMainIsArg arg -- * GHC input modules -- -- Used to correctly build and link sources. -data BuildSources = BuildSources { - cSourcesFiles :: [FilePath], - cxxSourceFiles :: [FilePath], - inputSourceFiles :: [FilePath], - inputSourceModules :: [ModuleName] - } +data BuildSources = BuildSources + { cSourcesFiles :: [FilePath] + , cxxSourceFiles :: [FilePath] + , inputSourceFiles :: [FilePath] + , inputSourceModules :: [ModuleName] + } -- | Locate and return the 'BuildSources' required to build and link. -gbuildSources :: Verbosity - -> PackageId - -> CabalSpecVersion - -> FilePath - -> GBuildMode - -> IO BuildSources +gbuildSources + :: Verbosity + -> PackageId + -> CabalSpecVersion + -> FilePath + -> GBuildMode + -> IO BuildSources gbuildSources verbosity pkgId specVer tmpDir bm = - case bm of - GBuildExe exe -> exeSources exe - GReplExe _ exe -> exeSources exe - GBuildFLib flib -> return $ flibSources flib - GReplFLib _ flib -> return $ flibSources flib + case bm of + GBuildExe exe -> exeSources exe + GReplExe _ exe -> exeSources exe + GBuildFLib flib -> return $ flibSources flib + GReplFLib _ flib -> return $ flibSources flib where exeSources :: Executable -> IO BuildSources exeSources exe@Executable{buildInfo = bnfo, modulePath = modPath} = do @@ -984,56 +1152,60 @@ gbuildSources verbosity pkgId specVer tmpDir bm = if isHaskell main || pkgId == fakePackageId then if specVer < CabalSpecV2_0 && (mainModName `elem` otherModNames) - then do - -- The cabal manual clearly states that `other-modules` is - -- intended for non-main modules. However, there's at least one - -- important package on Hackage (happy-1.19.5) which - -- violates this. We workaround this here so that we don't - -- invoke GHC with e.g. 'ghc --make Main src/Main.hs' which - -- would result in GHC complaining about duplicate Main - -- modules. - -- - -- Finally, we only enable this workaround for - -- specVersion < 2, as 'cabal-version:>=2.0' cabal files - -- have no excuse anymore to keep doing it wrong... ;-) - warn verbosity $ "Enabling workaround for Main module '" - ++ prettyShow mainModName - ++ "' listed in 'other-modules' illegally!" - - return BuildSources { - cSourcesFiles = cSources bnfo, - cxxSourceFiles = cxxSources bnfo, - inputSourceFiles = [main], - inputSourceModules = filter (/= mainModName) $ exeModules exe - } - - else return BuildSources { - cSourcesFiles = cSources bnfo, - cxxSourceFiles = cxxSources bnfo, - inputSourceFiles = [main], - inputSourceModules = exeModules exe - } - else let (csf, cxxsf) - | isCxx main = ( cSources bnfo, main : cxxSources bnfo) - -- if main is not a Haskell source - -- and main is not a C++ source - -- then we assume that it is a C source - | otherwise = (main : cSources bnfo, cxxSources bnfo) - - in return BuildSources { - cSourcesFiles = csf, - cxxSourceFiles = cxxsf, - inputSourceFiles = [], - inputSourceModules = exeModules exe - } + then do + -- The cabal manual clearly states that `other-modules` is + -- intended for non-main modules. However, there's at least one + -- important package on Hackage (happy-1.19.5) which + -- violates this. We workaround this here so that we don't + -- invoke GHC with e.g. 'ghc --make Main src/Main.hs' which + -- would result in GHC complaining about duplicate Main + -- modules. + -- + -- Finally, we only enable this workaround for + -- specVersion < 2, as 'cabal-version:>=2.0' cabal files + -- have no excuse anymore to keep doing it wrong... ;-) + warn verbosity $ + "Enabling workaround for Main module '" + ++ prettyShow mainModName + ++ "' listed in 'other-modules' illegally!" + + return + BuildSources + { cSourcesFiles = cSources bnfo + , cxxSourceFiles = cxxSources bnfo + , inputSourceFiles = [main] + , inputSourceModules = filter (/= mainModName) $ exeModules exe + } + else + return + BuildSources + { cSourcesFiles = cSources bnfo + , cxxSourceFiles = cxxSources bnfo + , inputSourceFiles = [main] + , inputSourceModules = exeModules exe + } + else + let (csf, cxxsf) + | isCxx main = (cSources bnfo, main : cxxSources bnfo) + -- if main is not a Haskell source + -- and main is not a C++ source + -- then we assume that it is a C source + | otherwise = (main : cSources bnfo, cxxSources bnfo) + in return + BuildSources + { cSourcesFiles = csf + , cxxSourceFiles = cxxsf + , inputSourceFiles = [] + , inputSourceModules = exeModules exe + } flibSources :: ForeignLib -> BuildSources flibSources flib@ForeignLib{foreignLibBuildInfo = bnfo} = - BuildSources { - cSourcesFiles = cSources bnfo, - cxxSourceFiles = cxxSources bnfo, - inputSourceFiles = [], - inputSourceModules = foreignLibModules flib + BuildSources + { cSourcesFiles = cSources bnfo + , cxxSourceFiles = cxxSources bnfo + , inputSourceFiles = [] + , inputSourceModules = foreignLibModules flib } isCxx :: FilePath -> Bool @@ -1044,29 +1216,34 @@ isHaskell :: FilePath -> Bool isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"] -- | Generic build function. See comment for 'GBuildMode'. -gbuild :: Verbosity -> Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> GBuildMode -> ComponentLocalBuildInfo -> IO () +gbuild + :: Verbosity + -> Flag (Maybe Int) + -> PackageDescription + -> LocalBuildInfo + -> GBuildMode + -> ComponentLocalBuildInfo + -> IO () gbuild verbosity numJobs pkg_descr lbi bm clbi = do (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) let replFlags = case bm of - GReplExe flags _ -> flags - GReplFLib flags _ -> flags - GBuildExe{} -> mempty - GBuildFLib{} -> mempty - comp = compiler lbi - platform = hostPlatform lbi - implInfo = getImplInfo comp + GReplExe flags _ -> flags + GReplFLib flags _ -> flags + GBuildExe{} -> mempty + GBuildFLib{} -> mempty + comp = compiler lbi + platform = hostPlatform lbi + implInfo = getImplInfo comp runGhcProg = runGHC verbosity ghcjsProg comp platform let (bnfo, threaded) = case bm of GBuildFLib _ -> popThreadedFlag (gbuildInfo bm) - _ -> (gbuildInfo bm, False) + _ -> (gbuildInfo bm, False) -- the name that GHC really uses (e.g., with .exe on Windows for executables) let targetName = gbuildTargetName lbi bm - let targetDir = buildDir lbi (gbuildName bm) - let tmpDir = targetDir (gbuildName bm ++ "-tmp") + let targetDir = buildDir lbi (gbuildName bm) + let tmpDir = targetDir (gbuildName bm ++ "-tmp") createDirectoryIfMissingVerbose verbosity True targetDir createDirectoryIfMissingVerbose verbosity True tmpDir @@ -1078,109 +1255,134 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do let isCoverageEnabled = exeCoverage lbi distPref = fromFlag $ configDistPref $ configFlags lbi hpcdir way - | gbuildIsRepl bm = mempty -- HPC is not supported in ghci + | gbuildIsRepl bm = mempty -- HPC is not supported in ghci | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way (gbuildName bm) - | otherwise = mempty + | otherwise = mempty rpaths <- getRPaths lbi clbi buildSources <- gbuildSources verbosity (package pkg_descr) (specVersion pkg_descr) tmpDir bm - let cSrcs = cSourcesFiles buildSources - cxxSrcs = cxxSourceFiles buildSources - inputFiles = inputSourceFiles buildSources - inputModules = inputSourceModules buildSources - isGhcDynamic = isDynamic comp + let cSrcs = cSourcesFiles buildSources + cxxSrcs = cxxSourceFiles buildSources + inputFiles = inputSourceFiles buildSources + inputModules = inputSourceModules buildSources + isGhcDynamic = isDynamic comp dynamicTooSupported = supportsDynamicToo comp - cObjs = map (`replaceExtension` objExtension) cSrcs - cxxObjs = map (`replaceExtension` objExtension) cxxSrcs - needDynamic = gbuildNeedDynamic lbi bm - needProfiling = withProfExe lbi + cObjs = map (`replaceExtension` objExtension) cSrcs + cxxObjs = map (`replaceExtension` objExtension) cxxSrcs + needDynamic = gbuildNeedDynamic lbi bm + needProfiling = withProfExe lbi - -- build executables + -- build executables buildRunner = case clbi of - LibComponentLocalBuildInfo {} -> False - FLibComponentLocalBuildInfo {} -> False - ExeComponentLocalBuildInfo {} -> True - TestComponentLocalBuildInfo {} -> True - BenchComponentLocalBuildInfo {} -> True - baseOpts = (componentGhcOptions verbosity lbi bnfo clbi tmpDir) - `mappend` mempty { - ghcOptMode = toFlag GhcModeMake, - ghcOptInputFiles = toNubListR $ if package pkg_descr == fakePackageId - then filter isHaskell inputFiles - else inputFiles, - ghcOptInputScripts = toNubListR $ if package pkg_descr == fakePackageId - then filter (not . isHaskell) inputFiles - else [], - ghcOptInputModules = toNubListR inputModules, - -- for all executable components (exe/test/bench), - -- GHCJS must be passed the "-build-runner" option - ghcOptExtra = - if buildRunner then ["-build-runner"] - else mempty - } - staticOpts = baseOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticOnly, - ghcOptHPCDir = hpcdir Hpc.Vanilla - } - profOpts = baseOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptProfilingAuto = Internal.profDetailLevelFlag False - (withProfExeDetail lbi), - ghcOptHiSuffix = toFlag "p_hi", - ghcOptObjSuffix = toFlag "p_o", - ghcOptExtra = hcProfOptions GHC bnfo, - ghcOptHPCDir = hpcdir Hpc.Prof - } - dynOpts = baseOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - -- TODO: Does it hurt to set -fPIC for executables? - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "dyn_hi", - ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcSharedOptions GHC bnfo, - ghcOptHPCDir = hpcdir Hpc.Dyn - } - dynTooOpts = staticOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, - ghcOptDynHiSuffix = toFlag "dyn_hi", - ghcOptDynObjSuffix = toFlag "dyn_o", - ghcOptHPCDir = hpcdir Hpc.Dyn - } - linkerOpts = mempty { - ghcOptLinkOptions = PD.ldOptions bnfo, - ghcOptLinkLibs = extraLibs bnfo, - ghcOptLinkLibPath = toNubListR $ extraLibDirs bnfo, - ghcOptLinkFrameworks = toNubListR $ - PD.frameworks bnfo, - ghcOptLinkFrameworkDirs = toNubListR $ - PD.extraFrameworkDirs bnfo, - ghcOptInputFiles = toNubListR - [tmpDir x | x <- cObjs ++ cxxObjs] - } - dynLinkerOpts = mempty { - ghcOptRPaths = rpaths - } - replOpts = baseOpts { - ghcOptExtra = Internal.filterGhciFlags - (ghcOptExtra baseOpts) - <> replFlags - } - -- For a normal compile we do separate invocations of ghc for - -- compiling as for linking. But for repl we have to do just - -- the one invocation, so that one has to include all the - -- linker stuff too, like -l flags and any .o files from C - -- files etc. - `mappend` linkerOpts - `mappend` mempty { - ghcOptMode = toFlag GhcModeInteractive, - ghcOptOptimisation = toFlag GhcNoOptimisation - } - commonOpts | needProfiling = profOpts - | needDynamic = dynOpts - | otherwise = staticOpts - compileOpts | useDynToo = dynTooOpts - | otherwise = commonOpts + LibComponentLocalBuildInfo{} -> False + FLibComponentLocalBuildInfo{} -> False + ExeComponentLocalBuildInfo{} -> True + TestComponentLocalBuildInfo{} -> True + BenchComponentLocalBuildInfo{} -> True + baseOpts = + (componentGhcOptions verbosity lbi bnfo clbi tmpDir) + `mappend` mempty + { ghcOptMode = toFlag GhcModeMake + , ghcOptInputFiles = + toNubListR $ + if package pkg_descr == fakePackageId + then filter isHaskell inputFiles + else inputFiles + , ghcOptInputScripts = + toNubListR $ + if package pkg_descr == fakePackageId + then filter (not . isHaskell) inputFiles + else [] + , ghcOptInputModules = toNubListR inputModules + , -- for all executable components (exe/test/bench), + -- GHCJS must be passed the "-build-runner" option + ghcOptExtra = + if buildRunner + then ["-build-runner"] + else mempty + } + staticOpts = + baseOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcStaticOnly + , ghcOptHPCDir = hpcdir Hpc.Vanilla + } + profOpts = + baseOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + , ghcOptProfilingAuto = + Internal.profDetailLevelFlag + False + (withProfExeDetail lbi) + , ghcOptHiSuffix = toFlag "p_hi" + , ghcOptObjSuffix = toFlag "p_o" + , ghcOptExtra = hcProfOptions GHC bnfo + , ghcOptHPCDir = hpcdir Hpc.Prof + } + dynOpts = + baseOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcDynamicOnly + , -- TODO: Does it hurt to set -fPIC for executables? + ghcOptFPic = toFlag True + , ghcOptHiSuffix = toFlag "dyn_hi" + , ghcOptObjSuffix = toFlag "dyn_o" + , ghcOptExtra = hcSharedOptions GHC bnfo + , ghcOptHPCDir = hpcdir Hpc.Dyn + } + dynTooOpts = + staticOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic + , ghcOptDynHiSuffix = toFlag "dyn_hi" + , ghcOptDynObjSuffix = toFlag "dyn_o" + , ghcOptHPCDir = hpcdir Hpc.Dyn + } + linkerOpts = + mempty + { ghcOptLinkOptions = PD.ldOptions bnfo + , ghcOptLinkLibs = extraLibs bnfo + , ghcOptLinkLibPath = toNubListR $ extraLibDirs bnfo + , ghcOptLinkFrameworks = + toNubListR $ + PD.frameworks bnfo + , ghcOptLinkFrameworkDirs = + toNubListR $ + PD.extraFrameworkDirs bnfo + , ghcOptInputFiles = + toNubListR + [tmpDir x | x <- cObjs ++ cxxObjs] + } + dynLinkerOpts = + mempty + { ghcOptRPaths = rpaths + } + replOpts = + baseOpts + { ghcOptExtra = + Internal.filterGhciFlags + (ghcOptExtra baseOpts) + <> replFlags + } + -- For a normal compile we do separate invocations of ghc for + -- compiling as for linking. But for repl we have to do just + -- the one invocation, so that one has to include all the + -- linker stuff too, like -l flags and any .o files from C + -- files etc. + `mappend` linkerOpts + `mappend` mempty + { ghcOptMode = toFlag GhcModeInteractive + , ghcOptOptimisation = toFlag GhcNoOptimisation + } + commonOpts + | needProfiling = profOpts + | needDynamic = dynOpts + | otherwise = staticOpts + compileOpts + | useDynToo = dynTooOpts + | otherwise = commonOpts withStaticExe = not needProfiling && not needDynamic -- For building exe's that use TH with -prof or -dynamic we actually have @@ -1192,141 +1394,188 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do -- need to be .dyn_o instead of .o. doingTH = usesTemplateHaskellOrQQ bnfo -- Should we use -dynamic-too instead of compiling twice? - useDynToo = dynamicTooSupported && isGhcDynamic - && doingTH && withStaticExe - && null (hcSharedOptions GHC bnfo) - compileTHOpts | isGhcDynamic = dynOpts - | otherwise = staticOpts + useDynToo = + dynamicTooSupported + && isGhcDynamic + && doingTH + && withStaticExe + && null (hcSharedOptions GHC bnfo) + compileTHOpts + | isGhcDynamic = dynOpts + | otherwise = staticOpts compileForTH | gbuildIsRepl bm = False - | useDynToo = False - | isGhcDynamic = doingTH && (needProfiling || withStaticExe) - | otherwise = doingTH && (needProfiling || needDynamic) + | useDynToo = False + | isGhcDynamic = doingTH && (needProfiling || withStaticExe) + | otherwise = doingTH && (needProfiling || needDynamic) - -- Build static/dynamic object files for TH, if needed. + -- Build static/dynamic object files for TH, if needed. when compileForTH $ - runGhcProg compileTHOpts { ghcOptNoLink = toFlag True - , ghcOptNumJobs = numJobs } + runGhcProg + compileTHOpts + { ghcOptNoLink = toFlag True + , ghcOptNumJobs = numJobs + } -- Do not try to build anything if there are no input files. -- This can happen if the cabal file ends up with only cSrcs -- but no Haskell modules. - unless ((null inputFiles && null inputModules) - || gbuildIsRepl bm) $ - runGhcProg compileOpts { ghcOptNoLink = toFlag True - , ghcOptNumJobs = numJobs } + unless + ( (null inputFiles && null inputModules) + || gbuildIsRepl bm + ) + $ runGhcProg + compileOpts + { ghcOptNoLink = toFlag True + , ghcOptNumJobs = numJobs + } -- build any C++ sources unless (null cxxSrcs) $ do - info verbosity "Building C++ Sources..." - sequence_ - [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo - lbi bnfo clbi tmpDir filename - vanillaCxxOpts = if isGhcDynamic - -- Dynamic GHC requires C++ sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCxxOpts { ghcOptFPic = toFlag True } - else baseCxxOpts - profCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True - } - sharedCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly - } - opts | needProfiling = profCxxOpts - | needDynamic = sharedCxxOpts - | otherwise = vanillaCxxOpts - -- TODO: Placing all Haskell, C, & C++ objects in a single directory - -- Has the potential for file collisions. In general we would - -- consider this a user error. However, we should strive to - -- add a warning if this occurs. - odir = fromFlag (ghcOptObjDir opts) - createDirectoryIfMissingVerbose verbosity True odir - needsRecomp <- checkNeedsRecompilation filename opts - when needsRecomp $ - runGhcProg opts - | filename <- cxxSrcs ] + info verbosity "Building C++ Sources..." + sequence_ + [ do + let baseCxxOpts = + Internal.componentCxxGhcOptions + verbosity + implInfo + lbi + bnfo + clbi + tmpDir + filename + vanillaCxxOpts = + if isGhcDynamic + then -- Dynamic GHC requires C++ sources to be built + -- with -fPIC for REPL to work. See #2207. + baseCxxOpts{ghcOptFPic = toFlag True} + else baseCxxOpts + profCxxOpts = + vanillaCxxOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + } + sharedCxxOpts = + vanillaCxxOpts + `mappend` mempty + { ghcOptFPic = toFlag True + , ghcOptDynLinkMode = toFlag GhcDynamicOnly + } + opts + | needProfiling = profCxxOpts + | needDynamic = sharedCxxOpts + | otherwise = vanillaCxxOpts + -- TODO: Placing all Haskell, C, & C++ objects in a single directory + -- Has the potential for file collisions. In general we would + -- consider this a user error. However, we should strive to + -- add a warning if this occurs. + odir = fromFlag (ghcOptObjDir opts) + createDirectoryIfMissingVerbose verbosity True odir + needsRecomp <- checkNeedsRecompilation filename opts + when needsRecomp $ + runGhcProg opts + | filename <- cxxSrcs + ] -- build any C sources unless (null cSrcs) $ do - info verbosity "Building C Sources..." - sequence_ - [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo - lbi bnfo clbi tmpDir filename - vanillaCcOpts = if isGhcDynamic - -- Dynamic GHC requires C sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCcOpts { ghcOptFPic = toFlag True } - else baseCcOpts - profCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True - } - sharedCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly - } - opts | needProfiling = profCcOpts - | needDynamic = sharedCcOpts - | otherwise = vanillaCcOpts - odir = fromFlag (ghcOptObjDir opts) - createDirectoryIfMissingVerbose verbosity True odir - needsRecomp <- checkNeedsRecompilation filename opts - when needsRecomp $ - runGhcProg opts - | filename <- cSrcs ] + info verbosity "Building C Sources..." + sequence_ + [ do + let baseCcOpts = + Internal.componentCcGhcOptions + verbosity + implInfo + lbi + bnfo + clbi + tmpDir + filename + vanillaCcOpts = + if isGhcDynamic + then -- Dynamic GHC requires C sources to be built + -- with -fPIC for REPL to work. See #2207. + baseCcOpts{ghcOptFPic = toFlag True} + else baseCcOpts + profCcOpts = + vanillaCcOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + } + sharedCcOpts = + vanillaCcOpts + `mappend` mempty + { ghcOptFPic = toFlag True + , ghcOptDynLinkMode = toFlag GhcDynamicOnly + } + opts + | needProfiling = profCcOpts + | needDynamic = sharedCcOpts + | otherwise = vanillaCcOpts + odir = fromFlag (ghcOptObjDir opts) + createDirectoryIfMissingVerbose verbosity True odir + needsRecomp <- checkNeedsRecompilation filename opts + when needsRecomp $ + runGhcProg opts + | filename <- cSrcs + ] -- TODO: problem here is we need the .c files built first, so we can load them -- with ghci, but .c files can depend on .h files generated by ghc by ffi -- exports. case bm of - GReplExe _ _ -> runGhcProg replOpts + GReplExe _ _ -> runGhcProg replOpts GReplFLib _ _ -> runGhcProg replOpts GBuildExe _ -> do - let linkOpts = commonOpts - `mappend` linkerOpts - `mappend` mempty { - ghcOptLinkNoHsMain = toFlag (null inputFiles) - } - `mappend` (if withDynExe lbi then dynLinkerOpts else mempty) + let linkOpts = + commonOpts + `mappend` linkerOpts + `mappend` mempty + { ghcOptLinkNoHsMain = toFlag (null inputFiles) + } + `mappend` (if withDynExe lbi then dynLinkerOpts else mempty) info verbosity "Linking..." -- Work around old GHCs not relinking in this -- situation, see #3294 let target = targetDir targetName - when (compilerVersion comp < mkVersion [7,7]) $ do + when (compilerVersion comp < mkVersion [7, 7]) $ do e <- doesFileExist target when e (removeFile target) - runGhcProg linkOpts { ghcOptOutputFile = toFlag target } + runGhcProg linkOpts{ghcOptOutputFile = toFlag target} GBuildFLib flib -> do - let rtsInfo = extractRtsInfo lbi - rtsOptLinkLibs = [ - if needDynamic - then if threaded - then dynRtsThreadedLib (rtsDynamicInfo rtsInfo) - else dynRtsVanillaLib (rtsDynamicInfo rtsInfo) - else if threaded - then statRtsThreadedLib (rtsStaticInfo rtsInfo) - else statRtsVanillaLib (rtsStaticInfo rtsInfo) - ] + let rtsInfo = extractRtsInfo lbi + rtsOptLinkLibs = + [ if needDynamic + then + if threaded + then dynRtsThreadedLib (rtsDynamicInfo rtsInfo) + else dynRtsVanillaLib (rtsDynamicInfo rtsInfo) + else + if threaded + then statRtsThreadedLib (rtsStaticInfo rtsInfo) + else statRtsVanillaLib (rtsStaticInfo rtsInfo) + ] linkOpts = case foreignLibType flib of ForeignLibNativeShared -> - commonOpts - `mappend` linkerOpts - `mappend` dynLinkerOpts - `mappend` mempty { - ghcOptLinkNoHsMain = toFlag True, - ghcOptShared = toFlag True, - ghcOptLinkLibs = rtsOptLinkLibs, - ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo, - ghcOptFPic = toFlag True, - ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm - } - -- See Note [RPATH] - `mappend` ifNeedsRPathWorkaround lbi mempty { - ghcOptLinkOptions = ["-Wl,--no-as-needed"] - , ghcOptLinkLibs = ["ffi"] - } + commonOpts + `mappend` linkerOpts + `mappend` dynLinkerOpts + `mappend` mempty + { ghcOptLinkNoHsMain = toFlag True + , ghcOptShared = toFlag True + , ghcOptLinkLibs = rtsOptLinkLibs + , ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo + , ghcOptFPic = toFlag True + , ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm + } + -- See Note [RPATH] + `mappend` ifNeedsRPathWorkaround + lbi + mempty + { ghcOptLinkOptions = ["-Wl,--no-as-needed"] + , ghcOptLinkLibs = ["ffi"] + } ForeignLibNativeStatic -> -- this should be caught by buildFLib -- (and if we do implement this, we probably don't even want to call @@ -1339,7 +1588,7 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do -- @flibBuildName@. info verbosity "Linking..." let buildName = flibBuildName lbi flib - runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir buildName) } + runGhcProg linkOpts{ghcOptOutputFile = toFlag (targetDir buildName)} renameFile (targetDir buildName) (targetDir targetName) {- @@ -1416,32 +1665,32 @@ ifNeedsRPathWorkaround :: Monoid a => LocalBuildInfo -> a -> a ifNeedsRPathWorkaround lbi a = case hostPlatform lbi of Platform _ Linux -> a - _otherwise -> mempty - -data DynamicRtsInfo = DynamicRtsInfo { - dynRtsVanillaLib :: FilePath - , dynRtsThreadedLib :: FilePath - , dynRtsDebugLib :: FilePath - , dynRtsEventlogLib :: FilePath - , dynRtsThreadedDebugLib :: FilePath + _otherwise -> mempty + +data DynamicRtsInfo = DynamicRtsInfo + { dynRtsVanillaLib :: FilePath + , dynRtsThreadedLib :: FilePath + , dynRtsDebugLib :: FilePath + , dynRtsEventlogLib :: FilePath + , dynRtsThreadedDebugLib :: FilePath , dynRtsThreadedEventlogLib :: FilePath } -data StaticRtsInfo = StaticRtsInfo { - statRtsVanillaLib :: FilePath - , statRtsThreadedLib :: FilePath - , statRtsDebugLib :: FilePath - , statRtsEventlogLib :: FilePath - , statRtsThreadedDebugLib :: FilePath - , statRtsThreadedEventlogLib :: FilePath - , statRtsProfilingLib :: FilePath +data StaticRtsInfo = StaticRtsInfo + { statRtsVanillaLib :: FilePath + , statRtsThreadedLib :: FilePath + , statRtsDebugLib :: FilePath + , statRtsEventlogLib :: FilePath + , statRtsThreadedDebugLib :: FilePath + , statRtsThreadedEventlogLib :: FilePath + , statRtsProfilingLib :: FilePath , statRtsThreadedProfilingLib :: FilePath } -data RtsInfo = RtsInfo { - rtsDynamicInfo :: DynamicRtsInfo - , rtsStaticInfo :: StaticRtsInfo - , rtsLibPaths :: [FilePath] +data RtsInfo = RtsInfo + { rtsDynamicInfo :: DynamicRtsInfo + , rtsStaticInfo :: StaticRtsInfo + , rtsLibPaths :: [FilePath] } -- | Extract (and compute) information about the RTS library @@ -1452,64 +1701,71 @@ data RtsInfo = RtsInfo { -- doesn't really help. extractRtsInfo :: LocalBuildInfo -> RtsInfo extractRtsInfo lbi = - case PackageIndex.lookupPackageName (installedPkgs lbi) (mkPackageName "rts") of - [(_, [rts])] -> aux rts - _otherwise -> error "No (or multiple) ghc rts package is registered" + case PackageIndex.lookupPackageName (installedPkgs lbi) (mkPackageName "rts") of + [(_, [rts])] -> aux rts + _otherwise -> error "No (or multiple) ghc rts package is registered" where aux :: InstalledPackageInfo -> RtsInfo - aux rts = RtsInfo { - rtsDynamicInfo = DynamicRtsInfo { - dynRtsVanillaLib = withGhcVersion "HSrts" - , dynRtsThreadedLib = withGhcVersion "HSrts_thr" - , dynRtsDebugLib = withGhcVersion "HSrts_debug" - , dynRtsEventlogLib = withGhcVersion "HSrts_l" - , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug" - , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l" - } - , rtsStaticInfo = StaticRtsInfo { - statRtsVanillaLib = "HSrts" - , statRtsThreadedLib = "HSrts_thr" - , statRtsDebugLib = "HSrts_debug" - , statRtsEventlogLib = "HSrts_l" - , statRtsThreadedDebugLib = "HSrts_thr_debug" - , statRtsThreadedEventlogLib = "HSrts_thr_l" - , statRtsProfilingLib = "HSrts_p" - , statRtsThreadedProfilingLib = "HSrts_thr_p" - } - , rtsLibPaths = InstalledPackageInfo.libraryDirs rts - } + aux rts = + RtsInfo + { rtsDynamicInfo = + DynamicRtsInfo + { dynRtsVanillaLib = withGhcVersion "HSrts" + , dynRtsThreadedLib = withGhcVersion "HSrts_thr" + , dynRtsDebugLib = withGhcVersion "HSrts_debug" + , dynRtsEventlogLib = withGhcVersion "HSrts_l" + , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug" + , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l" + } + , rtsStaticInfo = + StaticRtsInfo + { statRtsVanillaLib = "HSrts" + , statRtsThreadedLib = "HSrts_thr" + , statRtsDebugLib = "HSrts_debug" + , statRtsEventlogLib = "HSrts_l" + , statRtsThreadedDebugLib = "HSrts_thr_debug" + , statRtsThreadedEventlogLib = "HSrts_thr_l" + , statRtsProfilingLib = "HSrts_p" + , statRtsThreadedProfilingLib = "HSrts_thr_p" + } + , rtsLibPaths = InstalledPackageInfo.libraryDirs rts + } withGhcVersion = (++ ("-ghc" ++ prettyShow (compilerVersion (compiler lbi)))) -- | Returns True if the modification date of the given source file is newer than -- the object file we last compiled for it, or if no object file exists yet. checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool checkNeedsRecompilation filename opts = filename `moreRecentFile` oname - where oname = getObjectFileName filename opts + where + oname = getObjectFileName filename opts -- | Finds the object file name of the given source file getObjectFileName :: FilePath -> GhcOptions -> FilePath getObjectFileName filename opts = oname - where odir = fromFlag (ghcOptObjDir opts) - oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts) - oname = odir replaceExtension filename oext + where + odir = fromFlag (ghcOptObjDir opts) + oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts) + oname = odir replaceExtension filename oext -- | Calculate the RPATHs for the component we are building. -- -- Calculates relative RPATHs when 'relocatable' is set. -getRPaths :: LocalBuildInfo - -> ComponentLocalBuildInfo -- ^ Component we are building - -> IO (NubListR FilePath) +getRPaths + :: LocalBuildInfo + -> ComponentLocalBuildInfo + -- ^ Component we are building + -> IO (NubListR FilePath) getRPaths lbi clbi | supportRPaths hostOS = do - libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi - let hostPref = case hostOS of - OSX -> "@loader_path" - _ -> "$ORIGIN" - relPath p = if isRelative p then hostPref p else p - rpaths = toNubListR (map relPath libraryPaths) - return rpaths + libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi + let hostPref = case hostOS of + OSX -> "@loader_path" + _ -> "$ORIGIN" + relPath p = if isRelative p then hostPref p else p + rpaths = toNubListR (map relPath libraryPaths) + return rpaths where (Platform _ hostOS) = hostPlatform lbi - compid = compilerId . compiler $ lbi + compid = compilerId . compiler $ lbi -- The list of RPath-supported operating systems below reflects the -- platforms on which Cabal's RPATH handling is tested. It does _NOT_ @@ -1518,29 +1774,29 @@ getRPaths lbi clbi | supportRPaths hostOS = do -- E.g. when this comment was written, the *BSD operating systems were -- untested with regards to Cabal RPATH handling, and were hence set to -- 'False', while those operating systems themselves do support RPATH. - supportRPaths Linux   = True - supportRPaths Windows = False - supportRPaths OSX   = True - supportRPaths FreeBSD   = + supportRPaths Linux = True + supportRPaths Windows = False + supportRPaths OSX = True + supportRPaths FreeBSD = case compid of - CompilerId GHC ver | ver >= mkVersion [7,10,2] -> True - _ -> False - supportRPaths OpenBSD   = False - supportRPaths NetBSD   = False - supportRPaths DragonFly = False - supportRPaths Solaris = False - supportRPaths AIX = False - supportRPaths HPUX = False - supportRPaths IRIX = False - supportRPaths HaLVM = False - supportRPaths IOS = False - supportRPaths Android = False - supportRPaths Ghcjs = False - supportRPaths Wasi = False - supportRPaths Hurd = False + CompilerId GHC ver | ver >= mkVersion [7, 10, 2] -> True + _ -> False + supportRPaths OpenBSD = False + supportRPaths NetBSD = False + supportRPaths DragonFly = False + supportRPaths Solaris = False + supportRPaths AIX = False + supportRPaths HPUX = False + supportRPaths IRIX = False + supportRPaths HaLVM = False + supportRPaths IOS = False + supportRPaths Android = False + supportRPaths Ghcjs = False + supportRPaths Wasi = False + supportRPaths Hurd = False supportRPaths (OtherOS _) = False - -- Do _not_ add a default case so that we get a warning here when a new OS - -- is added. +-- Do _not_ add a default case so that we get a warning here when a new OS +-- is added. getRPaths _ _ = return mempty @@ -1550,154 +1806,193 @@ getRPaths _ _ = return mempty -- the appropriate RTS on our own. popThreadedFlag :: BuildInfo -> (BuildInfo, Bool) popThreadedFlag bi = - ( bi { options = filterHcOptions (/= "-threaded") (options bi) } - , hasThreaded (options bi)) - + ( bi{options = filterHcOptions (/= "-threaded") (options bi)} + , hasThreaded (options bi) + ) where - filterHcOptions :: (String -> Bool) - -> PerCompilerFlavor [String] - -> PerCompilerFlavor [String] + filterHcOptions + :: (String -> Bool) + -> PerCompilerFlavor [String] + -> PerCompilerFlavor [String] filterHcOptions p (PerCompilerFlavor ghc ghcjs) = - PerCompilerFlavor (filter p ghc) ghcjs + PerCompilerFlavor (filter p ghc) ghcjs hasThreaded :: PerCompilerFlavor [String] -> Bool hasThreaded (PerCompilerFlavor ghc _) = elem "-threaded" ghc -- | Extracts a String representing a hash of the ABI of a built -- library. It can fail if the library has not yet been built. --- -libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO String +libAbiHash + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO String libAbiHash verbosity _pkg_descr lbi lib clbi = do let - libBi = libBuildInfo lib - comp = compiler lbi - platform = hostPlatform lbi - vanillaArgs0 = - (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) - `mappend` mempty { - ghcOptMode = toFlag GhcModeAbiHash, - ghcOptInputModules = toNubListR $ exposedModules lib + libBi = libBuildInfo lib + comp = compiler lbi + platform = hostPlatform lbi + vanillaArgs0 = + (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) + `mappend` mempty + { ghcOptMode = toFlag GhcModeAbiHash + , ghcOptInputModules = toNubListR $ exposedModules lib + } + vanillaArgs = + -- Package DBs unnecessary, and break ghc-cabal. See #3633 + -- BUT, put at least the global database so that 7.4 doesn't + -- break. + vanillaArgs0 + { ghcOptPackageDBs = [GlobalPackageDB] + , ghcOptPackages = mempty } - vanillaArgs = - -- Package DBs unnecessary, and break ghc-cabal. See #3633 - -- BUT, put at least the global database so that 7.4 doesn't - -- break. - vanillaArgs0 { ghcOptPackageDBs = [GlobalPackageDB] - , ghcOptPackages = mempty } - sharedArgs = vanillaArgs `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "js_dyn_hi", - ghcOptObjSuffix = toFlag "js_dyn_o", - ghcOptExtra = hcSharedOptions GHC libBi - } - profArgs = vanillaArgs `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptProfilingAuto = Internal.profDetailLevelFlag True - (withProfLibDetail lbi), - ghcOptHiSuffix = toFlag "js_p_hi", - ghcOptObjSuffix = toFlag "js_p_o", - ghcOptExtra = hcProfOptions GHC libBi - } - ghcArgs - | withVanillaLib lbi = vanillaArgs - | withSharedLib lbi = sharedArgs - | withProfLib lbi = profArgs - | otherwise = error "libAbiHash: Can't find an enabled library way" + sharedArgs = + vanillaArgs + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptFPic = toFlag True + , ghcOptHiSuffix = toFlag "js_dyn_hi" + , ghcOptObjSuffix = toFlag "js_dyn_o" + , ghcOptExtra = hcSharedOptions GHC libBi + } + profArgs = + vanillaArgs + `mappend` mempty + { ghcOptProfilingMode = toFlag True + , ghcOptProfilingAuto = + Internal.profDetailLevelFlag + True + (withProfLibDetail lbi) + , ghcOptHiSuffix = toFlag "js_p_hi" + , ghcOptObjSuffix = toFlag "js_p_o" + , ghcOptExtra = hcProfOptions GHC libBi + } + ghcArgs + | withVanillaLib lbi = vanillaArgs + | withSharedLib lbi = sharedArgs + | withProfLib lbi = profArgs + | otherwise = error "libAbiHash: Can't find an enabled library way" (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) - hash <- getProgramInvocationOutput verbosity - (ghcInvocation ghcjsProg comp platform ghcArgs) + hash <- + getProgramInvocationOutput + verbosity + (ghcInvocation ghcjsProg comp platform ghcArgs) return (takeWhile (not . isSpace) hash) -componentGhcOptions :: Verbosity -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo -> FilePath - -> GhcOptions +componentGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> GhcOptions componentGhcOptions verbosity lbi bi clbi odir = let opts = Internal.componentGhcOptions verbosity implInfo lbi bi clbi odir comp = compiler lbi implInfo = getImplInfo comp - in opts { ghcOptExtra = ghcOptExtra opts `mappend` hcOptions GHCJS bi - } - + in opts + { ghcOptExtra = ghcOptExtra opts `mappend` hcOptions GHCJS bi + } -componentCcGhcOptions :: Verbosity -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions +componentCcGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> FilePath + -> GhcOptions componentCcGhcOptions verbosity lbi = - Internal.componentCcGhcOptions verbosity implInfo lbi + Internal.componentCcGhcOptions verbosity implInfo lbi where - comp = compiler lbi + comp = compiler lbi implInfo = getImplInfo comp - -- ----------------------------------------------------------------------------- -- Installing --- |Install executables for GHCJS. -installExe :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^Where to copy the files to - -> FilePath -- ^Build location - -> (FilePath, FilePath) -- ^Executable (prefix,suffix) - -> PackageDescription - -> Executable - -> IO () -installExe verbosity lbi binDir buildPref - (progprefix, progsuffix) _pkg exe = do - createDirectoryIfMissingVerbose verbosity True binDir - let exeName' = unUnqualComponentName $ exeName exe - exeFileName = exeName' - fixedExeBaseName = progprefix ++ exeName' ++ progsuffix - installBinary dest = do - runDbProgram verbosity ghcjsProgram (withPrograms lbi) $ - [ "--install-executable" - , buildPref exeName' exeFileName - , "-o", dest - ] ++ - case (stripExes lbi, lookupProgram stripProgram $ withPrograms lbi) of - (True, Just strip) -> ["-strip-program", programPath strip] - _ -> [] - installBinary (binDir fixedExeBaseName) - - --- |Install foreign library for GHC. -installFLib :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^install location - -> FilePath -- ^Build location - -> PackageDescription - -> ForeignLib - -> IO () +-- | Install executables for GHCJS. +installExe + :: Verbosity + -> LocalBuildInfo + -> FilePath + -- ^ Where to copy the files to + -> FilePath + -- ^ Build location + -> (FilePath, FilePath) + -- ^ Executable (prefix,suffix) + -> PackageDescription + -> Executable + -> IO () +installExe + verbosity + lbi + binDir + buildPref + (progprefix, progsuffix) + _pkg + exe = do + createDirectoryIfMissingVerbose verbosity True binDir + let exeName' = unUnqualComponentName $ exeName exe + exeFileName = exeName' + fixedExeBaseName = progprefix ++ exeName' ++ progsuffix + installBinary dest = do + runDbProgram verbosity ghcjsProgram (withPrograms lbi) $ + [ "--install-executable" + , buildPref exeName' exeFileName + , "-o" + , dest + ] + ++ case (stripExes lbi, lookupProgram stripProgram $ withPrograms lbi) of + (True, Just strip) -> ["-strip-program", programPath strip] + _ -> [] + installBinary (binDir fixedExeBaseName) + +-- | Install foreign library for GHC. +installFLib + :: Verbosity + -> LocalBuildInfo + -> FilePath + -- ^ install location + -> FilePath + -- ^ Build location + -> PackageDescription + -> ForeignLib + -> IO () installFLib verbosity lbi targetDir builtDir _pkg flib = - install (foreignLibIsShared flib) - builtDir - targetDir - (flibTargetName lbi flib) + install + (foreignLibIsShared flib) + builtDir + targetDir + (flibTargetName lbi flib) where install _isShared srcDir dstDir name = do let src = srcDir name dst = dstDir name createDirectoryIfMissingVerbose verbosity True targetDir - installOrdinaryFile verbosity src dst - - --- |Install for ghc, .hi, .a and, if --with-ghci given, .o -installLib :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^install location - -> FilePath -- ^install location for dynamic libraries - -> FilePath -- ^Build location - -> PackageDescription - -> Library - -> ComponentLocalBuildInfo - -> IO () + installOrdinaryFile verbosity src dst + +-- | Install for ghc, .hi, .a and, if --with-ghci given, .o +installLib + :: Verbosity + -> LocalBuildInfo + -> FilePath + -- ^ install location + -> FilePath + -- ^ install location for dynamic libraries + -> FilePath + -- ^ Build location + -> PackageDescription + -> Library + -> ComponentLocalBuildInfo + -> IO () installLib verbosity lbi targetDir dynlibTargetDir _builtDir _pkg lib clbi = do whenVanilla $ copyModuleFiles "js_hi" - whenProf $ copyModuleFiles "js_p_hi" - whenShared $ copyModuleFiles "js_dyn_hi" + whenProf $ copyModuleFiles "js_p_hi" + whenShared $ copyModuleFiles "js_dyn_hi" -- whenVanilla $ installOrdinary builtDir targetDir $ toJSLibName vanillaLibName -- whenProf $ installOrdinary builtDir targetDir $ toJSLibName profileLibName @@ -1705,20 +2000,24 @@ installLib verbosity lbi targetDir dynlibTargetDir _builtDir _pkg lib clbi = do -- fixme do these make the correct lib names? whenHasCode $ do whenVanilla $ do - sequence_ [ installOrdinary builtDir' targetDir (toJSLibName $ mkGenericStaticLibName (l ++ f)) - | l <- getHSLibraryName (componentUnitId clbi):(extraBundledLibs (libBuildInfo lib)) - , f <- "":extraLibFlavours (libBuildInfo lib) - ] - -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciLibName) + sequence_ + [ installOrdinary builtDir' targetDir (toJSLibName $ mkGenericStaticLibName (l ++ f)) + | l <- getHSLibraryName (componentUnitId clbi) : (extraBundledLibs (libBuildInfo lib)) + , f <- "" : extraLibFlavours (libBuildInfo lib) + ] + -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciLibName) whenProf $ do installOrdinary builtDir' targetDir (toJSLibName profileLibName) - -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciProfLibName) - whenShared $ - sequence_ [ installShared builtDir' dynlibTargetDir - (toJSLibName $ mkGenericSharedLibName platform compiler_id (l ++ f)) - | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib) - , f <- "":extraDynLibFlavours (libBuildInfo lib) - ] + -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciProfLibName) + whenShared $ + sequence_ + [ installShared + builtDir' + dynlibTargetDir + (toJSLibName $ mkGenericSharedLibName platform compiler_id (l ++ f)) + | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib) + , f <- "" : extraDynLibFlavours (libBuildInfo lib) + ] where builtDir' = componentBuildDir lbi clbi @@ -1729,44 +2028,49 @@ installLib verbosity lbi targetDir dynlibTargetDir _builtDir _pkg lib clbi = do if isShared then installExecutableFile verbosity src dst - else installOrdinaryFile verbosity src dst + else installOrdinaryFile verbosity src dst when (stripLibs lbi && not isJS) $ - Strip.stripLib verbosity - (hostPlatform lbi) (withPrograms lbi) dst + Strip.stripLib + verbosity + (hostPlatform lbi) + (withPrograms lbi) + dst installOrdinary = install False True - installShared = install True True + installShared = install True True copyModuleFiles ext = findModuleFilesEx verbosity [builtDir'] [ext] (allLibModules lib clbi) - >>= installOrdinaryFiles verbosity targetDir + >>= installOrdinaryFiles verbosity targetDir compiler_id = compilerId (compiler lbi) platform = hostPlatform lbi uid = componentUnitId clbi -- vanillaLibName = mkLibName uid - profileLibName = mkProfLibName uid + profileLibName = mkProfLibName uid -- sharedLibName = (mkSharedLibName (hostPlatform lbi) compiler_id) uid - hasLib = not $ null (allLibModules lib clbi) - && null (cSources (libBuildInfo lib)) - && null (cxxSources (libBuildInfo lib)) - && null (jsSources (libBuildInfo lib)) + hasLib = + not $ + null (allLibModules lib clbi) + && null (cSources (libBuildInfo lib)) + && null (cxxSources (libBuildInfo lib)) + && null (jsSources (libBuildInfo lib)) has_code = not (componentIsIndefinite clbi) whenHasCode = when has_code whenVanilla = when (hasLib && withVanillaLib lbi) - whenProf = when (hasLib && withProfLib lbi && has_code) + whenProf = when (hasLib && withProfLib lbi && has_code) -- whenGHCi = when (hasLib && withGHCiLib lbi && has_code) - whenShared = when (hasLib && withSharedLib lbi && has_code) - + whenShared = when (hasLib && withSharedLib lbi && has_code) adjustExts :: String -> String -> GhcOptions -> GhcOptions adjustExts hiSuf objSuf opts = - opts `mappend` mempty { - ghcOptHiSuffix = toFlag hiSuf, - ghcOptObjSuffix = toFlag objSuf - } + opts + `mappend` mempty + { ghcOptHiSuffix = toFlag hiSuf + , ghcOptObjSuffix = toFlag objSuf + } isDynamic :: Compiler -> Bool isDynamic = Internal.ghcLookupProperty "GHC Dynamic" @@ -1775,7 +2079,7 @@ supportsDynamicToo :: Compiler -> Bool supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" withExt :: FilePath -> String -> FilePath -withExt fp ext = fp <.> if takeExtension fp /= ('.':ext) then ext else "" +withExt fp ext = fp <.> if takeExtension fp /= ('.' : ext) then ext else "" findGhcjsGhcVersion :: Verbosity -> FilePath -> IO (Maybe Version) findGhcjsGhcVersion verbosity pgm = @@ -1789,20 +2093,22 @@ findGhcjsPkgGhcjsVersion verbosity pgm = -- Registering hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo -hcPkgInfo progdb = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram = ghcjsPkgProg - , HcPkg.noPkgDbStack = False - , HcPkg.noVerboseFlag = False - , HcPkg.flagPackageConf = False - , HcPkg.supportsDirDbs = True - , HcPkg.requiresDirDbs = ver >= v7_10 - , HcPkg.nativeMultiInstance = ver >= v7_10 - , HcPkg.recacheMultiInstance = True - , HcPkg.suppressFilesCheck = True - } +hcPkgInfo progdb = + HcPkg.HcPkgInfo + { HcPkg.hcPkgProgram = ghcjsPkgProg + , HcPkg.noPkgDbStack = False + , HcPkg.noVerboseFlag = False + , HcPkg.flagPackageConf = False + , HcPkg.supportsDirDbs = True + , HcPkg.requiresDirDbs = ver >= v7_10 + , HcPkg.nativeMultiInstance = ver >= v7_10 + , HcPkg.recacheMultiInstance = True + , HcPkg.suppressFilesCheck = True + } where - v7_10 = mkVersion [7,10] + v7_10 = mkVersion [7, 10] ghcjsPkgProg = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs program") $ lookupProgram ghcjsPkgProgram progdb - ver = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs version") $ programVersion ghcjsPkgProg + ver = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs version") $ programVersion ghcjsPkgProg registerPackage :: Verbosity @@ -1812,22 +2118,30 @@ registerPackage -> HcPkg.RegisterOptions -> IO () registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions = - HcPkg.register (hcPkgInfo progdb) verbosity packageDbs - installedPkgInfo registerOptions + HcPkg.register + (hcPkgInfo progdb) + verbosity + packageDbs + installedPkgInfo + registerOptions pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath pkgRoot verbosity lbi = pkgRoot' - where + where pkgRoot' GlobalPackageDB = let ghcjsProg = fromMaybe (error "GHCJS.pkgRoot: no ghcjs program") $ lookupProgram ghcjsProgram (withPrograms lbi) - in fmap takeDirectory (getGlobalPackageDB verbosity ghcjsProg) + in fmap takeDirectory (getGlobalPackageDB verbosity ghcjsProg) pkgRoot' UserPackageDB = do appDir <- getAppUserDataDirectory "ghcjs" -- fixme correct this version - let ver = compilerVersion (compiler lbi) - subdir = System.Info.arch ++ '-':System.Info.os - ++ '-':prettyShow ver - rootDir = appDir subdir + let ver = compilerVersion (compiler lbi) + subdir = + System.Info.arch + ++ '-' + : System.Info.os + ++ '-' + : prettyShow ver + rootDir = appDir subdir -- We must create the root directory for the user package database if it -- does not yet exists. Otherwise '${pkgroot}' will resolve to a -- directory at the time of 'ghc-pkg register', and registration will @@ -1836,12 +2150,13 @@ pkgRoot verbosity lbi = pkgRoot' return rootDir pkgRoot' (SpecificPackageDB fp) = return (takeDirectory fp) - -- | Get the JavaScript file name and command and arguments to run a -- program compiled by GHCJS -- the exe should be the base program name without exe extension -runCmd :: ProgramDb -> FilePath - -> (FilePath, FilePath, [String]) +runCmd + :: ProgramDb + -> FilePath + -> (FilePath, FilePath, [String]) runCmd progdb exe = ( script , programPath ghcjsProg diff --git a/Cabal/src/Distribution/Simple/Glob.hs b/Cabal/src/Distribution/Simple/Glob.hs index 2586ddd68e0..81c196cb9cb 100644 --- a/Cabal/src/Distribution/Simple/Glob.hs +++ b/Cabal/src/Distribution/Simple/Glob.hs @@ -3,6 +3,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Glob -- Copyright : Isaac Jones, Simon Marlow 2003-2004 @@ -13,29 +14,28 @@ -- Portability : portable -- -- Simple file globbing. - -module Distribution.Simple.Glob ( - GlobSyntaxError(..), - GlobResult(..), - matchDirFileGlob, - matchDirFileGlobWithDie, - runDirFileGlob, - fileGlobMatches, - parseFileGlob, - explainGlobSyntaxError, - isRecursiveInRoot, - Glob, +module Distribution.Simple.Glob + ( GlobSyntaxError (..) + , GlobResult (..) + , matchDirFileGlob + , matchDirFileGlobWithDie + , runDirFileGlob + , fileGlobMatches + , parseFileGlob + , explainGlobSyntaxError + , isRecursiveInRoot + , Glob ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.CabalSpecVersion import Distribution.Simple.Utils import Distribution.Verbosity -import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist) -import System.FilePath (joinPath, splitExtensions, splitDirectories, takeFileName, (), (<.>)) +import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents) +import System.FilePath (joinPath, splitDirectories, splitExtensions, takeFileName, (<.>), ()) import qualified Data.List.NonEmpty as NE @@ -45,19 +45,19 @@ import qualified Data.List.NonEmpty as NE -- separators from the glob we might not end up properly normalised. data GlobResult a - = GlobMatch a - -- ^ The glob matched the value supplied. - | GlobWarnMultiDot a - -- ^ The glob did not match the value supplied because the + = -- | The glob matched the value supplied. + GlobMatch a + | -- | The glob did not match the value supplied because the -- cabal-version is too low and the extensions on the file did -- not precisely match the glob's extensions, but rather the -- glob was a proper suffix of the file's extensions; i.e., if -- not for the low cabal-version, it would have matched. - | GlobMissingDirectory FilePath - -- ^ The glob couldn't match because the directory named doesn't + GlobWarnMultiDot a + | -- | The glob couldn't match because the directory named doesn't -- exist. The directory will be as it appears in the glob (i.e., -- relative to the directory passed to 'matchDirFileGlob', and, -- for 'data-files', relative to 'data-dir'). + GlobMissingDirectory FilePath deriving (Show, Eq, Ord, Functor) -- | Extract the matches from a list of 'GlobResult's. @@ -65,7 +65,7 @@ data GlobResult a -- Note: throws away the 'GlobMissingDirectory' results; chances are -- that you want to check for these and error out if any are present. globMatches :: [GlobResult a] -> [a] -globMatches input = [ a | GlobMatch a <- input ] +globMatches input = [a | GlobMatch a <- input] data GlobSyntaxError = StarInDirectory @@ -80,55 +80,62 @@ data GlobSyntaxError explainGlobSyntaxError :: FilePath -> GlobSyntaxError -> String explainGlobSyntaxError filepath StarInDirectory = - "invalid file glob '" ++ filepath - ++ "'. A wildcard '**' is only allowed as the final parent" - ++ " directory. Stars must not otherwise appear in the parent" - ++ " directories." + "invalid file glob '" + ++ filepath + ++ "'. A wildcard '**' is only allowed as the final parent" + ++ " directory. Stars must not otherwise appear in the parent" + ++ " directories." explainGlobSyntaxError filepath StarInExtension = - "invalid file glob '" ++ filepath - ++ "'. Wildcards '*' are only allowed as the" - ++ " file's base name, not in the file extension." + "invalid file glob '" + ++ filepath + ++ "'. Wildcards '*' are only allowed as the" + ++ " file's base name, not in the file extension." explainGlobSyntaxError filepath StarInFileName = - "invalid file glob '" ++ filepath - ++ "'. Wildcards '*' may only totally replace the" - ++ " file's base name, not only parts of it." + "invalid file glob '" + ++ filepath + ++ "'. Wildcards '*' may only totally replace the" + ++ " file's base name, not only parts of it." explainGlobSyntaxError filepath NoExtensionOnStar = - "invalid file glob '" ++ filepath - ++ "'. If a wildcard '*' is used it must be with an file extension." + "invalid file glob '" + ++ filepath + ++ "'. If a wildcard '*' is used it must be with an file extension." explainGlobSyntaxError filepath LiteralFileNameGlobStar = - "invalid file glob '" ++ filepath - ++ "'. Prior to 'cabal-version: 3.8'" - ++ " if a wildcard '**' is used as a parent directory, the" - ++ " file's base name must be a wildcard '*'." + "invalid file glob '" + ++ filepath + ++ "'. Prior to 'cabal-version: 3.8'" + ++ " if a wildcard '**' is used as a parent directory, the" + ++ " file's base name must be a wildcard '*'." explainGlobSyntaxError _ EmptyGlob = - "invalid file glob. A glob cannot be the empty string." + "invalid file glob. A glob cannot be the empty string." explainGlobSyntaxError filepath VersionDoesNotSupportGlobStar = - "invalid file glob '" ++ filepath - ++ "'. Using the double-star syntax requires 'cabal-version: 2.4'" - ++ " or greater. Alternatively, for compatibility with earlier Cabal" - ++ " versions, list the included directories explicitly." + "invalid file glob '" + ++ filepath + ++ "'. Using the double-star syntax requires 'cabal-version: 2.4'" + ++ " or greater. Alternatively, for compatibility with earlier Cabal" + ++ " versions, list the included directories explicitly." explainGlobSyntaxError filepath VersionDoesNotSupportGlob = - "invalid file glob '" ++ filepath - ++ "'. Using star wildcards requires 'cabal-version: >= 1.6'. " - ++ "Alternatively if you require compatibility with earlier Cabal " - ++ "versions then list all the files explicitly." + "invalid file glob '" + ++ filepath + ++ "'. Using star wildcards requires 'cabal-version: >= 1.6'. " + ++ "Alternatively if you require compatibility with earlier Cabal " + ++ "versions then list all the files explicitly." -data IsRecursive = Recursive | NonRecursive deriving Eq +data IsRecursive = Recursive | NonRecursive deriving (Eq) data MultiDot = MultiDotDisabled | MultiDotEnabled data Glob - = GlobStem FilePath Glob - -- ^ A single subdirectory component + remainder. + = -- | A single subdirectory component + remainder. + GlobStem FilePath Glob | GlobFinal GlobFinal data GlobFinal - = FinalMatch IsRecursive MultiDot String - -- ^ First argument: Is this a @**/*.ext@ pattern? + = -- | First argument: Is this a @**/*.ext@ pattern? -- Second argument: should we match against the exact extensions, or accept a suffix? -- Third argument: the extensions to accept. - | FinalLit IsRecursive FilePath - -- ^ Literal file name. + FinalMatch IsRecursive MultiDot String + | -- | Literal file name. + FinalLit IsRecursive FilePath reconstructGlob :: Glob -> FilePath reconstructGlob (GlobStem dir glob) = @@ -155,7 +162,7 @@ fileGlobMatchesSegments pat (seg : segs) = case pat of fileGlobMatchesSegments pat' segs GlobFinal final -> case final of FinalMatch Recursive multidot ext -> do - let (candidateBase, candidateExts) = splitExtensions (NE.last $ seg:|segs) + let (candidateBase, candidateExts) = splitExtensions (NE.last $ seg :| segs) guard (not (null candidateBase)) checkExt multidot ext candidateExts FinalMatch NonRecursive multidot ext -> do @@ -168,8 +175,10 @@ fileGlobMatchesSegments pat (seg : segs) = case pat of checkExt :: MultiDot - -> String -- ^ The pattern's extension - -> String -- ^ The candidate file's extension + -> String + -- ^ The pattern's extension + -> String + -- ^ The candidate file's extension -> Maybe (GlobResult ()) checkExt multidot ext candidate | ext == candidate = Just (GlobMatch ()) @@ -181,37 +190,41 @@ checkExt multidot ext candidate parseFileGlob :: CabalSpecVersion -> FilePath -> Either GlobSyntaxError Glob parseFileGlob version filepath = case reverse (splitDirectories filepath) of [] -> - Left EmptyGlob + Left EmptyGlob (filename : "**" : segments) | allowGlobStar -> do finalSegment <- case splitExtensions filename of - ("*", ext) | '*' `elem` ext -> Left StarInExtension - | null ext -> Left NoExtensionOnStar - | otherwise -> Right (FinalMatch Recursive multidot ext) - _ -> if allowLiteralFilenameGlobStar - then Right (FinalLit Recursive filename) - else Left LiteralFileNameGlobStar + ("*", ext) + | '*' `elem` ext -> Left StarInExtension + | null ext -> Left NoExtensionOnStar + | otherwise -> Right (FinalMatch Recursive multidot ext) + _ -> + if allowLiteralFilenameGlobStar + then Right (FinalLit Recursive filename) + else Left LiteralFileNameGlobStar foldM addStem (GlobFinal finalSegment) segments | otherwise -> Left VersionDoesNotSupportGlobStar (filename : segments) -> do - pat <- case splitExtensions filename of - ("*", ext) | not allowGlob -> Left VersionDoesNotSupportGlob - | '*' `elem` ext -> Left StarInExtension - | null ext -> Left NoExtensionOnStar - | otherwise -> Right (FinalMatch NonRecursive multidot ext) - (_, ext) | '*' `elem` ext -> Left StarInExtension - | '*' `elem` filename -> Left StarInFileName - | otherwise -> Right (FinalLit NonRecursive filename) - foldM addStem (GlobFinal pat) segments + pat <- case splitExtensions filename of + ("*", ext) + | not allowGlob -> Left VersionDoesNotSupportGlob + | '*' `elem` ext -> Left StarInExtension + | null ext -> Left NoExtensionOnStar + | otherwise -> Right (FinalMatch NonRecursive multidot ext) + (_, ext) + | '*' `elem` ext -> Left StarInExtension + | '*' `elem` filename -> Left StarInFileName + | otherwise -> Right (FinalLit NonRecursive filename) + foldM addStem (GlobFinal pat) segments where - allowGlob = version >= CabalSpecV1_6 + allowGlob = version >= CabalSpecV1_6 allowGlobStar = version >= CabalSpecV2_4 addStem pat seg | '*' `elem` seg = Left StarInDirectory - | otherwise = Right (GlobStem seg pat) + | otherwise = Right (GlobStem seg pat) multidot | version >= CabalSpecV2_4 = MultiDotEnabled - | otherwise = MultiDotDisabled + | otherwise = MultiDotDisabled allowLiteralFilenameGlobStar = version >= CabalSpecV3_8 -- | This will 'die'' when the glob matches no files, or if the glob @@ -227,37 +240,38 @@ parseFileGlob version filepath = case reverse (splitDirectories filepath) of -- prefix. -- -- The second 'FilePath' is the glob itself. --- matchDirFileGlob :: Verbosity -> CabalSpecVersion -> FilePath -> FilePath -> IO [FilePath] matchDirFileGlob v = matchDirFileGlobWithDie v die' -- | Like 'matchDirFileGlob' but with customizable 'die' -- -- @since 3.6.0.0 --- matchDirFileGlobWithDie :: Verbosity -> (Verbosity -> String -> IO [FilePath]) -> CabalSpecVersion -> FilePath -> FilePath -> IO [FilePath] matchDirFileGlobWithDie verbosity rip version dir filepath = case parseFileGlob version filepath of Left err -> rip verbosity $ explainGlobSyntaxError filepath err Right glob -> do results <- runDirFileGlob verbosity dir glob let missingDirectories = - [ missingDir | GlobMissingDirectory missingDir <- results ] + [missingDir | GlobMissingDirectory missingDir <- results] matches = globMatches results let errors :: [String] errors = - [ "filepath wildcard '" ++ filepath ++ "' refers to the directory" - ++ " '" ++ missingDir ++ "', which does not exist or is not a directory." - | missingDir <- missingDirectories - ] - ++ - [ "filepath wildcard '" ++ filepath ++ "' does not match any files." - | null matches - ] + [ "filepath wildcard '" + ++ filepath + ++ "' refers to the directory" + ++ " '" + ++ missingDir + ++ "', which does not exist or is not a directory." + | missingDir <- missingDirectories + ] + ++ [ "filepath wildcard '" ++ filepath ++ "' does not match any files." + | null matches + ] if null errors - then return matches - else rip verbosity $ unlines errors + then return matches + else rip verbosity $ unlines errors -- | Match files against a pre-parsed glob, starting in a directory. -- @@ -276,8 +290,8 @@ runDirFileGlob verbosity rawDir pat = do -- hard-to-debug failure if we don't check for that here. when (null rawDir) $ warn verbosity $ - "Null dir passed to runDirFileGlob; interpreting it " - ++ "as '.'. This is probably an internal error." + "Null dir passed to runDirFileGlob; interpreting it " + ++ "as '.'. This is probably an internal error." let dir = if null rawDir then "." else rawDir debug verbosity $ "Expanding glob '" ++ reconstructGlob pat ++ "' in directory '" ++ dir ++ "'." -- This function might be called from the project root with dir as @@ -304,8 +318,7 @@ runDirFileGlob verbosity rawDir pat = do match <- checkExt multidot exts candidateExts return (joinedPrefix candidate <$ match) return $ mapMaybe checkName candidates - else - return [ GlobMissingDirectory joinedPrefix ] + else return [GlobMissingDirectory joinedPrefix] FinalLit Recursive fn -> do let prefix = dir joinedPrefix directoryExists <- doesDirectoryExist prefix @@ -313,15 +326,13 @@ runDirFileGlob verbosity rawDir pat = do then do candidates <- getDirectoryContentsRecursive prefix let checkName candidate - | takeFileName candidate == fn = Just $ GlobMatch (joinedPrefix candidate) - | otherwise = Nothing + | takeFileName candidate == fn = Just $ GlobMatch (joinedPrefix candidate) + | otherwise = Nothing return $ mapMaybe checkName candidates - else - return [ GlobMissingDirectory joinedPrefix ] - + else return [GlobMissingDirectory joinedPrefix] FinalLit NonRecursive fn -> do exists <- doesFileExist (dir joinedPrefix fn) - return [ GlobMatch (joinedPrefix fn) | exists ] + return [GlobMatch (joinedPrefix fn) | exists] unfoldr' :: (a -> Either r (b, a)) -> a -> ([b], r) unfoldr' f a = case f a of @@ -338,7 +349,6 @@ splitConstantPrefix = unfoldr' step step (GlobStem seg pat) = Right (seg, pat) step (GlobFinal pat) = Left pat - isRecursiveInRoot :: Glob -> Bool -isRecursiveInRoot (GlobFinal (FinalMatch Recursive _ _)) = True +isRecursiveInRoot (GlobFinal (FinalMatch Recursive _ _)) = True isRecursiveInRoot _ = False diff --git a/Cabal/src/Distribution/Simple/Haddock.hs b/Cabal/src/Distribution/Simple/Haddock.hs index 215cf92f4d4..6b54de6b6c9 100644 --- a/Cabal/src/Distribution/Simple/Haddock.hs +++ b/Cabal/src/Distribution/Simple/Haddock.hs @@ -4,6 +4,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Haddock -- Copyright : Isaac Jones 2003-2005 @@ -18,59 +19,57 @@ -- -- The @hscolour@ support allows generating HTML versions of the original -- source, with coloured syntax highlighting. - -module Distribution.Simple.Haddock ( - haddock, createHaddockIndex, hscolour, - - haddockPackagePaths, - Visibility(..) +module Distribution.Simple.Haddock + ( haddock + , createHaddockIndex + , hscolour + , haddockPackagePaths + , Visibility (..) ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS -- local -import Distribution.Backpack.DescribeUnitId + import Distribution.Backpack (OpenModule) -import Distribution.Types.ForeignLib -import Distribution.Types.UnqualComponentName -import Distribution.Types.ComponentLocalBuildInfo -import Distribution.Types.ExecutableScope -import Distribution.Types.LocalBuildInfo -import Distribution.Types.TargetInfo -import Distribution.Types.ExposedModule -import Distribution.Package +import Distribution.Backpack.DescribeUnitId +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo import qualified Distribution.ModuleName as ModuleName +import Distribution.Package import Distribution.PackageDescription +import Distribution.Parsec (simpleParsec) +import Distribution.Pretty +import Distribution.Simple.Build +import Distribution.Simple.BuildPaths +import Distribution.Simple.BuildTarget import Distribution.Simple.Compiler +import Distribution.Simple.Flag import Distribution.Simple.Glob +import Distribution.Simple.InstallDirs +import Distribution.Simple.LocalBuildInfo hiding (substPathTemplate) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PreProcess +import Distribution.Simple.Program import Distribution.Simple.Program.GHC +import qualified Distribution.Simple.Program.HcPkg as HcPkg import Distribution.Simple.Program.ResponseFile -import Distribution.Simple.Program -import Distribution.Simple.PreProcess -import Distribution.Simple.Flag +import Distribution.Simple.Register import Distribution.Simple.Setup.Haddock import Distribution.Simple.Setup.Hscolour -import Distribution.Simple.Build -import Distribution.Simple.BuildTarget -import Distribution.Simple.InstallDirs -import Distribution.Simple.LocalBuildInfo hiding (substPathTemplate) -import Distribution.Simple.BuildPaths -import Distribution.Simple.Register -import qualified Distribution.Simple.Program.HcPkg as HcPkg -import qualified Distribution.Simple.PackageIndex as PackageIndex -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo -import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) import Distribution.Simple.Utils import Distribution.System -import Distribution.Pretty -import Distribution.Parsec (simpleParsec) +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ExposedModule +import Distribution.Types.LocalBuildInfo +import Distribution.Types.TargetInfo import Distribution.Utils.NubList -import Distribution.Version import qualified Distribution.Utils.ShortText as ShortText +import Distribution.Version import Distribution.Verbosity import Language.Haskell.Extension @@ -78,71 +77,72 @@ import Language.Haskell.Extension import Distribution.Compat.Semigroup (All (..), Any (..)) import Control.Monad -import Data.Either ( rights ) +import Data.Either (rights) -import System.Directory (getCurrentDirectory, doesDirectoryExist, doesFileExist) -import System.FilePath ( (), (<.>), normalise, isAbsolute ) -import System.IO (hClose, hPutStrLn, hSetEncoding, utf8) +import System.Directory (doesDirectoryExist, doesFileExist, getCurrentDirectory) +import System.FilePath (isAbsolute, normalise, (<.>), ()) +import System.IO (hClose, hPutStrLn, hSetEncoding, utf8) -- ------------------------------------------------------------------------------ -- Types -- | A record that represents the arguments to the haddock executable, a product -- monoid. -data HaddockArgs = HaddockArgs { - argInterfaceFile :: Flag FilePath, - -- ^ Path to the interface file, relative to argOutputDir, required. - argPackageName :: Flag PackageIdentifier, - -- ^ Package name, required. - argHideModules :: (All,[ModuleName.ModuleName]), - -- ^ (Hide modules ?, modules to hide) - argIgnoreExports :: Any, - -- ^ Ignore export lists in modules? - argLinkSource :: Flag (Template,Template,Template), - -- ^ (Template for modules, template for symbols, template for lines). - argLinkedSource :: Flag Bool, - -- ^ Generate hyperlinked sources - argQuickJump :: Flag Bool, - -- ^ Generate quickjump index - argCssFile :: Flag FilePath, - -- ^ Optional custom CSS file. - argContents :: Flag String, - -- ^ Optional URL to contents page. - argGenContents :: Flag Bool, - -- ^ Generate contents - argIndex :: Flag String, - -- ^ Optional URL to index page. - argGenIndex :: Flag Bool, - -- ^ Generate index - argBaseUrl :: Flag String, - -- ^ Optional base url from which static files will be loaded. - argVerbose :: Any, - argOutput :: Flag [Output], - -- ^ HTML or Hoogle doc or both? Required. - argInterfaces :: [(FilePath, Maybe String, Maybe String, Visibility)], - -- ^ [(Interface file, URL to the HTML docs and hyperlinked-source for links)]. - argOutputDir :: Directory, - -- ^ Where to generate the documentation. - argTitle :: Flag String, - -- ^ Page title, required. - argPrologue :: Flag String, - -- ^ Prologue text, required for 'haddock', ignored by 'haddocks'. - argPrologueFile :: Flag FilePath, - -- ^ Prologue file name, ignored by 'haddock', optional for 'haddocks'. - argGhcOptions :: GhcOptions, - -- ^ Additional flags to pass to GHC. - argGhcLibDir :: Flag FilePath, - -- ^ To find the correct GHC, required. - argReexports :: [OpenModule], - -- ^ Re-exported modules - argTargets :: [FilePath], - -- ^ Modules to process. - argLib :: Flag String - -- ^ haddock's static \/ auxiliary files. -} deriving Generic +data HaddockArgs = HaddockArgs + { argInterfaceFile :: Flag FilePath + -- ^ Path to the interface file, relative to argOutputDir, required. + , argPackageName :: Flag PackageIdentifier + -- ^ Package name, required. + , argHideModules :: (All, [ModuleName.ModuleName]) + -- ^ (Hide modules ?, modules to hide) + , argIgnoreExports :: Any + -- ^ Ignore export lists in modules? + , argLinkSource :: Flag (Template, Template, Template) + -- ^ (Template for modules, template for symbols, template for lines). + , argLinkedSource :: Flag Bool + -- ^ Generate hyperlinked sources + , argQuickJump :: Flag Bool + -- ^ Generate quickjump index + , argCssFile :: Flag FilePath + -- ^ Optional custom CSS file. + , argContents :: Flag String + -- ^ Optional URL to contents page. + , argGenContents :: Flag Bool + -- ^ Generate contents + , argIndex :: Flag String + -- ^ Optional URL to index page. + , argGenIndex :: Flag Bool + -- ^ Generate index + , argBaseUrl :: Flag String + -- ^ Optional base url from which static files will be loaded. + , argVerbose :: Any + , argOutput :: Flag [Output] + -- ^ HTML or Hoogle doc or both? Required. + , argInterfaces :: [(FilePath, Maybe String, Maybe String, Visibility)] + -- ^ [(Interface file, URL to the HTML docs and hyperlinked-source for links)]. + , argOutputDir :: Directory + -- ^ Where to generate the documentation. + , argTitle :: Flag String + -- ^ Page title, required. + , argPrologue :: Flag String + -- ^ Prologue text, required for 'haddock', ignored by 'haddocks'. + , argPrologueFile :: Flag FilePath + -- ^ Prologue file name, ignored by 'haddock', optional for 'haddocks'. + , argGhcOptions :: GhcOptions + -- ^ Additional flags to pass to GHC. + , argGhcLibDir :: Flag FilePath + -- ^ To find the correct GHC, required. + , argReexports :: [OpenModule] + -- ^ Re-exported modules + , argTargets :: [FilePath] + -- ^ Modules to process. + , argLib :: Flag String + -- ^ haddock's static \/ auxiliary files. + } + deriving (Generic) -- | The FilePath of a directory, it's a monoid under '()'. -newtype Directory = Dir { unDir' :: FilePath } deriving (Read,Show,Eq,Ord) +newtype Directory = Dir {unDir' :: FilePath} deriving (Read, Show, Eq, Ord) unDir :: Directory -> FilePath unDir = normalise . unDir' @@ -150,530 +150,672 @@ unDir = normalise . unDir' type Template = String data Output = Html | Hoogle - deriving Eq + deriving (Eq) -- ------------------------------------------------------------------------------ -- Haddock support -- | Get Haddock program and check if it matches the request -getHaddockProg :: Verbosity - -> ProgramDb - -> Compiler - -> HaddockArgs - -> Flag Bool -- ^ quickjump feature - -> IO (ConfiguredProgram, Version) +getHaddockProg + :: Verbosity + -> ProgramDb + -> Compiler + -> HaddockArgs + -> Flag Bool + -- ^ quickjump feature + -> IO (ConfiguredProgram, Version) getHaddockProg verbosity programDb comp args quickJumpFlag = do - let HaddockArgs { argQuickJump - , argOutput - } = args - hoogle = Hoogle `elem` fromFlagOrDefault [] argOutput - - (haddockProg, version, _) <- - requireProgramVersion verbosity haddockProgram - (orLaterVersion (mkVersion [2,0])) programDb - - -- various sanity checks - when (hoogle && version < mkVersion [2,2]) $ - die' verbosity "Haddock 2.0 and 2.1 do not support the --hoogle flag." - - when (fromFlag argQuickJump && version < mkVersion [2,19]) $ do - let msg = "Haddock prior to 2.19 does not support the --quickjump flag." - alt = "The generated documentation won't have the QuickJump feature." - if Flag True == quickJumpFlag - then die' verbosity msg - else warn verbosity (msg ++ "\n" ++ alt) - - haddockGhcVersionStr <- getProgramOutput verbosity haddockProg - ["--ghc-version"] - case (simpleParsec haddockGhcVersionStr, compilerCompatVersion GHC comp) of - (Nothing, _) -> die' verbosity "Could not get GHC version from Haddock" - (_, Nothing) -> die' verbosity "Could not get GHC version from compiler" - (Just haddockGhcVersion, Just ghcVersion) - | haddockGhcVersion == ghcVersion -> return () - | otherwise -> die' verbosity $ - "Haddock's internal GHC version must match the configured " - ++ "GHC version.\n" - ++ "The GHC version is " ++ prettyShow ghcVersion ++ " but " - ++ "haddock is using GHC version " ++ prettyShow haddockGhcVersion - - return (haddockProg, version) - - -haddock :: PackageDescription - -> LocalBuildInfo - -> [PPSuffixHandler] - -> HaddockFlags - -> IO () + let HaddockArgs + { argQuickJump + , argOutput + } = args + hoogle = Hoogle `elem` fromFlagOrDefault [] argOutput + + (haddockProg, version, _) <- + requireProgramVersion + verbosity + haddockProgram + (orLaterVersion (mkVersion [2, 0])) + programDb + + -- various sanity checks + when (hoogle && version < mkVersion [2, 2]) $ + die' verbosity "Haddock 2.0 and 2.1 do not support the --hoogle flag." + + when (fromFlag argQuickJump && version < mkVersion [2, 19]) $ do + let msg = "Haddock prior to 2.19 does not support the --quickjump flag." + alt = "The generated documentation won't have the QuickJump feature." + if Flag True == quickJumpFlag + then die' verbosity msg + else warn verbosity (msg ++ "\n" ++ alt) + + haddockGhcVersionStr <- + getProgramOutput + verbosity + haddockProg + ["--ghc-version"] + case (simpleParsec haddockGhcVersionStr, compilerCompatVersion GHC comp) of + (Nothing, _) -> die' verbosity "Could not get GHC version from Haddock" + (_, Nothing) -> die' verbosity "Could not get GHC version from compiler" + (Just haddockGhcVersion, Just ghcVersion) + | haddockGhcVersion == ghcVersion -> return () + | otherwise -> + die' verbosity $ + "Haddock's internal GHC version must match the configured " + ++ "GHC version.\n" + ++ "The GHC version is " + ++ prettyShow ghcVersion + ++ " but " + ++ "haddock is using GHC version " + ++ prettyShow haddockGhcVersion + + return (haddockProg, version) + +haddock + :: PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HaddockFlags + -> IO () haddock pkg_descr _ _ haddockFlags - | not (hasLibs pkg_descr) - && not (fromFlag $ haddockExecutables haddockFlags) - && not (fromFlag $ haddockTestSuites haddockFlags) - && not (fromFlag $ haddockBenchmarks haddockFlags) - && not (fromFlag $ haddockForeignLibs haddockFlags) - = + | not (hasLibs pkg_descr) + && not (fromFlag $ haddockExecutables haddockFlags) + && not (fromFlag $ haddockTestSuites haddockFlags) + && not (fromFlag $ haddockBenchmarks haddockFlags) + && not (fromFlag $ haddockForeignLibs haddockFlags) = warn (fromFlag $ haddockVerbosity haddockFlags) $ - "No documentation was generated as this package does not contain " - ++ "a library. Perhaps you want to use the --executables, --tests," - ++ " --benchmarks or --foreign-libraries flags." - + "No documentation was generated as this package does not contain " + ++ "a library. Perhaps you want to use the --executables, --tests," + ++ " --benchmarks or --foreign-libraries flags." haddock pkg_descr lbi suffixes flags' = do - let verbosity = flag haddockVerbosity - comp = compiler lbi - platform = hostPlatform lbi - - quickJmpFlag = haddockQuickJump flags' - flags = case haddockTarget of - ForDevelopment -> flags' - ForHackage -> flags' - { haddockHoogle = Flag True - , haddockHtml = Flag True + let verbosity = flag haddockVerbosity + comp = compiler lbi + platform = hostPlatform lbi + + quickJmpFlag = haddockQuickJump flags' + flags = case haddockTarget of + ForDevelopment -> flags' + ForHackage -> + flags' + { haddockHoogle = Flag True + , haddockHtml = Flag True , haddockHtmlLocation = Flag (pkg_url ++ "/docs") - , haddockContents = Flag (toPathTemplate pkg_url) + , haddockContents = Flag (toPathTemplate pkg_url) , haddockLinkedSource = Flag True - , haddockQuickJump = Flag True + , haddockQuickJump = Flag True } - pkg_url = "/package/$pkg-$version" - flag f = fromFlag $ f flags - - tmpFileOpts = defaultTempFileOptions - { optKeepTempFiles = flag haddockKeepTempFiles } - htmlTemplate = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation - $ flags - haddockTarget = - fromFlagOrDefault ForDevelopment (haddockForHackage flags') - - libdirArgs <- getGhcLibDir verbosity lbi - -- The haddock-output-dir flag overrides any other documentation placement concerns. - -- The point is to give the user full freedom over the location if they need it. - let overrideWithOutputDir args = case haddockOutputDir flags of - NoFlag -> args - Flag dir -> args { argOutputDir = Dir dir } - let commonArgs = overrideWithOutputDir $ mconcat + pkg_url = "/package/$pkg-$version" + flag f = fromFlag $ f flags + + tmpFileOpts = + defaultTempFileOptions + { optKeepTempFiles = flag haddockKeepTempFiles + } + htmlTemplate = + fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ + flags + haddockTarget = + fromFlagOrDefault ForDevelopment (haddockForHackage flags') + + libdirArgs <- getGhcLibDir verbosity lbi + -- The haddock-output-dir flag overrides any other documentation placement concerns. + -- The point is to give the user full freedom over the location if they need it. + let overrideWithOutputDir args = case haddockOutputDir flags of + NoFlag -> args + Flag dir -> args{argOutputDir = Dir dir} + let commonArgs = + overrideWithOutputDir $ + mconcat [ libdirArgs , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags - , fromPackageDescription haddockTarget pkg_descr ] - - (haddockProg, version) <- - getHaddockProg verbosity (withPrograms lbi) comp commonArgs quickJmpFlag - - -- We fall back to using HsColour only for versions of Haddock which don't - -- support '--hyperlinked-sources'. - when (flag haddockLinkedSource && version < mkVersion [2,17]) $ - hscolour' (warn verbosity) haddockTarget pkg_descr lbi suffixes + , fromPackageDescription haddockTarget pkg_descr + ] + + (haddockProg, version) <- + getHaddockProg verbosity (withPrograms lbi) comp commonArgs quickJmpFlag + + -- We fall back to using HsColour only for versions of Haddock which don't + -- support '--hyperlinked-sources'. + when (flag haddockLinkedSource && version < mkVersion [2, 17]) $ + hscolour' + (warn verbosity) + haddockTarget + pkg_descr + lbi + suffixes (defaultHscolourFlags `mappend` haddockToHscolour flags) - targets <- readTargetInfos verbosity pkg_descr lbi (haddockArgs flags) - - let - targets' = - case targets of - [] -> allTargetsInBuildOrder' pkg_descr lbi - _ -> targets + targets <- readTargetInfos verbosity pkg_descr lbi (haddockArgs flags) - internalPackageDB <- - createInternalPackageDB verbosity lbi (flag haddockDistPref) + let + targets' = + case targets of + [] -> allTargetsInBuildOrder' pkg_descr lbi + _ -> targets - (\f -> foldM_ f (installedPkgs lbi) targets') $ \index target -> do + internalPackageDB <- + createInternalPackageDB verbosity lbi (flag haddockDistPref) - let component = targetComponent target - clbi = targetCLBI target + (\f -> foldM_ f (installedPkgs lbi) targets') $ \index target -> do + let component = targetComponent target + clbi = targetCLBI target - componentInitialBuildSteps (flag haddockDistPref) pkg_descr lbi clbi verbosity + componentInitialBuildSteps (flag haddockDistPref) pkg_descr lbi clbi verbosity - let - lbi' = lbi { - withPackageDB = withPackageDB lbi ++ [internalPackageDB], - installedPkgs = index + let + lbi' = + lbi + { withPackageDB = withPackageDB lbi ++ [internalPackageDB] + , installedPkgs = index } - preprocessComponent pkg_descr component lbi' clbi False verbosity suffixes - let - doExe com = case (compToExe com) of - Just exe -> do - withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi') "tmp" $ - \tmp -> do - exeArgs <- fromExecutable verbosity tmp lbi' clbi htmlTemplate - version exe - let exeArgs' = commonArgs `mappend` exeArgs - runHaddock verbosity tmpFileOpts comp platform - haddockProg True exeArgs' - Nothing -> do - warn (fromFlag $ haddockVerbosity flags) - "Unsupported component, skipping..." - return () - -- We define 'smsg' once and then reuse it inside the case, so that - -- we don't say we are running Haddock when we actually aren't - -- (e.g., Haddock is not run on non-libraries) - smsg :: IO () - smsg = setupMessage' verbosity "Running Haddock on" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - case component of - CLib lib -> do - withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ + preprocessComponent pkg_descr component lbi' clbi False verbosity suffixes + let + doExe com = case (compToExe com) of + Just exe -> do + withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi') "tmp" $ \tmp -> do - smsg - libArgs <- fromLibrary verbosity tmp lbi' clbi htmlTemplate - version lib - let libArgs' = commonArgs `mappend` libArgs - runHaddock verbosity tmpFileOpts comp platform haddockProg True libArgs' - - pwd <- getCurrentDirectory - - let - ipi = inplaceInstalledPackageInfo - pwd (flag haddockDistPref) pkg_descr - (mkAbiHash "inplace") lib lbi' clbi - - debug verbosity $ "Registering inplace:\n" + exeArgs <- + fromExecutable + verbosity + tmp + lbi' + clbi + htmlTemplate + version + exe + let exeArgs' = commonArgs `mappend` exeArgs + runHaddock + verbosity + tmpFileOpts + comp + platform + haddockProg + True + exeArgs' + Nothing -> do + warn + (fromFlag $ haddockVerbosity flags) + "Unsupported component, skipping..." + return () + -- We define 'smsg' once and then reuse it inside the case, so that + -- we don't say we are running Haddock when we actually aren't + -- (e.g., Haddock is not run on non-libraries) + smsg :: IO () + smsg = + setupMessage' + verbosity + "Running Haddock on" + (packageId pkg_descr) + (componentLocalName clbi) + (maybeComponentInstantiatedWith clbi) + case component of + CLib lib -> do + withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ + \tmp -> do + smsg + libArgs <- + fromLibrary + verbosity + tmp + lbi' + clbi + htmlTemplate + version + lib + let libArgs' = commonArgs `mappend` libArgs + runHaddock verbosity tmpFileOpts comp platform haddockProg True libArgs' + + pwd <- getCurrentDirectory + + let + ipi = + inplaceInstalledPackageInfo + pwd + (flag haddockDistPref) + pkg_descr + (mkAbiHash "inplace") + lib + lbi' + clbi + + debug verbosity $ + "Registering inplace:\n" ++ (InstalledPackageInfo.showInstalledPackageInfo ipi) - registerPackage verbosity (compiler lbi') (withPrograms lbi') - (withPackageDB lbi') ipi - HcPkg.defaultRegisterOptions { - HcPkg.registerMultiInstance = True + registerPackage + verbosity + (compiler lbi') + (withPrograms lbi') + (withPackageDB lbi') + ipi + HcPkg.defaultRegisterOptions + { HcPkg.registerMultiInstance = True } - return $ PackageIndex.insert ipi index - - CFLib flib -> (when (flag haddockForeignLibs) $ do - withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi') "tmp" $ - \tmp -> do - smsg - flibArgs <- fromForeignLib verbosity tmp lbi' clbi htmlTemplate - version flib - let libArgs' = commonArgs `mappend` flibArgs - runHaddock verbosity tmpFileOpts comp platform haddockProg True libArgs') - + return $ PackageIndex.insert ipi index + CFLib flib -> + ( when (flag haddockForeignLibs) $ do + withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi') "tmp" $ + \tmp -> do + smsg + flibArgs <- + fromForeignLib + verbosity + tmp + lbi' + clbi + htmlTemplate + version + flib + let libArgs' = commonArgs `mappend` flibArgs + runHaddock verbosity tmpFileOpts comp platform haddockProg True libArgs' + ) >> return index + CExe _ -> (when (flag haddockExecutables) $ smsg >> doExe component) >> return index + CTest _ -> (when (flag haddockTestSuites) $ smsg >> doExe component) >> return index + CBench _ -> (when (flag haddockBenchmarks) $ smsg >> doExe component) >> return index - CExe _ -> (when (flag haddockExecutables) $ smsg >> doExe component) >> return index - CTest _ -> (when (flag haddockTestSuites) $ smsg >> doExe component) >> return index - CBench _ -> (when (flag haddockBenchmarks) $ smsg >> doExe component) >> return index - - for_ (extraDocFiles pkg_descr) $ \ fpath -> do - files <- matchDirFileGlob verbosity (specVersion pkg_descr) "." fpath - for_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs) - + for_ (extraDocFiles pkg_descr) $ \fpath -> do + files <- matchDirFileGlob verbosity (specVersion pkg_descr) "." fpath + for_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs) -- | Execute 'Haddock' configured with 'HaddocksFlags'. It is used to build -- index and contents for documentation of multiple packages. --- -createHaddockIndex :: Verbosity - -> ProgramDb - -> Compiler - -> Platform - -> HaddockProjectFlags - -> IO () +createHaddockIndex + :: Verbosity + -> ProgramDb + -> Compiler + -> Platform + -> HaddockProjectFlags + -> IO () createHaddockIndex verbosity programDb comp platform flags = do - let args = fromHaddockProjectFlags flags - (haddockProg, _version) <- - getHaddockProg verbosity programDb comp args (haddockProjectQuickJump flags) - runHaddock verbosity defaultTempFileOptions comp platform haddockProg False args + let args = fromHaddockProjectFlags flags + (haddockProg, _version) <- + getHaddockProg verbosity programDb comp args (haddockProjectQuickJump flags) + runHaddock verbosity defaultTempFileOptions comp platform haddockProg False args -- ------------------------------------------------------------------------------ -- Contributions to HaddockArgs (see also Doctest.hs for very similar code). fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs fromFlags env flags = - mempty { - argHideModules = (maybe mempty (All . not) - $ flagToMaybe (haddockInternal flags), mempty), - argLinkSource = if fromFlag (haddockLinkedSource flags) - then Flag ("src/%{MODULE/./-}.html" - ,"src/%{MODULE/./-}.html#%{NAME}" - ,"src/%{MODULE/./-}.html#line-%{LINE}") - else NoFlag, - argLinkedSource = haddockLinkedSource flags, - argQuickJump = haddockQuickJump flags, - argCssFile = haddockCss flags, - argContents = fmap (fromPathTemplate . substPathTemplate env) - (haddockContents flags), - argGenContents = Flag False, - argIndex = fmap (fromPathTemplate . substPathTemplate env) - (haddockIndex flags), - argGenIndex = Flag False, - argBaseUrl = haddockBaseUrl flags, - argLib = haddockLib flags, - argVerbose = maybe mempty (Any . (>= deafening)) - . flagToMaybe $ haddockVerbosity flags, - argOutput = - Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++ - [ Hoogle | Flag True <- [haddockHoogle flags] ] - of [] -> [ Html ] - os -> os, - argOutputDir = maybe mempty Dir . flagToMaybe $ haddockDistPref flags, - - argGhcOptions = mempty { ghcOptExtra = ghcArgs } + mempty + { argHideModules = + ( maybe mempty (All . not) $ + flagToMaybe (haddockInternal flags) + , mempty + ) + , argLinkSource = + if fromFlag (haddockLinkedSource flags) + then + Flag + ( "src/%{MODULE/./-}.html" + , "src/%{MODULE/./-}.html#%{NAME}" + , "src/%{MODULE/./-}.html#line-%{LINE}" + ) + else NoFlag + , argLinkedSource = haddockLinkedSource flags + , argQuickJump = haddockQuickJump flags + , argCssFile = haddockCss flags + , argContents = + fmap + (fromPathTemplate . substPathTemplate env) + (haddockContents flags) + , argGenContents = Flag False + , argIndex = + fmap + (fromPathTemplate . substPathTemplate env) + (haddockIndex flags) + , argGenIndex = Flag False + , argBaseUrl = haddockBaseUrl flags + , argLib = haddockLib flags + , argVerbose = + maybe mempty (Any . (>= deafening)) + . flagToMaybe + $ haddockVerbosity flags + , argOutput = + Flag $ case [Html | Flag True <- [haddockHtml flags]] + ++ [Hoogle | Flag True <- [haddockHoogle flags]] of + [] -> [Html] + os -> os + , argOutputDir = maybe mempty Dir . flagToMaybe $ haddockDistPref flags + , argGhcOptions = mempty{ghcOptExtra = ghcArgs} } - where - ghcArgs = fromMaybe [] . lookup "ghc" . haddockProgramArgs $ flags + where + ghcArgs = fromMaybe [] . lookup "ghc" . haddockProgramArgs $ flags fromHaddockProjectFlags :: HaddockProjectFlags -> HaddockArgs fromHaddockProjectFlags flags = - mempty - { argOutputDir = Dir (fromFlag $ haddockProjectDir flags) - , argQuickJump = haddockProjectQuickJump flags - , argGenContents = haddockProjectGenContents flags - , argGenIndex = haddockProjectGenIndex flags - , argPrologueFile = haddockProjectPrologue flags - , argInterfaces = fromFlagOrDefault [] (haddockProjectInterfaces flags) - , argLinkedSource = haddockProjectLinkedSource flags - , argLib = haddockProjectLib flags - } - + mempty + { argOutputDir = Dir (fromFlag $ haddockProjectDir flags) + , argQuickJump = haddockProjectQuickJump flags + , argGenContents = haddockProjectGenContents flags + , argGenIndex = haddockProjectGenIndex flags + , argPrologueFile = haddockProjectPrologue flags + , argInterfaces = fromFlagOrDefault [] (haddockProjectInterfaces flags) + , argLinkedSource = haddockProjectLinkedSource flags + , argLib = haddockProjectLib flags + } fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs -fromPackageDescription haddockTarget pkg_descr = mempty +fromPackageDescription haddockTarget pkg_descr = + mempty { argInterfaceFile = Flag $ haddockName pkg_descr , argPackageName = Flag $ packageId $ pkg_descr - , argOutputDir = Dir $ - "doc" "html" haddockDirName haddockTarget pkg_descr - , argPrologue = Flag $ ShortText.fromShortText $ - if ShortText.null desc - then synopsis pkg_descr - else desc + , argOutputDir = + Dir $ + "doc" "html" haddockDirName haddockTarget pkg_descr + , argPrologue = + Flag $ + ShortText.fromShortText $ + if ShortText.null desc + then synopsis pkg_descr + else desc , argTitle = Flag $ showPkg ++ subtitle } where desc = description pkg_descr showPkg = prettyShow (packageId pkg_descr) subtitle - | ShortText.null (synopsis pkg_descr) = "" - | otherwise = ": " ++ ShortText.fromShortText (synopsis pkg_descr) - -componentGhcOptions :: Verbosity -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo -> FilePath - -> GhcOptions + | ShortText.null (synopsis pkg_descr) = "" + | otherwise = ": " ++ ShortText.fromShortText (synopsis pkg_descr) + +componentGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> GhcOptions componentGhcOptions verbosity lbi bi clbi odir = let f = case compilerFlavor (compiler lbi) of - GHC -> GHC.componentGhcOptions - GHCJS -> GHCJS.componentGhcOptions - _ -> error $ - "Distribution.Simple.Haddock.componentGhcOptions:" ++ - "haddock only supports GHC and GHCJS" - in f verbosity lbi bi clbi odir - -mkHaddockArgs :: Verbosity - -> FilePath - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Maybe PathTemplate -- ^ template for HTML location - -> Version - -> [FilePath] - -> BuildInfo - -> IO HaddockArgs + GHC -> GHC.componentGhcOptions + GHCJS -> GHCJS.componentGhcOptions + _ -> + error $ + "Distribution.Simple.Haddock.componentGhcOptions:" + ++ "haddock only supports GHC and GHCJS" + in f verbosity lbi bi clbi odir + +mkHaddockArgs + :: Verbosity + -> FilePath + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -- ^ template for HTML location + -> Version + -> [FilePath] + -> BuildInfo + -> IO HaddockArgs mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion inFiles bi = do - ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate - let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) { - -- Noooooooooo!!!!!111 - -- haddock stomps on our precious .hi - -- and .o files. Workaround by telling - -- haddock to write them elsewhere. - ghcOptObjDir = toFlag tmp, - ghcOptHiDir = toFlag tmp, - ghcOptStubDir = toFlag tmp - } `mappend` getGhcCppOpts haddockVersion bi - sharedOpts = vanillaOpts { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "dyn_hi", - ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcSharedOptions GHC bi - - } - opts <- if withVanillaLib lbi - then return vanillaOpts - else if withSharedLib lbi - then return sharedOpts - else die' verbosity $ "Must have vanilla or shared libraries " - ++ "enabled in order to run haddock" - - return ifaceArgs - { argGhcOptions = opts - , argTargets = inFiles - , argReexports = getReexports clbi + ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate + let vanillaOpts = + (componentGhcOptions normal lbi bi clbi (buildDir lbi)) + { -- Noooooooooo!!!!!111 + -- haddock stomps on our precious .hi + -- and .o files. Workaround by telling + -- haddock to write them elsewhere. + ghcOptObjDir = toFlag tmp + , ghcOptHiDir = toFlag tmp + , ghcOptStubDir = toFlag tmp + } + `mappend` getGhcCppOpts haddockVersion bi + sharedOpts = + vanillaOpts + { ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptFPic = toFlag True + , ghcOptHiSuffix = toFlag "dyn_hi" + , ghcOptObjSuffix = toFlag "dyn_o" + , ghcOptExtra = hcSharedOptions GHC bi + } + opts <- + if withVanillaLib lbi + then return vanillaOpts + else + if withSharedLib lbi + then return sharedOpts + else + die' verbosity $ + "Must have vanilla or shared libraries " + ++ "enabled in order to run haddock" + + return + ifaceArgs + { argGhcOptions = opts + , argTargets = inFiles + , argReexports = getReexports clbi } -fromLibrary :: Verbosity - -> FilePath - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Maybe PathTemplate -- ^ template for HTML location - -> Version - -> Library - -> IO HaddockArgs +fromLibrary + :: Verbosity + -> FilePath + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -- ^ template for HTML location + -> Version + -> Library + -> IO HaddockArgs fromLibrary verbosity tmp lbi clbi htmlTemplate haddockVersion lib = do - inFiles <- map snd `fmap` getLibSourceFiles verbosity lbi lib clbi - args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion - inFiles (libBuildInfo lib) - return args { - argHideModules = (mempty, otherModules (libBuildInfo lib)) - } + inFiles <- map snd `fmap` getLibSourceFiles verbosity lbi lib clbi + args <- + mkHaddockArgs + verbosity + tmp + lbi + clbi + htmlTemplate + haddockVersion + inFiles + (libBuildInfo lib) + return + args + { argHideModules = (mempty, otherModules (libBuildInfo lib)) + } -fromExecutable :: Verbosity - -> FilePath - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Maybe PathTemplate -- ^ template for HTML location - -> Version - -> Executable - -> IO HaddockArgs +fromExecutable + :: Verbosity + -> FilePath + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -- ^ template for HTML location + -> Version + -> Executable + -> IO HaddockArgs fromExecutable verbosity tmp lbi clbi htmlTemplate haddockVersion exe = do - inFiles <- map snd `fmap` getExeSourceFiles verbosity lbi exe clbi - args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate - haddockVersion inFiles (buildInfo exe) - return args { - argOutputDir = Dir $ unUnqualComponentName $ exeName exe, - argTitle = Flag $ unUnqualComponentName $ exeName exe - } + inFiles <- map snd `fmap` getExeSourceFiles verbosity lbi exe clbi + args <- + mkHaddockArgs + verbosity + tmp + lbi + clbi + htmlTemplate + haddockVersion + inFiles + (buildInfo exe) + return + args + { argOutputDir = Dir $ unUnqualComponentName $ exeName exe + , argTitle = Flag $ unUnqualComponentName $ exeName exe + } -fromForeignLib :: Verbosity - -> FilePath - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Maybe PathTemplate -- ^ template for HTML location - -> Version - -> ForeignLib - -> IO HaddockArgs +fromForeignLib + :: Verbosity + -> FilePath + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -- ^ template for HTML location + -> Version + -> ForeignLib + -> IO HaddockArgs fromForeignLib verbosity tmp lbi clbi htmlTemplate haddockVersion flib = do - inFiles <- map snd `fmap` getFLibSourceFiles verbosity lbi flib clbi - args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate - haddockVersion inFiles (foreignLibBuildInfo flib) - return args { - argOutputDir = Dir $ unUnqualComponentName $ foreignLibName flib, - argTitle = Flag $ unUnqualComponentName $ foreignLibName flib - } + inFiles <- map snd `fmap` getFLibSourceFiles verbosity lbi flib clbi + args <- + mkHaddockArgs + verbosity + tmp + lbi + clbi + htmlTemplate + haddockVersion + inFiles + (foreignLibBuildInfo flib) + return + args + { argOutputDir = Dir $ unUnqualComponentName $ foreignLibName flib + , argTitle = Flag $ unUnqualComponentName $ foreignLibName flib + } compToExe :: Component -> Maybe Executable compToExe comp = case comp of - CTest test@TestSuite { testInterface = TestSuiteExeV10 _ f } -> - Just Executable { - exeName = testName test, - modulePath = f, - exeScope = ExecutablePublic, - buildInfo = testBuildInfo test - } - CBench bench@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f } -> - Just Executable { - exeName = benchmarkName bench, - modulePath = f, - exeScope = ExecutablePublic, - buildInfo = benchmarkBuildInfo bench - } + CTest test@TestSuite{testInterface = TestSuiteExeV10 _ f} -> + Just + Executable + { exeName = testName test + , modulePath = f + , exeScope = ExecutablePublic + , buildInfo = testBuildInfo test + } + CBench bench@Benchmark{benchmarkInterface = BenchmarkExeV10 _ f} -> + Just + Executable + { exeName = benchmarkName bench + , modulePath = f + , exeScope = ExecutablePublic + , buildInfo = benchmarkBuildInfo bench + } CExe exe -> Just exe _ -> Nothing -getInterfaces :: Verbosity - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Maybe PathTemplate -- ^ template for HTML location - -> IO HaddockArgs +getInterfaces + :: Verbosity + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -- ^ template for HTML location + -> IO HaddockArgs getInterfaces verbosity lbi clbi htmlTemplate = do - (packageFlags, warnings) <- haddockPackageFlags verbosity lbi clbi htmlTemplate - traverse_ (warn (verboseUnmarkOutput verbosity)) warnings - return $ mempty { - argInterfaces = packageFlags - } + (packageFlags, warnings) <- haddockPackageFlags verbosity lbi clbi htmlTemplate + traverse_ (warn (verboseUnmarkOutput verbosity)) warnings + return $ + mempty + { argInterfaces = packageFlags + } getReexports :: ComponentLocalBuildInfo -> [OpenModule] -getReexports LibComponentLocalBuildInfo {componentExposedModules = mods } = - mapMaybe exposedReexport mods +getReexports LibComponentLocalBuildInfo{componentExposedModules = mods} = + mapMaybe exposedReexport mods getReexports _ = [] -getGhcCppOpts :: Version - -> BuildInfo - -> GhcOptions +getGhcCppOpts + :: Version + -> BuildInfo + -> GhcOptions getGhcCppOpts haddockVersion bi = - mempty { - ghcOptExtensions = toNubListR [EnableExtension CPP | needsCpp], - ghcOptCppOptions = defines + mempty + { ghcOptExtensions = toNubListR [EnableExtension CPP | needsCpp] + , ghcOptCppOptions = defines } where - needsCpp = EnableExtension CPP `elem` usedExtensions bi - defines = [haddockVersionMacro] - haddockVersionMacro = "-D__HADDOCK_VERSION__=" - ++ show (v1 * 1000 + v2 * 10 + v3) + needsCpp = EnableExtension CPP `elem` usedExtensions bi + defines = [haddockVersionMacro] + haddockVersionMacro = + "-D__HADDOCK_VERSION__=" + ++ show (v1 * 1000 + v2 * 10 + v3) where (v1, v2, v3) = case versionNumbers haddockVersion of - [] -> (0,0,0) - [x] -> (x,0,0) - [x,y] -> (x,y,0) - (x:y:z:_) -> (x,y,z) - -getGhcLibDir :: Verbosity -> LocalBuildInfo - -> IO HaddockArgs + [] -> (0, 0, 0) + [x] -> (x, 0, 0) + [x, y] -> (x, y, 0) + (x : y : z : _) -> (x, y, z) + +getGhcLibDir + :: Verbosity + -> LocalBuildInfo + -> IO HaddockArgs getGhcLibDir verbosity lbi = do - l <- case compilerFlavor (compiler lbi) of - GHC -> GHC.getLibDir verbosity lbi - GHCJS -> GHCJS.getLibDir verbosity lbi - _ -> error "haddock only supports GHC and GHCJS" - return $ mempty { argGhcLibDir = Flag l } + l <- case compilerFlavor (compiler lbi) of + GHC -> GHC.getLibDir verbosity lbi + GHCJS -> GHCJS.getLibDir verbosity lbi + _ -> error "haddock only supports GHC and GHCJS" + return $ mempty{argGhcLibDir = Flag l} -- ------------------------------------------------------------------------------ + -- | Call haddock with the specified arguments. -runHaddock :: Verbosity - -> TempFileOptions - -> Compiler - -> Platform - -> ConfiguredProgram - -> Bool -- ^ require targets - -> HaddockArgs - -> IO () +runHaddock + :: Verbosity + -> TempFileOptions + -> Compiler + -> Platform + -> ConfiguredProgram + -> Bool + -- ^ require targets + -> HaddockArgs + -> IO () runHaddock verbosity tmpFileOpts comp platform haddockProg requireTargets args - | requireTargets && null (argTargets args) = warn verbosity $ - "Haddocks are being requested, but there aren't any modules given " - ++ "to create documentation for." + | requireTargets && null (argTargets args) = + warn verbosity $ + "Haddocks are being requested, but there aren't any modules given " + ++ "to create documentation for." | otherwise = do - let haddockVersion = fromMaybe (error "unable to determine haddock version") - (programVersion haddockProg) - renderArgs verbosity tmpFileOpts haddockVersion comp platform args $ - \(flags,result)-> do - - runProgram verbosity haddockProg flags - - notice verbosity $ "Documentation created: " ++ result - - -renderArgs :: Verbosity - -> TempFileOptions - -> Version - -> Compiler - -> Platform - -> HaddockArgs - -> (([String], FilePath) -> IO a) - -> IO a + let haddockVersion = + fromMaybe + (error "unable to determine haddock version") + (programVersion haddockProg) + renderArgs verbosity tmpFileOpts haddockVersion comp platform args $ + \(flags, result) -> do + runProgram verbosity haddockProg flags + + notice verbosity $ "Documentation created: " ++ result + +renderArgs + :: Verbosity + -> TempFileOptions + -> Version + -> Compiler + -> Platform + -> HaddockArgs + -> (([String], FilePath) -> IO a) + -> IO a renderArgs verbosity tmpFileOpts version comp platform args k = do - let haddockSupportsUTF8 = version >= mkVersion [2,14,4] - haddockSupportsResponseFiles = version > mkVersion [2,16,2] + let haddockSupportsUTF8 = version >= mkVersion [2, 14, 4] + haddockSupportsResponseFiles = version > mkVersion [2, 16, 2] createDirectoryIfMissingVerbose verbosity True outputDir case argPrologue args of Flag prologueText -> withTempFileEx tmpFileOpts outputDir "haddock-prologue.txt" $ \prologueFileName h -> do - do - when haddockSupportsUTF8 (hSetEncoding h utf8) - hPutStrLn h prologueText - hClose h - let pflag = "--prologue=" ++ prologueFileName - renderedArgs = pflag : renderPureArgs version comp platform args - if haddockSupportsResponseFiles - then - withResponseFile - verbosity - tmpFileOpts - outputDir - "haddock-response.txt" - (if haddockSupportsUTF8 then Just utf8 else Nothing) - renderedArgs - (\responseFileName -> k (["@" ++ responseFileName], result)) - else - k (renderedArgs, result) + do + when haddockSupportsUTF8 (hSetEncoding h utf8) + hPutStrLn h prologueText + hClose h + let pflag = "--prologue=" ++ prologueFileName + renderedArgs = pflag : renderPureArgs version comp platform args + if haddockSupportsResponseFiles + then + withResponseFile + verbosity + tmpFileOpts + outputDir + "haddock-response.txt" + (if haddockSupportsUTF8 then Just utf8 else Nothing) + renderedArgs + (\responseFileName -> k (["@" ++ responseFileName], result)) + else k (renderedArgs, result) _ -> do - let renderedArgs = (case argPrologueFile args of - Flag pfile -> ["--prologue="++pfile] - _ -> []) - <> renderPureArgs version comp platform args + let renderedArgs = + ( case argPrologueFile args of + Flag pfile -> ["--prologue=" ++ pfile] + _ -> [] + ) + <> renderPureArgs version comp platform args if haddockSupportsResponseFiles then withResponseFile @@ -684,251 +826,273 @@ renderArgs verbosity tmpFileOpts version comp platform args k = do (if haddockSupportsUTF8 then Just utf8 else Nothing) renderedArgs (\responseFileName -> k (["@" ++ responseFileName], result)) - else - k (renderedArgs, result) - where - outputDir = (unDir $ argOutputDir args) - result = intercalate ", " - . map (\o -> outputDir - case o of - Html -> "index.html" - Hoogle -> pkgstr <.> "txt") - . fromFlagOrDefault [Html] - . argOutput - $ args - where - pkgstr = prettyShow $ packageName pkgid - pkgid = arg argPackageName - arg f = fromFlag $ f args + else k (renderedArgs, result) + where + outputDir = (unDir $ argOutputDir args) + result = + intercalate ", " + . map + ( \o -> + outputDir + case o of + Html -> "index.html" + Hoogle -> pkgstr <.> "txt" + ) + . fromFlagOrDefault [Html] + . argOutput + $ args + where + pkgstr = prettyShow $ packageName pkgid + pkgid = arg argPackageName + arg f = fromFlag $ f args renderPureArgs :: Version -> Compiler -> Platform -> HaddockArgs -> [String] -renderPureArgs version comp platform args = concat - [ map (\f -> "--dump-interface="++ unDir (argOutputDir args) f) - . flagToList . argInterfaceFile $ args - +renderPureArgs version comp platform args = + concat + [ map (\f -> "--dump-interface=" ++ unDir (argOutputDir args) f) + . flagToList + . argInterfaceFile + $ args , if haddockSupportsPackageName - then maybe [] (\pkg -> [ "--package-name=" ++ prettyShow (pkgName pkg) - , "--package-version=" ++ prettyShow (pkgVersion pkg) - ]) - . flagToMaybe . argPackageName $ args + then + maybe + [] + ( \pkg -> + [ "--package-name=" ++ prettyShow (pkgName pkg) + , "--package-version=" ++ prettyShow (pkgVersion pkg) + ] + ) + . flagToMaybe + . argPackageName + $ args else [] - - , [ "--since-qual=external" | isVersion 2 20 ] - - , [ "--quickjump" | isVersion 2 19 - , _ <- flagToList . argQuickJump $ args ] - - , [ "--hyperlinked-source" | isVersion 2 17 - , True <- flagToList . argLinkedSource $ args ] - - , (\(All b,xs) -> bool (map (("--hide=" ++) . prettyShow) xs) [] b) - . argHideModules $ args - + , ["--since-qual=external" | isVersion 2 20] + , [ "--quickjump" | isVersion 2 19, _ <- flagToList . argQuickJump $ args + ] + , [ "--hyperlinked-source" | isVersion 2 17, True <- flagToList . argLinkedSource $ args + ] + , (\(All b, xs) -> bool (map (("--hide=" ++) . prettyShow) xs) [] b) + . argHideModules + $ args , bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args - - , maybe [] (\(m,e,l) -> - ["--source-module=" ++ m - ,"--source-entity=" ++ e] - ++ if isVersion 2 14 then ["--source-entity-line=" ++ l] - else [] - ) . flagToMaybe . argLinkSource $ args - - , maybe [] ((:[]) . ("--css="++)) . flagToMaybe . argCssFile $ args - - , maybe [] ((:[]) . ("--use-contents="++)) . flagToMaybe . argContents $ args - - , bool ["--gen-contents"] [] .fromFlagOrDefault False . argGenContents $ args - - , maybe [] ((:[]) . ("--use-index="++)) . flagToMaybe . argIndex $ args - + , maybe + [] + ( \(m, e, l) -> + [ "--source-module=" ++ m + , "--source-entity=" ++ e + ] + ++ if isVersion 2 14 + then ["--source-entity-line=" ++ l] + else [] + ) + . flagToMaybe + . argLinkSource + $ args + , maybe [] ((: []) . ("--css=" ++)) . flagToMaybe . argCssFile $ args + , maybe [] ((: []) . ("--use-contents=" ++)) . flagToMaybe . argContents $ args + , bool ["--gen-contents"] [] . fromFlagOrDefault False . argGenContents $ args + , maybe [] ((: []) . ("--use-index=" ++)) . flagToMaybe . argIndex $ args , bool ["--gen-index"] [] . fromFlagOrDefault False . argGenIndex $ args - - , maybe [] ((:[]) . ("--base-url="++)) . flagToMaybe . argBaseUrl $ args - + , maybe [] ((: []) . ("--base-url=" ++)) . flagToMaybe . argBaseUrl $ args , bool [] [verbosityFlag] . getAny . argVerbose $ args - , map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html") - . fromFlagOrDefault [] . argOutput $ args - + . fromFlagOrDefault [] + . argOutput + $ args , renderInterfaces . argInterfaces $ args - - , (:[]) . ("--odir="++) . unDir . argOutputDir $ args - - , maybe [] - ( (:[]) - . ("--title="++) - . (bool (++" (internal documentation)") - id (getAny $ argIgnoreExports args)) + , (: []) . ("--odir=" ++) . unDir . argOutputDir $ args + , maybe + [] + ( (: []) + . ("--title=" ++) + . ( bool + (++ " (internal documentation)") + id + (getAny $ argIgnoreExports args) + ) ) - . flagToMaybe . argTitle $ args - - , [ "--optghc=" ++ opt | let opts = argGhcOptions args - , opt <- renderGhcOptions comp platform opts ] - - , maybe [] (\l -> ["-B"++l]) $ - flagToMaybe (argGhcLibDir args) -- error if Nothing? - - -- https://github.com/haskell/haddock/pull/547 - , [ "--reexport=" ++ prettyShow r + . flagToMaybe + . argTitle + $ args + , [ "--optghc=" ++ opt | let opts = argGhcOptions args, opt <- renderGhcOptions comp platform opts + ] + , maybe [] (\l -> ["-B" ++ l]) $ + flagToMaybe (argGhcLibDir args) -- error if Nothing? + , -- https://github.com/haskell/haddock/pull/547 + [ "--reexport=" ++ prettyShow r | r <- argReexports args , isVersion 2 19 ] - , argTargets $ args - , maybe [] ((:[]) . ("--lib="++)) . flagToMaybe . argLib $ args + , maybe [] ((: []) . ("--lib=" ++)) . flagToMaybe . argLib $ args ] - where - renderInterfaces = map renderInterface - - renderInterface :: (FilePath, Maybe FilePath, Maybe FilePath, Visibility) -> String - renderInterface (i, html, hypsrc, visibility) = "--read-interface=" ++ - (intercalate "," $ concat [ [ fromMaybe "" html ] - , -- only render hypsrc path if html path - -- is given and hyperlinked-source is - -- enabled - [ case (html, hypsrc) of - (Nothing, _) -> "" - (_, Nothing) -> "" - (_, Just x) | isVersion 2 17 - , fromFlagOrDefault False . argLinkedSource $ args - -> x - | otherwise - -> "" - ] - , if haddockSupportsVisibility - then [ case visibility of - Visible -> "visible" - Hidden -> "hidden" - ] - else [] - , [ i ] - ]) - - bool a b c = if c then a else b - isVersion major minor = version >= mkVersion [major,minor] - verbosityFlag - | isVersion 2 5 = "--verbosity=1" - | otherwise = "--verbose" - haddockSupportsVisibility = version >= mkVersion [2,26,1] - haddockSupportsPackageName = version > mkVersion [2,16] + where + renderInterfaces = map renderInterface + + renderInterface :: (FilePath, Maybe FilePath, Maybe FilePath, Visibility) -> String + renderInterface (i, html, hypsrc, visibility) = + "--read-interface=" + ++ ( intercalate "," $ + concat + [ [fromMaybe "" html] + , -- only render hypsrc path if html path + -- is given and hyperlinked-source is + -- enabled + + [ case (html, hypsrc) of + (Nothing, _) -> "" + (_, Nothing) -> "" + (_, Just x) + | isVersion 2 17 + , fromFlagOrDefault False . argLinkedSource $ args -> + x + | otherwise -> + "" + ] + , if haddockSupportsVisibility + then + [ case visibility of + Visible -> "visible" + Hidden -> "hidden" + ] + else [] + , [i] + ] + ) + + bool a b c = if c then a else b + isVersion major minor = version >= mkVersion [major, minor] + verbosityFlag + | isVersion 2 5 = "--verbosity=1" + | otherwise = "--verbose" + haddockSupportsVisibility = version >= mkVersion [2, 26, 1] + haddockSupportsPackageName = version > mkVersion [2, 16] --------------------------------------------------------------------------------- -- | Given a list of 'InstalledPackageInfo's, return a list of interfaces and -- HTML paths, and an optional warning for packages with missing documentation. -haddockPackagePaths :: [InstalledPackageInfo] - -> Maybe (InstalledPackageInfo -> FilePath) - -> IO ([( FilePath -- path to interface - -- file - - , Maybe FilePath -- url to html - -- documentation - - , Maybe FilePath -- url to hyperlinked - -- source - , Visibility - )] - , Maybe String -- warning about - -- missing documentation - ) +haddockPackagePaths + :: [InstalledPackageInfo] + -> Maybe (InstalledPackageInfo -> FilePath) + -> IO + ( [ ( FilePath -- path to interface + -- file + , Maybe FilePath -- url to html + -- documentation + , Maybe FilePath -- url to hyperlinked + -- source + , Visibility + ) + ] + , Maybe String -- warning about + -- missing documentation + ) haddockPackagePaths ipkgs mkHtmlPath = do - interfaces <- sequenceA - [ case interfaceAndHtmlPath ipkg of + interfaces <- + sequenceA + [ case interfaceAndHtmlPath ipkg of Nothing -> return (Left (packageId ipkg)) Just (interface, html) -> do - (html', hypsrc') <- case html of Just htmlPath -> do let hypSrcPath = htmlPath defaultHyperlinkedSourceDirectory hypSrcExists <- doesDirectoryExist hypSrcPath - return $ ( Just (fixFileUrl htmlPath) - , if hypSrcExists - then Just (fixFileUrl hypSrcPath) - else Nothing - ) + return $ + ( Just (fixFileUrl htmlPath) + , if hypSrcExists + then Just (fixFileUrl hypSrcPath) + else Nothing + ) Nothing -> return (Nothing, Nothing) exists <- doesFileExist interface if exists then return (Right (interface, html', hypsrc', Visible)) else return (Left pkgid) - | ipkg <- ipkgs, let pkgid = packageId ipkg - , pkgName pkgid `notElem` noHaddockWhitelist - ] + | ipkg <- ipkgs + , let pkgid = packageId ipkg + , pkgName pkgid `notElem` noHaddockWhitelist + ] - let missing = [ pkgid | Left pkgid <- interfaces ] - warning = "The documentation for the following packages are not " - ++ "installed. No links will be generated to these packages: " - ++ intercalate ", " (map prettyShow missing) + let missing = [pkgid | Left pkgid <- interfaces] + warning = + "The documentation for the following packages are not " + ++ "installed. No links will be generated to these packages: " + ++ intercalate ", " (map prettyShow missing) flags = rights interfaces return (flags, if null missing then Nothing else Just warning) - where -- Don't warn about missing documentation for these packages. See #1231. - noHaddockWhitelist = map mkPackageName [ "rts" ] + noHaddockWhitelist = map mkPackageName ["rts"] -- Actually extract interface and HTML paths from an 'InstalledPackageInfo'. - interfaceAndHtmlPath :: InstalledPackageInfo - -> Maybe (FilePath, Maybe FilePath) + interfaceAndHtmlPath + :: InstalledPackageInfo + -> Maybe (FilePath, Maybe FilePath) interfaceAndHtmlPath pkg = do interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg) html <- case mkHtmlPath of - Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg) + Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg) Just mkPath -> Just (mkPath pkg) return (interface, if null html then Nothing else Just html) -- The 'haddock-html' field in the hc-pkg output is often set as a -- native path, but we need it as a URL. See #1064. Also don't "fix" -- the path if it is an interpolated one. - fixFileUrl f | Nothing <- mkHtmlPath - , isAbsolute f = "file://" ++ f - | otherwise = f + fixFileUrl f + | Nothing <- mkHtmlPath + , isAbsolute f = + "file://" ++ f + | otherwise = f -- 'src' is the default hyperlinked source directory ever since. It is -- not possible to configure that directory in any way in haddock. defaultHyperlinkedSourceDirectory = "src" - -haddockPackageFlags :: Verbosity - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Maybe PathTemplate - -> IO ([( FilePath -- path to interface - -- file - - , Maybe FilePath -- url to html - -- documentation - - , Maybe FilePath -- url to hyperlinked - -- source - , Visibility - )] - , Maybe String -- warning about - -- missing documentation - ) +haddockPackageFlags + :: Verbosity + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -> IO + ( [ ( FilePath -- path to interface + -- file + , Maybe FilePath -- url to html + -- documentation + , Maybe FilePath -- url to hyperlinked + -- source + , Visibility + ) + ] + , Maybe String -- warning about + -- missing documentation + ) haddockPackageFlags verbosity lbi clbi htmlTemplate = do let allPkgs = installedPkgs lbi directDeps = map fst (componentPackageDeps clbi) transitiveDeps <- case PackageIndex.dependencyClosure allPkgs directDeps of - Left x -> return x - Right inf -> die' verbosity $ "internal error when calculating transitive " - ++ "package dependencies.\nDebug info: " ++ show inf + Left x -> return x + Right inf -> + die' verbosity $ + "internal error when calculating transitive " + ++ "package dependencies.\nDebug info: " + ++ show inf haddockPackagePaths (PackageIndex.allPackages transitiveDeps) mkHtmlPath - where - mkHtmlPath = fmap expandTemplateVars htmlTemplate - expandTemplateVars tmpl pkg = - fromPathTemplate . substPathTemplate (env pkg) $ tmpl - env pkg = haddockTemplateEnv lbi (packageId pkg) - + where + mkHtmlPath = fmap expandTemplateVars htmlTemplate + expandTemplateVars tmpl pkg = + fromPathTemplate . substPathTemplate (env pkg) $ tmpl + env pkg = haddockTemplateEnv lbi (packageId pkg) haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv haddockTemplateEnv lbi pkg_id = (PrefixVar, prefix (installDirTemplates lbi)) - -- We want the legacy unit ID here, because it gives us nice paths - -- (Haddock people don't care about the dependencies) - : initialPathTemplateEnv + -- We want the legacy unit ID here, because it gives us nice paths + -- (Haddock people don't care about the dependencies) + : initialPathTemplateEnv pkg_id (mkLegacyUnitId pkg_id) (compilerInfo (compiler lbi)) @@ -937,31 +1101,37 @@ haddockTemplateEnv lbi pkg_id = -- ------------------------------------------------------------------------------ -- hscolour support. -hscolour :: PackageDescription - -> LocalBuildInfo - -> [PPSuffixHandler] - -> HscolourFlags - -> IO () +hscolour + :: PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HscolourFlags + -> IO () hscolour = hscolour' dieNoVerbosity ForDevelopment -hscolour' :: (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found. - -> HaddockTarget - -> PackageDescription - -> LocalBuildInfo - -> [PPSuffixHandler] - -> HscolourFlags - -> IO () +hscolour' + :: (String -> IO ()) + -- ^ Called when the 'hscolour' exe is not found. + -> HaddockTarget + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HscolourFlags + -> IO () hscolour' onNoHsColour haddockTarget pkg_descr lbi suffixes flags = - either onNoHsColour (\(hscolourProg, _, _) -> go hscolourProg) =<< - lookupProgramVersion verbosity hscolourProgram - (orLaterVersion (mkVersion [1,8])) (withPrograms lbi) + either onNoHsColour (\(hscolourProg, _, _) -> go hscolourProg) + =<< lookupProgramVersion + verbosity + hscolourProgram + (orLaterVersion (mkVersion [1, 8])) + (withPrograms lbi) where go :: ConfiguredProgram -> IO () go hscolourProg = do warn verbosity $ - "the 'cabal hscolour' command is deprecated in favour of 'cabal " ++ - "haddock --hyperlink-source' and will be removed in the next major " ++ - "release." + "the 'cabal hscolour' command is deprecated in favour of 'cabal " + ++ "haddock --hyperlink-source' and will be removed in the next major " + ++ "release." setupMessage verbosity "Running hscolour for" (packageId pkg_descr) createDirectoryIfMissingVerbose verbosity True $ @@ -973,11 +1143,14 @@ hscolour' onNoHsColour haddockTarget pkg_descr lbi suffixes flags = let doExe com = case (compToExe com) of Just exe -> do - let outputDir = hscolourPref haddockTarget distPref pkg_descr - unUnqualComponentName (exeName exe) "src" + let outputDir = + hscolourPref haddockTarget distPref pkg_descr + unUnqualComponentName (exeName exe) + "src" runHsColour hscolourProg outputDir =<< getExeSourceFiles verbosity lbi exe clbi Nothing -> do - warn (fromFlag $ hscolourVerbosity flags) + warn + (fromFlag $ hscolourVerbosity flags) "Unsupported component, skipping..." return () case comp of @@ -985,60 +1158,68 @@ hscolour' onNoHsColour haddockTarget pkg_descr lbi suffixes flags = let outputDir = hscolourPref haddockTarget distPref pkg_descr "src" runHsColour hscolourProg outputDir =<< getLibSourceFiles verbosity lbi lib clbi CFLib flib -> do - let outputDir = hscolourPref haddockTarget distPref pkg_descr - unUnqualComponentName (foreignLibName flib) "src" + let outputDir = + hscolourPref haddockTarget distPref pkg_descr + unUnqualComponentName (foreignLibName flib) + "src" runHsColour hscolourProg outputDir =<< getFLibSourceFiles verbosity lbi flib clbi - CExe _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp - CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp - CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp + CExe _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp + CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp + CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp stylesheet = flagToMaybe (hscolourCSS flags) - verbosity = fromFlag (hscolourVerbosity flags) - distPref = fromFlag (hscolourDistPref flags) + verbosity = fromFlag (hscolourVerbosity flags) + distPref = fromFlag (hscolourDistPref flags) runHsColour prog outputDir moduleFiles = do - createDirectoryIfMissingVerbose verbosity True outputDir - - case stylesheet of -- copy the CSS file - Nothing | programVersion prog >= Just (mkVersion [1,9]) -> - runProgram verbosity prog - ["-print-css", "-o" ++ outputDir "hscolour.css"] - | otherwise -> return () - Just s -> copyFileVerbose verbosity s (outputDir "hscolour.css") - - for_ moduleFiles $ \(m, inFile) -> - runProgram verbosity prog - ["-css", "-anchor", "-o" ++ outFile m, inFile] - where - outFile m = outputDir - intercalate "-" (ModuleName.components m) <.> "html" + createDirectoryIfMissingVerbose verbosity True outputDir + + case stylesheet of -- copy the CSS file + Nothing + | programVersion prog >= Just (mkVersion [1, 9]) -> + runProgram + verbosity + prog + ["-print-css", "-o" ++ outputDir "hscolour.css"] + | otherwise -> return () + Just s -> copyFileVerbose verbosity s (outputDir "hscolour.css") + + for_ moduleFiles $ \(m, inFile) -> + runProgram + verbosity + prog + ["-css", "-anchor", "-o" ++ outFile m, inFile] + where + outFile m = + outputDir + intercalate "-" (ModuleName.components m) <.> "html" haddockToHscolour :: HaddockFlags -> HscolourFlags haddockToHscolour flags = - HscolourFlags { - hscolourCSS = haddockHscolourCss flags, - hscolourExecutables = haddockExecutables flags, - hscolourTestSuites = haddockTestSuites flags, - hscolourBenchmarks = haddockBenchmarks flags, - hscolourForeignLibs = haddockForeignLibs flags, - hscolourVerbosity = haddockVerbosity flags, - hscolourDistPref = haddockDistPref flags, - hscolourCabalFilePath = haddockCabalFilePath flags + HscolourFlags + { hscolourCSS = haddockHscolourCss flags + , hscolourExecutables = haddockExecutables flags + , hscolourTestSuites = haddockTestSuites flags + , hscolourBenchmarks = haddockBenchmarks flags + , hscolourForeignLibs = haddockForeignLibs flags + , hscolourVerbosity = haddockVerbosity flags + , hscolourDistPref = haddockDistPref flags + , hscolourCabalFilePath = haddockCabalFilePath flags } -- ------------------------------------------------------------------------------ -- Boilerplate Monoid instance. instance Monoid HaddockArgs where - mempty = gmempty - mappend = (<>) + mempty = gmempty + mappend = (<>) instance Semigroup HaddockArgs where - (<>) = gmappend + (<>) = gmappend instance Monoid Directory where - mempty = Dir "." - mappend = (<>) + mempty = Dir "." + mappend = (<>) instance Semigroup Directory where - Dir m <> Dir n = Dir $ m n + Dir m <> Dir n = Dir $ m n diff --git a/Cabal/src/Distribution/Simple/HaskellSuite.hs b/Cabal/src/Distribution/Simple/HaskellSuite.hs index d40e4d46971..cbd2fbf1a07 100644 --- a/Cabal/src/Distribution/Simple/HaskellSuite.hs +++ b/Cabal/src/Distribution/Simple/HaskellSuite.hs @@ -3,39 +3,41 @@ module Distribution.Simple.HaskellSuite where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import qualified Data.List.NonEmpty as NE -import Distribution.Simple.Program -import Distribution.Simple.Compiler -import Distribution.Simple.Utils -import Distribution.Simple.BuildPaths -import Distribution.Verbosity -import Distribution.Version -import Distribution.Pretty -import Distribution.Parsec (simpleParsec) -import Distribution.Package import Distribution.InstalledPackageInfo hiding (includeDirs) -import Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Package import Distribution.PackageDescription +import Distribution.Parsec (simpleParsec) +import Distribution.Pretty +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.Program +import Distribution.Simple.Program.Builtin +import Distribution.Simple.Utils import Distribution.System (Platform) import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version import Language.Haskell.Extension -import Distribution.Simple.Program.Builtin configure - :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb) + :: Verbosity + -> Maybe FilePath + -> Maybe FilePath + -> ProgramDb + -> IO (Compiler, Maybe Platform, ProgramDb) configure verbosity mbHcPath hcPkgPath progdb0 = do - -- We have no idea how a haskell-suite tool is named, so we require at -- least some information from the user. hcPath <- let msg = "You have to provide name or path of a haskell-suite tool (-w PATH)" - in maybe (die' verbosity msg) return mbHcPath + in maybe (die' verbosity msg) return mbHcPath when (isJust hcPkgPath) $ warn verbosity "--with-hc-pkg option is ignored for haskell-suite" @@ -54,13 +56,13 @@ configure verbosity mbHcPath hcPkgPath progdb0 = do progdb1 return (comp, Nothing, progdb2) - where configureCompiler hcPath progdb0' = do let haskellSuiteProgram' = haskellSuiteProgram - { programFindLocation = \v p -> findProgramOnSearchPath v p hcPath } + { programFindLocation = \v p -> findProgramOnSearchPath v p hcPath + } -- NB: cannot call requireProgram right away — it'd think that -- the program is already configured and won't reconfigure it again. @@ -69,19 +71,20 @@ configure verbosity mbHcPath hcPkgPath progdb0 = do (confdCompiler, progdb2) <- requireProgram verbosity haskellSuiteProgram' progdb1 extensions <- getExtensions verbosity confdCompiler - languages <- getLanguages verbosity confdCompiler + languages <- getLanguages verbosity confdCompiler (compName, compVersion) <- getCompilerVersion verbosity confdCompiler let - comp = Compiler { - compilerId = CompilerId (HaskellSuite compName) compVersion, - compilerAbiTag = NoAbiTag, - compilerCompat = [], - compilerLanguages = languages, - compilerExtensions = extensions, - compilerProperties = mempty - } + comp = + Compiler + { compilerId = CompilerId (HaskellSuite compName) compVersion + , compilerAbiTag = NoAbiTag + , compilerCompat = [] + , compilerLanguages = languages + , compilerExtensions = extensions + , compilerProperties = mempty + } return (comp, confdCompiler, progdb2) @@ -106,51 +109,63 @@ getCompilerVersion verbosity prog = do getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Maybe CompilerFlag)] getExtensions verbosity prog = do extStrs <- - lines `fmap` - rawSystemStdout verbosity (programPath prog) ["--supported-extensions"] + lines + `fmap` rawSystemStdout verbosity (programPath prog) ["--supported-extensions"] return - [ (ext, Just $ "-X" ++ prettyShow ext) | Just ext <- map simpleParsec extStrs ] + [(ext, Just $ "-X" ++ prettyShow ext) | Just ext <- map simpleParsec extStrs] getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, CompilerFlag)] getLanguages verbosity prog = do langStrs <- - lines `fmap` - rawSystemStdout verbosity (programPath prog) ["--supported-languages"] + lines + `fmap` rawSystemStdout verbosity (programPath prog) ["--supported-languages"] return - [ (ext, "-G" ++ prettyShow ext) | Just ext <- map simpleParsec langStrs ] + [(ext, "-G" ++ prettyShow ext) | Just ext <- map simpleParsec langStrs] -- Other compilers do some kind of a packagedb stack check here. Not sure -- if we need something like that as well. -getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb - -> IO InstalledPackageIndex +getInstalledPackages + :: Verbosity + -> PackageDBStack + -> ProgramDb + -> IO InstalledPackageIndex getInstalledPackages verbosity packagedbs progdb = liftM (PackageIndex.fromList . concat) $ for packagedbs $ \packagedb -> - do str <- - getDbProgramOutput verbosity haskellSuitePkgProgram progdb - ["dump", packageDbOpt packagedb] - `catchExit` \_ -> die' verbosity $ "pkg dump failed" - case parsePackages str of - Right ok -> return ok - _ -> die' verbosity "failed to parse output of 'pkg dump'" - + do + str <- + getDbProgramOutput + verbosity + haskellSuitePkgProgram + progdb + ["dump", packageDbOpt packagedb] + `catchExit` \_ -> die' verbosity $ "pkg dump failed" + case parsePackages str of + Right ok -> return ok + _ -> die' verbosity "failed to parse output of 'pkg dump'" where parsePackages str = - case partitionEithers $ map (parseInstalledPackageInfo . toUTF8BS) (splitPkgs str) of - ([], ok) -> Right [ pkg | (_, pkg) <- ok ] - (msgss, _) -> Left (foldMap NE.toList msgss) + case partitionEithers $ map (parseInstalledPackageInfo . toUTF8BS) (splitPkgs str) of + ([], ok) -> Right [pkg | (_, pkg) <- ok] + (msgss, _) -> Left (foldMap NE.toList msgss) splitPkgs :: String -> [String] splitPkgs = map unlines . splitWith ("---" ==) . lines where splitWith :: (a -> Bool) -> [a] -> [[a]] - splitWith p xs = ys : case zs of - [] -> [] - _:ws -> splitWith p ws - where (ys,zs) = break p xs + splitWith p xs = + ys : case zs of + [] -> [] + _ : ws -> splitWith p ws + where + (ys, zs) = break p xs buildLib - :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () buildLib verbosity pkg_descr lbi lib clbi = do -- In future, there should be a mechanism for the compiler to request any -- number of the above parameters (or their parts) — in particular, @@ -167,28 +182,37 @@ buildLib verbosity pkg_descr lbi lib clbi = do pkgid = packageId pkg_descr runDbProgram verbosity haskellSuiteProgram progdb $ - [ "compile", "--build-dir", odir ] ++ - concat [ ["-i", d] | d <- srcDirs ] ++ - concat [ ["-I", d] | d <- [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] ++ includeDirs bi ] ++ - [ packageDbOpt pkgDb | pkgDb <- dbStack ] ++ - [ "--package-name", prettyShow pkgid ] ++ - concat [ ["--package-id", prettyShow ipkgid ] - | (ipkgid, _) <- componentPackageDeps clbi ] ++ - ["-G", prettyShow language] ++ - concat [ ["-X", prettyShow ex] | ex <- usedExtensions bi ] ++ - cppOptions (libBuildInfo lib) ++ - [ prettyShow modu | modu <- allLibModules lib clbi ] - - + ["compile", "--build-dir", odir] + ++ concat [["-i", d] | d <- srcDirs] + ++ concat + [ ["-I", d] + | d <- + [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + , odir + ] + ++ includeDirs bi + ] + ++ [packageDbOpt pkgDb | pkgDb <- dbStack] + ++ ["--package-name", prettyShow pkgid] + ++ concat + [ ["--package-id", prettyShow ipkgid] + | (ipkgid, _) <- componentPackageDeps clbi + ] + ++ ["-G", prettyShow language] + ++ concat [["-X", prettyShow ex] | ex <- usedExtensions bi] + ++ cppOptions (libBuildInfo lib) + ++ [prettyShow modu | modu <- allLibModules lib clbi] installLib :: Verbosity -> LocalBuildInfo - -> FilePath -- ^install location - -> FilePath -- ^install location for dynamic libraries - -> FilePath -- ^Build location + -> FilePath + -- ^ install location + -> FilePath + -- ^ install location for dynamic libraries + -> FilePath + -- ^ Build location -> PackageDescription -> Library -> ComponentLocalBuildInfo @@ -197,11 +221,16 @@ installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib clbi = do let progdb = withPrograms lbi runDbProgram verbosity haskellSuitePkgProgram progdb $ [ "install-library" - , "--build-dir", builtDir - , "--target-dir", targetDir - , "--dynlib-target-dir", dynlibTargetDir - , "--package-id", prettyShow $ packageId pkg - ] ++ map prettyShow (allLibModules lib clbi) + , "--build-dir" + , builtDir + , "--target-dir" + , targetDir + , "--dynlib-target-dir" + , dynlibTargetDir + , "--package-id" + , prettyShow $ packageId pkg + ] + ++ map prettyShow (allLibModules lib clbi) registerPackage :: Verbosity @@ -213,16 +242,22 @@ registerPackage verbosity progdb packageDbs installedPkgInfo = do (hspkg, _) <- requireProgram verbosity haskellSuitePkgProgram progdb runProgramInvocation verbosity $ - (programInvocation hspkg - ["update", packageDbOpt $ registrationPackageDB packageDbs]) - { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo installedPkgInfo } + ( programInvocation + hspkg + ["update", packageDbOpt $ registrationPackageDB packageDbs] + ) + { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo installedPkgInfo + } initPackageDB :: Verbosity -> ProgramDb -> FilePath -> IO () initPackageDB verbosity progdb dbPath = - runDbProgram verbosity haskellSuitePkgProgram progdb + runDbProgram + verbosity + haskellSuitePkgProgram + progdb ["init", dbPath] packageDbOpt :: PackageDB -> String -packageDbOpt GlobalPackageDB = "--global" -packageDbOpt UserPackageDB = "--user" +packageDbOpt GlobalPackageDB = "--global" +packageDbOpt UserPackageDB = "--user" packageDbOpt (SpecificPackageDB db) = "--package-db=" ++ db diff --git a/Cabal/src/Distribution/Simple/Hpc.hs b/Cabal/src/Distribution/Simple/Hpc.hs index 4e292509d78..5d24f190b7e 100644 --- a/Cabal/src/Distribution/Simple/Hpc.hs +++ b/Cabal/src/Distribution/Simple/Hpc.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Hpc -- Copyright : Thomas Tuegel 2011 @@ -13,39 +14,39 @@ -- This module provides functions for locating various HPC-related paths and -- a function for adding the necessary options to a PackageDescription to -- build test suites with HPC enabled. - module Distribution.Simple.Hpc - ( Way(..), guessWay - , htmlDir - , mixDir - , tixDir - , tixFilePath - , markupPackage - , markupTest - ) where + ( Way (..) + , guessWay + , htmlDir + , mixDir + , tixDir + , tixFilePath + , markupPackage + , markupTest + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.UnqualComponentName -import Distribution.ModuleName ( main ) -import qualified Distribution.PackageDescription as PD +import Distribution.ModuleName (main) import Distribution.PackageDescription - ( Library(..) - , TestSuite(..) - , testModules - ) + ( Library (..) + , TestSuite (..) + , testModules + ) +import qualified Distribution.PackageDescription as PD import Distribution.Pretty -import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..)) import Distribution.Simple.Program - ( hpcProgram - , requireProgramVersion - ) -import Distribution.Simple.Program.Hpc ( markup, union ) -import Distribution.Simple.Utils ( notice ) -import Distribution.Version ( anyVersion ) -import Distribution.Verbosity ( Verbosity() ) -import System.Directory ( createDirectoryIfMissing, doesFileExist ) + ( hpcProgram + , requireProgramVersion + ) +import Distribution.Simple.Program.Hpc (markup, union) +import Distribution.Simple.Utils (notice) +import Distribution.Types.UnqualComponentName +import Distribution.Verbosity (Verbosity ()) +import Distribution.Version (anyVersion) +import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath -- ------------------------------------------------------------------------- @@ -54,9 +55,12 @@ import System.FilePath data Way = Vanilla | Prof | Dyn deriving (Bounded, Enum, Eq, Read, Show) -hpcDir :: FilePath -- ^ \"dist/\" prefix - -> Way - -> FilePath -- ^ Directory containing component's HPC .mix files +hpcDir + :: FilePath + -- ^ \"dist/\" prefix + -> Way + -> FilePath + -- ^ Directory containing component's HPC .mix files hpcDir distPref way = distPref "hpc" wayDir where wayDir = case way of @@ -64,51 +68,69 @@ hpcDir distPref way = distPref "hpc" wayDir Prof -> "prof" Dyn -> "dyn" -mixDir :: FilePath -- ^ \"dist/\" prefix - -> Way - -> FilePath -- ^ Component name - -> FilePath -- ^ Directory containing test suite's .mix files +mixDir + :: FilePath + -- ^ \"dist/\" prefix + -> Way + -> FilePath + -- ^ Component name + -> FilePath + -- ^ Directory containing test suite's .mix files mixDir distPref way name = hpcDir distPrefBuild way "mix" name - where - -- This is a hack for HPC over test suites, needed to match the directory - -- where HPC saves and reads .mix files when the main library of the same - -- package is being processed, perhaps in a previous cabal run (#5213). - -- E.g., @distPref@ may be - -- @./dist-newstyle/build/x86_64-linux/ghc-9.0.1/cabal-gh5213-0.1/t/tests@ - -- but the path where library mix files reside has two less components - -- at the end (@t/tests@) and this reduced path needs to be passed to - -- both @hpc@ and @ghc@. For non-default optimization levels, the path - -- suffix is one element longer and the extra path element needs - -- to be preserved. - distPrefElements = splitDirectories distPref - distPrefBuild = case drop (length distPrefElements - 3) distPrefElements of - ["t", _, "noopt"] -> - joinPath $ take (length distPrefElements - 3) distPrefElements - ++ ["noopt"] - ["t", _, "opt"] -> - joinPath $ take (length distPrefElements - 3) distPrefElements - ++ ["opt"] - [_, "t", _] -> - joinPath $ take (length distPrefElements - 2) distPrefElements - _ -> distPref + where + -- This is a hack for HPC over test suites, needed to match the directory + -- where HPC saves and reads .mix files when the main library of the same + -- package is being processed, perhaps in a previous cabal run (#5213). + -- E.g., @distPref@ may be + -- @./dist-newstyle/build/x86_64-linux/ghc-9.0.1/cabal-gh5213-0.1/t/tests@ + -- but the path where library mix files reside has two less components + -- at the end (@t/tests@) and this reduced path needs to be passed to + -- both @hpc@ and @ghc@. For non-default optimization levels, the path + -- suffix is one element longer and the extra path element needs + -- to be preserved. + distPrefElements = splitDirectories distPref + distPrefBuild = case drop (length distPrefElements - 3) distPrefElements of + ["t", _, "noopt"] -> + joinPath $ + take (length distPrefElements - 3) distPrefElements + ++ ["noopt"] + ["t", _, "opt"] -> + joinPath $ + take (length distPrefElements - 3) distPrefElements + ++ ["opt"] + [_, "t", _] -> + joinPath $ take (length distPrefElements - 2) distPrefElements + _ -> distPref -tixDir :: FilePath -- ^ \"dist/\" prefix - -> Way - -> FilePath -- ^ Component name - -> FilePath -- ^ Directory containing test suite's .tix files +tixDir + :: FilePath + -- ^ \"dist/\" prefix + -> Way + -> FilePath + -- ^ Component name + -> FilePath + -- ^ Directory containing test suite's .tix files tixDir distPref way name = hpcDir distPref way "tix" name -- | Path to the .tix file containing a test suite's sum statistics. -tixFilePath :: FilePath -- ^ \"dist/\" prefix - -> Way - -> FilePath -- ^ Component name - -> FilePath -- ^ Path to test suite's .tix file +tixFilePath + :: FilePath + -- ^ \"dist/\" prefix + -> Way + -> FilePath + -- ^ Component name + -> FilePath + -- ^ Path to test suite's .tix file tixFilePath distPref way name = tixDir distPref way name name <.> "tix" -htmlDir :: FilePath -- ^ \"dist/\" prefix - -> Way - -> FilePath -- ^ Component name - -> FilePath -- ^ Path to test suite's HTML markup directory +htmlDir + :: FilePath + -- ^ \"dist/\" prefix + -> Way + -> FilePath + -- ^ Component name + -> FilePath + -- ^ Path to test suite's HTML markup directory htmlDir distPref way name = hpcDir distPref way "html" name -- | Attempt to guess the way the test suites in this package were compiled @@ -120,55 +142,76 @@ guessWay lbi | otherwise = Vanilla -- | Generate the HTML markup for a test suite. -markupTest :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^ \"dist/\" prefix - -> String -- ^ Library name - -> TestSuite - -> Library - -> IO () +markupTest + :: Verbosity + -> LocalBuildInfo + -> FilePath + -- ^ \"dist/\" prefix + -> String + -- ^ Library name + -> TestSuite + -> Library + -> IO () markupTest verbosity lbi distPref libraryName suite library = do - tixFileExists <- doesFileExist $ tixFilePath distPref way $ testName' - when tixFileExists $ do - -- behaviour of 'markup' depends on version, so we need *a* version - -- but no particular one - (hpc, hpcVer, _) <- requireProgramVersion verbosity - hpcProgram anyVersion (withPrograms lbi) - let htmlDir_ = htmlDir distPref way testName' - markup hpc hpcVer verbosity - (tixFilePath distPref way testName') mixDirs - htmlDir_ - (exposedModules library) - notice verbosity $ "Test coverage report written to " - ++ htmlDir_ "hpc_index" <.> "html" + tixFileExists <- doesFileExist $ tixFilePath distPref way $ testName' + when tixFileExists $ do + -- behaviour of 'markup' depends on version, so we need *a* version + -- but no particular one + (hpc, hpcVer, _) <- + requireProgramVersion + verbosity + hpcProgram + anyVersion + (withPrograms lbi) + let htmlDir_ = htmlDir distPref way testName' + markup + hpc + hpcVer + verbosity + (tixFilePath distPref way testName') + mixDirs + htmlDir_ + (exposedModules library) + notice verbosity $ + "Test coverage report written to " + ++ htmlDir_ + "hpc_index" <.> "html" where way = guessWay lbi testName' = unUnqualComponentName $ testName suite - mixDirs = map (mixDir distPref way) [ testName', libraryName ] + mixDirs = map (mixDir distPref way) [testName', libraryName] -- | Generate the HTML markup for all of a package's test suites. -markupPackage :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^ \"dist/\" prefix - -> PD.PackageDescription - -> [TestSuite] - -> IO () +markupPackage + :: Verbosity + -> LocalBuildInfo + -> FilePath + -- ^ \"dist/\" prefix + -> PD.PackageDescription + -> [TestSuite] + -> IO () markupPackage verbosity lbi distPref pkg_descr suites = do - let tixFiles = map (tixFilePath distPref way) testNames - tixFilesExist <- traverse doesFileExist tixFiles - when (and tixFilesExist) $ do - -- behaviour of 'markup' depends on version, so we need *a* version - -- but no particular one - (hpc, hpcVer, _) <- requireProgramVersion verbosity - hpcProgram anyVersion (withPrograms lbi) - let outFile = tixFilePath distPref way libraryName - htmlDir' = htmlDir distPref way libraryName - excluded = concatMap testModules suites ++ [ main ] - createDirectoryIfMissing True $ takeDirectory outFile - union hpc verbosity tixFiles outFile excluded - markup hpc hpcVer verbosity outFile mixDirs htmlDir' included - notice verbosity $ "Package coverage report written to " - ++ htmlDir' "hpc_index.html" + let tixFiles = map (tixFilePath distPref way) testNames + tixFilesExist <- traverse doesFileExist tixFiles + when (and tixFilesExist) $ do + -- behaviour of 'markup' depends on version, so we need *a* version + -- but no particular one + (hpc, hpcVer, _) <- + requireProgramVersion + verbosity + hpcProgram + anyVersion + (withPrograms lbi) + let outFile = tixFilePath distPref way libraryName + htmlDir' = htmlDir distPref way libraryName + excluded = concatMap testModules suites ++ [main] + createDirectoryIfMissing True $ takeDirectory outFile + union hpc verbosity tixFiles outFile excluded + markup hpc hpcVer verbosity outFile mixDirs htmlDir' included + notice verbosity $ + "Package coverage report written to " + ++ htmlDir' + "hpc_index.html" where way = guessWay lbi testNames = fmap (unUnqualComponentName . testName) suites diff --git a/Cabal/src/Distribution/Simple/Install.hs b/Cabal/src/Distribution/Simple/Install.hs index 432a94c7f22..f5034cf88b9 100644 --- a/Cabal/src/Distribution/Simple/Install.hs +++ b/Cabal/src/Distribution/Simple/Install.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Install -- Copyright : Isaac Jones 2003-2004 @@ -14,66 +15,86 @@ -- \"@.\/setup install@\" and \"@.\/setup copy@\" actions. It moves files into -- place based on the prefix argument. It does the generic bits and then calls -- compiler-specific functions to do the rest. - -module Distribution.Simple.Install ( - install, +module Distribution.Simple.Install + ( install ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.TargetInfo -import Distribution.Types.LocalBuildInfo +import Distribution.Types.ExecutableScope import Distribution.Types.ForeignLib +import Distribution.Types.LocalBuildInfo import Distribution.Types.PackageDescription +import Distribution.Types.TargetInfo import Distribution.Types.UnqualComponentName -import Distribution.Types.ExecutableScope import Distribution.Package import Distribution.PackageDescription -import Distribution.Simple.LocalBuildInfo import Distribution.Simple.BuildPaths (haddockName, haddockPref) -import Distribution.Simple.Glob (matchDirFileGlob) -import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose - , installDirectoryContents, installOrdinaryFile, isInSearchPath - , die', info, noticeNoWrap, warn ) +import Distribution.Simple.BuildTarget import Distribution.Simple.Compiler - ( CompilerFlavor(..), compilerFlavor ) + ( CompilerFlavor (..) + , compilerFlavor + ) import Distribution.Simple.Flag - ( fromFlag ) + ( fromFlag + ) +import Distribution.Simple.Glob (matchDirFileGlob) +import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Setup.Copy - ( CopyFlags(..) ) + ( CopyFlags (..) + ) import Distribution.Simple.Setup.Haddock - ( HaddockTarget(ForDevelopment) ) -import Distribution.Simple.BuildTarget + ( HaddockTarget (ForDevelopment) + ) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose + , die' + , info + , installDirectoryContents + , installOrdinaryFile + , isInSearchPath + , noticeNoWrap + , warn + ) import Distribution.Utils.Path (getSymbolicPath) -import qualified Distribution.Simple.GHC as GHC +import Distribution.Compat.Graph (IsNode (..)) +import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.UHC as UHC import qualified Distribution.Simple.HaskellSuite as HaskellSuite -import Distribution.Compat.Graph (IsNode(..)) +import qualified Distribution.Simple.UHC as UHC import System.Directory - ( doesDirectoryExist, doesFileExist ) + ( doesDirectoryExist + , doesFileExist + ) import System.FilePath - ( takeFileName, takeDirectory, (), isRelative ) + ( isRelative + , takeDirectory + , takeFileName + , () + ) -import Distribution.Verbosity import Distribution.Pretty - ( prettyShow ) + ( prettyShow + ) +import Distribution.Verbosity --- |Perform the \"@.\/setup install@\" and \"@.\/setup copy@\" --- actions. Move files into place based on the prefix argument. +-- | Perform the \"@.\/setup install@\" and \"@.\/setup copy@\" +-- actions. Move files into place based on the prefix argument. -- --- This does NOT register libraries, you should call 'register' --- to do that. - -install :: PackageDescription -- ^information from the .cabal file - -> LocalBuildInfo -- ^information from the configure step - -> CopyFlags -- ^flags sent to copy or install - -> IO () +-- This does NOT register libraries, you should call 'register' +-- to do that. +install + :: PackageDescription + -- ^ information from the .cabal file + -> LocalBuildInfo + -- ^ information from the configure step + -> CopyFlags + -- ^ flags sent to copy or install + -> IO () install pkg_descr lbi flags = do checkHasLibsOrExes targets <- readTargetInfos verbosity pkg_descr lbi (copyArgs flags) @@ -84,27 +105,33 @@ install pkg_descr lbi flags = do withNeededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) $ \target -> let comp = targetComponent target clbi = targetCLBI target - in copyComponent verbosity pkg_descr lbi comp clbi copydest - where - distPref = fromFlag (copyDistPref flags) - verbosity = fromFlag (copyVerbosity flags) - copydest = fromFlag (copyDest flags) + in copyComponent verbosity pkg_descr lbi comp clbi copydest + where + distPref = fromFlag (copyDistPref flags) + verbosity = fromFlag (copyVerbosity flags) + copydest = fromFlag (copyDest flags) - checkHasLibsOrExes = - unless (hasLibs pkg_descr || hasForeignLibs pkg_descr || hasExes pkg_descr) $ - die' verbosity "No executables and no library found. Nothing to do." + checkHasLibsOrExes = + unless (hasLibs pkg_descr || hasForeignLibs pkg_descr || hasExes pkg_descr) $ + die' verbosity "No executables and no library found. Nothing to do." -- | Copy package global files. -copyPackage :: Verbosity -> PackageDescription - -> LocalBuildInfo -> FilePath -> CopyDest -> IO () +copyPackage + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> FilePath + -> CopyDest + -> IO () copyPackage verbosity pkg_descr lbi distPref copydest = do - let -- This is a bit of a hack, to handle files which are not - -- per-component (data files and Haddock files.) - InstallDirs { - datadir = dataPref, - docdir = docPref, - htmldir = htmlPref, - haddockdir = interfacePref + let + -- This is a bit of a hack, to handle files which are not + -- per-component (data files and Haddock files.) + InstallDirs + { datadir = dataPref + , docdir = docPref + , htmldir = htmlPref + , haddockdir = interfacePref } = absoluteInstallCommandDirs pkg_descr lbi (localUnitId lbi) copydest -- Install (package-global) data files @@ -113,30 +140,40 @@ copyPackage verbosity pkg_descr lbi distPref copydest = do -- Install (package-global) Haddock files -- TODO: these should be done per-library docExists <- doesDirectoryExist $ haddockPref ForDevelopment distPref pkg_descr - info verbosity ("directory " ++ haddockPref ForDevelopment distPref pkg_descr ++ - " does exist: " ++ show docExists) + info + verbosity + ( "directory " + ++ haddockPref ForDevelopment distPref pkg_descr + ++ " does exist: " + ++ show docExists + ) -- TODO: this is a bit questionable, Haddock files really should -- be per library (when there are convenience libraries.) when docExists $ do - createDirectoryIfMissingVerbose verbosity True htmlPref - installDirectoryContents verbosity - (haddockPref ForDevelopment distPref pkg_descr) htmlPref - -- setPermissionsRecursive [Read] htmlPref - -- The haddock interface file actually already got installed - -- in the recursive copy, but now we install it where we actually - -- want it to be (normally the same place). We could remove the - -- copy in htmlPref first. - let haddockInterfaceFileSrc = haddockPref ForDevelopment distPref pkg_descr - haddockName pkg_descr - haddockInterfaceFileDest = interfacePref haddockName pkg_descr - -- We only generate the haddock interface file for libs, So if the - -- package consists only of executables there will not be one: - exists <- doesFileExist haddockInterfaceFileSrc - when exists $ do - createDirectoryIfMissingVerbose verbosity True interfacePref - installOrdinaryFile verbosity haddockInterfaceFileSrc - haddockInterfaceFileDest + createDirectoryIfMissingVerbose verbosity True htmlPref + installDirectoryContents + verbosity + (haddockPref ForDevelopment distPref pkg_descr) + htmlPref + -- setPermissionsRecursive [Read] htmlPref + -- The haddock interface file actually already got installed + -- in the recursive copy, but now we install it where we actually + -- want it to be (normally the same place). We could remove the + -- copy in htmlPref first. + let haddockInterfaceFileSrc = + haddockPref ForDevelopment distPref pkg_descr + haddockName pkg_descr + haddockInterfaceFileDest = interfacePref haddockName pkg_descr + -- We only generate the haddock interface file for libs, So if the + -- package consists only of executables there will not be one: + exists <- doesFileExist haddockInterfaceFileSrc + when exists $ do + createDirectoryIfMissingVerbose verbosity True interfacePref + installOrdinaryFile + verbosity + haddockInterfaceFileSrc + haddockInterfaceFileDest let lfiles = licenseFiles pkg_descr unless (null lfiles) $ do @@ -147,118 +184,146 @@ copyPackage verbosity pkg_descr lbi distPref copydest = do installOrdinaryFile verbosity lfile (docPref takeFileName lfile) -- | Copy files associated with a component. -copyComponent :: Verbosity -> PackageDescription - -> LocalBuildInfo -> Component -> ComponentLocalBuildInfo - -> CopyDest - -> IO () +copyComponent + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> Component + -> ComponentLocalBuildInfo + -> CopyDest + -> IO () copyComponent verbosity pkg_descr lbi (CLib lib) clbi copydest = do - let InstallDirs{ - libdir = libPref, - dynlibdir = dynlibPref, - includedir = incPref - } = absoluteInstallCommandDirs pkg_descr lbi (componentUnitId clbi) copydest - buildPref = componentBuildDir lbi clbi - - case libName lib of - LMainLibName -> noticeNoWrap verbosity ("Installing library in " ++ libPref) - LSubLibName n -> noticeNoWrap verbosity ("Installing internal library " ++ prettyShow n ++ " in " ++ libPref) + let InstallDirs + { libdir = libPref + , dynlibdir = dynlibPref + , includedir = incPref + } = absoluteInstallCommandDirs pkg_descr lbi (componentUnitId clbi) copydest + buildPref = componentBuildDir lbi clbi - -- install include files for all compilers - they may be needed to compile - -- haskell files (using the CPP extension) - installIncludeFiles verbosity (libBuildInfo lib) lbi buildPref incPref + case libName lib of + LMainLibName -> noticeNoWrap verbosity ("Installing library in " ++ libPref) + LSubLibName n -> noticeNoWrap verbosity ("Installing internal library " ++ prettyShow n ++ " in " ++ libPref) - case compilerFlavor (compiler lbi) of - GHC -> GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi - GHCJS -> GHCJS.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi - UHC -> UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi - HaskellSuite _ -> HaskellSuite.installLib - verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi - _ -> die' verbosity $ "installing with " - ++ prettyShow (compilerFlavor (compiler lbi)) - ++ " is not implemented" + -- install include files for all compilers - they may be needed to compile + -- haskell files (using the CPP extension) + installIncludeFiles verbosity (libBuildInfo lib) lbi buildPref incPref + case compilerFlavor (compiler lbi) of + GHC -> GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi + GHCJS -> GHCJS.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi + UHC -> UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi + HaskellSuite _ -> + HaskellSuite.installLib + verbosity + lbi + libPref + dynlibPref + buildPref + pkg_descr + lib + clbi + _ -> + die' verbosity $ + "installing with " + ++ prettyShow (compilerFlavor (compiler lbi)) + ++ " is not implemented" copyComponent verbosity pkg_descr lbi (CFLib flib) clbi copydest = do - let InstallDirs{ - flibdir = flibPref, - includedir = incPref - } = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest - buildPref = componentBuildDir lbi clbi + let InstallDirs + { flibdir = flibPref + , includedir = incPref + } = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest + buildPref = componentBuildDir lbi clbi - noticeNoWrap verbosity ("Installing foreign library " ++ unUnqualComponentName (foreignLibName flib) ++ " in " ++ flibPref) - installIncludeFiles verbosity (foreignLibBuildInfo flib) lbi buildPref incPref - - case compilerFlavor (compiler lbi) of - GHC -> GHC.installFLib verbosity lbi flibPref buildPref pkg_descr flib - GHCJS -> GHCJS.installFLib verbosity lbi flibPref buildPref pkg_descr flib - _ -> die' verbosity $ "installing foreign lib with " - ++ prettyShow (compilerFlavor (compiler lbi)) - ++ " is not implemented" + noticeNoWrap verbosity ("Installing foreign library " ++ unUnqualComponentName (foreignLibName flib) ++ " in " ++ flibPref) + installIncludeFiles verbosity (foreignLibBuildInfo flib) lbi buildPref incPref + case compilerFlavor (compiler lbi) of + GHC -> GHC.installFLib verbosity lbi flibPref buildPref pkg_descr flib + GHCJS -> GHCJS.installFLib verbosity lbi flibPref buildPref pkg_descr flib + _ -> + die' verbosity $ + "installing foreign lib with " + ++ prettyShow (compilerFlavor (compiler lbi)) + ++ " is not implemented" copyComponent verbosity pkg_descr lbi (CExe exe) clbi copydest = do - let installDirs = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest - -- the installers know how to find the actual location of the - -- binaries - buildPref = buildDir lbi - uid = componentUnitId clbi - pkgid = packageId pkg_descr - binPref | ExecutablePrivate <- exeScope exe = libexecdir installDirs - | otherwise = bindir installDirs - progPrefixPref = substPathTemplate pkgid lbi uid (progPrefix lbi) - progSuffixPref = substPathTemplate pkgid lbi uid (progSuffix lbi) - progFix = (progPrefixPref, progSuffixPref) - noticeNoWrap verbosity ("Installing executable " ++ prettyShow (exeName exe) - ++ " in " ++ binPref) - inPath <- isInSearchPath binPref - when (not inPath) $ - warn verbosity ("The directory " ++ binPref - ++ " is not in the system search path.") - case compilerFlavor (compiler lbi) of - GHC -> GHC.installExe verbosity lbi binPref buildPref progFix pkg_descr exe - GHCJS -> GHCJS.installExe verbosity lbi binPref buildPref progFix pkg_descr exe - UHC -> return () - HaskellSuite {} -> return () - _ -> die' verbosity $ "installing with " - ++ prettyShow (compilerFlavor (compiler lbi)) - ++ " is not implemented" + let installDirs = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest + -- the installers know how to find the actual location of the + -- binaries + buildPref = buildDir lbi + uid = componentUnitId clbi + pkgid = packageId pkg_descr + binPref + | ExecutablePrivate <- exeScope exe = libexecdir installDirs + | otherwise = bindir installDirs + progPrefixPref = substPathTemplate pkgid lbi uid (progPrefix lbi) + progSuffixPref = substPathTemplate pkgid lbi uid (progSuffix lbi) + progFix = (progPrefixPref, progSuffixPref) + noticeNoWrap + verbosity + ( "Installing executable " + ++ prettyShow (exeName exe) + ++ " in " + ++ binPref + ) + inPath <- isInSearchPath binPref + when (not inPath) $ + warn + verbosity + ( "The directory " + ++ binPref + ++ " is not in the system search path." + ) + case compilerFlavor (compiler lbi) of + GHC -> GHC.installExe verbosity lbi binPref buildPref progFix pkg_descr exe + GHCJS -> GHCJS.installExe verbosity lbi binPref buildPref progFix pkg_descr exe + UHC -> return () + HaskellSuite{} -> return () + _ -> + die' verbosity $ + "installing with " + ++ prettyShow (compilerFlavor (compiler lbi)) + ++ " is not implemented" -- Nothing to do for benchmark/testsuite copyComponent _ _ _ (CBench _) _ _ = return () copyComponent _ _ _ (CTest _) _ _ = return () -- | Install the files listed in data-files --- installDataFiles :: Verbosity -> PackageDescription -> FilePath -> IO () installDataFiles verbosity pkg_descr destDataDir = - flip traverse_ (dataFiles pkg_descr) $ \ glob -> do + flip traverse_ (dataFiles pkg_descr) $ \glob -> do let srcDataDirRaw = dataDir pkg_descr - srcDataDir = if null srcDataDirRaw - then "." - else srcDataDirRaw + srcDataDir = + if null srcDataDirRaw + then "." + else srcDataDirRaw files <- matchDirFileGlob verbosity (specVersion pkg_descr) srcDataDir glob - for_ files $ \ file' -> do + for_ files $ \file' -> do let src = srcDataDir file' dst = destDataDir file' createDirectoryIfMissingVerbose verbosity True (takeDirectory dst) installOrdinaryFile verbosity src dst -- | Install the files listed in install-includes for a library --- installIncludeFiles :: Verbosity -> BuildInfo -> LocalBuildInfo -> FilePath -> FilePath -> IO () installIncludeFiles verbosity libBi lbi buildPref destIncludeDir = do - let relincdirs = "." : filter isRelative (includeDirs libBi) - incdirs = [ baseDir lbi dir | dir <- relincdirs ] - ++ [ buildPref dir | dir <- relincdirs ] - incs <- traverse (findInc incdirs) (installIncludes libBi) - sequence_ - [ do createDirectoryIfMissingVerbose verbosity True destDir - installOrdinaryFile verbosity srcFile destFile - | (relFile, srcFile) <- incs - , let destFile = destIncludeDir relFile - destDir = takeDirectory destFile ] + let relincdirs = "." : filter isRelative (includeDirs libBi) + incdirs = + [baseDir lbi dir | dir <- relincdirs] + ++ [buildPref dir | dir <- relincdirs] + incs <- traverse (findInc incdirs) (installIncludes libBi) + sequence_ + [ do + createDirectoryIfMissingVerbose verbosity True destDir + installOrdinaryFile verbosity srcFile destFile + | (relFile, srcFile) <- incs + , let destFile = destIncludeDir relFile + destDir = takeDirectory destFile + ] where - baseDir lbi' = fromMaybe "" (takeDirectory <$> cabalFilePath lbi') - findInc [] file = die' verbosity ("can't find include file " ++ file) - findInc (dir:dirs) file = do - let path = dir file - exists <- doesFileExist path - if exists then return (file, path) else findInc dirs file + baseDir lbi' = fromMaybe "" (takeDirectory <$> cabalFilePath lbi') + findInc [] file = die' verbosity ("can't find include file " ++ file) + findInc (dir : dirs) file = do + let path = dir file + exists <- doesFileExist path + if exists then return (file, path) else findInc dirs file diff --git a/Cabal/src/Distribution/Simple/InstallDirs.hs b/Cabal/src/Distribution/Simple/InstallDirs.hs index 739b87d58c9..c77ee8a99b2 100644 --- a/Cabal/src/Distribution/Simple/InstallDirs.hs +++ b/Cabal/src/Distribution/Simple/InstallDirs.hs @@ -6,6 +6,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.InstallDirs -- Copyright : Isaac Jones 2003-2004 @@ -22,48 +23,49 @@ -- changing the prefix all other dirs still end up changed appropriately. So it -- provides a 'PathTemplate' type and functions for substituting for these -- templates. - -module Distribution.Simple.InstallDirs ( - InstallDirs(..), - InstallDirTemplates, - defaultInstallDirs, - defaultInstallDirs', - combineInstallDirs, - absoluteInstallDirs, - CopyDest(..), - prefixRelativeInstallDirs, - substituteInstallDirTemplates, - - PathTemplate, - PathTemplateVariable(..), - PathTemplateEnv, - toPathTemplate, - fromPathTemplate, - combinePathTemplate, - substPathTemplate, - initialPathTemplateEnv, - platformTemplateEnv, - compilerTemplateEnv, - packageTemplateEnv, - abiTemplateEnv, - installDirsTemplateEnv, +module Distribution.Simple.InstallDirs + ( InstallDirs (..) + , InstallDirTemplates + , defaultInstallDirs + , defaultInstallDirs' + , combineInstallDirs + , absoluteInstallDirs + , CopyDest (..) + , prefixRelativeInstallDirs + , substituteInstallDirTemplates + , PathTemplate + , PathTemplateVariable (..) + , PathTemplateEnv + , toPathTemplate + , fromPathTemplate + , combinePathTemplate + , substPathTemplate + , initialPathTemplateEnv + , platformTemplateEnv + , compilerTemplateEnv + , packageTemplateEnv + , abiTemplateEnv + , installDirsTemplateEnv ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Compat.Environment (lookupEnv) -import Distribution.Pretty -import Distribution.Package -import Distribution.System import Distribution.Compiler +import Distribution.Package +import Distribution.Pretty import Distribution.Simple.InstallDirs.Internal +import Distribution.System import System.Directory (getAppUserDataDirectory) import System.FilePath - ( (), isPathSeparator - , pathSeparator, dropDrive - , takeDirectory ) + ( dropDrive + , isPathSeparator + , pathSeparator + , takeDirectory + , () + ) #ifdef mingw32_HOST_OS import qualified Prelude @@ -74,32 +76,32 @@ import Foreign.C -- --------------------------------------------------------------------------- -- Installation directories - -- | The directories where we will install files for packages. -- -- We have several different directories for different types of files since -- many systems have conventions whereby different types of files in a package -- are installed in different directories. This is particularly the case on -- Unix style systems. --- -data InstallDirs dir = InstallDirs { - prefix :: dir, - bindir :: dir, - libdir :: dir, - libsubdir :: dir, - dynlibdir :: dir, - flibdir :: dir, -- ^ foreign libraries - libexecdir :: dir, - libexecsubdir:: dir, - includedir :: dir, - datadir :: dir, - datasubdir :: dir, - docdir :: dir, - mandir :: dir, - htmldir :: dir, - haddockdir :: dir, - sysconfdir :: dir - } deriving (Eq, Read, Show, Functor, Generic, Typeable) +data InstallDirs dir = InstallDirs + { prefix :: dir + , bindir :: dir + , libdir :: dir + , libsubdir :: dir + , dynlibdir :: dir + , flibdir :: dir + -- ^ foreign libraries + , libexecdir :: dir + , libexecsubdir :: dir + , includedir :: dir + , datadir :: dir + , datasubdir :: dir + , docdir :: dir + , mandir :: dir + , htmldir :: dir + , haddockdir :: dir + , sysconfdir :: dir + } + deriving (Eq, Read, Show, Functor, Generic, Typeable) instance Binary dir => Binary (InstallDirs dir) instance Structured dir => Structured (InstallDirs dir) @@ -111,38 +113,41 @@ instance (Semigroup dir, Monoid dir) => Monoid (InstallDirs dir) where instance Semigroup dir => Semigroup (InstallDirs dir) where (<>) = gmappend -combineInstallDirs :: (a -> b -> c) - -> InstallDirs a - -> InstallDirs b - -> InstallDirs c -combineInstallDirs combine a b = InstallDirs { - prefix = prefix a `combine` prefix b, - bindir = bindir a `combine` bindir b, - libdir = libdir a `combine` libdir b, - libsubdir = libsubdir a `combine` libsubdir b, - dynlibdir = dynlibdir a `combine` dynlibdir b, - flibdir = flibdir a `combine` flibdir b, - libexecdir = libexecdir a `combine` libexecdir b, - libexecsubdir= libexecsubdir a `combine` libexecsubdir b, - includedir = includedir a `combine` includedir b, - datadir = datadir a `combine` datadir b, - datasubdir = datasubdir a `combine` datasubdir b, - docdir = docdir a `combine` docdir b, - mandir = mandir a `combine` mandir b, - htmldir = htmldir a `combine` htmldir b, - haddockdir = haddockdir a `combine` haddockdir b, - sysconfdir = sysconfdir a `combine` sysconfdir b - } +combineInstallDirs + :: (a -> b -> c) + -> InstallDirs a + -> InstallDirs b + -> InstallDirs c +combineInstallDirs combine a b = + InstallDirs + { prefix = prefix a `combine` prefix b + , bindir = bindir a `combine` bindir b + , libdir = libdir a `combine` libdir b + , libsubdir = libsubdir a `combine` libsubdir b + , dynlibdir = dynlibdir a `combine` dynlibdir b + , flibdir = flibdir a `combine` flibdir b + , libexecdir = libexecdir a `combine` libexecdir b + , libexecsubdir = libexecsubdir a `combine` libexecsubdir b + , includedir = includedir a `combine` includedir b + , datadir = datadir a `combine` datadir b + , datasubdir = datasubdir a `combine` datasubdir b + , docdir = docdir a `combine` docdir b + , mandir = mandir a `combine` mandir b + , htmldir = htmldir a `combine` htmldir b + , haddockdir = haddockdir a `combine` haddockdir b + , sysconfdir = sysconfdir a `combine` sysconfdir b + } appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a -appendSubdirs append dirs = dirs { - libdir = libdir dirs `append` libsubdir dirs, - libexecdir = libexecdir dirs `append` libexecsubdir dirs, - datadir = datadir dirs `append` datasubdir dirs, - libsubdir = error "internal error InstallDirs.libsubdir", - libexecsubdir = error "internal error InstallDirs.libexecsubdir", - datasubdir = error "internal error InstallDirs.datasubdir" - } +appendSubdirs append dirs = + dirs + { libdir = libdir dirs `append` libsubdir dirs + , libexecdir = libexecdir dirs `append` libexecsubdir dirs + , datadir = datadir dirs `append` datasubdir dirs + , libsubdir = error "internal error InstallDirs.libsubdir" + , libexecsubdir = error "internal error InstallDirs.libexecsubdir" + , datasubdir = error "internal error InstallDirs.datasubdir" + } -- | The installation directories in terms of 'PathTemplate's that contain -- variables. @@ -165,7 +170,6 @@ appendSubdirs append dirs = dirs { -- -- An additional complication is the need to support relocatable packages on -- systems which support such things, like Windows. --- type InstallDirTemplates = InstallDirs PathTemplate -- --------------------------------------------------------------------------- @@ -174,56 +178,66 @@ type InstallDirTemplates = InstallDirs PathTemplate defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates defaultInstallDirs = defaultInstallDirs' False -defaultInstallDirs' :: Bool {- use external internal deps -} - -> CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates +defaultInstallDirs' + :: Bool {- use external internal deps -} + -> CompilerFlavor + -> Bool + -> Bool + -> IO InstallDirTemplates defaultInstallDirs' True comp userInstall hasLibs = do dflt <- defaultInstallDirs' False comp userInstall hasLibs -- Be a bit more hermetic about per-component installs - return dflt { datasubdir = toPathTemplate $ "$abi" "$libname", - docdir = toPathTemplate $ "$datadir" "doc" "$abi" "$libname" - } + return + dflt + { datasubdir = toPathTemplate $ "$abi" "$libname" + , docdir = toPathTemplate $ "$datadir" "doc" "$abi" "$libname" + } defaultInstallDirs' False comp userInstall _hasLibs = do installPrefix <- - if userInstall + if userInstall then do mDir <- lookupEnv "CABAL_DIR" case mDir of Nothing -> getAppUserDataDirectory "cabal" Just dir -> return dir else case buildOS of - Windows -> do windowsProgramFilesDir <- getWindowsProgramFilesDir - return (windowsProgramFilesDir "Haskell") - _ -> return "/usr/local" + Windows -> do + windowsProgramFilesDir <- getWindowsProgramFilesDir + return (windowsProgramFilesDir "Haskell") + _ -> return "/usr/local" installLibDir <- - case buildOS of + case buildOS of Windows -> return "$prefix" - _ -> return ("$prefix" "lib") - return $ fmap toPathTemplate $ InstallDirs { - prefix = installPrefix, - bindir = "$prefix" "bin", - libdir = installLibDir, - libsubdir = case comp of - UHC -> "$pkgid" - _other -> "$abi" "$libname", - dynlibdir = "$libdir" case comp of - UHC -> "$pkgid" - _other -> "$abi", - libexecsubdir= "$abi" "$pkgid", - flibdir = "$libdir", - libexecdir = case buildOS of - Windows -> "$prefix" "$libname" - _other -> "$prefix" "libexec", - includedir = "$libdir" "$libsubdir" "include", - datadir = case buildOS of - Windows -> "$prefix" - _other -> "$prefix" "share", - datasubdir = "$abi" "$pkgid", - docdir = "$datadir" "doc" "$abi" "$pkgid", - mandir = "$datadir" "man", - htmldir = "$docdir" "html", - haddockdir = "$htmldir", - sysconfdir = "$prefix" "etc" - } + _ -> return ("$prefix" "lib") + return $ + fmap toPathTemplate $ + InstallDirs + { prefix = installPrefix + , bindir = "$prefix" "bin" + , libdir = installLibDir + , libsubdir = case comp of + UHC -> "$pkgid" + _other -> "$abi" "$libname" + , dynlibdir = + "$libdir" case comp of + UHC -> "$pkgid" + _other -> "$abi" + , libexecsubdir = "$abi" "$pkgid" + , flibdir = "$libdir" + , libexecdir = case buildOS of + Windows -> "$prefix" "$libname" + _other -> "$prefix" "libexec" + , includedir = "$libdir" "$libsubdir" "include" + , datadir = case buildOS of + Windows -> "$prefix" + _other -> "$prefix" "share" + , datasubdir = "$abi" "$pkgid" + , docdir = "$datadir" "doc" "$abi" "$pkgid" + , mandir = "$datadir" "man" + , htmldir = "$docdir" "html" + , haddockdir = "$htmldir" + , sysconfdir = "$prefix" "etc" + } -- --------------------------------------------------------------------------- -- Converting directories, absolute or prefix-relative @@ -239,77 +253,84 @@ defaultInstallDirs' False comp userInstall _hasLibs = do -- can replace 'prefix' with the 'PrefixVar' and get resulting -- 'PathTemplate's that still have the 'PrefixVar' in them. Doing this makes it -- each to check which paths are relative to the $prefix. --- -substituteInstallDirTemplates :: PathTemplateEnv - -> InstallDirTemplates -> InstallDirTemplates +substituteInstallDirTemplates + :: PathTemplateEnv + -> InstallDirTemplates + -> InstallDirTemplates substituteInstallDirTemplates env dirs = dirs' where - dirs' = InstallDirs { - -- So this specifies exactly which vars are allowed in each template - prefix = subst prefix [], - bindir = subst bindir [prefixVar], - libdir = subst libdir [prefixVar, bindirVar], - libsubdir = subst libsubdir [], - dynlibdir = subst dynlibdir [prefixVar, bindirVar, libdirVar], - flibdir = subst flibdir [prefixVar, bindirVar, libdirVar], - libexecdir = subst libexecdir prefixBinLibVars, - libexecsubdir = subst libexecsubdir [], - includedir = subst includedir prefixBinLibVars, - datadir = subst datadir prefixBinLibVars, - datasubdir = subst datasubdir [], - docdir = subst docdir prefixBinLibDataVars, - mandir = subst mandir (prefixBinLibDataVars ++ [docdirVar]), - htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar]), - haddockdir = subst haddockdir (prefixBinLibDataVars ++ - [docdirVar, htmldirVar]), - sysconfdir = subst sysconfdir prefixBinLibVars - } - subst dir env' = substPathTemplate (env'++env) (dir dirs) - - prefixVar = (PrefixVar, prefix dirs') - bindirVar = (BindirVar, bindir dirs') - libdirVar = (LibdirVar, libdir dirs') - libsubdirVar = (LibsubdirVar, libsubdir dirs') - datadirVar = (DatadirVar, datadir dirs') - datasubdirVar = (DatasubdirVar, datasubdir dirs') - docdirVar = (DocdirVar, docdir dirs') - htmldirVar = (HtmldirVar, htmldir dirs') + dirs' = + InstallDirs + { -- So this specifies exactly which vars are allowed in each template + prefix = subst prefix [] + , bindir = subst bindir [prefixVar] + , libdir = subst libdir [prefixVar, bindirVar] + , libsubdir = subst libsubdir [] + , dynlibdir = subst dynlibdir [prefixVar, bindirVar, libdirVar] + , flibdir = subst flibdir [prefixVar, bindirVar, libdirVar] + , libexecdir = subst libexecdir prefixBinLibVars + , libexecsubdir = subst libexecsubdir [] + , includedir = subst includedir prefixBinLibVars + , datadir = subst datadir prefixBinLibVars + , datasubdir = subst datasubdir [] + , docdir = subst docdir prefixBinLibDataVars + , mandir = subst mandir (prefixBinLibDataVars ++ [docdirVar]) + , htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar]) + , haddockdir = + subst + haddockdir + ( prefixBinLibDataVars + ++ [docdirVar, htmldirVar] + ) + , sysconfdir = subst sysconfdir prefixBinLibVars + } + subst dir env' = substPathTemplate (env' ++ env) (dir dirs) + + prefixVar = (PrefixVar, prefix dirs') + bindirVar = (BindirVar, bindir dirs') + libdirVar = (LibdirVar, libdir dirs') + libsubdirVar = (LibsubdirVar, libsubdir dirs') + datadirVar = (DatadirVar, datadir dirs') + datasubdirVar = (DatasubdirVar, datasubdir dirs') + docdirVar = (DocdirVar, docdir dirs') + htmldirVar = (HtmldirVar, htmldir dirs') prefixBinLibVars = [prefixVar, bindirVar, libdirVar, libsubdirVar] prefixBinLibDataVars = prefixBinLibVars ++ [datadirVar, datasubdirVar] -- | Convert from abstract install directories to actual absolute ones by -- substituting for all the variables in the abstract paths, to get real -- absolute path. -absoluteInstallDirs :: PackageIdentifier - -> UnitId - -> CompilerInfo - -> CopyDest - -> Platform - -> InstallDirs PathTemplate - -> InstallDirs FilePath +absoluteInstallDirs + :: PackageIdentifier + -> UnitId + -> CompilerInfo + -> CopyDest + -> Platform + -> InstallDirs PathTemplate + -> InstallDirs FilePath absoluteInstallDirs pkgId libname compilerId copydest platform dirs = - (case copydest of - CopyTo destdir -> fmap ((destdir ) . dropDrive) - CopyToDb dbdir -> fmap (substPrefix "${pkgroot}" (takeDirectory dbdir)) - _ -> id) - . appendSubdirs () - . fmap fromPathTemplate - $ substituteInstallDirTemplates env dirs + ( case copydest of + CopyTo destdir -> fmap ((destdir ) . dropDrive) + CopyToDb dbdir -> fmap (substPrefix "${pkgroot}" (takeDirectory dbdir)) + _ -> id + ) + . appendSubdirs () + . fmap fromPathTemplate + $ substituteInstallDirTemplates env dirs where env = initialPathTemplateEnv pkgId libname compilerId platform substPrefix pre root path | pre `isPrefixOf` path = root ++ drop (length pre) path - | otherwise = path + | otherwise = path - --- |The location prefix for the /copy/ command. +-- | The location prefix for the /copy/ command. data CopyDest = NoCopyDest | CopyTo FilePath - | CopyToDb FilePath - -- ^ when using the ${pkgroot} as prefix. The CopyToDb will - -- adjust the paths to be relative to the provided package - -- database when copying / installing. + | -- | when using the ${pkgroot} as prefix. The CopyToDb will + -- adjust the paths to be relative to the provided package + -- database when copying / installing. + CopyToDb FilePath deriving (Eq, Show, Generic) instance Binary CopyDest @@ -319,22 +340,23 @@ instance Binary CopyDest -- If any of the paths are not relative, ie they are absolute paths, then it -- prevents us from making a relocatable package (also known as a \"prefix -- independent\" package). --- -prefixRelativeInstallDirs :: PackageIdentifier - -> UnitId - -> CompilerInfo - -> Platform - -> InstallDirTemplates - -> InstallDirs (Maybe FilePath) +prefixRelativeInstallDirs + :: PackageIdentifier + -> UnitId + -> CompilerInfo + -> Platform + -> InstallDirTemplates + -> InstallDirs (Maybe FilePath) prefixRelativeInstallDirs pkgId libname compilerId platform dirs = - fmap relative - . appendSubdirs combinePathTemplate - $ -- substitute the path template into each other, except that we map + fmap relative + . appendSubdirs combinePathTemplate + $ substituteInstallDirTemplates -- substitute the path template into each other, except that we map -- \$prefix back to $prefix. We're trying to end up with templates that -- mention no vars except $prefix. - substituteInstallDirTemplates env dirs { - prefix = PathTemplate [Variable PrefixVar] - } + env + dirs + { prefix = PathTemplate [Variable PrefixVar] + } where env = initialPathTemplateEnv pkgId libname compilerId platform @@ -342,17 +364,16 @@ prefixRelativeInstallDirs pkgId libname compilerId platform dirs = -- path by stripping off $prefix/ or $prefix relative dir = case dir of PathTemplate cs -> fmap (fromPathTemplate . PathTemplate) (relative' cs) - relative' (Variable PrefixVar : Ordinary (s:rest) : rest') - | isPathSeparator s = Just (Ordinary rest : rest') + relative' (Variable PrefixVar : Ordinary (s : rest) : rest') + | isPathSeparator s = Just (Ordinary rest : rest') relative' (Variable PrefixVar : rest) = Just rest - relative' _ = Nothing + relative' _ = Nothing -- --------------------------------------------------------------------------- -- Path templates -- | An abstract path, possibly containing variables that need to be -- substituted for to get a real 'FilePath'. --- newtype PathTemplate = PathTemplate [PathComponent] deriving (Eq, Ord, Generic, Typeable) @@ -362,15 +383,14 @@ instance Structured PathTemplate type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)] -- | Convert a 'FilePath' to a 'PathTemplate' including any template vars. --- toPathTemplate :: FilePath -> PathTemplate -toPathTemplate fp = PathTemplate +toPathTemplate fp = + PathTemplate . fromMaybe (error $ "panic! toPathTemplate " ++ show fp) . readMaybe -- TODO: eradicateNoParse $ fp -- | Convert back to a path, any remaining vars are included --- fromPathTemplate :: PathTemplate -> FilePath fromPathTemplate (PathTemplate template) = show template @@ -380,71 +400,80 @@ combinePathTemplate (PathTemplate t1) (PathTemplate t2) = substPathTemplate :: PathTemplateEnv -> PathTemplate -> PathTemplate substPathTemplate environment (PathTemplate template) = - PathTemplate (concatMap subst template) - - where subst component@(Ordinary _) = [component] - subst component@(Variable variable) = - case lookup variable environment of - Just (PathTemplate components) -> components - Nothing -> [component] + PathTemplate (concatMap subst template) + where + subst component@(Ordinary _) = [component] + subst component@(Variable variable) = + case lookup variable environment of + Just (PathTemplate components) -> components + Nothing -> [component] -- | The initial environment has all the static stuff but no paths -initialPathTemplateEnv :: PackageIdentifier - -> UnitId - -> CompilerInfo - -> Platform - -> PathTemplateEnv +initialPathTemplateEnv + :: PackageIdentifier + -> UnitId + -> CompilerInfo + -> Platform + -> PathTemplateEnv initialPathTemplateEnv pkgId libname compiler platform = - packageTemplateEnv pkgId libname - ++ compilerTemplateEnv compiler - ++ platformTemplateEnv platform - ++ abiTemplateEnv compiler platform + packageTemplateEnv pkgId libname + ++ compilerTemplateEnv compiler + ++ platformTemplateEnv platform + ++ abiTemplateEnv compiler platform packageTemplateEnv :: PackageIdentifier -> UnitId -> PathTemplateEnv packageTemplateEnv pkgId uid = - [(PkgNameVar, PathTemplate [Ordinary $ prettyShow (packageName pkgId)]) - ,(PkgVerVar, PathTemplate [Ordinary $ prettyShow (packageVersion pkgId)]) - -- Invariant: uid is actually a HashedUnitId. Hard to enforce because - -- it's an API change. - ,(LibNameVar, PathTemplate [Ordinary $ prettyShow uid]) - ,(PkgIdVar, PathTemplate [Ordinary $ prettyShow pkgId]) + [ (PkgNameVar, PathTemplate [Ordinary $ prettyShow (packageName pkgId)]) + , (PkgVerVar, PathTemplate [Ordinary $ prettyShow (packageVersion pkgId)]) + , -- Invariant: uid is actually a HashedUnitId. Hard to enforce because + -- it's an API change. + (LibNameVar, PathTemplate [Ordinary $ prettyShow uid]) + , (PkgIdVar, PathTemplate [Ordinary $ prettyShow pkgId]) ] compilerTemplateEnv :: CompilerInfo -> PathTemplateEnv compilerTemplateEnv compiler = - [(CompilerVar, PathTemplate [Ordinary $ prettyShow (compilerInfoId compiler)]) + [ (CompilerVar, PathTemplate [Ordinary $ prettyShow (compilerInfoId compiler)]) ] platformTemplateEnv :: Platform -> PathTemplateEnv platformTemplateEnv (Platform arch os) = - [(OSVar, PathTemplate [Ordinary $ prettyShow os]) - ,(ArchVar, PathTemplate [Ordinary $ prettyShow arch]) + [ (OSVar, PathTemplate [Ordinary $ prettyShow os]) + , (ArchVar, PathTemplate [Ordinary $ prettyShow arch]) ] abiTemplateEnv :: CompilerInfo -> Platform -> PathTemplateEnv abiTemplateEnv compiler (Platform arch os) = - [(AbiVar, PathTemplate [Ordinary $ prettyShow arch ++ '-':prettyShow os ++ - '-':prettyShow (compilerInfoId compiler) ++ - case compilerInfoAbiTag compiler of - NoAbiTag -> "" - AbiTag tag -> '-':tag]) - ,(AbiTagVar, PathTemplate [Ordinary $ abiTagString (compilerInfoAbiTag compiler)]) + [ + ( AbiVar + , PathTemplate + [ Ordinary $ + prettyShow arch + ++ '-' + : prettyShow os + ++ '-' + : prettyShow (compilerInfoId compiler) + ++ case compilerInfoAbiTag compiler of + NoAbiTag -> "" + AbiTag tag -> '-' : tag + ] + ) + , (AbiTagVar, PathTemplate [Ordinary $ abiTagString (compilerInfoAbiTag compiler)]) ] installDirsTemplateEnv :: InstallDirs PathTemplate -> PathTemplateEnv installDirsTemplateEnv dirs = - [(PrefixVar, prefix dirs) - ,(BindirVar, bindir dirs) - ,(LibdirVar, libdir dirs) - ,(LibsubdirVar, libsubdir dirs) - ,(DynlibdirVar, dynlibdir dirs) - ,(DatadirVar, datadir dirs) - ,(DatasubdirVar, datasubdir dirs) - ,(DocdirVar, docdir dirs) - ,(HtmldirVar, htmldir dirs) + [ (PrefixVar, prefix dirs) + , (BindirVar, bindir dirs) + , (LibdirVar, libdir dirs) + , (LibsubdirVar, libsubdir dirs) + , (DynlibdirVar, dynlibdir dirs) + , (DatadirVar, datadir dirs) + , (DatasubdirVar, datasubdir dirs) + , (DocdirVar, docdir dirs) + , (HtmldirVar, htmldir dirs) ] - -- --------------------------------------------------------------------------- -- Parsing and showing path templates: @@ -458,13 +487,16 @@ instance Show PathTemplate where show (PathTemplate template) = show (show template) instance Read PathTemplate where - readsPrec p s = [ (PathTemplate template, s') - | (path, s') <- readsPrec p s - , (template, "") <- reads path ] + readsPrec p s = + [ (PathTemplate template, s') + | (path, s') <- readsPrec p s + , (template, "") <- reads path + ] -- --------------------------------------------------------------------------- -- Internal utilities +{- FOURMOLU_DISABLE -} getWindowsProgramFilesDir :: IO FilePath getWindowsProgramFilesDir = do #ifdef mingw32_HOST_OS @@ -473,6 +505,7 @@ getWindowsProgramFilesDir = do let m = Nothing #endif return (fromMaybe "C:\\Program Files" m) +{- FOURMOLU_ENABLE -} #ifdef mingw32_HOST_OS shGetFolderPath :: CInt -> IO (Maybe FilePath) @@ -490,6 +523,7 @@ csidl_PROGRAM_FILES = 0x0026 -- csidl_PROGRAM_FILES_COMMON :: CInt -- csidl_PROGRAM_FILES_COMMON = 0x002b +{- FOURMOLU_DISABLE -} #ifdef x86_64_HOST_ARCH #define CALLCONV ccall #else @@ -504,3 +538,4 @@ foreign import CALLCONV unsafe "shlobj.h SHGetFolderPathW" -> CWString -> Prelude.IO CInt #endif +{- FOURMOLU_ENABLE -} diff --git a/Cabal/src/Distribution/Simple/InstallDirs/Internal.hs b/Cabal/src/Distribution/Simple/InstallDirs/Internal.hs index 61eedbee700..9c411b7dcc1 100644 --- a/Cabal/src/Distribution/Simple/InstallDirs/Internal.hs +++ b/Cabal/src/Distribution/Simple/InstallDirs/Internal.hs @@ -1,127 +1,160 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} + module Distribution.Simple.InstallDirs.Internal - ( PathComponent(..) - , PathTemplateVariable(..) + ( PathComponent (..) + , PathTemplateVariable (..) ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -data PathComponent = - Ordinary FilePath - | Variable PathTemplateVariable - deriving (Eq, Ord, Generic, Typeable) +data PathComponent + = Ordinary FilePath + | Variable PathTemplateVariable + deriving (Eq, Ord, Generic, Typeable) instance Binary PathComponent instance Structured PathComponent -data PathTemplateVariable = - PrefixVar -- ^ The @$prefix@ path variable - | BindirVar -- ^ The @$bindir@ path variable - | LibdirVar -- ^ The @$libdir@ path variable - | LibsubdirVar -- ^ The @$libsubdir@ path variable - | DynlibdirVar -- ^ The @$dynlibdir@ path variable - | DatadirVar -- ^ The @$datadir@ path variable - | DatasubdirVar -- ^ The @$datasubdir@ path variable - | DocdirVar -- ^ The @$docdir@ path variable - | HtmldirVar -- ^ The @$htmldir@ path variable - | PkgNameVar -- ^ The @$pkg@ package name path variable - | PkgVerVar -- ^ The @$version@ package version path variable - | PkgIdVar -- ^ The @$pkgid@ package Id path variable, eg @foo-1.0@ - | LibNameVar -- ^ The @$libname@ path variable - | CompilerVar -- ^ The compiler name and version, eg @ghc-6.6.1@ - | OSVar -- ^ The operating system name, eg @windows@ or @linux@ - | ArchVar -- ^ The CPU architecture name, eg @i386@ or @x86_64@ - | AbiVar -- ^ The compiler's ABI identifier, - --- $arch-$os-$compiler-$abitag - | AbiTagVar -- ^ The optional ABI tag for the compiler - | ExecutableNameVar -- ^ The executable name; used in shell wrappers - | TestSuiteNameVar -- ^ The name of the test suite being run - | TestSuiteResultVar -- ^ The result of the test suite being run, eg - -- @pass@, @fail@, or @error@. - | BenchmarkNameVar -- ^ The name of the benchmark being run +data PathTemplateVariable + = -- | The @$prefix@ path variable + PrefixVar + | -- | The @$bindir@ path variable + BindirVar + | -- | The @$libdir@ path variable + LibdirVar + | -- | The @$libsubdir@ path variable + LibsubdirVar + | -- | The @$dynlibdir@ path variable + DynlibdirVar + | -- | The @$datadir@ path variable + DatadirVar + | -- | The @$datasubdir@ path variable + DatasubdirVar + | -- | The @$docdir@ path variable + DocdirVar + | -- | The @$htmldir@ path variable + HtmldirVar + | -- | The @$pkg@ package name path variable + PkgNameVar + | -- | The @$version@ package version path variable + PkgVerVar + | -- | The @$pkgid@ package Id path variable, eg @foo-1.0@ + PkgIdVar + | -- | The @$libname@ path variable + LibNameVar + | -- | The compiler name and version, eg @ghc-6.6.1@ + CompilerVar + | -- | The operating system name, eg @windows@ or @linux@ + OSVar + | -- | The CPU architecture name, eg @i386@ or @x86_64@ + ArchVar + | -- | The compiler's ABI identifier, + AbiVar + | --- $arch-$os-$compiler-$abitag + + -- | The optional ABI tag for the compiler + AbiTagVar + | -- | The executable name; used in shell wrappers + ExecutableNameVar + | -- | The name of the test suite being run + TestSuiteNameVar + | -- | The result of the test suite being run, eg + -- @pass@, @fail@, or @error@. + TestSuiteResultVar + | -- | The name of the benchmark being run + BenchmarkNameVar deriving (Eq, Ord, Generic, Typeable) instance Binary PathTemplateVariable instance Structured PathTemplateVariable instance Show PathTemplateVariable where - show PrefixVar = "prefix" - show LibNameVar = "libname" - show BindirVar = "bindir" - show LibdirVar = "libdir" - show LibsubdirVar = "libsubdir" - show DynlibdirVar = "dynlibdir" - show DatadirVar = "datadir" + show PrefixVar = "prefix" + show LibNameVar = "libname" + show BindirVar = "bindir" + show LibdirVar = "libdir" + show LibsubdirVar = "libsubdir" + show DynlibdirVar = "dynlibdir" + show DatadirVar = "datadir" show DatasubdirVar = "datasubdir" - show DocdirVar = "docdir" - show HtmldirVar = "htmldir" - show PkgNameVar = "pkg" - show PkgVerVar = "version" - show PkgIdVar = "pkgid" - show CompilerVar = "compiler" - show OSVar = "os" - show ArchVar = "arch" - show AbiTagVar = "abitag" - show AbiVar = "abi" + show DocdirVar = "docdir" + show HtmldirVar = "htmldir" + show PkgNameVar = "pkg" + show PkgVerVar = "version" + show PkgIdVar = "pkgid" + show CompilerVar = "compiler" + show OSVar = "os" + show ArchVar = "arch" + show AbiTagVar = "abitag" + show AbiVar = "abi" show ExecutableNameVar = "executablename" - show TestSuiteNameVar = "test-suite" + show TestSuiteNameVar = "test-suite" show TestSuiteResultVar = "result" - show BenchmarkNameVar = "benchmark" + show BenchmarkNameVar = "benchmark" instance Read PathTemplateVariable where readsPrec _ s = - take 1 - [ (var, drop (length varStr) s) - | (varStr, var) <- vars - , varStr `isPrefixOf` s ] - -- NB: order matters! Longer strings first - where vars = [("prefix", PrefixVar) - ,("bindir", BindirVar) - ,("libdir", LibdirVar) - ,("libsubdir", LibsubdirVar) - ,("dynlibdir", DynlibdirVar) - ,("datadir", DatadirVar) - ,("datasubdir", DatasubdirVar) - ,("docdir", DocdirVar) - ,("htmldir", HtmldirVar) - ,("pkgid", PkgIdVar) - ,("libname", LibNameVar) - ,("pkgkey", LibNameVar) -- backwards compatibility - ,("pkg", PkgNameVar) - ,("version", PkgVerVar) - ,("compiler", CompilerVar) - ,("os", OSVar) - ,("arch", ArchVar) - ,("abitag", AbiTagVar) - ,("abi", AbiVar) - ,("executablename", ExecutableNameVar) - ,("test-suite", TestSuiteNameVar) - ,("result", TestSuiteResultVar) - ,("benchmark", BenchmarkNameVar)] + take + 1 + [ (var, drop (length varStr) s) + | (varStr, var) <- vars + , varStr `isPrefixOf` s + ] + where + -- NB: order matters! Longer strings first + vars = + [ ("prefix", PrefixVar) + , ("bindir", BindirVar) + , ("libdir", LibdirVar) + , ("libsubdir", LibsubdirVar) + , ("dynlibdir", DynlibdirVar) + , ("datadir", DatadirVar) + , ("datasubdir", DatasubdirVar) + , ("docdir", DocdirVar) + , ("htmldir", HtmldirVar) + , ("pkgid", PkgIdVar) + , ("libname", LibNameVar) + , ("pkgkey", LibNameVar) -- backwards compatibility + , ("pkg", PkgNameVar) + , ("version", PkgVerVar) + , ("compiler", CompilerVar) + , ("os", OSVar) + , ("arch", ArchVar) + , ("abitag", AbiTagVar) + , ("abi", AbiVar) + , ("executablename", ExecutableNameVar) + , ("test-suite", TestSuiteNameVar) + , ("result", TestSuiteResultVar) + , ("benchmark", BenchmarkNameVar) + ] instance Show PathComponent where show (Ordinary path) = path - show (Variable var) = '$':show var + show (Variable var) = '$' : show var showList = foldr (\x -> (shows x .)) id instance Read PathComponent where -- for some reason we collapse multiple $ symbols here readsPrec _ = lex0 - where lex0 [] = [] - lex0 ('$':'$':s') = lex0 ('$':s') - lex0 ('$':s') = case [ (Variable var, s'') - | (var, s'') <- reads s' ] of - [] -> lex1 "$" s' - ok -> ok - lex0 s' = lex1 [] s' - lex1 "" "" = [] - lex1 acc "" = [(Ordinary (reverse acc), "")] - lex1 acc ('$':'$':s) = lex1 acc ('$':s) - lex1 acc ('$':s) = [(Ordinary (reverse acc), '$':s)] - lex1 acc (c:s) = lex1 (c:acc) s - readList [] = [([],"")] - readList s = [ (component:components, s'') - | (component, s') <- reads s - , (components, s'') <- readList s' ] + where + lex0 [] = [] + lex0 ('$' : '$' : s') = lex0 ('$' : s') + lex0 ('$' : s') = case [ (Variable var, s'') + | (var, s'') <- reads s' + ] of + [] -> lex1 "$" s' + ok -> ok + lex0 s' = lex1 [] s' + lex1 "" "" = [] + lex1 acc "" = [(Ordinary (reverse acc), "")] + lex1 acc ('$' : '$' : s) = lex1 acc ('$' : s) + lex1 acc ('$' : s) = [(Ordinary (reverse acc), '$' : s)] + lex1 acc (c : s) = lex1 (c : acc) s + readList [] = [([], "")] + readList s = + [ (component : components, s'') + | (component, s') <- reads s + , (components, s'') <- readList s' + ] diff --git a/Cabal/src/Distribution/Simple/LocalBuildInfo.hs b/Cabal/src/Distribution/Simple/LocalBuildInfo.hs index 992b5eba74f..1290fd1f168 100644 --- a/Cabal/src/Distribution/Simple/LocalBuildInfo.hs +++ b/Cabal/src/Distribution/Simple/LocalBuildInfo.hs @@ -3,6 +3,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.LocalBuildInfo -- Copyright : Isaac Jones 2003-2004 @@ -18,81 +19,83 @@ -- programs, the package database to use and a bunch of miscellaneous configure -- flags. It gets saved and reloaded from a file (@dist\/setup-config@). It gets -- passed in to very many subsequent build actions. - -module Distribution.Simple.LocalBuildInfo ( - LocalBuildInfo(..), - localComponentId, - localUnitId, - localCompatPackageKey, - - -- * Buildable package components - Component(..), - ComponentName(..), - LibraryName(..), - defaultLibName, - showComponentName, - componentNameString, - ComponentLocalBuildInfo(..), - componentBuildDir, - foldComponent, - componentName, - componentBuildInfo, - componentBuildable, - pkgComponents, - pkgBuildableComponents, - lookupComponent, - getComponent, - allComponentsInBuildOrder, - depLibraryPaths, - allLibModules, - - withAllComponentsInBuildOrder, - withLibLBI, - withExeLBI, - withBenchLBI, - withTestLBI, - enabledTestLBIs, - enabledBenchLBIs, - - -- * Installation directories - module Distribution.Simple.InstallDirs, - absoluteInstallDirs, prefixRelativeInstallDirs, - absoluteInstallCommandDirs, - absoluteComponentInstallDirs, prefixRelativeComponentInstallDirs, - substPathTemplate, +module Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo (..) + , localComponentId + , localUnitId + , localCompatPackageKey + + -- * Buildable package components + , Component (..) + , ComponentName (..) + , LibraryName (..) + , defaultLibName + , showComponentName + , componentNameString + , ComponentLocalBuildInfo (..) + , componentBuildDir + , foldComponent + , componentName + , componentBuildInfo + , componentBuildable + , pkgComponents + , pkgBuildableComponents + , lookupComponent + , getComponent + , allComponentsInBuildOrder + , depLibraryPaths + , allLibModules + , withAllComponentsInBuildOrder + , withLibLBI + , withExeLBI + , withBenchLBI + , withTestLBI + , enabledTestLBIs + , enabledBenchLBIs + + -- * Installation directories + , module Distribution.Simple.InstallDirs + , absoluteInstallDirs + , prefixRelativeInstallDirs + , absoluteInstallCommandDirs + , absoluteComponentInstallDirs + , prefixRelativeComponentInstallDirs + , substPathTemplate ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Types.Component -import Distribution.Types.PackageId -import Distribution.Types.UnitId -import Distribution.Types.ComponentName -import Distribution.Types.UnqualComponentName -import Distribution.Types.PackageDescription import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ComponentName import Distribution.Types.LocalBuildInfo +import Distribution.Types.PackageDescription +import Distribution.Types.PackageId import Distribution.Types.TargetInfo +import Distribution.Types.UnitId +import Distribution.Types.UnqualComponentName -import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs, - prefixRelativeInstallDirs, - substPathTemplate, ) -import qualified Distribution.Simple.InstallDirs as InstallDirs -import Distribution.PackageDescription +import qualified Distribution.Compat.Graph as Graph import qualified Distribution.InstalledPackageInfo as Installed -import Distribution.Package import Distribution.ModuleName +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Pretty import Distribution.Simple.Compiler +import Distribution.Simple.InstallDirs hiding + ( absoluteInstallDirs + , prefixRelativeInstallDirs + , substPathTemplate + ) +import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.PackageIndex import Distribution.Simple.Utils -import Distribution.Pretty -import qualified Distribution.Compat.Graph as Graph import Data.List (stripPrefix) import System.FilePath -import System.Directory (doesDirectoryExist, canonicalizePath) +import System.Directory (canonicalizePath, doesDirectoryExist) -- ----------------------------------------------------------------------------- -- Configuration information of buildable components @@ -101,83 +104,104 @@ componentBuildDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> FilePath -- For now, we assume that libraries/executables/test-suites/benchmarks -- are only ever built once. With Backpack, we need a special case for -- libraries so that we can handle building them multiple times. -componentBuildDir lbi clbi - = buildDir lbi - case componentLocalName clbi of - CLibName LMainLibName -> - if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi) - then "" - else prettyShow (componentUnitId clbi) - CLibName (LSubLibName s) -> - if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi) - then unUnqualComponentName s - else prettyShow (componentUnitId clbi) - CFLibName s -> unUnqualComponentName s - CExeName s -> unUnqualComponentName s - CTestName s -> unUnqualComponentName s - CBenchName s -> unUnqualComponentName s +componentBuildDir lbi clbi = + buildDir lbi + case componentLocalName clbi of + CLibName LMainLibName -> + if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi) + then "" + else prettyShow (componentUnitId clbi) + CLibName (LSubLibName s) -> + if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi) + then unUnqualComponentName s + else prettyShow (componentUnitId clbi) + CFLibName s -> unUnqualComponentName s + CExeName s -> unUnqualComponentName s + CTestName s -> unUnqualComponentName s + CBenchName s -> unUnqualComponentName s -- | Perform the action on each enabled 'library' in the package -- description with the 'ComponentLocalBuildInfo'. -withLibLBI :: PackageDescription -> LocalBuildInfo - -> (Library -> ComponentLocalBuildInfo -> IO ()) -> IO () +withLibLBI + :: PackageDescription + -> LocalBuildInfo + -> (Library -> ComponentLocalBuildInfo -> IO ()) + -> IO () withLibLBI pkg lbi f = - withAllTargetsInBuildOrder' pkg lbi $ \target -> - case targetComponent target of - CLib lib -> f lib (targetCLBI target) - _ -> return () + withAllTargetsInBuildOrder' pkg lbi $ \target -> + case targetComponent target of + CLib lib -> f lib (targetCLBI target) + _ -> return () -- | Perform the action on each enabled 'Executable' in the package -- description. Extended version of 'withExe' that also gives corresponding -- build info. -withExeLBI :: PackageDescription -> LocalBuildInfo - -> (Executable -> ComponentLocalBuildInfo -> IO ()) -> IO () +withExeLBI + :: PackageDescription + -> LocalBuildInfo + -> (Executable -> ComponentLocalBuildInfo -> IO ()) + -> IO () withExeLBI pkg lbi f = - withAllTargetsInBuildOrder' pkg lbi $ \target -> - case targetComponent target of - CExe exe -> f exe (targetCLBI target) - _ -> return () + withAllTargetsInBuildOrder' pkg lbi $ \target -> + case targetComponent target of + CExe exe -> f exe (targetCLBI target) + _ -> return () -- | Perform the action on each enabled 'Benchmark' in the package -- description. -withBenchLBI :: PackageDescription -> LocalBuildInfo - -> (Benchmark -> ComponentLocalBuildInfo -> IO ()) -> IO () +withBenchLBI + :: PackageDescription + -> LocalBuildInfo + -> (Benchmark -> ComponentLocalBuildInfo -> IO ()) + -> IO () withBenchLBI pkg lbi f = - sequence_ [ f bench clbi | (bench, clbi) <- enabledBenchLBIs pkg lbi ] + sequence_ [f bench clbi | (bench, clbi) <- enabledBenchLBIs pkg lbi] -withTestLBI :: PackageDescription -> LocalBuildInfo - -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO () +withTestLBI + :: PackageDescription + -> LocalBuildInfo + -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) + -> IO () withTestLBI pkg lbi f = - sequence_ [ f test clbi | (test, clbi) <- enabledTestLBIs pkg lbi ] + sequence_ [f test clbi | (test, clbi) <- enabledTestLBIs pkg lbi] -enabledTestLBIs :: PackageDescription -> LocalBuildInfo - -> [(TestSuite, ComponentLocalBuildInfo)] +enabledTestLBIs + :: PackageDescription + -> LocalBuildInfo + -> [(TestSuite, ComponentLocalBuildInfo)] enabledTestLBIs pkg lbi = - [ (test, targetCLBI target) - | target <- allTargetsInBuildOrder' pkg lbi - , CTest test <- [targetComponent target] ] - -enabledBenchLBIs :: PackageDescription -> LocalBuildInfo - -> [(Benchmark, ComponentLocalBuildInfo)] + [ (test, targetCLBI target) + | target <- allTargetsInBuildOrder' pkg lbi + , CTest test <- [targetComponent target] + ] + +enabledBenchLBIs + :: PackageDescription + -> LocalBuildInfo + -> [(Benchmark, ComponentLocalBuildInfo)] enabledBenchLBIs pkg lbi = - [ (bench, targetCLBI target) - | target <- allTargetsInBuildOrder' pkg lbi - , CBench bench <- [targetComponent target] ] + [ (bench, targetCLBI target) + | target <- allTargetsInBuildOrder' pkg lbi + , CBench bench <- [targetComponent target] + ] -- | Perform the action on each buildable 'Library' or 'Executable' (Component) -- in the PackageDescription, subject to the build order specified by the -- 'compBuildOrder' field of the given 'LocalBuildInfo' -withAllComponentsInBuildOrder :: PackageDescription -> LocalBuildInfo - -> (Component -> ComponentLocalBuildInfo -> IO ()) - -> IO () +withAllComponentsInBuildOrder + :: PackageDescription + -> LocalBuildInfo + -> (Component -> ComponentLocalBuildInfo -> IO ()) + -> IO () withAllComponentsInBuildOrder pkg lbi f = - withAllTargetsInBuildOrder' pkg lbi $ \target -> - f (targetComponent target) (targetCLBI target) + withAllTargetsInBuildOrder' pkg lbi $ \target -> + f (targetComponent target) (targetCLBI target) -allComponentsInBuildOrder :: LocalBuildInfo - -> [ComponentLocalBuildInfo] +allComponentsInBuildOrder + :: LocalBuildInfo + -> [ComponentLocalBuildInfo] allComponentsInBuildOrder lbi = - Graph.topSort (componentGraph lbi) + Graph.topSort (componentGraph lbi) -- ----------------------------------------------------------------------------- -- A random function that has no business in this module @@ -186,29 +210,42 @@ allComponentsInBuildOrder lbi = -- transitive dependencies of the component we are building. -- -- When wanted, and possible, returns paths relative to the installDirs 'prefix' -depLibraryPaths :: Bool -- ^ Building for inplace? - -> Bool -- ^ Generate prefix-relative library paths - -> LocalBuildInfo - -> ComponentLocalBuildInfo -- ^ Component that is being built - -> IO [FilePath] +depLibraryPaths + :: Bool + -- ^ Building for inplace? + -> Bool + -- ^ Generate prefix-relative library paths + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -- ^ Component that is being built + -> IO [FilePath] depLibraryPaths inplace relative lbi clbi = do - let pkgDescr = localPkgDescr lbi - installDirs = absoluteComponentInstallDirs pkgDescr lbi (componentUnitId clbi) NoCopyDest - executable = case clbi of - ExeComponentLocalBuildInfo {} -> True - _ -> False - relDir | executable = bindir installDirs - | otherwise = libdir installDirs - - let -- TODO: this is kind of inefficient - internalDeps = [ uid - | (uid, _) <- componentPackageDeps clbi - -- Test that it's internal - , sub_target <- allTargetsInBuildOrder' pkgDescr lbi - , componentUnitId (targetCLBI (sub_target)) == uid ] - internalLibs = [ getLibDir (targetCLBI sub_target) - | sub_target <- neededTargetsInBuildOrder' - pkgDescr lbi internalDeps ] + let pkgDescr = localPkgDescr lbi + installDirs = absoluteComponentInstallDirs pkgDescr lbi (componentUnitId clbi) NoCopyDest + executable = case clbi of + ExeComponentLocalBuildInfo{} -> True + _ -> False + relDir + | executable = bindir installDirs + | otherwise = libdir installDirs + + let + -- TODO: this is kind of inefficient + internalDeps = + [ uid + | (uid, _) <- componentPackageDeps clbi + , -- Test that it's internal + sub_target <- allTargetsInBuildOrder' pkgDescr lbi + , componentUnitId (targetCLBI (sub_target)) == uid + ] + internalLibs = + [ getLibDir (targetCLBI sub_target) + | sub_target <- + neededTargetsInBuildOrder' + pkgDescr + lbi + internalDeps + ] {- -- This is better, but it doesn't work, because we may be passed a -- CLBI which doesn't actually exist, and was faked up when we @@ -219,61 +256,64 @@ depLibraryPaths inplace relative lbi clbi = do $ neededTargetsInBuildOrder lbi [componentUnitId clbi] internalLibs = map getLibDir internalCLBIs -} - getLibDir sub_clbi - | inplace = componentBuildDir lbi sub_clbi - | otherwise = dynlibdir (absoluteComponentInstallDirs pkgDescr lbi (componentUnitId sub_clbi) NoCopyDest) - - -- Why do we go through all the trouble of a hand-crafting - -- internalLibs, when 'installedPkgs' actually contains the - -- internal libraries? The trouble is that 'installedPkgs' - -- may contain *inplace* entries, which we must NOT use for - -- not inplace 'depLibraryPaths' (e.g., for RPATH calculation). - -- See #4025 for more details. This is all horrible but it - -- is a moot point if you are using a per-component build, - -- because you never have any internal libraries in this case; - -- they're all external. - let external_ipkgs = filter is_external (allPackages (installedPkgs lbi)) - is_external ipkg = not (installedUnitId ipkg `elem` internalDeps) - -- First look for dynamic libraries in `dynamic-library-dirs`, and use - -- `library-dirs` as a fall back. - getDynDir pkg = case Installed.libraryDynDirs pkg of - [] -> Installed.libraryDirs pkg - d -> d - allDepLibDirs = concatMap getDynDir external_ipkgs - - allDepLibDirs' = internalLibs ++ allDepLibDirs - allDepLibDirsC <- traverse canonicalizePathNoFail allDepLibDirs' - - let p = prefix installDirs - prefixRelative l = isJust (stripPrefix p l) - libPaths - | relative && - prefixRelative relDir = map (\l -> - if prefixRelative l - then shortRelativePath relDir l - else l - ) allDepLibDirsC - | otherwise = allDepLibDirsC - - return libPaths + getLibDir sub_clbi + | inplace = componentBuildDir lbi sub_clbi + | otherwise = dynlibdir (absoluteComponentInstallDirs pkgDescr lbi (componentUnitId sub_clbi) NoCopyDest) + + -- Why do we go through all the trouble of a hand-crafting + -- internalLibs, when 'installedPkgs' actually contains the + -- internal libraries? The trouble is that 'installedPkgs' + -- may contain *inplace* entries, which we must NOT use for + -- not inplace 'depLibraryPaths' (e.g., for RPATH calculation). + -- See #4025 for more details. This is all horrible but it + -- is a moot point if you are using a per-component build, + -- because you never have any internal libraries in this case; + -- they're all external. + let external_ipkgs = filter is_external (allPackages (installedPkgs lbi)) + is_external ipkg = not (installedUnitId ipkg `elem` internalDeps) + -- First look for dynamic libraries in `dynamic-library-dirs`, and use + -- `library-dirs` as a fall back. + getDynDir pkg = case Installed.libraryDynDirs pkg of + [] -> Installed.libraryDirs pkg + d -> d + allDepLibDirs = concatMap getDynDir external_ipkgs + + allDepLibDirs' = internalLibs ++ allDepLibDirs + allDepLibDirsC <- traverse canonicalizePathNoFail allDepLibDirs' + + let p = prefix installDirs + prefixRelative l = isJust (stripPrefix p l) + libPaths + | relative + && prefixRelative relDir = + map + ( \l -> + if prefixRelative l + then shortRelativePath relDir l + else l + ) + allDepLibDirsC + | otherwise = allDepLibDirsC + + return libPaths where -- 'canonicalizePath' fails on UNIX when the directory does not exists. -- So just don't canonicalize when it doesn't exist. canonicalizePathNoFail p = do exists <- doesDirectoryExist p if exists - then canonicalizePath p - else return p + then canonicalizePath p + else return p -- | Get all module names that needed to be built by GHC; i.e., all -- of these 'ModuleName's have interface files associated with them -- that need to be installed. allLibModules :: Library -> ComponentLocalBuildInfo -> [ModuleName] allLibModules lib clbi = - ordNub $ - explicitLibModules lib ++ - case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> map fst insts + ordNub $ + explicitLibModules lib + ++ case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> map fst insts _ -> [] -- ----------------------------------------------------------------------------- @@ -283,17 +323,21 @@ allLibModules lib clbi = -- assuming that @$libname@ points to the public library (or some fake -- package identifier if there is no public library.) IF AT ALL -- POSSIBLE, please use 'absoluteComponentInstallDirs' instead. -absoluteInstallDirs :: PackageDescription -> LocalBuildInfo - -> CopyDest - -> InstallDirs FilePath +absoluteInstallDirs + :: PackageDescription + -> LocalBuildInfo + -> CopyDest + -> InstallDirs FilePath absoluteInstallDirs pkg lbi copydest = - absoluteComponentInstallDirs pkg lbi (localUnitId lbi) copydest + absoluteComponentInstallDirs pkg lbi (localUnitId lbi) copydest -- | See 'InstallDirs.absoluteInstallDirs'. -absoluteComponentInstallDirs :: PackageDescription -> LocalBuildInfo - -> UnitId - -> CopyDest - -> InstallDirs FilePath +absoluteComponentInstallDirs + :: PackageDescription + -> LocalBuildInfo + -> UnitId + -> CopyDest + -> InstallDirs FilePath absoluteComponentInstallDirs pkg lbi uid copydest = InstallDirs.absoluteInstallDirs (packageId pkg) @@ -303,29 +347,31 @@ absoluteComponentInstallDirs pkg lbi uid copydest = (hostPlatform lbi) (installDirTemplates lbi) -absoluteInstallCommandDirs :: PackageDescription -> LocalBuildInfo - -> UnitId - -> CopyDest - -> InstallDirs FilePath +absoluteInstallCommandDirs + :: PackageDescription + -> LocalBuildInfo + -> UnitId + -> CopyDest + -> InstallDirs FilePath absoluteInstallCommandDirs pkg lbi uid copydest = - dirs { - -- Handle files which are not - -- per-component (data files and Haddock files.) - datadir = datadir dirs', - -- NB: The situation with Haddock is a bit delicate. On the - -- one hand, the easiest to understand Haddock documentation - -- path is pkgname-0.1, which means it's per-package (not - -- per-component). But this means that it's impossible to - -- install Haddock documentation for internal libraries. We'll - -- keep this constraint for now; this means you can't use - -- Cabal to Haddock internal libraries. This does not seem - -- like a big problem. - docdir = docdir dirs', - htmldir = htmldir dirs', - haddockdir = haddockdir dirs' + dirs + { -- Handle files which are not + -- per-component (data files and Haddock files.) + datadir = datadir dirs' + , -- NB: The situation with Haddock is a bit delicate. On the + -- one hand, the easiest to understand Haddock documentation + -- path is pkgname-0.1, which means it's per-package (not + -- per-component). But this means that it's impossible to + -- install Haddock documentation for internal libraries. We'll + -- keep this constraint for now; this means you can't use + -- Cabal to Haddock internal libraries. This does not seem + -- like a big problem. + docdir = docdir dirs' + , htmldir = htmldir dirs' + , haddockdir = haddockdir dirs' } where - dirs = absoluteComponentInstallDirs pkg lbi uid copydest + dirs = absoluteComponentInstallDirs pkg lbi uid copydest -- Notice use of 'absoluteInstallDirs' (not the -- per-component variant). This means for non-library -- packages we'll just pick a nondescriptive foo-0.1 @@ -335,15 +381,19 @@ absoluteInstallCommandDirs pkg lbi uid copydest = -- assuming that @$libname@ points to the public library (or some fake -- package identifier if there is no public library.) IF AT ALL -- POSSIBLE, please use 'prefixRelativeComponentInstallDirs' instead. -prefixRelativeInstallDirs :: PackageId -> LocalBuildInfo - -> InstallDirs (Maybe FilePath) +prefixRelativeInstallDirs + :: PackageId + -> LocalBuildInfo + -> InstallDirs (Maybe FilePath) prefixRelativeInstallDirs pkg_descr lbi = - prefixRelativeComponentInstallDirs pkg_descr lbi (localUnitId lbi) - --- |See 'InstallDirs.prefixRelativeInstallDirs' -prefixRelativeComponentInstallDirs :: PackageId -> LocalBuildInfo - -> UnitId - -> InstallDirs (Maybe FilePath) + prefixRelativeComponentInstallDirs pkg_descr lbi (localUnitId lbi) + +-- | See 'InstallDirs.prefixRelativeInstallDirs' +prefixRelativeComponentInstallDirs + :: PackageId + -> LocalBuildInfo + -> UnitId + -> InstallDirs (Maybe FilePath) prefixRelativeComponentInstallDirs pkg_descr lbi uid = InstallDirs.prefixRelativeInstallDirs (packageId pkg_descr) @@ -352,14 +402,19 @@ prefixRelativeComponentInstallDirs pkg_descr lbi uid = (hostPlatform lbi) (installDirTemplates lbi) -substPathTemplate :: PackageId -> LocalBuildInfo - -> UnitId - -> PathTemplate -> FilePath -substPathTemplate pkgid lbi uid = fromPathTemplate - . ( InstallDirs.substPathTemplate env ) - where env = initialPathTemplateEnv - pkgid - uid - (compilerInfo (compiler lbi)) - (hostPlatform lbi) - +substPathTemplate + :: PackageId + -> LocalBuildInfo + -> UnitId + -> PathTemplate + -> FilePath +substPathTemplate pkgid lbi uid = + fromPathTemplate + . (InstallDirs.substPathTemplate env) + where + env = + initialPathTemplateEnv + pkgid + uid + (compilerInfo (compiler lbi)) + (hostPlatform lbi) diff --git a/Cabal/src/Distribution/Simple/PackageDescription.hs b/Cabal/src/Distribution/Simple/PackageDescription.hs index 6bf11413930..c52cea789d9 100644 --- a/Cabal/src/Distribution/Simple/PackageDescription.hs +++ b/Cabal/src/Distribution/Simple/PackageDescription.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.PackageDescription -- Copyright : Isaac Jones 2003-2005 @@ -8,33 +9,37 @@ -- Portability : portable -- -- This defines parsers for the @.cabal@ format - -module Distribution.Simple.PackageDescription ( - -- * Read and Parse files - readGenericPackageDescription, - readHookedBuildInfo, +module Distribution.Simple.PackageDescription + ( -- * Read and Parse files + readGenericPackageDescription + , readHookedBuildInfo -- * Utility Parsing function - parseString, - ) where + , parseString + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Fields.ParseResult import Distribution.PackageDescription import Distribution.PackageDescription.Parsec - ( parseGenericPackageDescription, parseHookedBuildInfo ) -import Distribution.Parsec.Error ( showPError ) + ( parseGenericPackageDescription + , parseHookedBuildInfo + ) +import Distribution.Parsec.Error (showPError) import Distribution.Parsec.Warning - ( PWarning(..), PWarnType(PWTExperimental), showPWarning ) -import Distribution.Simple.Utils ( equating, die', warn ) -import Distribution.Verbosity ( normal, Verbosity ) + ( PWarnType (PWTExperimental) + , PWarning (..) + , showPWarning + ) +import Distribution.Simple.Utils (die', equating, warn) +import Distribution.Verbosity (Verbosity, normal) -import Data.List ( groupBy ) -import Text.Printf ( printf ) import qualified Data.ByteString as BS +import Data.List (groupBy) import System.Directory (doesFileExist) +import Text.Printf (printf) readGenericPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription readGenericPackageDescription = readAndParseFile parseGenericPackageDescription @@ -49,55 +54,63 @@ readHookedBuildInfo = readAndParseFile parseHookedBuildInfo -- -- Argument order is chosen to encourage partial application. readAndParseFile - :: (BS.ByteString -> ParseResult a) -- ^ File contents to final value parser - -> Verbosity -- ^ Verbosity level - -> FilePath -- ^ File to read - -> IO a + :: (BS.ByteString -> ParseResult a) + -- ^ File contents to final value parser + -> Verbosity + -- ^ Verbosity level + -> FilePath + -- ^ File to read + -> IO a readAndParseFile parser verbosity fpath = do - exists <- doesFileExist fpath - unless exists $ - die' verbosity $ - "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue." - bs <- BS.readFile fpath - parseString parser verbosity fpath bs + exists <- doesFileExist fpath + unless exists $ + die' verbosity $ + "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue." + bs <- BS.readFile fpath + parseString parser verbosity fpath bs parseString - :: (BS.ByteString -> ParseResult a) -- ^ File contents to final value parser - -> Verbosity -- ^ Verbosity level - -> String -- ^ File name - -> BS.ByteString - -> IO a + :: (BS.ByteString -> ParseResult a) + -- ^ File contents to final value parser + -> Verbosity + -- ^ Verbosity level + -> String + -- ^ File name + -> BS.ByteString + -> IO a parseString parser verbosity name bs = do - let (warnings, result) = runParseResult (parser bs) - traverse_ (warn verbosity . showPWarning name) (flattenDups verbosity warnings) - case result of - Right x -> return x - Left (_, errors) -> do - traverse_ (warn verbosity . showPError name) errors - die' verbosity $ "Failed parsing \"" ++ name ++ "\"." + let (warnings, result) = runParseResult (parser bs) + traverse_ (warn verbosity . showPWarning name) (flattenDups verbosity warnings) + case result of + Right x -> return x + Left (_, errors) -> do + traverse_ (warn verbosity . showPError name) errors + die' verbosity $ "Failed parsing \"" ++ name ++ "\"." -- | Collapse duplicate experimental feature warnings into single warning, with -- a count of further sites flattenDups :: Verbosity -> [PWarning] -> [PWarning] flattenDups verbosity ws - | verbosity <= normal = rest ++ experimentals - | otherwise = ws -- show all instances - where - (exps, rest) = partition (\(PWarning w _ _) -> w == PWTExperimental) ws - experimentals = - concatMap flatCount - . groupBy (equating warningStr) - . sortBy (comparing warningStr) - $ exps + | verbosity <= normal = rest ++ experimentals + | otherwise = ws -- show all instances + where + (exps, rest) = partition (\(PWarning w _ _) -> w == PWTExperimental) ws + experimentals = + concatMap flatCount + . groupBy (equating warningStr) + . sortBy (comparing warningStr) + $ exps - warningStr (PWarning _ _ w) = w + warningStr (PWarning _ _ w) = w - -- flatten if we have 3 or more examples - flatCount :: [PWarning] -> [PWarning] - flatCount w@[] = w - flatCount w@[_] = w - flatCount w@[_,_] = w - flatCount (PWarning t pos w:xs) = - [PWarning t pos - (w <> printf " (and %d more occurrences)" (length xs)) - ] + -- flatten if we have 3 or more examples + flatCount :: [PWarning] -> [PWarning] + flatCount w@[] = w + flatCount w@[_] = w + flatCount w@[_, _] = w + flatCount (PWarning t pos w : xs) = + [ PWarning + t + pos + (w <> printf " (and %d more occurrences)" (length xs)) + ] diff --git a/Cabal/src/Distribution/Simple/PackageIndex.hs b/Cabal/src/Distribution/Simple/PackageIndex.hs index 26d0147a3c7..927e10ae878 100644 --- a/Cabal/src/Distribution/Simple/PackageIndex.hs +++ b/Cabal/src/Distribution/Simple/PackageIndex.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.PackageIndex -- Copyright : (c) David Himmelstrup 2005, @@ -43,80 +44,77 @@ -- 'Distribution.Client.PackageIndex', which indexes packages only by -- 'PackageName' (this makes it suitable for indexing source packages, -- for which we don't know 'UnitId's.) --- -module Distribution.Simple.PackageIndex ( - -- * Package index data type - InstalledPackageIndex, - PackageIndex, - - -- * Creating an index - fromList, - - -- * Updates - merge, - - insert, - - deleteUnitId, - deleteSourcePackageId, - deletePackageName, --- deleteDependency, - - -- * Queries - - -- ** Precise lookups - lookupUnitId, - lookupComponentId, - lookupSourcePackageId, - lookupPackageId, - lookupPackageName, - lookupDependency, - lookupInternalDependency, - - -- ** Case-insensitive searches - searchByName, - SearchResult(..), - searchByNameSubstring, - searchWithPredicate, - - -- ** Bulk queries - allPackages, - allPackagesByName, - allPackagesBySourcePackageId, - allPackagesBySourcePackageIdAndLibName, - - -- ** Special queries - brokenPackages, - dependencyClosure, - reverseDependencyClosure, - topologicalOrder, - reverseTopologicalOrder, - dependencyInconsistencies, - dependencyCycles, - dependencyGraph, - moduleNameIndex +module Distribution.Simple.PackageIndex + ( -- * Package index data type + InstalledPackageIndex + , PackageIndex + + -- * Creating an index + , fromList + + -- * Updates + , merge + , insert + , deleteUnitId + , deleteSourcePackageId + , deletePackageName + -- deleteDependency, + + -- * Queries + + -- ** Precise lookups + , lookupUnitId + , lookupComponentId + , lookupSourcePackageId + , lookupPackageId + , lookupPackageName + , lookupDependency + , lookupInternalDependency + + -- ** Case-insensitive searches + , searchByName + , SearchResult (..) + , searchByNameSubstring + , searchWithPredicate + + -- ** Bulk queries + , allPackages + , allPackagesByName + , allPackagesBySourcePackageId + , allPackagesBySourcePackageIdAndLibName + + -- ** Special queries + , brokenPackages + , dependencyClosure + , reverseDependencyClosure + , topologicalOrder + , reverseTopologicalOrder + , dependencyInconsistencies + , dependencyCycles + , dependencyGraph + , moduleNameIndex ) where -import Prelude () -import Distribution.Compat.Prelude hiding (lookup) import qualified Data.Map.Strict as Map +import Distribution.Compat.Prelude hiding (lookup) +import Prelude () -import Distribution.Package import Distribution.Backpack -import Distribution.ModuleName import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.Version +import Distribution.ModuleName +import Distribution.Package import Distribution.Simple.Utils import Distribution.Types.LibraryName +import Distribution.Version import Control.Exception (assert) +import Control.Monad import Data.Array ((!)) import qualified Data.Array as Array import qualified Data.Graph as Graph -import Data.List as List ( groupBy, deleteBy, deleteFirstsBy ) +import Data.List as List (deleteBy, deleteFirstsBy, groupBy) import qualified Data.List.NonEmpty as NE -import qualified Data.Tree as Tree -import Control.Monad +import qualified Data.Tree as Tree import Distribution.Compat.Stack import qualified Prelude (foldr1) @@ -126,27 +124,25 @@ import qualified Prelude (foldr1) -- -- Packages are uniquely identified in by their 'UnitId', they can -- also be efficiently looked up by package name or by name and version. --- -data PackageIndex a = PackageIndex { - -- The primary index. Each InstalledPackageInfo record is uniquely identified - -- by its UnitId. - -- - unitIdIndex :: !(Map UnitId a), - - -- This auxiliary index maps package names (case-sensitively) to all the - -- versions and instances of that package. This allows us to find all - -- versions satisfying a dependency. - -- - -- It is a three-level index. The first level is the package name, - -- the second is the package version and the final level is instances - -- of the same package version. These are unique by UnitId - -- and are kept in preference order. - -- - -- FIXME: Clarify what "preference order" means. Check that this invariant is - -- preserved. See #1463 for discussion. - packageIdIndex :: !(Map (PackageName, LibraryName) (Map Version [a])) - - } deriving (Eq, Generic, Show, Read, Typeable) +data PackageIndex a = PackageIndex + { -- The primary index. Each InstalledPackageInfo record is uniquely identified + -- by its UnitId. + -- + unitIdIndex :: !(Map UnitId a) + , -- This auxiliary index maps package names (case-sensitively) to all the + -- versions and instances of that package. This allows us to find all + -- versions satisfying a dependency. + -- + -- It is a three-level index. The first level is the package name, + -- the second is the package version and the final level is instances + -- of the same package version. These are unique by UnitId + -- and are kept in preference order. + -- + -- FIXME: Clarify what "preference order" means. Check that this invariant is + -- preserved. See #1463 for discussion. + packageIdIndex :: !(Map (PackageName, LibraryName) (Map Version [a])) + } + deriving (Eq, Generic, Show, Read, Typeable) instance Binary a => Binary (PackageIndex a) instance Structured a => Structured (PackageIndex a) @@ -156,9 +152,10 @@ instance Structured a => Structured (PackageIndex a) type InstalledPackageIndex = PackageIndex IPI.InstalledPackageInfo instance Monoid (PackageIndex IPI.InstalledPackageInfo) where - mempty = PackageIndex Map.empty Map.empty + mempty = PackageIndex Map.empty Map.empty mappend = (<>) - --save one mappend with empty in the common case: + + -- save one mappend with empty in the common case: mconcat [] = mempty mconcat xs = Prelude.foldr1 mappend xs @@ -170,69 +167,84 @@ invariant :: WithCallStack (InstalledPackageIndex -> Bool) invariant (PackageIndex pids pnames) = -- trace (show pids' ++ "\n" ++ show pnames') $ pids' == pnames' - where - pids' = map installedUnitId (Map.elems pids) - pnames' = sort - [ assert pinstOk (installedUnitId pinst) - | ((pname, plib), pvers) <- Map.toList pnames - , let pversOk = not (Map.null pvers) - , (pver, pinsts) <- assert pversOk $ Map.toList pvers - , let pinsts' = sortBy (comparing installedUnitId) pinsts - pinstsOk = all (\g -> length g == 1) - (groupBy (equating installedUnitId) pinsts') - , pinst <- assert pinstsOk $ pinsts' - , let pinstOk = packageName pinst == pname + where + pids' = map installedUnitId (Map.elems pids) + pnames' = + sort + [ assert pinstOk (installedUnitId pinst) + | ((pname, plib), pvers) <- Map.toList pnames + , let pversOk = not (Map.null pvers) + , (pver, pinsts) <- assert pversOk $ Map.toList pvers + , let pinsts' = sortBy (comparing installedUnitId) pinsts + pinstsOk = + all + (\g -> length g == 1) + (groupBy (equating installedUnitId) pinsts') + , pinst <- assert pinstsOk $ pinsts' + , let pinstOk = + packageName pinst == pname && packageVersion pinst == pver - && IPI.sourceLibName pinst == plib - ] - -- If you see this invariant failing (ie the assert in mkPackageIndex below) - -- then one thing to check is if it is happening in fromList. Check if the - -- second list above (the sort [...] bit) is ending up with duplicates. This - -- has been observed in practice once due to a messed up ghc-pkg db. How/why - -- it became messed up was not discovered. + && IPI.sourceLibName pinst == plib + ] +-- If you see this invariant failing (ie the assert in mkPackageIndex below) +-- then one thing to check is if it is happening in fromList. Check if the +-- second list above (the sort [...] bit) is ending up with duplicates. This +-- has been observed in practice once due to a messed up ghc-pkg db. How/why +-- it became messed up was not discovered. -- + -- * Internal helpers + -- -mkPackageIndex :: WithCallStack (Map UnitId IPI.InstalledPackageInfo - -> Map (PackageName, LibraryName) - (Map Version [IPI.InstalledPackageInfo]) - -> InstalledPackageIndex) +mkPackageIndex + :: WithCallStack + ( Map UnitId IPI.InstalledPackageInfo + -> Map + (PackageName, LibraryName) + (Map Version [IPI.InstalledPackageInfo]) + -> InstalledPackageIndex + ) mkPackageIndex pids pnames = assert (invariant index) index - where index = PackageIndex pids pnames - + where + index = PackageIndex pids pnames -- + -- * Construction + -- -- | Build an index out of a bunch of packages. -- -- If there are duplicates by 'UnitId' then later ones mask earlier -- ones. --- fromList :: [IPI.InstalledPackageInfo] -> InstalledPackageIndex fromList pkgs = mkPackageIndex pids ((fmap . fmap) toList pnames) where - pids = Map.fromList [ (installedUnitId pkg, pkg) | pkg <- pkgs ] - pnames = + pids = Map.fromList [(installedUnitId pkg, pkg) | pkg <- pkgs] + pnames = Map.fromList [ (liftM2 (,) packageName IPI.sourceLibName (NE.head pkgsN), pvers) - | pkgsN <- NE.groupBy (equating (liftM2 (,) packageName IPI.sourceLibName)) - . sortBy (comparing (liftM3 (,,) packageName IPI.sourceLibName packageVersion)) - $ pkgs + | pkgsN <- + NE.groupBy (equating (liftM2 (,) packageName IPI.sourceLibName)) + . sortBy (comparing (liftM3 (,,) packageName IPI.sourceLibName packageVersion)) + $ pkgs , let pvers = Map.fromList - [ (packageVersion (NE.head pkgsNV), - NE.nubBy (equating installedUnitId) (NE.reverse pkgsNV)) - | pkgsNV <- NE.groupBy (equating packageVersion) pkgsN - ] + [ ( packageVersion (NE.head pkgsNV) + , NE.nubBy (equating installedUnitId) (NE.reverse pkgsNV) + ) + | pkgsNV <- NE.groupBy (equating packageVersion) pkgsN + ] ] -- + -- * Updates + -- -- | Merge two indexes. @@ -244,101 +256,110 @@ fromList pkgs = mkPackageIndex pids ((fmap . fmap) toList pnames) -- \"preferred\" over those from the first. Being preferred means they are top -- result when we do a lookup by source 'PackageId'. This is the mechanism we -- use to prefer user packages over global packages. --- -merge :: InstalledPackageIndex -> InstalledPackageIndex - -> InstalledPackageIndex +merge + :: InstalledPackageIndex + -> InstalledPackageIndex + -> InstalledPackageIndex merge (PackageIndex pids1 pnames1) (PackageIndex pids2 pnames2) = - mkPackageIndex (Map.unionWith (\_ y -> y) pids1 pids2) - (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2) + mkPackageIndex + (Map.unionWith (\_ y -> y) pids1 pids2) + (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2) where -- Packages in the second list mask those in the first, however preferred -- packages go first in the list. mergeBuckets xs ys = ys ++ (xs \\ ys) (\\) = deleteFirstsBy (equating installedUnitId) - -- | Inserts a single package into the index. -- -- This is equivalent to (but slightly quicker than) using 'mappend' or -- 'merge' with a singleton index. --- insert :: IPI.InstalledPackageInfo -> InstalledPackageIndex -> InstalledPackageIndex insert pkg (PackageIndex pids pnames) = - mkPackageIndex pids' pnames' - + mkPackageIndex pids' pnames' where - pids' = Map.insert (installedUnitId pkg) pkg pids + pids' = Map.insert (installedUnitId pkg) pkg pids pnames' = insertPackageName pnames insertPackageName = - Map.insertWith (\_ -> insertPackageVersion) - (packageName pkg, IPI.sourceLibName pkg) - (Map.singleton (packageVersion pkg) [pkg]) + Map.insertWith + (\_ -> insertPackageVersion) + (packageName pkg, IPI.sourceLibName pkg) + (Map.singleton (packageVersion pkg) [pkg]) insertPackageVersion = - Map.insertWith (\_ -> insertPackageInstance) - (packageVersion pkg) [pkg] + Map.insertWith + (\_ -> insertPackageInstance) + (packageVersion pkg) + [pkg] insertPackageInstance pkgs = pkg : deleteBy (equating installedUnitId) pkg pkgs - -- | Removes a single installed package from the index. --- -deleteUnitId :: UnitId -> InstalledPackageIndex - -> InstalledPackageIndex +deleteUnitId + :: UnitId + -> InstalledPackageIndex + -> InstalledPackageIndex deleteUnitId ipkgid original@(PackageIndex pids pnames) = case Map.updateLookupWithKey (\_ _ -> Nothing) ipkgid pids of - (Nothing, _) -> original - (Just spkgid, pids') -> mkPackageIndex pids' - (deletePkgName spkgid pnames) - + (Nothing, _) -> original + (Just spkgid, pids') -> + mkPackageIndex + pids' + (deletePkgName spkgid pnames) where deletePkgName spkgid = Map.update (deletePkgVersion spkgid) (packageName spkgid, IPI.sourceLibName spkgid) deletePkgVersion spkgid = - (\m -> if Map.null m then Nothing else Just m) - . Map.update deletePkgInstance (packageVersion spkgid) + (\m -> if Map.null m then Nothing else Just m) + . Map.update deletePkgInstance (packageVersion spkgid) deletePkgInstance = - (\xs -> if null xs then Nothing else Just xs) - . List.deleteBy (\_ pkg -> installedUnitId pkg == ipkgid) undefined + (\xs -> if null xs then Nothing else Just xs) + . List.deleteBy (\_ pkg -> installedUnitId pkg == ipkgid) undefined -- | Removes all packages with this source 'PackageId' from the index. --- -deleteSourcePackageId :: PackageId -> InstalledPackageIndex - -> InstalledPackageIndex +deleteSourcePackageId + :: PackageId + -> InstalledPackageIndex + -> InstalledPackageIndex deleteSourcePackageId pkgid original@(PackageIndex pids pnames) = -- NB: Doesn't delete internal packages case Map.lookup (packageName pkgid, LMainLibName) pnames of - Nothing -> original - Just pvers -> case Map.lookup (packageVersion pkgid) pvers of - Nothing -> original - Just pkgs -> mkPackageIndex - (foldl' (flip (Map.delete . installedUnitId)) pids pkgs) - (deletePkgName pnames) + Nothing -> original + Just pvers -> case Map.lookup (packageVersion pkgid) pvers of + Nothing -> original + Just pkgs -> + mkPackageIndex + (foldl' (flip (Map.delete . installedUnitId)) pids pkgs) + (deletePkgName pnames) where deletePkgName = Map.update deletePkgVersion (packageName pkgid, LMainLibName) deletePkgVersion = - (\m -> if Map.null m then Nothing else Just m) - . Map.delete (packageVersion pkgid) - + (\m -> if Map.null m then Nothing else Just m) + . Map.delete (packageVersion pkgid) -- | Removes all packages with this (case-sensitive) name from the index. -- -- NB: Does NOT delete internal libraries from this package. --- -deletePackageName :: PackageName -> InstalledPackageIndex - -> InstalledPackageIndex +deletePackageName + :: PackageName + -> InstalledPackageIndex + -> InstalledPackageIndex deletePackageName name original@(PackageIndex pids pnames) = case Map.lookup (name, LMainLibName) pnames of - Nothing -> original - Just pvers -> mkPackageIndex - (foldl' (flip (Map.delete . installedUnitId)) pids - (concat (Map.elems pvers))) - (Map.delete (name, LMainLibName) pnames) + Nothing -> original + Just pvers -> + mkPackageIndex + ( foldl' + (flip (Map.delete . installedUnitId)) + pids + (concat (Map.elems pvers)) + ) + (Map.delete (name, LMainLibName) pnames) {- -- | Removes all packages satisfying this dependency from the index. @@ -349,11 +370,12 @@ deleteDependency (Dependency name verstionRange) = -} -- + -- * Bulk queries + -- -- | Get all the packages from the index. --- allPackages :: PackageIndex a -> [a] allPackages = Map.elems . unitIdIndex @@ -362,91 +384,99 @@ allPackages = Map.elems . unitIdIndex -- They are grouped by package name (case-sensitively). -- -- (Doesn't include private libraries.) --- allPackagesByName :: PackageIndex a -> [(PackageName, [a])] allPackagesByName index = [ (pkgname, concat (Map.elems pvers)) - | ((pkgname, LMainLibName), pvers) <- Map.toList (packageIdIndex index) ] + | ((pkgname, LMainLibName), pvers) <- Map.toList (packageIdIndex index) + ] -- | Get all the packages from the index. -- -- They are grouped by source package id (package name and version). -- -- (Doesn't include private libraries) --- -allPackagesBySourcePackageId :: HasUnitId a => PackageIndex a - -> [(PackageId, [a])] +allPackagesBySourcePackageId + :: HasUnitId a + => PackageIndex a + -> [(PackageId, [a])] allPackagesBySourcePackageId index = [ (packageId ipkg, ipkgs) | ((_, LMainLibName), pvers) <- Map.toList (packageIdIndex index) - , ipkgs@(ipkg:_) <- Map.elems pvers ] + , ipkgs@(ipkg : _) <- Map.elems pvers + ] -- | Get all the packages from the index. -- -- They are grouped by source package id and library name. -- -- This DOES include internal libraries. -allPackagesBySourcePackageIdAndLibName :: HasUnitId a => PackageIndex a - -> [((PackageId, LibraryName), [a])] +allPackagesBySourcePackageIdAndLibName + :: HasUnitId a + => PackageIndex a + -> [((PackageId, LibraryName), [a])] allPackagesBySourcePackageIdAndLibName index = [ ((packageId ipkg, ln), ipkgs) | ((_, ln), pvers) <- Map.toList (packageIdIndex index) - , ipkgs@(ipkg:_) <- Map.elems pvers ] + , ipkgs@(ipkg : _) <- Map.elems pvers + ] -- + -- * Lookups + -- -- | Does a lookup by unit identifier. -- -- Since multiple package DBs mask each other by 'UnitId', -- then we get back at most one package. --- -lookupUnitId :: PackageIndex a -> UnitId - -> Maybe a +lookupUnitId + :: PackageIndex a + -> UnitId + -> Maybe a lookupUnitId index uid = Map.lookup uid (unitIdIndex index) -- | Does a lookup by component identifier. In the absence -- of Backpack, this is just a 'lookupUnitId'. --- -lookupComponentId :: PackageIndex a -> ComponentId - -> Maybe a +lookupComponentId + :: PackageIndex a + -> ComponentId + -> Maybe a lookupComponentId index cid = - Map.lookup (newSimpleUnitId cid) (unitIdIndex index) + Map.lookup (newSimpleUnitId cid) (unitIdIndex index) -- | Does a lookup by source package id (name & version). -- -- There can be multiple installed packages with the same source 'PackageId' -- but different 'UnitId'. They are returned in order of -- preference, with the most preferred first. --- lookupSourcePackageId :: PackageIndex a -> PackageId -> [a] lookupSourcePackageId index pkgid = -- Do not lookup internal libraries case Map.lookup (packageName pkgid, LMainLibName) (packageIdIndex index) of - Nothing -> [] - Just pvers -> case Map.lookup (packageVersion pkgid) pvers of - Nothing -> [] + Nothing -> [] + Just pvers -> case Map.lookup (packageVersion pkgid) pvers of + Nothing -> [] Just pkgs -> pkgs -- in preference order -- | Convenient alias of 'lookupSourcePackageId', but assuming only -- one package per package ID. lookupPackageId :: PackageIndex a -> PackageId -> Maybe a -lookupPackageId index pkgid = case lookupSourcePackageId index pkgid of - [] -> Nothing - [pkg] -> Just pkg - _ -> error "Distribution.Simple.PackageIndex: multiple matches found" +lookupPackageId index pkgid = case lookupSourcePackageId index pkgid of + [] -> Nothing + [pkg] -> Just pkg + _ -> error "Distribution.Simple.PackageIndex: multiple matches found" -- | Does a lookup by source package name. --- -lookupPackageName :: PackageIndex a -> PackageName - -> [(Version, [a])] +lookupPackageName + :: PackageIndex a + -> PackageName + -> [(Version, [a])] lookupPackageName index name = -- Do not match internal libraries case Map.lookup (name, LMainLibName) (packageIdIndex index) of - Nothing -> [] - Just pvers -> Map.toList pvers - + Nothing -> [] + Just pvers -> Map.toList pvers -- | Does a lookup by source package name and a range of versions. -- @@ -457,12 +487,14 @@ lookupPackageName index name = -- function on those; use 'lookupInternalDependency' instead. -- -- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty. --- -lookupDependency :: InstalledPackageIndex -> PackageName -> VersionRange - -> [(Version, [IPI.InstalledPackageInfo])] +lookupDependency + :: InstalledPackageIndex + -> PackageName + -> VersionRange + -> [(Version, [IPI.InstalledPackageInfo])] lookupDependency index pn vr = - -- Yes, a little bit of a misnomer here! - lookupInternalDependency index pn vr LMainLibName + -- Yes, a little bit of a misnomer here! + lookupInternalDependency index pn vr LMainLibName -- | Does a lookup by source package name and a range of versions. -- @@ -470,30 +502,34 @@ lookupDependency index pn vr = -- satisfying the version range constraint. -- -- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty. --- -lookupInternalDependency :: InstalledPackageIndex -> PackageName -> VersionRange - -> LibraryName - -> [(Version, [IPI.InstalledPackageInfo])] +lookupInternalDependency + :: InstalledPackageIndex + -> PackageName + -> VersionRange + -> LibraryName + -> [(Version, [IPI.InstalledPackageInfo])] lookupInternalDependency index name versionRange libn = case Map.lookup (name, libn) (packageIdIndex index) of - Nothing -> [] - Just pvers -> [ (ver, pkgs') - | (ver, pkgs) <- Map.toList pvers - , ver `withinRange` versionRange - , let pkgs' = filter eligible pkgs - -- Enforce the invariant - , not (null pkgs') - ] - where - -- When we select for dependencies, we ONLY want to pick up indefinite - -- packages, or packages with no instantiations. We'll do mix-in - -- linking to improve any such package into an instantiated one - -- later. - eligible pkg = IPI.indefinite pkg || null (IPI.instantiatedWith pkg) - + Nothing -> [] + Just pvers -> + [ (ver, pkgs') + | (ver, pkgs) <- Map.toList pvers + , ver `withinRange` versionRange + , let pkgs' = filter eligible pkgs + , -- Enforce the invariant + not (null pkgs') + ] + where + -- When we select for dependencies, we ONLY want to pick up indefinite + -- packages, or packages with no instantiations. We'll do mix-in + -- linking to improve any such package into an instantiated one + -- later. + eligible pkg = IPI.indefinite pkg || null (IPI.instantiatedWith pkg) -- + -- * Case insensitive name lookups + -- -- | Does a case-insensitive search by package name. @@ -507,42 +543,45 @@ lookupInternalDependency index name versionRange libn = -- have an ambiguous result, and we get back all the versions of all the -- packages. The list of ambiguous results is split by exact package name. So -- it is a non-empty list of non-empty lists. --- searchByName :: PackageIndex a -> String -> SearchResult [a] searchByName index name = -- Don't match internal packages - case [ pkgs | pkgs@((pname, LMainLibName),_) <- Map.toList (packageIdIndex index) - , lowercase (unPackageName pname) == lname ] of - [] -> None - [(_,pvers)] -> Unambiguous (concat (Map.elems pvers)) - pkgss -> case find ((mkPackageName name ==) . fst . fst) pkgss of - Just (_,pvers) -> Unambiguous (concat (Map.elems pvers)) - Nothing -> Ambiguous (map (concat . Map.elems . snd) pkgss) - where lname = lowercase name + case [ pkgs | pkgs@((pname, LMainLibName), _) <- Map.toList (packageIdIndex index), lowercase (unPackageName pname) == lname + ] of + [] -> None + [(_, pvers)] -> Unambiguous (concat (Map.elems pvers)) + pkgss -> case find ((mkPackageName name ==) . fst . fst) pkgss of + Just (_, pvers) -> Unambiguous (concat (Map.elems pvers)) + Nothing -> Ambiguous (map (concat . Map.elems . snd) pkgss) + where + lname = lowercase name data SearchResult a = None | Unambiguous a | Ambiguous [a] -- | Does a case-insensitive substring search by package name. -- -- That is, all packages that contain the given string in their name. --- searchByNameSubstring :: PackageIndex a -> String -> [a] searchByNameSubstring index searchterm = searchWithPredicate index (\n -> lsearchterm `isInfixOf` lowercase n) - where lsearchterm = lowercase searchterm + where + lsearchterm = lowercase searchterm -- | @since 3.4.0.0 searchWithPredicate :: PackageIndex a -> (String -> Bool) -> [a] searchWithPredicate index predicate = [ pkg - -- Don't match internal packages - | ((pname, LMainLibName), pvers) <- Map.toList (packageIdIndex index) + | -- Don't match internal packages + ((pname, LMainLibName), pvers) <- Map.toList (packageIdIndex index) , predicate (unPackageName pname) , pkgs <- Map.elems pvers - , pkg <- pkgs ] + , pkg <- pkgs + ] -- + -- * Special queries + -- -- None of the stuff below depends on the internal representation of the index. @@ -554,27 +593,30 @@ searchWithPredicate index predicate = -- This actually computes the strongly connected components. So it gives us a -- list of groups of packages where within each group they all depend on each -- other, directly or indirectly. --- dependencyCycles :: PackageInstalled a => PackageIndex a -> [[a]] dependencyCycles index = - [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ] + [vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList] where - adjacencyList = [ (pkg, installedUnitId pkg, installedDepends pkg) - | pkg <- allPackages index ] - + adjacencyList = + [ (pkg, installedUnitId pkg, installedDepends pkg) + | pkg <- allPackages index + ] -- | All packages that have immediate dependencies that are not in the index. -- -- Returns such packages along with the dependencies that they're missing. --- -brokenPackages :: PackageInstalled a => PackageIndex a - -> [(a, [UnitId])] +brokenPackages + :: PackageInstalled a + => PackageIndex a + -> [(a, [UnitId])] brokenPackages index = [ (pkg, missing) - | pkg <- allPackages index - , let missing = [ pkg' | pkg' <- installedDepends pkg - , isNothing (lookupUnitId index pkg') ] - , not (null missing) ] + | pkg <- allPackages index + , let missing = + [ pkg' | pkg' <- installedDepends pkg, isNothing (lookupUnitId index pkg') + ] + , not (null missing) + ] -- | Tries to take the transitive closure of the package dependencies. -- @@ -583,78 +625,89 @@ brokenPackages index = -- -- * Note that if the result is @Right []@ it is because at least one of -- the original given 'PackageId's do not occur in the index. --- -dependencyClosure :: InstalledPackageIndex - -> [UnitId] - -> Either (InstalledPackageIndex) - [(IPI.InstalledPackageInfo, [UnitId])] +dependencyClosure + :: InstalledPackageIndex + -> [UnitId] + -> Either + (InstalledPackageIndex) + [(IPI.InstalledPackageInfo, [UnitId])] dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of (completed, []) -> Left completed - (completed, _) -> Right (brokenPackages completed) - where - closure completed failed [] = (completed, failed) - closure completed failed (pkgid:pkgids) = case lookupUnitId index pkgid of - Nothing -> closure completed (pkgid:failed) pkgids - Just pkg -> case lookupUnitId completed (installedUnitId pkg) of - Just _ -> closure completed failed pkgids + (completed, _) -> Right (brokenPackages completed) + where + closure completed failed [] = (completed, failed) + closure completed failed (pkgid : pkgids) = case lookupUnitId index pkgid of + Nothing -> closure completed (pkgid : failed) pkgids + Just pkg -> case lookupUnitId completed (installedUnitId pkg) of + Just _ -> closure completed failed pkgids Nothing -> closure completed' failed pkgids' - where completed' = insert pkg completed - pkgids' = installedDepends pkg ++ pkgids + where + completed' = insert pkg completed + pkgids' = installedDepends pkg ++ pkgids -- | Takes the transitive closure of the packages reverse dependencies. -- -- * The given 'PackageId's must be in the index. --- -reverseDependencyClosure :: PackageInstalled a => PackageIndex a - -> [UnitId] - -> [a] +reverseDependencyClosure + :: PackageInstalled a + => PackageIndex a + -> [UnitId] + -> [a] reverseDependencyClosure index = - map vertexToPkg - . concatMap Tree.flatten - . Graph.dfs reverseDepGraph - . map (fromMaybe noSuchPkgId . pkgIdToVertex) - + map vertexToPkg + . concatMap Tree.flatten + . Graph.dfs reverseDepGraph + . map (fromMaybe noSuchPkgId . pkgIdToVertex) where (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index reverseDepGraph = Graph.transposeG depGraph noSuchPkgId = error "reverseDependencyClosure: package is not in the graph" topologicalOrder :: PackageInstalled a => PackageIndex a -> [a] -topologicalOrder index = map toPkgId - . Graph.topSort - $ graph - where (graph, toPkgId, _) = dependencyGraph index +topologicalOrder index = + map toPkgId + . Graph.topSort + $ graph + where + (graph, toPkgId, _) = dependencyGraph index reverseTopologicalOrder :: PackageInstalled a => PackageIndex a -> [a] -reverseTopologicalOrder index = map toPkgId - . Graph.topSort - . Graph.transposeG - $ graph - where (graph, toPkgId, _) = dependencyGraph index +reverseTopologicalOrder index = + map toPkgId + . Graph.topSort + . Graph.transposeG + $ graph + where + (graph, toPkgId, _) = dependencyGraph index -- | Builds a graph of the package dependencies. -- -- Dependencies on other packages that are not in the index are discarded. -- You can check if there are any such dependencies with 'brokenPackages'. --- -dependencyGraph :: PackageInstalled a => PackageIndex a - -> (Graph.Graph, - Graph.Vertex -> a, - UnitId -> Maybe Graph.Vertex) +dependencyGraph + :: PackageInstalled a + => PackageIndex a + -> ( Graph.Graph + , Graph.Vertex -> a + , UnitId -> Maybe Graph.Vertex + ) dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex) where - graph = Array.listArray bounds - [ [ v | Just v <- map id_to_vertex (installedDepends pkg) ] - | pkg <- pkgs ] + graph = + Array.listArray + bounds + [ [v | Just v <- map id_to_vertex (installedDepends pkg)] + | pkg <- pkgs + ] - pkgs = sortBy (comparing packageId) (allPackages index) - vertices = zip (map installedUnitId pkgs) [0..] - vertex_map = Map.fromList vertices + pkgs = sortBy (comparing packageId) (allPackages index) + vertices = zip (map installedUnitId pkgs) [0 ..] + vertex_map = Map.fromList vertices id_to_vertex pid = Map.lookup pid vertex_map vertex_to_pkg vertex = pkgTable ! vertex - pkgTable = Array.listArray bounds pkgs + pkgTable = Array.listArray bounds pkgs topBound = length pkgs - 1 bounds = (0, topBound) @@ -671,29 +724,36 @@ type DepUniqueKey = (PackageName, LibraryName, Map ModuleName OpenModule) -- Each element in the result is a package name along with the packages that -- depend on it and the versions they require. These are guaranteed to be -- distinct. --- -dependencyInconsistencies :: InstalledPackageIndex - -- At DepUniqueKey... - -> [(DepUniqueKey, - -- There were multiple packages (BAD!) - [(UnitId, - -- And here are the packages which - -- immediately depended on it - [IPI.InstalledPackageInfo])])] +dependencyInconsistencies + :: InstalledPackageIndex + -- At DepUniqueKey... + -> [ ( DepUniqueKey + , -- There were multiple packages (BAD!) + [ ( UnitId + , -- And here are the packages which + -- immediately depended on it + [IPI.InstalledPackageInfo] + ) + ] + ) + ] dependencyInconsistencies index = do - (dep_key, insts_map) <- Map.toList inverseIndex - let insts = Map.toList insts_map - guard (length insts >= 2) - return (dep_key, insts) + (dep_key, insts_map) <- Map.toList inverseIndex + let insts = Map.toList insts_map + guard (length insts >= 2) + return (dep_key, insts) where inverseIndex :: Map DepUniqueKey (Map UnitId [IPI.InstalledPackageInfo]) inverseIndex = Map.fromListWith (Map.unionWith (++)) $ do - pkg <- allPackages index - dep_ipid <- installedDepends pkg - Just dep <- [lookupUnitId index dep_ipid] - let dep_key = (packageName dep, IPI.sourceLibName dep, - Map.fromList (IPI.instantiatedWith dep)) - return (dep_key, Map.singleton dep_ipid [pkg]) + pkg <- allPackages index + dep_ipid <- installedDepends pkg + Just dep <- [lookupUnitId index dep_ipid] + let dep_key = + ( packageName dep + , IPI.sourceLibName dep + , Map.fromList (IPI.instantiatedWith dep) + ) + return (dep_key, Map.singleton dep_ipid [pkg]) -- | A rough approximation of GHC's module finder, takes a -- 'InstalledPackageIndex' and turns it into a map from module names to their @@ -705,12 +765,14 @@ moduleNameIndex index = pkg <- allPackages index IPI.ExposedModule m reexport <- IPI.exposedModules pkg case reexport of - Nothing -> return (m, [pkg]) - Just (OpenModuleVar _) -> [] - Just (OpenModule _ m') | m == m' -> [] - | otherwise -> return (m', [pkg]) - -- The heuristic is this: we want to prefer the original package - -- which originally exported a module. However, if a reexport - -- also *renamed* the module (m /= m'), then we have to use the - -- downstream package, since the upstream package has the wrong - -- module name! + Nothing -> return (m, [pkg]) + Just (OpenModuleVar _) -> [] + Just (OpenModule _ m') + | m == m' -> [] + | otherwise -> return (m', [pkg]) + +-- The heuristic is this: we want to prefer the original package +-- which originally exported a module. However, if a reexport +-- also *renamed* the module (m /= m'), then we have to use the +-- downstream package, since the upstream package has the wrong +-- module name! diff --git a/Cabal/src/Distribution/Simple/PreProcess.hs b/Cabal/src/Distribution/Simple/PreProcess.hs index d47dd803569..5531140629f 100644 --- a/Cabal/src/Distribution/Simple/PreProcess.hs +++ b/Cabal/src/Distribution/Simple/PreProcess.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.PreProcess -- Copyright : (c) 2003-2005, Isaac Jones, Malcolm Wallace @@ -19,121 +20,139 @@ -- for actually preprocessing some sources given a bunch of known suffix -- handlers. This module is not as good as it could be, it could really do with -- a rewrite to address some of the problems we have with pre-processors. +module Distribution.Simple.PreProcess + ( preprocessComponent + , preprocessExtras + , knownSuffixHandlers + , ppSuffixes + , PPSuffixHandler + , PreProcessor (..) + , mkSimplePreProcessor + , runSimplePreProcessor + , ppCpp + , ppCpp' + , ppGreenCard + , ppC2hs + , ppHsc2hs + , ppHappy + , ppAlex + , ppUnlit + , platformDefines + , unsorted + ) +where -module Distribution.Simple.PreProcess (preprocessComponent, preprocessExtras, - knownSuffixHandlers, ppSuffixes, - PPSuffixHandler, PreProcessor(..), - mkSimplePreProcessor, runSimplePreProcessor, - ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs, - ppHappy, ppAlex, ppUnlit, platformDefines, - unsorted - ) - where - -import Prelude () import Distribution.Compat.Prelude import Distribution.Compat.Stack +import Prelude () -import Distribution.Simple.PreProcess.Unlit import Distribution.Backpack.DescribeUnitId -import Distribution.Package -import qualified Distribution.ModuleName as ModuleName +import qualified Distribution.InstalledPackageInfo as Installed import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Package import Distribution.PackageDescription as PD -import qualified Distribution.InstalledPackageInfo as Installed -import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Pretty +import Distribution.Simple.BuildPaths import Distribution.Simple.CCompiler import Distribution.Simple.Compiler import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.BuildPaths -import Distribution.Simple.Utils +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PreProcess.Unlit import Distribution.Simple.Program import Distribution.Simple.Program.ResponseFile import Distribution.Simple.Test.LibV09 +import Distribution.Simple.Utils import Distribution.System import Distribution.Types.PackageName.Magic -import Distribution.Pretty -import Distribution.Version -import Distribution.Verbosity import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version -import System.Directory (doesFileExist, doesDirectoryExist) -import System.Info (os, arch) -import System.FilePath (splitExtension, dropExtensions, (), (<.>), - takeDirectory, normalise, replaceExtension, - takeExtensions) - --- |The interface to a preprocessor, which may be implemented using an --- external program, but need not be. The arguments are the name of --- the input file, the name of the output file and a verbosity level. --- Here is a simple example that merely prepends a comment to the given --- source file: --- --- > ppTestHandler :: PreProcessor --- > ppTestHandler = --- > PreProcessor { --- > platformIndependent = True, --- > runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> --- > do info verbosity (inFile++" has been preprocessed to "++outFile) --- > stuff <- readFile inFile --- > writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff) --- > return ExitSuccess +import System.Directory (doesDirectoryExist, doesFileExist) +import System.FilePath + ( dropExtensions + , normalise + , replaceExtension + , splitExtension + , takeDirectory + , takeExtensions + , (<.>) + , () + ) +import System.Info (arch, os) + +-- | The interface to a preprocessor, which may be implemented using an +-- external program, but need not be. The arguments are the name of +-- the input file, the name of the output file and a verbosity level. +-- Here is a simple example that merely prepends a comment to the given +-- source file: -- --- We split the input and output file names into a base directory and the --- rest of the file name. The input base dir is the path in the list of search --- dirs that this file was found in. The output base dir is the build dir where --- all the generated source files are put. +-- > ppTestHandler :: PreProcessor +-- > ppTestHandler = +-- > PreProcessor { +-- > platformIndependent = True, +-- > runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> +-- > do info verbosity (inFile++" has been preprocessed to "++outFile) +-- > stuff <- readFile inFile +-- > writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff) +-- > return ExitSuccess -- --- The reason for splitting it up this way is that some pre-processors don't --- simply generate one output .hs file from one input file but have --- dependencies on other generated files (notably c2hs, where building one --- .hs file may require reading other .chi files, and then compiling the .hs --- file may require reading a generated .h file). In these cases the generated --- files need to embed relative path names to each other (eg the generated .hs --- file mentions the .h file in the FFI imports). This path must be relative to --- the base directory where the generated files are located, it cannot be --- relative to the top level of the build tree because the compilers do not --- look for .h files relative to there, ie we do not use \"-I .\", instead we --- use \"-I dist\/build\" (or whatever dist dir has been set by the user) +-- We split the input and output file names into a base directory and the +-- rest of the file name. The input base dir is the path in the list of search +-- dirs that this file was found in. The output base dir is the build dir where +-- all the generated source files are put. -- --- Most pre-processors do not care of course, so mkSimplePreProcessor and --- runSimplePreProcessor functions handle the simple case. +-- The reason for splitting it up this way is that some pre-processors don't +-- simply generate one output .hs file from one input file but have +-- dependencies on other generated files (notably c2hs, where building one +-- .hs file may require reading other .chi files, and then compiling the .hs +-- file may require reading a generated .h file). In these cases the generated +-- files need to embed relative path names to each other (eg the generated .hs +-- file mentions the .h file in the FFI imports). This path must be relative to +-- the base directory where the generated files are located, it cannot be +-- relative to the top level of the build tree because the compilers do not +-- look for .h files relative to there, ie we do not use \"-I .\", instead we +-- use \"-I dist\/build\" (or whatever dist dir has been set by the user) -- -data PreProcessor = PreProcessor { - - -- Is the output of the pre-processor platform independent? eg happy output - -- is portable haskell but c2hs's output is platform dependent. - -- This matters since only platform independent generated code can be - -- included into a source tarball. - platformIndependent :: Bool, - - -- TODO: deal with pre-processors that have implementation dependent output - -- eg alex and happy have --ghc flags. However we can't really include - -- ghc-specific code into supposedly portable source tarballs. - - -- | This function can reorder /all/ modules, not just those that the +-- Most pre-processors do not care of course, so mkSimplePreProcessor and +-- runSimplePreProcessor functions handle the simple case. +data PreProcessor = PreProcessor + { -- Is the output of the pre-processor platform independent? eg happy output + -- is portable haskell but c2hs's output is platform dependent. + -- This matters since only platform independent generated code can be + -- included into a source tarball. + platformIndependent :: Bool + , -- TODO: deal with pre-processors that have implementation dependent output + -- eg alex and happy have --ghc flags. However we can't really include + -- ghc-specific code into supposedly portable source tarballs. + + ppOrdering + :: Verbosity + -> [FilePath] -- Source directories + -> [ModuleName] -- Module names + -> IO [ModuleName] -- Sorted modules + + -- ^ This function can reorder /all/ modules, not just those that the -- require the preprocessor in question. As such, this function should be -- well-behaved and not reorder modules it doesn't have dominion over! -- -- @since 3.8.1.0 - ppOrdering :: Verbosity - -> [FilePath] -- Source directories - -> [ModuleName] -- Module names - -> IO [ModuleName], -- Sorted modules - - runPreProcessor :: (FilePath, FilePath) -- Location of the source file relative to a base dir - -> (FilePath, FilePath) -- Output file name, relative to an output base dir - -> Verbosity -- verbosity - -> IO () -- Should exit if the preprocessor fails + , runPreProcessor + :: (FilePath, FilePath) -- Location of the source file relative to a base dir + -> (FilePath, FilePath) -- Output file name, relative to an output base dir + -> Verbosity -- verbosity + -> IO () -- Should exit if the preprocessor fails } -- | Just present the modules in the order given; this is the default and it is -- appropriate for preprocessors which do not have any sort of dependencies -- between modules. -unsorted :: Verbosity - -> [FilePath] - -> [ModuleName] - -> IO [ModuleName] +unsorted + :: Verbosity + -> [FilePath] + -> [ModuleName] + -> IO [ModuleName] unsorted _ _ ms = pure ms -- | Function to determine paths to possible extra C sources for a @@ -142,196 +161,257 @@ unsorted _ _ ms = pure ms -- preprocessor's output name format. type PreProcessorExtras = FilePath -> IO [FilePath] - -mkSimplePreProcessor :: (FilePath -> FilePath -> Verbosity -> IO ()) - -> (FilePath, FilePath) - -> (FilePath, FilePath) -> Verbosity -> IO () -mkSimplePreProcessor simplePP +mkSimplePreProcessor + :: (FilePath -> FilePath -> Verbosity -> IO ()) + -> (FilePath, FilePath) + -> (FilePath, FilePath) + -> Verbosity + -> IO () +mkSimplePreProcessor + simplePP (inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) verbosity = simplePP inFile outFile verbosity - where inFile = normalise (inBaseDir inRelativeFile) - outFile = normalise (outBaseDir outRelativeFile) - -runSimplePreProcessor :: PreProcessor -> FilePath -> FilePath -> Verbosity - -> IO () + (outBaseDir, outRelativeFile) + verbosity = simplePP inFile outFile verbosity + where + inFile = normalise (inBaseDir inRelativeFile) + outFile = normalise (outBaseDir outRelativeFile) + +runSimplePreProcessor + :: PreProcessor + -> FilePath + -> FilePath + -> Verbosity + -> IO () runSimplePreProcessor pp inFile outFile verbosity = runPreProcessor pp (".", inFile) (".", outFile) verbosity --- |A preprocessor for turning non-Haskell files with the given extension --- into plain Haskell source files. -type PPSuffixHandler - = (String, BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor) +-- | A preprocessor for turning non-Haskell files with the given extension +-- into plain Haskell source files. +type PPSuffixHandler = + (String, BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor) -- | Apply preprocessors to the sources from 'hsSourceDirs' for a given -- component (lib, exe, or test suite). -- -- XXX: This is terrible -preprocessComponent :: PackageDescription - -> Component - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Bool - -> Verbosity - -> [PPSuffixHandler] - -> IO () +preprocessComponent + :: PackageDescription + -> Component + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Bool + -> Verbosity + -> [PPSuffixHandler] + -> IO () preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = -- Skip preprocessing for scripts since they should be regular Haskell files, -- but may have no or unknown extensions. when (package pd /= fakePackageId) $ do - -- NB: never report instantiation here; we'll report it properly when - -- building. - setupMessage' verbosity "Preprocessing" (packageId pd) - (componentLocalName clbi) (Nothing :: Maybe [(ModuleName, Module)]) - case comp of - (CLib lib@Library{ libBuildInfo = bi }) -> do - let dirs = map getSymbolicPath (hsSourceDirs bi) ++ - [ autogenComponentModulesDir lbi clbi ,autogenPackageModulesDir lbi] - let hndlrs = localHandlers bi - mods <- orderingFromHandlers verbosity dirs hndlrs (allLibModules lib clbi) - for_ (map ModuleName.toFilePath mods) $ - pre dirs (componentBuildDir lbi clbi) hndlrs - (CFLib flib@ForeignLib { foreignLibBuildInfo = bi, foreignLibName = nm }) -> do - let nm' = unUnqualComponentName nm - let flibDir = buildDir lbi nm' nm' ++ "-tmp" - dirs = map getSymbolicPath (hsSourceDirs bi) ++ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi] - let hndlrs = localHandlers bi - mods <- orderingFromHandlers verbosity dirs hndlrs (foreignLibModules flib) - for_ (map ModuleName.toFilePath mods) $ - pre dirs flibDir hndlrs - (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do - let nm' = unUnqualComponentName nm - let exeDir = buildDir lbi nm' nm' ++ "-tmp" - dirs = map getSymbolicPath (hsSourceDirs bi) ++ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi] - let hndlrs = localHandlers bi - mods <- orderingFromHandlers verbosity dirs hndlrs (otherModules bi) - for_ (map ModuleName.toFilePath mods) $ - pre dirs exeDir hndlrs - pre (map getSymbolicPath (hsSourceDirs bi)) exeDir (localHandlers bi) $ - dropExtensions (modulePath exe) - CTest test@TestSuite{ testName = nm } -> do - let nm' = unUnqualComponentName nm - case testInterface test of - TestSuiteExeV10 _ f -> + -- NB: never report instantiation here; we'll report it properly when + -- building. + setupMessage' + verbosity + "Preprocessing" + (packageId pd) + (componentLocalName clbi) + (Nothing :: Maybe [(ModuleName, Module)]) + case comp of + (CLib lib@Library{libBuildInfo = bi}) -> do + let dirs = + map getSymbolicPath (hsSourceDirs bi) + ++ [autogenComponentModulesDir lbi clbi, autogenPackageModulesDir lbi] + let hndlrs = localHandlers bi + mods <- orderingFromHandlers verbosity dirs hndlrs (allLibModules lib clbi) + for_ (map ModuleName.toFilePath mods) $ + pre dirs (componentBuildDir lbi clbi) hndlrs + (CFLib flib@ForeignLib{foreignLibBuildInfo = bi, foreignLibName = nm}) -> do + let nm' = unUnqualComponentName nm + let flibDir = buildDir lbi nm' nm' ++ "-tmp" + dirs = + map getSymbolicPath (hsSourceDirs bi) + ++ [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + ] + let hndlrs = localHandlers bi + mods <- orderingFromHandlers verbosity dirs hndlrs (foreignLibModules flib) + for_ (map ModuleName.toFilePath mods) $ + pre dirs flibDir hndlrs + (CExe exe@Executable{buildInfo = bi, exeName = nm}) -> do + let nm' = unUnqualComponentName nm + let exeDir = buildDir lbi nm' nm' ++ "-tmp" + dirs = + map getSymbolicPath (hsSourceDirs bi) + ++ [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + ] + let hndlrs = localHandlers bi + mods <- orderingFromHandlers verbosity dirs hndlrs (otherModules bi) + for_ (map ModuleName.toFilePath mods) $ + pre dirs exeDir hndlrs + pre (map getSymbolicPath (hsSourceDirs bi)) exeDir (localHandlers bi) $ + dropExtensions (modulePath exe) + CTest test@TestSuite{testName = nm} -> do + let nm' = unUnqualComponentName nm + case testInterface test of + TestSuiteExeV10 _ f -> preProcessTest test f $ buildDir lbi nm' nm' ++ "-tmp" - TestSuiteLibV09 _ _ -> do - let testDir = buildDir lbi stubName test - stubName test ++ "-tmp" + TestSuiteLibV09 _ _ -> do + let testDir = + buildDir lbi + stubName test + stubName test + ++ "-tmp" writeSimpleTestStub test testDir preProcessTest test (stubFilePath test) testDir - TestSuiteUnsupported tt -> - die' verbosity $ "No support for preprocessing test " - ++ "suite type " ++ prettyShow tt - CBench bm@Benchmark{ benchmarkName = nm } -> do - let nm' = unUnqualComponentName nm - case benchmarkInterface bm of - BenchmarkExeV10 _ f -> + TestSuiteUnsupported tt -> + die' verbosity $ + "No support for preprocessing test " + ++ "suite type " + ++ prettyShow tt + CBench bm@Benchmark{benchmarkName = nm} -> do + let nm' = unUnqualComponentName nm + case benchmarkInterface bm of + BenchmarkExeV10 _ f -> preProcessBench bm f $ buildDir lbi nm' nm' ++ "-tmp" - BenchmarkUnsupported tt -> - die' verbosity $ "No support for preprocessing benchmark " - ++ "type " ++ prettyShow tt + BenchmarkUnsupported tt -> + die' verbosity $ + "No support for preprocessing benchmark " + ++ "type " + ++ prettyShow tt where orderingFromHandlers v d hndlrs mods = - foldM (\acc (_,pp) -> ppOrdering pp v d acc) mods hndlrs + foldM (\acc (_, pp) -> ppOrdering pp v d acc) mods hndlrs builtinHaskellSuffixes = ["hs", "lhs", "hsig", "lhsig"] - builtinCSuffixes = cSourceExtensions - builtinSuffixes = builtinHaskellSuffixes ++ builtinCSuffixes + builtinCSuffixes = cSourceExtensions + builtinSuffixes = builtinHaskellSuffixes ++ builtinCSuffixes localHandlers bi = [(ext, h bi lbi clbi) | (ext, h) <- handlers] pre dirs dir lhndlrs fp = preprocessFile (map unsafeMakeSymbolicPath dirs) dir isSrcDist fp verbosity builtinSuffixes lhndlrs True - preProcessTest test = preProcessComponent (testBuildInfo test) - (testModules test) - preProcessBench bm = preProcessComponent (benchmarkBuildInfo bm) - (benchmarkModules bm) + preProcessTest test = + preProcessComponent + (testBuildInfo test) + (testModules test) + preProcessBench bm = + preProcessComponent + (benchmarkBuildInfo bm) + (benchmarkModules bm) preProcessComponent - :: BuildInfo - -> [ModuleName] - -> FilePath - -> FilePath - -> IO () + :: BuildInfo + -> [ModuleName] + -> FilePath + -> FilePath + -> IO () preProcessComponent bi modules exePath dir = do - let biHandlers = localHandlers bi - sourceDirs = map getSymbolicPath (hsSourceDirs bi) ++ [ autogenComponentModulesDir lbi clbi - , autogenPackageModulesDir lbi ] - sequence_ [ preprocessFile (map unsafeMakeSymbolicPath sourceDirs) dir isSrcDist - (ModuleName.toFilePath modu) verbosity builtinSuffixes - biHandlers False - | modu <- modules ] - -- XXX: what we do here (re SymbolicPath dir) - -- XXX: 2020-10-15 do we rely here on CWD being the PackageDir? - -- Note we don't fail on missing in this case, because the main file may be generated later (i.e. by a test code generator) - preprocessFile (unsafeMakeSymbolicPath dir : hsSourceDirs bi) dir isSrcDist - (dropExtensions $ exePath) verbosity - builtinSuffixes biHandlers False - ---TODO: try to list all the modules that could not be found + let biHandlers = localHandlers bi + sourceDirs = + map getSymbolicPath (hsSourceDirs bi) + ++ [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + ] + sequence_ + [ preprocessFile + (map unsafeMakeSymbolicPath sourceDirs) + dir + isSrcDist + (ModuleName.toFilePath modu) + verbosity + builtinSuffixes + biHandlers + False + | modu <- modules + ] + -- XXX: what we do here (re SymbolicPath dir) + -- XXX: 2020-10-15 do we rely here on CWD being the PackageDir? + -- Note we don't fail on missing in this case, because the main file may be generated later (i.e. by a test code generator) + preprocessFile + (unsafeMakeSymbolicPath dir : hsSourceDirs bi) + dir + isSrcDist + (dropExtensions $ exePath) + verbosity + builtinSuffixes + biHandlers + False + +-- TODO: try to list all the modules that could not be found -- not just the first one. It's annoying and slow due to the need -- to reconfigure after editing the .cabal file each time. -- | Find the first extension of the file that exists, and preprocess it -- if required. preprocessFile - :: [SymbolicPath PackageDir SourceDir] -- ^ source directories - - -> FilePath -- ^build directory - -> Bool -- ^preprocess for sdist - -> FilePath -- ^module file name - -> Verbosity -- ^verbosity - -> [String] -- ^builtin suffixes - -> [(String, PreProcessor)] -- ^possible preprocessors - -> Bool -- ^fail on missing file - -> IO () + :: [SymbolicPath PackageDir SourceDir] + -- ^ source directories + -> FilePath + -- ^ build directory + -> Bool + -- ^ preprocess for sdist + -> FilePath + -- ^ module file name + -> Verbosity + -- ^ verbosity + -> [String] + -- ^ builtin suffixes + -> [(String, PreProcessor)] + -- ^ possible preprocessors + -> Bool + -- ^ fail on missing file + -> IO () preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers failOnMissing = do - -- look for files in the various source dirs with this module name - -- and a file extension of a known preprocessor - psrcFiles <- findFileWithExtension' (map fst handlers) (map getSymbolicPath searchLoc) baseFile - case psrcFiles of - -- no preprocessor file exists, look for an ordinary source file - -- just to make sure one actually exists at all for this module. - -- Note: by looking in the target/output build dir too, we allow - -- source files to appear magically in the target build dir without - -- any corresponding "real" source file. This lets custom Setup.hs - -- files generate source modules directly into the build dir without - -- the rest of the build system being aware of it (somewhat dodgy) - Nothing -> do - bsrcFiles <- findFileWithExtension builtinSuffixes (buildLoc : map getSymbolicPath searchLoc) baseFile - case (bsrcFiles, failOnMissing) of - (Nothing, True) -> - die' verbosity $ "can't find source for " ++ baseFile - ++ " in " ++ intercalate ", " (map getSymbolicPath searchLoc) - _ -> return () - -- found a pre-processable file in one of the source dirs - Just (psrcLoc, psrcRelFile) -> do - let (srcStem, ext) = splitExtension psrcRelFile - psrcFile = psrcLoc psrcRelFile - pp = fromMaybe (error "Distribution.Simple.PreProcess: Just expected") - (lookup (safeTail ext) handlers) - -- Preprocessing files for 'sdist' is different from preprocessing - -- for 'build'. When preprocessing for sdist we preprocess to - -- avoid that the user has to have the preprocessors available. - -- ATM, we don't have a way to specify which files are to be - -- preprocessed and which not, so for sdist we only process - -- platform independent files and put them into the 'buildLoc' - -- (which we assume is set to the temp. directory that will become - -- the tarball). - --TODO: eliminate sdist variant, just supply different handlers - when (not forSDist || forSDist && platformIndependent pp) $ do - -- look for existing pre-processed source file in the dest dir to - -- see if we really have to re-run the preprocessor. - ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] baseFile - recomp <- case ppsrcFiles of - Nothing -> return True - Just ppsrcFile -> - psrcFile `moreRecentFile` ppsrcFile - when recomp $ do - let destDir = buildLoc dirName srcStem - createDirectoryIfMissingVerbose verbosity True destDir - runPreProcessorWithHsBootHack pp - (psrcLoc, psrcRelFile) - (buildLoc, srcStem <.> "hs") - + -- look for files in the various source dirs with this module name + -- and a file extension of a known preprocessor + psrcFiles <- findFileWithExtension' (map fst handlers) (map getSymbolicPath searchLoc) baseFile + case psrcFiles of + -- no preprocessor file exists, look for an ordinary source file + -- just to make sure one actually exists at all for this module. + -- Note: by looking in the target/output build dir too, we allow + -- source files to appear magically in the target build dir without + -- any corresponding "real" source file. This lets custom Setup.hs + -- files generate source modules directly into the build dir without + -- the rest of the build system being aware of it (somewhat dodgy) + Nothing -> do + bsrcFiles <- findFileWithExtension builtinSuffixes (buildLoc : map getSymbolicPath searchLoc) baseFile + case (bsrcFiles, failOnMissing) of + (Nothing, True) -> + die' verbosity $ + "can't find source for " + ++ baseFile + ++ " in " + ++ intercalate ", " (map getSymbolicPath searchLoc) + _ -> return () + -- found a pre-processable file in one of the source dirs + Just (psrcLoc, psrcRelFile) -> do + let (srcStem, ext) = splitExtension psrcRelFile + psrcFile = psrcLoc psrcRelFile + pp = + fromMaybe + (error "Distribution.Simple.PreProcess: Just expected") + (lookup (safeTail ext) handlers) + -- Preprocessing files for 'sdist' is different from preprocessing + -- for 'build'. When preprocessing for sdist we preprocess to + -- avoid that the user has to have the preprocessors available. + -- ATM, we don't have a way to specify which files are to be + -- preprocessed and which not, so for sdist we only process + -- platform independent files and put them into the 'buildLoc' + -- (which we assume is set to the temp. directory that will become + -- the tarball). + -- TODO: eliminate sdist variant, just supply different handlers + when (not forSDist || forSDist && platformIndependent pp) $ do + -- look for existing pre-processed source file in the dest dir to + -- see if we really have to re-run the preprocessor. + ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] baseFile + recomp <- case ppsrcFiles of + Nothing -> return True + Just ppsrcFile -> + psrcFile `moreRecentFile` ppsrcFile + when recomp $ do + let destDir = buildLoc dirName srcStem + createDirectoryIfMissingVerbose verbosity True destDir + runPreProcessorWithHsBootHack + pp + (psrcLoc, psrcRelFile) + (buildLoc, srcStem <.> "hs") where dirName = takeDirectory @@ -340,48 +420,55 @@ preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes ha -- then we need to copy the hs-boot file there too. This should probably be -- done another way. Possibly we should also be looking for .lhs-boot -- files, but I think that preprocessors only produce .hs files. - runPreProcessorWithHsBootHack pp - (inBaseDir, inRelativeFile) + runPreProcessorWithHsBootHack + pp + (inBaseDir, inRelativeFile) (outBaseDir, outRelativeFile) = do - runPreProcessor pp + runPreProcessor + pp (inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) verbosity + (outBaseDir, outRelativeFile) + verbosity exists <- doesFileExist inBoot when exists $ copyFileVerbose verbosity inBoot outBoot + where + inBoot = replaceExtension inFile "hs-boot" + outBoot = replaceExtension outFile "hs-boot" - where - inBoot = replaceExtension inFile "hs-boot" - outBoot = replaceExtension outFile "hs-boot" - - inFile = normalise (inBaseDir inRelativeFile) - outFile = normalise (outBaseDir outRelativeFile) + inFile = normalise (inBaseDir inRelativeFile) + outFile = normalise (outBaseDir outRelativeFile) -- ------------------------------------------------------------ + -- * known preprocessors + -- ------------------------------------------------------------ ppGreenCard :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppGreenCard _ lbi _ - = PreProcessor { - platformIndependent = False, - ppOrdering = unsorted, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - runDbProgram verbosity greencardProgram (withPrograms lbi) - (["-tffi", "-o" ++ outFile, inFile]) - } +ppGreenCard _ lbi _ = + PreProcessor + { platformIndependent = False + , ppOrdering = unsorted + , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + runDbProgram + verbosity + greencardProgram + (withPrograms lbi) + (["-tffi", "-o" ++ outFile, inFile]) + } -- This one is useful for preprocessors that can't handle literate source. -- We also need a way to chain preprocessors. ppUnlit :: PreProcessor ppUnlit = - PreProcessor { - platformIndependent = True, - ppOrdering = unsorted, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - withUTF8FileContents inFile $ \contents -> - either (writeUTF8File outFile) (die' verbosity) (unlit inFile contents) - } + PreProcessor + { platformIndependent = True + , ppOrdering = unsorted + , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + withUTF8FileContents inFile $ \contents -> + either (writeUTF8File outFile) (die' verbosity) (unlit inFile contents) + } ppCpp :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor ppCpp = ppCpp' [] @@ -389,161 +476,198 @@ ppCpp = ppCpp' [] ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor ppCpp' extraArgs bi lbi clbi = case compilerFlavor (compiler lbi) of - GHC -> ppGhcCpp ghcProgram (const True) args bi lbi clbi + GHC -> ppGhcCpp ghcProgram (const True) args bi lbi clbi GHCJS -> ppGhcCpp ghcjsProgram (const True) args bi lbi clbi - _ -> ppCpphs args bi lbi clbi - where cppArgs = getCppOptions bi lbi - args = cppArgs ++ extraArgs - -ppGhcCpp :: Program -> (Version -> Bool) - -> [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor + _ -> ppCpphs args bi lbi clbi + where + cppArgs = getCppOptions bi lbi + args = cppArgs ++ extraArgs + +ppGhcCpp + :: Program + -> (Version -> Bool) + -> [String] + -> BuildInfo + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> PreProcessor ppGhcCpp program xHs extraArgs _bi lbi clbi = - PreProcessor { - platformIndependent = False, - ppOrdering = unsorted, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do - (prog, version, _) <- requireProgramVersion verbosity - program anyVersion (withPrograms lbi) - runProgram verbosity prog $ + PreProcessor + { platformIndependent = False + , ppOrdering = unsorted + , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (prog, version, _) <- + requireProgramVersion + verbosity + program + anyVersion + (withPrograms lbi) + runProgram verbosity prog $ ["-E", "-cpp"] - -- This is a bit of an ugly hack. We're going to - -- unlit the file ourselves later on if appropriate, - -- so we need GHC not to unlit it now or it'll get - -- double-unlitted. In the future we might switch to - -- using cpphs --unlit instead. - ++ (if xHs version then ["-x", "hs"] else []) - ++ [ "-optP-include", "-optP"++ (autogenComponentModulesDir lbi clbi cppHeaderName) ] - ++ ["-o", outFile, inFile] - ++ extraArgs - } + -- This is a bit of an ugly hack. We're going to + -- unlit the file ourselves later on if appropriate, + -- so we need GHC not to unlit it now or it'll get + -- double-unlitted. In the future we might switch to + -- using cpphs --unlit instead. + ++ (if xHs version then ["-x", "hs"] else []) + ++ ["-optP-include", "-optP" ++ (autogenComponentModulesDir lbi clbi cppHeaderName)] + ++ ["-o", outFile, inFile] + ++ extraArgs + } ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor ppCpphs extraArgs _bi lbi clbi = - PreProcessor { - platformIndependent = False, - ppOrdering = unsorted, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do - (cpphsProg, cpphsVersion, _) <- requireProgramVersion verbosity - cpphsProgram anyVersion (withPrograms lbi) - runProgram verbosity cpphsProg $ - ("-O" ++ outFile) : inFile - : "--noline" : "--strip" - : (if cpphsVersion >= mkVersion [1,6] - then ["--include="++ (autogenComponentModulesDir lbi clbi cppHeaderName)] - else []) - ++ extraArgs - } + PreProcessor + { platformIndependent = False + , ppOrdering = unsorted + , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (cpphsProg, cpphsVersion, _) <- + requireProgramVersion + verbosity + cpphsProgram + anyVersion + (withPrograms lbi) + runProgram verbosity cpphsProg $ + ("-O" ++ outFile) + : inFile + : "--noline" + : "--strip" + : ( if cpphsVersion >= mkVersion [1, 6] + then ["--include=" ++ (autogenComponentModulesDir lbi clbi cppHeaderName)] + else [] + ) + ++ extraArgs + } ppHsc2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor ppHsc2hs bi lbi clbi = - PreProcessor { - platformIndependent = False, - ppOrdering = unsorted, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do - (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) - (hsc2hsProg, hsc2hsVersion, _) <- requireProgramVersion verbosity - hsc2hsProgram anyVersion (withPrograms lbi) - -- See Trac #13896 and https://github.com/haskell/cabal/issues/3122. - let isCross = hostPlatform lbi /= buildPlatform - prependCrossFlags = if isCross then ("-x":) else id - let hsc2hsSupportsResponseFiles = hsc2hsVersion >= mkVersion [0,68,4] - pureArgs = genPureArgs hsc2hsVersion gccProg inFile outFile - if hsc2hsSupportsResponseFiles - then withResponseFile - verbosity - defaultTempFileOptions - (takeDirectory outFile) - "hsc2hs-response.txt" - Nothing - pureArgs - (\responseFileName -> - runProgram verbosity hsc2hsProg (prependCrossFlags ["@"++ responseFileName])) - else runProgram verbosity hsc2hsProg (prependCrossFlags pureArgs) - } + PreProcessor + { platformIndependent = False + , ppOrdering = unsorted + , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) + (hsc2hsProg, hsc2hsVersion, _) <- + requireProgramVersion + verbosity + hsc2hsProgram + anyVersion + (withPrograms lbi) + -- See Trac #13896 and https://github.com/haskell/cabal/issues/3122. + let isCross = hostPlatform lbi /= buildPlatform + prependCrossFlags = if isCross then ("-x" :) else id + let hsc2hsSupportsResponseFiles = hsc2hsVersion >= mkVersion [0, 68, 4] + pureArgs = genPureArgs hsc2hsVersion gccProg inFile outFile + if hsc2hsSupportsResponseFiles + then + withResponseFile + verbosity + defaultTempFileOptions + (takeDirectory outFile) + "hsc2hs-response.txt" + Nothing + pureArgs + ( \responseFileName -> + runProgram verbosity hsc2hsProg (prependCrossFlags ["@" ++ responseFileName]) + ) + else runProgram verbosity hsc2hsProg (prependCrossFlags pureArgs) + } where -- Returns a list of command line arguments that can either be passed -- directly, or via a response file. genPureArgs :: Version -> ConfiguredProgram -> String -> String -> [String] genPureArgs hsc2hsVersion gccProg inFile outFile = - -- Additional gcc options - [ "--cflag=" ++ opt | opt <- programDefaultArgs gccProg - ++ programOverrideArgs gccProg ] - ++ [ "--lflag=" ++ opt | opt <- programDefaultArgs gccProg - ++ programOverrideArgs gccProg ] - - -- OSX frameworks: - ++ [ what ++ "=-F" ++ opt - | isOSX - , opt <- nub (concatMap Installed.frameworkDirs pkgs) - , what <- ["--cflag", "--lflag"] ] - ++ [ "--lflag=" ++ arg - | isOSX - , opt <- PD.frameworks bi ++ concatMap Installed.frameworks pkgs - , arg <- ["-framework", opt] ] - - -- Note that on ELF systems, wherever we use -L, we must also use -R - -- because presumably that -L dir is not on the normal path for the - -- system's dynamic linker. This is needed because hsc2hs works by - -- compiling a C program and then running it. - - ++ [ "--cflag=" ++ opt | opt <- platformDefines lbi ] - - -- Options from the current package: - ++ [ "--cflag=-I" ++ dir | dir <- PD.includeDirs bi ] - ++ [ "--cflag=-I" ++ buildDir lbi dir | dir <- PD.includeDirs bi ] - ++ [ "--cflag=" ++ opt | opt <- PD.ccOptions bi - ++ PD.cppOptions bi - -- hsc2hs uses the C ABI - -- We assume that there are only C sources - -- and C++ functions are exported via a C - -- interface and wrapped in a C source file. - -- Therefore we do not supply C++ flags - -- because there will not be C++ sources. - -- - -- DO NOT add PD.cxxOptions unless this changes! - ] - ++ [ "--cflag=" ++ opt | opt <- - [ "-I" ++ autogenComponentModulesDir lbi clbi, - "-I" ++ autogenPackageModulesDir lbi, - "-include", autogenComponentModulesDir lbi clbi cppHeaderName ] ] - ++ [ "--lflag=-L" ++ opt - | opt <- + -- Additional gcc options + [ "--cflag=" ++ opt + | opt <- + programDefaultArgs gccProg + ++ programOverrideArgs gccProg + ] + ++ [ "--lflag=" ++ opt + | opt <- + programDefaultArgs gccProg + ++ programOverrideArgs gccProg + ] + -- OSX frameworks: + ++ [ what ++ "=-F" ++ opt + | isOSX + , opt <- nub (concatMap Installed.frameworkDirs pkgs) + , what <- ["--cflag", "--lflag"] + ] + ++ [ "--lflag=" ++ arg + | isOSX + , opt <- PD.frameworks bi ++ concatMap Installed.frameworks pkgs + , arg <- ["-framework", opt] + ] + -- Note that on ELF systems, wherever we use -L, we must also use -R + -- because presumably that -L dir is not on the normal path for the + -- system's dynamic linker. This is needed because hsc2hs works by + -- compiling a C program and then running it. + + ++ ["--cflag=" ++ opt | opt <- platformDefines lbi] + -- Options from the current package: + ++ ["--cflag=-I" ++ dir | dir <- PD.includeDirs bi] + ++ ["--cflag=-I" ++ buildDir lbi dir | dir <- PD.includeDirs bi] + ++ [ "--cflag=" ++ opt + | opt <- + PD.ccOptions bi + ++ PD.cppOptions bi + -- hsc2hs uses the C ABI + -- We assume that there are only C sources + -- and C++ functions are exported via a C + -- interface and wrapped in a C source file. + -- Therefore we do not supply C++ flags + -- because there will not be C++ sources. + -- + -- DO NOT add PD.cxxOptions unless this changes! + ] + ++ [ "--cflag=" ++ opt + | opt <- + [ "-I" ++ autogenComponentModulesDir lbi clbi + , "-I" ++ autogenPackageModulesDir lbi + , "-include" + , autogenComponentModulesDir lbi clbi cppHeaderName + ] + ] + ++ [ "--lflag=-L" ++ opt + | opt <- if withFullyStaticExe lbi then PD.extraLibDirsStatic bi else PD.extraLibDirs bi - ] - ++ [ "--lflag=-Wl,-R," ++ opt - | isELF - , opt <- + ] + ++ [ "--lflag=-Wl,-R," ++ opt + | isELF + , opt <- if withFullyStaticExe lbi then PD.extraLibDirsStatic bi else PD.extraLibDirs bi - ] - ++ [ "--lflag=-l" ++ opt | opt <- PD.extraLibs bi ] - ++ [ "--lflag=" ++ opt | opt <- PD.ldOptions bi ] - - -- Options from dependent packages - ++ [ "--cflag=" ++ opt - | pkg <- pkgs - , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] - ++ [ opt | opt <- Installed.ccOptions pkg ] ] - ++ [ "--lflag=" ++ opt - | pkg <- pkgs - , opt <- [ "-L" ++ opt | opt <- Installed.libraryDirs pkg ] - ++ [ "-Wl,-R," ++ opt | isELF - , opt <- Installed.libraryDirs pkg ] + ] + ++ ["--lflag=-l" ++ opt | opt <- PD.extraLibs bi] + ++ ["--lflag=" ++ opt | opt <- PD.ldOptions bi] + -- Options from dependent packages + ++ [ "--cflag=" ++ opt + | pkg <- pkgs + , opt <- + ["-I" ++ opt | opt <- Installed.includeDirs pkg] + ++ [opt | opt <- Installed.ccOptions pkg] + ] + ++ [ "--lflag=" ++ opt + | pkg <- pkgs + , opt <- + ["-L" ++ opt | opt <- Installed.libraryDirs pkg] + ++ [ "-Wl,-R," ++ opt | isELF, opt <- Installed.libraryDirs pkg + ] ++ [ "-l" ++ opt | opt <- - if withFullyStaticExe lbi - then Installed.extraLibrariesStatic pkg - else Installed.extraLibraries pkg + if withFullyStaticExe lbi + then Installed.extraLibrariesStatic pkg + else Installed.extraLibraries pkg ] - ++ [ opt | opt <- Installed.ldOptions pkg ] ] - ++ preccldFlags - ++ hsc2hsOptions bi - ++ postccldFlags - - ++ ["-o", outFile, inFile] + ++ [opt | opt <- Installed.ldOptions pkg] + ] + ++ preccldFlags + ++ hsc2hsOptions bi + ++ postccldFlags + ++ ["-o", outFile, inFile] where -- hsc2hs flag parsing was wrong -- (see -- https://github.com/haskell/hsc2hs/issues/35) @@ -555,128 +679,140 @@ ppHsc2hs bi lbi clbi = ] (preccldFlags, postccldFlags) - | hsc2hsVersion >= mkVersion [0,68,8] = (ccldFlags, []) - | otherwise = ([], ccldFlags) + | hsc2hsVersion >= mkVersion [0, 68, 8] = (ccldFlags, []) + | otherwise = ([], ccldFlags) hacked_index = packageHacks (installedPkgs lbi) -- Look only at the dependencies of the current component -- being built! This relies on 'installedPkgs' maintaining -- 'InstalledPackageInfo' for internal deps too; see #2971. pkgs = PackageIndex.topologicalOrder $ - case PackageIndex.dependencyClosure hacked_index - (map fst (componentPackageDeps clbi)) of - Left index' -> index' - Right inf -> - error ("ppHsc2hs: broken closure: " ++ show inf) + case PackageIndex.dependencyClosure + hacked_index + (map fst (componentPackageDeps clbi)) of + Left index' -> index' + Right inf -> + error ("ppHsc2hs: broken closure: " ++ show inf) isOSX = case buildOS of OSX -> True; _ -> False - isELF = case buildOS of OSX -> False; Windows -> False; AIX -> False; _ -> True; + isELF = case buildOS of OSX -> False; Windows -> False; AIX -> False; _ -> True packageHacks = case compilerFlavor (compiler lbi) of - GHC -> hackRtsPackage + GHC -> hackRtsPackage GHCJS -> hackRtsPackage - _ -> id + _ -> id -- We don't link in the actual Haskell libraries of our dependencies, so -- the -u flags in the ldOptions of the rts package mean linking fails on -- OS X (its ld is a tad stricter than gnu ld). Thus we remove the -- ldOptions for GHC's rts package: hackRtsPackage index = case PackageIndex.lookupPackageName index (mkPackageName "rts") of - [(_, [rts])] - -> PackageIndex.insert rts { Installed.ldOptions = [] } index - _ -> error "No (or multiple) ghc rts package is registered!!" + [(_, [rts])] -> + PackageIndex.insert rts{Installed.ldOptions = []} index + _ -> error "No (or multiple) ghc rts package is registered!!" ppHsc2hsExtras :: PreProcessorExtras -ppHsc2hsExtras buildBaseDir = filter ("_hsc.c" `isSuffixOf`) `fmap` - getDirectoryContentsRecursive buildBaseDir +ppHsc2hsExtras buildBaseDir = + filter ("_hsc.c" `isSuffixOf`) + `fmap` getDirectoryContentsRecursive buildBaseDir ppC2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor ppC2hs bi lbi clbi = - PreProcessor { - platformIndependent = False, - ppOrdering = unsorted, - runPreProcessor = \(inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) verbosity -> do - (c2hsProg, _, _) <- requireProgramVersion verbosity - c2hsProgram (orLaterVersion (mkVersion [0,15])) - (withPrograms lbi) - (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) - runProgram verbosity c2hsProg $ - - -- Options from the current package: - [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ] - ++ [ "--cppopts=" ++ opt | opt <- getCppOptions bi lbi ] - ++ [ "--cppopts=-include" ++ (autogenComponentModulesDir lbi clbi cppHeaderName) ] - ++ [ "--include=" ++ outBaseDir ] - - -- Options from dependent packages - ++ [ "--cppopts=" ++ opt - | pkg <- pkgs - , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] - ++ [ opt | opt@('-':c:_) <- Installed.ccOptions pkg - -- c2hs uses the C ABI - -- We assume that there are only C sources - -- and C++ functions are exported via a C - -- interface and wrapped in a C source file. - -- Therefore we do not supply C++ flags - -- because there will not be C++ sources. - -- - -- - -- DO NOT add Installed.cxxOptions unless this changes! - , c `elem` "DIU" ] ] - --TODO: install .chi files for packages, so we can --include - -- those dirs here, for the dependencies - - -- input and output files - ++ [ "--output-dir=" ++ outBaseDir - , "--output=" ++ outRelativeFile - , inBaseDir inRelativeFile ] - } + PreProcessor + { platformIndependent = False + , ppOrdering = unsorted + , runPreProcessor = + \(inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) + verbosity -> do + (c2hsProg, _, _) <- + requireProgramVersion + verbosity + c2hsProgram + (orLaterVersion (mkVersion [0, 15])) + (withPrograms lbi) + (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) + runProgram verbosity c2hsProg $ + -- Options from the current package: + ["--cpp=" ++ programPath gccProg, "--cppopts=-E"] + ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi] + ++ ["--cppopts=-include" ++ (autogenComponentModulesDir lbi clbi cppHeaderName)] + ++ ["--include=" ++ outBaseDir] + -- Options from dependent packages + ++ [ "--cppopts=" ++ opt + | pkg <- pkgs + , opt <- + ["-I" ++ opt | opt <- Installed.includeDirs pkg] + ++ [ opt | opt@('-' : c : _) <- Installed.ccOptions pkg, + -- c2hs uses the C ABI + -- We assume that there are only C sources + -- and C++ functions are exported via a C + -- interface and wrapped in a C source file. + -- Therefore we do not supply C++ flags + -- because there will not be C++ sources. + -- + -- + -- DO NOT add Installed.cxxOptions unless this changes! + c `elem` "DIU" + ] + ] + -- TODO: install .chi files for packages, so we can --include + -- those dirs here, for the dependencies + + -- input and output files + ++ [ "--output-dir=" ++ outBaseDir + , "--output=" ++ outRelativeFile + , inBaseDir inRelativeFile + ] + } where pkgs = PackageIndex.topologicalOrder (installedPkgs lbi) ppC2hsExtras :: PreProcessorExtras -ppC2hsExtras d = filter (\p -> takeExtensions p == ".chs.c") `fmap` - getDirectoryContentsRecursive d +ppC2hsExtras d = + filter (\p -> takeExtensions p == ".chs.c") + `fmap` getDirectoryContentsRecursive d ---TODO: perhaps use this with hsc2hs too ---TODO: remove cc-options from cpphs for cabal-version: >= 1.10 ---TODO: Refactor and add separate getCppOptionsForHs, getCppOptionsForCxx, & getCppOptionsForC +-- TODO: perhaps use this with hsc2hs too +-- TODO: remove cc-options from cpphs for cabal-version: >= 1.10 +-- TODO: Refactor and add separate getCppOptionsForHs, getCppOptionsForCxx, & getCppOptionsForC -- instead of combining all these cases in a single function. This blind combination can -- potentially lead to compilation inconsistencies. getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] -getCppOptions bi lbi - = platformDefines lbi - ++ cppOptions bi - ++ ["-I" ++ dir | dir <- PD.includeDirs bi] - ++ [opt | opt@('-':c:_) <- PD.ccOptions bi ++ PD.cxxOptions bi, c `elem` "DIU"] +getCppOptions bi lbi = + platformDefines lbi + ++ cppOptions bi + ++ ["-I" ++ dir | dir <- PD.includeDirs bi] + ++ [opt | opt@('-' : c : _) <- PD.ccOptions bi ++ PD.cxxOptions bi, c `elem` "DIU"] platformDefines :: LocalBuildInfo -> [String] platformDefines lbi = case compilerFlavor comp of - GHC -> - ["-D__GLASGOW_HASKELL__=" ++ versionInt version] ++ - ["-D" ++ os ++ "_BUILD_OS=1"] ++ - ["-D" ++ arch ++ "_BUILD_ARCH=1"] ++ - map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++ - map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr + GHC -> + ["-D__GLASGOW_HASKELL__=" ++ versionInt version] + ++ ["-D" ++ os ++ "_BUILD_OS=1"] + ++ ["-D" ++ arch ++ "_BUILD_ARCH=1"] + ++ map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr + ++ map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr GHCJS -> - compatGlasgowHaskell ++ - ["-D__GHCJS__=" ++ versionInt version] ++ - ["-D" ++ os ++ "_BUILD_OS=1"] ++ - ["-D" ++ arch ++ "_BUILD_ARCH=1"] ++ - map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++ - map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr - HaskellSuite {} -> - ["-D__HASKELL_SUITE__"] ++ - map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++ - map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr - _ -> [] + compatGlasgowHaskell + ++ ["-D__GHCJS__=" ++ versionInt version] + ++ ["-D" ++ os ++ "_BUILD_OS=1"] + ++ ["-D" ++ arch ++ "_BUILD_ARCH=1"] + ++ map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr + ++ map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr + HaskellSuite{} -> + ["-D__HASKELL_SUITE__"] + ++ map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr + ++ map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr + _ -> [] where comp = compiler lbi Platform hostArch hostOS = hostPlatform lbi version = compilerVersion comp compatGlasgowHaskell = - maybe [] (\v -> ["-D__GLASGOW_HASKELL__=" ++ versionInt v]) - (compilerCompatVersion GHC comp) + maybe + [] + (\v -> ["-D__GLASGOW_HASKELL__=" ++ versionInt v]) + (compilerCompatVersion GHC comp) -- TODO: move this into the compiler abstraction -- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all -- the other compilers. Check if that's really what they want. @@ -684,144 +820,155 @@ platformDefines lbi = versionInt v = case versionNumbers v of [] -> "1" [n] -> show n - n1:n2:_ -> + n1 : n2 : _ -> -- 6.8.x -> 608 -- 6.10.x -> 610 let s1 = show n1 s2 = show n2 middle = case s2 of - _ : _ : _ -> "" - _ -> "0" - in s1 ++ middle ++ s2 + _ : _ : _ -> "" + _ -> "0" + in s1 ++ middle ++ s2 osStr = case hostOS of - Linux -> ["linux"] - Windows -> ["mingw32"] - OSX -> ["darwin"] - FreeBSD -> ["freebsd"] - OpenBSD -> ["openbsd"] - NetBSD -> ["netbsd"] + Linux -> ["linux"] + Windows -> ["mingw32"] + OSX -> ["darwin"] + FreeBSD -> ["freebsd"] + OpenBSD -> ["openbsd"] + NetBSD -> ["netbsd"] DragonFly -> ["dragonfly"] - Solaris -> ["solaris2"] - AIX -> ["aix"] - HPUX -> ["hpux"] - IRIX -> ["irix"] - HaLVM -> [] - IOS -> ["ios"] - Android -> ["android"] - Ghcjs -> ["ghcjs"] - Wasi -> ["wasi"] - Hurd -> ["hurd"] + Solaris -> ["solaris2"] + AIX -> ["aix"] + HPUX -> ["hpux"] + IRIX -> ["irix"] + HaLVM -> [] + IOS -> ["ios"] + Android -> ["android"] + Ghcjs -> ["ghcjs"] + Wasi -> ["wasi"] + Hurd -> ["hurd"] OtherOS _ -> [] archStr = case hostArch of - I386 -> ["i386"] - X86_64 -> ["x86_64"] - PPC -> ["powerpc"] - PPC64 -> ["powerpc64"] - Sparc -> ["sparc"] - Arm -> ["arm"] - AArch64 -> ["aarch64"] - Mips -> ["mips"] - SH -> [] - IA64 -> ["ia64"] - S390 -> ["s390"] - S390X -> ["s390x"] - Alpha -> ["alpha"] - Hppa -> ["hppa"] - Rs6000 -> ["rs6000"] - M68k -> ["m68k"] - Vax -> ["vax"] - JavaScript -> ["javascript"] - Wasm32 -> ["wasm32"] + I386 -> ["i386"] + X86_64 -> ["x86_64"] + PPC -> ["powerpc"] + PPC64 -> ["powerpc64"] + Sparc -> ["sparc"] + Arm -> ["arm"] + AArch64 -> ["aarch64"] + Mips -> ["mips"] + SH -> [] + IA64 -> ["ia64"] + S390 -> ["s390"] + S390X -> ["s390x"] + Alpha -> ["alpha"] + Hppa -> ["hppa"] + Rs6000 -> ["rs6000"] + M68k -> ["m68k"] + Vax -> ["vax"] + JavaScript -> ["javascript"] + Wasm32 -> ["wasm32"] OtherArch _ -> [] ppHappy :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppHappy _ lbi _ = pp { platformIndependent = True } - where pp = standardPP lbi happyProgram (hcFlags hc) - hc = compilerFlavor (compiler lbi) - hcFlags GHC = ["-agc"] - hcFlags GHCJS = ["-agc"] - hcFlags _ = [] +ppHappy _ lbi _ = pp{platformIndependent = True} + where + pp = standardPP lbi happyProgram (hcFlags hc) + hc = compilerFlavor (compiler lbi) + hcFlags GHC = ["-agc"] + hcFlags GHCJS = ["-agc"] + hcFlags _ = [] ppAlex :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppAlex _ lbi _ = pp { platformIndependent = True } - where pp = standardPP lbi alexProgram (hcFlags hc) - hc = compilerFlavor (compiler lbi) - hcFlags GHC = ["-g"] - hcFlags GHCJS = ["-g"] - hcFlags _ = [] +ppAlex _ lbi _ = pp{platformIndependent = True} + where + pp = standardPP lbi alexProgram (hcFlags hc) + hc = compilerFlavor (compiler lbi) + hcFlags GHC = ["-g"] + hcFlags GHCJS = ["-g"] + hcFlags _ = [] standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor standardPP lbi prog args = - PreProcessor { - platformIndependent = False, - ppOrdering = unsorted, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - runDbProgram verbosity prog (withPrograms lbi) - (args ++ ["-o", outFile, inFile]) - } - --- |Convenience function; get the suffixes of these preprocessors. -ppSuffixes :: [ PPSuffixHandler ] -> [String] + PreProcessor + { platformIndependent = False + , ppOrdering = unsorted + , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + runDbProgram + verbosity + prog + (withPrograms lbi) + (args ++ ["-o", outFile, inFile]) + } + +-- | Convenience function; get the suffixes of these preprocessors. +ppSuffixes :: [PPSuffixHandler] -> [String] ppSuffixes = map fst --- |Standard preprocessors: GreenCard, c2hs, hsc2hs, happy, alex and cpphs. -knownSuffixHandlers :: [ PPSuffixHandler ] +-- | Standard preprocessors: GreenCard, c2hs, hsc2hs, happy, alex and cpphs. +knownSuffixHandlers :: [PPSuffixHandler] knownSuffixHandlers = - [ ("gc", ppGreenCard) - , ("chs", ppC2hs) - , ("hsc", ppHsc2hs) - , ("x", ppAlex) - , ("y", ppHappy) - , ("ly", ppHappy) - , ("cpphs", ppCpp) + [ ("gc", ppGreenCard) + , ("chs", ppC2hs) + , ("hsc", ppHsc2hs) + , ("x", ppAlex) + , ("y", ppHappy) + , ("ly", ppHappy) + , ("cpphs", ppCpp) ] --- |Standard preprocessors with possible extra C sources: c2hs, hsc2hs. -knownExtrasHandlers :: [ PreProcessorExtras ] -knownExtrasHandlers = [ ppC2hsExtras, ppHsc2hsExtras ] +-- | Standard preprocessors with possible extra C sources: c2hs, hsc2hs. +knownExtrasHandlers :: [PreProcessorExtras] +knownExtrasHandlers = [ppC2hsExtras, ppHsc2hsExtras] -- | Find any extra C sources generated by preprocessing that need to -- be added to the component (addresses issue #238). -preprocessExtras :: Verbosity - -> Component - -> LocalBuildInfo - -> IO [FilePath] +preprocessExtras + :: Verbosity + -> Component + -> LocalBuildInfo + -> IO [FilePath] preprocessExtras verbosity comp lbi = case comp of CLib _ -> pp $ buildDir lbi - (CExe Executable { exeName = nm }) -> do + (CExe Executable{exeName = nm}) -> do let nm' = unUnqualComponentName nm pp $ buildDir lbi nm' nm' ++ "-tmp" - (CFLib ForeignLib { foreignLibName = nm }) -> do + (CFLib ForeignLib{foreignLibName = nm}) -> do let nm' = unUnqualComponentName nm pp $ buildDir lbi nm' nm' ++ "-tmp" CTest test -> do let nm' = unUnqualComponentName $ testName test case testInterface test of TestSuiteExeV10 _ _ -> - pp $ buildDir lbi nm' nm' ++ "-tmp" + pp $ buildDir lbi nm' nm' ++ "-tmp" TestSuiteLibV09 _ _ -> - pp $ buildDir lbi stubName test stubName test ++ "-tmp" + pp $ buildDir lbi stubName test stubName test ++ "-tmp" TestSuiteUnsupported tt -> - die' verbosity $ "No support for preprocessing test suite type " ++ - prettyShow tt + die' verbosity $ + "No support for preprocessing test suite type " + ++ prettyShow tt CBench bm -> do let nm' = unUnqualComponentName $ benchmarkName bm case benchmarkInterface bm of BenchmarkExeV10 _ _ -> - pp $ buildDir lbi nm' nm' ++ "-tmp" + pp $ buildDir lbi nm' nm' ++ "-tmp" BenchmarkUnsupported tt -> - die' verbosity $ "No support for preprocessing benchmark " - ++ "type " ++ prettyShow tt + die' verbosity $ + "No support for preprocessing benchmark " + ++ "type " + ++ prettyShow tt where pp :: FilePath -> IO [FilePath] pp dir = do - b <- doesDirectoryExist dir - if b - then (map (dir ) . filter not_sub . concat) - <$> for knownExtrasHandlers - (withLexicalCallStack (\f -> f dir)) - else pure [] + b <- doesDirectoryExist dir + if b + then + (map (dir ) . filter not_sub . concat) + <$> for + knownExtrasHandlers + (withLexicalCallStack (\f -> f dir)) + else pure [] -- TODO: This is a terrible hack to work around #3545 while we don't -- reorganize the directory layout. Basically, for the main -- library, we might accidentally pick up autogenerated sources for @@ -831,11 +978,12 @@ preprocessExtras verbosity comp lbi = case comp of -- if a user has a test suite named foobar and puts their C file in -- foobar/foo.c, this test will incorrectly exclude it. But I -- didn't want to break BC... - not_sub p = and [ not (pre `isPrefixOf` p) | pre <- component_dirs ] + not_sub p = and [not (pre `isPrefixOf` p) | pre <- component_dirs] component_dirs = component_names (localPkgDescr lbi) -- TODO: libify me - component_names pkg_descr = fmap unUnqualComponentName $ - mapMaybe (libraryNameString . libName) (subLibraries pkg_descr) ++ - map exeName (executables pkg_descr) ++ - map testName (testSuites pkg_descr) ++ - map benchmarkName (benchmarks pkg_descr) + component_names pkg_descr = + fmap unUnqualComponentName $ + mapMaybe (libraryNameString . libName) (subLibraries pkg_descr) + ++ map exeName (executables pkg_descr) + ++ map testName (testSuites pkg_descr) + ++ map benchmarkName (benchmarks pkg_descr) diff --git a/Cabal/src/Distribution/Simple/PreProcess/Unlit.hs b/Cabal/src/Distribution/Simple/PreProcess/Unlit.hs index bcd2649a311..a4a1e6719cd 100644 --- a/Cabal/src/Distribution/Simple/PreProcess/Unlit.hs +++ b/Cabal/src/Distribution/Simple/PreProcess/Unlit.hs @@ -1,4 +1,9 @@ ----------------------------------------------------------------------------- + +-- This version is interesting because instead of striping comment lines, it +-- turns them into "-- " style comments. This allows using haddock markup +-- in literate scripts without having to use "> --" prefix. + -- | -- Module : Distribution.Simple.PreProcess.Unlit -- Copyright : ... @@ -8,73 +13,77 @@ -- -- Remove the \"literal\" markups from a Haskell source file, including -- \"@>@\", \"@\\begin{code}@\", \"@\\end{code}@\", and \"@#@\" +module Distribution.Simple.PreProcess.Unlit (unlit, plain) where --- This version is interesting because instead of striping comment lines, it --- turns them into "-- " style comments. This allows using haddock markup --- in literate scripts without having to use "> --" prefix. - -module Distribution.Simple.PreProcess.Unlit (unlit,plain) where - -import Prelude () import Distribution.Compat.Prelude -import Distribution.Utils.Generic (safeTail, safeLast, safeInit) +import Distribution.Utils.Generic (safeInit, safeLast, safeTail) +import Prelude () import Data.List (mapAccumL) -data Classified = BirdTrack String | Blank String | Ordinary String - | Line !Int String | CPP String - | BeginCode | EndCode - -- output only: - | Error String | Comment String +data Classified + = BirdTrack String + | Blank String + | Ordinary String + | Line !Int String + | CPP String + | BeginCode + | EndCode + | -- output only: + Error String + | Comment String -- | No unliteration. plain :: String -> String -> String plain _ hs = hs classify :: String -> Classified -classify ('>':s) = BirdTrack s -classify ('#':s) = case tokens s of - (line:file@('"':_:_):_) | all isDigit line - && safeLast file == Just '"' - -- this shouldn't fail as we tested for 'all isDigit' - -> Line (fromMaybe (error $ "panic! read @Int " ++ show line) $ readMaybe line) (safeTail (safeInit file)) -- TODO:eradicateNoParse - _ -> CPP s - where tokens = unfoldr $ \str -> case lex str of - (t@(_:_), str'):_ -> Just (t, str') - _ -> Nothing -classify ('\\':s) +classify ('>' : s) = BirdTrack s +classify ('#' : s) = case tokens s of + (line : file@('"' : _ : _) : _) + | all isDigit line + && safeLast file == Just '"' -> + -- this shouldn't fail as we tested for 'all isDigit' + Line (fromMaybe (error $ "panic! read @Int " ++ show line) $ readMaybe line) (safeTail (safeInit file)) -- TODO:eradicateNoParse + _ -> CPP s + where + tokens = unfoldr $ \str -> case lex str of + (t@(_ : _), str') : _ -> Just (t, str') + _ -> Nothing +classify ('\\' : s) | "begin{code}" `isPrefixOf` s = BeginCode - | "end{code}" `isPrefixOf` s = EndCode -classify s | all isSpace s = Blank s -classify s = Ordinary s + | "end{code}" `isPrefixOf` s = EndCode +classify s | all isSpace s = Blank s +classify s = Ordinary s -- So the weird exception for comment indenting is to make things work with -- haddock, see classifyAndCheckForBirdTracks below. unclassify :: Bool -> Classified -> String -unclassify _ (BirdTrack s) = ' ':s -unclassify _ (Blank s) = s -unclassify _ (Ordinary s) = s -unclassify _ (Line n file) = "# " ++ show n ++ " " ++ show file -unclassify _ (CPP s) = '#':s -unclassify True (Comment "") = " --" -unclassify True (Comment s) = " -- " ++ s -unclassify False (Comment "") = "--" -unclassify False (Comment s) = "-- " ++ s -unclassify _ _ = internalError +unclassify _ (BirdTrack s) = ' ' : s +unclassify _ (Blank s) = s +unclassify _ (Ordinary s) = s +unclassify _ (Line n file) = "# " ++ show n ++ " " ++ show file +unclassify _ (CPP s) = '#' : s +unclassify True (Comment "") = " --" +unclassify True (Comment s) = " -- " ++ s +unclassify False (Comment "") = "--" +unclassify False (Comment s) = "-- " ++ s +unclassify _ _ = internalError -- | 'unlit' takes a filename (for error reports), and transforms the -- given string, to eliminate the literate comments from the program text. unlit :: FilePath -> String -> Either String String unlit file input = - let (usesBirdTracks, classified) = classifyAndCheckForBirdTracks - . inlines - $ input - in either (Left . unlines . map (unclassify usesBirdTracks)) - Right - . checkErrors - . reclassify - $ classified - + let (usesBirdTracks, classified) = + classifyAndCheckForBirdTracks + . inlines + $ input + in either + (Left . unlines . map (unclassify usesBirdTracks)) + Right + . checkErrors + . reclassify + $ classified where -- So haddock requires comments and code to align, since it treats comments -- as following the layout rule. This is a pain for us since bird track @@ -94,16 +103,17 @@ unlit file input = in (seenBirdTrack || isBirdTrack classification, classification) isBirdTrack (BirdTrack _) = True - isBirdTrack _ = False - - checkErrors ls = case [ e | Error e <- ls ] of - [] -> Left ls - (message:_) -> Right (f ++ ":" ++ show n ++ ": " ++ message) - where (f, n) = errorPos file 1 ls - errorPos f n [] = (f, n) - errorPos f n (Error _:_) = (f, n) - errorPos _ _ (Line n' f':ls) = errorPos f' n' ls - errorPos f n (_ :ls) = errorPos f (n+1) ls + isBirdTrack _ = False + + checkErrors ls = case [e | Error e <- ls] of + [] -> Left ls + (message : _) -> Right (f ++ ":" ++ show n ++ ": " ++ message) + where + (f, n) = errorPos file 1 ls + errorPos f n [] = (f, n) + errorPos f n (Error _ : _) = (f, n) + errorPos _ _ (Line n' f' : ls) = errorPos f' n' ls + errorPos f n (_ : ls) = errorPos f (n + 1) ls -- Here we model a state machine, with each state represented by -- a local function. We only have four states (well, five, @@ -117,51 +127,51 @@ unlit file input = reclassify :: [Classified] -> [Classified] reclassify = blank -- begin in blank state where - latex [] = [] - latex (EndCode :ls) = Blank "" : comment ls - latex (BeginCode :_ ) = [Error "\\begin{code} in code section"] - latex (BirdTrack l:ls) = Ordinary ('>':l) : latex ls - latex ( l:ls) = l : latex ls - - blank [] = [] - blank (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] - blank (BeginCode :ls) = Blank "" : latex ls - blank (BirdTrack l:ls) = BirdTrack l : bird ls - blank (Ordinary l:ls) = Comment l : comment ls - blank ( l:ls) = l : blank ls - - bird [] = [] - bird (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] - bird (BeginCode :ls) = Blank "" : latex ls - bird (Blank l :ls) = Blank l : blank ls - bird (Ordinary _:_ ) = [Error "program line before comment line"] - bird ( l:ls) = l : bird ls - - comment [] = [] - comment (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] - comment (BeginCode :ls) = Blank "" : latex ls - comment (CPP l :ls) = CPP l : comment ls - comment (BirdTrack _:_ ) = [Error "comment line before program line"] + latex [] = [] + latex (EndCode : ls) = Blank "" : comment ls + latex (BeginCode : _) = [Error "\\begin{code} in code section"] + latex (BirdTrack l : ls) = Ordinary ('>' : l) : latex ls + latex (l : ls) = l : latex ls + + blank [] = [] + blank (EndCode : _) = [Error "\\end{code} without \\begin{code}"] + blank (BeginCode : ls) = Blank "" : latex ls + blank (BirdTrack l : ls) = BirdTrack l : bird ls + blank (Ordinary l : ls) = Comment l : comment ls + blank (l : ls) = l : blank ls + + bird [] = [] + bird (EndCode : _) = [Error "\\end{code} without \\begin{code}"] + bird (BeginCode : ls) = Blank "" : latex ls + bird (Blank l : ls) = Blank l : blank ls + bird (Ordinary _ : _) = [Error "program line before comment line"] + bird (l : ls) = l : bird ls + + comment [] = [] + comment (EndCode : _) = [Error "\\end{code} without \\begin{code}"] + comment (BeginCode : ls) = Blank "" : latex ls + comment (CPP l : ls) = CPP l : comment ls + comment (BirdTrack _ : _) = [Error "comment line before program line"] -- a blank line and another ordinary line following a comment -- will be treated as continuing the comment. Otherwise it's -- then end of the comment, with a blank line. - comment (Blank l:ls@(Ordinary _:_)) = Comment l : comment ls - comment (Blank l:ls) = Blank l : blank ls - comment (Line n f :ls) = Line n f : comment ls - comment (Ordinary l:ls) = Comment l : comment ls - comment (Comment _: _) = internalError - comment (Error _: _) = internalError + comment (Blank l : ls@(Ordinary _ : _)) = Comment l : comment ls + comment (Blank l : ls) = Blank l : blank ls + comment (Line n f : ls) = Line n f : comment ls + comment (Ordinary l : ls) = Comment l : comment ls + comment (Comment _ : _) = internalError + comment (Error _ : _) = internalError -- Re-implementation of 'lines', for better efficiency (but decreased laziness). -- Also, importantly, accepts non-standard DOS and Mac line ending characters. inlines :: String -> [String] inlines xs = lines' xs id where - lines' [] acc = [acc []] - lines' ('\^M':'\n':s) acc = acc [] : lines' s id -- DOS - lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS - lines' ('\n':s) acc = acc [] : lines' s id -- Unix - lines' (c:s) acc = lines' s (acc . (c:)) + lines' [] acc = [acc []] + lines' ('\^M' : '\n' : s) acc = acc [] : lines' s id -- DOS + lines' ('\^M' : s) acc = acc [] : lines' s id -- MacOS + lines' ('\n' : s) acc = acc [] : lines' s id -- Unix + lines' (c : s) acc = lines' s (acc . (c :)) internalError :: a internalError = error "unlit: internal error" diff --git a/Cabal/src/Distribution/Simple/Program.hs b/Cabal/src/Distribution/Simple/Program.hs index c5110811982..7423b5d1455 100644 --- a/Cabal/src/Distribution/Simple/Program.hs +++ b/Cabal/src/Distribution/Simple/Program.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program -- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 @@ -34,150 +35,166 @@ -- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a -- hook user the ability to get the above flags and such so that they -- don't have to write all the PATH logic inside Setup.lhs. - -module Distribution.Simple.Program ( - -- * Program and functions for constructing them - Program(..) - , ProgramSearchPath - , ProgramSearchPathEntry(..) - , simpleProgram - , findProgramOnSearchPath - , defaultProgramSearchPath - , findProgramVersion +module Distribution.Simple.Program + ( -- * Program and functions for constructing them + Program (..) + , ProgramSearchPath + , ProgramSearchPathEntry (..) + , simpleProgram + , findProgramOnSearchPath + , defaultProgramSearchPath + , findProgramVersion -- * Configured program and related functions - , ConfiguredProgram(..) - , programPath - , ProgArg - , ProgramLocation(..) - , runProgram - , getProgramOutput - , suppressOverrideArgs + , ConfiguredProgram (..) + , programPath + , ProgArg + , ProgramLocation (..) + , runProgram + , getProgramOutput + , suppressOverrideArgs -- * Program invocations - , ProgramInvocation(..) - , emptyProgramInvocation - , simpleProgramInvocation - , programInvocation - , runProgramInvocation - , getProgramInvocationOutput - , getProgramInvocationLBS + , ProgramInvocation (..) + , emptyProgramInvocation + , simpleProgramInvocation + , programInvocation + , runProgramInvocation + , getProgramInvocationOutput + , getProgramInvocationLBS -- * The collection of unconfigured and configured programs - , builtinPrograms + , builtinPrograms -- * The collection of configured programs we can run - , ProgramDb - , defaultProgramDb - , emptyProgramDb - , restoreProgramDb - , addKnownProgram - , addKnownPrograms - , lookupKnownProgram - , knownPrograms - , getProgramSearchPath - , setProgramSearchPath - , userSpecifyPath - , userSpecifyPaths - , userMaybeSpecifyPath - , userSpecifyArgs - , userSpecifyArgss - , userSpecifiedArgs - , lookupProgram - , lookupProgramVersion - , updateProgram - , configureProgram - , configureAllKnownPrograms - , reconfigurePrograms - , requireProgram - , requireProgramVersion - , needProgram - , runDbProgram - , getDbProgramOutput + , ProgramDb + , defaultProgramDb + , emptyProgramDb + , restoreProgramDb + , addKnownProgram + , addKnownPrograms + , lookupKnownProgram + , knownPrograms + , getProgramSearchPath + , setProgramSearchPath + , userSpecifyPath + , userSpecifyPaths + , userMaybeSpecifyPath + , userSpecifyArgs + , userSpecifyArgss + , userSpecifiedArgs + , lookupProgram + , lookupProgramVersion + , updateProgram + , configureProgram + , configureAllKnownPrograms + , reconfigurePrograms + , requireProgram + , requireProgramVersion + , needProgram + , runDbProgram + , getDbProgramOutput -- * Programs that Cabal knows about - , ghcProgram - , ghcPkgProgram - , ghcjsProgram - , ghcjsPkgProgram - , hmakeProgram - , jhcProgram - , uhcProgram - , gccProgram - , arProgram - , stripProgram - , happyProgram - , alexProgram - , hsc2hsProgram - , c2hsProgram - , cpphsProgram - , hscolourProgram - , doctestProgram - , haddockProgram - , greencardProgram - , ldProgram - , tarProgram - , cppProgram - , pkgConfigProgram - , hpcProgram - ) where + , ghcProgram + , ghcPkgProgram + , ghcjsProgram + , ghcjsPkgProgram + , hmakeProgram + , jhcProgram + , uhcProgram + , gccProgram + , arProgram + , stripProgram + , happyProgram + , alexProgram + , hsc2hsProgram + , c2hsProgram + , cpphsProgram + , hscolourProgram + , doctestProgram + , haddockProgram + , greencardProgram + , ldProgram + , tarProgram + , cppProgram + , pkgConfigProgram + , hpcProgram + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Simple.Program.Types -import Distribution.Simple.Program.Run -import Distribution.Simple.Program.Db import Distribution.Simple.Program.Builtin +import Distribution.Simple.Program.Db import Distribution.Simple.Program.Find +import Distribution.Simple.Program.Run +import Distribution.Simple.Program.Types import Distribution.Simple.Utils import Distribution.Verbosity -- | Runs the given configured program. -runProgram :: Verbosity -- ^Verbosity - -> ConfiguredProgram -- ^The program to run - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO () +runProgram + :: Verbosity + -- ^ Verbosity + -> ConfiguredProgram + -- ^ The program to run + -> [ProgArg] + -- ^ Any /extra/ arguments to add + -> IO () runProgram verbosity prog args = runProgramInvocation verbosity (programInvocation prog args) - -- | Runs the given configured program and gets the output. --- -getProgramOutput :: Verbosity -- ^Verbosity - -> ConfiguredProgram -- ^The program to run - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO String +getProgramOutput + :: Verbosity + -- ^ Verbosity + -> ConfiguredProgram + -- ^ The program to run + -> [ProgArg] + -- ^ Any /extra/ arguments to add + -> IO String getProgramOutput verbosity prog args = getProgramInvocationOutput verbosity (programInvocation prog args) - -- | Looks up the given program in the program database and runs it. --- -runDbProgram :: Verbosity -- ^verbosity - -> Program -- ^The program to run - -> ProgramDb -- ^look up the program here - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO () +runDbProgram + :: Verbosity + -- ^ verbosity + -> Program + -- ^ The program to run + -> ProgramDb + -- ^ look up the program here + -> [ProgArg] + -- ^ Any /extra/ arguments to add + -> IO () runDbProgram verbosity prog programDb args = case lookupProgram prog programDb of - Nothing -> die' verbosity notFound + Nothing -> die' verbosity notFound Just configuredProg -> runProgram verbosity configuredProg args - where - notFound = "The program '" ++ programName prog - ++ "' is required but it could not be found" + where + notFound = + "The program '" + ++ programName prog + ++ "' is required but it could not be found" -- | Looks up the given program in the program database and runs it. --- -getDbProgramOutput :: Verbosity -- ^verbosity - -> Program -- ^The program to run - -> ProgramDb -- ^look up the program here - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO String +getDbProgramOutput + :: Verbosity + -- ^ verbosity + -> Program + -- ^ The program to run + -> ProgramDb + -- ^ look up the program here + -> [ProgArg] + -- ^ Any /extra/ arguments to add + -> IO String getDbProgramOutput verbosity prog programDb args = case lookupProgram prog programDb of - Nothing -> die' verbosity notFound + Nothing -> die' verbosity notFound Just configuredProg -> getProgramOutput verbosity configuredProg args - where - notFound = "The program '" ++ programName prog - ++ "' is required but it could not be found" + where + notFound = + "The program '" + ++ programName prog + ++ "' is required but it could not be found" diff --git a/Cabal/src/Distribution/Simple/Program/Ar.hs b/Cabal/src/Distribution/Simple/Program/Ar.hs index 6c2ef09ecca..b5d1cfe65e6 100644 --- a/Cabal/src/Distribution/Simple/Program/Ar.hs +++ b/Cabal/src/Distribution/Simple/Program/Ar.hs @@ -1,9 +1,10 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE NondecreasingIndentation #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Ar -- Copyright : Duncan Coutts 2009 @@ -12,127 +13,155 @@ -- Portability : portable -- -- This module provides an library interface to the @ar@ program. - -module Distribution.Simple.Program.Ar ( - createArLibArchive, - multiStageProgramInvocation +module Distribution.Simple.Program.Ar + ( createArLibArchive + , multiStageProgramInvocation ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import Distribution.Compat.CopyFile (filesEqual) -import Distribution.Simple.Compiler (arResponseFilesSupported, arDashLSupported) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) +import Distribution.Simple.Compiler (arDashLSupported, arResponseFilesSupported) +import Distribution.Simple.Flag + ( fromFlagOrDefault + ) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..)) import Distribution.Simple.Program - ( ProgramInvocation, arProgram, requireProgram ) + ( ProgramInvocation + , arProgram + , requireProgram + ) import Distribution.Simple.Program.ResponseFile - ( withResponseFile ) + ( withResponseFile + ) import Distribution.Simple.Program.Run - ( programInvocation, multiStageProgramInvocation - , runProgramInvocation ) -import Distribution.Simple.Flag - ( fromFlagOrDefault ) + ( multiStageProgramInvocation + , programInvocation + , runProgramInvocation + ) import Distribution.Simple.Setup.Config - ( configUseResponseFiles ) + ( configUseResponseFiles + ) import Distribution.Simple.Utils - ( defaultTempFileOptions, dieWithLocation', withTempDirectory ) + ( defaultTempFileOptions + , dieWithLocation' + , withTempDirectory + ) import Distribution.System - ( Arch(..), OS(..), Platform(..) ) + ( Arch (..) + , OS (..) + , Platform (..) + ) import Distribution.Verbosity - ( Verbosity, deafening, verbose ) + ( Verbosity + , deafening + , verbose + ) import System.Directory (doesFileExist, renameFile) -import System.FilePath ((), splitFileName) +import System.FilePath (splitFileName, ()) import System.IO - ( Handle, IOMode(ReadWriteMode), SeekMode(AbsoluteSeek) - , hFileSize, hSeek, withBinaryFile ) + ( Handle + , IOMode (ReadWriteMode) + , SeekMode (AbsoluteSeek) + , hFileSize + , hSeek + , withBinaryFile + ) -- | Call @ar@ to create a library archive from a bunch of object files. --- -createArLibArchive :: Verbosity -> LocalBuildInfo - -> FilePath -> [FilePath] -> IO () +createArLibArchive + :: Verbosity + -> LocalBuildInfo + -> FilePath + -> [FilePath] + -> IO () createArLibArchive verbosity lbi targetPath files = do (ar, _) <- requireProgram verbosity arProgram progDb let (targetDir, targetName) = splitFileName targetPath - withTempDirectory verbosity targetDir "objs" $ \ tmpDir -> do - let tmpPath = tmpDir targetName - - -- The args to use with "ar" are actually rather subtle and system-dependent. - -- In particular we have the following issues: - -- - -- -- On OS X, "ar q" does not make an archive index. Archives with no - -- index cannot be used. - -- - -- -- GNU "ar r" will not let us add duplicate objects, only "ar q" lets us - -- do that. We have duplicates because of modules like "A.M" and "B.M" - -- both make an object file "M.o" and ar does not consider the directory. - -- - -- -- llvm-ar, which GHC >=9.4 uses on Windows, supports a "L" modifier - -- in "q" mode which compels the archiver to add the members of an input - -- archive to the output, rather than the archive itself. This is - -- necessary as GHC may produce .o files that are actually archives. See - -- https://gitlab.haskell.org/ghc/ghc/-/issues/21068. - -- - -- Our solution is to use "ar r" in the simple case when one call is enough. - -- When we need to call ar multiple times we use "ar q" and for the last - -- call on OSX we use "ar qs" so that it'll make the index. - - let simpleArgs = case hostOS of - OSX -> ["-r", "-s"] - _ | dashLSupported -> ["-qL"] - _ -> ["-r"] - - initialArgs = ["-q"] - finalArgs = case hostOS of - OSX -> ["-q", "-s"] - _ | dashLSupported -> ["-qL"] - _ -> ["-q"] - - extraArgs = verbosityOpts verbosity ++ [tmpPath] - - simple = programInvocation ar (simpleArgs ++ extraArgs) - initial = programInvocation ar (initialArgs ++ extraArgs) - middle = initial - final = programInvocation ar (finalArgs ++ extraArgs) - - oldVersionManualOverride = - fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi - responseArgumentsNotSupported = - not (arResponseFilesSupported (compiler lbi)) - dashLSupported = - arDashLSupported (compiler lbi) - - invokeWithResponesFile :: FilePath -> ProgramInvocation - invokeWithResponesFile atFile = - programInvocation ar $ - simpleArgs ++ extraArgs ++ ['@' : atFile] - - if oldVersionManualOverride || responseArgumentsNotSupported - then - sequence_ - [ runProgramInvocation verbosity inv - | inv <- multiStageProgramInvocation - simple (initial, middle, final) files ] - else - withResponseFile verbosity defaultTempFileOptions tmpDir "ar.rsp" Nothing files $ + withTempDirectory verbosity targetDir "objs" $ \tmpDir -> do + let tmpPath = tmpDir targetName + + -- The args to use with "ar" are actually rather subtle and system-dependent. + -- In particular we have the following issues: + -- + -- -- On OS X, "ar q" does not make an archive index. Archives with no + -- index cannot be used. + -- + -- -- GNU "ar r" will not let us add duplicate objects, only "ar q" lets us + -- do that. We have duplicates because of modules like "A.M" and "B.M" + -- both make an object file "M.o" and ar does not consider the directory. + -- + -- -- llvm-ar, which GHC >=9.4 uses on Windows, supports a "L" modifier + -- in "q" mode which compels the archiver to add the members of an input + -- archive to the output, rather than the archive itself. This is + -- necessary as GHC may produce .o files that are actually archives. See + -- https://gitlab.haskell.org/ghc/ghc/-/issues/21068. + -- + -- Our solution is to use "ar r" in the simple case when one call is enough. + -- When we need to call ar multiple times we use "ar q" and for the last + -- call on OSX we use "ar qs" so that it'll make the index. + + let simpleArgs = case hostOS of + OSX -> ["-r", "-s"] + _ | dashLSupported -> ["-qL"] + _ -> ["-r"] + + initialArgs = ["-q"] + finalArgs = case hostOS of + OSX -> ["-q", "-s"] + _ | dashLSupported -> ["-qL"] + _ -> ["-q"] + + extraArgs = verbosityOpts verbosity ++ [tmpPath] + + simple = programInvocation ar (simpleArgs ++ extraArgs) + initial = programInvocation ar (initialArgs ++ extraArgs) + middle = initial + final = programInvocation ar (finalArgs ++ extraArgs) + + oldVersionManualOverride = + fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi + responseArgumentsNotSupported = + not (arResponseFilesSupported (compiler lbi)) + dashLSupported = + arDashLSupported (compiler lbi) + + invokeWithResponesFile :: FilePath -> ProgramInvocation + invokeWithResponesFile atFile = + programInvocation ar $ + simpleArgs ++ extraArgs ++ ['@' : atFile] + + if oldVersionManualOverride || responseArgumentsNotSupported + then + sequence_ + [ runProgramInvocation verbosity inv + | inv <- + multiStageProgramInvocation + simple + (initial, middle, final) + files + ] + else withResponseFile verbosity defaultTempFileOptions tmpDir "ar.rsp" Nothing files $ \path -> runProgramInvocation verbosity $ invokeWithResponesFile path - unless (hostArch == Arm -- See #1537 - || hostOS == AIX) $ -- AIX uses its own "ar" format variant - wipeMetadata verbosity tmpPath - equal <- filesEqual tmpPath targetPath - unless equal $ renameFile tmpPath targetPath - + unless + ( hostArch == Arm -- See #1537 + || hostOS == AIX + ) + $ wipeMetadata verbosity tmpPath -- AIX uses its own "ar" format variant + equal <- filesEqual tmpPath targetPath + unless equal $ renameFile tmpPath targetPath where progDb = withPrograms lbi Platform hostArch hostOS = hostPlatform lbi verbosityOpts v | v >= deafening = ["-v"] - | v >= verbose = [] - | otherwise = ["-c"] -- Do not warn if library had to be created. + | v >= verbose = [] + | otherwise = ["-c"] -- Do not warn if library had to be created. -- | @ar@ by default includes various metadata for each object file in their -- respective headers, so the output can differ for the same inputs, making @@ -142,17 +171,18 @@ createArLibArchive verbosity lbi targetPath files = do -- rather harder than just re-implementing this feature. wipeMetadata :: Verbosity -> FilePath -> IO () wipeMetadata verbosity path = do - -- Check for existence first (ReadWriteMode would create one otherwise) - exists <- doesFileExist path - unless exists $ wipeError "Temporary file disappeared" - withBinaryFile path ReadWriteMode $ \ h -> hFileSize h >>= wipeArchive h - + -- Check for existence first (ReadWriteMode would create one otherwise) + exists <- doesFileExist path + unless exists $ wipeError "Temporary file disappeared" + withBinaryFile path ReadWriteMode $ \h -> hFileSize h >>= wipeArchive h where - wipeError msg = dieWithLocation' verbosity path Nothing $ + wipeError msg = + dieWithLocation' verbosity path Nothing $ "Distribution.Simple.Program.Ar.wipeMetadata: " ++ msg archLF = "!\x0a" -- global magic, 8 bytes x60LF = "\x60\x0a" -- header magic, 2 bytes - metadata = BS.concat + metadata = + BS.concat [ "0 " -- mtime, 12 bytes , "0 " -- UID, 6 bytes , "0 " -- GID, 6 bytes @@ -164,40 +194,41 @@ wipeMetadata verbosity path = do -- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details wipeArchive :: Handle -> Integer -> IO () wipeArchive h archiveSize = do - global <- BS.hGet h (BS.length archLF) - unless (global == archLF) $ wipeError "Bad global header" - wipeHeader (toInteger $ BS.length archLF) - + global <- BS.hGet h (BS.length archLF) + unless (global == archLF) $ wipeError "Bad global header" + wipeHeader (toInteger $ BS.length archLF) where wipeHeader :: Integer -> IO () wipeHeader offset = case compare offset archiveSize of - EQ -> return () - GT -> wipeError (atOffset "Archive truncated") - LT -> do - header <- BS.hGet h headerSize - unless (BS.length header == headerSize) $ - wipeError (atOffset "Short header") - let magic = BS.drop 58 header - unless (magic == x60LF) . wipeError . atOffset $ - "Bad magic " ++ show magic ++ " in header" - - let name = BS.take 16 header - let size = BS.take 10 $ BS.drop 48 header - objSize <- case reads (BS8.unpack size) of - [(n, s)] | all isSpace s -> return n - _ -> wipeError (atOffset "Bad file size in header") - - let replacement = BS.concat [ name, metadata, size, magic ] - unless (BS.length replacement == headerSize) $ - wipeError (atOffset "Something has gone terribly wrong") - hSeek h AbsoluteSeek offset - BS.hPut h replacement - - let nextHeader = offset + toInteger headerSize + - -- Odd objects are padded with an extra '\x0a' - if odd objSize then objSize + 1 else objSize - hSeek h AbsoluteSeek nextHeader - wipeHeader nextHeader - + EQ -> return () + GT -> wipeError (atOffset "Archive truncated") + LT -> do + header <- BS.hGet h headerSize + unless (BS.length header == headerSize) $ + wipeError (atOffset "Short header") + let magic = BS.drop 58 header + unless (magic == x60LF) . wipeError . atOffset $ + "Bad magic " ++ show magic ++ " in header" + + let name = BS.take 16 header + let size = BS.take 10 $ BS.drop 48 header + objSize <- case reads (BS8.unpack size) of + [(n, s)] | all isSpace s -> return n + _ -> wipeError (atOffset "Bad file size in header") + + let replacement = BS.concat [name, metadata, size, magic] + unless (BS.length replacement == headerSize) $ + wipeError (atOffset "Something has gone terribly wrong") + hSeek h AbsoluteSeek offset + BS.hPut h replacement + + let nextHeader = + offset + + toInteger headerSize + + + -- Odd objects are padded with an extra '\x0a' + if odd objSize then objSize + 1 else objSize + hSeek h AbsoluteSeek nextHeader + wipeHeader nextHeader where atOffset msg = msg ++ " at offset " ++ show offset diff --git a/Cabal/src/Distribution/Simple/Program/Builtin.hs b/Cabal/src/Distribution/Simple/Program/Builtin.hs index 5c615fd5f51..909ecc7e4b6 100644 --- a/Cabal/src/Distribution/Simple/Program/Builtin.hs +++ b/Cabal/src/Distribution/Simple/Program/Builtin.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Builtin -- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 @@ -9,47 +10,45 @@ -- The module defines all the known built-in 'Program's. -- -- Where possible we try to find their version numbers. --- -module Distribution.Simple.Program.Builtin ( - - -- * The collection of unconfigured and configured programs - builtinPrograms, +module Distribution.Simple.Program.Builtin + ( -- * The collection of unconfigured and configured programs + builtinPrograms -- * Programs that Cabal knows about - ghcProgram, - ghcPkgProgram, - runghcProgram, - ghcjsProgram, - ghcjsPkgProgram, - hmakeProgram, - jhcProgram, - haskellSuiteProgram, - haskellSuitePkgProgram, - uhcProgram, - gccProgram, - arProgram, - stripProgram, - happyProgram, - alexProgram, - hsc2hsProgram, - c2hsProgram, - cpphsProgram, - hscolourProgram, - doctestProgram, - haddockProgram, - greencardProgram, - ldProgram, - tarProgram, - cppProgram, - pkgConfigProgram, - hpcProgram, + , ghcProgram + , ghcPkgProgram + , runghcProgram + , ghcjsProgram + , ghcjsPkgProgram + , hmakeProgram + , jhcProgram + , haskellSuiteProgram + , haskellSuitePkgProgram + , uhcProgram + , gccProgram + , arProgram + , stripProgram + , happyProgram + , alexProgram + , hsc2hsProgram + , c2hsProgram + , cpphsProgram + , hscolourProgram + , doctestProgram + , haddockProgram + , greencardProgram + , ldProgram + , tarProgram + , cppProgram + , pkgConfigProgram + , hpcProgram ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Simple.Program.GHC import Distribution.Simple.Program.Find +import Distribution.Simple.Program.GHC import Distribution.Simple.Program.Internal import Distribution.Simple.Program.Run import Distribution.Simple.Program.Types @@ -60,137 +59,153 @@ import Distribution.Version import qualified Data.Map as Map -- ------------------------------------------------------------ + -- * Known programs + -- ------------------------------------------------------------ -- | The default list of programs. -- These programs are typically used internally to Cabal. builtinPrograms :: [Program] builtinPrograms = - [ - -- compilers and related progs - ghcProgram - , runghcProgram - , ghcPkgProgram - , ghcjsProgram - , ghcjsPkgProgram - , haskellSuiteProgram - , haskellSuitePkgProgram - , hmakeProgram - , jhcProgram - , uhcProgram - , hpcProgram - -- preprocessors - , hscolourProgram - , doctestProgram - , haddockProgram - , happyProgram - , alexProgram - , hsc2hsProgram - , c2hsProgram - , cpphsProgram - , greencardProgram - -- platform toolchain - , gccProgram - , arProgram - , stripProgram - , ldProgram - , tarProgram - -- configuration tools - , pkgConfigProgram - ] + [ -- compilers and related progs + ghcProgram + , runghcProgram + , ghcPkgProgram + , ghcjsProgram + , ghcjsPkgProgram + , haskellSuiteProgram + , haskellSuitePkgProgram + , hmakeProgram + , jhcProgram + , uhcProgram + , hpcProgram + , -- preprocessors + hscolourProgram + , doctestProgram + , haddockProgram + , happyProgram + , alexProgram + , hsc2hsProgram + , c2hsProgram + , cpphsProgram + , greencardProgram + , -- platform toolchain + gccProgram + , arProgram + , stripProgram + , ldProgram + , tarProgram + , -- configuration tools + pkgConfigProgram + ] ghcProgram :: Program -ghcProgram = (simpleProgram "ghc") { - programFindVersion = findProgramVersion "--numeric-version" id, - - -- Workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/8825 - -- (spurious warning on non-english locales) - programPostConf = \_verbosity ghcProg -> - do let ghcProg' = ghcProg { - programOverrideEnv = ("LANGUAGE", Just "en") - : programOverrideEnv ghcProg - } - -- Only the 7.8 branch seems to be affected. Fixed in 7.8.4. - affectedVersionRange = intersectVersionRanges - (laterVersion $ mkVersion [7,8,0]) - (earlierVersion $ mkVersion [7,8,4]) - return $ maybe ghcProg - (\v -> if withinRange v affectedVersionRange - then ghcProg' else ghcProg) - (programVersion ghcProg), - - programNormaliseArgs = normaliseGhcArgs - } +ghcProgram = + (simpleProgram "ghc") + { programFindVersion = findProgramVersion "--numeric-version" id + , -- Workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/8825 + -- (spurious warning on non-english locales) + programPostConf = \_verbosity ghcProg -> + do + let ghcProg' = + ghcProg + { programOverrideEnv = + ("LANGUAGE", Just "en") + : programOverrideEnv ghcProg + } + -- Only the 7.8 branch seems to be affected. Fixed in 7.8.4. + affectedVersionRange = + intersectVersionRanges + (laterVersion $ mkVersion [7, 8, 0]) + (earlierVersion $ mkVersion [7, 8, 4]) + return $ + maybe + ghcProg + ( \v -> + if withinRange v affectedVersionRange + then ghcProg' + else ghcProg + ) + (programVersion ghcProg) + , programNormaliseArgs = normaliseGhcArgs + } runghcProgram :: Program -runghcProgram = (simpleProgram "runghc") { - programFindVersion = findProgramVersion "--version" $ \str -> - case words str of - -- "runghc 7.10.3" - (_:ver:_) -> ver - _ -> "" - } +runghcProgram = + (simpleProgram "runghc") + { programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- "runghc 7.10.3" + (_ : ver : _) -> ver + _ -> "" + } ghcPkgProgram :: Program -ghcPkgProgram = (simpleProgram "ghc-pkg") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "ghc-pkg --version" gives a string like - -- "GHC package manager version 6.4.1" - case words str of - (_:_:_:_:ver:_) -> ver - _ -> "" - } +ghcPkgProgram = + (simpleProgram "ghc-pkg") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "ghc-pkg --version" gives a string like + -- "GHC package manager version 6.4.1" + case words str of + (_ : _ : _ : _ : ver : _) -> ver + _ -> "" + } ghcjsProgram :: Program -ghcjsProgram = (simpleProgram "ghcjs") { - programFindVersion = findProgramVersion "--numeric-ghcjs-version" id - } +ghcjsProgram = + (simpleProgram "ghcjs") + { programFindVersion = findProgramVersion "--numeric-ghcjs-version" id + } -- note: version is the version number of the GHC version that ghcjs-pkg was built with ghcjsPkgProgram :: Program -ghcjsPkgProgram = (simpleProgram "ghcjs-pkg") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "ghcjs-pkg --version" gives a string like - -- "GHCJS package manager version 6.4.1" - case words str of - (_:_:_:_:ver:_) -> ver - _ -> "" - } +ghcjsPkgProgram = + (simpleProgram "ghcjs-pkg") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "ghcjs-pkg --version" gives a string like + -- "GHCJS package manager version 6.4.1" + case words str of + (_ : _ : _ : _ : ver : _) -> ver + _ -> "" + } hmakeProgram :: Program -hmakeProgram = (simpleProgram "hmake") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "hmake --version" gives a string line - -- "/usr/local/bin/hmake: 3.13 (2006-11-01)" - case words str of - (_:ver:_) -> ver - _ -> "" - } +hmakeProgram = + (simpleProgram "hmake") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "hmake --version" gives a string line + -- "/usr/local/bin/hmake: 3.13 (2006-11-01)" + case words str of + (_ : ver : _) -> ver + _ -> "" + } jhcProgram :: Program -jhcProgram = (simpleProgram "jhc") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- invoking "jhc --version" gives a string like - -- "jhc 0.3.20080208 (wubgipkamcep-2) - -- compiled by ghc-6.8 on a x86_64 running linux" - case words str of - (_:ver:_) -> ver - _ -> "" - } +jhcProgram = + (simpleProgram "jhc") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- invoking "jhc --version" gives a string like + -- "jhc 0.3.20080208 (wubgipkamcep-2) + -- compiled by ghc-6.8 on a x86_64 running linux" + case words str of + (_ : ver : _) -> ver + _ -> "" + } uhcProgram :: Program -uhcProgram = (simpleProgram "uhc") { - programFindVersion = findProgramVersion "--version-dotted" id - } +uhcProgram = + (simpleProgram "uhc") + { programFindVersion = findProgramVersion "--version-dotted" id + } hpcProgram :: Program -hpcProgram = (simpleProgram "hpc") - { - programFindVersion = findProgramVersion "version" $ \str -> - case words str of - (_ : _ : _ : ver : _) -> ver - _ -> "" +hpcProgram = + (simpleProgram "hpc") + { programFindVersion = findProgramVersion "version" $ \str -> + case words str of + (_ : _ : _ : ver : _) -> ver + _ -> "" } -- This represents a haskell-suite compiler. Of course, the compiler @@ -210,113 +225,123 @@ hpcProgram = (simpleProgram "hpc") -- The path to the real compiler is found and recorded in the ProgramDb -- during the configure phase. haskellSuiteProgram :: Program -haskellSuiteProgram = (simpleProgram "haskell-suite") { - -- pretend that the program exists, otherwise it won't be in the - -- "configured" state - programFindLocation = \_verbosity _searchPath -> - return $ Just ("haskell-suite-dummy-location", []) - } +haskellSuiteProgram = + (simpleProgram "haskell-suite") + { -- pretend that the program exists, otherwise it won't be in the + -- "configured" state + programFindLocation = \_verbosity _searchPath -> + return $ Just ("haskell-suite-dummy-location", []) + } -- This represent a haskell-suite package manager. See the comments for -- haskellSuiteProgram. haskellSuitePkgProgram :: Program -haskellSuitePkgProgram = (simpleProgram "haskell-suite-pkg") { - programFindLocation = \_verbosity _searchPath -> - return $ Just ("haskell-suite-pkg-dummy-location", []) - } - +haskellSuitePkgProgram = + (simpleProgram "haskell-suite-pkg") + { programFindLocation = \_verbosity _searchPath -> + return $ Just ("haskell-suite-pkg-dummy-location", []) + } happyProgram :: Program -happyProgram = (simpleProgram "happy") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "happy --version" gives a string like - -- "Happy Version 1.16 Copyright (c) ...." - case words str of - (_:_:ver:_) -> ver - _ -> "" - } +happyProgram = + (simpleProgram "happy") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "happy --version" gives a string like + -- "Happy Version 1.16 Copyright (c) ...." + case words str of + (_ : _ : ver : _) -> ver + _ -> "" + } alexProgram :: Program -alexProgram = (simpleProgram "alex") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "alex --version" gives a string like - -- "Alex version 2.1.0, (c) 2003 Chris Dornan and Simon Marlow" - case words str of - (_:_:ver:_) -> takeWhile (\x -> isDigit x || x == '.') ver - _ -> "" - } +alexProgram = + (simpleProgram "alex") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "alex --version" gives a string like + -- "Alex version 2.1.0, (c) 2003 Chris Dornan and Simon Marlow" + case words str of + (_ : _ : ver : _) -> takeWhile (\x -> isDigit x || x == '.') ver + _ -> "" + } gccProgram :: Program -gccProgram = (simpleProgram "gcc") { - programFindVersion = findProgramVersion "-dumpversion" id - } +gccProgram = + (simpleProgram "gcc") + { programFindVersion = findProgramVersion "-dumpversion" id + } arProgram :: Program arProgram = simpleProgram "ar" stripProgram :: Program -stripProgram = (simpleProgram "strip") { - programFindVersion = \verbosity -> - findProgramVersion "--version" stripExtractVersion (lessVerbose verbosity) - } +stripProgram = + (simpleProgram "strip") + { programFindVersion = \verbosity -> + findProgramVersion "--version" stripExtractVersion (lessVerbose verbosity) + } hsc2hsProgram :: Program -hsc2hsProgram = (simpleProgram "hsc2hs") { - programFindVersion = - findProgramVersion "--version" $ \str -> - -- Invoking "hsc2hs --version" gives a string like "hsc2hs version 0.66" - case words str of - (_:_:ver:_) -> ver - _ -> "" - } +hsc2hsProgram = + (simpleProgram "hsc2hs") + { programFindVersion = + findProgramVersion "--version" $ \str -> + -- Invoking "hsc2hs --version" gives a string like "hsc2hs version 0.66" + case words str of + (_ : _ : ver : _) -> ver + _ -> "" + } c2hsProgram :: Program -c2hsProgram = (simpleProgram "c2hs") { - programFindVersion = findProgramVersion "--numeric-version" id - } +c2hsProgram = + (simpleProgram "c2hs") + { programFindVersion = findProgramVersion "--numeric-version" id + } cpphsProgram :: Program -cpphsProgram = (simpleProgram "cpphs") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "cpphs --version" gives a string like "cpphs 1.3" - case words str of - (_:ver:_) -> ver - _ -> "" - } +cpphsProgram = + (simpleProgram "cpphs") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "cpphs --version" gives a string like "cpphs 1.3" + case words str of + (_ : ver : _) -> ver + _ -> "" + } hscolourProgram :: Program -hscolourProgram = (simpleProgram "hscolour") { - programFindLocation = \v p -> findProgramOnSearchPath v p "HsColour", - programFindVersion = findProgramVersion "-version" $ \str -> - -- Invoking "HsColour -version" gives a string like "HsColour 1.7" - case words str of - (_:ver:_) -> ver - _ -> "" - } +hscolourProgram = + (simpleProgram "hscolour") + { programFindLocation = \v p -> findProgramOnSearchPath v p "HsColour" + , programFindVersion = findProgramVersion "-version" $ \str -> + -- Invoking "HsColour -version" gives a string like "HsColour 1.7" + case words str of + (_ : ver : _) -> ver + _ -> "" + } -- TODO: Ensure that doctest is built against the same GHC as the one -- that's being used. Same for haddock. @phadej pointed this out. doctestProgram :: Program -doctestProgram = (simpleProgram "doctest") { - programFindLocation = \v p -> findProgramOnSearchPath v p "doctest" - , programFindVersion = findProgramVersion "--version" $ \str -> - -- "doctest version 0.11.2" - case words str of - (_:_:ver:_) -> ver - _ -> "" - } +doctestProgram = + (simpleProgram "doctest") + { programFindLocation = \v p -> findProgramOnSearchPath v p "doctest" + , programFindVersion = findProgramVersion "--version" $ \str -> + -- "doctest version 0.11.2" + case words str of + (_ : _ : ver : _) -> ver + _ -> "" + } haddockProgram :: Program -haddockProgram = (simpleProgram "haddock") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "haddock --version" gives a string like - -- "Haddock version 0.8, (c) Simon Marlow 2006" - case words str of - (_:_:ver:_) -> takeWhile (`elem` ('.':['0'..'9'])) ver - _ -> "", - - programNormaliseArgs = \_ _ args -> args - } +haddockProgram = + (simpleProgram "haddock") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "haddock --version" gives a string like + -- "Haddock version 0.8, (c) Simon Marlow 2006" + case words str of + (_ : _ : ver : _) -> takeWhile (`elem` ('.' : ['0' .. '9'])) ver + _ -> "" + , programNormaliseArgs = \_ _ args -> args + } greencardProgram :: Program greencardProgram = simpleProgram "greencard" @@ -325,24 +350,28 @@ ldProgram :: Program ldProgram = simpleProgram "ld" tarProgram :: Program -tarProgram = (simpleProgram "tar") { - -- See #1901. Some versions of 'tar' (OpenBSD, NetBSD, ...) don't support the - -- '--format' option. - programPostConf = \verbosity tarProg -> do - tarHelpOutput <- getProgramInvocationOutput - verbosity (programInvocation tarProg ["--help"]) - -- Some versions of tar don't support '--help'. - `catchIO` (\_ -> return "") - let k = "Supports --format" - v = if ("--format" `isInfixOf` tarHelpOutput) then "YES" else "NO" - m = Map.insert k v (programProperties tarProg) - return $ tarProg { programProperties = m } - } +tarProgram = + (simpleProgram "tar") + { -- See #1901. Some versions of 'tar' (OpenBSD, NetBSD, ...) don't support the + -- '--format' option. + programPostConf = \verbosity tarProg -> do + tarHelpOutput <- + getProgramInvocationOutput + verbosity + (programInvocation tarProg ["--help"]) + -- Some versions of tar don't support '--help'. + `catchIO` (\_ -> return "") + let k = "Supports --format" + v = if ("--format" `isInfixOf` tarHelpOutput) then "YES" else "NO" + m = Map.insert k v (programProperties tarProg) + return $ tarProg{programProperties = m} + } cppProgram :: Program cppProgram = simpleProgram "cpp" pkgConfigProgram :: Program -pkgConfigProgram = (simpleProgram "pkg-config") { - programFindVersion = findProgramVersion "--version" id - } +pkgConfigProgram = + (simpleProgram "pkg-config") + { programFindVersion = findProgramVersion "--version" id + } diff --git a/Cabal/src/Distribution/Simple/Program/Db.hs b/Cabal/src/Distribution/Simple/Program/Db.hs index 4657e19b059..7e151bc06e2 100644 --- a/Cabal/src/Distribution/Simple/Program/Db.hs +++ b/Cabal/src/Distribution/Simple/Program/Db.hs @@ -1,8 +1,9 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Db -- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 @@ -23,42 +24,40 @@ -- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a -- hook user the ability to get the above flags and such so that they -- don't have to write all the PATH logic inside Setup.lhs. - -module Distribution.Simple.Program.Db ( - -- * The collection of configured programs we can run - ProgramDb, - emptyProgramDb, - defaultProgramDb, - restoreProgramDb, +module Distribution.Simple.Program.Db + ( -- * The collection of configured programs we can run + ProgramDb + , emptyProgramDb + , defaultProgramDb + , restoreProgramDb -- ** Query and manipulate the program db - addKnownProgram, - addKnownPrograms, - lookupKnownProgram, - knownPrograms, - getProgramSearchPath, - setProgramSearchPath, - modifyProgramSearchPath, - userSpecifyPath, - userSpecifyPaths, - userMaybeSpecifyPath, - userSpecifyArgs, - userSpecifyArgss, - userSpecifiedArgs, - lookupProgram, - updateProgram, - configuredPrograms, + , addKnownProgram + , addKnownPrograms + , lookupKnownProgram + , knownPrograms + , getProgramSearchPath + , setProgramSearchPath + , modifyProgramSearchPath + , userSpecifyPath + , userSpecifyPaths + , userMaybeSpecifyPath + , userSpecifyArgs + , userSpecifyArgss + , userSpecifiedArgs + , lookupProgram + , updateProgram + , configuredPrograms -- ** Query and manipulate the program db - configureProgram, - configureAllKnownPrograms, - unconfigureProgram, - lookupProgramVersion, - reconfigurePrograms, - requireProgram, - requireProgramVersion, - needProgram, - + , configureProgram + , configureAllKnownPrograms + , unconfigureProgram + , lookupProgramVersion + , reconfigurePrograms + , requireProgram + , requireProgramVersion + , needProgram ) where import Distribution.Compat.Prelude @@ -69,7 +68,7 @@ import Distribution.Simple.Program.Builtin import Distribution.Simple.Program.Find import Distribution.Simple.Program.Types import Distribution.Simple.Utils -import Distribution.Utils.Structured (Structure (..), Structured (..)) +import Distribution.Utils.Structured (Structure (..), Structured (..)) import Distribution.Verbosity import Distribution.Version @@ -78,7 +77,9 @@ import Data.Tuple (swap) import qualified Data.Map as Map -- ------------------------------------------------------------ + -- * Programs database + -- ------------------------------------------------------------ -- | The configuration is a collection of information about programs. It @@ -89,17 +90,16 @@ import qualified Data.Map as Map -- by one we try to configure them at which point we move them into the -- configured collection. For unconfigured programs we record not just the -- 'Program' but also any user-provided arguments and location for the program. -data ProgramDb = ProgramDb { - unconfiguredProgs :: UnconfiguredProgs, - progSearchPath :: ProgramSearchPath, - configuredProgs :: ConfiguredProgs - } +data ProgramDb = ProgramDb + { unconfiguredProgs :: UnconfiguredProgs + , progSearchPath :: ProgramSearchPath + , configuredProgs :: ConfiguredProgs + } deriving (Typeable) type UnconfiguredProgram = (Program, Maybe FilePath, [ProgArg]) -type UnconfiguredProgs = Map.Map String UnconfiguredProgram -type ConfiguredProgs = Map.Map String ConfiguredProgram - +type UnconfiguredProgs = Map.Map String UnconfiguredProgram +type ConfiguredProgs = Map.Map String ConfiguredProgram emptyProgramDb :: ProgramDb emptyProgramDb = ProgramDb Map.empty defaultProgramSearchPath Map.empty @@ -107,38 +107,38 @@ emptyProgramDb = ProgramDb Map.empty defaultProgramSearchPath Map.empty defaultProgramDb :: ProgramDb defaultProgramDb = restoreProgramDb builtinPrograms emptyProgramDb - -- internal helpers: -updateUnconfiguredProgs :: (UnconfiguredProgs -> UnconfiguredProgs) - -> ProgramDb -> ProgramDb +updateUnconfiguredProgs + :: (UnconfiguredProgs -> UnconfiguredProgs) + -> ProgramDb + -> ProgramDb updateUnconfiguredProgs update progdb = - progdb { unconfiguredProgs = update (unconfiguredProgs progdb) } + progdb{unconfiguredProgs = update (unconfiguredProgs progdb)} -updateConfiguredProgs :: (ConfiguredProgs -> ConfiguredProgs) - -> ProgramDb -> ProgramDb +updateConfiguredProgs + :: (ConfiguredProgs -> ConfiguredProgs) + -> ProgramDb + -> ProgramDb updateConfiguredProgs update progdb = - progdb { configuredProgs = update (configuredProgs progdb) } - + progdb{configuredProgs = update (configuredProgs progdb)} -- Read & Show instances are based on listToFM -- | Note that this instance does not preserve the known 'Program's. -- See 'restoreProgramDb' for details. --- instance Show ProgramDb where show = show . Map.toAscList . configuredProgs -- | Note that this instance does not preserve the known 'Program's. -- See 'restoreProgramDb' for details. --- instance Read ProgramDb where readsPrec p s = - [ (emptyProgramDb { configuredProgs = Map.fromList s' }, r) - | (s', r) <- readsPrec p s ] + [ (emptyProgramDb{configuredProgs = Map.fromList s'}, r) + | (s', r) <- readsPrec p s + ] -- | Note that this instance does not preserve the known 'Program's. -- See 'restoreProgramDb' for details. --- instance Binary ProgramDb where put db = do put (progSearchPath db) @@ -146,18 +146,22 @@ instance Binary ProgramDb where get = do searchpath <- get - progs <- get - return $! emptyProgramDb { - progSearchPath = searchpath, - configuredProgs = progs - } + progs <- get + return $! + emptyProgramDb + { progSearchPath = searchpath + , configuredProgs = progs + } instance Structured ProgramDb where - structure p = Nominal (typeRep p) 0 "ProgramDb" - [ structure (Proxy :: Proxy ProgramSearchPath) - , structure (Proxy :: Proxy ConfiguredProgs) - ] - + structure p = + Nominal + (typeRep p) + 0 + "ProgramDb" + [ structure (Proxy :: Proxy ProgramSearchPath) + , structure (Proxy :: Proxy ConfiguredProgs) + ] -- | The 'Read'\/'Show' and 'Binary' instances do not preserve all the -- unconfigured 'Programs' because 'Program' is not in 'Read'\/'Show' because @@ -166,127 +170,129 @@ instance Structured ProgramDb where -- -- * It does not add the default programs, but you probably want them, use -- 'builtinPrograms' in addition to any extra you might need. --- restoreProgramDb :: [Program] -> ProgramDb -> ProgramDb restoreProgramDb = addKnownPrograms - -- ------------------------------- -- Managing unconfigured programs -- | Add a known program that we may configure later --- addKnownProgram :: Program -> ProgramDb -> ProgramDb -addKnownProgram prog = updateUnconfiguredProgs $ - Map.insertWith combine (programName prog) (prog, Nothing, []) - where combine _ (_, path, args) = (prog, path, args) - +addKnownProgram prog = + updateUnconfiguredProgs $ + Map.insertWith combine (programName prog) (prog, Nothing, []) + where + combine _ (_, path, args) = (prog, path, args) addKnownPrograms :: [Program] -> ProgramDb -> ProgramDb addKnownPrograms progs progdb = foldl' (flip addKnownProgram) progdb progs - lookupKnownProgram :: String -> ProgramDb -> Maybe Program lookupKnownProgram name = - fmap (\(p,_,_)->p) . Map.lookup name . unconfiguredProgs - + fmap (\(p, _, _) -> p) . Map.lookup name . unconfiguredProgs knownPrograms :: ProgramDb -> [(Program, Maybe ConfiguredProgram)] knownPrograms progdb = - [ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs progdb) - , let p' = Map.lookup (programName p) (configuredProgs progdb) ] + [ (p, p') | (p, _, _) <- Map.elems (unconfiguredProgs progdb), let p' = Map.lookup (programName p) (configuredProgs progdb) + ] -- | Get the current 'ProgramSearchPath' used by the 'ProgramDb'. -- This is the default list of locations where programs are looked for when -- configuring them. This can be overridden for specific programs (with -- 'userSpecifyPath'), and specific known programs can modify or ignore this -- search path in their own configuration code. --- getProgramSearchPath :: ProgramDb -> ProgramSearchPath getProgramSearchPath = progSearchPath -- | Change the current 'ProgramSearchPath' used by the 'ProgramDb'. -- This will affect programs that are configured from here on, so you -- should usually set it before configuring any programs. --- setProgramSearchPath :: ProgramSearchPath -> ProgramDb -> ProgramDb -setProgramSearchPath searchpath db = db { progSearchPath = searchpath } +setProgramSearchPath searchpath db = db{progSearchPath = searchpath} -- | Modify the current 'ProgramSearchPath' used by the 'ProgramDb'. -- This will affect programs that are configured from here on, so you -- should usually modify it before configuring any programs. --- -modifyProgramSearchPath :: (ProgramSearchPath -> ProgramSearchPath) - -> ProgramDb - -> ProgramDb +modifyProgramSearchPath + :: (ProgramSearchPath -> ProgramSearchPath) + -> ProgramDb + -> ProgramDb modifyProgramSearchPath f db = setProgramSearchPath (f $ getProgramSearchPath db) db --- |User-specify this path. Basically override any path information --- for this program in the configuration. If it's not a known --- program ignore it. --- -userSpecifyPath :: String -- ^Program name - -> FilePath -- ^user-specified path to the program - -> ProgramDb -> ProgramDb +-- | User-specify this path. Basically override any path information +-- for this program in the configuration. If it's not a known +-- program ignore it. +userSpecifyPath + :: String + -- ^ Program name + -> FilePath + -- ^ user-specified path to the program + -> ProgramDb + -> ProgramDb userSpecifyPath name path = updateUnconfiguredProgs $ - flip Map.update name $ \(prog, _, args) -> Just (prog, Just path, args) - - -userMaybeSpecifyPath :: String -> Maybe FilePath - -> ProgramDb -> ProgramDb -userMaybeSpecifyPath _ Nothing progdb = progdb + flip Map.update name $ + \(prog, _, args) -> Just (prog, Just path, args) + +userMaybeSpecifyPath + :: String + -> Maybe FilePath + -> ProgramDb + -> ProgramDb +userMaybeSpecifyPath _ Nothing progdb = progdb userMaybeSpecifyPath name (Just path) progdb = userSpecifyPath name path progdb - --- |User-specify the arguments for this program. Basically override --- any args information for this program in the configuration. If it's --- not a known program, ignore it.. -userSpecifyArgs :: String -- ^Program name - -> [ProgArg] -- ^user-specified args - -> ProgramDb - -> ProgramDb +-- | User-specify the arguments for this program. Basically override +-- any args information for this program in the configuration. If it's +-- not a known program, ignore it.. +userSpecifyArgs + :: String + -- ^ Program name + -> [ProgArg] + -- ^ user-specified args + -> ProgramDb + -> ProgramDb userSpecifyArgs name args' = - updateUnconfiguredProgs - (flip Map.update name $ - \(prog, path, args) -> Just (prog, path, args ++ args')) - . updateConfiguredProgs - (flip Map.update name $ - \prog -> Just prog { programOverrideArgs = programOverrideArgs prog - ++ args' }) - + updateUnconfiguredProgs + ( flip Map.update name $ + \(prog, path, args) -> Just (prog, path, args ++ args') + ) + . updateConfiguredProgs + ( flip Map.update name $ + \prog -> + Just + prog + { programOverrideArgs = + programOverrideArgs prog + ++ args' + } + ) -- | Like 'userSpecifyPath' but for a list of progs and their paths. --- -userSpecifyPaths :: [(String, FilePath)] - -> ProgramDb - -> ProgramDb +userSpecifyPaths + :: [(String, FilePath)] + -> ProgramDb + -> ProgramDb userSpecifyPaths paths progdb = foldl' (\progdb' (prog, path) -> userSpecifyPath prog path progdb') progdb paths - -- | Like 'userSpecifyPath' but for a list of progs and their args. --- -userSpecifyArgss :: [(String, [ProgArg])] - -> ProgramDb - -> ProgramDb +userSpecifyArgss + :: [(String, [ProgArg])] + -> ProgramDb + -> ProgramDb userSpecifyArgss argss progdb = foldl' (\progdb' (prog, args) -> userSpecifyArgs prog args progdb') progdb argss - -- | Get the path that has been previously specified for a program, if any. --- userSpecifiedPath :: Program -> ProgramDb -> Maybe FilePath userSpecifiedPath prog = - join . fmap (\(_,p,_)->p) . Map.lookup (programName prog) . unconfiguredProgs - + join . fmap (\(_, p, _) -> p) . Map.lookup (programName prog) . unconfiguredProgs -- | Get any extra args that have been previously specified for a program. --- userSpecifiedArgs :: Program -> ProgramDb -> [ProgArg] userSpecifiedArgs prog = - maybe [] (\(_,_,as)->as) . Map.lookup (programName prog) . unconfiguredProgs - + maybe [] (\(_, _, as) -> as) . Map.lookup (programName prog) . unconfiguredProgs -- ----------------------------- -- Managing configured programs @@ -295,13 +301,14 @@ userSpecifiedArgs prog = lookupProgram :: Program -> ProgramDb -> Maybe ConfiguredProgram lookupProgram prog = Map.lookup (programName prog) . configuredProgs - -- | Update a configured program in the database. -updateProgram :: ConfiguredProgram -> ProgramDb - -> ProgramDb -updateProgram prog = updateConfiguredProgs $ - Map.insert (programId prog) prog - +updateProgram + :: ConfiguredProgram + -> ProgramDb + -> ProgramDb +updateProgram prog = + updateConfiguredProgs $ + Map.insert (programId prog) prog -- | List all configured programs. configuredPrograms :: ProgramDb -> [ConfiguredProgram] @@ -323,57 +330,62 @@ configuredPrograms = Map.elems . configuredProgs -- front all the programs we will need, so we try to configure them all. -- To verify that a program was actually successfully configured use -- 'requireProgram'. --- -configureProgram :: Verbosity - -> Program - -> ProgramDb - -> IO ProgramDb +configureProgram + :: Verbosity + -> Program + -> ProgramDb + -> IO ProgramDb configureProgram verbosity prog progdb = do let name = programName prog maybeLocation <- case userSpecifiedPath prog progdb of - Nothing -> + Nothing -> programFindLocation prog verbosity (progSearchPath progdb) - >>= return . fmap (swap . fmap FoundOnSystem . swap) + >>= return . fmap (swap . fmap FoundOnSystem . swap) Just path -> do absolute <- doesExecutableExist path if absolute then return (Just (UserSpecified path, [])) - else findProgramOnSearchPath verbosity (progSearchPath progdb) path - >>= maybe (die' verbosity notFound) - (return . Just . swap . fmap UserSpecified . swap) - where notFound = "Cannot find the program '" ++ name - ++ "'. User-specified path '" - ++ path ++ "' does not refer to an executable and " - ++ "the program is not on the system path." + else + findProgramOnSearchPath verbosity (progSearchPath progdb) path + >>= maybe + (die' verbosity notFound) + (return . Just . swap . fmap UserSpecified . swap) + where + notFound = + "Cannot find the program '" + ++ name + ++ "'. User-specified path '" + ++ path + ++ "' does not refer to an executable and " + ++ "the program is not on the system path." case maybeLocation of Nothing -> return progdb Just (location, triedLocations) -> do version <- programFindVersion prog verbosity (locationPath location) newPath <- programSearchPathAsPATHVar (progSearchPath progdb) - let configuredProg = ConfiguredProgram { - programId = name, - programVersion = version, - programDefaultArgs = [], - programOverrideArgs = userSpecifiedArgs prog progdb, - programOverrideEnv = [("PATH", Just newPath)], - programProperties = Map.empty, - programLocation = location, - programMonitorFiles = triedLocations - } + let configuredProg = + ConfiguredProgram + { programId = name + , programVersion = version + , programDefaultArgs = [] + , programOverrideArgs = userSpecifiedArgs prog progdb + , programOverrideEnv = [("PATH", Just newPath)] + , programProperties = Map.empty + , programLocation = location + , programMonitorFiles = triedLocations + } configuredProg' <- programPostConf prog verbosity configuredProg return (updateConfiguredProgs (Map.insert name configuredProg') progdb) - -- | Configure a bunch of programs using 'configureProgram'. Just a 'foldM'. --- -configurePrograms :: Verbosity - -> [Program] - -> ProgramDb - -> IO ProgramDb +configurePrograms + :: Verbosity + -> [Program] + -> ProgramDb + -> IO ProgramDb configurePrograms verbosity progs progdb = foldM (flip (configureProgram verbosity)) progdb progs - -- | Unconfigure a program. This is basically a hack and you shouldn't -- use it, but it can be handy for making sure a 'requireProgram' -- actually reconfigures. @@ -382,49 +394,51 @@ unconfigureProgram progname = updateConfiguredProgs $ Map.delete progname -- | Try to configure all the known programs that have not yet been configured. --- -configureAllKnownPrograms :: Verbosity - -> ProgramDb - -> IO ProgramDb +configureAllKnownPrograms + :: Verbosity + -> ProgramDb + -> IO ProgramDb configureAllKnownPrograms verbosity progdb = - configurePrograms verbosity - [ prog | (prog,_,_) <- Map.elems notYetConfigured ] progdb + configurePrograms + verbosity + [prog | (prog, _, _) <- Map.elems notYetConfigured] + progdb where - notYetConfigured = unconfiguredProgs progdb - `Map.difference` configuredProgs progdb - + notYetConfigured = + unconfiguredProgs progdb + `Map.difference` configuredProgs progdb -- | reconfigure a bunch of programs given new user-specified args. It takes -- the same inputs as 'userSpecifyPath' and 'userSpecifyArgs' and for all progs -- with a new path it calls 'configureProgram'. --- -reconfigurePrograms :: Verbosity - -> [(String, FilePath)] - -> [(String, [ProgArg])] - -> ProgramDb - -> IO ProgramDb +reconfigurePrograms + :: Verbosity + -> [(String, FilePath)] + -> [(String, [ProgArg])] + -> ProgramDb + -> IO ProgramDb reconfigurePrograms verbosity paths argss progdb = do configurePrograms verbosity progs - . userSpecifyPaths paths - . userSpecifyArgss argss - $ progdb - + . userSpecifyPaths paths + . userSpecifyArgss argss + $ progdb where - progs = catMaybes [ lookupKnownProgram name progdb | (name,_) <- paths ] - + progs = catMaybes [lookupKnownProgram name progdb | (name, _) <- paths] -- | Check that a program is configured and available to be run. -- -- It raises an exception if the program could not be configured, otherwise -- it returns the configured program. --- -requireProgram :: Verbosity -> Program -> ProgramDb - -> IO (ConfiguredProgram, ProgramDb) +requireProgram + :: Verbosity + -> Program + -> ProgramDb + -> IO (ConfiguredProgram, ProgramDb) requireProgram verbosity prog progdb = do - mres <- needProgram verbosity prog progdb - case mres of - Nothing -> die' verbosity notFound - Just res -> return res + mres <- needProgram verbosity prog progdb + case mres of + Nothing -> die' verbosity notFound + Just res -> return res where notFound = "The program '" ++ programName prog ++ "' is required but it could not be found." @@ -434,17 +448,19 @@ requireProgram verbosity prog progdb = do -- or is not found. -- -- @since 3.0.1.0 -needProgram :: Verbosity -> Program -> ProgramDb - -> IO (Maybe (ConfiguredProgram, ProgramDb)) +needProgram + :: Verbosity + -> Program + -> ProgramDb + -> IO (Maybe (ConfiguredProgram, ProgramDb)) needProgram verbosity prog progdb = do - -- If it's not already been configured, try to configure it now progdb' <- case lookupProgram prog progdb of Nothing -> configureProgram verbosity prog progdb - Just _ -> return progdb + Just _ -> return progdb case lookupProgram prog progdb' of - Nothing -> return Nothing + Nothing -> return Nothing Just configuredProg -> return (Just (configuredProg, progdb')) -- | Check that a program is configured and available to be run. @@ -456,50 +472,66 @@ needProgram verbosity prog progdb = do -- It returns the configured program, its version number and a possibly updated -- 'ProgramDb'. If the program could not be configured or the version is -- unsuitable, it returns an error value. --- lookupProgramVersion - :: Verbosity -> Program -> VersionRange -> ProgramDb + :: Verbosity + -> Program + -> VersionRange + -> ProgramDb -> IO (Either String (ConfiguredProgram, Version, ProgramDb)) lookupProgramVersion verbosity prog range programDb = do - -- If it's not already been configured, try to configure it now programDb' <- case lookupProgram prog programDb of Nothing -> configureProgram verbosity prog programDb - Just _ -> return programDb + Just _ -> return programDb case lookupProgram prog programDb' of - Nothing -> return $! Left notFound - Just configuredProg@ConfiguredProgram { programLocation = location } -> + Nothing -> return $! Left notFound + Just configuredProg@ConfiguredProgram{programLocation = location} -> case programVersion configuredProg of Just version | withinRange version range -> - return $! Right (configuredProg, version ,programDb') - | otherwise -> - return $! Left (badVersion version location) - Nothing -> + return $! Right (configuredProg, version, programDb') + | otherwise -> + return $! Left (badVersion version location) + Nothing -> return $! Left (unknownVersion location) - - where notFound = "The program '" - ++ programName prog ++ "'" ++ versionRequirement - ++ " is required but it could not be found." - badVersion v l = "The program '" - ++ programName prog ++ "'" ++ versionRequirement - ++ " is required but the version found at " - ++ locationPath l ++ " is version " ++ prettyShow v - unknownVersion l = "The program '" - ++ programName prog ++ "'" ++ versionRequirement - ++ " is required but the version of " - ++ locationPath l ++ " could not be determined." - versionRequirement - | isAnyVersion range = "" - | otherwise = " version " ++ prettyShow range + where + notFound = + "The program '" + ++ programName prog + ++ "'" + ++ versionRequirement + ++ " is required but it could not be found." + badVersion v l = + "The program '" + ++ programName prog + ++ "'" + ++ versionRequirement + ++ " is required but the version found at " + ++ locationPath l + ++ " is version " + ++ prettyShow v + unknownVersion l = + "The program '" + ++ programName prog + ++ "'" + ++ versionRequirement + ++ " is required but the version of " + ++ locationPath l + ++ " could not be determined." + versionRequirement + | isAnyVersion range = "" + | otherwise = " version " ++ prettyShow range -- | Like 'lookupProgramVersion', but raises an exception in case of error -- instead of returning 'Left errMsg'. --- -requireProgramVersion :: Verbosity -> Program -> VersionRange - -> ProgramDb - -> IO (ConfiguredProgram, Version, ProgramDb) +requireProgramVersion + :: Verbosity + -> Program + -> VersionRange + -> ProgramDb + -> IO (ConfiguredProgram, Version, ProgramDb) requireProgramVersion verbosity prog range programDb = - join $ either (die' verbosity) return `fmap` - lookupProgramVersion verbosity prog range programDb + join $ + either (die' verbosity) return + `fmap` lookupProgramVersion verbosity prog range programDb diff --git a/Cabal/src/Distribution/Simple/Program/Find.hs b/Cabal/src/Distribution/Simple/Program/Find.hs index 1e8497e1e1a..806c9125968 100644 --- a/Cabal/src/Distribution/Simple/Program/Find.hs +++ b/Cabal/src/Distribution/Simple/Program/Find.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Find -- Copyright : Duncan Coutts 2013 @@ -24,30 +25,35 @@ -- So we need an extension of the usual 'findExecutable' that can look in -- additional locations, either before, after or instead of the normal OS -- locations. --- -module Distribution.Simple.Program.Find ( - -- * Program search path - ProgramSearchPath, - ProgramSearchPathEntry(..), - defaultProgramSearchPath, - findProgramOnSearchPath, - programSearchPathAsPATHVar, - getSystemSearchPath, +module Distribution.Simple.Program.Find + ( -- * Program search path + ProgramSearchPath + , ProgramSearchPathEntry (..) + , defaultProgramSearchPath + , findProgramOnSearchPath + , programSearchPathAsPATHVar + , getSystemSearchPath ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Verbosity +import Distribution.Compat.Environment import Distribution.Simple.Utils import Distribution.System -import Distribution.Compat.Environment +import Distribution.Verbosity import qualified System.Directory as Directory - ( findExecutable ) + ( findExecutable + ) import System.FilePath as FilePath - ( (), (<.>), splitSearchPath, searchPathSeparator, getSearchPath - , takeDirectory ) + ( getSearchPath + , searchPathSeparator + , splitSearchPath + , takeDirectory + , (<.>) + , () + ) #if defined(mingw32_HOST_OS) import qualified System.Win32 as Win32 #endif @@ -63,11 +69,13 @@ import qualified System.Win32 as Win32 -- dir to search after the usual ones. -- -- > ['ProgramSearchPathDefault', 'ProgramSearchPathDir' dir] --- type ProgramSearchPath = [ProgramSearchPathEntry] -data ProgramSearchPathEntry = - ProgramSearchPathDir FilePath -- ^ A specific dir - | ProgramSearchPathDefault -- ^ The system default + +data ProgramSearchPathEntry + = -- | A specific dir + ProgramSearchPathDir FilePath + | -- | The system default + ProgramSearchPathDefault deriving (Eq, Generic, Typeable) instance Binary ProgramSearchPathEntry @@ -76,69 +84,74 @@ instance Structured ProgramSearchPathEntry defaultProgramSearchPath :: ProgramSearchPath defaultProgramSearchPath = [ProgramSearchPathDefault] -findProgramOnSearchPath :: Verbosity -> ProgramSearchPath - -> FilePath -> IO (Maybe (FilePath, [FilePath])) +findProgramOnSearchPath + :: Verbosity + -> ProgramSearchPath + -> FilePath + -> IO (Maybe (FilePath, [FilePath])) findProgramOnSearchPath verbosity searchpath prog = do - debug verbosity $ "Searching for " ++ prog ++ " in path." - res <- tryPathElems [] searchpath - case res of - Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path") - Just (path, _) -> debug verbosity ("Found " ++ prog ++ " at "++ path) - return res + debug verbosity $ "Searching for " ++ prog ++ " in path." + res <- tryPathElems [] searchpath + case res of + Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path") + Just (path, _) -> debug verbosity ("Found " ++ prog ++ " at " ++ path) + return res where - tryPathElems :: [[FilePath]] -> [ProgramSearchPathEntry] - -> IO (Maybe (FilePath, [FilePath])) - tryPathElems _ [] = return Nothing - tryPathElems tried (pe:pes) = do + tryPathElems + :: [[FilePath]] + -> [ProgramSearchPathEntry] + -> IO (Maybe (FilePath, [FilePath])) + tryPathElems _ [] = return Nothing + tryPathElems tried (pe : pes) = do res <- tryPathElem pe case res of - (Nothing, notfoundat) -> tryPathElems (notfoundat : tried) pes + (Nothing, notfoundat) -> tryPathElems (notfoundat : tried) pes (Just foundat, notfoundat) -> return (Just (foundat, alltried)) where alltried = concat (reverse (notfoundat : tried)) tryPathElem :: ProgramSearchPathEntry -> IO (Maybe FilePath, [FilePath]) tryPathElem (ProgramSearchPathDir dir) = - findFirstExe [ dir prog <.> ext | ext <- exeExtensions ] - + findFirstExe [dir prog <.> ext | ext <- exeExtensions] -- On windows, getSystemSearchPath is not guaranteed 100% correct so we -- use findExecutable and then approximate the not-found-at locations. tryPathElem ProgramSearchPathDefault | buildOS == Windows = do - mExe <- firstJustM [ findExecutable (prog <.> ext) | ext <- exeExtensions ] + mExe <- firstJustM [findExecutable (prog <.> ext) | ext <- exeExtensions] syspath <- getSystemSearchPath case mExe of Nothing -> - let notfoundat = [ dir prog | dir <- syspath ] in - return (Nothing, notfoundat) - + let notfoundat = [dir prog | dir <- syspath] + in return (Nothing, notfoundat) Just foundat -> do - let founddir = takeDirectory foundat - notfoundat = [ dir prog - | dir <- takeWhile (/= founddir) syspath ] + let founddir = takeDirectory foundat + notfoundat = + [ dir prog + | dir <- takeWhile (/= founddir) syspath + ] return (Just foundat, notfoundat) -- On other OSs we can just do the simple thing tryPathElem ProgramSearchPathDefault = do dirs <- getSystemSearchPath - findFirstExe [ dir prog <.> ext | dir <- dirs, ext <- exeExtensions ] + findFirstExe [dir prog <.> ext | dir <- dirs, ext <- exeExtensions] findFirstExe :: [FilePath] -> IO (Maybe FilePath, [FilePath]) findFirstExe = go [] where - go fs' [] = return (Nothing, reverse fs') - go fs' (f:fs) = do + go fs' [] = return (Nothing, reverse fs') + go fs' (f : fs) = do isExe <- doesExecutableExist f if isExe then return (Just f, reverse fs') - else go (f:fs') fs + else go (f : fs') fs -- Helper for evaluating actions until the first one returns 'Just' firstJustM :: Monad m => [m (Maybe a)] -> m (Maybe a) firstJustM [] = return Nothing - firstJustM (ma:mas) = do + firstJustM (ma : mas) = do a <- ma case a of - Just _ -> return a + Just _ -> return a Nothing -> firstJustM mas -- | Interpret a 'ProgramSearchPath' to construct a new @$PATH@ env var. @@ -146,17 +159,16 @@ findProgramOnSearchPath verbosity searchpath prog = do -- algorithm looks at more than just the @%PATH%@. programSearchPathAsPATHVar :: ProgramSearchPath -> IO String programSearchPathAsPATHVar searchpath = do - ess <- traverse getEntries searchpath - return (intercalate [searchPathSeparator] (concat ess)) + ess <- traverse getEntries searchpath + return (intercalate [searchPathSeparator] (concat ess)) where getEntries (ProgramSearchPathDir dir) = return [dir] - getEntries ProgramSearchPathDefault = do + getEntries ProgramSearchPathDefault = do env <- getEnvironment return (maybe [] splitSearchPath (lookup "PATH" env)) -- | Get the system search path. On Unix systems this is just the @$PATH@ env -- var, but on windows it's a bit more complicated. --- getSystemSearchPath :: IO [FilePath] getSystemSearchPath = fmap nub $ do #if defined(mingw32_HOST_OS) @@ -195,4 +207,3 @@ findExecutable prog = do else return Nothing _ -> return mExe #endif - diff --git a/Cabal/src/Distribution/Simple/Program/GHC.hs b/Cabal/src/Distribution/Simple/Program/GHC.hs index 902422c253f..71294c59d00 100644 --- a/Cabal/src/Distribution/Simple/Program/GHC.hs +++ b/Cabal/src/Distribution/Simple/Program/GHC.hs @@ -4,57 +4,53 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Simple.Program.GHC ( - GhcOptions(..), - GhcMode(..), - GhcOptimisation(..), - GhcDynLinkMode(..), - GhcProfAuto(..), - - ghcInvocation, - renderGhcOptions, - - runGHC, - - packageDbArgsDb, - normaliseGhcArgs - +module Distribution.Simple.Program.GHC + ( GhcOptions (..) + , GhcMode (..) + , GhcOptimisation (..) + , GhcDynLinkMode (..) + , GhcProfAuto (..) + , ghcInvocation + , renderGhcOptions + , runGHC + , packageDbArgsDb + , normaliseGhcArgs ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Backpack -import Distribution.Compat.Semigroup (First'(..), Last'(..), Option'(..)) -import Distribution.Simple.GHC.ImplInfo -import Distribution.PackageDescription +import Distribution.Compat.Semigroup (First' (..), Last' (..), Option' (..)) import Distribution.ModuleName +import Distribution.PackageDescription +import Distribution.Pretty import Distribution.Simple.Compiler import Distribution.Simple.Flag -import Distribution.Simple.Program.Types +import Distribution.Simple.GHC.ImplInfo import Distribution.Simple.Program.Run +import Distribution.Simple.Program.Types import Distribution.System -import Distribution.Pretty import Distribution.Types.ComponentId +import Distribution.Utils.NubList import Distribution.Verbosity import Distribution.Version -import Distribution.Utils.NubList import Language.Haskell.Extension import Data.List (stripPrefix) import qualified Data.Map as Map -import Data.Monoid (All(..), Any(..), Endo(..)) +import Data.Monoid (All (..), Any (..), Endo (..)) import qualified Data.Set as Set normaliseGhcArgs :: Maybe Version -> PackageDescription -> [String] -> [String] normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs - | ghcVersion `withinRange` supportedGHCVersions - = argumentFilters . filter simpleFilters . filterRtsOpts $ ghcArgs + | ghcVersion `withinRange` supportedGHCVersions = + argumentFilters . filter simpleFilters . filterRtsOpts $ ghcArgs where supportedGHCVersions :: VersionRange - supportedGHCVersions = orLaterVersion (mkVersion [8,0]) - -- we (weakly) support unknown future GHC versions for the purpose - -- of filtering GHC arguments + supportedGHCVersions = orLaterVersion (mkVersion [8, 0]) + -- we (weakly) support unknown future GHC versions for the purpose + -- of filtering GHC arguments from :: Monoid m => [Int] -> m -> m from version flags @@ -66,8 +62,9 @@ normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs | ghcVersion `withinRange` earlierVersion (mkVersion version) = flags | otherwise = mempty - checkGhcFlags :: forall m . Monoid m => ([String] -> m) -> m - checkGhcFlags fun = mconcat + checkGhcFlags :: forall m. Monoid m => ([String] -> m) -> m + checkGhcFlags fun = + mconcat [ fun ghcArgs , checkComponentFlags libBuildInfo pkgLibs , checkComponentFlags buildInfo executables @@ -84,7 +81,9 @@ normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs checkComponent = foldMap fun . filterGhcOptions . allGhcOptions allGhcOptions :: BuildInfo -> [(CompilerFlavor, [String])] - allGhcOptions = foldMap (perCompilerFlavorToList .) + allGhcOptions = + foldMap + (perCompilerFlavorToList .) [options, profOptions, sharedOptions, staticOptions] filterGhcOptions :: [(CompilerFlavor, [String])] -> [[String]] @@ -97,31 +96,40 @@ normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs checkWarnings = All . Set.null . foldr alter Set.empty alter :: String -> Set String -> Set String - alter flag = appEndo $ mconcat - [ \s -> Endo $ if s == "-Werror" then Set.insert s else id - , \s -> Endo $ if s == "-Wwarn" then const Set.empty else id - , \s -> from [8,6] . Endo $ + alter flag = + appEndo $ + mconcat + [ \s -> Endo $ if s == "-Werror" then Set.insert s else id + , \s -> Endo $ if s == "-Wwarn" then const Set.empty else id + , \s -> + from [8, 6] . Endo $ if s == "-Werror=compat" - then Set.union compatWarningSet else id - , \s -> from [8,6] . Endo $ + then Set.union compatWarningSet + else id + , \s -> + from [8, 6] . Endo $ if s == "-Wno-error=compat" - then (`Set.difference` compatWarningSet) else id - , \s -> from [8,6] . Endo $ + then (`Set.difference` compatWarningSet) + else id + , \s -> + from [8, 6] . Endo $ if s == "-Wwarn=compat" - then (`Set.difference` compatWarningSet) else id - , from [8,4] $ markFlag "-Werror=" Set.insert - , from [8,4] $ markFlag "-Wwarn=" Set.delete - , from [8,4] $ markFlag "-Wno-error=" Set.delete - ] flag + then (`Set.difference` compatWarningSet) + else id + , from [8, 4] $ markFlag "-Werror=" Set.insert + , from [8, 4] $ markFlag "-Wwarn=" Set.delete + , from [8, 4] $ markFlag "-Wno-error=" Set.delete + ] + flag markFlag - :: String - -> (String -> Set String -> Set String) - -> String - -> Endo (Set String) + :: String + -> (String -> Set String -> Set String) + -> String + -> Endo (Set String) markFlag name update flag = Endo $ case stripPrefix name flag of - Just rest | not (null rest) && rest /= "compat" -> update rest - _ -> id + Just rest | not (null rest) && rest /= "compat" -> update rest + _ -> id flagArgumentFilter :: [String] -> [String] -> [String] flagArgumentFilter flags = go @@ -130,20 +138,21 @@ normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs makeFilter flag arg = Option' $ First' . filterRest <$> stripPrefix flag arg where filterRest leftOver = case dropEq leftOver of - [] -> drop 1 - _ -> id + [] -> drop 1 + _ -> id checkFilter :: String -> Maybe ([String] -> [String]) checkFilter = fmap getFirst' . getOption' . foldMap makeFilter flags go :: [String] -> [String] go [] = [] - go (arg:args) = case checkFilter arg of - Just f -> go (f args) - Nothing -> arg : go args + go (arg : args) = case checkFilter arg of + Just f -> go (f args) + Nothing -> arg : go args argumentFilters :: [String] -> [String] - argumentFilters = flagArgumentFilter + argumentFilters = + flagArgumentFilter ["-ghci-script", "-H", "-interactive-print"] filterRtsOpts :: [String] -> [String] @@ -151,118 +160,162 @@ normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs where go :: Bool -> [String] -> [String] go _ [] = [] - go _ ("+RTS":opts) = go True opts - go _ ("-RTS":opts) = go False opts - go isRTSopts (opt:opts) = addOpt $ go isRTSopts opts + go _ ("+RTS" : opts) = go True opts + go _ ("-RTS" : opts) = go False opts + go isRTSopts (opt : opts) = addOpt $ go isRTSopts opts where - addOpt | isRTSopts = id - | otherwise = (opt:) + addOpt + | isRTSopts = id + | otherwise = (opt :) simpleFilters :: String -> Bool - simpleFilters = not . getAny . mconcat - [ flagIn simpleFlags - , Any . isPrefixOf "-ddump-" - , Any . isPrefixOf "-dsuppress-" - , Any . isPrefixOf "-dno-suppress-" - , flagIn $ invertibleFlagSet "-" ["ignore-dot-ghci"] - , flagIn . invertibleFlagSet "-f" . mconcat $ - [ [ "reverse-errors", "warn-unused-binds", "break-on-error" - , "break-on-exception", "print-bind-result" - , "print-bind-contents", "print-evld-with-show" - , "implicit-import-qualified", "error-spans" - ] - , from [7,8] - [ "print-explicit-foralls" -- maybe also earlier, but GHC-7.6 doesn't have --show-options - , "print-explicit-kinds" - ] - , from [8,0] - [ "print-explicit-coercions" - , "print-explicit-runtime-reps" - , "print-equality-relations" - , "print-unicode-syntax" - , "print-expanded-synonyms" - , "print-potential-instances" - , "print-typechecker-elaboration" - ] - , from [8,2] - [ "diagnostics-show-caret", "local-ghci-history" - , "show-warning-groups", "hide-source-paths" - , "show-hole-constraints" + simpleFilters = + not + . getAny + . mconcat + [ flagIn simpleFlags + , Any . isPrefixOf "-ddump-" + , Any . isPrefixOf "-dsuppress-" + , Any . isPrefixOf "-dno-suppress-" + , flagIn $ invertibleFlagSet "-" ["ignore-dot-ghci"] + , flagIn . invertibleFlagSet "-f" . mconcat $ + [ + [ "reverse-errors" + , "warn-unused-binds" + , "break-on-error" + , "break-on-exception" + , "print-bind-result" + , "print-bind-contents" + , "print-evld-with-show" + , "implicit-import-qualified" + , "error-spans" ] - , from [8,4] ["show-loaded-modules"] - , from [8,6] [ "ghci-leak-check", "no-it" ] - , from [8,10] - [ "defer-diagnostics" -- affects printing of diagnostics - , "keep-going" -- try harder, the build will still fail if it's erroneous - , "print-axiom-incomps" -- print more debug info for closed type families - ] - ] - , flagIn . invertibleFlagSet "-d" $ [ "ppr-case-as-let", "ppr-ticks" ] - , isOptIntFlag - , isIntFlag - , if safeToFilterWarnings - then isWarning <> (Any . ("-w"==)) - else mempty - , from [8,6] $ - if safeToFilterHoles - then isTypedHoleFlag - else mempty - ] + , from + [7, 8] + [ "print-explicit-foralls" -- maybe also earlier, but GHC-7.6 doesn't have --show-options + , "print-explicit-kinds" + ] + , from + [8, 0] + [ "print-explicit-coercions" + , "print-explicit-runtime-reps" + , "print-equality-relations" + , "print-unicode-syntax" + , "print-expanded-synonyms" + , "print-potential-instances" + , "print-typechecker-elaboration" + ] + , from + [8, 2] + [ "diagnostics-show-caret" + , "local-ghci-history" + , "show-warning-groups" + , "hide-source-paths" + , "show-hole-constraints" + ] + , from [8, 4] ["show-loaded-modules"] + , from [8, 6] ["ghci-leak-check", "no-it"] + , from + [8, 10] + [ "defer-diagnostics" -- affects printing of diagnostics + , "keep-going" -- try harder, the build will still fail if it's erroneous + , "print-axiom-incomps" -- print more debug info for closed type families + ] + ] + , flagIn . invertibleFlagSet "-d" $ ["ppr-case-as-let", "ppr-ticks"] + , isOptIntFlag + , isIntFlag + , if safeToFilterWarnings + then isWarning <> (Any . ("-w" ==)) + else mempty + , from [8, 6] $ + if safeToFilterHoles + then isTypedHoleFlag + else mempty + ] flagIn :: Set String -> String -> Any flagIn set flag = Any $ Set.member flag set isWarning :: String -> Any - isWarning = mconcat $ map ((Any .) . isPrefixOf) - ["-fwarn-", "-fno-warn-", "-W", "-Wno-"] + isWarning = + mconcat $ + map + ((Any .) . isPrefixOf) + ["-fwarn-", "-fno-warn-", "-W", "-Wno-"] simpleFlags :: Set String - simpleFlags = Set.fromList . mconcat $ - [ [ "-n", "-#include", "-Rghc-timing", "-dstg-stats" - , "-dth-dec-file", "-dsource-stats", "-dverbose-core2core" - , "-dverbose-stg2stg", "-dcore-lint", "-dstg-lint", "-dcmm-lint" - , "-dasm-lint", "-dannot-lint", "-dshow-passes", "-dfaststring-stats" - , "-fno-max-relevant-binds", "-recomp", "-no-recomp", "-fforce-recomp" - , "-fno-force-recomp" - ] - - , from [8,2] - [ "-fno-max-errors", "-fdiagnostics-color=auto" - , "-fdiagnostics-color=always", "-fdiagnostics-color=never" - , "-dppr-debug", "-dno-debug-output" + simpleFlags = + Set.fromList . mconcat $ + [ + [ "-n" + , "-#include" + , "-Rghc-timing" + , "-dstg-stats" + , "-dth-dec-file" + , "-dsource-stats" + , "-dverbose-core2core" + , "-dverbose-stg2stg" + , "-dcore-lint" + , "-dstg-lint" + , "-dcmm-lint" + , "-dasm-lint" + , "-dannot-lint" + , "-dshow-passes" + , "-dfaststring-stats" + , "-fno-max-relevant-binds" + , "-recomp" + , "-no-recomp" + , "-fforce-recomp" + , "-fno-force-recomp" ] - - , from [8,4] [ "-ddebug-output" ] - , from [8,4] $ to [8,6] [ "-fno-max-valid-substitutions" ] - , from [8,6] [ "-dhex-word-literals" ] - , from [8,8] [ "-fshow-docs-of-hole-fits", "-fno-show-docs-of-hole-fits" ] - , from [9,0] [ "-dlinear-core-lint" ] - ] + , from + [8, 2] + [ "-fno-max-errors" + , "-fdiagnostics-color=auto" + , "-fdiagnostics-color=always" + , "-fdiagnostics-color=never" + , "-dppr-debug" + , "-dno-debug-output" + ] + , from [8, 4] ["-ddebug-output"] + , from [8, 4] $ to [8, 6] ["-fno-max-valid-substitutions"] + , from [8, 6] ["-dhex-word-literals"] + , from [8, 8] ["-fshow-docs-of-hole-fits", "-fno-show-docs-of-hole-fits"] + , from [9, 0] ["-dlinear-core-lint"] + ] isOptIntFlag :: String -> Any isOptIntFlag = mconcat . map (dropIntFlag True) $ ["-v", "-j"] isIntFlag :: String -> Any - isIntFlag = mconcat . map (dropIntFlag False) . mconcat $ - [ [ "-fmax-relevant-binds", "-ddpr-user-length", "-ddpr-cols" - , "-dtrace-level", "-fghci-hist-size" ] - , from [8,2] ["-fmax-uncovered-patterns", "-fmax-errors"] - , from [8,4] $ to [8,6] ["-fmax-valid-substitutions"] + isIntFlag = + mconcat . map (dropIntFlag False) . mconcat $ + [ + [ "-fmax-relevant-binds" + , "-ddpr-user-length" + , "-ddpr-cols" + , "-dtrace-level" + , "-fghci-hist-size" + ] + , from [8, 2] ["-fmax-uncovered-patterns", "-fmax-errors"] + , from [8, 4] $ to [8, 6] ["-fmax-valid-substitutions"] ] dropIntFlag :: Bool -> String -> String -> Any dropIntFlag isOpt flag input = Any $ case stripPrefix flag input of - Nothing -> False - Just rest | isOpt && null rest -> True - | otherwise -> case parseInt rest of - Just _ -> True - Nothing -> False + Nothing -> False + Just rest + | isOpt && null rest -> True + | otherwise -> case parseInt rest of + Just _ -> True + Nothing -> False where parseInt :: String -> Maybe Int parseInt = readMaybe . dropEq dropEq :: String -> String - dropEq ('=':s) = s + dropEq ('=' : s) = s dropEq s = s invertibleFlagSet :: String -> [String] -> Set String @@ -270,14 +323,21 @@ normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs Set.fromList $ (++) <$> [prefix, prefix ++ "no-"] <*> flagNames compatWarningSet :: Set String - compatWarningSet = Set.fromList $ mconcat - [ from [8,6] - [ "missing-monadfail-instances", "semigroup" - , "noncanonical-monoid-instances", "implicit-kind-vars" ] - ] + compatWarningSet = + Set.fromList $ + mconcat + [ from + [8, 6] + [ "missing-monadfail-instances" + , "semigroup" + , "noncanonical-monoid-instances" + , "implicit-kind-vars" + ] + ] safeToFilterHoles :: Bool - safeToFilterHoles = getAll . checkGhcFlags $ + safeToFilterHoles = + getAll . checkGhcFlags $ All . fromMaybe True . fmap getLast' . getOption' . foldMap notDeferred where notDeferred :: String -> Option' (Last' Bool) @@ -286,24 +346,34 @@ normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs notDeferred _ = Option' Nothing isTypedHoleFlag :: String -> Any - isTypedHoleFlag = mconcat + isTypedHoleFlag = + mconcat [ flagIn . invertibleFlagSet "-f" $ - [ "show-hole-constraints", "show-valid-substitutions" - , "show-valid-hole-fits", "sort-valid-hole-fits" - , "sort-by-size-hole-fits", "sort-by-subsumption-hole-fits" - , "abstract-refinement-hole-fits", "show-provenance-of-hole-fits" - , "show-hole-matches-of-hole-fits", "show-type-of-hole-fits" - , "show-type-app-of-hole-fits", "show-type-app-vars-of-hole-fits" + [ "show-hole-constraints" + , "show-valid-substitutions" + , "show-valid-hole-fits" + , "sort-valid-hole-fits" + , "sort-by-size-hole-fits" + , "sort-by-subsumption-hole-fits" + , "abstract-refinement-hole-fits" + , "show-provenance-of-hole-fits" + , "show-hole-matches-of-hole-fits" + , "show-type-of-hole-fits" + , "show-type-app-of-hole-fits" + , "show-type-app-vars-of-hole-fits" , "unclutter-valid-hole-fits" ] , flagIn . Set.fromList $ - [ "-fno-max-valid-hole-fits", "-fno-max-refinement-hole-fits" - , "-fno-refinement-level-hole-fits" ] + [ "-fno-max-valid-hole-fits" + , "-fno-max-refinement-hole-fits" + , "-fno-refinement-level-hole-fits" + ] , mconcat . map (dropIntFlag False) $ - [ "-fmax-valid-hole-fits", "-fmax-refinement-hole-fits" - , "-frefinement-level-hole-fits" ] + [ "-fmax-valid-hole-fits" + , "-fmax-refinement-hole-fits" + , "-frefinement-level-hole-fits" + ] ] - normaliseGhcArgs _ _ args = args -- | A structured set of GHC options/flags @@ -314,546 +384,525 @@ normaliseGhcArgs _ _ args = args -- enabled extensions; -- * options that cannot be deduplicated in general without changing -- semantics, e.g. extra ghc options or linking options. -data GhcOptions = GhcOptions { - - -- | The major mode for the ghc invocation. - ghcOptMode :: Flag GhcMode, - - -- | Any extra options to pass directly to ghc. These go at the end and hence +data GhcOptions = GhcOptions + { ghcOptMode :: Flag GhcMode + -- ^ The major mode for the ghc invocation. + , ghcOptExtra :: [String] + -- ^ Any extra options to pass directly to ghc. These go at the end and hence -- override other stuff. - ghcOptExtra :: [String], - - -- | Extra default flags to pass directly to ghc. These go at the beginning + , ghcOptExtraDefault :: [String] + -- ^ Extra default flags to pass directly to ghc. These go at the beginning -- and so can be overridden by other stuff. - ghcOptExtraDefault :: [String], - - ----------------------- - -- Inputs and outputs - - -- | The main input files; could be .hs, .hi, .c, .o, depending on mode. - ghcOptInputFiles :: NubListR FilePath, - - -- | Script files with irregular extensions that need -x hs. - ghcOptInputScripts :: NubListR FilePath, - - -- | The names of input Haskell modules, mainly for @--make@ mode. - ghcOptInputModules :: NubListR ModuleName, - - -- | Location for output file; the @ghc -o@ flag. - ghcOptOutputFile :: Flag FilePath, - - -- | Location for dynamic output file in 'GhcStaticAndDynamic' mode; + , ----------------------- + -- Inputs and outputs + + ghcOptInputFiles :: NubListR FilePath + -- ^ The main input files; could be .hs, .hi, .c, .o, depending on mode. + , ghcOptInputScripts :: NubListR FilePath + -- ^ Script files with irregular extensions that need -x hs. + , ghcOptInputModules :: NubListR ModuleName + -- ^ The names of input Haskell modules, mainly for @--make@ mode. + , ghcOptOutputFile :: Flag FilePath + -- ^ Location for output file; the @ghc -o@ flag. + , ghcOptOutputDynFile :: Flag FilePath + -- ^ Location for dynamic output file in 'GhcStaticAndDynamic' mode; -- the @ghc -dyno@ flag. - ghcOptOutputDynFile :: Flag FilePath, - - -- | Start with an empty search path for Haskell source files; + , ghcOptSourcePathClear :: Flag Bool + -- ^ Start with an empty search path for Haskell source files; -- the @ghc -i@ flag (@-i@ on its own with no path argument). - ghcOptSourcePathClear :: Flag Bool, - - -- | Search path for Haskell source files; the @ghc -i@ flag. - ghcOptSourcePath :: NubListR FilePath, + , ghcOptSourcePath :: NubListR FilePath + -- ^ Search path for Haskell source files; the @ghc -i@ flag. + , ------------- + -- Packages - ------------- - -- Packages - - -- | The unit ID the modules will belong to; the @ghc -this-unit-id@ + ghcOptThisUnitId :: Flag String + -- ^ The unit ID the modules will belong to; the @ghc -this-unit-id@ -- flag (or @-this-package-key@ or @-package-name@ on older -- versions of GHC). This is a 'String' because we assume you've -- already figured out what the correct format for this string is -- (we need to handle backwards compatibility.) - ghcOptThisUnitId :: Flag String, - - -- | GHC doesn't make any assumptions about the format of + , ghcOptThisComponentId :: Flag ComponentId + -- ^ GHC doesn't make any assumptions about the format of -- definite unit ids, so when we are instantiating a package it -- needs to be told explicitly what the component being instantiated -- is. This only gets set when 'ghcOptInstantiatedWith' is non-empty - ghcOptThisComponentId :: Flag ComponentId, - - -- | How the requirements of the package being compiled are to + , ghcOptInstantiatedWith :: [(ModuleName, OpenModule)] + -- ^ How the requirements of the package being compiled are to -- be filled. When typechecking an indefinite package, the 'OpenModule' -- is always a 'OpenModuleVar'; otherwise, it specifies the installed module -- that instantiates a package. - ghcOptInstantiatedWith :: [(ModuleName, OpenModule)], - - -- | No code? (But we turn on interface writing - ghcOptNoCode :: Flag Bool, - - -- | GHC package databases to use, the @ghc -package-conf@ flag. - ghcOptPackageDBs :: PackageDBStack, - - -- | The GHC packages to bring into scope when compiling, + , ghcOptNoCode :: Flag Bool + -- ^ No code? (But we turn on interface writing + , ghcOptPackageDBs :: PackageDBStack + -- ^ GHC package databases to use, the @ghc -package-conf@ flag. + , ghcOptPackages + :: NubListR (OpenUnitId, ModuleRenaming) + -- ^ The GHC packages to bring into scope when compiling, -- the @ghc -package-id@ flags. - ghcOptPackages :: - NubListR (OpenUnitId, ModuleRenaming), - - -- | Start with a clean package set; the @ghc -hide-all-packages@ flag - ghcOptHideAllPackages :: Flag Bool, - - -- | Warn about modules, not listed in command line - ghcOptWarnMissingHomeModules :: Flag Bool, - - -- | Don't automatically link in Haskell98 etc; the @ghc + , ghcOptHideAllPackages :: Flag Bool + -- ^ Start with a clean package set; the @ghc -hide-all-packages@ flag + , ghcOptWarnMissingHomeModules :: Flag Bool + -- ^ Warn about modules, not listed in command line + , ghcOptNoAutoLinkPackages :: Flag Bool + -- ^ Don't automatically link in Haskell98 etc; the @ghc -- -no-auto-link-packages@ flag. - ghcOptNoAutoLinkPackages :: Flag Bool, - - ----------------- - -- Linker stuff - - -- | Names of libraries to link in; the @ghc -l@ flag. - ghcOptLinkLibs :: [FilePath], - - -- | Search path for libraries to link in; the @ghc -L@ flag. - ghcOptLinkLibPath :: NubListR FilePath, - - -- | Options to pass through to the linker; the @ghc -optl@ flag. - ghcOptLinkOptions :: [String], - - -- | OSX only: frameworks to link in; the @ghc -framework@ flag. - ghcOptLinkFrameworks :: NubListR String, - - -- | OSX only: Search path for frameworks to link in; the + , ----------------- + -- Linker stuff + + ghcOptLinkLibs :: [FilePath] + -- ^ Names of libraries to link in; the @ghc -l@ flag. + , ghcOptLinkLibPath :: NubListR FilePath + -- ^ Search path for libraries to link in; the @ghc -L@ flag. + , ghcOptLinkOptions :: [String] + -- ^ Options to pass through to the linker; the @ghc -optl@ flag. + , ghcOptLinkFrameworks :: NubListR String + -- ^ OSX only: frameworks to link in; the @ghc -framework@ flag. + , ghcOptLinkFrameworkDirs :: NubListR String + -- ^ OSX only: Search path for frameworks to link in; the -- @ghc -framework-path@ flag. - ghcOptLinkFrameworkDirs :: NubListR String, - - -- | Instruct GHC to link against @libHSrts@ when producing a shared library. - ghcOptLinkRts :: Flag Bool, - - -- | Don't do the link step, useful in make mode; the @ghc -no-link@ flag. - ghcOptNoLink :: Flag Bool, - - -- | Don't link in the normal RTS @main@ entry point; the @ghc -no-hs-main@ + , ghcOptLinkRts :: Flag Bool + -- ^ Instruct GHC to link against @libHSrts@ when producing a shared library. + , ghcOptNoLink :: Flag Bool + -- ^ Don't do the link step, useful in make mode; the @ghc -no-link@ flag. + , ghcOptLinkNoHsMain :: Flag Bool + -- ^ Don't link in the normal RTS @main@ entry point; the @ghc -no-hs-main@ -- flag. - ghcOptLinkNoHsMain :: Flag Bool, - - -- | Module definition files (Windows specific) - ghcOptLinkModDefFiles :: NubListR FilePath, - - -------------------- - -- C and CPP stuff - - -- | Options to pass through to the C compiler; the @ghc -optc@ flag. - ghcOptCcOptions :: [String], - - -- | Options to pass through to the C++ compiler. - ghcOptCxxOptions :: [String], - - -- | Options to pass through to the Assembler. - ghcOptAsmOptions :: [String], - - -- | Options to pass through to CPP; the @ghc -optP@ flag. - ghcOptCppOptions :: [String], - - -- | Search path for CPP includes like header files; the @ghc -I@ flag. - ghcOptCppIncludePath :: NubListR FilePath, - - -- | Extra header files to include at CPP stage; the @ghc -optP-include@ flag. - ghcOptCppIncludes :: NubListR FilePath, - - -- | Extra header files to include for old-style FFI; the @ghc -#include@ flag. - ghcOptFfiIncludes :: NubListR FilePath, - - -- | Program to use for the C and C++ compiler; the @ghc -pgmc@ flag. - ghcOptCcProgram :: Flag FilePath, - - ---------------------------- - -- Language and extensions - - -- | The base language; the @ghc -XHaskell98@ or @-XHaskell2010@ flag. - ghcOptLanguage :: Flag Language, - - -- | The language extensions; the @ghc -X@ flag. - ghcOptExtensions :: NubListR Extension, - - -- | A GHC version-dependent mapping of extensions to flags. This must be + , ghcOptLinkModDefFiles :: NubListR FilePath + -- ^ Module definition files (Windows specific) + , -------------------- + -- C and CPP stuff + + ghcOptCcOptions :: [String] + -- ^ Options to pass through to the C compiler; the @ghc -optc@ flag. + , ghcOptCxxOptions :: [String] + -- ^ Options to pass through to the C++ compiler. + , ghcOptAsmOptions :: [String] + -- ^ Options to pass through to the Assembler. + , ghcOptCppOptions :: [String] + -- ^ Options to pass through to CPP; the @ghc -optP@ flag. + , ghcOptCppIncludePath :: NubListR FilePath + -- ^ Search path for CPP includes like header files; the @ghc -I@ flag. + , ghcOptCppIncludes :: NubListR FilePath + -- ^ Extra header files to include at CPP stage; the @ghc -optP-include@ flag. + , ghcOptFfiIncludes :: NubListR FilePath + -- ^ Extra header files to include for old-style FFI; the @ghc -#include@ flag. + , ghcOptCcProgram :: Flag FilePath + -- ^ Program to use for the C and C++ compiler; the @ghc -pgmc@ flag. + , ---------------------------- + -- Language and extensions + + ghcOptLanguage :: Flag Language + -- ^ The base language; the @ghc -XHaskell98@ or @-XHaskell2010@ flag. + , ghcOptExtensions :: NubListR Extension + -- ^ The language extensions; the @ghc -X@ flag. + , ghcOptExtensionMap :: Map Extension (Maybe CompilerFlag) + -- ^ A GHC version-dependent mapping of extensions to flags. This must be -- set to be able to make use of the 'ghcOptExtensions'. - ghcOptExtensionMap :: Map Extension (Maybe CompilerFlag), - - ---------------- - -- Compilation - - -- | What optimisation level to use; the @ghc -O@ flag. - ghcOptOptimisation :: Flag GhcOptimisation, - - -- | Emit debug info; the @ghc -g@ flag. - ghcOptDebugInfo :: Flag DebugInfoLevel, - - -- | Compile in profiling mode; the @ghc -prof@ flag. - ghcOptProfilingMode :: Flag Bool, - - -- | Automatically add profiling cost centers; the @ghc -fprof-auto*@ flags. - ghcOptProfilingAuto :: Flag GhcProfAuto, - - -- | Use the \"split sections\" feature; the @ghc -split-sections@ flag. - ghcOptSplitSections :: Flag Bool, - - -- | Use the \"split object files\" feature; the @ghc -split-objs@ flag. - ghcOptSplitObjs :: Flag Bool, - - -- | Run N jobs simultaneously (if possible). - ghcOptNumJobs :: Flag (Maybe Int), - - -- | Enable coverage analysis; the @ghc -fhpc -hpcdir@ flags. - ghcOptHPCDir :: Flag FilePath, - - ---------------- - -- GHCi - - -- | Extra GHCi startup scripts; the @-ghci-script@ flag - ghcOptGHCiScripts :: [FilePath], - - ------------------------ - -- Redirecting outputs - - ghcOptHiSuffix :: Flag String, - ghcOptObjSuffix :: Flag String, - ghcOptDynHiSuffix :: Flag String, -- ^ only in 'GhcStaticAndDynamic' mode - ghcOptDynObjSuffix :: Flag String, -- ^ only in 'GhcStaticAndDynamic' mode - ghcOptHiDir :: Flag FilePath, - ghcOptObjDir :: Flag FilePath, - ghcOptOutputDir :: Flag FilePath, - ghcOptStubDir :: Flag FilePath, - - -------------------- - -- Creating libraries - - ghcOptDynLinkMode :: Flag GhcDynLinkMode, - ghcOptStaticLib :: Flag Bool, - ghcOptShared :: Flag Bool, - ghcOptFPic :: Flag Bool, - ghcOptDylibName :: Flag String, - ghcOptRPaths :: NubListR FilePath, - - --------------- - -- Misc flags - - -- | Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag. - ghcOptVerbosity :: Flag Verbosity, - - -- | Put the extra folders in the PATH environment variable we invoke + , ---------------- + -- Compilation + + ghcOptOptimisation :: Flag GhcOptimisation + -- ^ What optimisation level to use; the @ghc -O@ flag. + , ghcOptDebugInfo :: Flag DebugInfoLevel + -- ^ Emit debug info; the @ghc -g@ flag. + , ghcOptProfilingMode :: Flag Bool + -- ^ Compile in profiling mode; the @ghc -prof@ flag. + , ghcOptProfilingAuto :: Flag GhcProfAuto + -- ^ Automatically add profiling cost centers; the @ghc -fprof-auto*@ flags. + , ghcOptSplitSections :: Flag Bool + -- ^ Use the \"split sections\" feature; the @ghc -split-sections@ flag. + , ghcOptSplitObjs :: Flag Bool + -- ^ Use the \"split object files\" feature; the @ghc -split-objs@ flag. + , ghcOptNumJobs :: Flag (Maybe Int) + -- ^ Run N jobs simultaneously (if possible). + , ghcOptHPCDir :: Flag FilePath + -- ^ Enable coverage analysis; the @ghc -fhpc -hpcdir@ flags. + , ---------------- + -- GHCi + + ghcOptGHCiScripts :: [FilePath] + -- ^ Extra GHCi startup scripts; the @-ghci-script@ flag + , ------------------------ + -- Redirecting outputs + + ghcOptHiSuffix :: Flag String + , ghcOptObjSuffix :: Flag String + , ghcOptDynHiSuffix :: Flag String + -- ^ only in 'GhcStaticAndDynamic' mode + , ghcOptDynObjSuffix :: Flag String + -- ^ only in 'GhcStaticAndDynamic' mode + , ghcOptHiDir :: Flag FilePath + , ghcOptObjDir :: Flag FilePath + , ghcOptOutputDir :: Flag FilePath + , ghcOptStubDir :: Flag FilePath + , -------------------- + -- Creating libraries + + ghcOptDynLinkMode :: Flag GhcDynLinkMode + , ghcOptStaticLib :: Flag Bool + , ghcOptShared :: Flag Bool + , ghcOptFPic :: Flag Bool + , ghcOptDylibName :: Flag String + , ghcOptRPaths :: NubListR FilePath + , --------------- + -- Misc flags + + ghcOptVerbosity :: Flag Verbosity + -- ^ Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag. + , ghcOptExtraPath :: NubListR FilePath + -- ^ Put the extra folders in the PATH environment variable we invoke -- GHC with - ghcOptExtraPath :: NubListR FilePath, - - -- | Let GHC know that it is Cabal that's calling it. + , ghcOptCabal :: Flag Bool + -- ^ Let GHC know that it is Cabal that's calling it. -- Modifies some of the GHC error messages. - ghcOptCabal :: Flag Bool - -} deriving (Show, Generic) - - -data GhcMode = GhcModeCompile -- ^ @ghc -c@ - | GhcModeLink -- ^ @ghc@ - | GhcModeMake -- ^ @ghc --make@ - | GhcModeInteractive -- ^ @ghci@ \/ @ghc --interactive@ - | GhcModeAbiHash -- ^ @ghc --abi-hash@ --- | GhcModeDepAnalysis -- ^ @ghc -M@ --- | GhcModeEvaluate -- ^ @ghc -e@ - deriving (Show, Eq) - -data GhcOptimisation = GhcNoOptimisation -- ^ @-O0@ - | GhcNormalOptimisation -- ^ @-O@ - | GhcMaximumOptimisation -- ^ @-O2@ - | GhcSpecialOptimisation String -- ^ e.g. @-Odph@ - deriving (Show, Eq) - -data GhcDynLinkMode = GhcStaticOnly -- ^ @-static@ - | GhcDynamicOnly -- ^ @-dynamic@ - | GhcStaticAndDynamic -- ^ @-static -dynamic-too@ - deriving (Show, Eq) - -data GhcProfAuto = GhcProfAutoAll -- ^ @-fprof-auto@ - | GhcProfAutoToplevel -- ^ @-fprof-auto-top@ - | GhcProfAutoExported -- ^ @-fprof-auto-exported@ - | GhcProfLate -- ^ @-fprof-late - deriving (Show, Eq) - -runGHC :: Verbosity -> ConfiguredProgram -> Compiler -> Platform -> GhcOptions - -> IO () + } + deriving (Show, Generic) + +data GhcMode + = -- | @ghc -c@ + GhcModeCompile + | -- | @ghc@ + GhcModeLink + | -- | @ghc --make@ + GhcModeMake + | -- | @ghci@ \/ @ghc --interactive@ + GhcModeInteractive + | -- | @ghc --abi-hash@ + -- | GhcModeDepAnalysis -- ^ @ghc -M@ + -- | GhcModeEvaluate -- ^ @ghc -e@ + GhcModeAbiHash + deriving (Show, Eq) + +data GhcOptimisation + = -- | @-O0@ + GhcNoOptimisation + | -- | @-O@ + GhcNormalOptimisation + | -- | @-O2@ + GhcMaximumOptimisation + | -- | e.g. @-Odph@ + GhcSpecialOptimisation String + deriving (Show, Eq) + +data GhcDynLinkMode + = -- | @-static@ + GhcStaticOnly + | -- | @-dynamic@ + GhcDynamicOnly + | -- | @-static -dynamic-too@ + GhcStaticAndDynamic + deriving (Show, Eq) + +data GhcProfAuto + = -- | @-fprof-auto@ + GhcProfAutoAll + | -- | @-fprof-auto-top@ + GhcProfAutoToplevel + | -- | @-fprof-auto-exported@ + GhcProfAutoExported + | -- | @-fprof-late + GhcProfLate + deriving (Show, Eq) + +runGHC + :: Verbosity + -> ConfiguredProgram + -> Compiler + -> Platform + -> GhcOptions + -> IO () runGHC verbosity ghcProg comp platform opts = do runProgramInvocation verbosity (ghcInvocation ghcProg comp platform opts) - -ghcInvocation :: ConfiguredProgram -> Compiler -> Platform -> GhcOptions - -> ProgramInvocation +ghcInvocation + :: ConfiguredProgram + -> Compiler + -> Platform + -> GhcOptions + -> ProgramInvocation ghcInvocation prog comp platform opts = - (programInvocation prog (renderGhcOptions comp platform opts)) { - progInvokePathEnv = fromNubListR (ghcOptExtraPath opts) + (programInvocation prog (renderGhcOptions comp platform opts)) + { progInvokePathEnv = fromNubListR (ghcOptExtraPath opts) } renderGhcOptions :: Compiler -> Platform -> GhcOptions -> [String] renderGhcOptions comp _platform@(Platform _arch os) opts | compilerFlavor comp `notElem` [GHC, GHCJS] = - error $ "Distribution.Simple.Program.GHC.renderGhcOptions: " - ++ "compiler flavor must be 'GHC' or 'GHCJS'!" + error $ + "Distribution.Simple.Program.GHC.renderGhcOptions: " + ++ "compiler flavor must be 'GHC' or 'GHCJS'!" | otherwise = - concat - [ case flagToMaybe (ghcOptMode opts) of - Nothing -> [] - Just GhcModeCompile -> ["-c"] - Just GhcModeLink -> [] - Just GhcModeMake -> ["--make"] - Just GhcModeInteractive -> ["--interactive"] - Just GhcModeAbiHash -> ["--abi-hash"] --- Just GhcModeDepAnalysis -> ["-M"] --- Just GhcModeEvaluate -> ["-e", expr] - - , ghcOptExtraDefault opts - - , [ "-no-link" | flagBool ghcOptNoLink ] - , [ "-flink-rts" | flagBool ghcOptLinkRts ] - - --------------- - -- Misc flags - - , maybe [] verbosityOpts (flagToMaybe (ghcOptVerbosity opts)) - - , [ "-fbuilding-cabal-package" | flagBool ghcOptCabal ] - - ---------------- - -- Compilation - - , case flagToMaybe (ghcOptOptimisation opts) of - Nothing -> [] - Just GhcNoOptimisation -> ["-O0"] - Just GhcNormalOptimisation -> ["-O"] - Just GhcMaximumOptimisation -> ["-O2"] - Just (GhcSpecialOptimisation s) -> ["-O" ++ s] -- eg -Odph - - , case flagToMaybe (ghcOptDebugInfo opts) of - Nothing -> [] - Just NoDebugInfo -> [] - Just MinimalDebugInfo -> ["-g1"] - Just NormalDebugInfo -> ["-g2"] - Just MaximalDebugInfo -> ["-g3"] - - , [ "-prof" | flagBool ghcOptProfilingMode ] - - , case flagToMaybe (ghcOptProfilingAuto opts) of - _ | not (flagBool ghcOptProfilingMode) - -> [] - Nothing -> [] - Just GhcProfAutoAll - | flagProfAuto implInfo -> ["-fprof-auto"] - | otherwise -> ["-auto-all"] -- not the same, but close - Just GhcProfLate - | flagProfLate implInfo -> ["-fprof-late"] - | otherwise -> ["-fprof-auto-top"] -- not the same, not very close, but what we have. - Just GhcProfAutoToplevel - | flagProfAuto implInfo -> ["-fprof-auto-top"] - | otherwise -> ["-auto-all"] - Just GhcProfAutoExported - | flagProfAuto implInfo -> ["-fprof-auto-exported"] - | otherwise -> ["-auto"] - - , [ "-split-sections" | flagBool ghcOptSplitSections ] - , [ "-split-objs" | flagBool ghcOptSplitObjs ] - - , case flagToMaybe (ghcOptHPCDir opts) of - Nothing -> [] - Just hpcdir -> ["-fhpc", "-hpcdir", hpcdir] - - , if parmakeSupported comp - then case ghcOptNumJobs opts of - NoFlag -> [] - Flag n -> ["-j" ++ maybe "" show n] - else [] - - -------------------- - -- Creating libraries - - , [ "-staticlib" | flagBool ghcOptStaticLib ] - , [ "-shared" | flagBool ghcOptShared ] - , case flagToMaybe (ghcOptDynLinkMode opts) of - Nothing -> [] - Just GhcStaticOnly -> ["-static"] - Just GhcDynamicOnly -> ["-dynamic"] - Just GhcStaticAndDynamic -> ["-static", "-dynamic-too"] - , [ "-fPIC" | flagBool ghcOptFPic ] - - , concat [ ["-dylib-install-name", libname] | libname <- flag ghcOptDylibName ] - - ------------------------ - -- Redirecting outputs - - , concat [ ["-osuf", suf] | suf <- flag ghcOptObjSuffix ] - , concat [ ["-hisuf", suf] | suf <- flag ghcOptHiSuffix ] - , concat [ ["-dynosuf", suf] | suf <- flag ghcOptDynObjSuffix ] - , concat [ ["-dynhisuf",suf] | suf <- flag ghcOptDynHiSuffix ] - , concat [ ["-outputdir", dir] | dir <- flag ghcOptOutputDir ] - , concat [ ["-odir", dir] | dir <- flag ghcOptObjDir ] - , concat [ ["-hidir", dir] | dir <- flag ghcOptHiDir ] - , concat [ ["-stubdir", dir] | dir <- flag ghcOptStubDir ] - - ----------------------- - -- Source search path - - , [ "-i" | flagBool ghcOptSourcePathClear ] - , [ "-i" ++ dir | dir <- flags ghcOptSourcePath ] - - -------------------- - - -------------------- - -- CPP, C, and C++ stuff - - , [ "-I" ++ dir | dir <- flags ghcOptCppIncludePath ] - , [ "-optP" ++ opt | opt <- ghcOptCppOptions opts] - , concat [ [ "-optP-include", "-optP" ++ inc] - | inc <- flags ghcOptCppIncludes ] - , [ "-optc" ++ opt | opt <- ghcOptCcOptions opts] - , -- C++ compiler options: GHC >= 8.10 requires -optcxx, older requires -optc - let cxxflag = case compilerCompatVersion GHC comp of + concat + [ case flagToMaybe (ghcOptMode opts) of + Nothing -> [] + Just GhcModeCompile -> ["-c"] + Just GhcModeLink -> [] + Just GhcModeMake -> ["--make"] + Just GhcModeInteractive -> ["--interactive"] + Just GhcModeAbiHash -> ["--abi-hash"] + , -- Just GhcModeDepAnalysis -> ["-M"] + -- Just GhcModeEvaluate -> ["-e", expr] + + ghcOptExtraDefault opts + , ["-no-link" | flagBool ghcOptNoLink] + , ["-flink-rts" | flagBool ghcOptLinkRts] + , --------------- + -- Misc flags + + maybe [] verbosityOpts (flagToMaybe (ghcOptVerbosity opts)) + , ["-fbuilding-cabal-package" | flagBool ghcOptCabal] + , ---------------- + -- Compilation + + case flagToMaybe (ghcOptOptimisation opts) of + Nothing -> [] + Just GhcNoOptimisation -> ["-O0"] + Just GhcNormalOptimisation -> ["-O"] + Just GhcMaximumOptimisation -> ["-O2"] + Just (GhcSpecialOptimisation s) -> ["-O" ++ s] -- eg -Odph + , case flagToMaybe (ghcOptDebugInfo opts) of + Nothing -> [] + Just NoDebugInfo -> [] + Just MinimalDebugInfo -> ["-g1"] + Just NormalDebugInfo -> ["-g2"] + Just MaximalDebugInfo -> ["-g3"] + , ["-prof" | flagBool ghcOptProfilingMode] + , case flagToMaybe (ghcOptProfilingAuto opts) of + _ + | not (flagBool ghcOptProfilingMode) -> + [] + Nothing -> [] + Just GhcProfAutoAll + | flagProfAuto implInfo -> ["-fprof-auto"] + | otherwise -> ["-auto-all"] -- not the same, but close + Just GhcProfLate + | flagProfLate implInfo -> ["-fprof-late"] + | otherwise -> ["-fprof-auto-top"] -- not the same, not very close, but what we have. + Just GhcProfAutoToplevel + | flagProfAuto implInfo -> ["-fprof-auto-top"] + | otherwise -> ["-auto-all"] + Just GhcProfAutoExported + | flagProfAuto implInfo -> ["-fprof-auto-exported"] + | otherwise -> ["-auto"] + , ["-split-sections" | flagBool ghcOptSplitSections] + , ["-split-objs" | flagBool ghcOptSplitObjs] + , case flagToMaybe (ghcOptHPCDir opts) of + Nothing -> [] + Just hpcdir -> ["-fhpc", "-hpcdir", hpcdir] + , if parmakeSupported comp + then case ghcOptNumJobs opts of + NoFlag -> [] + Flag n -> ["-j" ++ maybe "" show n] + else [] + , -------------------- + -- Creating libraries + + ["-staticlib" | flagBool ghcOptStaticLib] + , ["-shared" | flagBool ghcOptShared] + , case flagToMaybe (ghcOptDynLinkMode opts) of + Nothing -> [] + Just GhcStaticOnly -> ["-static"] + Just GhcDynamicOnly -> ["-dynamic"] + Just GhcStaticAndDynamic -> ["-static", "-dynamic-too"] + , ["-fPIC" | flagBool ghcOptFPic] + , concat [["-dylib-install-name", libname] | libname <- flag ghcOptDylibName] + , ------------------------ + -- Redirecting outputs + + concat [["-osuf", suf] | suf <- flag ghcOptObjSuffix] + , concat [["-hisuf", suf] | suf <- flag ghcOptHiSuffix] + , concat [["-dynosuf", suf] | suf <- flag ghcOptDynObjSuffix] + , concat [["-dynhisuf", suf] | suf <- flag ghcOptDynHiSuffix] + , concat [["-outputdir", dir] | dir <- flag ghcOptOutputDir] + , concat [["-odir", dir] | dir <- flag ghcOptObjDir] + , concat [["-hidir", dir] | dir <- flag ghcOptHiDir] + , concat [["-stubdir", dir] | dir <- flag ghcOptStubDir] + , ----------------------- + -- Source search path + + ["-i" | flagBool ghcOptSourcePathClear] + , ["-i" ++ dir | dir <- flags ghcOptSourcePath] + , -------------------- + + -------------------- + -- CPP, C, and C++ stuff + + ["-I" ++ dir | dir <- flags ghcOptCppIncludePath] + , ["-optP" ++ opt | opt <- ghcOptCppOptions opts] + , concat + [ ["-optP-include", "-optP" ++ inc] + | inc <- flags ghcOptCppIncludes + ] + , ["-optc" ++ opt | opt <- ghcOptCcOptions opts] + , -- C++ compiler options: GHC >= 8.10 requires -optcxx, older requires -optc + let cxxflag = case compilerCompatVersion GHC comp of Just v | v >= mkVersion [8, 10] -> "-optcxx" _ -> "-optc" - in [ cxxflag ++ opt | opt <- ghcOptCxxOptions opts] - , [ "-opta" ++ opt | opt <- ghcOptAsmOptions opts] - , concat [ ["-pgmc", cc] | cc <- flag ghcOptCcProgram ] - - ----------------- - -- Linker stuff - - , [ "-optl" ++ opt | opt <- ghcOptLinkOptions opts] - , ["-l" ++ lib | lib <- ghcOptLinkLibs opts] - , ["-L" ++ dir | dir <- flags ghcOptLinkLibPath ] - , if isOSX - then concat [ ["-framework", fmwk] - | fmwk <- flags ghcOptLinkFrameworks ] - else [] - , if isOSX - then concat [ ["-framework-path", path] - | path <- flags ghcOptLinkFrameworkDirs ] - else [] - , [ "-no-hs-main" | flagBool ghcOptLinkNoHsMain ] - , [ "-dynload deploy" | not (null (flags ghcOptRPaths)) ] - , concat [ [ "-optl-Wl,-rpath," ++ dir] - | dir <- flags ghcOptRPaths ] - , [ modDefFile | modDefFile <- flags ghcOptLinkModDefFiles ] - - ------------- - -- Packages - - , concat [ [ case () of - _ | unitIdSupported comp -> "-this-unit-id" - | packageKeySupported comp -> "-this-package-key" - | otherwise -> "-package-name" - , this_arg ] - | this_arg <- flag ghcOptThisUnitId ] - - , concat [ ["-this-component-id", prettyShow this_cid ] - | this_cid <- flag ghcOptThisComponentId ] - - , if null (ghcOptInstantiatedWith opts) - then [] - else "-instantiated-with" - : intercalate "," (map (\(n,m) -> prettyShow n ++ "=" - ++ prettyShow m) - (ghcOptInstantiatedWith opts)) - : [] - - , concat [ ["-fno-code", "-fwrite-interface"] | flagBool ghcOptNoCode ] - - , [ "-hide-all-packages" | flagBool ghcOptHideAllPackages ] - , [ "-Wmissing-home-modules" | flagBool ghcOptWarnMissingHomeModules ] - , [ "-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages ] - - , packageDbArgs implInfo (ghcOptPackageDBs opts) - - , concat $ let space "" = "" - space xs = ' ' : xs + in [cxxflag ++ opt | opt <- ghcOptCxxOptions opts] + , ["-opta" ++ opt | opt <- ghcOptAsmOptions opts] + , concat [["-pgmc", cc] | cc <- flag ghcOptCcProgram] + , ----------------- + -- Linker stuff + + ["-optl" ++ opt | opt <- ghcOptLinkOptions opts] + , ["-l" ++ lib | lib <- ghcOptLinkLibs opts] + , ["-L" ++ dir | dir <- flags ghcOptLinkLibPath] + , if isOSX + then + concat + [ ["-framework", fmwk] + | fmwk <- flags ghcOptLinkFrameworks + ] + else [] + , if isOSX + then + concat + [ ["-framework-path", path] + | path <- flags ghcOptLinkFrameworkDirs + ] + else [] + , ["-no-hs-main" | flagBool ghcOptLinkNoHsMain] + , ["-dynload deploy" | not (null (flags ghcOptRPaths))] + , concat + [ ["-optl-Wl,-rpath," ++ dir] + | dir <- flags ghcOptRPaths + ] + , [modDefFile | modDefFile <- flags ghcOptLinkModDefFiles] + , ------------- + -- Packages + + concat + [ [ case () of + _ + | unitIdSupported comp -> "-this-unit-id" + | packageKeySupported comp -> "-this-package-key" + | otherwise -> "-package-name" + , this_arg + ] + | this_arg <- flag ghcOptThisUnitId + ] + , concat + [ ["-this-component-id", prettyShow this_cid] + | this_cid <- flag ghcOptThisComponentId + ] + , if null (ghcOptInstantiatedWith opts) + then [] + else + "-instantiated-with" + : intercalate + "," + ( map + ( \(n, m) -> + prettyShow n + ++ "=" + ++ prettyShow m + ) + (ghcOptInstantiatedWith opts) + ) + : [] + , concat [["-fno-code", "-fwrite-interface"] | flagBool ghcOptNoCode] + , ["-hide-all-packages" | flagBool ghcOptHideAllPackages] + , ["-Wmissing-home-modules" | flagBool ghcOptWarnMissingHomeModules] + , ["-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages] + , packageDbArgs implInfo (ghcOptPackageDBs opts) + , concat $ + let space "" = "" + space xs = ' ' : xs in [ ["-package-id", prettyShow ipkgid ++ space (prettyShow rns)] - | (ipkgid,rns) <- flags ghcOptPackages ] - - ---------------------------- - -- Language and extensions - - , if supportsHaskell2010 implInfo - then [ "-X" ++ prettyShow lang | lang <- flag ghcOptLanguage ] - else [] - - , [ ext' - | ext <- flags ghcOptExtensions - , ext' <- case Map.lookup ext (ghcOptExtensionMap opts) of - Just (Just arg) -> [arg] - Just Nothing -> [] - Nothing -> - error $ "Distribution.Simple.Program.GHC.renderGhcOptions: " - ++ prettyShow ext ++ " not present in ghcOptExtensionMap." - ] - - ---------------- - -- GHCi - - , concat [ [ "-ghci-script", script ] | script <- ghcOptGHCiScripts opts - , flagGhciScript implInfo ] - - --------------- - -- Inputs - - -- Specify the input file(s) first, so that in ghci the `main-is` module is - -- in scope instead of the first module defined in `other-modules`. - , flags ghcOptInputFiles - , concat [ [ "-x", "hs", script] | script <- flags ghcOptInputScripts ] - , [ prettyShow modu | modu <- flags ghcOptInputModules ] - - , concat [ [ "-o", out] | out <- flag ghcOptOutputFile ] - , concat [ [ "-dyno", out] | out <- flag ghcOptOutputDynFile ] - - --------------- - -- Extra - - , ghcOptExtra opts - - ] - + | (ipkgid, rns) <- flags ghcOptPackages + ] + , ---------------------------- + -- Language and extensions + + if supportsHaskell2010 implInfo + then ["-X" ++ prettyShow lang | lang <- flag ghcOptLanguage] + else [] + , [ ext' + | ext <- flags ghcOptExtensions + , ext' <- case Map.lookup ext (ghcOptExtensionMap opts) of + Just (Just arg) -> [arg] + Just Nothing -> [] + Nothing -> + error $ + "Distribution.Simple.Program.GHC.renderGhcOptions: " + ++ prettyShow ext + ++ " not present in ghcOptExtensionMap." + ] + , ---------------- + -- GHCi + concat + [ ["-ghci-script", script] | script <- ghcOptGHCiScripts opts, flagGhciScript implInfo + ] + , --------------- + -- Inputs + + -- Specify the input file(s) first, so that in ghci the `main-is` module is + -- in scope instead of the first module defined in `other-modules`. + flags ghcOptInputFiles + , concat [["-x", "hs", script] | script <- flags ghcOptInputScripts] + , [prettyShow modu | modu <- flags ghcOptInputModules] + , concat [["-o", out] | out <- flag ghcOptOutputFile] + , concat [["-dyno", out] | out <- flag ghcOptOutputDynFile] + , --------------- + -- Extra + + ghcOptExtra opts + ] where - implInfo = getImplInfo comp - isOSX = os == OSX - flag flg = flagToList (flg opts) - flags flg = fromNubListR . flg $ opts + implInfo = getImplInfo comp + isOSX = os == OSX + flag flg = flagToList (flg opts) + flags flg = fromNubListR . flg $ opts flagBool flg = fromFlagOrDefault False (flg opts) verbosityOpts :: Verbosity -> [String] verbosityOpts verbosity | verbosity >= deafening = ["-v"] - | verbosity >= normal = [] - | otherwise = ["-w", "-v0"] - + | verbosity >= normal = [] + | otherwise = ["-w", "-v0"] -- | GHC <7.6 uses '-package-conf' instead of '-package-db'. packageDbArgsConf :: PackageDBStack -> [String] packageDbArgsConf dbstack = case dbstack of - (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs - (GlobalPackageDB:dbs) -> ("-no-user-package-conf") - : concatMap specific dbs + (GlobalPackageDB : UserPackageDB : dbs) -> concatMap specific dbs + (GlobalPackageDB : dbs) -> + ("-no-user-package-conf") + : concatMap specific dbs _ -> ierror where - specific (SpecificPackageDB db) = [ "-package-conf", db ] - specific _ = ierror - ierror = error $ "internal error: unexpected package db stack: " - ++ show dbstack + specific (SpecificPackageDB db) = ["-package-conf", db] + specific _ = ierror + ierror = + error $ + "internal error: unexpected package db stack: " + ++ show dbstack -- | GHC >= 7.6 uses the '-package-db' flag. See -- https://gitlab.haskell.org/ghc/ghc/-/issues/5977. packageDbArgsDb :: PackageDBStack -> [String] -- special cases to make arguments prettier in common scenarios packageDbArgsDb dbstack = case dbstack of - (GlobalPackageDB:UserPackageDB:dbs) - | all isSpecific dbs -> concatMap single dbs - (GlobalPackageDB:dbs) - | all isSpecific dbs -> "-no-user-package-db" - : concatMap single dbs - dbs -> "-clear-package-db" - : concatMap single dbs - where - single (SpecificPackageDB db) = [ "-package-db", db ] - single GlobalPackageDB = [ "-global-package-db" ] - single UserPackageDB = [ "-user-package-db" ] - isSpecific (SpecificPackageDB _) = True - isSpecific _ = False + (GlobalPackageDB : UserPackageDB : dbs) + | all isSpecific dbs -> concatMap single dbs + (GlobalPackageDB : dbs) + | all isSpecific dbs -> + "-no-user-package-db" + : concatMap single dbs + dbs -> + "-clear-package-db" + : concatMap single dbs + where + single (SpecificPackageDB db) = ["-package-db", db] + single GlobalPackageDB = ["-global-package-db"] + single UserPackageDB = ["-user-package-db"] + isSpecific (SpecificPackageDB _) = True + isSpecific _ = False packageDbArgs :: GhcImplInfo -> PackageDBStack -> [String] packageDbArgs implInfo | flagPackageConf implInfo = packageDbArgsConf - | otherwise = packageDbArgsDb + | otherwise = packageDbArgsDb -- ----------------------------------------------------------------------------- -- Boilerplate Monoid instance for GhcOptions diff --git a/Cabal/src/Distribution/Simple/Program/HcPkg.hs b/Cabal/src/Distribution/Simple/Program/HcPkg.hs index 1a3e3258e8f..8a39469c875 100644 --- a/Cabal/src/Distribution/Simple/Program/HcPkg.hs +++ b/Cabal/src/Distribution/Simple/Program/HcPkg.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.HcPkg -- Copyright : Duncan Coutts 2009, 2013 @@ -13,35 +14,34 @@ -- -- This module provides an library interface to the @hc-pkg@ program. -- Currently only GHC and GHCJS have hc-pkg programs. - -module Distribution.Simple.Program.HcPkg ( - -- * Types - HcPkgInfo(..), - RegisterOptions(..), - defaultRegisterOptions, +module Distribution.Simple.Program.HcPkg + ( -- * Types + HcPkgInfo (..) + , RegisterOptions (..) + , defaultRegisterOptions -- * Actions - init, - invoke, - register, - unregister, - recache, - expose, - hide, - dump, - describe, - list, + , init + , invoke + , register + , unregister + , recache + , expose + , hide + , dump + , describe + , list -- * Program invocations - initInvocation, - registerInvocation, - unregisterInvocation, - recacheInvocation, - exposeInvocation, - hideInvocation, - dumpInvocation, - describeInvocation, - listInvocation, + , initInvocation + , registerInvocation + , unregisterInvocation + , recacheInvocation + , exposeInvocation + , hideInvocation + , dumpInvocation + , describeInvocation + , listInvocation ) where import Distribution.Compat.Prelude hiding (init) @@ -59,42 +59,46 @@ import Distribution.Types.PackageId import Distribution.Types.UnitId import Distribution.Verbosity -import Data.List (stripPrefix) +import Data.List (stripPrefix) import System.FilePath as FilePath (isPathSeparator, joinPath, splitDirectories, splitPath, (<.>), ()) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.List.NonEmpty as NE +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.List.NonEmpty as NE import qualified System.FilePath.Posix as FilePath.Posix -- | Information about the features and capabilities of an @hc-pkg@ -- program. --- data HcPkgInfo = HcPkgInfo - { hcPkgProgram :: ConfiguredProgram - , noPkgDbStack :: Bool -- ^ no package DB stack supported - , noVerboseFlag :: Bool -- ^ hc-pkg does not support verbosity flags - , flagPackageConf :: Bool -- ^ use package-conf option instead of package-db - , supportsDirDbs :: Bool -- ^ supports directory style package databases - , requiresDirDbs :: Bool -- ^ requires directory style package databases - , nativeMultiInstance :: Bool -- ^ supports --enable-multi-instance flag - , recacheMultiInstance :: Bool -- ^ supports multi-instance via recache - , suppressFilesCheck :: Bool -- ^ supports --force-files or equivalent + { hcPkgProgram :: ConfiguredProgram + , noPkgDbStack :: Bool + -- ^ no package DB stack supported + , noVerboseFlag :: Bool + -- ^ hc-pkg does not support verbosity flags + , flagPackageConf :: Bool + -- ^ use package-conf option instead of package-db + , supportsDirDbs :: Bool + -- ^ supports directory style package databases + , requiresDirDbs :: Bool + -- ^ requires directory style package databases + , nativeMultiInstance :: Bool + -- ^ supports --enable-multi-instance flag + , recacheMultiInstance :: Bool + -- ^ supports multi-instance via recache + , suppressFilesCheck :: Bool + -- ^ supports --force-files or equivalent } - -- | Call @hc-pkg@ to initialise a package database at the location {path}. -- -- > hc-pkg init {path} --- init :: HcPkgInfo -> Verbosity -> Bool -> FilePath -> IO () init hpi verbosity preferCompat path - | not (supportsDirDbs hpi) - || (not (requiresDirDbs hpi) && preferCompat) - = writeFile path "[]" - - | otherwise - = runProgramInvocation verbosity (initInvocation hpi verbosity path) + | not (supportsDirDbs hpi) + || (not (requiresDirDbs hpi) && preferCompat) = + writeFile path "[]" + | otherwise = + runProgramInvocation verbosity (initInvocation hpi verbosity path) -- | Run @hc-pkg@ using a given package DB stack, directly forwarding the -- provided command-line arguments to it. @@ -102,194 +106,202 @@ invoke :: HcPkgInfo -> Verbosity -> PackageDBStack -> [String] -> IO () invoke hpi verbosity dbStack extraArgs = runProgramInvocation verbosity invocation where - args = packageDbStackOpts hpi dbStack ++ extraArgs + args = packageDbStackOpts hpi dbStack ++ extraArgs invocation = programInvocation (hcPkgProgram hpi) args -- | Additional variations in the behaviour for 'register'. -data RegisterOptions = RegisterOptions { - -- | Allows re-registering \/ overwriting an existing package - registerAllowOverwrite :: Bool, - - -- | Insist on the ability to register multiple instances of a - -- single version of a single package. This will fail if the @hc-pkg@ - -- does not support it, see 'nativeMultiInstance' and - -- 'recacheMultiInstance'. - registerMultiInstance :: Bool, - - -- | Require that no checks are performed on the existence of package - -- files mentioned in the registration info. This must be used if - -- registering prior to putting the files in their final place. This will - -- fail if the @hc-pkg@ does not support it, see 'suppressFilesCheck'. - registerSuppressFilesCheck :: Bool - } +data RegisterOptions = RegisterOptions + { registerAllowOverwrite :: Bool + -- ^ Allows re-registering \/ overwriting an existing package + , registerMultiInstance :: Bool + -- ^ Insist on the ability to register multiple instances of a + -- single version of a single package. This will fail if the @hc-pkg@ + -- does not support it, see 'nativeMultiInstance' and + -- 'recacheMultiInstance'. + , registerSuppressFilesCheck :: Bool + -- ^ Require that no checks are performed on the existence of package + -- files mentioned in the registration info. This must be used if + -- registering prior to putting the files in their final place. This will + -- fail if the @hc-pkg@ does not support it, see 'suppressFilesCheck'. + } -- | Defaults are @True@, @False@ and @False@ defaultRegisterOptions :: RegisterOptions -defaultRegisterOptions = RegisterOptions { - registerAllowOverwrite = True, - registerMultiInstance = False, - registerSuppressFilesCheck = False - } +defaultRegisterOptions = + RegisterOptions + { registerAllowOverwrite = True + , registerMultiInstance = False + , registerSuppressFilesCheck = False + } -- | Call @hc-pkg@ to register a package. -- -- > hc-pkg register {filename | -} [--user | --global | --package-db] --- -register :: HcPkgInfo -> Verbosity -> PackageDBStack - -> InstalledPackageInfo - -> RegisterOptions - -> IO () +register + :: HcPkgInfo + -> Verbosity + -> PackageDBStack + -> InstalledPackageInfo + -> RegisterOptions + -> IO () register hpi verbosity packagedbs pkgInfo registerOptions | registerMultiInstance registerOptions - , not (nativeMultiInstance hpi || recacheMultiInstance hpi) - = die' verbosity $ "HcPkg.register: the compiler does not support " - ++ "registering multiple instances of packages." - + , not (nativeMultiInstance hpi || recacheMultiInstance hpi) = + die' verbosity $ + "HcPkg.register: the compiler does not support " + ++ "registering multiple instances of packages." | registerSuppressFilesCheck registerOptions - , not (suppressFilesCheck hpi) - = die' verbosity $ "HcPkg.register: the compiler does not support " - ++ "suppressing checks on files." - - -- This is a trick. Older versions of GHC do not support the - -- --enable-multi-instance flag for ghc-pkg register but it turns out that - -- the same ability is available by using ghc-pkg recache. The recache - -- command is there to support distro package managers that like to work - -- by just installing files and running update commands, rather than - -- special add/remove commands. So the way to register by this method is - -- to write the package registration file directly into the package db and - -- then call hc-pkg recache. - -- + , not (suppressFilesCheck hpi) = + die' verbosity $ + "HcPkg.register: the compiler does not support " + ++ "suppressing checks on files." + -- This is a trick. Older versions of GHC do not support the + -- --enable-multi-instance flag for ghc-pkg register but it turns out that + -- the same ability is available by using ghc-pkg recache. The recache + -- command is there to support distro package managers that like to work + -- by just installing files and running update commands, rather than + -- special add/remove commands. So the way to register by this method is + -- to write the package registration file directly into the package db and + -- then call hc-pkg recache. + -- | registerMultiInstance registerOptions - , recacheMultiInstance hpi - = do let pkgdb = registrationPackageDB packagedbs - writeRegistrationFileDirectly verbosity hpi pkgdb pkgInfo - recache hpi verbosity pkgdb - - | otherwise - = runProgramInvocation verbosity - (registerInvocation hpi verbosity packagedbs pkgInfo registerOptions) - -writeRegistrationFileDirectly :: Verbosity - -> HcPkgInfo - -> PackageDB - -> InstalledPackageInfo - -> IO () + , recacheMultiInstance hpi = + do + let pkgdb = registrationPackageDB packagedbs + writeRegistrationFileDirectly verbosity hpi pkgdb pkgInfo + recache hpi verbosity pkgdb + | otherwise = + runProgramInvocation + verbosity + (registerInvocation hpi verbosity packagedbs pkgInfo registerOptions) + +writeRegistrationFileDirectly + :: Verbosity + -> HcPkgInfo + -> PackageDB + -> InstalledPackageInfo + -> IO () writeRegistrationFileDirectly verbosity hpi (SpecificPackageDB dir) pkgInfo - | supportsDirDbs hpi - = do let pkgfile = dir prettyShow (installedUnitId pkgInfo) <.> "conf" - writeUTF8File pkgfile (showInstalledPackageInfo pkgInfo) - - | otherwise - = die' verbosity $ "HcPkg.writeRegistrationFileDirectly: compiler does not support dir style package dbs" - + | supportsDirDbs hpi = + do + let pkgfile = dir prettyShow (installedUnitId pkgInfo) <.> "conf" + writeUTF8File pkgfile (showInstalledPackageInfo pkgInfo) + | otherwise = + die' verbosity $ "HcPkg.writeRegistrationFileDirectly: compiler does not support dir style package dbs" writeRegistrationFileDirectly verbosity _ _ _ = - -- We don't know here what the dir for the global or user dbs are, - -- if that's needed it'll require a bit more plumbing to support. - die' verbosity $ "HcPkg.writeRegistrationFileDirectly: only supports SpecificPackageDB for now" - + -- We don't know here what the dir for the global or user dbs are, + -- if that's needed it'll require a bit more plumbing to support. + die' verbosity $ "HcPkg.writeRegistrationFileDirectly: only supports SpecificPackageDB for now" -- | Call @hc-pkg@ to unregister a package -- -- > hc-pkg unregister [pkgid] [--user | --global | --package-db] --- unregister :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () unregister hpi verbosity packagedb pkgid = - runProgramInvocation verbosity + runProgramInvocation + verbosity (unregisterInvocation hpi verbosity packagedb pkgid) - -- | Call @hc-pkg@ to recache the registered packages. -- -- > hc-pkg recache [--user | --global | --package-db] --- recache :: HcPkgInfo -> Verbosity -> PackageDB -> IO () recache hpi verbosity packagedb = - runProgramInvocation verbosity + runProgramInvocation + verbosity (recacheInvocation hpi verbosity packagedb) - -- | Call @hc-pkg@ to expose a package. -- -- > hc-pkg expose [pkgid] [--user | --global | --package-db] --- expose :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () expose hpi verbosity packagedb pkgid = - runProgramInvocation verbosity + runProgramInvocation + verbosity (exposeInvocation hpi verbosity packagedb pkgid) -- | Call @hc-pkg@ to retrieve a specific package -- -- > hc-pkg describe [pkgid] [--user | --global | --package-db] --- describe :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId -> IO [InstalledPackageInfo] describe hpi verbosity packagedb pid = do - - output <- getProgramInvocationLBS verbosity - (describeInvocation hpi verbosity packagedb pid) - `catchIO` \_ -> return mempty + output <- + getProgramInvocationLBS + verbosity + (describeInvocation hpi verbosity packagedb pid) + `catchIO` \_ -> return mempty case parsePackages output of Left ok -> return ok - _ -> die' verbosity $ "failed to parse output of '" - ++ programId (hcPkgProgram hpi) ++ " describe " ++ prettyShow pid ++ "'" + _ -> + die' verbosity $ + "failed to parse output of '" + ++ programId (hcPkgProgram hpi) + ++ " describe " + ++ prettyShow pid + ++ "'" -- | Call @hc-pkg@ to hide a package. -- -- > hc-pkg hide [pkgid] [--user | --global | --package-db] --- hide :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () hide hpi verbosity packagedb pkgid = - runProgramInvocation verbosity + runProgramInvocation + verbosity (hideInvocation hpi verbosity packagedb pkgid) - -- | Call @hc-pkg@ to get all the details of all the packages in the given -- package database. --- dump :: HcPkgInfo -> Verbosity -> PackageDB -> IO [InstalledPackageInfo] dump hpi verbosity packagedb = do - - output <- getProgramInvocationLBS verbosity - (dumpInvocation hpi verbosity packagedb) - `catchIO` \e -> die' verbosity $ programId (hcPkgProgram hpi) ++ " dump failed: " - ++ displayException e + output <- + getProgramInvocationLBS + verbosity + (dumpInvocation hpi verbosity packagedb) + `catchIO` \e -> + die' verbosity $ + programId (hcPkgProgram hpi) + ++ " dump failed: " + ++ displayException e case parsePackages output of Left ok -> return ok - _ -> die' verbosity $ "failed to parse output of '" - ++ programId (hcPkgProgram hpi) ++ " dump'" - + _ -> + die' verbosity $ + "failed to parse output of '" + ++ programId (hcPkgProgram hpi) + ++ " dump'" parsePackages :: LBS.ByteString -> Either [InstalledPackageInfo] [String] parsePackages lbs0 = - case traverse parseInstalledPackageInfo $ splitPkgs lbs0 of - Right ok -> Left [ setUnitId . maybe id mungePackagePaths (pkgRoot pkg) $ pkg | (_, pkg) <- ok ] - Left msgs -> Right (NE.toList msgs) + case traverse parseInstalledPackageInfo $ splitPkgs lbs0 of + Right ok -> Left [setUnitId . maybe id mungePackagePaths (pkgRoot pkg) $ pkg | (_, pkg) <- ok] + Left msgs -> Right (NE.toList msgs) where splitPkgs :: LBS.ByteString -> [BS.ByteString] splitPkgs = checkEmpty . doSplit where -- Handle the case of there being no packages at all. checkEmpty [s] | BS.all isSpace8 s = [] - checkEmpty ss = ss + checkEmpty ss = ss isSpace8 :: Word8 -> Bool - isSpace8 9 = True -- '\t' + isSpace8 9 = True -- '\t' isSpace8 10 = True -- '\n' isSpace8 13 = True -- '\r' isSpace8 32 = True -- ' ' - isSpace8 _ = False + isSpace8 _ = False doSplit :: LBS.ByteString -> [BS.ByteString] doSplit lbs = go (LBS.findIndices (\w -> w == 10 || w == 13) lbs) where go :: [Int64] -> [BS.ByteString] - go [] = [ LBS.toStrict lbs ] - go (idx:idxs) = - let (pfx, sfx) = LBS.splitAt idx lbs - in case foldr (<|>) Nothing $ map (`lbsStripPrefix` sfx) separators of + go [] = [LBS.toStrict lbs] + go (idx : idxs) = + let (pfx, sfx) = LBS.splitAt idx lbs + in case foldr (<|>) Nothing $ map (`lbsStripPrefix` sfx) separators of Just sfx' -> LBS.toStrict pfx : doSplit sfx' - Nothing -> go idxs + Nothing -> go idxs separators :: [LBS.ByteString] separators = ["\n---\n", "\r\n---\r\n", "\r---\r"] @@ -303,26 +315,25 @@ lbsStripPrefix pfx lbs | otherwise = Nothing #endif - mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec -- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) -- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. -- The "pkgroot" is the directory containing the package database. mungePackagePaths pkgroot pkginfo = - pkginfo { - importDirs = mungePaths (importDirs pkginfo), - includeDirs = mungePaths (includeDirs pkginfo), - libraryDirs = mungePaths (libraryDirs pkginfo), - libraryDirsStatic = mungePaths (libraryDirsStatic pkginfo), - libraryDynDirs = mungePaths (libraryDynDirs pkginfo), - frameworkDirs = mungePaths (frameworkDirs pkginfo), - haddockInterfaces = mungePaths (haddockInterfaces pkginfo), - haddockHTMLs = mungeUrls (haddockHTMLs pkginfo) + pkginfo + { importDirs = mungePaths (importDirs pkginfo) + , includeDirs = mungePaths (includeDirs pkginfo) + , libraryDirs = mungePaths (libraryDirs pkginfo) + , libraryDirsStatic = mungePaths (libraryDirsStatic pkginfo) + , libraryDynDirs = mungePaths (libraryDynDirs pkginfo) + , frameworkDirs = mungePaths (frameworkDirs pkginfo) + , haddockInterfaces = mungePaths (haddockInterfaces pkginfo) + , haddockHTMLs = mungeUrls (haddockHTMLs pkginfo) } where mungePaths = map mungePath - mungeUrls = map mungeUrl + mungeUrls = map mungeUrl mungePath p = case stripVarPrefix "${pkgroot}" p of Just p' -> pkgroot p' @@ -332,53 +343,59 @@ mungePackagePaths pkgroot pkginfo = Just p' -> toUrlPath pkgroot p' Nothing -> p - toUrlPath r p = "file:///" - -- URLs always use posix style '/' separators: - ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p) + toUrlPath r p = + "file:///" + -- URLs always use posix style '/' separators: + ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p) stripVarPrefix var p = case splitPath p of - (root:path') -> case stripPrefix var root of + (root : path') -> case stripPrefix var root of Just [sep] | isPathSeparator sep -> Just (joinPath path') - _ -> Nothing - _ -> Nothing - + _ -> Nothing + _ -> Nothing -- Older installed package info files did not have the installedUnitId -- field, so if it is missing then we fill it as the source package ID. -- NB: Internal libraries not supported. setUnitId :: InstalledPackageInfo -> InstalledPackageInfo -setUnitId pkginfo@InstalledPackageInfo { - installedUnitId = uid, - sourcePackageId = pid - } | unUnitId uid == "" - = pkginfo { - installedUnitId = mkLegacyUnitId pid, - installedComponentId_ = mkComponentId (prettyShow pid) - } +setUnitId + pkginfo@InstalledPackageInfo + { installedUnitId = uid + , sourcePackageId = pid + } + | unUnitId uid == "" = + pkginfo + { installedUnitId = mkLegacyUnitId pid + , installedComponentId_ = mkComponentId (prettyShow pid) + } setUnitId pkginfo = pkginfo - -- | Call @hc-pkg@ to get the source package Id of all the packages in the -- given package database. -- -- This is much less information than with 'dump', but also rather quicker. -- Note in particular that it does not include the 'UnitId', just -- the source 'PackageId' which is not necessarily unique in any package db. --- -list :: HcPkgInfo -> Verbosity -> PackageDB - -> IO [PackageId] +list + :: HcPkgInfo + -> Verbosity + -> PackageDB + -> IO [PackageId] list hpi verbosity packagedb = do - - output <- getProgramInvocationOutput verbosity - (listInvocation hpi verbosity packagedb) - `catchIO` \_ -> die' verbosity $ programId (hcPkgProgram hpi) ++ " list failed" + output <- + getProgramInvocationOutput + verbosity + (listInvocation hpi verbosity packagedb) + `catchIO` \_ -> die' verbosity $ programId (hcPkgProgram hpi) ++ " list failed" case parsePackageIds output of Just ok -> return ok - _ -> die' verbosity $ "failed to parse output of '" - ++ programId (hcPkgProgram hpi) ++ " list'" - + _ -> + die' verbosity $ + "failed to parse output of '" + ++ programId (hcPkgProgram hpi) + ++ " list'" where parsePackageIds = traverse simpleParsec . words @@ -388,130 +405,157 @@ list hpi verbosity packagedb = do initInvocation :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation initInvocation hpi verbosity path = - programInvocation (hcPkgProgram hpi) args + programInvocation (hcPkgProgram hpi) args where - args = ["init", path] + args = + ["init", path] ++ verbosityOpts hpi verbosity registerInvocation - :: HcPkgInfo -> Verbosity -> PackageDBStack + :: HcPkgInfo + -> Verbosity + -> PackageDBStack -> InstalledPackageInfo -> RegisterOptions -> ProgramInvocation registerInvocation hpi verbosity packagedbs pkgInfo registerOptions = - (programInvocation (hcPkgProgram hpi) (args "-")) { - progInvokeInput = Just $ IODataText $ showInstalledPackageInfo pkgInfo, - progInvokeInputEncoding = IOEncodingUTF8 + (programInvocation (hcPkgProgram hpi) (args "-")) + { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo pkgInfo + , progInvokeInputEncoding = IOEncodingUTF8 } where cmdname | registerAllowOverwrite registerOptions = "update" - | registerMultiInstance registerOptions = "update" - | otherwise = "register" - - args file = [cmdname, file] - ++ packageDbStackOpts hpi packagedbs - ++ [ "--enable-multi-instance" - | registerMultiInstance registerOptions ] - ++ [ "--force-files" - | registerSuppressFilesCheck registerOptions ] - ++ verbosityOpts hpi verbosity - -unregisterInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId - -> ProgramInvocation + | registerMultiInstance registerOptions = "update" + | otherwise = "register" + + args file = + [cmdname, file] + ++ packageDbStackOpts hpi packagedbs + ++ [ "--enable-multi-instance" + | registerMultiInstance registerOptions + ] + ++ [ "--force-files" + | registerSuppressFilesCheck registerOptions + ] + ++ verbosityOpts hpi verbosity + +unregisterInvocation + :: HcPkgInfo + -> Verbosity + -> PackageDB + -> PackageId + -> ProgramInvocation unregisterInvocation hpi verbosity packagedb pkgid = programInvocation (hcPkgProgram hpi) $ - ["unregister", packageDbOpts hpi packagedb, prettyShow pkgid] - ++ verbosityOpts hpi verbosity + ["unregister", packageDbOpts hpi packagedb, prettyShow pkgid] + ++ verbosityOpts hpi verbosity - -recacheInvocation :: HcPkgInfo -> Verbosity -> PackageDB - -> ProgramInvocation +recacheInvocation + :: HcPkgInfo + -> Verbosity + -> PackageDB + -> ProgramInvocation recacheInvocation hpi verbosity packagedb = programInvocation (hcPkgProgram hpi) $ - ["recache", packageDbOpts hpi packagedb] - ++ verbosityOpts hpi verbosity - - -exposeInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId - -> ProgramInvocation + ["recache", packageDbOpts hpi packagedb] + ++ verbosityOpts hpi verbosity + +exposeInvocation + :: HcPkgInfo + -> Verbosity + -> PackageDB + -> PackageId + -> ProgramInvocation exposeInvocation hpi verbosity packagedb pkgid = programInvocation (hcPkgProgram hpi) $ - ["expose", packageDbOpts hpi packagedb, prettyShow pkgid] - ++ verbosityOpts hpi verbosity - -describeInvocation :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId - -> ProgramInvocation + ["expose", packageDbOpts hpi packagedb, prettyShow pkgid] + ++ verbosityOpts hpi verbosity + +describeInvocation + :: HcPkgInfo + -> Verbosity + -> PackageDBStack + -> PackageId + -> ProgramInvocation describeInvocation hpi verbosity packagedbs pkgid = programInvocation (hcPkgProgram hpi) $ - ["describe", prettyShow pkgid] - ++ packageDbStackOpts hpi packagedbs - ++ verbosityOpts hpi verbosity - -hideInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId - -> ProgramInvocation + ["describe", prettyShow pkgid] + ++ packageDbStackOpts hpi packagedbs + ++ verbosityOpts hpi verbosity + +hideInvocation + :: HcPkgInfo + -> Verbosity + -> PackageDB + -> PackageId + -> ProgramInvocation hideInvocation hpi verbosity packagedb pkgid = programInvocation (hcPkgProgram hpi) $ - ["hide", packageDbOpts hpi packagedb, prettyShow pkgid] - ++ verbosityOpts hpi verbosity - + ["hide", packageDbOpts hpi packagedb, prettyShow pkgid] + ++ verbosityOpts hpi verbosity dumpInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation dumpInvocation hpi _verbosity packagedb = - (programInvocation (hcPkgProgram hpi) args) { - progInvokeOutputEncoding = IOEncodingUTF8 + (programInvocation (hcPkgProgram hpi) args) + { progInvokeOutputEncoding = IOEncodingUTF8 } where - args = ["dump", packageDbOpts hpi packagedb] + args = + ["dump", packageDbOpts hpi packagedb] ++ verbosityOpts hpi silent - -- We use verbosity level 'silent' because it is important that we - -- do not contaminate the output with info/debug messages. + +-- We use verbosity level 'silent' because it is important that we +-- do not contaminate the output with info/debug messages. listInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation listInvocation hpi _verbosity packagedb = - (programInvocation (hcPkgProgram hpi) args) { - progInvokeOutputEncoding = IOEncodingUTF8 + (programInvocation (hcPkgProgram hpi) args) + { progInvokeOutputEncoding = IOEncodingUTF8 } where - args = ["list", "--simple-output", packageDbOpts hpi packagedb] + args = + ["list", "--simple-output", packageDbOpts hpi packagedb] ++ verbosityOpts hpi silent - -- We use verbosity level 'silent' because it is important that we - -- do not contaminate the output with info/debug messages. +-- We use verbosity level 'silent' because it is important that we +-- do not contaminate the output with info/debug messages. packageDbStackOpts :: HcPkgInfo -> PackageDBStack -> [String] packageDbStackOpts hpi dbstack | noPkgDbStack hpi = [packageDbOpts hpi (registrationPackageDB dbstack)] - | otherwise = case dbstack of - (GlobalPackageDB:UserPackageDB:dbs) -> "--global" - : "--user" - : map specific dbs - (GlobalPackageDB:dbs) -> "--global" - : ("--no-user-" ++ packageDbFlag hpi) - : map specific dbs - _ -> ierror - where - specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db - specific _ = ierror - ierror :: a - ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) + | otherwise = case dbstack of + (GlobalPackageDB : UserPackageDB : dbs) -> + "--global" + : "--user" + : map specific dbs + (GlobalPackageDB : dbs) -> + "--global" + : ("--no-user-" ++ packageDbFlag hpi) + : map specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db + specific _ = ierror + ierror :: a + ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) packageDbFlag :: HcPkgInfo -> String packageDbFlag hpi - | flagPackageConf hpi - = "package-conf" - | otherwise - = "package-db" + | flagPackageConf hpi = + "package-conf" + | otherwise = + "package-db" packageDbOpts :: HcPkgInfo -> PackageDB -> String -packageDbOpts _ GlobalPackageDB = "--global" -packageDbOpts _ UserPackageDB = "--user" +packageDbOpts _ GlobalPackageDB = "--global" +packageDbOpts _ UserPackageDB = "--user" packageDbOpts hpi (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db verbosityOpts :: HcPkgInfo -> Verbosity -> [String] verbosityOpts hpi v - | noVerboseFlag hpi - = [] + | noVerboseFlag hpi = + [] | v >= deafening = ["-v2"] - | v == silent = ["-v0"] - | otherwise = [] + | v == silent = ["-v0"] + | otherwise = [] diff --git a/Cabal/src/Distribution/Simple/Program/Hpc.hs b/Cabal/src/Distribution/Simple/Program/Hpc.hs index f86cde6b33d..0fb210e72e3 100644 --- a/Cabal/src/Distribution/Simple/Program/Hpc.hs +++ b/Cabal/src/Distribution/Simple/Program/Hpc.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Hpc -- Copyright : Thomas Tuegel 2011 @@ -10,21 +11,20 @@ -- Portability : portable -- -- This module provides an library interface to the @hpc@ program. - module Distribution.Simple.Program.Hpc - ( markup - , union - ) where + ( markup + , union + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import System.Directory (makeRelativeToCurrentDirectory) import Distribution.ModuleName +import Distribution.Pretty import Distribution.Simple.Program.Run import Distribution.Simple.Program.Types -import Distribution.Pretty import Distribution.Simple.Utils import Distribution.Verbosity import Distribution.Version @@ -36,74 +36,103 @@ import Distribution.Version -- first path in the list. This means that e.g. test suites that import their -- library as a dependency can still work, but those that include the library -- modules directly (in other-modules) don't. -markup :: ConfiguredProgram - -> Version - -> Verbosity - -> FilePath -- ^ Path to .tix file - -> [FilePath] -- ^ Paths to .mix file directories - -> FilePath -- ^ Path where html output should be located - -> [ModuleName] -- ^ List of modules to include in the report - -> IO () +markup + :: ConfiguredProgram + -> Version + -> Verbosity + -> FilePath + -- ^ Path to .tix file + -> [FilePath] + -- ^ Paths to .mix file directories + -> FilePath + -- ^ Path where html output should be located + -> [ModuleName] + -- ^ List of modules to include in the report + -> IO () markup hpc hpcVer verbosity tixFile hpcDirs destDir included = do - hpcDirs' <- if withinRange hpcVer (orLaterVersion version07) - then return hpcDirs - else do - warn verbosity $ "Your version of HPC (" ++ prettyShow hpcVer - ++ ") does not properly handle multiple search paths. " - ++ "Coverage report generation may fail unexpectedly. These " - ++ "issues are addressed in version 0.7 or later (GHC 7.8 or " - ++ "later)." - ++ if null droppedDirs - then "" - else " The following search paths have been abandoned: " - ++ show droppedDirs - return passedDirs + hpcDirs' <- + if withinRange hpcVer (orLaterVersion version07) + then return hpcDirs + else do + warn verbosity $ + "Your version of HPC (" + ++ prettyShow hpcVer + ++ ") does not properly handle multiple search paths. " + ++ "Coverage report generation may fail unexpectedly. These " + ++ "issues are addressed in version 0.7 or later (GHC 7.8 or " + ++ "later)." + ++ if null droppedDirs + then "" + else + " The following search paths have been abandoned: " + ++ show droppedDirs + return passedDirs - -- Prior to GHC 8.0, hpc assumes all .mix paths are relative. - hpcDirs'' <- traverse makeRelativeToCurrentDirectory hpcDirs' + -- Prior to GHC 8.0, hpc assumes all .mix paths are relative. + hpcDirs'' <- traverse makeRelativeToCurrentDirectory hpcDirs' - runProgramInvocation verbosity - (markupInvocation hpc tixFile hpcDirs'' destDir included) + runProgramInvocation + verbosity + (markupInvocation hpc tixFile hpcDirs'' destDir included) where version07 = mkVersion [0, 7] (passedDirs, droppedDirs) = splitAt 1 hpcDirs -markupInvocation :: ConfiguredProgram - -> FilePath -- ^ Path to .tix file - -> [FilePath] -- ^ Paths to .mix file directories - -> FilePath -- ^ Path where html output should be - -- located - -> [ModuleName] -- ^ List of modules to include - -> ProgramInvocation +markupInvocation + :: ConfiguredProgram + -> FilePath + -- ^ Path to .tix file + -> [FilePath] + -- ^ Paths to .mix file directories + -> FilePath + -- ^ Path where html output should be + -- located + -> [ModuleName] + -- ^ List of modules to include + -> ProgramInvocation markupInvocation hpc tixFile hpcDirs destDir included = - let args = [ "markup", tixFile - , "--destdir=" ++ destDir - ] - ++ map ("--hpcdir=" ++) hpcDirs - ++ ["--include=" ++ prettyShow moduleName - | moduleName <- included ] - in programInvocation hpc args + let args = + [ "markup" + , tixFile + , "--destdir=" ++ destDir + ] + ++ map ("--hpcdir=" ++) hpcDirs + ++ [ "--include=" ++ prettyShow moduleName + | moduleName <- included + ] + in programInvocation hpc args -union :: ConfiguredProgram - -> Verbosity - -> [FilePath] -- ^ Paths to .tix files - -> FilePath -- ^ Path to resultant .tix file - -> [ModuleName] -- ^ List of modules to exclude from union - -> IO () +union + :: ConfiguredProgram + -> Verbosity + -> [FilePath] + -- ^ Paths to .tix files + -> FilePath + -- ^ Path to resultant .tix file + -> [ModuleName] + -- ^ List of modules to exclude from union + -> IO () union hpc verbosity tixFiles outFile excluded = - runProgramInvocation verbosity - (unionInvocation hpc tixFiles outFile excluded) + runProgramInvocation + verbosity + (unionInvocation hpc tixFiles outFile excluded) -unionInvocation :: ConfiguredProgram - -> [FilePath] -- ^ Paths to .tix files - -> FilePath -- ^ Path to resultant .tix file - -> [ModuleName] -- ^ List of modules to exclude from union - -> ProgramInvocation +unionInvocation + :: ConfiguredProgram + -> [FilePath] + -- ^ Paths to .tix files + -> FilePath + -- ^ Path to resultant .tix file + -> [ModuleName] + -- ^ List of modules to exclude from union + -> ProgramInvocation unionInvocation hpc tixFiles outFile excluded = - programInvocation hpc $ concat - [ ["sum", "--union"] - , tixFiles - , ["--output=" ++ outFile] - , ["--exclude=" ++ prettyShow moduleName - | moduleName <- excluded ] + programInvocation hpc $ + concat + [ ["sum", "--union"] + , tixFiles + , ["--output=" ++ outFile] + , [ "--exclude=" ++ prettyShow moduleName + | moduleName <- excluded ] + ] diff --git a/Cabal/src/Distribution/Simple/Program/Internal.hs b/Cabal/src/Distribution/Simple/Program/Internal.hs index c842a989c14..add9dd74d71 100644 --- a/Cabal/src/Distribution/Simple/Program/Internal.hs +++ b/Cabal/src/Distribution/Simple/Program/Internal.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Internal -- @@ -6,14 +7,13 @@ -- Portability : portable -- -- Internal utilities used by Distribution.Simple.Program.*. - -module Distribution.Simple.Program.Internal ( - stripExtractVersion, +module Distribution.Simple.Program.Internal + ( stripExtractVersion ) where -import Prelude () import Distribution.Compat.Prelude -import Distribution.Utils.Generic(safeTail) +import Distribution.Utils.Generic (safeTail) +import Prelude () -- | Extract the version number from the output of 'strip --version'. -- @@ -23,25 +23,24 @@ import Distribution.Utils.Generic(safeTail) -- 'strip' doesn't appear to have a version flag. stripExtractVersion :: String -> String stripExtractVersion str = - let numeric "" = False - numeric (x:_) = isDigit x + let numeric "" = False + numeric (x : _) = isDigit x -- Filter out everything in parentheses. filterPar' :: Int -> [String] -> [String] - filterPar' _ [] = [] - filterPar' n (x:xs) - | n >= 0 && "(" `isPrefixOf` x = filterPar' (n+1) ((safeTail x):xs) - | n > 0 && ")" `isSuffixOf` x = filterPar' (n-1) xs - | n > 0 = filterPar' n xs - | otherwise = x:filterPar' n xs + filterPar' _ [] = [] + filterPar' n (x : xs) + | n >= 0 && "(" `isPrefixOf` x = filterPar' (n + 1) ((safeTail x) : xs) + | n > 0 && ")" `isSuffixOf` x = filterPar' (n - 1) xs + | n > 0 = filterPar' n xs + | otherwise = x : filterPar' n xs filterPar = filterPar' 0 - - in case dropWhile (not . numeric) (filterPar . words $ str) of - (ver:_) -> - -- take the first two version components - let isDot = (== '.') - (major, rest) = break isDot ver - minor = takeWhile isDigit (dropWhile isDot rest) - in major ++ "." ++ minor - _ -> "" + in case dropWhile (not . numeric) (filterPar . words $ str) of + (ver : _) -> + -- take the first two version components + let isDot = (== '.') + (major, rest) = break isDot ver + minor = takeWhile isDigit (dropWhile isDot rest) + in major ++ "." ++ minor + _ -> "" diff --git a/Cabal/src/Distribution/Simple/Program/Ld.hs b/Cabal/src/Distribution/Simple/Program/Ld.hs index 9115d38d9d8..d7449b93964 100644 --- a/Cabal/src/Distribution/Simple/Program/Ld.hs +++ b/Cabal/src/Distribution/Simple/Program/Ld.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Ld -- Copyright : Duncan Coutts 2009 @@ -10,60 +11,74 @@ -- Portability : portable -- -- This module provides an library interface to the @ld@ linker program. - -module Distribution.Simple.Program.Ld ( - combineObjectFiles, +module Distribution.Simple.Program.Ld + ( combineObjectFiles ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Simple.Compiler (arResponseFilesSupported) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) +import Distribution.Simple.Flag + ( fromFlagOrDefault + ) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..)) import Distribution.Simple.Program.ResponseFile - ( withResponseFile ) + ( withResponseFile + ) import Distribution.Simple.Program.Run - ( ProgramInvocation, programInvocation, multiStageProgramInvocation - , runProgramInvocation ) + ( ProgramInvocation + , multiStageProgramInvocation + , programInvocation + , runProgramInvocation + ) import Distribution.Simple.Program.Types - ( ConfiguredProgram(..) ) -import Distribution.Simple.Flag - ( fromFlagOrDefault ) + ( ConfiguredProgram (..) + ) import Distribution.Simple.Setup.Config - ( configUseResponseFiles ) + ( configUseResponseFiles + ) import Distribution.Simple.Utils - ( defaultTempFileOptions ) + ( defaultTempFileOptions + ) import Distribution.Verbosity - ( Verbosity ) + ( Verbosity + ) import System.Directory - ( renameFile ) + ( renameFile + ) import System.FilePath - ( (<.>), takeDirectory ) + ( takeDirectory + , (<.>) + ) -- | Call @ld -r@ to link a bunch of object files together. --- -combineObjectFiles :: Verbosity -> LocalBuildInfo -> ConfiguredProgram - -> FilePath -> [FilePath] -> IO () +combineObjectFiles + :: Verbosity + -> LocalBuildInfo + -> ConfiguredProgram + -> FilePath + -> [FilePath] + -> IO () combineObjectFiles verbosity lbi ld target files = do - -- Unlike "ar", the "ld" tool is not designed to be used with xargs. That is, -- if we have more object files than fit on a single command line then we -- have a slight problem. What we have to do is link files in batches into -- a temp object file and then include that one in the next batch. - let simpleArgs = ["-r", "-o", target] + let simpleArgs = ["-r", "-o", target] initialArgs = ["-r", "-o", target] - middleArgs = ["-r", "-o", target, tmpfile] - finalArgs = middleArgs + middleArgs = ["-r", "-o", target, tmpfile] + finalArgs = middleArgs - simple = programInvocation ld simpleArgs - initial = programInvocation ld initialArgs - middle = programInvocation ld middleArgs - final = programInvocation ld finalArgs + simple = programInvocation ld simpleArgs + initial = programInvocation ld initialArgs + middle = programInvocation ld middleArgs + final = programInvocation ld finalArgs - targetDir = takeDirectory target + targetDir = takeDirectory target invokeWithResponesFile :: FilePath -> ProgramInvocation invokeWithResponesFile atFile = @@ -73,22 +88,19 @@ combineObjectFiles verbosity lbi ld target files = do fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi -- Whether ghc's ar supports response files is a good proxy for -- whether ghc's ld supports them as well. - responseArgumentsNotSupported = + responseArgumentsNotSupported = not (arResponseFilesSupported (compiler lbi)) if oldVersionManualOverride || responseArgumentsNotSupported - then - run $ multiStageProgramInvocation simple (initial, middle, final) files - else - withResponseFile verbosity defaultTempFileOptions targetDir "ld.rsp" Nothing files $ - \path -> runProgramInvocation verbosity $ invokeWithResponesFile path - + then run $ multiStageProgramInvocation simple (initial, middle, final) files + else withResponseFile verbosity defaultTempFileOptions targetDir "ld.rsp" Nothing files $ + \path -> runProgramInvocation verbosity $ invokeWithResponesFile path where - tmpfile = target <.> "tmp" -- perhaps should use a proper temp file - + tmpfile = target <.> "tmp" -- perhaps should use a proper temp file run :: [ProgramInvocation] -> IO () - run [] = return () - run [inv] = runProgramInvocation verbosity inv - run (inv:invs) = do runProgramInvocation verbosity inv - renameFile target tmpfile - run invs + run [] = return () + run [inv] = runProgramInvocation verbosity inv + run (inv : invs) = do + runProgramInvocation verbosity inv + renameFile target tmpfile + run invs diff --git a/Cabal/src/Distribution/Simple/Program/ResponseFile.hs b/Cabal/src/Distribution/Simple/Program/ResponseFile.hs index 598f46b7106..8a477d3fdd4 100644 --- a/Cabal/src/Distribution/Simple/Program/ResponseFile.hs +++ b/Cabal/src/Distribution/Simple/Program/ResponseFile.hs @@ -1,6 +1,10 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes #-} + +---------------------------------------------------------------------------- + ---------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.ResponseFile -- Copyright : (c) Sergey Vinokurov 2017 @@ -8,24 +12,26 @@ -- -- Maintainer : cabal-devel@haskell.org -- Created : 23 July 2017 ----------------------------------------------------------------------------- - module Distribution.Simple.Program.ResponseFile (withResponseFile) where +import System.IO (TextEncoding, hClose, hPutStr, hSetEncoding) import Prelude () -import System.IO (TextEncoding, hSetEncoding, hPutStr, hClose) import Distribution.Compat.Prelude -import Distribution.Simple.Utils (TempFileOptions, withTempFileEx, debug) +import Distribution.Simple.Utils (TempFileOptions, debug, withTempFileEx) import Distribution.Verbosity withResponseFile :: Verbosity -> TempFileOptions - -> FilePath -- ^ Working directory to create response file in. - -> FilePath -- ^ Template for response file name. - -> Maybe TextEncoding -- ^ Encoding to use for response file contents. - -> [String] -- ^ Arguments to put into response file. + -> FilePath + -- ^ Working directory to create response file in. + -> FilePath + -- ^ Template for response file name. + -> Maybe TextEncoding + -- ^ Encoding to use for response file contents. + -> [String] + -- ^ Arguments to put into response file. -> (FilePath -> IO a) -> IO a withResponseFile verbosity tmpFileOpts workDir fileNameTemplate encoding arguments f = @@ -51,9 +57,9 @@ escapeResponseFileArg = reverse . foldl' escape [] escape :: String -> Char -> String escape cs c = case c of - '\\' -> c:'\\':cs - '\'' -> c:'\\':cs - '"' -> c:'\\':cs - _ | isSpace c -> c:'\\':cs - | otherwise -> c:cs - + '\\' -> c : '\\' : cs + '\'' -> c : '\\' : cs + '"' -> c : '\\' : cs + _ + | isSpace c -> c : '\\' : cs + | otherwise -> c : cs diff --git a/Cabal/src/Distribution/Simple/Program/Run.hs b/Cabal/src/Distribution/Simple/Program/Run.hs index 66ab3ac82a7..bfc62896d91 100644 --- a/Cabal/src/Distribution/Simple/Program/Run.hs +++ b/Cabal/src/Distribution/Simple/Program/Run.hs @@ -1,8 +1,9 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Run -- Copyright : Duncan Coutts 2009 @@ -12,21 +13,18 @@ -- -- This module provides a data type for program invocations and functions to -- run them. - -module Distribution.Simple.Program.Run ( - ProgramInvocation(..), - IOEncoding(..), - emptyProgramInvocation, - simpleProgramInvocation, - programInvocation, - multiStageProgramInvocation, - - runProgramInvocation, - getProgramInvocationOutput, - getProgramInvocationLBS, - getProgramInvocationOutputAndErrors, - - getEffectiveEnvironment, +module Distribution.Simple.Program.Run + ( ProgramInvocation (..) + , IOEncoding (..) + , emptyProgramInvocation + , simpleProgramInvocation + , programInvocation + , multiStageProgramInvocation + , runProgramInvocation + , getProgramInvocationOutput + , getProgramInvocationLBS + , getProgramInvocationOutputAndErrors + , getEffectiveEnvironment ) where import Distribution.Compat.Prelude @@ -41,7 +39,7 @@ import Distribution.Verbosity import System.FilePath (searchPathSeparator) import qualified Data.ByteString.Lazy as LBS -import qualified Data.Map as Map +import qualified Data.Map as Map -- | Represents a specific invocation of a specific program. -- @@ -49,176 +47,197 @@ import qualified Data.Map as Map -- and actually doing it. This provides the opportunity to the caller to -- adjust how the program will be called. These invocations can either be run -- directly or turned into shell or batch scripts. --- -data ProgramInvocation = ProgramInvocation { - progInvokePath :: FilePath, - progInvokeArgs :: [String], - progInvokeEnv :: [(String, Maybe String)], - -- Extra paths to add to PATH - progInvokePathEnv :: [FilePath], - progInvokeCwd :: Maybe FilePath, - progInvokeInput :: Maybe IOData, - progInvokeInputEncoding :: IOEncoding, -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'. - progInvokeOutputEncoding :: IOEncoding - } +data ProgramInvocation = ProgramInvocation + { progInvokePath :: FilePath + , progInvokeArgs :: [String] + , progInvokeEnv :: [(String, Maybe String)] + , -- Extra paths to add to PATH + progInvokePathEnv :: [FilePath] + , progInvokeCwd :: Maybe FilePath + , progInvokeInput :: Maybe IOData + , progInvokeInputEncoding :: IOEncoding + -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'. + , progInvokeOutputEncoding :: IOEncoding + } -data IOEncoding = IOEncodingText -- locale mode text - | IOEncodingUTF8 -- always utf8 +data IOEncoding + = IOEncodingText -- locale mode text + | IOEncodingUTF8 -- always utf8 encodeToIOData :: IOEncoding -> IOData -> IOData -encodeToIOData _ iod@(IODataBinary _) = iod -encodeToIOData IOEncodingText iod@(IODataText _) = iod -encodeToIOData IOEncodingUTF8 (IODataText str) = IODataBinary (toUTF8LBS str) +encodeToIOData _ iod@(IODataBinary _) = iod +encodeToIOData IOEncodingText iod@(IODataText _) = iod +encodeToIOData IOEncodingUTF8 (IODataText str) = IODataBinary (toUTF8LBS str) emptyProgramInvocation :: ProgramInvocation emptyProgramInvocation = - ProgramInvocation { - progInvokePath = "", - progInvokeArgs = [], - progInvokeEnv = [], - progInvokePathEnv = [], - progInvokeCwd = Nothing, - progInvokeInput = Nothing, - progInvokeInputEncoding = IOEncodingText, - progInvokeOutputEncoding = IOEncodingText - } + ProgramInvocation + { progInvokePath = "" + , progInvokeArgs = [] + , progInvokeEnv = [] + , progInvokePathEnv = [] + , progInvokeCwd = Nothing + , progInvokeInput = Nothing + , progInvokeInputEncoding = IOEncodingText + , progInvokeOutputEncoding = IOEncodingText + } simpleProgramInvocation :: FilePath -> [String] -> ProgramInvocation simpleProgramInvocation path args = - emptyProgramInvocation { - progInvokePath = path, - progInvokeArgs = args - } + emptyProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + } programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation programInvocation prog args = - emptyProgramInvocation { - progInvokePath = programPath prog, - progInvokeArgs = programDefaultArgs prog - ++ args - ++ programOverrideArgs prog, - progInvokeEnv = programOverrideEnv prog - } - + emptyProgramInvocation + { progInvokePath = programPath prog + , progInvokeArgs = + programDefaultArgs prog + ++ args + ++ programOverrideArgs prog + , progInvokeEnv = programOverrideEnv prog + } runProgramInvocation :: Verbosity -> ProgramInvocation -> IO () -runProgramInvocation verbosity - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = [], - progInvokePathEnv = [], - progInvokeCwd = Nothing, - progInvokeInput = Nothing - } = - rawSystemExit verbosity path args - -runProgramInvocation verbosity - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = envOverrides, - progInvokePathEnv = extraPath, - progInvokeCwd = mcwd, - progInvokeInput = Nothing - } = do +runProgramInvocation + verbosity + ProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = [] + , progInvokePathEnv = [] + , progInvokeCwd = Nothing + , progInvokeInput = Nothing + } = + rawSystemExit verbosity path args +runProgramInvocation + verbosity + ProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = envOverrides + , progInvokePathEnv = extraPath + , progInvokeCwd = mcwd + , progInvokeInput = Nothing + } = do pathOverride <- getExtraPathEnv envOverrides extraPath menv <- getEffectiveEnvironment (envOverrides ++ pathOverride) - maybeExit $ rawSystemIOWithEnv verbosity - path args - mcwd menv - Nothing Nothing Nothing - -runProgramInvocation verbosity - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = envOverrides, - progInvokePathEnv = extraPath, - progInvokeCwd = mcwd, - progInvokeInput = Just inputStr, - progInvokeInputEncoding = encoding - } = do + maybeExit $ + rawSystemIOWithEnv + verbosity + path + args + mcwd + menv + Nothing + Nothing + Nothing +runProgramInvocation + verbosity + ProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = envOverrides + , progInvokePathEnv = extraPath + , progInvokeCwd = mcwd + , progInvokeInput = Just inputStr + , progInvokeInputEncoding = encoding + } = do pathOverride <- getExtraPathEnv envOverrides extraPath menv <- getEffectiveEnvironment (envOverrides ++ pathOverride) - (_, errors, exitCode) <- rawSystemStdInOut verbosity - path args - mcwd menv - (Just input) IODataModeBinary + (_, errors, exitCode) <- + rawSystemStdInOut + verbosity + path + args + mcwd + menv + (Just input) + IODataModeBinary when (exitCode /= ExitSuccess) $ - die' verbosity $ "'" ++ path ++ "' exited with an error:\n" ++ errors - where - input = encodeToIOData encoding inputStr + die' verbosity $ + "'" ++ path ++ "' exited with an error:\n" ++ errors + where + input = encodeToIOData encoding inputStr getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String getProgramInvocationOutput verbosity inv = do - (output, errors, exitCode) <- getProgramInvocationOutputAndErrors verbosity inv - when (exitCode /= ExitSuccess) $ - die' verbosity $ "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors - return output + (output, errors, exitCode) <- getProgramInvocationOutputAndErrors verbosity inv + when (exitCode /= ExitSuccess) $ + die' verbosity $ + "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors + return output getProgramInvocationLBS :: Verbosity -> ProgramInvocation -> IO LBS.ByteString getProgramInvocationLBS verbosity inv = do - (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary - when (exitCode /= ExitSuccess) $ - die' verbosity $ "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors - return output - -getProgramInvocationOutputAndErrors :: Verbosity -> ProgramInvocation - -> IO (String, String, ExitCode) + (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary + when (exitCode /= ExitSuccess) $ + die' verbosity $ + "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors + return output + +getProgramInvocationOutputAndErrors + :: Verbosity + -> ProgramInvocation + -> IO (String, String, ExitCode) getProgramInvocationOutputAndErrors verbosity inv = case progInvokeOutputEncoding inv of - IOEncodingText -> do - (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeText - return (output, errors, exitCode) - IOEncodingUTF8 -> do - (output', errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary - return (normaliseLineEndings (fromUTF8LBS output'), errors, exitCode) + IOEncodingText -> do + (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeText + return (output, errors, exitCode) + IOEncodingUTF8 -> do + (output', errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary + return (normaliseLineEndings (fromUTF8LBS output'), errors, exitCode) getProgramInvocationIODataAndErrors - :: KnownIODataMode mode => Verbosity -> ProgramInvocation -> IODataMode mode - -> IO (mode, String, ExitCode) + :: KnownIODataMode mode + => Verbosity + -> ProgramInvocation + -> IODataMode mode + -> IO (mode, String, ExitCode) getProgramInvocationIODataAndErrors verbosity ProgramInvocation - { progInvokePath = path - , progInvokeArgs = args - , progInvokeEnv = envOverrides - , progInvokePathEnv = extraPath - , progInvokeCwd = mcwd - , progInvokeInput = minputStr + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = envOverrides + , progInvokePathEnv = extraPath + , progInvokeCwd = mcwd + , progInvokeInput = minputStr , progInvokeInputEncoding = encoding } mode = do pathOverride <- getExtraPathEnv envOverrides extraPath menv <- getEffectiveEnvironment (envOverrides ++ pathOverride) rawSystemStdInOut verbosity path args mcwd menv input mode - where - input = encodeToIOData encoding <$> minputStr + where + input = encodeToIOData encoding <$> minputStr getExtraPathEnv :: [(String, Maybe String)] -> [FilePath] -> IO [(String, Maybe String)] getExtraPathEnv _ [] = return [] getExtraPathEnv env extras = do - mb_path <- case lookup "PATH" env of - Just x -> return x - Nothing -> lookupEnv "PATH" - let extra = intercalate [searchPathSeparator] extras - path' = case mb_path of - Nothing -> extra - Just path -> extra ++ searchPathSeparator : path - return [("PATH", Just path')] + mb_path <- case lookup "PATH" env of + Just x -> return x + Nothing -> lookupEnv "PATH" + let extra = intercalate [searchPathSeparator] extras + path' = case mb_path of + Nothing -> extra + Just path -> extra ++ searchPathSeparator : path + return [("PATH", Just path')] -- | Return the current environment extended with the given overrides. -- If an entry is specified twice in @overrides@, the second entry takes -- precedence. --- -getEffectiveEnvironment :: [(String, Maybe String)] - -> IO (Maybe [(String, String)]) -getEffectiveEnvironment [] = return Nothing +getEffectiveEnvironment + :: [(String, Maybe String)] + -> IO (Maybe [(String, String)]) +getEffectiveEnvironment [] = return Nothing getEffectiveEnvironment overrides = - fmap (Just . Map.toList . apply overrides . Map.fromList) getEnvironment + fmap (Just . Map.toList . apply overrides . Map.fromList) getEnvironment where apply os env = foldl' (flip update) env os - update (var, Nothing) = Map.delete var + update (var, Nothing) = Map.delete var update (var, Just val) = Map.insert var val -- | Like the unix xargs program. Useful for when we've got very long command @@ -240,53 +259,51 @@ getEffectiveEnvironment overrides = -- > $ middle args_2 -- > ... -- > $ final args_n --- multiStageProgramInvocation :: ProgramInvocation -> (ProgramInvocation, ProgramInvocation, ProgramInvocation) -> [String] -> [ProgramInvocation] multiStageProgramInvocation simple (initial, middle, final) args = - - let argSize inv = length (progInvokePath inv) - + foldl' (\s a -> length a + 1 + s) 1 (progInvokeArgs inv) + let argSize inv = + length (progInvokePath inv) + + foldl' (\s a -> length a + 1 + s) 1 (progInvokeArgs inv) fixedArgSize = maximum (map argSize [simple, initial, middle, final]) - chunkSize = maxCommandLineSize - fixedArgSize - + chunkSize = maxCommandLineSize - fixedArgSize in case splitChunks chunkSize args of - [] -> [ simple ] - - [c] -> [ simple `appendArgs` c ] - - (c:c2:cs) | (xs, x) <- unsnocNE (c2:|cs) -> - [ initial `appendArgs` c ] - ++ [ middle `appendArgs` c'| c' <- xs ] - ++ [ final `appendArgs` x ] - + [] -> [simple] + [c] -> [simple `appendArgs` c] + (c : c2 : cs) + | (xs, x) <- unsnocNE (c2 :| cs) -> + [initial `appendArgs` c] + ++ [middle `appendArgs` c' | c' <- xs] + ++ [final `appendArgs` x] where appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation - inv `appendArgs` as = inv { progInvokeArgs = progInvokeArgs inv ++ as } + inv `appendArgs` as = inv{progInvokeArgs = progInvokeArgs inv ++ as} splitChunks :: Int -> [[a]] -> [[[a]]] splitChunks len = unfoldr $ \s -> - if null s then Nothing - else Just (chunk len s) + if null s + then Nothing + else Just (chunk len s) chunk :: Int -> [[a]] -> ([[a]], [[a]]) - chunk len (s:_) | length s >= len = error toolong - chunk len ss = chunk' [] len ss + chunk len (s : _) | length s >= len = error toolong + chunk len ss = chunk' [] len ss chunk' :: [[a]] -> Int -> [[a]] -> ([[a]], [[a]]) - chunk' acc len (s:ss) - | len' < len = chunk' (s:acc) (len-len'-1) ss - where len' = length s - chunk' acc _ ss = (reverse acc, ss) - - toolong = "multiStageProgramInvocation: a single program arg is larger " - ++ "than the maximum command line length!" + chunk' acc len (s : ss) + | len' < len = chunk' (s : acc) (len - len' - 1) ss + where + len' = length s + chunk' acc _ ss = (reverse acc, ss) + toolong = + "multiStageProgramInvocation: a single program arg is larger " + ++ "than the maximum command line length!" ---FIXME: discover this at configure time or runtime on unix +-- FIXME: discover this at configure time or runtime on unix -- The value is 32k on Windows and posix specifies a minimum of 4k -- but all sensible unixes use more than 4k. -- we could use getSysVar ArgumentLimit but that's in the unix lib diff --git a/Cabal/src/Distribution/Simple/Program/Script.hs b/Cabal/src/Distribution/Simple/Program/Script.hs index 2b83f9796d4..f89db34306e 100644 --- a/Cabal/src/Distribution/Simple/Program/Script.hs +++ b/Cabal/src/Distribution/Simple/Program/Script.hs @@ -1,5 +1,7 @@ {-# LANGUAGE GADTs #-} + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Script -- Copyright : Duncan Coutts 2009 @@ -9,16 +11,14 @@ -- -- This module provides an library interface to the @hc-pkg@ program. -- Currently only GHC and LHC have hc-pkg programs. - -module Distribution.Simple.Program.Script ( - - invocationAsSystemScript, - invocationAsShellScript, - invocationAsBatchFile, +module Distribution.Simple.Program.Script + ( invocationAsSystemScript + , invocationAsShellScript + , invocationAsBatchFile ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Simple.Program.Run import Distribution.Simple.Utils @@ -26,89 +26,89 @@ import Distribution.System -- | Generate a system script, either POSIX shell script or Windows batch file -- as appropriate for the given system. --- invocationAsSystemScript :: OS -> ProgramInvocation -> String invocationAsSystemScript Windows = invocationAsBatchFile -invocationAsSystemScript _ = invocationAsShellScript - +invocationAsSystemScript _ = invocationAsShellScript -- | Generate a POSIX shell script that invokes a program. --- invocationAsShellScript :: ProgramInvocation -> String invocationAsShellScript - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = envExtra, - progInvokeCwd = mcwd, - progInvokeInput = minput - } = unlines $ - [ "#!/bin/sh" ] - ++ concatMap setEnv envExtra - ++ [ "cd " ++ quote cwd | cwd <- maybeToList mcwd ] - ++ [ (case minput of - Nothing -> "" - Just input -> "printf '%s' " ++ quote (iodataToText input) ++ " | ") - ++ unwords (map quote $ path : args) ++ " \"$@\""] - - where - setEnv (var, Nothing) = ["unset " ++ var, "export " ++ var] - setEnv (var, Just val) = ["export " ++ var ++ "=" ++ quote val] - - quote :: String -> String - quote s = "'" ++ escape s ++ "'" - - escape [] = [] - escape ('\'':cs) = "'\\''" ++ escape cs - escape (c :cs) = c : escape cs + ProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = envExtra + , progInvokeCwd = mcwd + , progInvokeInput = minput + } = + unlines $ + ["#!/bin/sh"] + ++ concatMap setEnv envExtra + ++ ["cd " ++ quote cwd | cwd <- maybeToList mcwd] + ++ [ ( case minput of + Nothing -> "" + Just input -> "printf '%s' " ++ quote (iodataToText input) ++ " | " + ) + ++ unwords (map quote $ path : args) + ++ " \"$@\"" + ] + where + setEnv (var, Nothing) = ["unset " ++ var, "export " ++ var] + setEnv (var, Just val) = ["export " ++ var ++ "=" ++ quote val] + + quote :: String -> String + quote s = "'" ++ escape s ++ "'" + + escape [] = [] + escape ('\'' : cs) = "'\\''" ++ escape cs + escape (c : cs) = c : escape cs iodataToText :: IOData -> String -iodataToText (IODataText str) = str +iodataToText (IODataText str) = str iodataToText (IODataBinary lbs) = fromUTF8LBS lbs - -- | Generate a Windows batch file that invokes a program. --- invocationAsBatchFile :: ProgramInvocation -> String invocationAsBatchFile - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = envExtra, - progInvokeCwd = mcwd, - progInvokeInput = minput - } = unlines $ - [ "@echo off" ] - ++ map setEnv envExtra - ++ [ "cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd ] - ++ case minput of - Nothing -> - [ path ++ concatMap (' ':) args ] - - Just input -> - [ "(" ] - ++ [ "echo " ++ escape line | line <- lines $ iodataToText input ] - ++ [ ") | " - ++ "\"" ++ path ++ "\"" - ++ concatMap (\arg -> ' ':quote arg) args ] - - where - setEnv (var, Nothing) = "set " ++ var ++ "=" - setEnv (var, Just val) = "set " ++ var ++ "=" ++ escape val - - quote :: String -> String - quote s = "\"" ++ escapeQ s ++ "\"" - - escapeQ [] = [] - escapeQ ('"':cs) = "\"\"\"" ++ escapeQ cs - escapeQ (c :cs) = c : escapeQ cs - - escape [] = [] - escape ('|':cs) = "^|" ++ escape cs - escape ('<':cs) = "^<" ++ escape cs - escape ('>':cs) = "^>" ++ escape cs - escape ('&':cs) = "^&" ++ escape cs - escape ('(':cs) = "^(" ++ escape cs - escape (')':cs) = "^)" ++ escape cs - escape ('^':cs) = "^^" ++ escape cs - escape (c :cs) = c : escape cs + ProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = envExtra + , progInvokeCwd = mcwd + , progInvokeInput = minput + } = + unlines $ + ["@echo off"] + ++ map setEnv envExtra + ++ ["cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd] + ++ case minput of + Nothing -> + [path ++ concatMap (' ' :) args] + Just input -> + ["("] + ++ ["echo " ++ escape line | line <- lines $ iodataToText input] + ++ [ ") | " + ++ "\"" + ++ path + ++ "\"" + ++ concatMap (\arg -> ' ' : quote arg) args + ] + where + setEnv (var, Nothing) = "set " ++ var ++ "=" + setEnv (var, Just val) = "set " ++ var ++ "=" ++ escape val + + quote :: String -> String + quote s = "\"" ++ escapeQ s ++ "\"" + + escapeQ [] = [] + escapeQ ('"' : cs) = "\"\"\"" ++ escapeQ cs + escapeQ (c : cs) = c : escapeQ cs + + escape [] = [] + escape ('|' : cs) = "^|" ++ escape cs + escape ('<' : cs) = "^<" ++ escape cs + escape ('>' : cs) = "^>" ++ escape cs + escape ('&' : cs) = "^&" ++ escape cs + escape ('(' : cs) = "^(" ++ escape cs + escape (')' : cs) = "^)" ++ escape cs + escape ('^' : cs) = "^^" ++ escape cs + escape (c : cs) = c : escape cs diff --git a/Cabal/src/Distribution/Simple/Program/Strip.hs b/Cabal/src/Distribution/Simple/Program/Strip.hs index 6557d8356b9..bb43e5ed47d 100644 --- a/Cabal/src/Distribution/Simple/Program/Strip.hs +++ b/Cabal/src/Distribution/Simple/Program/Strip.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Strip -- @@ -9,12 +10,11 @@ -- Portability : portable -- -- This module provides an library interface to the @strip@ program. - module Distribution.Simple.Program.Strip (stripLib, stripExe) - where +where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Simple.Program import Distribution.Simple.Utils @@ -22,54 +22,62 @@ import Distribution.System import Distribution.Verbosity import Distribution.Version -import System.FilePath (takeBaseName) +import System.FilePath (takeBaseName) runStrip :: Verbosity -> ProgramDb -> FilePath -> [String] -> IO () runStrip verbosity progDb path args = case lookupProgram stripProgram progDb of Just strip -> runProgram verbosity strip (args ++ [path]) - Nothing -> unless (buildOS == Windows) $ - -- Don't bother warning on windows, we don't expect them to - -- have the strip program anyway. - warn verbosity $ "Unable to strip executable or library '" - ++ (takeBaseName path) - ++ "' (missing the 'strip' program)" + Nothing -> + unless (buildOS == Windows) $ + -- Don't bother warning on windows, we don't expect them to + -- have the strip program anyway. + warn verbosity $ + "Unable to strip executable or library '" + ++ (takeBaseName path) + ++ "' (missing the 'strip' program)" stripExe :: Verbosity -> Platform -> ProgramDb -> FilePath -> IO () stripExe verbosity (Platform _arch os) progdb path = runStrip verbosity progdb path args where args = case os of - OSX -> ["-x"] -- By default, stripping the ghc binary on at least - -- some OS X installations causes: - -- HSbase-3.0.o: unknown symbol `_environ'" - -- The -x flag fixes that. - _ -> [] + OSX -> ["-x"] -- By default, stripping the ghc binary on at least + -- some OS X installations causes: + -- HSbase-3.0.o: unknown symbol `_environ'" + -- The -x flag fixes that. + _ -> [] stripLib :: Verbosity -> Platform -> ProgramDb -> FilePath -> IO () stripLib verbosity (Platform arch os) progdb path = do case os of - OSX -> -- '--strip-unneeded' is not supported on OS X, iOS, AIX, or - -- Solaris. See #1630. - return () + OSX -> + -- '--strip-unneeded' is not supported on OS X, iOS, AIX, or + -- Solaris. See #1630. + return () IOS -> return () AIX -> return () Solaris -> return () - Windows -> -- Stripping triggers a bug in 'strip.exe' for - -- libraries with lots identically named modules. See - -- #1784. - return() - Linux | arch == I386 -> - -- Versions of 'strip' on 32-bit Linux older than 2.18 are - -- broken. See #2339. - let okVersion = orLaterVersion (mkVersion [2,18]) - in case programVersion =<< lookupProgram stripProgram progdb of - Just v | withinRange v okVersion -> - runStrip verbosity progdb path args - _ -> warn verbosity $ "Unable to strip library '" - ++ (takeBaseName path) - ++ "' (version of 'strip' too old; " - ++ "requires >= 2.18 on 32-bit Linux)" - _ -> runStrip verbosity progdb path args + Windows -> + -- Stripping triggers a bug in 'strip.exe' for + -- libraries with lots identically named modules. See + -- #1784. + return () + Linux + | arch == I386 -> + -- Versions of 'strip' on 32-bit Linux older than 2.18 are + -- broken. See #2339. + let okVersion = orLaterVersion (mkVersion [2, 18]) + in case programVersion =<< lookupProgram stripProgram progdb of + Just v + | withinRange v okVersion -> + runStrip verbosity progdb path args + _ -> + warn verbosity $ + "Unable to strip library '" + ++ (takeBaseName path) + ++ "' (version of 'strip' too old; " + ++ "requires >= 2.18 on 32-bit Linux)" + _ -> runStrip verbosity progdb path args where args = ["--strip-unneeded"] diff --git a/Cabal/src/Distribution/Simple/Program/Types.hs b/Cabal/src/Distribution/Simple/Program/Types.hs index 4078f050185..2186b23fc01 100644 --- a/Cabal/src/Distribution/Simple/Program/Types.hs +++ b/Cabal/src/Distribution/Simple/Program/Types.hs @@ -2,9 +2,9 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Types -- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 @@ -19,30 +19,29 @@ -- args). Configuring a program involves finding its location and if necessary -- finding its version. There's reasonable default behavior for trying to find -- \"foo\" in PATH, being able to override its location, etc. --- -module Distribution.Simple.Program.Types ( - -- * Program and functions for constructing them - Program(..), - ProgramSearchPath, - ProgramSearchPathEntry(..), - simpleProgram, +module Distribution.Simple.Program.Types + ( -- * Program and functions for constructing them + Program (..) + , ProgramSearchPath + , ProgramSearchPathEntry (..) + , simpleProgram -- * Configured program and related functions - ConfiguredProgram(..), - programPath, - suppressOverrideArgs, - ProgArg, - ProgramLocation(..), - simpleConfiguredProgram, + , ConfiguredProgram (..) + , programPath + , suppressOverrideArgs + , ProgArg + , ProgramLocation (..) + , simpleConfiguredProgram ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.PackageDescription import Distribution.Simple.Program.Find -import Distribution.Version import Distribution.Verbosity +import Distribution.Version import qualified Data.Map as Map @@ -50,38 +49,36 @@ import qualified Data.Map as Map -- -- Note: rather than constructing this directly, start with 'simpleProgram' and -- override any extra fields. --- -data Program = Program { - -- | The simple name of the program, eg. ghc - programName :: String, - - -- | A function to search for the program if its location was not - -- specified by the user. Usually this will just be a call to - -- 'findProgramOnSearchPath'. - -- - -- It is supplied with the prevailing search path which will typically - -- just be used as-is, but can be extended or ignored as needed. - -- - -- For the purpose of change monitoring, in addition to the location - -- where the program was found, it returns all the other places that - -- were tried. - -- - programFindLocation :: Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])), - - -- | Try to find the version of the program. For many programs this is - -- not possible or is not necessary so it's OK to return Nothing. - programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version), - - -- | A function to do any additional configuration after we have - -- located the program (and perhaps identified its version). For example - -- it could add args, or environment vars. - programPostConf :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram, - -- | A function that filters any arguments that don't impact the output - -- from a commandline. Used to limit the volatility of dependency hashes - -- when using new-build. - programNormaliseArgs :: Maybe Version -> PackageDescription -> [String] -> [String] - } +data Program = Program + { programName :: String + -- ^ The simple name of the program, eg. ghc + , programFindLocation + :: Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) + -- ^ A function to search for the program if its location was not + -- specified by the user. Usually this will just be a call to + -- 'findProgramOnSearchPath'. + -- + -- It is supplied with the prevailing search path which will typically + -- just be used as-is, but can be extended or ignored as needed. + -- + -- For the purpose of change monitoring, in addition to the location + -- where the program was found, it returns all the other places that + -- were tried. + , programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version) + -- ^ Try to find the version of the program. For many programs this is + -- not possible or is not necessary so it's OK to return Nothing. + , programPostConf :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + -- ^ A function to do any additional configuration after we have + -- located the program (and perhaps identified its version). For example + -- it could add args, or environment vars. + , programNormaliseArgs :: Maybe Version -> PackageDescription -> [String] -> [String] + -- ^ A function that filters any arguments that don't impact the output + -- from a commandline. Used to limit the volatility of dependency hashes + -- when using new-build. + } + instance Show Program where show (Program name _ _ _ _) = "Program: " ++ name @@ -92,45 +89,36 @@ type ProgArg = String -- These are usually made by configuring a 'Program', but if you have to -- construct one directly then start with 'simpleConfiguredProgram' and -- override any extra fields. --- -data ConfiguredProgram = ConfiguredProgram { - -- | Just the name again - programId :: String, - - -- | The version of this program, if it is known. - programVersion :: Maybe Version, - - -- | Default command-line args for this program. - -- These flags will appear first on the command line, so they can be - -- overridden by subsequent flags. - programDefaultArgs :: [String], - - -- | Override command-line args for this program. - -- These flags will appear last on the command line, so they override - -- all earlier flags. - programOverrideArgs :: [String], - - -- | Override environment variables for this program. - -- These env vars will extend\/override the prevailing environment of - -- the current to form the environment for the new process. - programOverrideEnv :: [(String, Maybe String)], - - -- | A key-value map listing various properties of the program, useful - -- for feature detection. Populated during the configuration step, key - -- names depend on the specific program. - programProperties :: Map.Map String String, - - -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@ - programLocation :: ProgramLocation, - - -- | In addition to the 'programLocation' where the program was found, - -- these are additional locations that were looked at. The combination - -- of ths found location and these not-found locations can be used to - -- monitor to detect when the re-configuring the program might give a - -- different result (e.g. found in a different location). - -- - programMonitorFiles :: [FilePath] - } +data ConfiguredProgram = ConfiguredProgram + { programId :: String + -- ^ Just the name again + , programVersion :: Maybe Version + -- ^ The version of this program, if it is known. + , programDefaultArgs :: [String] + -- ^ Default command-line args for this program. + -- These flags will appear first on the command line, so they can be + -- overridden by subsequent flags. + , programOverrideArgs :: [String] + -- ^ Override command-line args for this program. + -- These flags will appear last on the command line, so they override + -- all earlier flags. + , programOverrideEnv :: [(String, Maybe String)] + -- ^ Override environment variables for this program. + -- These env vars will extend\/override the prevailing environment of + -- the current to form the environment for the new process. + , programProperties :: Map.Map String String + -- ^ A key-value map listing various properties of the program, useful + -- for feature detection. Populated during the configuration step, key + -- names depend on the specific program. + , programLocation :: ProgramLocation + -- ^ Location of the program. eg. @\/usr\/bin\/ghc-6.4@ + , programMonitorFiles :: [FilePath] + -- ^ In addition to the 'programLocation' where the program was found, + -- these are additional locations that were looked at. The combination + -- of ths found location and these not-found locations can be used to + -- monitor to detect when the re-configuring the program might give a + -- different result (e.g. found in a different location). + } deriving (Eq, Generic, Read, Show, Typeable) instance Binary ConfiguredProgram @@ -139,12 +127,12 @@ instance Structured ConfiguredProgram -- | Where a program was found. Also tells us whether it's specified by user or -- not. This includes not just the path, but the program as well. data ProgramLocation - = UserSpecified { locationPath :: FilePath } - -- ^The user gave the path to this program, - -- eg. --ghc-path=\/usr\/bin\/ghc-6.6 - | FoundOnSystem { locationPath :: FilePath } - -- ^The program was found automatically. - deriving (Eq, Generic, Read, Show, Typeable) + = -- | The user gave the path to this program, + -- eg. --ghc-path=\/usr\/bin\/ghc-6.6 + UserSpecified {locationPath :: FilePath} + | -- | The program was found automatically. + FoundOnSystem {locationPath :: FilePath} + deriving (Eq, Generic, Read, Show, Typeable) instance Binary ProgramLocation instance Structured ProgramLocation @@ -155,7 +143,7 @@ programPath = locationPath . programLocation -- | Suppress any extra arguments added by the user. suppressOverrideArgs :: ConfiguredProgram -> ConfiguredProgram -suppressOverrideArgs prog = prog { programOverrideArgs = [] } +suppressOverrideArgs prog = prog{programOverrideArgs = []} -- | Make a simple named program. -- @@ -163,28 +151,28 @@ suppressOverrideArgs prog = prog { programOverrideArgs = [] } -- version name. You can override these behaviours if necessary, eg: -- -- > (simpleProgram "foo") { programFindLocation = ... , programFindVersion ... } --- simpleProgram :: String -> Program -simpleProgram name = Program { - programName = name, - programFindLocation = \v p -> findProgramOnSearchPath v p name, - programFindVersion = \_ _ -> return Nothing, - programPostConf = \_ p -> return p, - programNormaliseArgs = \_ _ -> id - } +simpleProgram name = + Program + { programName = name + , programFindLocation = \v p -> findProgramOnSearchPath v p name + , programFindVersion = \_ _ -> return Nothing + , programPostConf = \_ p -> return p + , programNormaliseArgs = \_ _ -> id + } -- | Make a simple 'ConfiguredProgram'. -- -- > simpleConfiguredProgram "foo" (FoundOnSystem path) --- simpleConfiguredProgram :: String -> ProgramLocation -> ConfiguredProgram -simpleConfiguredProgram name loc = ConfiguredProgram { - programId = name, - programVersion = Nothing, - programDefaultArgs = [], - programOverrideArgs = [], - programOverrideEnv = [], - programProperties = Map.empty, - programLocation = loc, - programMonitorFiles = [] -- did not look in any other locations - } +simpleConfiguredProgram name loc = + ConfiguredProgram + { programId = name + , programVersion = Nothing + , programDefaultArgs = [] + , programOverrideArgs = [] + , programOverrideEnv = [] + , programProperties = Map.empty + , programLocation = loc + , programMonitorFiles = [] -- did not look in any other locations + } diff --git a/Cabal/src/Distribution/Simple/Register.hs b/Cabal/src/Distribution/Simple/Register.hs index f71f340f44b..fc6075dc357 100644 --- a/Cabal/src/Distribution/Simple/Register.hs +++ b/Cabal/src/Distribution/Simple/Register.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Register -- Copyright : Isaac Jones 2003-2004 @@ -25,164 +26,194 @@ -- This module does not delegate anything to the per-compiler modules but just -- mixes it all in this module, which is rather unsatisfactory. The script -- generation and the unregister feature are not well used or tested. - -module Distribution.Simple.Register ( - register, - unregister, - - internalPackageDBPath, - - initPackageDB, - doesPackageDBExist, - createPackageDB, - deletePackageDB, - - abiHash, - invokeHcPkg, - registerPackage, - HcPkg.RegisterOptions(..), - HcPkg.defaultRegisterOptions, - generateRegistrationInfo, - inplaceInstalledPackageInfo, - absoluteInstalledPackageInfo, - generalInstalledPackageInfo, +module Distribution.Simple.Register + ( register + , unregister + , internalPackageDBPath + , initPackageDB + , doesPackageDBExist + , createPackageDB + , deletePackageDB + , abiHash + , invokeHcPkg + , registerPackage + , HcPkg.RegisterOptions (..) + , HcPkg.defaultRegisterOptions + , generateRegistrationInfo + , inplaceInstalledPackageInfo + , absoluteInstalledPackageInfo + , generalInstalledPackageInfo ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.TargetInfo -import Distribution.Types.LocalBuildInfo import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.LocalBuildInfo +import Distribution.Types.TargetInfo -import Distribution.Simple.LocalBuildInfo import Distribution.Simple.BuildPaths import Distribution.Simple.BuildTarget +import Distribution.Simple.LocalBuildInfo -import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.UHC as UHC import qualified Distribution.Simple.HaskellSuite as HaskellSuite import qualified Distribution.Simple.PackageIndex as Index +import qualified Distribution.Simple.UHC as UHC import Distribution.Backpack.DescribeUnitId +import Distribution.Compat.Graph (IsNode (nodeKey)) +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.License (licenseFromSPDX, licenseToSPDX) +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Pretty import Distribution.Simple.Compiler +import Distribution.Simple.Flag import Distribution.Simple.Program -import Distribution.Simple.Program.Script import qualified Distribution.Simple.Program.HcPkg as HcPkg -import Distribution.Simple.Flag +import Distribution.Simple.Program.Script import Distribution.Simple.Setup.Register -import Distribution.PackageDescription -import Distribution.Package -import Distribution.License (licenseToSPDX, licenseFromSPDX) -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.Simple.Utils -import Distribution.Utils.MapAccum import Distribution.System -import Distribution.Pretty +import Distribution.Utils.MapAccum import Distribution.Verbosity as Verbosity import Distribution.Version -import Distribution.Compat.Graph (IsNode(nodeKey)) -import System.FilePath ((), (<.>), isAbsolute) import System.Directory +import System.FilePath (isAbsolute, (<.>), ()) import qualified Data.ByteString.Lazy.Char8 as BS.Char8 -- ----------------------------------------------------------------------------- -- Registration -register :: PackageDescription -> LocalBuildInfo - -> RegisterFlags -- ^Install in the user's database?; verbose - -> IO () +register + :: PackageDescription + -> LocalBuildInfo + -> RegisterFlags + -- ^ Install in the user's database?; verbose + -> IO () register pkg_descr lbi0 flags = - -- Duncan originally asked for us to not register/install files - -- when there was no public library. But with per-component - -- configure, we legitimately need to install internal libraries - -- so that we can get them. So just unconditionally install. - doRegister - where - doRegister = do - targets <- readTargetInfos verbosity pkg_descr lbi0 (regArgs flags) - - -- It's important to register in build order, because ghc-pkg - -- will complain if a dependency is not registered. - let componentsToRegister - = neededTargetsInBuildOrder' pkg_descr lbi0 (map nodeKey targets) - - (_, ipi_mbs) <- + -- Duncan originally asked for us to not register/install files + -- when there was no public library. But with per-component + -- configure, we legitimately need to install internal libraries + -- so that we can get them. So just unconditionally install. + doRegister + where + doRegister = do + targets <- readTargetInfos verbosity pkg_descr lbi0 (regArgs flags) + + -- It's important to register in build order, because ghc-pkg + -- will complain if a dependency is not registered. + let componentsToRegister = + neededTargetsInBuildOrder' pkg_descr lbi0 (map nodeKey targets) + + (_, ipi_mbs) <- mapAccumM `flip` installedPkgs lbi0 `flip` componentsToRegister $ \index tgt -> - case targetComponent tgt of - CLib lib -> do - let clbi = targetCLBI tgt - lbi = lbi0 { installedPkgs = index } - ipi <- generateOne pkg_descr lib lbi clbi flags - return (Index.insert ipi index, Just ipi) - _ -> return (index, Nothing) - - registerAll pkg_descr lbi0 flags (catMaybes ipi_mbs) - where - verbosity = fromFlag (regVerbosity flags) - -generateOne :: PackageDescription -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo - -> RegisterFlags - -> IO InstalledPackageInfo -generateOne pkg lib lbi clbi regFlags - = do - absPackageDBs <- absolutePackageDBPaths packageDbs - installedPkgInfo <- generateRegistrationInfo - verbosity pkg lib lbi clbi inplace reloc distPref - (registrationPackageDB absPackageDBs) + case targetComponent tgt of + CLib lib -> do + let clbi = targetCLBI tgt + lbi = lbi0{installedPkgs = index} + ipi <- generateOne pkg_descr lib lbi clbi flags + return (Index.insert ipi index, Just ipi) + _ -> return (index, Nothing) + + registerAll pkg_descr lbi0 flags (catMaybes ipi_mbs) + where + verbosity = fromFlag (regVerbosity flags) + +generateOne + :: PackageDescription + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> RegisterFlags + -> IO InstalledPackageInfo +generateOne pkg lib lbi clbi regFlags = + do + absPackageDBs <- absolutePackageDBPaths packageDbs + installedPkgInfo <- + generateRegistrationInfo + verbosity + pkg + lib + lbi + clbi + inplace + reloc + distPref + (registrationPackageDB absPackageDBs) info verbosity (IPI.showInstalledPackageInfo installedPkgInfo) return installedPkgInfo where - inplace = fromFlag (regInPlace regFlags) - reloc = relocatable lbi + inplace = fromFlag (regInPlace regFlags) + reloc = relocatable lbi -- FIXME: there's really no guarantee this will work. -- registering into a totally different db stack can -- fail if dependencies cannot be satisfied. - packageDbs = nub $ withPackageDB lbi - ++ maybeToList (flagToMaybe (regPackageDB regFlags)) - distPref = fromFlag (regDistPref regFlags) + packageDbs = + nub $ + withPackageDB lbi + ++ maybeToList (flagToMaybe (regPackageDB regFlags)) + distPref = fromFlag (regDistPref regFlags) verbosity = fromFlag (regVerbosity regFlags) -registerAll :: PackageDescription -> LocalBuildInfo -> RegisterFlags - -> [InstalledPackageInfo] - -> IO () -registerAll pkg lbi regFlags ipis - = do +registerAll + :: PackageDescription + -> LocalBuildInfo + -> RegisterFlags + -> [InstalledPackageInfo] + -> IO () +registerAll pkg lbi regFlags ipis = + do when (fromFlag (regPrintId regFlags)) $ do for_ ipis $ \installedPkgInfo -> -- Only print the public library's IPI - when (packageId installedPkgInfo == packageId pkg - && IPI.sourceLibName installedPkgInfo == LMainLibName) $ - putStrLn (prettyShow (IPI.installedUnitId installedPkgInfo)) + when + ( packageId installedPkgInfo == packageId pkg + && IPI.sourceLibName installedPkgInfo == LMainLibName + ) + $ putStrLn (prettyShow (IPI.installedUnitId installedPkgInfo)) - -- Three different modes: + -- Three different modes: case () of - _ | modeGenerateRegFile -> writeRegistrationFileOrDirectory - | modeGenerateRegScript -> writeRegisterScript - | otherwise -> do - for_ ipis $ \ipi -> do - setupMessage' verbosity "Registering" (packageId pkg) - (CLibName (IPI.sourceLibName ipi)) - (Just (IPI.instantiatedWith ipi)) - registerPackage verbosity (compiler lbi) (withPrograms lbi) - packageDbs ipi HcPkg.defaultRegisterOptions - + _ + | modeGenerateRegFile -> writeRegistrationFileOrDirectory + | modeGenerateRegScript -> writeRegisterScript + | otherwise -> do + for_ ipis $ \ipi -> do + setupMessage' + verbosity + "Registering" + (packageId pkg) + (CLibName (IPI.sourceLibName ipi)) + (Just (IPI.instantiatedWith ipi)) + registerPackage + verbosity + (compiler lbi) + (withPrograms lbi) + packageDbs + ipi + HcPkg.defaultRegisterOptions where modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) - regFile = fromMaybe (prettyShow (packageId pkg) <.> "conf") - (fromFlag (regGenPkgConf regFlags)) + regFile = + fromMaybe + (prettyShow (packageId pkg) <.> "conf") + (fromFlag (regGenPkgConf regFlags)) modeGenerateRegScript = fromFlag (regGenScript regFlags) -- FIXME: there's really no guarantee this will work. -- registering into a totally different db stack can -- fail if dependencies cannot be satisfied. - packageDbs = nub $ withPackageDB lbi - ++ maybeToList (flagToMaybe (regPackageDB regFlags)) + packageDbs = + nub $ + withPackageDB lbi + ++ maybeToList (flagToMaybe (regPackageDB regFlags)) verbosity = fromFlag (regVerbosity regFlags) writeRegistrationFileOrDirectory = do @@ -197,172 +228,247 @@ registerAll pkg lbi regFlags ipis createDirectory regFile let num_ipis = length ipis lpad m xs = replicate (m - length ys) '0' ++ ys - where ys = take m xs + where + ys = take m xs number i = lpad (length (show num_ipis)) (show i) - for_ (zip ([1..] :: [Int]) ipis) $ \(i, installedPkgInfo) -> - writeUTF8File (regFile (number i ++ "-" ++ prettyShow (IPI.installedUnitId installedPkgInfo))) - (IPI.showInstalledPackageInfo installedPkgInfo) + for_ (zip ([1 ..] :: [Int]) ipis) $ \(i, installedPkgInfo) -> + writeUTF8File + (regFile (number i ++ "-" ++ prettyShow (IPI.installedUnitId installedPkgInfo))) + (IPI.showInstalledPackageInfo installedPkgInfo) writeRegisterScript = case compilerFlavor (compiler lbi) of UHC -> notice verbosity "Registration scripts not needed for uhc" - _ -> withHcPkg verbosity - "Registration scripts are not implemented for this compiler" - (compiler lbi) (withPrograms lbi) - (writeHcPkgRegisterScript verbosity ipis packageDbs) - - -generateRegistrationInfo :: Verbosity - -> PackageDescription - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Bool - -> Bool - -> FilePath - -> PackageDB - -> IO InstalledPackageInfo + _ -> + withHcPkg + verbosity + "Registration scripts are not implemented for this compiler" + (compiler lbi) + (withPrograms lbi) + (writeHcPkgRegisterScript verbosity ipis packageDbs) + +generateRegistrationInfo + :: Verbosity + -> PackageDescription + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Bool + -> Bool + -> FilePath + -> PackageDB + -> IO InstalledPackageInfo generateRegistrationInfo verbosity pkg lib lbi clbi inplace reloc distPref packageDb = do - --TODO: eliminate pwd! + -- TODO: eliminate pwd! pwd <- getCurrentDirectory installedPkgInfo <- if inplace - -- NB: With an inplace installation, the user may run './Setup + then -- NB: With an inplace installation, the user may run './Setup -- build' to update the library files, without reregistering. -- In this case, it is critical that the ABI hash not flip. - then return (inplaceInstalledPackageInfo pwd distPref - pkg (mkAbiHash "inplace") lib lbi clbi) - else do + + return + ( inplaceInstalledPackageInfo + pwd + distPref + pkg + (mkAbiHash "inplace") + lib + lbi + clbi + ) + else do abi_hash <- abiHash verbosity pkg distPref lbi lib clbi if reloc - then relocRegistrationInfo verbosity - pkg lib lbi clbi abi_hash packageDb - else return (absoluteInstalledPackageInfo - pkg abi_hash lib lbi clbi) - + then + relocRegistrationInfo + verbosity + pkg + lib + lbi + clbi + abi_hash + packageDb + else + return + ( absoluteInstalledPackageInfo + pkg + abi_hash + lib + lbi + clbi + ) return installedPkgInfo -- | Compute the 'AbiHash' of a library that we built inplace. -abiHash :: Verbosity - -> PackageDescription - -> FilePath - -> LocalBuildInfo - -> Library - -> ComponentLocalBuildInfo - -> IO AbiHash +abiHash + :: Verbosity + -> PackageDescription + -> FilePath + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO AbiHash abiHash verbosity pkg distPref lbi lib clbi = - case compilerFlavor comp of - GHC -> do - fmap mkAbiHash $ GHC.libAbiHash verbosity pkg lbi' lib clbi - GHCJS -> do - fmap mkAbiHash $ GHCJS.libAbiHash verbosity pkg lbi' lib clbi - _ -> return (mkAbiHash "") + case compilerFlavor comp of + GHC -> do + fmap mkAbiHash $ GHC.libAbiHash verbosity pkg lbi' lib clbi + GHCJS -> do + fmap mkAbiHash $ GHCJS.libAbiHash verbosity pkg lbi' lib clbi + _ -> return (mkAbiHash "") where comp = compiler lbi - lbi' = lbi { - withPackageDB = withPackageDB lbi - ++ [SpecificPackageDB (internalPackageDBPath lbi distPref)] - } - -relocRegistrationInfo :: Verbosity - -> PackageDescription - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> AbiHash - -> PackageDB - -> IO InstalledPackageInfo + lbi' = + lbi + { withPackageDB = + withPackageDB lbi + ++ [SpecificPackageDB (internalPackageDBPath lbi distPref)] + } + +relocRegistrationInfo + :: Verbosity + -> PackageDescription + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> AbiHash + -> PackageDB + -> IO InstalledPackageInfo relocRegistrationInfo verbosity pkg lib lbi clbi abi_hash packageDb = case (compilerFlavor (compiler lbi)) of - GHC -> do fs <- GHC.pkgRoot verbosity lbi packageDb - return (relocatableInstalledPackageInfo - pkg abi_hash lib lbi clbi fs) - _ -> die' verbosity - "Distribution.Simple.Register.relocRegistrationInfo: \ - \not implemented for this compiler" + GHC -> do + fs <- GHC.pkgRoot verbosity lbi packageDb + return + ( relocatableInstalledPackageInfo + pkg + abi_hash + lib + lbi + clbi + fs + ) + _ -> + die' + verbosity + "Distribution.Simple.Register.relocRegistrationInfo: \ + \not implemented for this compiler" initPackageDB :: Verbosity -> Compiler -> ProgramDb -> FilePath -> IO () initPackageDB verbosity comp progdb dbPath = - createPackageDB verbosity comp progdb False dbPath + createPackageDB verbosity comp progdb False dbPath -- | Create an empty package DB at the specified location. -createPackageDB :: Verbosity -> Compiler -> ProgramDb -> Bool - -> FilePath -> IO () +createPackageDB + :: Verbosity + -> Compiler + -> ProgramDb + -> Bool + -> FilePath + -> IO () createPackageDB verbosity comp progdb preferCompat dbPath = - case compilerFlavor comp of - GHC -> HcPkg.init (GHC.hcPkgInfo progdb) verbosity preferCompat dbPath - GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity False dbPath - UHC -> return () - HaskellSuite _ -> HaskellSuite.initPackageDB verbosity progdb dbPath - _ -> die' verbosity $ - "Distribution.Simple.Register.createPackageDB: " - ++ "not implemented for this compiler" + case compilerFlavor comp of + GHC -> HcPkg.init (GHC.hcPkgInfo progdb) verbosity preferCompat dbPath + GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity False dbPath + UHC -> return () + HaskellSuite _ -> HaskellSuite.initPackageDB verbosity progdb dbPath + _ -> + die' verbosity $ + "Distribution.Simple.Register.createPackageDB: " + ++ "not implemented for this compiler" doesPackageDBExist :: FilePath -> IO Bool doesPackageDBExist dbPath = do - -- currently one impl for all compiler flavours, but could change if needed - dir_exists <- doesDirectoryExist dbPath - if dir_exists - then return True - else doesFileExist dbPath + -- currently one impl for all compiler flavours, but could change if needed + dir_exists <- doesDirectoryExist dbPath + if dir_exists + then return True + else doesFileExist dbPath deletePackageDB :: FilePath -> IO () deletePackageDB dbPath = do - -- currently one impl for all compiler flavours, but could change if needed - dir_exists <- doesDirectoryExist dbPath - if dir_exists - then removeDirectoryRecursive dbPath - else do file_exists <- doesFileExist dbPath - when file_exists $ removeFile dbPath + -- currently one impl for all compiler flavours, but could change if needed + dir_exists <- doesDirectoryExist dbPath + if dir_exists + then removeDirectoryRecursive dbPath + else do + file_exists <- doesFileExist dbPath + when file_exists $ removeFile dbPath -- | Run @hc-pkg@ using a given package DB stack, directly forwarding the -- provided command-line arguments to it. -invokeHcPkg :: Verbosity -> Compiler -> ProgramDb -> PackageDBStack - -> [String] -> IO () +invokeHcPkg + :: Verbosity + -> Compiler + -> ProgramDb + -> PackageDBStack + -> [String] + -> IO () invokeHcPkg verbosity comp progdb dbStack extraArgs = - withHcPkg verbosity "invokeHcPkg" comp progdb + withHcPkg + verbosity + "invokeHcPkg" + comp + progdb (\hpi -> HcPkg.invoke hpi verbosity dbStack extraArgs) -withHcPkg :: Verbosity -> String -> Compiler -> ProgramDb - -> (HcPkg.HcPkgInfo -> IO a) -> IO a +withHcPkg + :: Verbosity + -> String + -> Compiler + -> ProgramDb + -> (HcPkg.HcPkgInfo -> IO a) + -> IO a withHcPkg verbosity name comp progdb f = case compilerFlavor comp of - GHC -> f (GHC.hcPkgInfo progdb) + GHC -> f (GHC.hcPkgInfo progdb) GHCJS -> f (GHCJS.hcPkgInfo progdb) - _ -> die' verbosity ("Distribution.Simple.Register." ++ name ++ ":\ - \not implemented for this compiler") - -registerPackage :: Verbosity - -> Compiler - -> ProgramDb - -> PackageDBStack - -> InstalledPackageInfo - -> HcPkg.RegisterOptions - -> IO () + _ -> + die' + verbosity + ( "Distribution.Simple.Register." + ++ name + ++ ":\ + \not implemented for this compiler" + ) + +registerPackage + :: Verbosity + -> Compiler + -> ProgramDb + -> PackageDBStack + -> InstalledPackageInfo + -> HcPkg.RegisterOptions + -> IO () registerPackage verbosity comp progdb packageDbs installedPkgInfo registerOptions = case compilerFlavor comp of - GHC -> GHC.registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions + GHC -> GHC.registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions GHCJS -> GHCJS.registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions - HaskellSuite {} -> - HaskellSuite.registerPackage verbosity progdb packageDbs installedPkgInfo - _ | HcPkg.registerMultiInstance registerOptions - -> die' verbosity "Registering multiple package instances is not yet supported for this compiler" - UHC -> UHC.registerPackage verbosity comp progdb packageDbs installedPkgInfo - _ -> die' verbosity "Registering is not implemented for this compiler" - -writeHcPkgRegisterScript :: Verbosity - -> [InstalledPackageInfo] - -> PackageDBStack - -> HcPkg.HcPkgInfo - -> IO () + HaskellSuite{} -> + HaskellSuite.registerPackage verbosity progdb packageDbs installedPkgInfo + _ + | HcPkg.registerMultiInstance registerOptions -> + die' verbosity "Registering multiple package instances is not yet supported for this compiler" + UHC -> UHC.registerPackage verbosity comp progdb packageDbs installedPkgInfo + _ -> die' verbosity "Registering is not implemented for this compiler" + +writeHcPkgRegisterScript + :: Verbosity + -> [InstalledPackageInfo] + -> PackageDBStack + -> HcPkg.HcPkgInfo + -> IO () writeHcPkgRegisterScript verbosity ipis packageDbs hpi = do let genScript installedPkgInfo = - let invocation = HcPkg.registerInvocation hpi Verbosity.normal - packageDbs installedPkgInfo - HcPkg.defaultRegisterOptions - in invocationAsSystemScript buildOS invocation + let invocation = + HcPkg.registerInvocation + hpi + Verbosity.normal + packageDbs + installedPkgInfo + HcPkg.defaultRegisterOptions + in invocationAsSystemScript buildOS invocation scripts = map genScript ipis -- TODO: Do something more robust here regScript = unlines scripts @@ -373,19 +479,18 @@ writeHcPkgRegisterScript verbosity ipis packageDbs hpi = do regScriptFileName :: FilePath regScriptFileName = case buildOS of - Windows -> "register.bat" - _ -> "register.sh" - + Windows -> "register.bat" + _ -> "register.sh" -- ----------------------------------------------------------------------------- -- Making the InstalledPackageInfo -- | Construct 'InstalledPackageInfo' for a library in a package, given a set -- of installation directories. --- generalInstalledPackageInfo - :: ([FilePath] -> [FilePath]) -- ^ Translate relative include dir paths to - -- absolute paths. + :: ([FilePath] -> [FilePath]) + -- ^ Translate relative include dir paths to + -- absolute paths. -> PackageDescription -> AbiHash -> Library @@ -394,87 +499,94 @@ generalInstalledPackageInfo -> InstallDirs FilePath -> InstalledPackageInfo generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDirs = - IPI.InstalledPackageInfo { - IPI.sourcePackageId = packageId pkg, - IPI.installedUnitId = componentUnitId clbi, - IPI.installedComponentId_ = componentComponentId clbi, - IPI.instantiatedWith = componentInstantiatedWith clbi, - IPI.sourceLibName = libName lib, - IPI.compatPackageKey = componentCompatPackageKey clbi, - -- If GHC >= 8.4 we register with SDPX, otherwise with legacy license - IPI.license = + IPI.InstalledPackageInfo + { IPI.sourcePackageId = packageId pkg + , IPI.installedUnitId = componentUnitId clbi + , IPI.installedComponentId_ = componentComponentId clbi + , IPI.instantiatedWith = componentInstantiatedWith clbi + , IPI.sourceLibName = libName lib + , IPI.compatPackageKey = componentCompatPackageKey clbi + , -- If GHC >= 8.4 we register with SDPX, otherwise with legacy license + IPI.license = if ghc84 - then Left $ either id licenseToSPDX $ licenseRaw pkg - else Right $ either licenseFromSPDX id $ licenseRaw pkg, - IPI.copyright = copyright pkg, - IPI.maintainer = maintainer pkg, - IPI.author = author pkg, - IPI.stability = stability pkg, - IPI.homepage = homepage pkg, - IPI.pkgUrl = pkgUrl pkg, - IPI.synopsis = synopsis pkg, - IPI.description = description pkg, - IPI.category = category pkg, - IPI.abiHash = abi_hash, - IPI.indefinite = componentIsIndefinite clbi, - IPI.exposed = libExposed lib, - IPI.exposedModules = componentExposedModules clbi - -- add virtual modules into the list of exposed modules for the - -- package database as well. - ++ map (\name -> IPI.ExposedModule name Nothing) (virtualModules bi), - IPI.hiddenModules = otherModules bi, - IPI.trusted = IPI.trusted IPI.emptyInstalledPackageInfo, - IPI.importDirs = [ libdir installDirs | hasModules ], - IPI.libraryDirs = libdirs, - IPI.libraryDirsStatic = libdirsStatic, - IPI.libraryDynDirs = dynlibdirs, - IPI.dataDir = datadir installDirs, - IPI.hsLibraries = (if hasLibrary - then [getHSLibraryName (componentUnitId clbi)] - else []) ++ extraBundledLibs bi, - IPI.extraLibraries = extraLibs bi, - IPI.extraLibrariesStatic = extraLibsStatic bi, - IPI.extraGHCiLibraries = extraGHCiLibs bi, - IPI.includeDirs = absinc ++ adjustRelIncDirs relinc, - IPI.includes = includes bi, - IPI.depends = depends, - IPI.abiDepends = [], -- due to #5465 - IPI.ccOptions = [], -- Note. NOT ccOptions bi! - -- We don't want cc-options to be propagated - -- to C compilations in other packages. - IPI.cxxOptions = [], -- Also. NOT cxxOptions bi! - IPI.ldOptions = ldOptions bi, - IPI.frameworks = frameworks bi, - IPI.frameworkDirs = extraFrameworkDirs bi, - IPI.haddockInterfaces = [haddockdir installDirs haddockName pkg], - IPI.haddockHTMLs = [htmldir installDirs], - IPI.pkgRoot = Nothing, - IPI.libVisibility = libVisibility lib - } + then Left $ either id licenseToSPDX $ licenseRaw pkg + else Right $ either licenseFromSPDX id $ licenseRaw pkg + , IPI.copyright = copyright pkg + , IPI.maintainer = maintainer pkg + , IPI.author = author pkg + , IPI.stability = stability pkg + , IPI.homepage = homepage pkg + , IPI.pkgUrl = pkgUrl pkg + , IPI.synopsis = synopsis pkg + , IPI.description = description pkg + , IPI.category = category pkg + , IPI.abiHash = abi_hash + , IPI.indefinite = componentIsIndefinite clbi + , IPI.exposed = libExposed lib + , IPI.exposedModules = + componentExposedModules clbi + -- add virtual modules into the list of exposed modules for the + -- package database as well. + ++ map (\name -> IPI.ExposedModule name Nothing) (virtualModules bi) + , IPI.hiddenModules = otherModules bi + , IPI.trusted = IPI.trusted IPI.emptyInstalledPackageInfo + , IPI.importDirs = [libdir installDirs | hasModules] + , IPI.libraryDirs = libdirs + , IPI.libraryDirsStatic = libdirsStatic + , IPI.libraryDynDirs = dynlibdirs + , IPI.dataDir = datadir installDirs + , IPI.hsLibraries = + ( if hasLibrary + then [getHSLibraryName (componentUnitId clbi)] + else [] + ) + ++ extraBundledLibs bi + , IPI.extraLibraries = extraLibs bi + , IPI.extraLibrariesStatic = extraLibsStatic bi + , IPI.extraGHCiLibraries = extraGHCiLibs bi + , IPI.includeDirs = absinc ++ adjustRelIncDirs relinc + , IPI.includes = includes bi + , IPI.depends = depends + , IPI.abiDepends = [] -- due to #5465 + , IPI.ccOptions = [] -- Note. NOT ccOptions bi! + -- We don't want cc-options to be propagated + -- to C compilations in other packages. + , IPI.cxxOptions = [] -- Also. NOT cxxOptions bi! + , IPI.ldOptions = ldOptions bi + , IPI.frameworks = frameworks bi + , IPI.frameworkDirs = extraFrameworkDirs bi + , IPI.haddockInterfaces = [haddockdir installDirs haddockName pkg] + , IPI.haddockHTMLs = [htmldir installDirs] + , IPI.pkgRoot = Nothing + , IPI.libVisibility = libVisibility lib + } where ghc84 = case compilerId $ compiler lbi of - CompilerId GHC v -> v >= mkVersion [8, 4] - _ -> False + CompilerId GHC v -> v >= mkVersion [8, 4] + _ -> False bi = libBuildInfo lib - --TODO: unclear what the root cause of the + -- TODO: unclear what the root cause of the -- duplication is, but we nub it here for now: depends = ordNub $ map fst (componentPackageDeps clbi) (absinc, relinc) = partition isAbsolute (includeDirs bi) hasModules = not $ null (allLibModules lib clbi) comp = compiler lbi - hasLibrary = (hasModules || not (null (cSources bi)) - || not (null (asmSources bi)) - || not (null (cmmSources bi)) - || not (null (cxxSources bi)) - || (not (null (jsSources bi)) && hasJsSupport)) - && not (componentIsIndefinite clbi) + hasLibrary = + ( hasModules + || not (null (cSources bi)) + || not (null (asmSources bi)) + || not (null (cmmSources bi)) + || not (null (cxxSources bi)) + || (not (null (jsSources bi)) && hasJsSupport) + ) + && not (componentIsIndefinite clbi) hasJsSupport = case hostPlatform lbi of Platform JavaScript _ -> True - _ -> False + _ -> False libdirsStatic | hasLibrary = libdir installDirs : extraLibDirsStaticOrFallback - | otherwise = extraLibDirsStaticOrFallback + | otherwise = extraLibDirsStaticOrFallback where -- If no static library dirs were given, the package likely makes no -- distinction between fully static linking and otherwise. @@ -483,128 +595,161 @@ generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDi [] -> extraLibDirs bi dirs -> dirs (libdirs, dynlibdirs) - | not hasLibrary - = (extraLibDirs bi, []) + | not hasLibrary = + (extraLibDirs bi, []) -- the dynamic-library-dirs defaults to the library-dirs if not specified, -- so this works whether the dynamic-library-dirs field is supported or not - | libraryDynDirSupported comp - = (libdir installDirs : extraLibDirs bi, - dynlibdir installDirs : extraLibDirs bi) + | libraryDynDirSupported comp = + ( libdir installDirs : extraLibDirs bi + , dynlibdir installDirs : extraLibDirs bi + ) + | otherwise = + (libdir installDirs : dynlibdir installDirs : extraLibDirs bi, []) - | otherwise - = (libdir installDirs : dynlibdir installDirs : extraLibDirs bi, []) - -- the compiler doesn't understand the dynamic-library-dirs field so we - -- add the dyn directory to the "normal" list in the library-dirs field +-- the compiler doesn't understand the dynamic-library-dirs field so we +-- add the dyn directory to the "normal" list in the library-dirs field -- | Construct 'InstalledPackageInfo' for a library that is in place in the -- build tree. -- -- This function knows about the layout of in place packages. --- -inplaceInstalledPackageInfo :: FilePath -- ^ top of the build tree - -> FilePath -- ^ location of the dist tree - -> PackageDescription - -> AbiHash - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> InstalledPackageInfo +inplaceInstalledPackageInfo + :: FilePath + -- ^ top of the build tree + -> FilePath + -- ^ location of the dist tree + -> PackageDescription + -> AbiHash + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> InstalledPackageInfo inplaceInstalledPackageInfo inplaceDir distPref pkg abi_hash lib lbi clbi = - generalInstalledPackageInfo adjustRelativeIncludeDirs - pkg abi_hash lib lbi clbi installDirs + generalInstalledPackageInfo + adjustRelativeIncludeDirs + pkg + abi_hash + lib + lbi + clbi + installDirs where adjustRelativeIncludeDirs = concatMap $ \d -> - [ inplaceDir d -- local include-dir - , inplaceDir libTargetDir d -- autogen include-dir + [ inplaceDir d -- local include-dir + , inplaceDir libTargetDir d -- autogen include-dir ] libTargetDir = componentBuildDir lbi clbi installDirs = - (absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest) { - libdir = inplaceDir libTargetDir, - dynlibdir = inplaceDir libTargetDir, - datadir = inplaceDir dataDir pkg, - docdir = inplaceDocdir, - htmldir = inplaceHtmldir, - haddockdir = inplaceHtmldir - } - inplaceDocdir = inplaceDir distPref "doc" + (absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest) + { libdir = inplaceDir libTargetDir + , dynlibdir = inplaceDir libTargetDir + , datadir = inplaceDir dataDir pkg + , docdir = inplaceDocdir + , htmldir = inplaceHtmldir + , haddockdir = inplaceHtmldir + } + inplaceDocdir = inplaceDir distPref "doc" inplaceHtmldir = inplaceDocdir "html" prettyShow (packageName pkg) - -- | Construct 'InstalledPackageInfo' for the final install location of a -- library package. -- -- This function knows about the layout of installed packages. --- -absoluteInstalledPackageInfo :: PackageDescription - -> AbiHash - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> InstalledPackageInfo +absoluteInstalledPackageInfo + :: PackageDescription + -> AbiHash + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> InstalledPackageInfo absoluteInstalledPackageInfo pkg abi_hash lib lbi clbi = - generalInstalledPackageInfo adjustReativeIncludeDirs - pkg abi_hash lib lbi clbi installDirs + generalInstalledPackageInfo + adjustReativeIncludeDirs + pkg + abi_hash + lib + lbi + clbi + installDirs where -- For installed packages we install all include files into one dir, -- whereas in the build tree they may live in multiple local dirs. adjustReativeIncludeDirs _ | null (installIncludes bi) = [] - | otherwise = [includedir installDirs] + | otherwise = [includedir installDirs] bi = libBuildInfo lib installDirs = absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest - -relocatableInstalledPackageInfo :: PackageDescription - -> AbiHash - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> FilePath - -> InstalledPackageInfo +relocatableInstalledPackageInfo + :: PackageDescription + -> AbiHash + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> InstalledPackageInfo relocatableInstalledPackageInfo pkg abi_hash lib lbi clbi pkgroot = - generalInstalledPackageInfo adjustReativeIncludeDirs - pkg abi_hash lib lbi clbi installDirs + generalInstalledPackageInfo + adjustReativeIncludeDirs + pkg + abi_hash + lib + lbi + clbi + installDirs where -- For installed packages we install all include files into one dir, -- whereas in the build tree they may live in multiple local dirs. adjustReativeIncludeDirs _ | null (installIncludes bi) = [] - | otherwise = [includedir installDirs] + | otherwise = [includedir installDirs] bi = libBuildInfo lib - installDirs = fmap (("${pkgroot}" ) . shortRelativePath pkgroot) - $ absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest + installDirs = + fmap (("${pkgroot}" ) . shortRelativePath pkgroot) $ + absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest -- ----------------------------------------------------------------------------- -- Unregistration unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO () unregister pkg lbi regFlags = do - let pkgid = packageId pkg + let pkgid = packageId pkg genScript = fromFlag (regGenScript regFlags) verbosity = fromFlag (regVerbosity regFlags) - packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi)) - (regPackageDB regFlags) + packageDb = + fromFlagOrDefault + (registrationPackageDB (withPackageDB lbi)) + (regPackageDB regFlags) unreg hpi = - let invocation = HcPkg.unregisterInvocation - hpi Verbosity.normal packageDb pkgid - in if genScript - then writeFileAtomic unregScriptFileName - (BS.Char8.pack $ invocationAsSystemScript buildOS invocation) - else runProgramInvocation verbosity invocation + let invocation = + HcPkg.unregisterInvocation + hpi + Verbosity.normal + packageDb + pkgid + in if genScript + then + writeFileAtomic + unregScriptFileName + (BS.Char8.pack $ invocationAsSystemScript buildOS invocation) + else runProgramInvocation verbosity invocation setupMessage verbosity "Unregistering" pkgid - withHcPkg verbosity "unregistering is only implemented for GHC and GHCJS" - (compiler lbi) (withPrograms lbi) unreg + withHcPkg + verbosity + "unregistering is only implemented for GHC and GHCJS" + (compiler lbi) + (withPrograms lbi) + unreg unregScriptFileName :: FilePath unregScriptFileName = case buildOS of - Windows -> "unregister.bat" - _ -> "unregister.sh" + Windows -> "unregister.bat" + _ -> "unregister.sh" internalPackageDBPath :: LocalBuildInfo -> FilePath -> FilePath internalPackageDBPath lbi distPref = - case compilerFlavor (compiler lbi) of - UHC -> UHC.inplacePackageDbPath lbi - _ -> distPref "package.conf.inplace" + case compilerFlavor (compiler lbi) of + UHC -> UHC.inplacePackageDbPath lbi + _ -> distPref "package.conf.inplace" diff --git a/Cabal/src/Distribution/Simple/Setup.hs b/Cabal/src/Distribution/Simple/Setup.hs index e03cafd7305..b1758d1ee96 100644 --- a/Cabal/src/Distribution/Simple/Setup.hs +++ b/Cabal/src/Distribution/Simple/Setup.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Setup -- Copyright : Isaac Jones 2003-2004 @@ -31,53 +32,107 @@ -- needs is to unify it with the code for managing sets of fields that can be -- read and written from files. This would allow us to save configure flags in -- config files. - -module Distribution.Simple.Setup ( - - GlobalFlags(..), emptyGlobalFlags, defaultGlobalFlags, globalCommand, - ConfigFlags(..), emptyConfigFlags, defaultConfigFlags, configureCommand, - configPrograms, - configAbsolutePaths, readPackageDb, readPackageDbList, showPackageDb, showPackageDbList, - CopyFlags(..), emptyCopyFlags, defaultCopyFlags, copyCommand, - InstallFlags(..), emptyInstallFlags, defaultInstallFlags, installCommand, - HaddockTarget(..), - HaddockFlags(..), emptyHaddockFlags, defaultHaddockFlags, haddockCommand, - Visibility(..), - HaddockProjectFlags(..), emptyHaddockProjectFlags, defaultHaddockProjectFlags, haddockProjectCommand, - HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand, - BuildFlags(..), emptyBuildFlags, defaultBuildFlags, buildCommand, - DumpBuildInfo(..), - ReplFlags(..), defaultReplFlags, replCommand, - ReplOptions(..), - CleanFlags(..), emptyCleanFlags, defaultCleanFlags, cleanCommand, - RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand, - unregisterCommand, - SDistFlags(..), emptySDistFlags, defaultSDistFlags, sdistCommand, - TestFlags(..), emptyTestFlags, defaultTestFlags, testCommand, - TestShowDetails(..), - BenchmarkFlags(..), emptyBenchmarkFlags, - defaultBenchmarkFlags, benchmarkCommand, - CopyDest(..), - configureArgs, configureOptions, configureCCompiler, configureLinker, - buildOptions, haddockOptions, haddockProjectOptions, installDirsOptions, - testOptions', benchmarkOptions', - programDbOptions, programDbPaths', - programFlagsDescription, - replOptions, - splitArgs, - - defaultDistPref, optionDistPref, - - Flag(..), - toFlag, - fromFlag, - fromFlagOrDefault, - flagToMaybe, - flagToList, - maybeToFlag, - BooleanFlag(..), - boolOpt, boolOpt', trueArg, falseArg, - optionVerbosity, optionNumJobs) where +module Distribution.Simple.Setup + ( GlobalFlags (..) + , emptyGlobalFlags + , defaultGlobalFlags + , globalCommand + , ConfigFlags (..) + , emptyConfigFlags + , defaultConfigFlags + , configureCommand + , configPrograms + , configAbsolutePaths + , readPackageDb + , readPackageDbList + , showPackageDb + , showPackageDbList + , CopyFlags (..) + , emptyCopyFlags + , defaultCopyFlags + , copyCommand + , InstallFlags (..) + , emptyInstallFlags + , defaultInstallFlags + , installCommand + , HaddockTarget (..) + , HaddockFlags (..) + , emptyHaddockFlags + , defaultHaddockFlags + , haddockCommand + , Visibility (..) + , HaddockProjectFlags (..) + , emptyHaddockProjectFlags + , defaultHaddockProjectFlags + , haddockProjectCommand + , HscolourFlags (..) + , emptyHscolourFlags + , defaultHscolourFlags + , hscolourCommand + , BuildFlags (..) + , emptyBuildFlags + , defaultBuildFlags + , buildCommand + , DumpBuildInfo (..) + , ReplFlags (..) + , defaultReplFlags + , replCommand + , ReplOptions (..) + , CleanFlags (..) + , emptyCleanFlags + , defaultCleanFlags + , cleanCommand + , RegisterFlags (..) + , emptyRegisterFlags + , defaultRegisterFlags + , registerCommand + , unregisterCommand + , SDistFlags (..) + , emptySDistFlags + , defaultSDistFlags + , sdistCommand + , TestFlags (..) + , emptyTestFlags + , defaultTestFlags + , testCommand + , TestShowDetails (..) + , BenchmarkFlags (..) + , emptyBenchmarkFlags + , defaultBenchmarkFlags + , benchmarkCommand + , CopyDest (..) + , configureArgs + , configureOptions + , configureCCompiler + , configureLinker + , buildOptions + , haddockOptions + , haddockProjectOptions + , installDirsOptions + , testOptions' + , benchmarkOptions' + , programDbOptions + , programDbPaths' + , programFlagsDescription + , replOptions + , splitArgs + , defaultDistPref + , optionDistPref + , Flag (..) + , toFlag + , fromFlag + , fromFlagOrDefault + , flagToMaybe + , flagToList + , maybeToFlag + , BooleanFlag (..) + , boolOpt + , boolOpt' + , trueArg + , falseArg + , optionVerbosity + , optionNumJobs + ) where import Prelude () @@ -101,8 +156,8 @@ import Distribution.Simple.Setup.SDist import Distribution.Simple.Setup.Test -- The test cases kinda have to be rewritten from the ground up... :/ ---hunitTests :: [Test] ---hunitTests = +-- hunitTests :: [Test] +-- hunitTests = -- let m = [("ghc", GHC), ("nhc98", NHC), ("hugs", Hugs)] -- (flags, commands', unkFlags, ers) -- = getOpt Permute options ["configure", "foobar", "--prefix=/foo", "--ghc", "--nhc98", "--hugs", "--with-compiler=/comp", "--unknown1", "--unknown2", "--install-prefix=/foo", "--user", "--global"] diff --git a/Cabal/src/Distribution/Simple/Setup/Benchmark.hs b/Cabal/src/Distribution/Simple/Setup/Benchmark.hs index 0b854f551ae..3f657c22466 100644 --- a/Cabal/src/Distribution/Simple/Setup/Benchmark.hs +++ b/Cabal/src/Distribution/Simple/Setup/Benchmark.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Benchmark -- Copyright : Isaac Jones 2003-2004 @@ -16,79 +17,104 @@ -- -- Definition of the benchmarking command-line options. -- See: @Distribution.Simple.Setup@ - -module Distribution.Simple.Setup.Benchmark ( - BenchmarkFlags(..), emptyBenchmarkFlags, - defaultBenchmarkFlags, benchmarkCommand, - benchmarkOptions' +module Distribution.Simple.Setup.Benchmark + ( BenchmarkFlags (..) + , emptyBenchmarkFlags + , defaultBenchmarkFlags + , benchmarkCommand + , benchmarkOptions' ) where -import Prelude () import Distribution.Compat.Prelude hiding (get) +import Prelude () import Distribution.Simple.Command hiding (boolOpt, boolOpt') import Distribution.Simple.Flag -import Distribution.Simple.Utils import Distribution.Simple.InstallDirs +import Distribution.Simple.Utils import Distribution.Verbosity import Distribution.Simple.Setup.Common -- ------------------------------------------------------------ + -- * Benchmark flags + -- ------------------------------------------------------------ -data BenchmarkFlags = BenchmarkFlags { - benchmarkDistPref :: Flag FilePath, - benchmarkVerbosity :: Flag Verbosity, - benchmarkOptions :: [PathTemplate] - } deriving (Show, Generic, Typeable) +data BenchmarkFlags = BenchmarkFlags + { benchmarkDistPref :: Flag FilePath + , benchmarkVerbosity :: Flag Verbosity + , benchmarkOptions :: [PathTemplate] + } + deriving (Show, Generic, Typeable) defaultBenchmarkFlags :: BenchmarkFlags -defaultBenchmarkFlags = BenchmarkFlags { - benchmarkDistPref = NoFlag, - benchmarkVerbosity = Flag normal, - benchmarkOptions = [] - } +defaultBenchmarkFlags = + BenchmarkFlags + { benchmarkDistPref = NoFlag + , benchmarkVerbosity = Flag normal + , benchmarkOptions = [] + } benchmarkCommand :: CommandUI BenchmarkFlags -benchmarkCommand = CommandUI - { commandName = "bench" - , commandSynopsis = - "Run all/specific benchmarks." - , commandDescription = Just $ \ _pname -> wrapText $ - testOrBenchmarkHelpText "benchmark" - , commandNotes = Nothing - , commandUsage = usageAlternatives "bench" - [ "[FLAGS]" - , "BENCHCOMPONENTS [FLAGS]" - ] - , commandDefaultFlags = defaultBenchmarkFlags - , commandOptions = benchmarkOptions' - } +benchmarkCommand = + CommandUI + { commandName = "bench" + , commandSynopsis = + "Run all/specific benchmarks." + , commandDescription = Just $ \_pname -> + wrapText $ + testOrBenchmarkHelpText "benchmark" + , commandNotes = Nothing + , commandUsage = + usageAlternatives + "bench" + [ "[FLAGS]" + , "BENCHCOMPONENTS [FLAGS]" + ] + , commandDefaultFlags = defaultBenchmarkFlags + , commandOptions = benchmarkOptions' + } benchmarkOptions' :: ShowOrParseArgs -> [OptionField BenchmarkFlags] benchmarkOptions' showOrParseArgs = - [ optionVerbosity benchmarkVerbosity - (\v flags -> flags { benchmarkVerbosity = v }) + [ optionVerbosity + benchmarkVerbosity + (\v flags -> flags{benchmarkVerbosity = v}) , optionDistPref - benchmarkDistPref (\d flags -> flags { benchmarkDistPref = d }) - showOrParseArgs - , option [] ["benchmark-options"] - ("give extra options to benchmark executables " - ++ "(name templates can use $pkgid, $compiler, " - ++ "$os, $arch, $benchmark)") - benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) - (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs) - (const [])) - , option [] ["benchmark-option"] - ("give extra option to benchmark executables " - ++ "(no need to quote options containing spaces, " - ++ "name template can use $pkgid, $compiler, " - ++ "$os, $arch, $benchmark)") - benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) - (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) - (map fromPathTemplate)) + benchmarkDistPref + (\d flags -> flags{benchmarkDistPref = d}) + showOrParseArgs + , option + [] + ["benchmark-options"] + ( "give extra options to benchmark executables " + ++ "(name templates can use $pkgid, $compiler, " + ++ "$os, $arch, $benchmark)" + ) + benchmarkOptions + (\v flags -> flags{benchmarkOptions = v}) + ( reqArg' + "TEMPLATES" + (map toPathTemplate . splitArgs) + (const []) + ) + , option + [] + ["benchmark-option"] + ( "give extra option to benchmark executables " + ++ "(no need to quote options containing spaces, " + ++ "name template can use $pkgid, $compiler, " + ++ "$os, $arch, $benchmark)" + ) + benchmarkOptions + (\v flags -> flags{benchmarkOptions = v}) + ( reqArg' + "TEMPLATE" + (\x -> [toPathTemplate x]) + (map fromPathTemplate) + ) ] emptyBenchmarkFlags :: BenchmarkFlags @@ -100,4 +126,3 @@ instance Monoid BenchmarkFlags where instance Semigroup BenchmarkFlags where (<>) = gmappend - diff --git a/Cabal/src/Distribution/Simple/Setup/Build.hs b/Cabal/src/Distribution/Simple/Setup/Build.hs index 7adf67f3e01..68888532852 100644 --- a/Cabal/src/Distribution/Simple/Setup/Build.hs +++ b/Cabal/src/Distribution/Simple/Setup/Build.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Setup.Build -- Copyright : Isaac Jones 2003-2004 @@ -16,107 +17,130 @@ -- -- Definition of the build command-line options. -- See: @Distribution.Simple.Setup@ - -module Distribution.Simple.Setup.Build ( - BuildFlags(..), emptyBuildFlags, defaultBuildFlags, buildCommand, - DumpBuildInfo(..), - buildOptions, +module Distribution.Simple.Setup.Build + ( BuildFlags (..) + , emptyBuildFlags + , defaultBuildFlags + , buildCommand + , DumpBuildInfo (..) + , buildOptions ) where -import Prelude () import Distribution.Compat.Prelude hiding (get) +import Prelude () import Distribution.Simple.Command hiding (boolOpt, boolOpt') import Distribution.Simple.Flag -import Distribution.Simple.Utils import Distribution.Simple.Program -import Distribution.Verbosity +import Distribution.Simple.Utils import Distribution.Types.DumpBuildInfo +import Distribution.Verbosity import Distribution.Simple.Setup.Common -- ------------------------------------------------------------ + -- * Build flags + -- ------------------------------------------------------------ -data BuildFlags = BuildFlags { - buildProgramPaths :: [(String, FilePath)], - buildProgramArgs :: [(String, [String])], - buildDistPref :: Flag FilePath, - buildVerbosity :: Flag Verbosity, - buildNumJobs :: Flag (Maybe Int), - -- TODO: this one should not be here, it's just that the silly +data BuildFlags = BuildFlags + { buildProgramPaths :: [(String, FilePath)] + , buildProgramArgs :: [(String, [String])] + , buildDistPref :: Flag FilePath + , buildVerbosity :: Flag Verbosity + , buildNumJobs :: Flag (Maybe Int) + , -- TODO: this one should not be here, it's just that the silly -- UserHooks stop us from passing extra info in other ways - buildArgs :: [String], - buildCabalFilePath :: Flag FilePath + buildArgs :: [String] + , buildCabalFilePath :: Flag FilePath } deriving (Read, Show, Generic, Typeable) defaultBuildFlags :: BuildFlags -defaultBuildFlags = BuildFlags { - buildProgramPaths = mempty, - buildProgramArgs = [], - buildDistPref = mempty, - buildVerbosity = Flag normal, - buildNumJobs = mempty, - buildArgs = [], - buildCabalFilePath = mempty - } +defaultBuildFlags = + BuildFlags + { buildProgramPaths = mempty + , buildProgramArgs = [] + , buildDistPref = mempty + , buildVerbosity = Flag normal + , buildNumJobs = mempty + , buildArgs = [] + , buildCabalFilePath = mempty + } buildCommand :: ProgramDb -> CommandUI BuildFlags -buildCommand progDb = CommandUI - { commandName = "build" - , commandSynopsis = "Compile all/specific components." - , commandDescription = Just $ \_ -> wrapText $ - "Components encompass executables, tests, and benchmarks.\n" - ++ "\n" - ++ "Affected by configuration options, see `configure`.\n" - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " build " - ++ " All the components in the package\n" - ++ " " ++ pname ++ " build foo " - ++ " A component (i.e. lib, exe, test suite)\n\n" - ++ programFlagsDescription progDb ---TODO: re-enable once we have support for module/file targets --- ++ " " ++ pname ++ " build Foo.Bar " --- ++ " A module\n" --- ++ " " ++ pname ++ " build Foo/Bar.hs" --- ++ " A file\n\n" --- ++ "If a target is ambiguous it can be qualified with the component " --- ++ "name, e.g.\n" --- ++ " " ++ pname ++ " build foo:Foo.Bar\n" --- ++ " " ++ pname ++ " build testsuite1:Foo/Bar.hs\n" - , commandUsage = usageAlternatives "build" $ - [ "[FLAGS]" - , "COMPONENTS [FLAGS]" - ] - , commandDefaultFlags = defaultBuildFlags - , commandOptions = \showOrParseArgs -> - [ optionVerbosity - buildVerbosity (\v flags -> flags { buildVerbosity = v }) - - , optionDistPref - buildDistPref (\d flags -> flags { buildDistPref = d }) showOrParseArgs - ] - ++ buildOptions progDb showOrParseArgs - } - -buildOptions :: ProgramDb -> ShowOrParseArgs - -> [OptionField BuildFlags] +buildCommand progDb = + CommandUI + { commandName = "build" + , commandSynopsis = "Compile all/specific components." + , commandDescription = Just $ \_ -> + wrapText $ + "Components encompass executables, tests, and benchmarks.\n" + ++ "\n" + ++ "Affected by configuration options, see `configure`.\n" + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " + ++ pname + ++ " build " + ++ " All the components in the package\n" + ++ " " + ++ pname + ++ " build foo " + ++ " A component (i.e. lib, exe, test suite)\n\n" + ++ programFlagsDescription progDb + , -- TODO: re-enable once we have support for module/file targets + -- ++ " " ++ pname ++ " build Foo.Bar " + -- ++ " A module\n" + -- ++ " " ++ pname ++ " build Foo/Bar.hs" + -- ++ " A file\n\n" + -- ++ "If a target is ambiguous it can be qualified with the component " + -- ++ "name, e.g.\n" + -- ++ " " ++ pname ++ " build foo:Foo.Bar\n" + -- ++ " " ++ pname ++ " build testsuite1:Foo/Bar.hs\n" + commandUsage = + usageAlternatives "build" $ + [ "[FLAGS]" + , "COMPONENTS [FLAGS]" + ] + , commandDefaultFlags = defaultBuildFlags + , commandOptions = \showOrParseArgs -> + [ optionVerbosity + buildVerbosity + (\v flags -> flags{buildVerbosity = v}) + , optionDistPref + buildDistPref + (\d flags -> flags{buildDistPref = d}) + showOrParseArgs + ] + ++ buildOptions progDb showOrParseArgs + } + +buildOptions + :: ProgramDb + -> ShowOrParseArgs + -> [OptionField BuildFlags] buildOptions progDb showOrParseArgs = [ optionNumJobs - buildNumJobs (\v flags -> flags { buildNumJobs = v }) + buildNumJobs + (\v flags -> flags{buildNumJobs = v}) ] - - ++ programDbPaths progDb showOrParseArgs - buildProgramPaths (\v flags -> flags { buildProgramPaths = v}) - - ++ programDbOption progDb showOrParseArgs - buildProgramArgs (\v fs -> fs { buildProgramArgs = v }) - - ++ programDbOptions progDb showOrParseArgs - buildProgramArgs (\v flags -> flags { buildProgramArgs = v}) + ++ programDbPaths + progDb + showOrParseArgs + buildProgramPaths + (\v flags -> flags{buildProgramPaths = v}) + ++ programDbOption + progDb + showOrParseArgs + buildProgramArgs + (\v fs -> fs{buildProgramArgs = v}) + ++ programDbOptions + progDb + showOrParseArgs + buildProgramArgs + (\v flags -> flags{buildProgramArgs = v}) emptyBuildFlags :: BuildFlags emptyBuildFlags = mempty @@ -127,4 +151,3 @@ instance Monoid BuildFlags where instance Semigroup BuildFlags where (<>) = gmappend - diff --git a/Cabal/src/Distribution/Simple/Setup/Clean.hs b/Cabal/src/Distribution/Simple/Setup/Clean.hs index e2b723c22a7..b08a3cac75c 100644 --- a/Cabal/src/Distribution/Simple/Setup/Clean.hs +++ b/Cabal/src/Distribution/Simple/Setup/Clean.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Setup.Clean -- Copyright : Isaac Jones 2003-2004 @@ -16,14 +17,15 @@ -- -- Definition of the clean command-line options. -- See: @Distribution.Simple.Setup@ - -module Distribution.Simple.Setup.Clean ( - - CleanFlags(..), emptyCleanFlags, defaultCleanFlags, cleanCommand, +module Distribution.Simple.Setup.Clean + ( CleanFlags (..) + , emptyCleanFlags + , defaultCleanFlags + , cleanCommand ) where -import Prelude () import Distribution.Compat.Prelude hiding (get) +import Prelude () import Distribution.Simple.Command hiding (boolOpt, boolOpt') import Distribution.Simple.Flag @@ -32,47 +34,54 @@ import Distribution.Verbosity import Distribution.Simple.Setup.Common -- ------------------------------------------------------------ + -- * Clean flags + -- ------------------------------------------------------------ -data CleanFlags = CleanFlags { - cleanSaveConf :: Flag Bool, - cleanDistPref :: Flag FilePath, - cleanVerbosity :: Flag Verbosity, - cleanCabalFilePath :: Flag FilePath +data CleanFlags = CleanFlags + { cleanSaveConf :: Flag Bool + , cleanDistPref :: Flag FilePath + , cleanVerbosity :: Flag Verbosity + , cleanCabalFilePath :: Flag FilePath } deriving (Show, Generic, Typeable) defaultCleanFlags :: CleanFlags -defaultCleanFlags = CleanFlags { - cleanSaveConf = Flag False, - cleanDistPref = NoFlag, - cleanVerbosity = Flag normal, - cleanCabalFilePath = mempty - } +defaultCleanFlags = + CleanFlags + { cleanSaveConf = Flag False + , cleanDistPref = NoFlag + , cleanVerbosity = Flag normal + , cleanCabalFilePath = mempty + } cleanCommand :: CommandUI CleanFlags -cleanCommand = CommandUI - { commandName = "clean" - , commandSynopsis = "Clean up after a build." - , commandDescription = Just $ \_ -> - "Removes .hi, .o, preprocessed sources, etc.\n" - , commandNotes = Nothing - , commandUsage = \pname -> - "Usage: " ++ pname ++ " clean [FLAGS]\n" - , commandDefaultFlags = defaultCleanFlags - , commandOptions = \showOrParseArgs -> - [optionVerbosity cleanVerbosity (\v flags -> flags { cleanVerbosity = v }) - ,optionDistPref - cleanDistPref (\d flags -> flags { cleanDistPref = d }) - showOrParseArgs - - ,option "s" ["save-configure"] - "Do not remove the configuration file (dist/setup-config) during cleaning. Saves need to reconfigure." - cleanSaveConf (\v flags -> flags { cleanSaveConf = v }) - trueArg - ] - } +cleanCommand = + CommandUI + { commandName = "clean" + , commandSynopsis = "Clean up after a build." + , commandDescription = Just $ \_ -> + "Removes .hi, .o, preprocessed sources, etc.\n" + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " clean [FLAGS]\n" + , commandDefaultFlags = defaultCleanFlags + , commandOptions = \showOrParseArgs -> + [ optionVerbosity cleanVerbosity (\v flags -> flags{cleanVerbosity = v}) + , optionDistPref + cleanDistPref + (\d flags -> flags{cleanDistPref = d}) + showOrParseArgs + , option + "s" + ["save-configure"] + "Do not remove the configuration file (dist/setup-config) during cleaning. Saves need to reconfigure." + cleanSaveConf + (\v flags -> flags{cleanSaveConf = v}) + trueArg + ] + } emptyCleanFlags :: CleanFlags emptyCleanFlags = mempty @@ -83,4 +92,3 @@ instance Monoid CleanFlags where instance Semigroup CleanFlags where (<>) = gmappend - diff --git a/Cabal/src/Distribution/Simple/Setup/Common.hs b/Cabal/src/Distribution/Simple/Setup/Common.hs index ff9187b4550..f866ba3d8d4 100644 --- a/Cabal/src/Distribution/Simple/Setup/Common.hs +++ b/Cabal/src/Distribution/Simple/Setup/Common.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Setup.Common -- Copyright : Isaac Jones 2003-2004 @@ -16,76 +17,91 @@ -- -- Common utilities for defining command-line options. -- See: @Distribution.Simple.Setup@ - -module Distribution.Simple.Setup.Common ( - CopyDest(..), - configureCCompiler, configureLinker, - programDbOption, programDbOptions, - programDbPaths, programDbPaths', - programFlagsDescription, - splitArgs, testOrBenchmarkHelpText, - - defaultDistPref, optionDistPref, - - Flag(..), - toFlag, - fromFlag, - fromFlagOrDefault, - flagToMaybe, - flagToList, - maybeToFlag, - BooleanFlag(..), - boolOpt, boolOpt', trueArg, falseArg, - reqArgFlag, - optionVerbosity, optionNumJobs +module Distribution.Simple.Setup.Common + ( CopyDest (..) + , configureCCompiler + , configureLinker + , programDbOption + , programDbOptions + , programDbPaths + , programDbPaths' + , programFlagsDescription + , splitArgs + , testOrBenchmarkHelpText + , defaultDistPref + , optionDistPref + , Flag (..) + , toFlag + , fromFlag + , fromFlagOrDefault + , flagToMaybe + , flagToList + , maybeToFlag + , BooleanFlag (..) + , boolOpt + , boolOpt' + , trueArg + , falseArg + , reqArgFlag + , optionVerbosity + , optionNumJobs ) where -import Prelude () import Distribution.Compat.Prelude hiding (get) +import Prelude () import Distribution.ReadE import Distribution.Simple.Command hiding (boolOpt, boolOpt') import qualified Distribution.Simple.Command as Command import Distribution.Simple.Flag -import Distribution.Simple.Utils -import Distribution.Simple.Program import Distribution.Simple.InstallDirs +import Distribution.Simple.Program +import Distribution.Simple.Utils import Distribution.Verbosity - -- FIXME Not sure where this should live defaultDistPref :: FilePath defaultDistPref = "dist" -- | Help text for @test@ and @bench@ commands. testOrBenchmarkHelpText - :: String -- ^ Either @"test"@ or @"benchmark"@. - -> String -- ^ Help text. -testOrBenchmarkHelpText s = unlines $ map unwords - [ [ "The package must have been build with configuration" - , concat [ "flag `--enable-", s, "s`." ] - ] - , [] -- blank line - , [ concat [ "Note that additional dependencies of the ", s, "s" ] - , "must have already been installed." - ] - , [] - , [ "By defining UserHooks in a custom Setup.hs, the package can define" - , concat [ "actions to be executed before and after running ", s, "s." ] - ] - ] + :: String + -- ^ Either @"test"@ or @"benchmark"@. + -> String + -- ^ Help text. +testOrBenchmarkHelpText s = + unlines $ + map + unwords + [ + [ "The package must have been build with configuration" + , concat ["flag `--enable-", s, "s`."] + ] + , [] -- blank line + , + [ concat ["Note that additional dependencies of the ", s, "s"] + , "must have already been installed." + ] + , [] + , + [ "By defining UserHooks in a custom Setup.hs, the package can define" + , concat ["actions to be executed before and after running ", s, "s."] + ] + ] -- ------------------------------------------------------------ + -- * Shared options utils + -- ------------------------------------------------------------ programFlagsDescription :: ProgramDb -> String programFlagsDescription progDb = - "The flags --with-PROG and --PROG-option(s) can be used with" - ++ " the following programs:" - ++ (concatMap (\line -> "\n " ++ unwords line) . wrapLine 77 . sort) - [ programName prog | (prog, _) <- knownPrograms progDb ] - ++ "\n" + "The flags --with-PROG and --PROG-option(s) can be used with" + ++ " the following programs:" + ++ (concatMap (\line -> "\n " ++ unwords line) . wrapLine 77 . sort) + [programName prog | (prog, _) <- knownPrograms progDb] + ++ "\n" -- | For each known program @PROG@ in 'progDb', produce a @with-PROG@ -- 'OptionField'. @@ -109,16 +125,24 @@ programDbPaths' programDbPaths' mkName progDb showOrParseArgs get set = case showOrParseArgs of -- we don't want a verbose help text list so we just show a generic one: - ShowArgs -> [withProgramPath "PROG"] - ParseArgs -> map (withProgramPath . programName . fst) - (knownPrograms progDb) + ShowArgs -> [withProgramPath "PROG"] + ParseArgs -> + map + (withProgramPath . programName . fst) + (knownPrograms progDb) where withProgramPath prog = - option "" [mkName prog] + option + "" + [mkName prog] ("give the path to " ++ prog) - get set - (reqArg' "PATH" (\path -> [(prog, path)]) - (\progPaths -> [ path | (prog', path) <- progPaths, prog==prog' ])) + get + set + ( reqArg' + "PATH" + (\path -> [(prog, path)]) + (\progPaths -> [path | (prog', path) <- progPaths, prog == prog']) + ) -- | For each known program @PROG@ in 'progDb', produce a @PROG-option@ -- 'OptionField'. @@ -131,19 +155,33 @@ programDbOption programDbOption progDb showOrParseArgs get set = case showOrParseArgs of -- we don't want a verbose help text list so we just show a generic one: - ShowArgs -> [programOption "PROG"] - ParseArgs -> map (programOption . programName . fst) - (knownPrograms progDb) + ShowArgs -> [programOption "PROG"] + ParseArgs -> + map + (programOption . programName . fst) + (knownPrograms progDb) where programOption prog = - option "" [prog ++ "-option"] - ("give an extra option to " ++ prog ++ - " (no need to quote options containing spaces)") - get set - (reqArg' "OPT" (\arg -> [(prog, [arg])]) - (\progArgs -> concat [ args - | (prog', args) <- progArgs, prog==prog' ])) - + option + "" + [prog ++ "-option"] + ( "give an extra option to " + ++ prog + ++ " (no need to quote options containing spaces)" + ) + get + set + ( reqArg' + "OPT" + (\arg -> [(prog, [arg])]) + ( \progArgs -> + concat + [ args + | (prog', args) <- progArgs + , prog == prog' + ] + ) + ) -- | For each known program @PROG@ in 'progDb', produce a @PROG-options@ -- 'OptionField'. @@ -156,99 +194,144 @@ programDbOptions programDbOptions progDb showOrParseArgs get set = case showOrParseArgs of -- we don't want a verbose help text list so we just show a generic one: - ShowArgs -> [programOptions "PROG"] - ParseArgs -> map (programOptions . programName . fst) - (knownPrograms progDb) + ShowArgs -> [programOptions "PROG"] + ParseArgs -> + map + (programOptions . programName . fst) + (knownPrograms progDb) where programOptions prog = - option "" [prog ++ "-options"] + option + "" + [prog ++ "-options"] ("give extra options to " ++ prog) - get set + get + set (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const [])) -- ------------------------------------------------------------ + -- * GetOpt Utils + -- ------------------------------------------------------------ -boolOpt :: SFlags -> SFlags - -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a -boolOpt = Command.boolOpt flagToMaybe Flag +boolOpt + :: SFlags + -> SFlags + -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a +boolOpt = Command.boolOpt flagToMaybe Flag -boolOpt' :: OptFlags -> OptFlags - -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a +boolOpt' + :: OptFlags + -> OptFlags + -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a boolOpt' = Command.boolOpt' flagToMaybe Flag trueArg, falseArg :: MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a -trueArg sfT lfT = boolOpt' (sfT, lfT) ([], []) sfT lfT -falseArg sfF lfF = boolOpt' ([], []) (sfF, lfF) sfF lfF - -reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description -> - (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b +trueArg sfT lfT = boolOpt' (sfT, lfT) ([], []) sfT lfT +falseArg sfF lfF = boolOpt' ([], []) (sfF, lfF) sfF lfF + +reqArgFlag + :: ArgPlaceHolder + -> SFlags + -> LFlags + -> Description + -> (b -> Flag String) + -> (Flag String -> b -> b) + -> OptDescr b reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList -optionDistPref :: (flags -> Flag FilePath) - -> (Flag FilePath -> flags -> flags) - -> ShowOrParseArgs - -> OptionField flags +optionDistPref + :: (flags -> Flag FilePath) + -> (Flag FilePath -> flags -> flags) + -> ShowOrParseArgs + -> OptionField flags optionDistPref get set = \showOrParseArgs -> - option "" (distPrefFlagName showOrParseArgs) - ( "The directory where Cabal puts generated build files " - ++ "(default " ++ defaultDistPref ++ ")") - get set + option + "" + (distPrefFlagName showOrParseArgs) + ( "The directory where Cabal puts generated build files " + ++ "(default " + ++ defaultDistPref + ++ ")" + ) + get + set (reqArgFlag "DIR") where - distPrefFlagName ShowArgs = ["builddir"] + distPrefFlagName ShowArgs = ["builddir"] distPrefFlagName ParseArgs = ["builddir", "distdir", "distpref"] -optionVerbosity :: (flags -> Flag Verbosity) - -> (Flag Verbosity -> flags -> flags) - -> OptionField flags +optionVerbosity + :: (flags -> Flag Verbosity) + -> (Flag Verbosity -> flags -> flags) + -> OptionField flags optionVerbosity get set = - option "v" ["verbose"] + option + "v" + ["verbose"] "Control verbosity (n is 0--3, default verbosity level is 1)" - get set - (optArg "n" (fmap Flag flagToVerbosity) - (Flag verbose) -- default Value if no n is given - (fmap (Just . showForCabal) . flagToList)) - -optionNumJobs :: (flags -> Flag (Maybe Int)) - -> (Flag (Maybe Int) -> flags -> flags) - -> OptionField flags + get + set + ( optArg + "n" + (fmap Flag flagToVerbosity) + (Flag verbose) -- default Value if no n is given + (fmap (Just . showForCabal) . flagToList) + ) + +optionNumJobs + :: (flags -> Flag (Maybe Int)) + -> (Flag (Maybe Int) -> flags -> flags) + -> OptionField flags optionNumJobs get set = - option "j" ["jobs"] + option + "j" + ["jobs"] "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)." - get set - (optArg "NUM" (fmap Flag numJobsParser) - (Flag Nothing) - (map (Just . maybe "$ncpus" show) . flagToList)) + get + set + ( optArg + "NUM" + (fmap Flag numJobsParser) + (Flag Nothing) + (map (Just . maybe "$ncpus" show) . flagToList) + ) where numJobsParser :: ReadE (Maybe Int) numJobsParser = ReadE $ \s -> case s of "$ncpus" -> Right Nothing - _ -> case reads s of + _ -> case reads s of [(n, "")] - | n < 1 -> Left "The number of jobs should be 1 or more." + | n < 1 -> Left "The number of jobs should be 1 or more." | otherwise -> Right (Just n) - _ -> Left "The jobs value should be a number or '$ncpus'" + _ -> Left "The jobs value should be a number or '$ncpus'" -- ------------------------------------------------------------ + -- * Other Utils + -- ------------------------------------------------------------ -configureCCompiler :: Verbosity -> ProgramDb - -> IO (FilePath, [String]) +configureCCompiler + :: Verbosity + -> ProgramDb + -> IO (FilePath, [String]) configureCCompiler verbosity progdb = configureProg verbosity progdb gccProgram configureLinker :: Verbosity -> ProgramDb -> IO (FilePath, [String]) configureLinker verbosity progdb = configureProg verbosity progdb ldProgram -configureProg :: Verbosity -> ProgramDb -> Program - -> IO (FilePath, [String]) +configureProg + :: Verbosity + -> ProgramDb + -> Program + -> IO (FilePath, [String]) configureProg verbosity programDb prog = do - (p, _) <- requireProgram verbosity prog programDb - let pInv = programInvocation p [] - return (progInvokePath pInv, progInvokeArgs pInv) + (p, _) <- requireProgram verbosity prog programDb + let pInv = programInvocation p [] + return (progInvokePath pInv, progInvokeArgs pInv) -- | Helper function to split a string into a list of arguments. -- It's supposed to handle quoted things sensibly, eg: @@ -258,27 +341,26 @@ configureProg verbosity programDb prog = do -- -- > splitArgs "\"-DMSGSTR=\\\"foo bar\\\"\" --baz" -- > = ["-DMSGSTR=\"foo bar\"","--baz"] --- splitArgs :: String -> [String] -splitArgs = space [] +splitArgs = space [] where space :: String -> String -> [String] - space w [] = word w [] - space w ( c :s) - | isSpace c = word w (space [] s) - space w ('"':s) = string w s - space w s = nonstring w s + space w [] = word w [] + space w (c : s) + | isSpace c = word w (space [] s) + space w ('"' : s) = string w s + space w s = nonstring w s string :: String -> String -> [String] - string w [] = word w [] - string w ('"':s) = space w s - string w ('\\':'"':s) = string ('"':w) s - string w ( c :s) = string (c:w) s + string w [] = word w [] + string w ('"' : s) = space w s + string w ('\\' : '"' : s) = string ('"' : w) s + string w (c : s) = string (c : w) s nonstring :: String -> String -> [String] - nonstring w [] = word w [] - nonstring w ('"':s) = string w s - nonstring w ( c :s) = space (c:w) s + nonstring w [] = word w [] + nonstring w ('"' : s) = string w s + nonstring w (c : s) = space (c : w) s word [] s = s - word w s = reverse w : s + word w s = reverse w : s diff --git a/Cabal/src/Distribution/Simple/Setup/Config.hs b/Cabal/src/Distribution/Simple/Setup/Config.hs index 1de98c0c88f..613d9a3c3d1 100644 --- a/Cabal/src/Distribution/Simple/Setup/Config.hs +++ b/Cabal/src/Distribution/Simple/Setup/Config.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Setup.Config -- Copyright : Isaac Jones 2003-2004 @@ -16,46 +17,56 @@ -- -- Definition of the configure command-line options. -- See: @Distribution.Simple.Setup@ - -module Distribution.Simple.Setup.Config ( - ConfigFlags(..), emptyConfigFlags, defaultConfigFlags, configureCommand, - configPrograms, - configAbsolutePaths, readPackageDb, readPackageDbList, showPackageDb, showPackageDbList, - configureArgs, configureOptions, installDirsOptions +module Distribution.Simple.Setup.Config + ( ConfigFlags (..) + , emptyConfigFlags + , defaultConfigFlags + , configureCommand + , configPrograms + , configAbsolutePaths + , readPackageDb + , readPackageDbList + , showPackageDb + , showPackageDbList + , configureArgs + , configureOptions + , installDirsOptions ) where -import Prelude () import Distribution.Compat.Prelude hiding (get) +import Prelude () -import Distribution.Compiler -import Distribution.ReadE -import Distribution.Parsec -import Distribution.Pretty import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp +import Distribution.Compiler import Distribution.ModuleName import Distribution.PackageDescription +import Distribution.Parsec +import Distribution.Pretty +import Distribution.ReadE import Distribution.Simple.Command hiding (boolOpt, boolOpt') import Distribution.Simple.Compiler import Distribution.Simple.Flag -import Distribution.Simple.Utils -import Distribution.Simple.Program import Distribution.Simple.InstallDirs -import Distribution.Verbosity -import Distribution.Utils.NubList +import Distribution.Simple.Program +import Distribution.Simple.Utils import Distribution.Types.ComponentId import Distribution.Types.DumpBuildInfo import Distribution.Types.GivenComponent import Distribution.Types.Module import Distribution.Types.PackageVersionConstraint +import Distribution.Utils.NubList +import Distribution.Verbosity +import qualified Text.PrettyPrint as Disp -import Distribution.Compat.Stack import Distribution.Compat.Semigroup (Last' (..), Option' (..)) +import Distribution.Compat.Stack import Distribution.Simple.Setup.Common -- ------------------------------------------------------------ + -- * Config flags + -- ------------------------------------------------------------ -- | Flags to @configure@ command. @@ -63,102 +74,146 @@ import Distribution.Simple.Setup.Common -- IMPORTANT: every time a new flag is added, 'D.C.Setup.filterConfigureFlags' -- should be updated. -- IMPORTANT: every time a new flag is added, it should be added to the Eq instance -data ConfigFlags = ConfigFlags { - -- This is the same hack as in 'buildArgs' and 'copyArgs'. +data ConfigFlags = ConfigFlags + { -- This is the same hack as in 'buildArgs' and 'copyArgs'. -- TODO: Stop using this eventually when 'UserHooks' gets changed - configArgs :: [String], - - --FIXME: the configPrograms is only here to pass info through to configure + configArgs :: [String] + , -- FIXME: the configPrograms is only here to pass info through to configure -- because the type of configure is constrained by the UserHooks. -- when we change UserHooks next we should pass the initial -- ProgramDb directly and not via ConfigFlags - configPrograms_ :: Option' (Last' ProgramDb), -- ^All programs that - -- @cabal@ may run - configProgramPaths :: [(String, FilePath)], -- ^user specified programs paths - configProgramArgs :: [(String, [String])], -- ^user specified programs args - configProgramPathExtra :: NubList FilePath, -- ^Extend the $PATH - configHcFlavor :: Flag CompilerFlavor, -- ^The \"flavor\" of the - -- compiler, e.g. GHC. - configHcPath :: Flag FilePath, -- ^given compiler location - configHcPkg :: Flag FilePath, -- ^given hc-pkg location - configVanillaLib :: Flag Bool, -- ^Enable vanilla library - configProfLib :: Flag Bool, -- ^Enable profiling in the library - configSharedLib :: Flag Bool, -- ^Build shared library - configStaticLib :: Flag Bool, -- ^Build static library - configDynExe :: Flag Bool, -- ^Enable dynamic linking of the - -- executables. - configFullyStaticExe :: Flag Bool, -- ^Enable fully static linking of the - -- executables. - configProfExe :: Flag Bool, -- ^Enable profiling in the - -- executables. - configProf :: Flag Bool, -- ^Enable profiling in the library - -- and executables. - configProfDetail :: Flag ProfDetailLevel, -- ^Profiling detail level - -- in the library and executables. - configProfLibDetail :: Flag ProfDetailLevel, -- ^Profiling detail level - -- in the library - configConfigureArgs :: [String], -- ^Extra arguments to @configure@ - configOptimization :: Flag OptimisationLevel, -- ^Enable optimization. - configProgPrefix :: Flag PathTemplate, -- ^Installed executable prefix. - configProgSuffix :: Flag PathTemplate, -- ^Installed executable suffix. - configInstallDirs :: InstallDirs (Flag PathTemplate), -- ^Installation - -- paths - configScratchDir :: Flag FilePath, - configExtraLibDirs :: [FilePath], -- ^ path to search for extra libraries - configExtraLibDirsStatic :: [FilePath], -- ^ path to search for extra - -- libraries when linking - -- fully static executables - configExtraFrameworkDirs :: [FilePath], -- ^ path to search for extra - -- frameworks (OS X only) - configExtraIncludeDirs :: [FilePath], -- ^ path to search for header files - configIPID :: Flag String, -- ^ explicit IPID to be used - configCID :: Flag ComponentId, -- ^ explicit CID to be used - configDeterministic :: Flag Bool, -- ^ be as deterministic as possible - -- (e.g., invariant over GHC, database, - -- etc). Used by the test suite - - configDistPref :: Flag FilePath, -- ^"dist" prefix - configCabalFilePath :: Flag FilePath, -- ^ Cabal file to use - configVerbosity :: Flag Verbosity, -- ^verbosity level - configUserInstall :: Flag Bool, -- ^The --user\/--global flag - configPackageDBs :: [Maybe PackageDB], -- ^Which package DBs to use - configGHCiLib :: Flag Bool, -- ^Enable compiling library for GHCi - configSplitSections :: Flag Bool, -- ^Enable -split-sections with GHC - configSplitObjs :: Flag Bool, -- ^Enable -split-objs with GHC - configStripExes :: Flag Bool, -- ^Enable executable stripping - configStripLibs :: Flag Bool, -- ^Enable library stripping - configConstraints :: [PackageVersionConstraint], -- ^Additional constraints for - -- dependencies. - configDependencies :: [GivenComponent], - -- ^The packages depended on. - configInstantiateWith :: [(ModuleName, Module)], - -- ^ The requested Backpack instantiation. If empty, either this - -- package does not use Backpack, or we just want to typecheck - -- the indefinite package. - configConfigurationsFlags :: FlagAssignment, - configTests :: Flag Bool, -- ^Enable test suite compilation - configBenchmarks :: Flag Bool, -- ^Enable benchmark compilation - configCoverage :: Flag Bool, -- ^Enable program coverage - configLibCoverage :: Flag Bool, -- ^Enable program coverage (deprecated) - configExactConfiguration :: Flag Bool, - -- ^All direct dependencies and flags are provided on the command line by - -- the user via the '--dependency' and '--flags' options. - configFlagError :: Flag String, - -- ^Halt and show an error message indicating an error in flag assignment - configRelocatable :: Flag Bool, -- ^ Enable relocatable package built - configDebugInfo :: Flag DebugInfoLevel, -- ^ Emit debug info. - configDumpBuildInfo :: Flag DumpBuildInfo, - -- ^ Should we dump available build information on build? - -- Dump build information to disk before attempting to build, - -- tooling can parse these files and use them to compile the - -- source files themselves. - configUseResponseFiles :: Flag Bool, - -- ^ Whether to use response files at all. They're used for such tools - -- as haddock, or ld. - configAllowDependingOnPrivateLibs :: Flag Bool - -- ^ Allow depending on private sublibraries. This is used by external - -- tools (like cabal-install) so they can add multiple-public-libraries - -- compatibility to older ghcs by checking visibility externally. + configPrograms_ :: Option' (Last' ProgramDb) + -- ^ All programs that + -- @cabal@ may run + , configProgramPaths :: [(String, FilePath)] + -- ^ user specified programs paths + , configProgramArgs :: [(String, [String])] + -- ^ user specified programs args + , configProgramPathExtra :: NubList FilePath + -- ^ Extend the $PATH + , configHcFlavor :: Flag CompilerFlavor + -- ^ The \"flavor\" of the + -- compiler, e.g. GHC. + , configHcPath :: Flag FilePath + -- ^ given compiler location + , configHcPkg :: Flag FilePath + -- ^ given hc-pkg location + , configVanillaLib :: Flag Bool + -- ^ Enable vanilla library + , configProfLib :: Flag Bool + -- ^ Enable profiling in the library + , configSharedLib :: Flag Bool + -- ^ Build shared library + , configStaticLib :: Flag Bool + -- ^ Build static library + , configDynExe :: Flag Bool + -- ^ Enable dynamic linking of the + -- executables. + , configFullyStaticExe :: Flag Bool + -- ^ Enable fully static linking of the + -- executables. + , configProfExe :: Flag Bool + -- ^ Enable profiling in the + -- executables. + , configProf :: Flag Bool + -- ^ Enable profiling in the library + -- and executables. + , configProfDetail :: Flag ProfDetailLevel + -- ^ Profiling detail level + -- in the library and executables. + , configProfLibDetail :: Flag ProfDetailLevel + -- ^ Profiling detail level + -- in the library + , configConfigureArgs :: [String] + -- ^ Extra arguments to @configure@ + , configOptimization :: Flag OptimisationLevel + -- ^ Enable optimization. + , configProgPrefix :: Flag PathTemplate + -- ^ Installed executable prefix. + , configProgSuffix :: Flag PathTemplate + -- ^ Installed executable suffix. + , configInstallDirs :: InstallDirs (Flag PathTemplate) + -- ^ Installation + -- paths + , configScratchDir :: Flag FilePath + , configExtraLibDirs :: [FilePath] + -- ^ path to search for extra libraries + , configExtraLibDirsStatic :: [FilePath] + -- ^ path to search for extra + -- libraries when linking + -- fully static executables + , configExtraFrameworkDirs :: [FilePath] + -- ^ path to search for extra + -- frameworks (OS X only) + , configExtraIncludeDirs :: [FilePath] + -- ^ path to search for header files + , configIPID :: Flag String + -- ^ explicit IPID to be used + , configCID :: Flag ComponentId + -- ^ explicit CID to be used + , configDeterministic :: Flag Bool + -- ^ be as deterministic as possible + -- (e.g., invariant over GHC, database, + -- etc). Used by the test suite + , configDistPref :: Flag FilePath + -- ^ "dist" prefix + , configCabalFilePath :: Flag FilePath + -- ^ Cabal file to use + , configVerbosity :: Flag Verbosity + -- ^ verbosity level + , configUserInstall :: Flag Bool + -- ^ The --user\/--global flag + , configPackageDBs :: [Maybe PackageDB] + -- ^ Which package DBs to use + , configGHCiLib :: Flag Bool + -- ^ Enable compiling library for GHCi + , configSplitSections :: Flag Bool + -- ^ Enable -split-sections with GHC + , configSplitObjs :: Flag Bool + -- ^ Enable -split-objs with GHC + , configStripExes :: Flag Bool + -- ^ Enable executable stripping + , configStripLibs :: Flag Bool + -- ^ Enable library stripping + , configConstraints :: [PackageVersionConstraint] + -- ^ Additional constraints for + -- dependencies. + , configDependencies :: [GivenComponent] + -- ^ The packages depended on. + , configInstantiateWith :: [(ModuleName, Module)] + -- ^ The requested Backpack instantiation. If empty, either this + -- package does not use Backpack, or we just want to typecheck + -- the indefinite package. + , configConfigurationsFlags :: FlagAssignment + , configTests :: Flag Bool + -- ^ Enable test suite compilation + , configBenchmarks :: Flag Bool + -- ^ Enable benchmark compilation + , configCoverage :: Flag Bool + -- ^ Enable program coverage + , configLibCoverage :: Flag Bool + -- ^ Enable program coverage (deprecated) + , configExactConfiguration :: Flag Bool + -- ^ All direct dependencies and flags are provided on the command line by + -- the user via the '--dependency' and '--flags' options. + , configFlagError :: Flag String + -- ^ Halt and show an error message indicating an error in flag assignment + , configRelocatable :: Flag Bool + -- ^ Enable relocatable package built + , configDebugInfo :: Flag DebugInfoLevel + -- ^ Emit debug info. + , configDumpBuildInfo :: Flag DumpBuildInfo + -- ^ Should we dump available build information on build? + -- Dump build information to disk before attempting to build, + -- tooling can parse these files and use them to compile the + -- source files themselves. + , configUseResponseFiles :: Flag Bool + -- ^ Whether to use response files at all. They're used for such tools + -- as haddock, or ld. + , configAllowDependingOnPrivateLibs :: Flag Bool + -- ^ Allow depending on private sublibraries. This is used by external + -- tools (like cabal-install) so they can add multiple-public-libraries + -- compatibility to older ghcs by checking visibility externally. } deriving (Generic, Read, Show, Typeable) @@ -168,145 +223,163 @@ instance Structured ConfigFlags -- | More convenient version of 'configPrograms'. Results in an -- 'error' if internal invariant is violated. configPrograms :: WithCallStack (ConfigFlags -> ProgramDb) -configPrograms = fromMaybe (error "FIXME: remove configPrograms") . fmap getLast' - . getOption' . configPrograms_ +configPrograms = + fromMaybe (error "FIXME: remove configPrograms") + . fmap getLast' + . getOption' + . configPrograms_ instance Eq ConfigFlags where (==) a b = -- configPrograms skipped: not user specified, has no Eq instance equal configProgramPaths - && equal configProgramArgs - && equal configProgramPathExtra - && equal configHcFlavor - && equal configHcPath - && equal configHcPkg - && equal configVanillaLib - && equal configProfLib - && equal configSharedLib - && equal configStaticLib - && equal configDynExe - && equal configFullyStaticExe - && equal configProfExe - && equal configProf - && equal configProfDetail - && equal configProfLibDetail - && equal configConfigureArgs - && equal configOptimization - && equal configProgPrefix - && equal configProgSuffix - && equal configInstallDirs - && equal configScratchDir - && equal configExtraLibDirs - && equal configExtraLibDirsStatic - && equal configExtraIncludeDirs - && equal configIPID - && equal configDeterministic - && equal configDistPref - && equal configVerbosity - && equal configUserInstall - && equal configPackageDBs - && equal configGHCiLib - && equal configSplitSections - && equal configSplitObjs - && equal configStripExes - && equal configStripLibs - && equal configConstraints - && equal configDependencies - && equal configConfigurationsFlags - && equal configTests - && equal configBenchmarks - && equal configCoverage - && equal configLibCoverage - && equal configExactConfiguration - && equal configFlagError - && equal configRelocatable - && equal configDebugInfo - && equal configDumpBuildInfo - && equal configUseResponseFiles + && equal configProgramArgs + && equal configProgramPathExtra + && equal configHcFlavor + && equal configHcPath + && equal configHcPkg + && equal configVanillaLib + && equal configProfLib + && equal configSharedLib + && equal configStaticLib + && equal configDynExe + && equal configFullyStaticExe + && equal configProfExe + && equal configProf + && equal configProfDetail + && equal configProfLibDetail + && equal configConfigureArgs + && equal configOptimization + && equal configProgPrefix + && equal configProgSuffix + && equal configInstallDirs + && equal configScratchDir + && equal configExtraLibDirs + && equal configExtraLibDirsStatic + && equal configExtraIncludeDirs + && equal configIPID + && equal configDeterministic + && equal configDistPref + && equal configVerbosity + && equal configUserInstall + && equal configPackageDBs + && equal configGHCiLib + && equal configSplitSections + && equal configSplitObjs + && equal configStripExes + && equal configStripLibs + && equal configConstraints + && equal configDependencies + && equal configConfigurationsFlags + && equal configTests + && equal configBenchmarks + && equal configCoverage + && equal configLibCoverage + && equal configExactConfiguration + && equal configFlagError + && equal configRelocatable + && equal configDebugInfo + && equal configDumpBuildInfo + && equal configUseResponseFiles where equal f = on (==) f a b configAbsolutePaths :: ConfigFlags -> IO ConfigFlags configAbsolutePaths f = - (\v -> f { configPackageDBs = v }) - `liftM` traverse (maybe (return Nothing) (liftM Just . absolutePackageDBPath)) - (configPackageDBs f) + (\v -> f{configPackageDBs = v}) + `liftM` traverse + (maybe (return Nothing) (liftM Just . absolutePackageDBPath)) + (configPackageDBs f) +{- FOURMOLU_DISABLE -} defaultConfigFlags :: ProgramDb -> ConfigFlags -defaultConfigFlags progDb = emptyConfigFlags { - configArgs = [], - configPrograms_ = Option' (Just (Last' progDb)), - configHcFlavor = maybe NoFlag Flag defaultCompilerFlavor, - configVanillaLib = Flag True, - configProfLib = NoFlag, - configSharedLib = NoFlag, - configStaticLib = NoFlag, - configDynExe = Flag False, - configFullyStaticExe = Flag False, - configProfExe = NoFlag, - configProf = NoFlag, - configProfDetail = NoFlag, - configProfLibDetail= NoFlag, - configOptimization = Flag NormalOptimisation, - configProgPrefix = Flag (toPathTemplate ""), - configProgSuffix = Flag (toPathTemplate ""), - configDistPref = NoFlag, - configCabalFilePath = NoFlag, - configVerbosity = Flag normal, - configUserInstall = Flag False, --TODO: reverse this +defaultConfigFlags progDb = + emptyConfigFlags + { configArgs = [] + , configPrograms_ = Option' (Just (Last' progDb)) + , configHcFlavor = maybe NoFlag Flag defaultCompilerFlavor + , configVanillaLib = Flag True + , configProfLib = NoFlag + , configSharedLib = NoFlag + , configStaticLib = NoFlag + , configDynExe = Flag False + , configFullyStaticExe = Flag False + , configProfExe = NoFlag + , configProf = NoFlag + , configProfDetail = NoFlag + , configProfLibDetail = NoFlag + , configOptimization = Flag NormalOptimisation + , configProgPrefix = Flag (toPathTemplate "") + , configProgSuffix = Flag (toPathTemplate "") + , configDistPref = NoFlag + , configCabalFilePath = NoFlag + , configVerbosity = Flag normal + , configUserInstall = Flag False -- TODO: reverse this #if defined(mingw32_HOST_OS) - -- See #8062 and GHC #21019. - configGHCiLib = Flag False, + -- See #8062 and GHC #21019. + , configGHCiLib = Flag False #else - configGHCiLib = NoFlag, + , configGHCiLib = NoFlag #endif - configSplitSections = Flag False, - configSplitObjs = Flag False, -- takes longer, so turn off by default - configStripExes = NoFlag, - configStripLibs = NoFlag, - configTests = Flag False, - configBenchmarks = Flag False, - configCoverage = Flag False, - configLibCoverage = NoFlag, - configExactConfiguration = Flag False, - configFlagError = NoFlag, - configRelocatable = Flag False, - configDebugInfo = Flag NoDebugInfo, - configDumpBuildInfo = NoFlag, - configUseResponseFiles = NoFlag - } + , configSplitSections = Flag False + , configSplitObjs = Flag False -- takes longer, so turn off by default + , configStripExes = NoFlag + , configStripLibs = NoFlag + , configTests = Flag False + , configBenchmarks = Flag False + , configCoverage = Flag False + , configLibCoverage = NoFlag + , configExactConfiguration = Flag False + , configFlagError = NoFlag + , configRelocatable = Flag False + , configDebugInfo = Flag NoDebugInfo + , configDumpBuildInfo = NoFlag + , configUseResponseFiles = NoFlag + } +{- FOURMOLU_ENABLE -} configureCommand :: ProgramDb -> CommandUI ConfigFlags -configureCommand progDb = CommandUI - { commandName = "configure" - , commandSynopsis = "Prepare to build the package." - , commandDescription = Just $ \_ -> wrapText $ - "Configure how the package is built by setting " - ++ "package (and other) flags.\n" - ++ "\n" - ++ "The configuration affects several other commands, " - ++ "including build, test, bench, run, repl.\n" - , commandNotes = Just $ \_pname -> programFlagsDescription progDb - , commandUsage = \pname -> - "Usage: " ++ pname ++ " configure [FLAGS]\n" - , commandDefaultFlags = defaultConfigFlags progDb - , commandOptions = \showOrParseArgs -> - configureOptions showOrParseArgs - ++ programDbPaths progDb showOrParseArgs - configProgramPaths (\v fs -> fs { configProgramPaths = v }) - ++ programDbOption progDb showOrParseArgs - configProgramArgs (\v fs -> fs { configProgramArgs = v }) - ++ programDbOptions progDb showOrParseArgs - configProgramArgs (\v fs -> fs { configProgramArgs = v }) - } +configureCommand progDb = + CommandUI + { commandName = "configure" + , commandSynopsis = "Prepare to build the package." + , commandDescription = Just $ \_ -> + wrapText $ + "Configure how the package is built by setting " + ++ "package (and other) flags.\n" + ++ "\n" + ++ "The configuration affects several other commands, " + ++ "including build, test, bench, run, repl.\n" + , commandNotes = Just $ \_pname -> programFlagsDescription progDb + , commandUsage = \pname -> + "Usage: " ++ pname ++ " configure [FLAGS]\n" + , commandDefaultFlags = defaultConfigFlags progDb + , commandOptions = \showOrParseArgs -> + configureOptions showOrParseArgs + ++ programDbPaths + progDb + showOrParseArgs + configProgramPaths + (\v fs -> fs{configProgramPaths = v}) + ++ programDbOption + progDb + showOrParseArgs + configProgramArgs + (\v fs -> fs{configProgramArgs = v}) + ++ programDbOptions + progDb + showOrParseArgs + configProgramArgs + (\v fs -> fs{configProgramArgs = v}) + } -- | Inverse to 'dispModSubstEntry'. parsecModSubstEntry :: ParsecParser (ModuleName, Module) parsecModSubstEntry = do - k <- parsec - _ <- P.char '=' - v <- parsec - return (k, v) + k <- parsec + _ <- P.char '=' + v <- parsec + return (k, v) -- | Pretty-print a single entry of a module substitution. dispModSubstEntry :: (ModuleName, Module) -> Disp.Doc @@ -314,313 +387,451 @@ dispModSubstEntry (k, v) = pretty k <<>> Disp.char '=' <<>> pretty v configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] configureOptions showOrParseArgs = - [optionVerbosity configVerbosity - (\v flags -> flags { configVerbosity = v }) - ,optionDistPref - configDistPref (\d flags -> flags { configDistPref = d }) - showOrParseArgs - - ,option [] ["compiler"] "compiler" - configHcFlavor (\v flags -> flags { configHcFlavor = v }) - (choiceOpt [ (Flag GHC, ("g", ["ghc"]), "compile with GHC") - , (Flag GHCJS, ([] , ["ghcjs"]), "compile with GHCJS") - , (Flag UHC, ([] , ["uhc"]), "compile with UHC") - -- "haskell-suite" compiler id string will be replaced - -- by a more specific one during the configure stage - , (Flag (HaskellSuite "haskell-suite"), ([] , ["haskell-suite"]), - "compile with a haskell-suite compiler")]) - - ,option "" ["cabal-file"] - "use this Cabal file" - configCabalFilePath (\v flags -> flags { configCabalFilePath = v }) - (reqArgFlag "PATH") - - ,option "w" ["with-compiler"] - "give the path to a particular compiler" - configHcPath (\v flags -> flags { configHcPath = v }) - (reqArgFlag "PATH") - - ,option "" ["with-hc-pkg"] - "give the path to the package tool" - configHcPkg (\v flags -> flags { configHcPkg = v }) - (reqArgFlag "PATH") - ] - ++ map liftInstallDirs installDirsOptions - ++ [option "" ["program-prefix"] + [ optionVerbosity + configVerbosity + (\v flags -> flags{configVerbosity = v}) + , optionDistPref + configDistPref + (\d flags -> flags{configDistPref = d}) + showOrParseArgs + , option + [] + ["compiler"] + "compiler" + configHcFlavor + (\v flags -> flags{configHcFlavor = v}) + ( choiceOpt + [ (Flag GHC, ("g", ["ghc"]), "compile with GHC") + , (Flag GHCJS, ([], ["ghcjs"]), "compile with GHCJS") + , (Flag UHC, ([], ["uhc"]), "compile with UHC") + , -- "haskell-suite" compiler id string will be replaced + -- by a more specific one during the configure stage + + ( Flag (HaskellSuite "haskell-suite") + , ([], ["haskell-suite"]) + , "compile with a haskell-suite compiler" + ) + ] + ) + , option + "" + ["cabal-file"] + "use this Cabal file" + configCabalFilePath + (\v flags -> flags{configCabalFilePath = v}) + (reqArgFlag "PATH") + , option + "w" + ["with-compiler"] + "give the path to a particular compiler" + configHcPath + (\v flags -> flags{configHcPath = v}) + (reqArgFlag "PATH") + , option + "" + ["with-hc-pkg"] + "give the path to the package tool" + configHcPkg + (\v flags -> flags{configHcPkg = v}) + (reqArgFlag "PATH") + ] + ++ map liftInstallDirs installDirsOptions + ++ [ option + "" + ["program-prefix"] "prefix to be applied to installed executables" configProgPrefix - (\v flags -> flags { configProgPrefix = v }) + (\v flags -> flags{configProgPrefix = v}) (reqPathTemplateArgFlag "PREFIX") - - ,option "" ["program-suffix"] + , option + "" + ["program-suffix"] "suffix to be applied to installed executables" - configProgSuffix (\v flags -> flags { configProgSuffix = v } ) + configProgSuffix + (\v flags -> flags{configProgSuffix = v}) (reqPathTemplateArgFlag "SUFFIX") - - ,option "" ["library-vanilla"] - "Vanilla libraries" - configVanillaLib (\v flags -> flags { configVanillaLib = v }) - (boolOpt [] []) - - ,option "p" ["library-profiling"] - "Library profiling" - configProfLib (\v flags -> flags { configProfLib = v }) - (boolOpt "p" []) - - ,option "" ["shared"] - "Shared library" - configSharedLib (\v flags -> flags { configSharedLib = v }) - (boolOpt [] []) - - ,option "" ["static"] - "Static library" - configStaticLib (\v flags -> flags { configStaticLib = v }) - (boolOpt [] []) - - ,option "" ["executable-dynamic"] - "Executable dynamic linking" - configDynExe (\v flags -> flags { configDynExe = v }) - (boolOpt [] []) - - ,option "" ["executable-static"] - "Executable fully static linking" - configFullyStaticExe (\v flags -> flags { configFullyStaticExe = v }) - (boolOpt [] []) - - ,option "" ["profiling"] - "Executable and library profiling" - configProf (\v flags -> flags { configProf = v }) - (boolOpt [] []) - - ,option "" ["executable-profiling"] - "Executable profiling (DEPRECATED)" - configProfExe (\v flags -> flags { configProfExe = v }) - (boolOpt [] []) - - ,option "" ["profiling-detail"] - ("Profiling detail level for executable and library (default, " ++ - "none, exported-functions, toplevel-functions, all-functions, late).") - configProfDetail (\v flags -> flags { configProfDetail = v }) - (reqArg' "level" (Flag . flagToProfDetailLevel) - showProfDetailLevelFlag) - - ,option "" ["library-profiling-detail"] - "Profiling detail level for libraries only." - configProfLibDetail (\v flags -> flags { configProfLibDetail = v }) - (reqArg' "level" (Flag . flagToProfDetailLevel) - showProfDetailLevelFlag) - - ,multiOption "optimization" - configOptimization (\v flags -> flags { configOptimization = v }) - [optArg' "n" (Flag . flagToOptimisationLevel) - (\f -> case f of - Flag NoOptimisation -> [] - Flag NormalOptimisation -> [Nothing] - Flag MaximumOptimisation -> [Just "2"] - _ -> []) - "O" ["enable-optimization","enable-optimisation"] - "Build with optimization (n is 0--2, default is 1)", - noArg (Flag NoOptimisation) [] - ["disable-optimization","disable-optimisation"] - "Build without optimization" - ] - - ,multiOption "debug-info" - configDebugInfo (\v flags -> flags { configDebugInfo = v }) - [optArg' "n" (Flag . flagToDebugInfoLevel) - (\f -> case f of - Flag NoDebugInfo -> [] - Flag MinimalDebugInfo -> [Just "1"] - Flag NormalDebugInfo -> [Nothing] - Flag MaximalDebugInfo -> [Just "3"] - _ -> []) - "" ["enable-debug-info"] - "Emit debug info (n is 0--3, default is 0)", - noArg (Flag NoDebugInfo) [] - ["disable-debug-info"] - "Don't emit debug info" - ] - - , multiOption "build-info" - configDumpBuildInfo - (\v flags -> flags { configDumpBuildInfo = v }) - [noArg (Flag DumpBuildInfo) [] - ["enable-build-info"] - "Enable build information generation during project building", - noArg (Flag NoDumpBuildInfo) [] - ["disable-build-info"] - "Disable build information generation during project building" - ] - - ,option "" ["library-for-ghci"] - "compile library for use with GHCi" - configGHCiLib (\v flags -> flags { configGHCiLib = v }) - (boolOpt [] []) - - ,option "" ["split-sections"] - "compile library code such that unneeded definitions can be dropped from the final executable (GHC 7.8+)" - configSplitSections (\v flags -> flags { configSplitSections = v }) - (boolOpt [] []) - - ,option "" ["split-objs"] - "split library into smaller objects to reduce binary sizes (GHC 6.6+)" - configSplitObjs (\v flags -> flags { configSplitObjs = v }) - (boolOpt [] []) - - ,option "" ["executable-stripping"] - "strip executables upon installation to reduce binary sizes" - configStripExes (\v flags -> flags { configStripExes = v }) - (boolOpt [] []) - - ,option "" ["library-stripping"] - "strip libraries upon installation to reduce binary sizes" - configStripLibs (\v flags -> flags { configStripLibs = v }) - (boolOpt [] []) - - ,option "" ["configure-option"] - "Extra option for configure" - configConfigureArgs (\v flags -> flags { configConfigureArgs = v }) - (reqArg' "OPT" (\x -> [x]) id) - - ,option "" ["user-install"] - "doing a per-user installation" - configUserInstall (\v flags -> flags { configUserInstall = v }) - (boolOpt' ([],["user"]) ([], ["global"])) - - ,option "" ["package-db"] - ( "Append the given package database to the list of package" - ++ " databases used (to satisfy dependencies and register into)." - ++ " May be a specific file, 'global' or 'user'. The initial list" - ++ " is ['global'], ['global', 'user'], or ['global', $sandbox]," - ++ " depending on context. Use 'clear' to reset the list to empty." - ++ " See the user guide for details.") - configPackageDBs (\v flags -> flags { configPackageDBs = v }) - (reqArg' "DB" readPackageDbList showPackageDbList) - - ,option "f" ["flags"] - "Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false." - configConfigurationsFlags (\v flags -> flags { configConfigurationsFlags = v }) - (reqArg "FLAGS" + , option + "" + ["library-vanilla"] + "Vanilla libraries" + configVanillaLib + (\v flags -> flags{configVanillaLib = v}) + (boolOpt [] []) + , option + "p" + ["library-profiling"] + "Library profiling" + configProfLib + (\v flags -> flags{configProfLib = v}) + (boolOpt "p" []) + , option + "" + ["shared"] + "Shared library" + configSharedLib + (\v flags -> flags{configSharedLib = v}) + (boolOpt [] []) + , option + "" + ["static"] + "Static library" + configStaticLib + (\v flags -> flags{configStaticLib = v}) + (boolOpt [] []) + , option + "" + ["executable-dynamic"] + "Executable dynamic linking" + configDynExe + (\v flags -> flags{configDynExe = v}) + (boolOpt [] []) + , option + "" + ["executable-static"] + "Executable fully static linking" + configFullyStaticExe + (\v flags -> flags{configFullyStaticExe = v}) + (boolOpt [] []) + , option + "" + ["profiling"] + "Executable and library profiling" + configProf + (\v flags -> flags{configProf = v}) + (boolOpt [] []) + , option + "" + ["executable-profiling"] + "Executable profiling (DEPRECATED)" + configProfExe + (\v flags -> flags{configProfExe = v}) + (boolOpt [] []) + , option + "" + ["profiling-detail"] + ( "Profiling detail level for executable and library (default, " + ++ "none, exported-functions, toplevel-functions, all-functions, late)." + ) + configProfDetail + (\v flags -> flags{configProfDetail = v}) + ( reqArg' + "level" + (Flag . flagToProfDetailLevel) + showProfDetailLevelFlag + ) + , option + "" + ["library-profiling-detail"] + "Profiling detail level for libraries only." + configProfLibDetail + (\v flags -> flags{configProfLibDetail = v}) + ( reqArg' + "level" + (Flag . flagToProfDetailLevel) + showProfDetailLevelFlag + ) + , multiOption + "optimization" + configOptimization + (\v flags -> flags{configOptimization = v}) + [ optArg' + "n" + (Flag . flagToOptimisationLevel) + ( \f -> case f of + Flag NoOptimisation -> [] + Flag NormalOptimisation -> [Nothing] + Flag MaximumOptimisation -> [Just "2"] + _ -> [] + ) + "O" + ["enable-optimization", "enable-optimisation"] + "Build with optimization (n is 0--2, default is 1)" + , noArg + (Flag NoOptimisation) + [] + ["disable-optimization", "disable-optimisation"] + "Build without optimization" + ] + , multiOption + "debug-info" + configDebugInfo + (\v flags -> flags{configDebugInfo = v}) + [ optArg' + "n" + (Flag . flagToDebugInfoLevel) + ( \f -> case f of + Flag NoDebugInfo -> [] + Flag MinimalDebugInfo -> [Just "1"] + Flag NormalDebugInfo -> [Nothing] + Flag MaximalDebugInfo -> [Just "3"] + _ -> [] + ) + "" + ["enable-debug-info"] + "Emit debug info (n is 0--3, default is 0)" + , noArg + (Flag NoDebugInfo) + [] + ["disable-debug-info"] + "Don't emit debug info" + ] + , multiOption + "build-info" + configDumpBuildInfo + (\v flags -> flags{configDumpBuildInfo = v}) + [ noArg + (Flag DumpBuildInfo) + [] + ["enable-build-info"] + "Enable build information generation during project building" + , noArg + (Flag NoDumpBuildInfo) + [] + ["disable-build-info"] + "Disable build information generation during project building" + ] + , option + "" + ["library-for-ghci"] + "compile library for use with GHCi" + configGHCiLib + (\v flags -> flags{configGHCiLib = v}) + (boolOpt [] []) + , option + "" + ["split-sections"] + "compile library code such that unneeded definitions can be dropped from the final executable (GHC 7.8+)" + configSplitSections + (\v flags -> flags{configSplitSections = v}) + (boolOpt [] []) + , option + "" + ["split-objs"] + "split library into smaller objects to reduce binary sizes (GHC 6.6+)" + configSplitObjs + (\v flags -> flags{configSplitObjs = v}) + (boolOpt [] []) + , option + "" + ["executable-stripping"] + "strip executables upon installation to reduce binary sizes" + configStripExes + (\v flags -> flags{configStripExes = v}) + (boolOpt [] []) + , option + "" + ["library-stripping"] + "strip libraries upon installation to reduce binary sizes" + configStripLibs + (\v flags -> flags{configStripLibs = v}) + (boolOpt [] []) + , option + "" + ["configure-option"] + "Extra option for configure" + configConfigureArgs + (\v flags -> flags{configConfigureArgs = v}) + (reqArg' "OPT" (\x -> [x]) id) + , option + "" + ["user-install"] + "doing a per-user installation" + configUserInstall + (\v flags -> flags{configUserInstall = v}) + (boolOpt' ([], ["user"]) ([], ["global"])) + , option + "" + ["package-db"] + ( "Append the given package database to the list of package" + ++ " databases used (to satisfy dependencies and register into)." + ++ " May be a specific file, 'global' or 'user'. The initial list" + ++ " is ['global'], ['global', 'user'], or ['global', $sandbox]," + ++ " depending on context. Use 'clear' to reset the list to empty." + ++ " See the user guide for details." + ) + configPackageDBs + (\v flags -> flags{configPackageDBs = v}) + (reqArg' "DB" readPackageDbList showPackageDbList) + , option + "f" + ["flags"] + "Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false." + configConfigurationsFlags + (\v flags -> flags{configConfigurationsFlags = v}) + ( reqArg + "FLAGS" (parsecToReadE (\err -> "Invalid flag assignment: " ++ err) legacyParsecFlagAssignment) - legacyShowFlagAssignment') - - ,option "" ["extra-include-dirs"] - "A list of directories to search for header files" - configExtraIncludeDirs (\v flags -> flags {configExtraIncludeDirs = v}) - (reqArg' "PATH" (\x -> [x]) id) - - ,option "" ["deterministic"] - "Try to be as deterministic as possible (used by the test suite)" - configDeterministic (\v flags -> flags {configDeterministic = v}) - (boolOpt [] []) - - ,option "" ["ipid"] - "Installed package ID to compile this package as" - configIPID (\v flags -> flags {configIPID = v}) - (reqArgFlag "IPID") - - ,option "" ["cid"] - "Installed component ID to compile this component as" - (fmap prettyShow . configCID) (\v flags -> flags {configCID = fmap mkComponentId v}) - (reqArgFlag "CID") - - ,option "" ["extra-lib-dirs"] - "A list of directories to search for external libraries" - configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v}) - (reqArg' "PATH" (\x -> [x]) id) - - ,option "" ["extra-lib-dirs-static"] - "A list of directories to search for external libraries when linking fully static executables" - configExtraLibDirsStatic (\v flags -> flags {configExtraLibDirsStatic = v}) - (reqArg' "PATH" (\x -> [x]) id) - - ,option "" ["extra-framework-dirs"] - "A list of directories to search for external frameworks (OS X only)" - configExtraFrameworkDirs - (\v flags -> flags {configExtraFrameworkDirs = v}) - (reqArg' "PATH" (\x -> [x]) id) - - ,option "" ["extra-prog-path"] - "A list of directories to search for required programs (in addition to the normal search locations)" - configProgramPathExtra (\v flags -> flags {configProgramPathExtra = v}) - (reqArg' "PATH" (\x -> toNubList [x]) fromNubList) - - ,option "" ["constraint"] - "A list of additional constraints on the dependencies." - configConstraints (\v flags -> flags { configConstraints = v}) - (reqArg "DEPENDENCY" - (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsec)) - (map prettyShow)) - - ,option "" ["dependency"] - "A list of exact dependencies. E.g., --dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\"" - configDependencies (\v flags -> flags { configDependencies = v}) - (reqArg "NAME[:COMPONENT_NAME]=CID" - (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsecGivenComponent)) - (map (\(GivenComponent pn cn cid) -> - prettyShow pn - ++ case cn of LMainLibName -> "" - LSubLibName n -> ":" ++ prettyShow n - ++ "=" ++ prettyShow cid))) - - ,option "" ["instantiate-with"] - "A mapping of signature names to concrete module instantiations." - configInstantiateWith (\v flags -> flags { configInstantiateWith = v }) - (reqArg "NAME=MOD" - (parsecToReadE ("Cannot parse module substitution: " ++) (fmap (:[]) parsecModSubstEntry)) - (map (Disp.renderStyle defaultStyle . dispModSubstEntry))) - - ,option "" ["tests"] - "dependency checking and compilation for test suites listed in the package description file." - configTests (\v flags -> flags { configTests = v }) - (boolOpt [] []) - - ,option "" ["coverage"] - "build package with Haskell Program Coverage. (GHC only)" - configCoverage (\v flags -> flags { configCoverage = v }) - (boolOpt [] []) - - ,option "" ["library-coverage"] - "build package with Haskell Program Coverage. (GHC only) (DEPRECATED)" - configLibCoverage (\v flags -> flags { configLibCoverage = v }) - (boolOpt [] []) - - ,option "" ["exact-configuration"] - "All direct dependencies and flags are provided on the command line." - configExactConfiguration - (\v flags -> flags { configExactConfiguration = v }) - trueArg - - ,option "" ["benchmarks"] - "dependency checking and compilation for benchmarks listed in the package description file." - configBenchmarks (\v flags -> flags { configBenchmarks = v }) - (boolOpt [] []) - - ,option "" ["relocatable"] - "building a package that is relocatable. (GHC only)" - configRelocatable (\v flags -> flags { configRelocatable = v}) - (boolOpt [] []) - - ,option "" ["response-files"] - "enable workaround for old versions of programs like \"ar\" that do not support @file arguments" - configUseResponseFiles - (\v flags -> flags { configUseResponseFiles = v }) - (boolOpt' ([], ["disable-response-files"]) ([], [])) - - ,option "" ["allow-depending-on-private-libs"] - ( "Allow depending on private libraries. " - ++ "If set, the library visibility check MUST be done externally." ) - configAllowDependingOnPrivateLibs - (\v flags -> flags { configAllowDependingOnPrivateLibs = v }) - trueArg - ] + legacyShowFlagAssignment' + ) + , option + "" + ["extra-include-dirs"] + "A list of directories to search for header files" + configExtraIncludeDirs + (\v flags -> flags{configExtraIncludeDirs = v}) + (reqArg' "PATH" (\x -> [x]) id) + , option + "" + ["deterministic"] + "Try to be as deterministic as possible (used by the test suite)" + configDeterministic + (\v flags -> flags{configDeterministic = v}) + (boolOpt [] []) + , option + "" + ["ipid"] + "Installed package ID to compile this package as" + configIPID + (\v flags -> flags{configIPID = v}) + (reqArgFlag "IPID") + , option + "" + ["cid"] + "Installed component ID to compile this component as" + (fmap prettyShow . configCID) + (\v flags -> flags{configCID = fmap mkComponentId v}) + (reqArgFlag "CID") + , option + "" + ["extra-lib-dirs"] + "A list of directories to search for external libraries" + configExtraLibDirs + (\v flags -> flags{configExtraLibDirs = v}) + (reqArg' "PATH" (\x -> [x]) id) + , option + "" + ["extra-lib-dirs-static"] + "A list of directories to search for external libraries when linking fully static executables" + configExtraLibDirsStatic + (\v flags -> flags{configExtraLibDirsStatic = v}) + (reqArg' "PATH" (\x -> [x]) id) + , option + "" + ["extra-framework-dirs"] + "A list of directories to search for external frameworks (OS X only)" + configExtraFrameworkDirs + (\v flags -> flags{configExtraFrameworkDirs = v}) + (reqArg' "PATH" (\x -> [x]) id) + , option + "" + ["extra-prog-path"] + "A list of directories to search for required programs (in addition to the normal search locations)" + configProgramPathExtra + (\v flags -> flags{configProgramPathExtra = v}) + (reqArg' "PATH" (\x -> toNubList [x]) fromNubList) + , option + "" + ["constraint"] + "A list of additional constraints on the dependencies." + configConstraints + (\v flags -> flags{configConstraints = v}) + ( reqArg + "DEPENDENCY" + (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsec)) + (map prettyShow) + ) + , option + "" + ["dependency"] + "A list of exact dependencies. E.g., --dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\"" + configDependencies + (\v flags -> flags{configDependencies = v}) + ( reqArg + "NAME[:COMPONENT_NAME]=CID" + (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsecGivenComponent)) + ( map + ( \(GivenComponent pn cn cid) -> + prettyShow pn + ++ case cn of + LMainLibName -> "" + LSubLibName n -> ":" ++ prettyShow n + ++ "=" + ++ prettyShow cid + ) + ) + ) + , option + "" + ["instantiate-with"] + "A mapping of signature names to concrete module instantiations." + configInstantiateWith + (\v flags -> flags{configInstantiateWith = v}) + ( reqArg + "NAME=MOD" + (parsecToReadE ("Cannot parse module substitution: " ++) (fmap (: []) parsecModSubstEntry)) + (map (Disp.renderStyle defaultStyle . dispModSubstEntry)) + ) + , option + "" + ["tests"] + "dependency checking and compilation for test suites listed in the package description file." + configTests + (\v flags -> flags{configTests = v}) + (boolOpt [] []) + , option + "" + ["coverage"] + "build package with Haskell Program Coverage. (GHC only)" + configCoverage + (\v flags -> flags{configCoverage = v}) + (boolOpt [] []) + , option + "" + ["library-coverage"] + "build package with Haskell Program Coverage. (GHC only) (DEPRECATED)" + configLibCoverage + (\v flags -> flags{configLibCoverage = v}) + (boolOpt [] []) + , option + "" + ["exact-configuration"] + "All direct dependencies and flags are provided on the command line." + configExactConfiguration + (\v flags -> flags{configExactConfiguration = v}) + trueArg + , option + "" + ["benchmarks"] + "dependency checking and compilation for benchmarks listed in the package description file." + configBenchmarks + (\v flags -> flags{configBenchmarks = v}) + (boolOpt [] []) + , option + "" + ["relocatable"] + "building a package that is relocatable. (GHC only)" + configRelocatable + (\v flags -> flags{configRelocatable = v}) + (boolOpt [] []) + , option + "" + ["response-files"] + "enable workaround for old versions of programs like \"ar\" that do not support @file arguments" + configUseResponseFiles + (\v flags -> flags{configUseResponseFiles = v}) + (boolOpt' ([], ["disable-response-files"]) ([], [])) + , option + "" + ["allow-depending-on-private-libs"] + ( "Allow depending on private libraries. " + ++ "If set, the library visibility check MUST be done externally." + ) + configAllowDependingOnPrivateLibs + (\v flags -> flags{configAllowDependingOnPrivateLibs = v}) + trueArg + ] where liftInstallDirs = - liftOption configInstallDirs (\v flags -> flags { configInstallDirs = v }) + liftOption configInstallDirs (\v flags -> flags{configInstallDirs = v}) reqPathTemplateArgFlag title _sf _lf d get set = - reqArgFlag title _sf _lf d - (fmap fromPathTemplate . get) (set . fmap toPathTemplate) + reqArgFlag + title + _sf + _lf + d + (fmap fromPathTemplate . get) + (set . fmap toPathTemplate) readPackageDbList :: String -> [Maybe PackageDB] readPackageDbList str = [readPackageDb str] @@ -629,10 +840,10 @@ readPackageDbList str = [readPackageDb str] -- -- @since 3.7.0.0 readPackageDb :: String -> Maybe PackageDB -readPackageDb "clear" = Nothing +readPackageDb "clear" = Nothing readPackageDb "global" = Just GlobalPackageDB -readPackageDb "user" = Just UserPackageDB -readPackageDb other = Just (SpecificPackageDB other) +readPackageDb "user" = Just UserPackageDB +readPackageDb other = Just (SpecificPackageDB other) showPackageDbList :: [Maybe PackageDB] -> [String] showPackageDbList = map showPackageDb @@ -641,13 +852,13 @@ showPackageDbList = map showPackageDb -- -- @since 3.7.0.0 showPackageDb :: Maybe PackageDB -> String -showPackageDb Nothing = "clear" -showPackageDb (Just GlobalPackageDB) = "global" -showPackageDb (Just UserPackageDB) = "user" +showPackageDb Nothing = "clear" +showPackageDb (Just GlobalPackageDB) = "global" +showPackageDb (Just UserPackageDB) = "user" showPackageDb (Just (SpecificPackageDB db)) = db showProfDetailLevelFlag :: Flag ProfDetailLevel -> [String] -showProfDetailLevelFlag NoFlag = [] +showProfDetailLevelFlag NoFlag = [] showProfDetailLevelFlag (Flag dl) = [showProfDetailLevel dl] parsecGivenComponent :: ParsecParser GivenComponent @@ -656,84 +867,117 @@ parsecGivenComponent = do ln <- P.option LMainLibName $ do _ <- P.char ':' ucn <- parsec - return $ if unUnqualComponentName ucn == unPackageName pn - then LMainLibName - else LSubLibName ucn + return $ + if unUnqualComponentName ucn == unPackageName pn + then LMainLibName + else LSubLibName ucn _ <- P.char '=' cid <- parsec return $ GivenComponent pn ln cid installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))] installDirsOptions = - [ option "" ["prefix"] + [ option + "" + ["prefix"] "bake this prefix in preparation of installation" - prefix (\v flags -> flags { prefix = v }) + prefix + (\v flags -> flags{prefix = v}) installDirArg - - , option "" ["bindir"] + , option + "" + ["bindir"] "installation directory for executables" - bindir (\v flags -> flags { bindir = v }) + bindir + (\v flags -> flags{bindir = v}) installDirArg - - , option "" ["libdir"] + , option + "" + ["libdir"] "installation directory for libraries" - libdir (\v flags -> flags { libdir = v }) + libdir + (\v flags -> flags{libdir = v}) installDirArg - - , option "" ["libsubdir"] + , option + "" + ["libsubdir"] "subdirectory of libdir in which libs are installed" - libsubdir (\v flags -> flags { libsubdir = v }) + libsubdir + (\v flags -> flags{libsubdir = v}) installDirArg - - , option "" ["dynlibdir"] + , option + "" + ["dynlibdir"] "installation directory for dynamic libraries" - dynlibdir (\v flags -> flags { dynlibdir = v }) + dynlibdir + (\v flags -> flags{dynlibdir = v}) installDirArg - - , option "" ["libexecdir"] + , option + "" + ["libexecdir"] "installation directory for program executables" - libexecdir (\v flags -> flags { libexecdir = v }) + libexecdir + (\v flags -> flags{libexecdir = v}) installDirArg - - , option "" ["libexecsubdir"] + , option + "" + ["libexecsubdir"] "subdirectory of libexecdir in which private executables are installed" - libexecsubdir (\v flags -> flags { libexecsubdir = v }) + libexecsubdir + (\v flags -> flags{libexecsubdir = v}) installDirArg - - , option "" ["datadir"] + , option + "" + ["datadir"] "installation directory for read-only data" - datadir (\v flags -> flags { datadir = v }) + datadir + (\v flags -> flags{datadir = v}) installDirArg - - , option "" ["datasubdir"] + , option + "" + ["datasubdir"] "subdirectory of datadir in which data files are installed" - datasubdir (\v flags -> flags { datasubdir = v }) + datasubdir + (\v flags -> flags{datasubdir = v}) installDirArg - - , option "" ["docdir"] + , option + "" + ["docdir"] "installation directory for documentation" - docdir (\v flags -> flags { docdir = v }) + docdir + (\v flags -> flags{docdir = v}) installDirArg - - , option "" ["htmldir"] + , option + "" + ["htmldir"] "installation directory for HTML documentation" - htmldir (\v flags -> flags { htmldir = v }) + htmldir + (\v flags -> flags{htmldir = v}) installDirArg - - , option "" ["haddockdir"] + , option + "" + ["haddockdir"] "installation directory for haddock interfaces" - haddockdir (\v flags -> flags { haddockdir = v }) + haddockdir + (\v flags -> flags{haddockdir = v}) installDirArg - - , option "" ["sysconfdir"] + , option + "" + ["sysconfdir"] "installation directory for configuration files" - sysconfdir (\v flags -> flags { sysconfdir = v }) + sysconfdir + (\v flags -> flags{sysconfdir = v}) installDirArg ] where installDirArg _sf _lf d get set = - reqArgFlag "DIR" _sf _lf d - (fmap fromPathTemplate . get) (set . fmap toPathTemplate) + reqArgFlag + "DIR" + _sf + _lf + d + (fmap fromPathTemplate . get) + (set . fmap toPathTemplate) emptyConfigFlags :: ConfigFlags emptyConfigFlags = mempty @@ -745,32 +989,35 @@ instance Monoid ConfigFlags where instance Semigroup ConfigFlags where (<>) = gmappend - -- | Arguments to pass to a @configure@ script, e.g. generated by -- @autoconf@. configureArgs :: Bool -> ConfigFlags -> [String] -configureArgs bcHack flags - = hc_flag - ++ optFlag "with-hc-pkg" configHcPkg - ++ optFlag' "prefix" prefix - ++ optFlag' "bindir" bindir - ++ optFlag' "libdir" libdir - ++ optFlag' "libexecdir" libexecdir - ++ optFlag' "datadir" datadir - ++ optFlag' "sysconfdir" sysconfdir - ++ configConfigureArgs flags +configureArgs bcHack flags = + hc_flag + ++ optFlag "with-hc-pkg" configHcPkg + ++ optFlag' "prefix" prefix + ++ optFlag' "bindir" bindir + ++ optFlag' "libdir" libdir + ++ optFlag' "libexecdir" libexecdir + ++ optFlag' "datadir" datadir + ++ optFlag' "sysconfdir" sysconfdir + ++ configConfigureArgs flags where - hc_flag = case (configHcFlavor flags, configHcPath flags) of - (_, Flag hc_path) -> [hc_flag_name ++ hc_path] - (Flag hc, NoFlag) -> [hc_flag_name ++ prettyShow hc] - (NoFlag,NoFlag) -> [] - hc_flag_name - --TODO kill off thic bc hack when defaultUserHooks is removed. - | bcHack = "--with-hc=" - | otherwise = "--with-compiler=" - optFlag name config_field = case config_field flags of - Flag p -> ["--" ++ name ++ "=" ++ p] - NoFlag -> [] - optFlag' name config_field = optFlag name (fmap fromPathTemplate - . config_field - . configInstallDirs) + hc_flag = case (configHcFlavor flags, configHcPath flags) of + (_, Flag hc_path) -> [hc_flag_name ++ hc_path] + (Flag hc, NoFlag) -> [hc_flag_name ++ prettyShow hc] + (NoFlag, NoFlag) -> [] + hc_flag_name + -- TODO kill off thic bc hack when defaultUserHooks is removed. + | bcHack = "--with-hc=" + | otherwise = "--with-compiler=" + optFlag name config_field = case config_field flags of + Flag p -> ["--" ++ name ++ "=" ++ p] + NoFlag -> [] + optFlag' name config_field = + optFlag + name + ( fmap fromPathTemplate + . config_field + . configInstallDirs + ) diff --git a/Cabal/src/Distribution/Simple/Setup/Copy.hs b/Cabal/src/Distribution/Simple/Setup/Copy.hs index 0da627a734b..56416ddae5d 100644 --- a/Cabal/src/Distribution/Simple/Setup/Copy.hs +++ b/Cabal/src/Distribution/Simple/Setup/Copy.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Setup.Copy -- Copyright : Isaac Jones 2003-2004 @@ -16,99 +17,126 @@ -- -- Definition of the copy command-line options. -- See: @Distribution.Simple.Setup@ - -module Distribution.Simple.Setup.Copy ( - - CopyFlags(..), emptyCopyFlags, defaultCopyFlags, copyCommand, +module Distribution.Simple.Setup.Copy + ( CopyFlags (..) + , emptyCopyFlags + , defaultCopyFlags + , copyCommand ) where -import Prelude () import Distribution.Compat.Prelude hiding (get) +import Prelude () import Distribution.ReadE import Distribution.Simple.Command hiding (boolOpt, boolOpt') import Distribution.Simple.Flag -import Distribution.Simple.Utils import Distribution.Simple.InstallDirs +import Distribution.Simple.Utils import Distribution.Verbosity import Distribution.Simple.Setup.Common -- ------------------------------------------------------------ + -- * Copy flags + -- ------------------------------------------------------------ -- | Flags to @copy@: (destdir, copy-prefix (backwards compat), verbosity) -data CopyFlags = CopyFlags { - copyDest :: Flag CopyDest, - copyDistPref :: Flag FilePath, - copyVerbosity :: Flag Verbosity, - -- This is the same hack as in 'buildArgs'. But I (ezyang) don't +data CopyFlags = CopyFlags + { copyDest :: Flag CopyDest + , copyDistPref :: Flag FilePath + , copyVerbosity :: Flag Verbosity + , -- This is the same hack as in 'buildArgs'. But I (ezyang) don't -- think it's a hack, it's the right way to make hooks more robust -- TODO: Stop using this eventually when 'UserHooks' gets changed - copyArgs :: [String], - copyCabalFilePath :: Flag FilePath + copyArgs :: [String] + , copyCabalFilePath :: Flag FilePath } deriving (Show, Generic) defaultCopyFlags :: CopyFlags -defaultCopyFlags = CopyFlags { - copyDest = Flag NoCopyDest, - copyDistPref = NoFlag, - copyVerbosity = Flag normal, - copyArgs = [], - copyCabalFilePath = mempty - } +defaultCopyFlags = + CopyFlags + { copyDest = Flag NoCopyDest + , copyDistPref = NoFlag + , copyVerbosity = Flag normal + , copyArgs = [] + , copyCabalFilePath = mempty + } copyCommand :: CommandUI CopyFlags -copyCommand = CommandUI - { commandName = "copy" - , commandSynopsis = "Copy the files of all/specific components to install locations." - , commandDescription = Just $ \_ -> wrapText $ +copyCommand = + CommandUI + { commandName = "copy" + , commandSynopsis = "Copy the files of all/specific components to install locations." + , commandDescription = Just $ \_ -> + wrapText $ "Components encompass executables and libraries. " - ++ "Does not call register, and allows a prefix at install time. " - ++ "Without the --destdir flag, configure determines location.\n" - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " copy " - ++ " All the components in the package\n" - ++ " " ++ pname ++ " copy foo " - ++ " A component (i.e. lib, exe, test suite)" - , commandUsage = usageAlternatives "copy" $ - [ "[FLAGS]" - , "COMPONENTS [FLAGS]" - ] - , commandDefaultFlags = defaultCopyFlags - , commandOptions = \showOrParseArgs -> case showOrParseArgs of - ShowArgs -> filter ((`notElem` ["target-package-db"]) - . optionName) $ copyOptions ShowArgs - ParseArgs -> copyOptions ParseArgs -} - -copyOptions :: ShowOrParseArgs -> [OptionField CopyFlags] + ++ "Does not call register, and allows a prefix at install time. " + ++ "Without the --destdir flag, configure determines location.\n" + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " + ++ pname + ++ " copy " + ++ " All the components in the package\n" + ++ " " + ++ pname + ++ " copy foo " + ++ " A component (i.e. lib, exe, test suite)" + , commandUsage = + usageAlternatives "copy" $ + [ "[FLAGS]" + , "COMPONENTS [FLAGS]" + ] + , commandDefaultFlags = defaultCopyFlags + , commandOptions = \showOrParseArgs -> case showOrParseArgs of + ShowArgs -> + filter + ( (`notElem` ["target-package-db"]) + . optionName + ) + $ copyOptions ShowArgs + ParseArgs -> copyOptions ParseArgs + } + +copyOptions :: ShowOrParseArgs -> [OptionField CopyFlags] copyOptions showOrParseArgs = - [optionVerbosity copyVerbosity (\v flags -> flags { copyVerbosity = v }) - - ,optionDistPref - copyDistPref (\d flags -> flags { copyDistPref = d }) - showOrParseArgs - - ,option "" ["destdir"] - "directory to copy files to, prepended to installation directories" - copyDest (\v flags -> case copyDest flags of - Flag (CopyToDb _) -> error "Use either 'destdir' or 'target-package-db'." - _ -> flags { copyDest = v }) - (reqArg "DIR" (succeedReadE (Flag . CopyTo)) - (\f -> case f of Flag (CopyTo p) -> [p]; _ -> [])) - - ,option "" ["target-package-db"] - "package database to copy files into. Required when using ${pkgroot} prefix." - copyDest (\v flags -> case copyDest flags of - NoFlag -> flags { copyDest = v } - Flag NoCopyDest -> flags { copyDest = v } - _ -> error "Use either 'destdir' or 'target-package-db'.") - (reqArg "DATABASE" (succeedReadE (Flag . CopyToDb)) - (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> [])) + [ optionVerbosity copyVerbosity (\v flags -> flags{copyVerbosity = v}) + , optionDistPref + copyDistPref + (\d flags -> flags{copyDistPref = d}) + showOrParseArgs + , option + "" + ["destdir"] + "directory to copy files to, prepended to installation directories" + copyDest + ( \v flags -> case copyDest flags of + Flag (CopyToDb _) -> error "Use either 'destdir' or 'target-package-db'." + _ -> flags{copyDest = v} + ) + ( reqArg + "DIR" + (succeedReadE (Flag . CopyTo)) + (\f -> case f of Flag (CopyTo p) -> [p]; _ -> []) + ) + , option + "" + ["target-package-db"] + "package database to copy files into. Required when using ${pkgroot} prefix." + copyDest + ( \v flags -> case copyDest flags of + NoFlag -> flags{copyDest = v} + Flag NoCopyDest -> flags{copyDest = v} + _ -> error "Use either 'destdir' or 'target-package-db'." + ) + ( reqArg + "DATABASE" + (succeedReadE (Flag . CopyToDb)) + (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> []) + ) ] emptyCopyFlags :: CopyFlags @@ -120,4 +148,3 @@ instance Monoid CopyFlags where instance Semigroup CopyFlags where (<>) = gmappend - diff --git a/Cabal/src/Distribution/Simple/Setup/Global.hs b/Cabal/src/Distribution/Simple/Setup/Global.hs index 35e7b60f842..c3c8ad9a566 100644 --- a/Cabal/src/Distribution/Simple/Setup/Global.hs +++ b/Cabal/src/Distribution/Simple/Setup/Global.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Setup.Global -- Copyright : Isaac Jones 2003-2004 @@ -16,21 +17,24 @@ -- -- Definition of the global command-line options. -- See: @Distribution.Simple.Setup@ - -module Distribution.Simple.Setup.Global ( - GlobalFlags(..), emptyGlobalFlags, defaultGlobalFlags, globalCommand, +module Distribution.Simple.Setup.Global + ( GlobalFlags (..) + , emptyGlobalFlags + , defaultGlobalFlags + , globalCommand ) where -import Prelude () import Distribution.Compat.Prelude hiding (get) +import Prelude () import Distribution.Simple.Command hiding (boolOpt, boolOpt') import Distribution.Simple.Flag import Distribution.Simple.Setup.Common - -- ------------------------------------------------------------ + -- * Global flags + -- ------------------------------------------------------------ -- In fact since individual flags types are monoids and these are just sets of @@ -40,55 +44,72 @@ import Distribution.Simple.Setup.Common -- override with the ones we get from a file or the command line, or both. -- | Flags that apply at the top level, not to any sub-command. -data GlobalFlags = GlobalFlags { - globalVersion :: Flag Bool, - globalNumericVersion :: Flag Bool - } deriving (Generic, Typeable) +data GlobalFlags = GlobalFlags + { globalVersion :: Flag Bool + , globalNumericVersion :: Flag Bool + } + deriving (Generic, Typeable) defaultGlobalFlags :: GlobalFlags -defaultGlobalFlags = GlobalFlags { - globalVersion = Flag False, - globalNumericVersion = Flag False - } +defaultGlobalFlags = + GlobalFlags + { globalVersion = Flag False + , globalNumericVersion = Flag False + } globalCommand :: [Command action] -> CommandUI GlobalFlags -globalCommand commands = CommandUI - { commandName = "" - , commandSynopsis = "" - , commandUsage = \pname -> - "This Setup program uses the Haskell Cabal Infrastructure.\n" - ++ "See http://www.haskell.org/cabal/ for more information.\n" - ++ "\n" - ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n" - , commandDescription = Just $ \pname -> - let - commands' = commands ++ [commandAddAction helpCommandUI undefined] - cmdDescs = getNormalCommandDescriptions commands' - maxlen = maximum $ [length name | (name, _) <- cmdDescs] - align str = str ++ replicate (maxlen - length str) ' ' - in - "Commands:\n" - ++ unlines [ " " ++ align name ++ " " ++ descr - | (name, descr) <- cmdDescs ] - ++ "\n" - ++ "For more information about a command use\n" - ++ " " ++ pname ++ " COMMAND --help\n\n" - ++ "Typical steps for installing Cabal packages:\n" - ++ concat [ " " ++ pname ++ " " ++ x ++ "\n" - | x <- ["configure", "build", "install"]] - , commandNotes = Nothing - , commandDefaultFlags = defaultGlobalFlags - , commandOptions = \_ -> - [option ['V'] ["version"] - "Print version information" - globalVersion (\v flags -> flags { globalVersion = v }) - trueArg - ,option [] ["numeric-version"] - "Print just the version number" - globalNumericVersion (\v flags -> flags { globalNumericVersion = v }) - trueArg - ] - } +globalCommand commands = + CommandUI + { commandName = "" + , commandSynopsis = "" + , commandUsage = \pname -> + "This Setup program uses the Haskell Cabal Infrastructure.\n" + ++ "See http://www.haskell.org/cabal/ for more information.\n" + ++ "\n" + ++ "Usage: " + ++ pname + ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n" + , commandDescription = Just $ \pname -> + let + commands' = commands ++ [commandAddAction helpCommandUI undefined] + cmdDescs = getNormalCommandDescriptions commands' + maxlen = maximum $ [length name | (name, _) <- cmdDescs] + align str = str ++ replicate (maxlen - length str) ' ' + in + "Commands:\n" + ++ unlines + [ " " ++ align name ++ " " ++ descr + | (name, descr) <- cmdDescs + ] + ++ "\n" + ++ "For more information about a command use\n" + ++ " " + ++ pname + ++ " COMMAND --help\n\n" + ++ "Typical steps for installing Cabal packages:\n" + ++ concat + [ " " ++ pname ++ " " ++ x ++ "\n" + | x <- ["configure", "build", "install"] + ] + , commandNotes = Nothing + , commandDefaultFlags = defaultGlobalFlags + , commandOptions = \_ -> + [ option + ['V'] + ["version"] + "Print version information" + globalVersion + (\v flags -> flags{globalVersion = v}) + trueArg + , option + [] + ["numeric-version"] + "Print just the version number" + globalNumericVersion + (\v flags -> flags{globalNumericVersion = v}) + trueArg + ] + } emptyGlobalFlags :: GlobalFlags emptyGlobalFlags = mempty @@ -99,4 +120,3 @@ instance Monoid GlobalFlags where instance Semigroup GlobalFlags where (<>) = gmappend - diff --git a/Cabal/src/Distribution/Simple/Setup/Haddock.hs b/Cabal/src/Distribution/Simple/Setup/Haddock.hs index 1a35e796bde..c1043bbef2d 100644 --- a/Cabal/src/Distribution/Simple/Setup/Haddock.hs +++ b/Cabal/src/Distribution/Simple/Setup/Haddock.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Setup.Haddock -- Copyright : Isaac Jones 2003-2004 @@ -16,35 +17,41 @@ -- -- Definition of the haddock command-line options. -- See: @Distribution.Simple.Setup@ - -module Distribution.Simple.Setup.Haddock ( - - HaddockTarget(..), - HaddockFlags(..), emptyHaddockFlags, defaultHaddockFlags, haddockCommand, - Visibility(..), - HaddockProjectFlags(..), emptyHaddockProjectFlags, defaultHaddockProjectFlags, haddockProjectCommand, - haddockOptions, haddockProjectOptions, +module Distribution.Simple.Setup.Haddock + ( HaddockTarget (..) + , HaddockFlags (..) + , emptyHaddockFlags + , defaultHaddockFlags + , haddockCommand + , Visibility (..) + , HaddockProjectFlags (..) + , emptyHaddockProjectFlags + , defaultHaddockProjectFlags + , haddockProjectCommand + , haddockOptions + , haddockProjectOptions ) where -import Prelude () import Distribution.Compat.Prelude hiding (get) +import Prelude () +import qualified Distribution.Compat.CharParsing as P import Distribution.Parsec import Distribution.Pretty -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp import Distribution.Simple.Command hiding (boolOpt, boolOpt') import Distribution.Simple.Flag -import Distribution.Simple.Program import Distribution.Simple.InstallDirs +import Distribution.Simple.Program import Distribution.Verbosity +import qualified Text.PrettyPrint as Disp import Distribution.Simple.Setup.Common -- ------------------------------------------------------------ + -- * Haddock flags --- ------------------------------------------------------------ +-- ------------------------------------------------------------ -- | When we build haddock documentation, there are two cases: -- @@ -63,217 +70,284 @@ instance Binary HaddockTarget instance Structured HaddockTarget instance Pretty HaddockTarget where - pretty ForHackage = Disp.text "for-hackage" - pretty ForDevelopment = Disp.text "for-development" + pretty ForHackage = Disp.text "for-hackage" + pretty ForDevelopment = Disp.text "for-development" instance Parsec HaddockTarget where - parsec = P.choice [ P.try $ P.string "for-hackage" >> return ForHackage - , P.string "for-development" >> return ForDevelopment] + parsec = + P.choice + [ P.try $ P.string "for-hackage" >> return ForHackage + , P.string "for-development" >> return ForDevelopment + ] -data HaddockFlags = HaddockFlags { - haddockProgramPaths :: [(String, FilePath)], - haddockProgramArgs :: [(String, [String])], - haddockHoogle :: Flag Bool, - haddockHtml :: Flag Bool, - haddockHtmlLocation :: Flag String, - haddockForHackage :: Flag HaddockTarget, - haddockExecutables :: Flag Bool, - haddockTestSuites :: Flag Bool, - haddockBenchmarks :: Flag Bool, - haddockForeignLibs :: Flag Bool, - haddockInternal :: Flag Bool, - haddockCss :: Flag FilePath, - haddockLinkedSource :: Flag Bool, - haddockQuickJump :: Flag Bool, - haddockHscolourCss :: Flag FilePath, - haddockContents :: Flag PathTemplate, - haddockIndex :: Flag PathTemplate, - haddockDistPref :: Flag FilePath, - haddockKeepTempFiles:: Flag Bool, - haddockVerbosity :: Flag Verbosity, - haddockCabalFilePath :: Flag FilePath, - haddockBaseUrl :: Flag String, - haddockLib :: Flag String, - haddockOutputDir :: Flag FilePath, - haddockArgs :: [String] +data HaddockFlags = HaddockFlags + { haddockProgramPaths :: [(String, FilePath)] + , haddockProgramArgs :: [(String, [String])] + , haddockHoogle :: Flag Bool + , haddockHtml :: Flag Bool + , haddockHtmlLocation :: Flag String + , haddockForHackage :: Flag HaddockTarget + , haddockExecutables :: Flag Bool + , haddockTestSuites :: Flag Bool + , haddockBenchmarks :: Flag Bool + , haddockForeignLibs :: Flag Bool + , haddockInternal :: Flag Bool + , haddockCss :: Flag FilePath + , haddockLinkedSource :: Flag Bool + , haddockQuickJump :: Flag Bool + , haddockHscolourCss :: Flag FilePath + , haddockContents :: Flag PathTemplate + , haddockIndex :: Flag PathTemplate + , haddockDistPref :: Flag FilePath + , haddockKeepTempFiles :: Flag Bool + , haddockVerbosity :: Flag Verbosity + , haddockCabalFilePath :: Flag FilePath + , haddockBaseUrl :: Flag String + , haddockLib :: Flag String + , haddockOutputDir :: Flag FilePath + , haddockArgs :: [String] } deriving (Show, Generic, Typeable) defaultHaddockFlags :: HaddockFlags -defaultHaddockFlags = HaddockFlags { - haddockProgramPaths = mempty, - haddockProgramArgs = [], - haddockHoogle = Flag False, - haddockHtml = Flag False, - haddockHtmlLocation = NoFlag, - haddockForHackage = NoFlag, - haddockExecutables = Flag False, - haddockTestSuites = Flag False, - haddockBenchmarks = Flag False, - haddockForeignLibs = Flag False, - haddockInternal = Flag False, - haddockCss = NoFlag, - haddockLinkedSource = Flag False, - haddockQuickJump = Flag False, - haddockHscolourCss = NoFlag, - haddockContents = NoFlag, - haddockDistPref = NoFlag, - haddockKeepTempFiles= Flag False, - haddockVerbosity = Flag normal, - haddockCabalFilePath = mempty, - haddockIndex = NoFlag, - haddockBaseUrl = NoFlag, - haddockLib = NoFlag, - haddockOutputDir = NoFlag, - haddockArgs = mempty - } +defaultHaddockFlags = + HaddockFlags + { haddockProgramPaths = mempty + , haddockProgramArgs = [] + , haddockHoogle = Flag False + , haddockHtml = Flag False + , haddockHtmlLocation = NoFlag + , haddockForHackage = NoFlag + , haddockExecutables = Flag False + , haddockTestSuites = Flag False + , haddockBenchmarks = Flag False + , haddockForeignLibs = Flag False + , haddockInternal = Flag False + , haddockCss = NoFlag + , haddockLinkedSource = Flag False + , haddockQuickJump = Flag False + , haddockHscolourCss = NoFlag + , haddockContents = NoFlag + , haddockDistPref = NoFlag + , haddockKeepTempFiles = Flag False + , haddockVerbosity = Flag normal + , haddockCabalFilePath = mempty + , haddockIndex = NoFlag + , haddockBaseUrl = NoFlag + , haddockLib = NoFlag + , haddockOutputDir = NoFlag + , haddockArgs = mempty + } haddockCommand :: CommandUI HaddockFlags -haddockCommand = CommandUI - { commandName = "haddock" - , commandSynopsis = "Generate Haddock HTML documentation." - , commandDescription = Just $ \_ -> - "Requires the program haddock, version 2.x.\n" - , commandNotes = Nothing - , commandUsage = usageAlternatives "haddock" $ - [ "[FLAGS]" - , "COMPONENTS [FLAGS]" - ] - , commandDefaultFlags = defaultHaddockFlags - , commandOptions = \showOrParseArgs -> - haddockOptions showOrParseArgs - ++ programDbPaths progDb ParseArgs - haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v}) - ++ programDbOption progDb showOrParseArgs - haddockProgramArgs (\v fs -> fs { haddockProgramArgs = v }) - ++ programDbOptions progDb ParseArgs - haddockProgramArgs (\v flags -> flags { haddockProgramArgs = v}) - } +haddockCommand = + CommandUI + { commandName = "haddock" + , commandSynopsis = "Generate Haddock HTML documentation." + , commandDescription = Just $ \_ -> + "Requires the program haddock, version 2.x.\n" + , commandNotes = Nothing + , commandUsage = + usageAlternatives "haddock" $ + [ "[FLAGS]" + , "COMPONENTS [FLAGS]" + ] + , commandDefaultFlags = defaultHaddockFlags + , commandOptions = \showOrParseArgs -> + haddockOptions showOrParseArgs + ++ programDbPaths + progDb + ParseArgs + haddockProgramPaths + (\v flags -> flags{haddockProgramPaths = v}) + ++ programDbOption + progDb + showOrParseArgs + haddockProgramArgs + (\v fs -> fs{haddockProgramArgs = v}) + ++ programDbOptions + progDb + ParseArgs + haddockProgramArgs + (\v flags -> flags{haddockProgramArgs = v}) + } where - progDb = addKnownProgram haddockProgram - $ addKnownProgram ghcProgram - $ emptyProgramDb + progDb = + addKnownProgram haddockProgram $ + addKnownProgram ghcProgram $ + emptyProgramDb haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags] haddockOptions showOrParseArgs = - [optionVerbosity haddockVerbosity - (\v flags -> flags { haddockVerbosity = v }) - ,optionDistPref - haddockDistPref (\d flags -> flags { haddockDistPref = d }) - showOrParseArgs - - ,option "" ["keep-temp-files"] - "Keep temporary files" - haddockKeepTempFiles (\b flags -> flags { haddockKeepTempFiles = b }) - trueArg - - ,option "" ["hoogle"] - "Generate a hoogle database" - haddockHoogle (\v flags -> flags { haddockHoogle = v }) - trueArg - - ,option "" ["html"] - "Generate HTML documentation (the default)" - haddockHtml (\v flags -> flags { haddockHtml = v }) - trueArg - - ,option "" ["html-location"] - "Location of HTML documentation for pre-requisite packages" - haddockHtmlLocation (\v flags -> flags { haddockHtmlLocation = v }) - (reqArgFlag "URL") - - ,option "" ["for-hackage"] - "Collection of flags to generate documentation suitable for upload to hackage" - haddockForHackage (\v flags -> flags { haddockForHackage = v }) - (noArg (Flag ForHackage)) - - ,option "" ["executables"] - "Run haddock for Executables targets" - haddockExecutables (\v flags -> flags { haddockExecutables = v }) - trueArg - - ,option "" ["tests"] - "Run haddock for Test Suite targets" - haddockTestSuites (\v flags -> flags { haddockTestSuites = v }) - trueArg - - ,option "" ["benchmarks"] - "Run haddock for Benchmark targets" - haddockBenchmarks (\v flags -> flags { haddockBenchmarks = v }) - trueArg - - ,option "" ["foreign-libraries"] - "Run haddock for Foreign Library targets" - haddockForeignLibs (\v flags -> flags { haddockForeignLibs = v }) - trueArg - - ,option "" ["all"] - "Run haddock for all targets" - (\f -> allFlags [ haddockExecutables f - , haddockTestSuites f - , haddockBenchmarks f - , haddockForeignLibs f - ]) - (\v flags -> flags { haddockExecutables = v - , haddockTestSuites = v - , haddockBenchmarks = v - , haddockForeignLibs = v - }) - trueArg - - ,option "" ["internal"] - "Run haddock for internal modules and include all symbols" - haddockInternal (\v flags -> flags { haddockInternal = v }) - trueArg - - ,option "" ["css"] - "Use PATH as the haddock stylesheet" - haddockCss (\v flags -> flags { haddockCss = v }) - (reqArgFlag "PATH") - - ,option "" ["hyperlink-source","hyperlink-sources","hyperlinked-source"] - "Hyperlink the documentation to the source code" - haddockLinkedSource (\v flags -> flags { haddockLinkedSource = v }) - trueArg - - ,option "" ["quickjump"] - "Generate an index for interactive documentation navigation" - haddockQuickJump (\v flags -> flags { haddockQuickJump = v }) - trueArg - - ,option "" ["hscolour-css"] - "Use PATH as the HsColour stylesheet" - haddockHscolourCss (\v flags -> flags { haddockHscolourCss = v }) - (reqArgFlag "PATH") - - ,option "" ["contents-location"] - "Bake URL in as the location for the contents page" - haddockContents (\v flags -> flags { haddockContents = v }) - (reqArg' "URL" - (toFlag . toPathTemplate) - (flagToList . fmap fromPathTemplate)) - - ,option "" ["index-location"] - "Use a separately-generated HTML index" - haddockIndex (\v flags -> flags { haddockIndex = v}) - (reqArg' "URL" - (toFlag . toPathTemplate) - (flagToList . fmap fromPathTemplate)) - - ,option "" ["base-url"] - "Base URL for static files." - haddockBaseUrl (\v flags -> flags { haddockBaseUrl = v}) - (reqArgFlag "URL") - - ,option "" ["lib"] - "location of Haddocks static / auxiliary files" - haddockLib (\v flags -> flags { haddockLib = v}) - (reqArgFlag "DIR") - - ,option "" ["output-dir"] - "Generate haddock documentation into this directory. This flag is provided as a technology preview and is subject to change in the next releases." - haddockOutputDir (\v flags -> flags { haddockOutputDir = v }) - (reqArgFlag "DIR") + [ optionVerbosity + haddockVerbosity + (\v flags -> flags{haddockVerbosity = v}) + , optionDistPref + haddockDistPref + (\d flags -> flags{haddockDistPref = d}) + showOrParseArgs + , option + "" + ["keep-temp-files"] + "Keep temporary files" + haddockKeepTempFiles + (\b flags -> flags{haddockKeepTempFiles = b}) + trueArg + , option + "" + ["hoogle"] + "Generate a hoogle database" + haddockHoogle + (\v flags -> flags{haddockHoogle = v}) + trueArg + , option + "" + ["html"] + "Generate HTML documentation (the default)" + haddockHtml + (\v flags -> flags{haddockHtml = v}) + trueArg + , option + "" + ["html-location"] + "Location of HTML documentation for pre-requisite packages" + haddockHtmlLocation + (\v flags -> flags{haddockHtmlLocation = v}) + (reqArgFlag "URL") + , option + "" + ["for-hackage"] + "Collection of flags to generate documentation suitable for upload to hackage" + haddockForHackage + (\v flags -> flags{haddockForHackage = v}) + (noArg (Flag ForHackage)) + , option + "" + ["executables"] + "Run haddock for Executables targets" + haddockExecutables + (\v flags -> flags{haddockExecutables = v}) + trueArg + , option + "" + ["tests"] + "Run haddock for Test Suite targets" + haddockTestSuites + (\v flags -> flags{haddockTestSuites = v}) + trueArg + , option + "" + ["benchmarks"] + "Run haddock for Benchmark targets" + haddockBenchmarks + (\v flags -> flags{haddockBenchmarks = v}) + trueArg + , option + "" + ["foreign-libraries"] + "Run haddock for Foreign Library targets" + haddockForeignLibs + (\v flags -> flags{haddockForeignLibs = v}) + trueArg + , option + "" + ["all"] + "Run haddock for all targets" + ( \f -> + allFlags + [ haddockExecutables f + , haddockTestSuites f + , haddockBenchmarks f + , haddockForeignLibs f + ] + ) + ( \v flags -> + flags + { haddockExecutables = v + , haddockTestSuites = v + , haddockBenchmarks = v + , haddockForeignLibs = v + } + ) + trueArg + , option + "" + ["internal"] + "Run haddock for internal modules and include all symbols" + haddockInternal + (\v flags -> flags{haddockInternal = v}) + trueArg + , option + "" + ["css"] + "Use PATH as the haddock stylesheet" + haddockCss + (\v flags -> flags{haddockCss = v}) + (reqArgFlag "PATH") + , option + "" + ["hyperlink-source", "hyperlink-sources", "hyperlinked-source"] + "Hyperlink the documentation to the source code" + haddockLinkedSource + (\v flags -> flags{haddockLinkedSource = v}) + trueArg + , option + "" + ["quickjump"] + "Generate an index for interactive documentation navigation" + haddockQuickJump + (\v flags -> flags{haddockQuickJump = v}) + trueArg + , option + "" + ["hscolour-css"] + "Use PATH as the HsColour stylesheet" + haddockHscolourCss + (\v flags -> flags{haddockHscolourCss = v}) + (reqArgFlag "PATH") + , option + "" + ["contents-location"] + "Bake URL in as the location for the contents page" + haddockContents + (\v flags -> flags{haddockContents = v}) + ( reqArg' + "URL" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate) + ) + , option + "" + ["index-location"] + "Use a separately-generated HTML index" + haddockIndex + (\v flags -> flags{haddockIndex = v}) + ( reqArg' + "URL" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate) + ) + , option + "" + ["base-url"] + "Base URL for static files." + haddockBaseUrl + (\v flags -> flags{haddockBaseUrl = v}) + (reqArgFlag "URL") + , option + "" + ["lib"] + "location of Haddocks static / auxiliary files" + haddockLib + (\v flags -> flags{haddockLib = v}) + (reqArgFlag "DIR") + , option + "" + ["output-dir"] + "Generate haddock documentation into this directory. This flag is provided as a technology preview and is subject to change in the next releases." + haddockOutputDir + (\v flags -> flags{haddockOutputDir = v}) + (reqArgFlag "DIR") ] emptyHaddockFlags :: HaddockFlags @@ -287,240 +361,296 @@ instance Semigroup HaddockFlags where (<>) = gmappend -- ------------------------------------------------------------ + -- * HaddocksFlags flags + -- ------------------------------------------------------------ -- | Governs whether modules from a given interface should be visible or -- hidden in the Haddock generated content page. We don't expose this -- functionality to the user, but simply use 'Visible' for only local packages. -- Visibility of modules is available since @haddock-2.26.1@. --- data Visibility = Visible | Hidden deriving (Eq, Show) -data HaddockProjectFlags = HaddockProjectFlags { - haddockProjectHackage :: Flag Bool, - -- ^ a shortcut option which builds documentation linked to hackage. It implies: - -- * `--html-location='https://hackage.haskell.org/package/$prg-$version/docs' - -- * `--quickjump` - -- * `--gen-index` - -- * `--gen-contents` - -- * `--hyperlinked-source` - haddockProjectLocal :: Flag Bool, - -- ^ a shortcut option which builds self contained directory which contains - -- all the documentation, it implies: - -- * `--quickjump` - -- * `--gen-index` - -- * `--gen-contents` - -- * `--hyperlinked-source` - -- - -- And it will also pass `--base-url` option to `haddock`. - - -- options passed to @haddock@ via 'createHaddockIndex' - haddockProjectDir :: Flag String, - -- ^ output directory of combined haddocks, the default is './haddocks' - haddockProjectPrologue :: Flag String, - haddockProjectGenIndex :: Flag Bool, - haddockProjectGenContents :: Flag Bool, - haddockProjectInterfaces :: Flag [(FilePath, Maybe FilePath, Maybe FilePath, Visibility)], - -- ^ 'haddocksInterfaces' is inferred by the 'haddocksAction'; currently not - -- exposed to the user. - - -- options passed to @haddock@ via 'HaddockFlags' when building +data HaddockProjectFlags = HaddockProjectFlags + { haddockProjectHackage :: Flag Bool + -- ^ a shortcut option which builds documentation linked to hackage. It implies: + -- * `--html-location='https://hackage.haskell.org/package/$prg-$version/docs' + -- * `--quickjump` + -- * `--gen-index` + -- * `--gen-contents` + -- * `--hyperlinked-source` + , haddockProjectLocal :: Flag Bool + -- ^ a shortcut option which builds self contained directory which contains + -- all the documentation, it implies: + -- * `--quickjump` + -- * `--gen-index` + -- * `--gen-contents` + -- * `--hyperlinked-source` + -- + -- And it will also pass `--base-url` option to `haddock`. + , -- options passed to @haddock@ via 'createHaddockIndex' + haddockProjectDir :: Flag String + -- ^ output directory of combined haddocks, the default is './haddocks' + , haddockProjectPrologue :: Flag String + , haddockProjectGenIndex :: Flag Bool + , haddockProjectGenContents :: Flag Bool + , haddockProjectInterfaces :: Flag [(FilePath, Maybe FilePath, Maybe FilePath, Visibility)] + -- ^ 'haddocksInterfaces' is inferred by the 'haddocksAction'; currently not + -- exposed to the user. + , -- options passed to @haddock@ via 'HaddockFlags' when building -- documentation - haddockProjectProgramPaths :: [(String, FilePath)], - haddockProjectProgramArgs :: [(String, [String])], - haddockProjectHoogle :: Flag Bool, - -- haddockHtml is not supported - haddockProjectHtmlLocation :: Flag String, - -- haddockForHackage is not supported - haddockProjectExecutables :: Flag Bool, - haddockProjectTestSuites :: Flag Bool, - haddockProjectBenchmarks :: Flag Bool, - haddockProjectForeignLibs :: Flag Bool, - haddockProjectInternal :: Flag Bool, - haddockProjectCss :: Flag FilePath, - haddockProjectLinkedSource :: Flag Bool, - haddockProjectQuickJump :: Flag Bool, - haddockProjectHscolourCss :: Flag FilePath, - -- haddockContent is not supported, a fixed value is provided + haddockProjectProgramPaths :: [(String, FilePath)] + , haddockProjectProgramArgs :: [(String, [String])] + , haddockProjectHoogle :: Flag Bool + , -- haddockHtml is not supported + haddockProjectHtmlLocation :: Flag String + , -- haddockForHackage is not supported + haddockProjectExecutables :: Flag Bool + , haddockProjectTestSuites :: Flag Bool + , haddockProjectBenchmarks :: Flag Bool + , haddockProjectForeignLibs :: Flag Bool + , haddockProjectInternal :: Flag Bool + , haddockProjectCss :: Flag FilePath + , haddockProjectLinkedSource :: Flag Bool + , haddockProjectQuickJump :: Flag Bool + , haddockProjectHscolourCss :: Flag FilePath + , -- haddockContent is not supported, a fixed value is provided -- haddockIndex is not supported, a fixed value is provided -- haddockDistPerf is not supported, note: it changes location of the haddocks - haddockProjectKeepTempFiles:: Flag Bool, - haddockProjectVerbosity :: Flag Verbosity, - -- haddockBaseUrl is not supported, a fixed value is provided - haddockProjectLib :: Flag String, - haddockProjectOutputDir :: Flag FilePath + haddockProjectKeepTempFiles :: Flag Bool + , haddockProjectVerbosity :: Flag Verbosity + , -- haddockBaseUrl is not supported, a fixed value is provided + haddockProjectLib :: Flag String + , haddockProjectOutputDir :: Flag FilePath } deriving (Show, Generic, Typeable) defaultHaddockProjectFlags :: HaddockProjectFlags -defaultHaddockProjectFlags = HaddockProjectFlags { - haddockProjectHackage = Flag False, - haddockProjectLocal = Flag False, - haddockProjectDir = Flag "./haddocks", - haddockProjectPrologue = NoFlag, - haddockProjectGenIndex = Flag False, - haddockProjectGenContents = Flag False, - haddockProjectTestSuites = Flag False, - haddockProjectProgramPaths = mempty, - haddockProjectProgramArgs = mempty, - haddockProjectHoogle = Flag False, - haddockProjectHtmlLocation = NoFlag, - haddockProjectExecutables = Flag False, - haddockProjectBenchmarks = Flag False, - haddockProjectForeignLibs = Flag False, - haddockProjectInternal = Flag False, - haddockProjectCss = NoFlag, - haddockProjectLinkedSource = Flag False, - haddockProjectQuickJump = Flag False, - haddockProjectHscolourCss = NoFlag, - haddockProjectKeepTempFiles= Flag False, - haddockProjectVerbosity = Flag normal, - haddockProjectLib = NoFlag, - haddockProjectOutputDir = NoFlag, - haddockProjectInterfaces = NoFlag - } +defaultHaddockProjectFlags = + HaddockProjectFlags + { haddockProjectHackage = Flag False + , haddockProjectLocal = Flag False + , haddockProjectDir = Flag "./haddocks" + , haddockProjectPrologue = NoFlag + , haddockProjectGenIndex = Flag False + , haddockProjectGenContents = Flag False + , haddockProjectTestSuites = Flag False + , haddockProjectProgramPaths = mempty + , haddockProjectProgramArgs = mempty + , haddockProjectHoogle = Flag False + , haddockProjectHtmlLocation = NoFlag + , haddockProjectExecutables = Flag False + , haddockProjectBenchmarks = Flag False + , haddockProjectForeignLibs = Flag False + , haddockProjectInternal = Flag False + , haddockProjectCss = NoFlag + , haddockProjectLinkedSource = Flag False + , haddockProjectQuickJump = Flag False + , haddockProjectHscolourCss = NoFlag + , haddockProjectKeepTempFiles = Flag False + , haddockProjectVerbosity = Flag normal + , haddockProjectLib = NoFlag + , haddockProjectOutputDir = NoFlag + , haddockProjectInterfaces = NoFlag + } haddockProjectCommand :: CommandUI HaddockProjectFlags -haddockProjectCommand = CommandUI - { commandName = "v2-haddock-project" - , commandSynopsis = "Generate Haddocks HTML documentation for the cabal project." - , commandDescription = Just $ \_ -> - "Require the programm haddock, version 2.26.\n" - , commandNotes = Nothing - , commandUsage = usageAlternatives "haddocks" $ - [ "[FLAGS]" - , "COMPONENTS [FLAGS]" - ] - , commandDefaultFlags = defaultHaddockProjectFlags - , commandOptions = \showOrParseArgs -> - haddockProjectOptions showOrParseArgs - ++ programDbPaths progDb ParseArgs - haddockProjectProgramPaths (\v flags -> flags { haddockProjectProgramPaths = v}) - ++ programDbOption progDb showOrParseArgs - haddockProjectProgramArgs (\v fs -> fs { haddockProjectProgramArgs = v }) - ++ programDbOptions progDb ParseArgs - haddockProjectProgramArgs (\v flags -> flags { haddockProjectProgramArgs = v}) - } +haddockProjectCommand = + CommandUI + { commandName = "v2-haddock-project" + , commandSynopsis = "Generate Haddocks HTML documentation for the cabal project." + , commandDescription = Just $ \_ -> + "Require the programm haddock, version 2.26.\n" + , commandNotes = Nothing + , commandUsage = + usageAlternatives "haddocks" $ + [ "[FLAGS]" + , "COMPONENTS [FLAGS]" + ] + , commandDefaultFlags = defaultHaddockProjectFlags + , commandOptions = \showOrParseArgs -> + haddockProjectOptions showOrParseArgs + ++ programDbPaths + progDb + ParseArgs + haddockProjectProgramPaths + (\v flags -> flags{haddockProjectProgramPaths = v}) + ++ programDbOption + progDb + showOrParseArgs + haddockProjectProgramArgs + (\v fs -> fs{haddockProjectProgramArgs = v}) + ++ programDbOptions + progDb + ParseArgs + haddockProjectProgramArgs + (\v flags -> flags{haddockProjectProgramArgs = v}) + } where - progDb = addKnownProgram haddockProgram - $ addKnownProgram ghcProgram - $ emptyProgramDb + progDb = + addKnownProgram haddockProgram $ + addKnownProgram ghcProgram $ + emptyProgramDb haddockProjectOptions :: ShowOrParseArgs -> [OptionField HaddockProjectFlags] haddockProjectOptions _showOrParseArgs = - [option "" ["hackage"] - (concat ["A short-cut option to build documentation linked to hackage; " - ,"it implies --quickjump, --gen-index, --gen-contents, " - ,"--hyperlinked-source and --html-location" - ]) - haddockProjectHackage (\v flags -> flags { haddockProjectHackage = v }) - trueArg - - ,option "" ["local"] - (concat ["A short-cut option to build self contained documentation; " - ,"it implies --quickjump, --gen-index, --gen-contents " - ,"and --hyperlinked-source." - ]) - haddockProjectLocal (\v flags -> flags { haddockProjectLocal = v }) - trueArg - - ,option "" ["output"] + [ option + "" + ["hackage"] + ( concat + [ "A short-cut option to build documentation linked to hackage; " + , "it implies --quickjump, --gen-index, --gen-contents, " + , "--hyperlinked-source and --html-location" + ] + ) + haddockProjectHackage + (\v flags -> flags{haddockProjectHackage = v}) + trueArg + , option + "" + ["local"] + ( concat + [ "A short-cut option to build self contained documentation; " + , "it implies --quickjump, --gen-index, --gen-contents " + , "and --hyperlinked-source." + ] + ) + haddockProjectLocal + (\v flags -> flags{haddockProjectLocal = v}) + trueArg + , option + "" + ["output"] "Output directory" - haddockProjectDir (\v flags -> flags { haddockProjectDir = v }) + haddockProjectDir + (\v flags -> flags{haddockProjectDir = v}) (optArg' "DIRECTORY" maybeToFlag (fmap Just . flagToList)) - - ,option "" ["prologue"] - "File path to a prologue file in haddock format" - haddockProjectPrologue (\v flags -> flags { haddockProjectPrologue = v}) - (optArg' "PATH" maybeToFlag (fmap Just . flagToList)) - - ,option "" ["gen-index"] - "Generate index" - haddockProjectGenIndex (\v flags -> flags { haddockProjectGenIndex = v}) - trueArg - - ,option "" ["gen-contents"] - "Generate contents" - haddockProjectGenContents (\v flags -> flags { haddockProjectGenContents = v}) - trueArg - - ,option "" ["hoogle"] - "Generate a hoogle database" - haddockProjectHoogle (\v flags -> flags { haddockProjectHoogle = v }) - trueArg - - ,option "" ["html-location"] - "Location of HTML documentation for pre-requisite packages" - haddockProjectHtmlLocation (\v flags -> flags { haddockProjectHtmlLocation = v }) - (reqArgFlag "URL") - - ,option "" ["executables"] - "Run haddock for Executables targets" - haddockProjectExecutables (\v flags -> flags { haddockProjectExecutables = v }) - trueArg - - ,option "" ["tests"] - "Run haddock for Test Suite targets" - haddockProjectTestSuites (\v flags -> flags { haddockProjectTestSuites = v }) - trueArg - - ,option "" ["benchmarks"] - "Run haddock for Benchmark targets" - haddockProjectBenchmarks (\v flags -> flags { haddockProjectBenchmarks = v }) - trueArg - - ,option "" ["foreign-libraries"] - "Run haddock for Foreign Library targets" - haddockProjectForeignLibs (\v flags -> flags { haddockProjectForeignLibs = v }) - trueArg - - ,option "" ["internal"] - "Run haddock for internal modules and include all symbols" - haddockProjectInternal (\v flags -> flags { haddockProjectInternal = v }) - trueArg - - ,option "" ["css"] - "Use PATH as the haddock stylesheet" - haddockProjectCss (\v flags -> flags { haddockProjectCss = v }) - (reqArgFlag "PATH") - - ,option "" ["hyperlink-source","hyperlink-sources","hyperlinked-source"] - "Hyperlink the documentation to the source code" - haddockProjectLinkedSource (\v flags -> flags { haddockProjectLinkedSource = v }) - trueArg - - ,option "" ["quickjump"] - "Generate an index for interactive documentation navigation" - haddockProjectQuickJump (\v flags -> flags { haddockProjectQuickJump = v }) - trueArg - - ,option "" ["hscolour-css"] - "Use PATH as the HsColour stylesheet" - haddockProjectHscolourCss (\v flags -> flags { haddockProjectHscolourCss = v }) - (reqArgFlag "PATH") - - ,option "" ["keep-temp-files"] - "Keep temporary files" - haddockProjectKeepTempFiles (\b flags -> flags { haddockProjectKeepTempFiles = b }) - trueArg - - ,optionVerbosity haddockProjectVerbosity - (\v flags -> flags { haddockProjectVerbosity = v }) - - ,option "" ["lib"] - "location of Haddocks static / auxiliary files" - haddockProjectLib (\v flags -> flags { haddockProjectLib = v}) - (reqArgFlag "DIR") - - ,option "" ["output-dir"] - "Generate haddock documentation into this directory. This flag is provided as a technology preview and is subject to change in the next releases." - haddockProjectOutputDir (\v flags -> flags { haddockProjectOutputDir = v}) - (reqArgFlag "DIR") - ] - + , option + "" + ["prologue"] + "File path to a prologue file in haddock format" + haddockProjectPrologue + (\v flags -> flags{haddockProjectPrologue = v}) + (optArg' "PATH" maybeToFlag (fmap Just . flagToList)) + , option + "" + ["gen-index"] + "Generate index" + haddockProjectGenIndex + (\v flags -> flags{haddockProjectGenIndex = v}) + trueArg + , option + "" + ["gen-contents"] + "Generate contents" + haddockProjectGenContents + (\v flags -> flags{haddockProjectGenContents = v}) + trueArg + , option + "" + ["hoogle"] + "Generate a hoogle database" + haddockProjectHoogle + (\v flags -> flags{haddockProjectHoogle = v}) + trueArg + , option + "" + ["html-location"] + "Location of HTML documentation for pre-requisite packages" + haddockProjectHtmlLocation + (\v flags -> flags{haddockProjectHtmlLocation = v}) + (reqArgFlag "URL") + , option + "" + ["executables"] + "Run haddock for Executables targets" + haddockProjectExecutables + (\v flags -> flags{haddockProjectExecutables = v}) + trueArg + , option + "" + ["tests"] + "Run haddock for Test Suite targets" + haddockProjectTestSuites + (\v flags -> flags{haddockProjectTestSuites = v}) + trueArg + , option + "" + ["benchmarks"] + "Run haddock for Benchmark targets" + haddockProjectBenchmarks + (\v flags -> flags{haddockProjectBenchmarks = v}) + trueArg + , option + "" + ["foreign-libraries"] + "Run haddock for Foreign Library targets" + haddockProjectForeignLibs + (\v flags -> flags{haddockProjectForeignLibs = v}) + trueArg + , option + "" + ["internal"] + "Run haddock for internal modules and include all symbols" + haddockProjectInternal + (\v flags -> flags{haddockProjectInternal = v}) + trueArg + , option + "" + ["css"] + "Use PATH as the haddock stylesheet" + haddockProjectCss + (\v flags -> flags{haddockProjectCss = v}) + (reqArgFlag "PATH") + , option + "" + ["hyperlink-source", "hyperlink-sources", "hyperlinked-source"] + "Hyperlink the documentation to the source code" + haddockProjectLinkedSource + (\v flags -> flags{haddockProjectLinkedSource = v}) + trueArg + , option + "" + ["quickjump"] + "Generate an index for interactive documentation navigation" + haddockProjectQuickJump + (\v flags -> flags{haddockProjectQuickJump = v}) + trueArg + , option + "" + ["hscolour-css"] + "Use PATH as the HsColour stylesheet" + haddockProjectHscolourCss + (\v flags -> flags{haddockProjectHscolourCss = v}) + (reqArgFlag "PATH") + , option + "" + ["keep-temp-files"] + "Keep temporary files" + haddockProjectKeepTempFiles + (\b flags -> flags{haddockProjectKeepTempFiles = b}) + trueArg + , optionVerbosity + haddockProjectVerbosity + (\v flags -> flags{haddockProjectVerbosity = v}) + , option + "" + ["lib"] + "location of Haddocks static / auxiliary files" + haddockProjectLib + (\v flags -> flags{haddockProjectLib = v}) + (reqArgFlag "DIR") + , option + "" + ["output-dir"] + "Generate haddock documentation into this directory. This flag is provided as a technology preview and is subject to change in the next releases." + haddockProjectOutputDir + (\v flags -> flags{haddockProjectOutputDir = v}) + (reqArgFlag "DIR") + ] emptyHaddockProjectFlags :: HaddockProjectFlags emptyHaddockProjectFlags = mempty @@ -531,4 +661,3 @@ instance Monoid HaddockProjectFlags where instance Semigroup HaddockProjectFlags where (<>) = gmappend - diff --git a/Cabal/src/Distribution/Simple/Setup/Hscolour.hs b/Cabal/src/Distribution/Simple/Setup/Hscolour.hs index 44debdad5ca..6b5e2761133 100644 --- a/Cabal/src/Distribution/Simple/Setup/Hscolour.hs +++ b/Cabal/src/Distribution/Simple/Setup/Hscolour.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Setup.Hscolour -- Copyright : Isaac Jones 2003-2004 @@ -16,14 +17,15 @@ -- -- Definition of the hscolour command-line options. -- See: @Distribution.Simple.Setup@ - -module Distribution.Simple.Setup.Hscolour ( - - HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand, +module Distribution.Simple.Setup.Hscolour + ( HscolourFlags (..) + , emptyHscolourFlags + , defaultHscolourFlags + , hscolourCommand ) where -import Prelude () import Distribution.Compat.Prelude hiding (get) +import Prelude () import Distribution.Simple.Command hiding (boolOpt, boolOpt') import Distribution.Simple.Flag @@ -32,35 +34,38 @@ import Distribution.Verbosity import Distribution.Simple.Setup.Common -- ------------------------------------------------------------ + -- * HsColour flags + -- ------------------------------------------------------------ -data HscolourFlags = HscolourFlags { - hscolourCSS :: Flag FilePath, - hscolourExecutables :: Flag Bool, - hscolourTestSuites :: Flag Bool, - hscolourBenchmarks :: Flag Bool, - hscolourForeignLibs :: Flag Bool, - hscolourDistPref :: Flag FilePath, - hscolourVerbosity :: Flag Verbosity, - hscolourCabalFilePath :: Flag FilePath - } +data HscolourFlags = HscolourFlags + { hscolourCSS :: Flag FilePath + , hscolourExecutables :: Flag Bool + , hscolourTestSuites :: Flag Bool + , hscolourBenchmarks :: Flag Bool + , hscolourForeignLibs :: Flag Bool + , hscolourDistPref :: Flag FilePath + , hscolourVerbosity :: Flag Verbosity + , hscolourCabalFilePath :: Flag FilePath + } deriving (Show, Generic, Typeable) emptyHscolourFlags :: HscolourFlags emptyHscolourFlags = mempty defaultHscolourFlags :: HscolourFlags -defaultHscolourFlags = HscolourFlags { - hscolourCSS = NoFlag, - hscolourExecutables = Flag False, - hscolourTestSuites = Flag False, - hscolourBenchmarks = Flag False, - hscolourDistPref = NoFlag, - hscolourForeignLibs = Flag False, - hscolourVerbosity = Flag normal, - hscolourCabalFilePath = mempty - } +defaultHscolourFlags = + HscolourFlags + { hscolourCSS = NoFlag + , hscolourExecutables = Flag False + , hscolourTestSuites = Flag False + , hscolourBenchmarks = Flag False + , hscolourDistPref = NoFlag + , hscolourForeignLibs = Flag False + , hscolourVerbosity = Flag normal + , hscolourCabalFilePath = mempty + } instance Monoid HscolourFlags where mempty = gmempty @@ -70,61 +75,80 @@ instance Semigroup HscolourFlags where (<>) = gmappend hscolourCommand :: CommandUI HscolourFlags -hscolourCommand = CommandUI - { commandName = "hscolour" - , commandSynopsis = - "Generate HsColour colourised code, in HTML format." - , commandDescription = Just (\_ -> "Requires the hscolour program.\n") - , commandNotes = Just $ \_ -> - "Deprecated in favour of 'cabal haddock --hyperlink-source'." - , commandUsage = \pname -> - "Usage: " ++ pname ++ " hscolour [FLAGS]\n" - , commandDefaultFlags = defaultHscolourFlags - , commandOptions = \showOrParseArgs -> - [optionVerbosity hscolourVerbosity - (\v flags -> flags { hscolourVerbosity = v }) - ,optionDistPref - hscolourDistPref (\d flags -> flags { hscolourDistPref = d }) - showOrParseArgs - - ,option "" ["executables"] - "Run hscolour for Executables targets" - hscolourExecutables (\v flags -> flags { hscolourExecutables = v }) - trueArg - - ,option "" ["tests"] - "Run hscolour for Test Suite targets" - hscolourTestSuites (\v flags -> flags { hscolourTestSuites = v }) - trueArg - - ,option "" ["benchmarks"] - "Run hscolour for Benchmark targets" - hscolourBenchmarks (\v flags -> flags { hscolourBenchmarks = v }) - trueArg - - ,option "" ["foreign-libraries"] - "Run hscolour for Foreign Library targets" - hscolourForeignLibs (\v flags -> flags { hscolourForeignLibs = v }) - trueArg - - ,option "" ["all"] - "Run hscolour for all targets" - (\f -> allFlags [ hscolourExecutables f - , hscolourTestSuites f - , hscolourBenchmarks f - , hscolourForeignLibs f - ]) - (\v flags -> flags { hscolourExecutables = v - , hscolourTestSuites = v - , hscolourBenchmarks = v - , hscolourForeignLibs = v - }) - trueArg - - ,option "" ["css"] - "Use a cascading style sheet" - hscolourCSS (\v flags -> flags { hscolourCSS = v }) - (reqArgFlag "PATH") - ] - } - +hscolourCommand = + CommandUI + { commandName = "hscolour" + , commandSynopsis = + "Generate HsColour colourised code, in HTML format." + , commandDescription = Just (\_ -> "Requires the hscolour program.\n") + , commandNotes = Just $ \_ -> + "Deprecated in favour of 'cabal haddock --hyperlink-source'." + , commandUsage = \pname -> + "Usage: " ++ pname ++ " hscolour [FLAGS]\n" + , commandDefaultFlags = defaultHscolourFlags + , commandOptions = \showOrParseArgs -> + [ optionVerbosity + hscolourVerbosity + (\v flags -> flags{hscolourVerbosity = v}) + , optionDistPref + hscolourDistPref + (\d flags -> flags{hscolourDistPref = d}) + showOrParseArgs + , option + "" + ["executables"] + "Run hscolour for Executables targets" + hscolourExecutables + (\v flags -> flags{hscolourExecutables = v}) + trueArg + , option + "" + ["tests"] + "Run hscolour for Test Suite targets" + hscolourTestSuites + (\v flags -> flags{hscolourTestSuites = v}) + trueArg + , option + "" + ["benchmarks"] + "Run hscolour for Benchmark targets" + hscolourBenchmarks + (\v flags -> flags{hscolourBenchmarks = v}) + trueArg + , option + "" + ["foreign-libraries"] + "Run hscolour for Foreign Library targets" + hscolourForeignLibs + (\v flags -> flags{hscolourForeignLibs = v}) + trueArg + , option + "" + ["all"] + "Run hscolour for all targets" + ( \f -> + allFlags + [ hscolourExecutables f + , hscolourTestSuites f + , hscolourBenchmarks f + , hscolourForeignLibs f + ] + ) + ( \v flags -> + flags + { hscolourExecutables = v + , hscolourTestSuites = v + , hscolourBenchmarks = v + , hscolourForeignLibs = v + } + ) + trueArg + , option + "" + ["css"] + "Use a cascading style sheet" + hscolourCSS + (\v flags -> flags{hscolourCSS = v}) + (reqArgFlag "PATH") + ] + } diff --git a/Cabal/src/Distribution/Simple/Setup/Install.hs b/Cabal/src/Distribution/Simple/Setup/Install.hs index 5465164284f..b038a18a0b1 100644 --- a/Cabal/src/Distribution/Simple/Setup/Install.hs +++ b/Cabal/src/Distribution/Simple/Setup/Install.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Setup.Install -- Copyright : Isaac Jones 2003-2004 @@ -16,100 +17,134 @@ -- -- Definition of the install command-line options. -- See: @Distribution.Simple.Setup@ - -module Distribution.Simple.Setup.Install ( - InstallFlags(..), emptyInstallFlags, defaultInstallFlags, installCommand, +module Distribution.Simple.Setup.Install + ( InstallFlags (..) + , emptyInstallFlags + , defaultInstallFlags + , installCommand ) where -import Prelude () import Distribution.Compat.Prelude hiding (get) +import Prelude () import Distribution.ReadE import Distribution.Simple.Command hiding (boolOpt, boolOpt') import Distribution.Simple.Compiler import Distribution.Simple.Flag -import Distribution.Simple.Utils import Distribution.Simple.InstallDirs +import Distribution.Simple.Utils import Distribution.Verbosity import Distribution.Simple.Setup.Common -- ------------------------------------------------------------ + -- * Install flags + -- ------------------------------------------------------------ -- | Flags to @install@: (package db, verbosity) -data InstallFlags = InstallFlags { - installPackageDB :: Flag PackageDB, - installDest :: Flag CopyDest, - installDistPref :: Flag FilePath, - installUseWrapper :: Flag Bool, - installInPlace :: Flag Bool, - installVerbosity :: Flag Verbosity, - -- this is only here, because we can not +data InstallFlags = InstallFlags + { installPackageDB :: Flag PackageDB + , installDest :: Flag CopyDest + , installDistPref :: Flag FilePath + , installUseWrapper :: Flag Bool + , installInPlace :: Flag Bool + , installVerbosity :: Flag Verbosity + , -- this is only here, because we can not -- change the hooks API. installCabalFilePath :: Flag FilePath } deriving (Show, Generic) defaultInstallFlags :: InstallFlags -defaultInstallFlags = InstallFlags { - installPackageDB = NoFlag, - installDest = Flag NoCopyDest, - installDistPref = NoFlag, - installUseWrapper = Flag False, - installInPlace = Flag False, - installVerbosity = Flag normal, - installCabalFilePath = mempty - } +defaultInstallFlags = + InstallFlags + { installPackageDB = NoFlag + , installDest = Flag NoCopyDest + , installDistPref = NoFlag + , installUseWrapper = Flag False + , installInPlace = Flag False + , installVerbosity = Flag normal + , installCabalFilePath = mempty + } installCommand :: CommandUI InstallFlags -installCommand = CommandUI - { commandName = "install" - , commandSynopsis = - "Copy the files into the install locations. Run register." - , commandDescription = Just $ \_ -> wrapText $ - "Unlike the copy command, install calls the register command." - ++ "If you want to install into a location that is not what was" - ++ "specified in the configure step, use the copy command.\n" - , commandNotes = Nothing - , commandUsage = \pname -> - "Usage: " ++ pname ++ " install [FLAGS]\n" - , commandDefaultFlags = defaultInstallFlags - , commandOptions = \showOrParseArgs -> case showOrParseArgs of - ShowArgs -> filter ((`notElem` ["target-package-db"]) - . optionName) $ installOptions ShowArgs - ParseArgs -> installOptions ParseArgs - } - -installOptions :: ShowOrParseArgs -> [OptionField InstallFlags] +installCommand = + CommandUI + { commandName = "install" + , commandSynopsis = + "Copy the files into the install locations. Run register." + , commandDescription = Just $ \_ -> + wrapText $ + "Unlike the copy command, install calls the register command." + ++ "If you want to install into a location that is not what was" + ++ "specified in the configure step, use the copy command.\n" + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " install [FLAGS]\n" + , commandDefaultFlags = defaultInstallFlags + , commandOptions = \showOrParseArgs -> case showOrParseArgs of + ShowArgs -> + filter + ( (`notElem` ["target-package-db"]) + . optionName + ) + $ installOptions ShowArgs + ParseArgs -> installOptions ParseArgs + } + +installOptions :: ShowOrParseArgs -> [OptionField InstallFlags] installOptions showOrParseArgs = - [optionVerbosity installVerbosity (\v flags -> flags { installVerbosity = v }) - ,optionDistPref - installDistPref (\d flags -> flags { installDistPref = d }) - showOrParseArgs - - ,option "" ["inplace"] - "install the package in the install subdirectory of the dist prefix, so it can be used without being installed" - installInPlace (\v flags -> flags { installInPlace = v }) - trueArg - - ,option "" ["shell-wrappers"] - "using shell script wrappers around executables" - installUseWrapper (\v flags -> flags { installUseWrapper = v }) - (boolOpt [] []) - - ,option "" ["package-db"] "" - installPackageDB (\v flags -> flags { installPackageDB = v }) - (choiceOpt [ (Flag UserPackageDB, ([],["user"]), - "upon configuration register this package in the user's local package database") - , (Flag GlobalPackageDB, ([],["global"]), - "(default) upon configuration register this package in the system-wide package database")]) - ,option "" ["target-package-db"] - "package database to install into. Required when using ${pkgroot} prefix." - installDest (\v flags -> flags { installDest = v }) - (reqArg "DATABASE" (succeedReadE (Flag . CopyToDb)) - (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> [])) + [ optionVerbosity installVerbosity (\v flags -> flags{installVerbosity = v}) + , optionDistPref + installDistPref + (\d flags -> flags{installDistPref = d}) + showOrParseArgs + , option + "" + ["inplace"] + "install the package in the install subdirectory of the dist prefix, so it can be used without being installed" + installInPlace + (\v flags -> flags{installInPlace = v}) + trueArg + , option + "" + ["shell-wrappers"] + "using shell script wrappers around executables" + installUseWrapper + (\v flags -> flags{installUseWrapper = v}) + (boolOpt [] []) + , option + "" + ["package-db"] + "" + installPackageDB + (\v flags -> flags{installPackageDB = v}) + ( choiceOpt + [ + ( Flag UserPackageDB + , ([], ["user"]) + , "upon configuration register this package in the user's local package database" + ) + , + ( Flag GlobalPackageDB + , ([], ["global"]) + , "(default) upon configuration register this package in the system-wide package database" + ) + ] + ) + , option + "" + ["target-package-db"] + "package database to install into. Required when using ${pkgroot} prefix." + installDest + (\v flags -> flags{installDest = v}) + ( reqArg + "DATABASE" + (succeedReadE (Flag . CopyToDb)) + (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> []) + ) ] emptyInstallFlags :: InstallFlags @@ -121,4 +156,3 @@ instance Monoid InstallFlags where instance Semigroup InstallFlags where (<>) = gmappend - diff --git a/Cabal/src/Distribution/Simple/Setup/Register.hs b/Cabal/src/Distribution/Simple/Setup/Register.hs index 2211bbc9a83..ee1fc0d587b 100644 --- a/Cabal/src/Distribution/Simple/Setup/Register.hs +++ b/Cabal/src/Distribution/Simple/Setup/Register.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Setup.Register -- Copyright : Isaac Jones 2003-2004 @@ -16,14 +17,16 @@ -- -- Definition of the register command-line options. -- See: @Distribution.Simple.Setup@ - -module Distribution.Simple.Setup.Register ( - RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand, - unregisterCommand, +module Distribution.Simple.Setup.Register + ( RegisterFlags (..) + , emptyRegisterFlags + , defaultRegisterFlags + , registerCommand + , unregisterCommand ) where -import Prelude () import Distribution.Compat.Prelude hiding (get) +import Prelude () import Distribution.Simple.Command hiding (boolOpt, boolOpt') import Distribution.Simple.Compiler @@ -33,112 +36,153 @@ import Distribution.Verbosity import Distribution.Simple.Setup.Common -- ------------------------------------------------------------ + -- * Register flags + -- ------------------------------------------------------------ -- | Flags to @register@ and @unregister@: (user package, gen-script, -- in-place, verbosity) -data RegisterFlags = RegisterFlags { - regPackageDB :: Flag PackageDB, - regGenScript :: Flag Bool, - regGenPkgConf :: Flag (Maybe FilePath), - regInPlace :: Flag Bool, - regDistPref :: Flag FilePath, - regPrintId :: Flag Bool, - regVerbosity :: Flag Verbosity, - -- Same as in 'buildArgs' and 'copyArgs' - regArgs :: [String], - regCabalFilePath :: Flag FilePath +data RegisterFlags = RegisterFlags + { regPackageDB :: Flag PackageDB + , regGenScript :: Flag Bool + , regGenPkgConf :: Flag (Maybe FilePath) + , regInPlace :: Flag Bool + , regDistPref :: Flag FilePath + , regPrintId :: Flag Bool + , regVerbosity :: Flag Verbosity + , -- Same as in 'buildArgs' and 'copyArgs' + regArgs :: [String] + , regCabalFilePath :: Flag FilePath } deriving (Show, Generic, Typeable) defaultRegisterFlags :: RegisterFlags -defaultRegisterFlags = RegisterFlags { - regPackageDB = NoFlag, - regGenScript = Flag False, - regGenPkgConf = NoFlag, - regInPlace = Flag False, - regDistPref = NoFlag, - regPrintId = Flag False, - regArgs = [], - regCabalFilePath = mempty, - regVerbosity = Flag normal - } +defaultRegisterFlags = + RegisterFlags + { regPackageDB = NoFlag + , regGenScript = Flag False + , regGenPkgConf = NoFlag + , regInPlace = Flag False + , regDistPref = NoFlag + , regPrintId = Flag False + , regArgs = [] + , regCabalFilePath = mempty + , regVerbosity = Flag normal + } registerCommand :: CommandUI RegisterFlags -registerCommand = CommandUI - { commandName = "register" - , commandSynopsis = - "Register this package with the compiler." - , commandDescription = Nothing - , commandNotes = Nothing - , commandUsage = \pname -> - "Usage: " ++ pname ++ " register [FLAGS]\n" - , commandDefaultFlags = defaultRegisterFlags - , commandOptions = \showOrParseArgs -> - [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) - ,optionDistPref - regDistPref (\d flags -> flags { regDistPref = d }) - showOrParseArgs - - ,option "" ["packageDB"] "" - regPackageDB (\v flags -> flags { regPackageDB = v }) - (choiceOpt [ (Flag UserPackageDB, ([],["user"]), - "upon registration, register this package in the user's local package database") - , (Flag GlobalPackageDB, ([],["global"]), - "(default)upon registration, register this package in the system-wide package database")]) - - ,option "" ["inplace"] - "register the package in the build location, so it can be used without being installed" - regInPlace (\v flags -> flags { regInPlace = v }) - trueArg - - ,option "" ["gen-script"] - "instead of registering, generate a script to register later" - regGenScript (\v flags -> flags { regGenScript = v }) - trueArg - - ,option "" ["gen-pkg-config"] - "instead of registering, generate a package registration file/directory" - regGenPkgConf (\v flags -> flags { regGenPkgConf = v }) - (optArg' "PKG" Flag flagToList) - - ,option "" ["print-ipid"] - "print the installed package ID calculated for this package" - regPrintId (\v flags -> flags { regPrintId = v }) - trueArg - ] - } +registerCommand = + CommandUI + { commandName = "register" + , commandSynopsis = + "Register this package with the compiler." + , commandDescription = Nothing + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " register [FLAGS]\n" + , commandDefaultFlags = defaultRegisterFlags + , commandOptions = \showOrParseArgs -> + [ optionVerbosity regVerbosity (\v flags -> flags{regVerbosity = v}) + , optionDistPref + regDistPref + (\d flags -> flags{regDistPref = d}) + showOrParseArgs + , option + "" + ["packageDB"] + "" + regPackageDB + (\v flags -> flags{regPackageDB = v}) + ( choiceOpt + [ + ( Flag UserPackageDB + , ([], ["user"]) + , "upon registration, register this package in the user's local package database" + ) + , + ( Flag GlobalPackageDB + , ([], ["global"]) + , "(default)upon registration, register this package in the system-wide package database" + ) + ] + ) + , option + "" + ["inplace"] + "register the package in the build location, so it can be used without being installed" + regInPlace + (\v flags -> flags{regInPlace = v}) + trueArg + , option + "" + ["gen-script"] + "instead of registering, generate a script to register later" + regGenScript + (\v flags -> flags{regGenScript = v}) + trueArg + , option + "" + ["gen-pkg-config"] + "instead of registering, generate a package registration file/directory" + regGenPkgConf + (\v flags -> flags{regGenPkgConf = v}) + (optArg' "PKG" Flag flagToList) + , option + "" + ["print-ipid"] + "print the installed package ID calculated for this package" + regPrintId + (\v flags -> flags{regPrintId = v}) + trueArg + ] + } unregisterCommand :: CommandUI RegisterFlags -unregisterCommand = CommandUI - { commandName = "unregister" - , commandSynopsis = - "Unregister this package with the compiler." - , commandDescription = Nothing - , commandNotes = Nothing - , commandUsage = \pname -> - "Usage: " ++ pname ++ " unregister [FLAGS]\n" - , commandDefaultFlags = defaultRegisterFlags - , commandOptions = \showOrParseArgs -> - [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) - ,optionDistPref - regDistPref (\d flags -> flags { regDistPref = d }) - showOrParseArgs - - ,option "" ["user"] "" - regPackageDB (\v flags -> flags { regPackageDB = v }) - (choiceOpt [ (Flag UserPackageDB, ([],["user"]), - "unregister this package in the user's local package database") - , (Flag GlobalPackageDB, ([],["global"]), - "(default) unregister this package in the system-wide package database")]) - - ,option "" ["gen-script"] - "Instead of performing the unregister command, generate a script to unregister later" - regGenScript (\v flags -> flags { regGenScript = v }) - trueArg - ] - } +unregisterCommand = + CommandUI + { commandName = "unregister" + , commandSynopsis = + "Unregister this package with the compiler." + , commandDescription = Nothing + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " unregister [FLAGS]\n" + , commandDefaultFlags = defaultRegisterFlags + , commandOptions = \showOrParseArgs -> + [ optionVerbosity regVerbosity (\v flags -> flags{regVerbosity = v}) + , optionDistPref + regDistPref + (\d flags -> flags{regDistPref = d}) + showOrParseArgs + , option + "" + ["user"] + "" + regPackageDB + (\v flags -> flags{regPackageDB = v}) + ( choiceOpt + [ + ( Flag UserPackageDB + , ([], ["user"]) + , "unregister this package in the user's local package database" + ) + , + ( Flag GlobalPackageDB + , ([], ["global"]) + , "(default) unregister this package in the system-wide package database" + ) + ] + ) + , option + "" + ["gen-script"] + "Instead of performing the unregister command, generate a script to unregister later" + regGenScript + (\v flags -> flags{regGenScript = v}) + trueArg + ] + } emptyRegisterFlags :: RegisterFlags emptyRegisterFlags = mempty @@ -149,4 +193,3 @@ instance Monoid RegisterFlags where instance Semigroup RegisterFlags where (<>) = gmappend - diff --git a/Cabal/src/Distribution/Simple/Setup/Repl.hs b/Cabal/src/Distribution/Simple/Setup/Repl.hs index 2ae90e57c91..8ae7d729fb7 100644 --- a/Cabal/src/Distribution/Simple/Setup/Repl.hs +++ b/Cabal/src/Distribution/Simple/Setup/Repl.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Setup.Repl -- Copyright : Isaac Jones 2003-2004 @@ -16,40 +17,41 @@ -- -- Definition of the repl command-line options. -- See: @Distribution.Simple.Setup@ - -module Distribution.Simple.Setup.Repl ( - - ReplFlags(..), defaultReplFlags, replCommand, - ReplOptions(..), - replOptions, +module Distribution.Simple.Setup.Repl + ( ReplFlags (..) + , defaultReplFlags + , replCommand + , ReplOptions (..) + , replOptions ) where -import Prelude () import Distribution.Compat.Prelude hiding (get) +import Prelude () import Distribution.ReadE import Distribution.Simple.Command hiding (boolOpt, boolOpt') import Distribution.Simple.Flag -import Distribution.Simple.Utils import Distribution.Simple.Program +import Distribution.Simple.Utils import Distribution.Verbosity import Distribution.Simple.Setup.Common -- ------------------------------------------------------------ + -- * REPL Flags + -- ------------------------------------------------------------ -data ReplOptions = ReplOptions { - replOptionsFlags :: [String], - replOptionsNoLoad :: Flag Bool +data ReplOptions = ReplOptions + { replOptionsFlags :: [String] + , replOptionsNoLoad :: Flag Bool } deriving (Show, Generic, Typeable) instance Binary ReplOptions instance Structured ReplOptions - instance Monoid ReplOptions where mempty = ReplOptions mempty (Flag False) mappend = (<>) @@ -57,25 +59,26 @@ instance Monoid ReplOptions where instance Semigroup ReplOptions where (<>) = gmappend -data ReplFlags = ReplFlags { - replProgramPaths :: [(String, FilePath)], - replProgramArgs :: [(String, [String])], - replDistPref :: Flag FilePath, - replVerbosity :: Flag Verbosity, - replReload :: Flag Bool, - replReplOptions :: ReplOptions +data ReplFlags = ReplFlags + { replProgramPaths :: [(String, FilePath)] + , replProgramArgs :: [(String, [String])] + , replDistPref :: Flag FilePath + , replVerbosity :: Flag Verbosity + , replReload :: Flag Bool + , replReplOptions :: ReplOptions } deriving (Show, Generic, Typeable) defaultReplFlags :: ReplFlags -defaultReplFlags = ReplFlags { - replProgramPaths = mempty, - replProgramArgs = [], - replDistPref = NoFlag, - replVerbosity = Flag normal, - replReload = Flag False, - replReplOptions = mempty - } +defaultReplFlags = + ReplFlags + { replProgramPaths = mempty + , replProgramArgs = [] + , replDistPref = NoFlag + , replVerbosity = Flag normal + , replReload = Flag False + , replReplOptions = mempty + } instance Monoid ReplFlags where mempty = gmempty @@ -85,85 +88,107 @@ instance Semigroup ReplFlags where (<>) = gmappend replCommand :: ProgramDb -> CommandUI ReplFlags -replCommand progDb = CommandUI - { commandName = "repl" - , commandSynopsis = - "Open an interpreter session for the given component." - , commandDescription = Just $ \pname -> wrapText $ - "If the current directory contains no package, ignores COMPONENT " - ++ "parameters and opens an interactive interpreter session; if a " - ++ "sandbox is present, its package database will be used.\n" - ++ "\n" - ++ "Otherwise, (re)configures with the given or default flags, and " - ++ "loads the interpreter with the relevant modules. For executables, " - ++ "tests and benchmarks, loads the main module (and its " - ++ "dependencies); for libraries all exposed/other modules.\n" - ++ "\n" - ++ "The default component is the library itself, or the executable " - ++ "if that is the only component.\n" - ++ "\n" - ++ "Support for loading specific modules is planned but not " - ++ "implemented yet. For certain scenarios, `" ++ pname - ++ " exec -- ghci :l Foo` may be used instead. Note that `exec` will " - ++ "not (re)configure and you will have to specify the location of " - ++ "other modules, if required.\n" - - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " repl " - ++ " The first component in the package\n" - ++ " " ++ pname ++ " repl foo " - ++ " A named component (i.e. lib, exe, test suite)\n" - ++ " " ++ pname ++ " repl --repl-options=\"-lstdc++\"" - ++ " Specifying flags for interpreter\n" ---TODO: re-enable once we have support for module/file targets --- ++ " " ++ pname ++ " repl Foo.Bar " --- ++ " A module\n" --- ++ " " ++ pname ++ " repl Foo/Bar.hs" --- ++ " A file\n\n" --- ++ "If a target is ambiguous it can be qualified with the component " --- ++ "name, e.g.\n" --- ++ " " ++ pname ++ " repl foo:Foo.Bar\n" --- ++ " " ++ pname ++ " repl testsuite1:Foo/Bar.hs\n" - , commandUsage = \pname -> "Usage: " ++ pname ++ " repl [COMPONENT] [FLAGS]\n" - , commandDefaultFlags = defaultReplFlags - , commandOptions = \showOrParseArgs -> - optionVerbosity replVerbosity (\v flags -> flags { replVerbosity = v }) - : optionDistPref - replDistPref (\d flags -> flags { replDistPref = d }) - showOrParseArgs - - : programDbPaths progDb showOrParseArgs - replProgramPaths (\v flags -> flags { replProgramPaths = v}) - - ++ programDbOption progDb showOrParseArgs - replProgramArgs (\v flags -> flags { replProgramArgs = v}) - - ++ programDbOptions progDb showOrParseArgs - replProgramArgs (\v flags -> flags { replProgramArgs = v}) - - ++ case showOrParseArgs of - ParseArgs -> - [ option "" ["reload"] - "Used from within an interpreter to update files." - replReload (\v flags -> flags { replReload = v }) - trueArg - ] - _ -> [] - ++ map liftReplOption (replOptions showOrParseArgs) - } +replCommand progDb = + CommandUI + { commandName = "repl" + , commandSynopsis = + "Open an interpreter session for the given component." + , commandDescription = Just $ \pname -> + wrapText $ + "If the current directory contains no package, ignores COMPONENT " + ++ "parameters and opens an interactive interpreter session; if a " + ++ "sandbox is present, its package database will be used.\n" + ++ "\n" + ++ "Otherwise, (re)configures with the given or default flags, and " + ++ "loads the interpreter with the relevant modules. For executables, " + ++ "tests and benchmarks, loads the main module (and its " + ++ "dependencies); for libraries all exposed/other modules.\n" + ++ "\n" + ++ "The default component is the library itself, or the executable " + ++ "if that is the only component.\n" + ++ "\n" + ++ "Support for loading specific modules is planned but not " + ++ "implemented yet. For certain scenarios, `" + ++ pname + ++ " exec -- ghci :l Foo` may be used instead. Note that `exec` will " + ++ "not (re)configure and you will have to specify the location of " + ++ "other modules, if required.\n" + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " + ++ pname + ++ " repl " + ++ " The first component in the package\n" + ++ " " + ++ pname + ++ " repl foo " + ++ " A named component (i.e. lib, exe, test suite)\n" + ++ " " + ++ pname + ++ " repl --repl-options=\"-lstdc++\"" + ++ " Specifying flags for interpreter\n" + , -- TODO: re-enable once we have support for module/file targets + -- ++ " " ++ pname ++ " repl Foo.Bar " + -- ++ " A module\n" + -- ++ " " ++ pname ++ " repl Foo/Bar.hs" + -- ++ " A file\n\n" + -- ++ "If a target is ambiguous it can be qualified with the component " + -- ++ "name, e.g.\n" + -- ++ " " ++ pname ++ " repl foo:Foo.Bar\n" + -- ++ " " ++ pname ++ " repl testsuite1:Foo/Bar.hs\n" + commandUsage = \pname -> "Usage: " ++ pname ++ " repl [COMPONENT] [FLAGS]\n" + , commandDefaultFlags = defaultReplFlags + , commandOptions = \showOrParseArgs -> + optionVerbosity replVerbosity (\v flags -> flags{replVerbosity = v}) + : optionDistPref + replDistPref + (\d flags -> flags{replDistPref = d}) + showOrParseArgs + : programDbPaths + progDb + showOrParseArgs + replProgramPaths + (\v flags -> flags{replProgramPaths = v}) + ++ programDbOption + progDb + showOrParseArgs + replProgramArgs + (\v flags -> flags{replProgramArgs = v}) + ++ programDbOptions + progDb + showOrParseArgs + replProgramArgs + (\v flags -> flags{replProgramArgs = v}) + ++ case showOrParseArgs of + ParseArgs -> + [ option + "" + ["reload"] + "Used from within an interpreter to update files." + replReload + (\v flags -> flags{replReload = v}) + trueArg + ] + _ -> [] + ++ map liftReplOption (replOptions showOrParseArgs) + } where - liftReplOption = liftOption replReplOptions (\v flags -> flags { replReplOptions = v }) + liftReplOption = liftOption replReplOptions (\v flags -> flags{replReplOptions = v}) replOptions :: ShowOrParseArgs -> [OptionField ReplOptions] replOptions _ = - [ option [] ["repl-no-load"] - "Disable loading of project modules at REPL startup." - replOptionsNoLoad (\p flags -> flags { replOptionsNoLoad = p }) - trueArg - , option [] ["repl-options"] - "Use the option(s) for the repl" - replOptionsFlags (\p flags -> flags { replOptionsFlags = p }) - (reqArg "FLAG" (succeedReadE words) id) + [ option + [] + ["repl-no-load"] + "Disable loading of project modules at REPL startup." + replOptionsNoLoad + (\p flags -> flags{replOptionsNoLoad = p}) + trueArg + , option + [] + ["repl-options"] + "Use the option(s) for the repl" + replOptionsFlags + (\p flags -> flags{replOptionsFlags = p}) + (reqArg "FLAG" (succeedReadE words) id) ] - diff --git a/Cabal/src/Distribution/Simple/Setup/SDist.hs b/Cabal/src/Distribution/Simple/Setup/SDist.hs index 214c9222ff2..56dde313fbb 100644 --- a/Cabal/src/Distribution/Simple/Setup/SDist.hs +++ b/Cabal/src/Distribution/Simple/Setup/SDist.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Setup.SDist -- Copyright : Isaac Jones 2003-2004 @@ -16,14 +17,15 @@ -- -- Definition of the sdist command-line options. -- See: @Distribution.Simple.Setup@ - -module Distribution.Simple.Setup.SDist ( - - SDistFlags(..), emptySDistFlags, defaultSDistFlags, sdistCommand, +module Distribution.Simple.Setup.SDist + ( SDistFlags (..) + , emptySDistFlags + , defaultSDistFlags + , sdistCommand ) where -import Prelude () import Distribution.Compat.Prelude hiding (get) +import Prelude () import Distribution.Simple.Command hiding (boolOpt, boolOpt') import Distribution.Simple.Flag @@ -32,61 +34,73 @@ import Distribution.Verbosity import Distribution.Simple.Setup.Common -- ------------------------------------------------------------ + -- * SDist flags + -- ------------------------------------------------------------ -- | Flags to @sdist@: (snapshot, verbosity) -data SDistFlags = SDistFlags { - sDistSnapshot :: Flag Bool, - sDistDirectory :: Flag FilePath, - sDistDistPref :: Flag FilePath, - sDistListSources :: Flag FilePath, - sDistVerbosity :: Flag Verbosity +data SDistFlags = SDistFlags + { sDistSnapshot :: Flag Bool + , sDistDirectory :: Flag FilePath + , sDistDistPref :: Flag FilePath + , sDistListSources :: Flag FilePath + , sDistVerbosity :: Flag Verbosity } deriving (Show, Generic, Typeable) defaultSDistFlags :: SDistFlags -defaultSDistFlags = SDistFlags { - sDistSnapshot = Flag False, - sDistDirectory = mempty, - sDistDistPref = NoFlag, - sDistListSources = mempty, - sDistVerbosity = Flag normal - } +defaultSDistFlags = + SDistFlags + { sDistSnapshot = Flag False + , sDistDirectory = mempty + , sDistDistPref = NoFlag + , sDistListSources = mempty + , sDistVerbosity = Flag normal + } sdistCommand :: CommandUI SDistFlags -sdistCommand = CommandUI - { commandName = "sdist" - , commandSynopsis = - "Generate a source distribution file (.tar.gz)." - , commandDescription = Nothing - , commandNotes = Nothing - , commandUsage = \pname -> - "Usage: " ++ pname ++ " sdist [FLAGS]\n" - , commandDefaultFlags = defaultSDistFlags - , commandOptions = \showOrParseArgs -> - [optionVerbosity sDistVerbosity (\v flags -> flags { sDistVerbosity = v }) - ,optionDistPref - sDistDistPref (\d flags -> flags { sDistDistPref = d }) - showOrParseArgs - - ,option "" ["list-sources"] - "Just write a list of the package's sources to a file" - sDistListSources (\v flags -> flags { sDistListSources = v }) - (reqArgFlag "FILE") - - ,option "" ["snapshot"] - "Produce a snapshot source distribution" - sDistSnapshot (\v flags -> flags { sDistSnapshot = v }) - trueArg - - ,option "" ["output-directory"] - ("Generate a source distribution in the given directory, " - ++ "without creating a tarball") - sDistDirectory (\v flags -> flags { sDistDirectory = v }) - (reqArgFlag "DIR") - ] - } +sdistCommand = + CommandUI + { commandName = "sdist" + , commandSynopsis = + "Generate a source distribution file (.tar.gz)." + , commandDescription = Nothing + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " sdist [FLAGS]\n" + , commandDefaultFlags = defaultSDistFlags + , commandOptions = \showOrParseArgs -> + [ optionVerbosity sDistVerbosity (\v flags -> flags{sDistVerbosity = v}) + , optionDistPref + sDistDistPref + (\d flags -> flags{sDistDistPref = d}) + showOrParseArgs + , option + "" + ["list-sources"] + "Just write a list of the package's sources to a file" + sDistListSources + (\v flags -> flags{sDistListSources = v}) + (reqArgFlag "FILE") + , option + "" + ["snapshot"] + "Produce a snapshot source distribution" + sDistSnapshot + (\v flags -> flags{sDistSnapshot = v}) + trueArg + , option + "" + ["output-directory"] + ( "Generate a source distribution in the given directory, " + ++ "without creating a tarball" + ) + sDistDirectory + (\v flags -> flags{sDistDirectory = v}) + (reqArgFlag "DIR") + ] + } emptySDistFlags :: SDistFlags emptySDistFlags = mempty @@ -97,4 +111,3 @@ instance Monoid SDistFlags where instance Semigroup SDistFlags where (<>) = gmappend - diff --git a/Cabal/src/Distribution/Simple/Setup/Test.hs b/Cabal/src/Distribution/Simple/Setup/Test.hs index afbcbdd104d..bee0ccbef1a 100644 --- a/Cabal/src/Distribution/Simple/Setup/Test.hs +++ b/Cabal/src/Distribution/Simple/Setup/Test.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Test -- Copyright : Isaac Jones 2003-2004 @@ -16,170 +17,231 @@ -- -- Definition of the testing command-line options. -- See: @Distribution.Simple.Setup@ - -module Distribution.Simple.Setup.Test ( - - TestFlags(..), emptyTestFlags, defaultTestFlags, testCommand, - TestShowDetails(..), - testOptions' , +module Distribution.Simple.Setup.Test + ( TestFlags (..) + , emptyTestFlags + , defaultTestFlags + , testCommand + , TestShowDetails (..) + , testOptions' ) where -import Prelude () import Distribution.Compat.Prelude hiding (get) +import Prelude () -import Distribution.ReadE +import qualified Distribution.Compat.CharParsing as P import Distribution.Parsec import Distribution.Pretty -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp +import Distribution.ReadE import Distribution.Simple.Command hiding (boolOpt, boolOpt') import Distribution.Simple.Flag -import Distribution.Simple.Utils import Distribution.Simple.InstallDirs +import Distribution.Simple.Utils import Distribution.Verbosity +import qualified Text.PrettyPrint as Disp import Distribution.Simple.Setup.Common -- ------------------------------------------------------------ + -- * Test flags + -- ------------------------------------------------------------ data TestShowDetails = Never | Failures | Always | Streaming | Direct - deriving (Eq, Ord, Enum, Bounded, Generic, Show, Typeable) + deriving (Eq, Ord, Enum, Bounded, Generic, Show, Typeable) instance Binary TestShowDetails instance Structured TestShowDetails knownTestShowDetails :: [TestShowDetails] -knownTestShowDetails = [minBound..maxBound] +knownTestShowDetails = [minBound .. maxBound] instance Pretty TestShowDetails where - pretty = Disp.text . lowercase . show + pretty = Disp.text . lowercase . show instance Parsec TestShowDetails where - parsec = maybe (fail "invalid TestShowDetails") return . classify =<< ident - where - ident = P.munch1 (\c -> isAlpha c || c == '_' || c == '-') - classify str = lookup (lowercase str) enumMap - enumMap :: [(String, TestShowDetails)] - enumMap = [ (prettyShow x, x) - | x <- knownTestShowDetails ] - ---TODO: do we need this instance? + parsec = maybe (fail "invalid TestShowDetails") return . classify =<< ident + where + ident = P.munch1 (\c -> isAlpha c || c == '_' || c == '-') + classify str = lookup (lowercase str) enumMap + enumMap :: [(String, TestShowDetails)] + enumMap = + [ (prettyShow x, x) + | x <- knownTestShowDetails + ] + +-- TODO: do we need this instance? instance Monoid TestShowDetails where - mempty = Never - mappend = (<>) + mempty = Never + mappend = (<>) instance Semigroup TestShowDetails where - a <> b = if a < b then b else a - -data TestFlags = TestFlags { - testDistPref :: Flag FilePath, - testVerbosity :: Flag Verbosity, - testHumanLog :: Flag PathTemplate, - testMachineLog :: Flag PathTemplate, - testShowDetails :: Flag TestShowDetails, - testKeepTix :: Flag Bool, - testWrapper :: Flag FilePath, - testFailWhenNoTestSuites :: Flag Bool, - -- TODO: think about if/how options are passed to test exes - testOptions :: [PathTemplate] - } deriving (Show, Generic, Typeable) + a <> b = if a < b then b else a + +data TestFlags = TestFlags + { testDistPref :: Flag FilePath + , testVerbosity :: Flag Verbosity + , testHumanLog :: Flag PathTemplate + , testMachineLog :: Flag PathTemplate + , testShowDetails :: Flag TestShowDetails + , testKeepTix :: Flag Bool + , testWrapper :: Flag FilePath + , testFailWhenNoTestSuites :: Flag Bool + , -- TODO: think about if/how options are passed to test exes + testOptions :: [PathTemplate] + } + deriving (Show, Generic, Typeable) defaultTestFlags :: TestFlags -defaultTestFlags = TestFlags { - testDistPref = NoFlag, - testVerbosity = Flag normal, - testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log", - testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log", - testShowDetails = toFlag Direct, - testKeepTix = toFlag False, - testWrapper = NoFlag, - testFailWhenNoTestSuites = toFlag False, - testOptions = [] - } +defaultTestFlags = + TestFlags + { testDistPref = NoFlag + , testVerbosity = Flag normal + , testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log" + , testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log" + , testShowDetails = toFlag Direct + , testKeepTix = toFlag False + , testWrapper = NoFlag + , testFailWhenNoTestSuites = toFlag False + , testOptions = [] + } testCommand :: CommandUI TestFlags -testCommand = CommandUI - { commandName = "test" - , commandSynopsis = - "Run all/specific tests in the test suite." - , commandDescription = Just $ \ _pname -> wrapText $ - testOrBenchmarkHelpText "test" - , commandNotes = Nothing - , commandUsage = usageAlternatives "test" - [ "[FLAGS]" - , "TESTCOMPONENTS [FLAGS]" - ] - , commandDefaultFlags = defaultTestFlags - , commandOptions = testOptions' - } - -testOptions' :: ShowOrParseArgs -> [OptionField TestFlags] +testCommand = + CommandUI + { commandName = "test" + , commandSynopsis = + "Run all/specific tests in the test suite." + , commandDescription = Just $ \_pname -> + wrapText $ + testOrBenchmarkHelpText "test" + , commandNotes = Nothing + , commandUsage = + usageAlternatives + "test" + [ "[FLAGS]" + , "TESTCOMPONENTS [FLAGS]" + ] + , commandDefaultFlags = defaultTestFlags + , commandOptions = testOptions' + } + +testOptions' :: ShowOrParseArgs -> [OptionField TestFlags] testOptions' showOrParseArgs = - [ optionVerbosity testVerbosity (\v flags -> flags { testVerbosity = v }) + [ optionVerbosity testVerbosity (\v flags -> flags{testVerbosity = v}) , optionDistPref - testDistPref (\d flags -> flags { testDistPref = d }) - showOrParseArgs - , option [] ["log"] - ("Log all test suite results to file (name template can use " - ++ "$pkgid, $compiler, $os, $arch, $test-suite, $result)") - testHumanLog (\v flags -> flags { testHumanLog = v }) - (reqArg' "TEMPLATE" - (toFlag . toPathTemplate) - (flagToList . fmap fromPathTemplate)) - , option [] ["machine-log"] - ("Produce a machine-readable log file (name template can use " - ++ "$pkgid, $compiler, $os, $arch, $result)") - testMachineLog (\v flags -> flags { testMachineLog = v }) - (reqArg' "TEMPLATE" - (toFlag . toPathTemplate) - (flagToList . fmap fromPathTemplate)) - , option [] ["show-details"] - ("'always': always show results of individual test cases. " - ++ "'never': never show results of individual test cases. " - ++ "'failures': show results of failing test cases. " - ++ "'streaming': show results of test cases in real time." - ++ "'direct': send results of test cases in real time; no log file.") - testShowDetails (\v flags -> flags { testShowDetails = v }) - (reqArg "FILTER" - (parsecToReadE (\_ -> "--show-details flag expects one of " - ++ intercalate ", " - (map prettyShow knownTestShowDetails)) - (fmap toFlag parsec)) - (flagToList . fmap prettyShow)) - , option [] ["keep-tix-files"] - "keep .tix files for HPC between test runs" - testKeepTix (\v flags -> flags { testKeepTix = v}) - trueArg - , option [] ["test-wrapper"] - "Run test through a wrapper." - testWrapper (\v flags -> flags { testWrapper = v }) - (reqArg' "FILE" (toFlag :: FilePath -> Flag FilePath) - (flagToList :: Flag FilePath -> [FilePath])) - , option [] ["fail-when-no-test-suites"] - ("Exit with failure when no test suites are found.") - testFailWhenNoTestSuites (\v flags -> flags { testFailWhenNoTestSuites = v}) - trueArg - , option [] ["test-options"] - ("give extra options to test executables " - ++ "(name templates can use $pkgid, $compiler, " - ++ "$os, $arch, $test-suite)") - testOptions (\v flags -> flags { testOptions = v }) - (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs) - (const [])) - , option [] ["test-option"] - ("give extra option to test executables " - ++ "(no need to quote options containing spaces, " - ++ "name template can use $pkgid, $compiler, " - ++ "$os, $arch, $test-suite)") - testOptions (\v flags -> flags { testOptions = v }) - (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) - (map fromPathTemplate)) + testDistPref + (\d flags -> flags{testDistPref = d}) + showOrParseArgs + , option + [] + ["log"] + ( "Log all test suite results to file (name template can use " + ++ "$pkgid, $compiler, $os, $arch, $test-suite, $result)" + ) + testHumanLog + (\v flags -> flags{testHumanLog = v}) + ( reqArg' + "TEMPLATE" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate) + ) + , option + [] + ["machine-log"] + ( "Produce a machine-readable log file (name template can use " + ++ "$pkgid, $compiler, $os, $arch, $result)" + ) + testMachineLog + (\v flags -> flags{testMachineLog = v}) + ( reqArg' + "TEMPLATE" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate) + ) + , option + [] + ["show-details"] + ( "'always': always show results of individual test cases. " + ++ "'never': never show results of individual test cases. " + ++ "'failures': show results of failing test cases. " + ++ "'streaming': show results of test cases in real time." + ++ "'direct': send results of test cases in real time; no log file." + ) + testShowDetails + (\v flags -> flags{testShowDetails = v}) + ( reqArg + "FILTER" + ( parsecToReadE + ( \_ -> + "--show-details flag expects one of " + ++ intercalate + ", " + (map prettyShow knownTestShowDetails) + ) + (fmap toFlag parsec) + ) + (flagToList . fmap prettyShow) + ) + , option + [] + ["keep-tix-files"] + "keep .tix files for HPC between test runs" + testKeepTix + (\v flags -> flags{testKeepTix = v}) + trueArg + , option + [] + ["test-wrapper"] + "Run test through a wrapper." + testWrapper + (\v flags -> flags{testWrapper = v}) + ( reqArg' + "FILE" + (toFlag :: FilePath -> Flag FilePath) + (flagToList :: Flag FilePath -> [FilePath]) + ) + , option + [] + ["fail-when-no-test-suites"] + ("Exit with failure when no test suites are found.") + testFailWhenNoTestSuites + (\v flags -> flags{testFailWhenNoTestSuites = v}) + trueArg + , option + [] + ["test-options"] + ( "give extra options to test executables " + ++ "(name templates can use $pkgid, $compiler, " + ++ "$os, $arch, $test-suite)" + ) + testOptions + (\v flags -> flags{testOptions = v}) + ( reqArg' + "TEMPLATES" + (map toPathTemplate . splitArgs) + (const []) + ) + , option + [] + ["test-option"] + ( "give extra option to test executables " + ++ "(no need to quote options containing spaces, " + ++ "name template can use $pkgid, $compiler, " + ++ "$os, $arch, $test-suite)" + ) + testOptions + (\v flags -> flags{testOptions = v}) + ( reqArg' + "TEMPLATE" + (\x -> [toPathTemplate x]) + (map fromPathTemplate) + ) ] emptyTestFlags :: TestFlags -emptyTestFlags = mempty +emptyTestFlags = mempty instance Monoid TestFlags where mempty = gmempty @@ -187,4 +249,3 @@ instance Monoid TestFlags where instance Semigroup TestFlags where (<>) = gmappend - diff --git a/Cabal/src/Distribution/Simple/ShowBuildInfo.hs b/Cabal/src/Distribution/Simple/ShowBuildInfo.hs index 6cfecd8f463..4f84f3ed8e4 100644 --- a/Cabal/src/Distribution/Simple/ShowBuildInfo.hs +++ b/Cabal/src/Distribution/Simple/ShowBuildInfo.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | -- This module defines a simple JSON-based format for exporting basic -- information about a Cabal package and the compiler configuration Cabal @@ -55,12 +57,11 @@ -- * @src-files@: any other Haskell sources needed by the component -- -- Note: At the moment this is only supported when using the GHC compiler. --- - -{-# LANGUAGE OverloadedStrings #-} - -module Distribution.Simple.ShowBuildInfo ( - mkBuildInfo, mkBuildInfo', mkCompilerInfo, mkComponentInfo +module Distribution.Simple.ShowBuildInfo + ( mkBuildInfo + , mkBuildInfo' + , mkCompilerInfo + , mkComponentInfo ) where import System.FilePath @@ -68,37 +69,42 @@ import System.FilePath import Distribution.Compat.Prelude import Prelude () -import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.Program.GHC as GHC -import Distribution.PackageDescription import Distribution.Compiler -import Distribution.Verbosity -import Distribution.Simple.Compiler (Compiler, showCompilerId, compilerFlavor) +import Distribution.PackageDescription +import Distribution.Pretty +import Distribution.Simple.Compiler (Compiler, compilerFlavor, showCompilerId) import Distribution.Simple.Program -import Distribution.Simple.Setup.Build ( BuildFlags ) +import Distribution.Simple.Setup.Build (BuildFlags) import Distribution.Simple.Utils (cabalVersion) -import Distribution.Utils.Json +import Distribution.Text import Distribution.Types.Component import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.LocalBuildInfo import Distribution.Types.TargetInfo -import Distribution.Text -import Distribution.Pretty +import Distribution.Utils.Json +import Distribution.Verbosity -- | Construct a JSON document describing the build information for a -- package. mkBuildInfo - :: FilePath -- ^ The source directory of the package - -> PackageDescription -- ^ Mostly information from the .cabal file - -> LocalBuildInfo -- ^ Configuration information - -> BuildFlags -- ^ Flags that the user passed to build + :: FilePath + -- ^ The source directory of the package + -> PackageDescription + -- ^ Mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> BuildFlags + -- ^ Flags that the user passed to build -> (ConfiguredProgram, Compiler) -- ^ Compiler information. -- Needs to be passed explicitly, as we can't extract that information here -- without some partial function. -> [TargetInfo] - -> ([String], Json) -- ^ Json representation of buildinfo alongside generated warnings + -> ([String], Json) + -- ^ Json representation of buildinfo alongside generated warnings mkBuildInfo wdir pkg_descr lbi _flags compilerInfo targetsToBuild = (warnings, JsonObject buildInfoFields) where buildInfoFields = mkBuildInfo' (uncurry mkCompilerInfo compilerInfo) componentInfos @@ -113,33 +119,40 @@ mkBuildInfo wdir pkg_descr lbi _flags compilerInfo targetsToBuild = (warnings, J -- the schema at @\/doc\/json-schemas\/build-info.schema.json@ and the docs of -- @--enable-build-info@\/@--disable-build-info@. mkBuildInfo' - :: Json -- ^ The 'Json' from 'mkCompilerInfo' - -> [Json] -- ^ The 'Json' from 'mkComponentInfo' + :: Json + -- ^ The 'Json' from 'mkCompilerInfo' + -> [Json] + -- ^ The 'Json' from 'mkComponentInfo' -> [(String, Json)] mkBuildInfo' compilerInfo componentInfos = [ "cabal-lib-version" .= JsonString (display cabalVersion) - , "compiler" .= compilerInfo - , "components" .= JsonArray componentInfos + , "compiler" .= compilerInfo + , "components" .= JsonArray componentInfos ] mkCompilerInfo :: ConfiguredProgram -> Compiler -> Json -mkCompilerInfo compilerProgram compilerInfo = JsonObject - [ "flavour" .= JsonString (prettyShow $ compilerFlavor compilerInfo) - , "compiler-id" .= JsonString (showCompilerId compilerInfo) - , "path" .= JsonString (programPath compilerProgram) - ] +mkCompilerInfo compilerProgram compilerInfo = + JsonObject + [ "flavour" .= JsonString (prettyShow $ compilerFlavor compilerInfo) + , "compiler-id" .= JsonString (showCompilerId compilerInfo) + , "path" .= JsonString (programPath compilerProgram) + ] mkComponentInfo :: FilePath -> PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> ([String], Json) -mkComponentInfo wdir pkg_descr lbi clbi = (warnings, JsonObject $ - [ "type" .= JsonString compType - , "name" .= JsonString (prettyShow name) - , "unit-id" .= JsonString (prettyShow $ componentUnitId clbi) - , "compiler-args" .= JsonArray (map JsonString compilerArgs) - , "modules" .= JsonArray (map (JsonString . display) modules) - , "src-files" .= JsonArray (map JsonString sourceFiles) - , "hs-src-dirs" .= JsonArray (map (JsonString . prettyShow) $ hsSourceDirs bi) - , "src-dir" .= JsonString (addTrailingPathSeparator wdir) - ] <> cabalFile) +mkComponentInfo wdir pkg_descr lbi clbi = + ( warnings + , JsonObject $ + [ "type" .= JsonString compType + , "name" .= JsonString (prettyShow name) + , "unit-id" .= JsonString (prettyShow $ componentUnitId clbi) + , "compiler-args" .= JsonArray (map JsonString compilerArgs) + , "modules" .= JsonArray (map (JsonString . display) modules) + , "src-files" .= JsonArray (map JsonString sourceFiles) + , "hs-src-dirs" .= JsonArray (map (JsonString . prettyShow) $ hsSourceDirs bi) + , "src-dir" .= JsonString (addTrailingPathSeparator wdir) + ] + <> cabalFile + ) where (warnings, compilerArgs) = getCompilerArgs bi lbi clbi name = componentLocalName clbi @@ -147,11 +160,11 @@ mkComponentInfo wdir pkg_descr lbi clbi = (warnings, JsonObject $ -- If this error happens, a cabal invariant has been violated comp = fromMaybe (error $ "mkBuildInfo: no component " ++ prettyShow name) $ lookupComponent pkg_descr name compType = case comp of - CLib _ -> "lib" - CExe _ -> "exe" - CTest _ -> "test" + CLib _ -> "lib" + CExe _ -> "exe" + CTest _ -> "test" CBench _ -> "bench" - CFLib _ -> "flib" + CFLib _ -> "flib" modules = case comp of CLib lib -> explicitLibModules lib CExe exe -> exeModules exe @@ -163,7 +176,7 @@ mkComponentInfo wdir pkg_descr lbi clbi = (warnings, JsonObject $ CBench bench -> benchmarkModules bench CFLib flib -> foreignLibModules flib sourceFiles = case comp of - CLib _ -> [] + CLib _ -> [] CExe exe -> [modulePath exe] CTest test -> case testInterface test of @@ -173,11 +186,10 @@ mkComponentInfo wdir pkg_descr lbi clbi = (warnings, JsonObject $ CBench bench -> case benchmarkInterface bench of BenchmarkExeV10 _ fp -> [fp] BenchmarkUnsupported _ -> [] - CFLib _ -> [] cabalFile | Just fp <- pkgDescrFile lbi = [("cabal-file", JsonString fp)] - | otherwise = [] + | otherwise = [] -- | Get the command-line arguments that would be passed -- to the compiler to build the given component. @@ -188,12 +200,16 @@ getCompilerArgs -> ([String], [String]) getCompilerArgs bi lbi clbi = case compilerFlavor $ compiler lbi of - GHC -> ([], ghc) - GHCJS -> ([], ghc) - c -> - ( ["ShowBuildInfo.getCompilerArgs: Don't know how to get build " - ++ " arguments for compiler " ++ show c] - , []) + GHC -> ([], ghc) + GHCJS -> ([], ghc) + c -> + ( + [ "ShowBuildInfo.getCompilerArgs: Don't know how to get build " + ++ " arguments for compiler " + ++ show c + ] + , [] + ) where -- This is absolutely awful ghc = GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts diff --git a/Cabal/src/Distribution/Simple/SrcDist.hs b/Cabal/src/Distribution/Simple/SrcDist.hs index e3bf177ac24..86748bee38c 100644 --- a/Cabal/src/Distribution/Simple/SrcDist.hs +++ b/Cabal/src/Distribution/Simple/SrcDist.hs @@ -2,6 +2,10 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + +-- NOTE: FIX: we don't have a great way of testing this module, since +-- we can't easily look inside a tarball once its created. + -- | -- Module : Distribution.Simple.SrcDist -- Copyright : Simon Marlow 2004 @@ -19,68 +23,67 @@ -- The 'createArchive' action uses the external @tar@ program and assumes that -- it accepts the @-z@ flag. Neither of these assumptions are valid on Windows. -- The 'sdist' action now also does some distribution QA checks. +module Distribution.Simple.SrcDist + ( -- * The top level action + sdist + + -- ** Parts of 'sdist' + , printPackageProblems + , prepareTree + , createArchive + + -- ** Snapshots + , prepareSnapshotTree + , snapshotPackage + , snapshotVersion + , dateToSnapshotNumber + + -- * Extracting the source files + , listPackageSources + , listPackageSourcesWithDie + ) where --- NOTE: FIX: we don't have a great way of testing this module, since --- we can't easily look inside a tarball once its created. - -module Distribution.Simple.SrcDist ( - -- * The top level action - sdist, - - -- ** Parts of 'sdist' - printPackageProblems, - prepareTree, - createArchive, - - -- ** Snapshots - prepareSnapshotTree, - snapshotPackage, - snapshotVersion, - dateToSnapshotNumber, - - -- * Extracting the source files - listPackageSources, - listPackageSourcesWithDie, - - ) where - -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.PackageDescription -import Distribution.PackageDescription.Check hiding (doesFileExist) -import Distribution.Package import Distribution.ModuleName import qualified Distribution.ModuleName as ModuleName -import Distribution.Version +import Distribution.Package +import Distribution.PackageDescription +import Distribution.PackageDescription.Check hiding (doesFileExist) +import Distribution.Pretty +import Distribution.Simple.BuildPaths import Distribution.Simple.Configure (findDistPrefOrDefault) -import Distribution.Simple.Glob (matchDirFileGlobWithDie) -import Distribution.Simple.Utils import Distribution.Simple.Flag -import Distribution.Simple.Setup.SDist +import Distribution.Simple.Glob (matchDirFileGlobWithDie) import Distribution.Simple.PreProcess -import Distribution.Simple.BuildPaths import Distribution.Simple.Program -import Distribution.Pretty -import Distribution.Verbosity +import Distribution.Simple.Setup.SDist +import Distribution.Simple.Utils import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version import qualified Data.Map as Map import Data.Time (UTCTime, getCurrentTime, toGregorian, utctDay) -import System.Directory ( doesFileExist ) -import System.IO (IOMode(WriteMode), hPutStrLn, withFile) -import System.FilePath ((), (<.>), dropExtension, isRelative) - --- |Create a source distribution. -sdist :: PackageDescription -- ^ information from the tarball - -> SDistFlags -- ^ verbosity & snapshot - -> (FilePath -> FilePath) -- ^ build prefix (temp dir) - -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) - -> IO () +import System.Directory (doesFileExist) +import System.FilePath (dropExtension, isRelative, (<.>), ()) +import System.IO (IOMode (WriteMode), hPutStrLn, withFile) + +-- | Create a source distribution. +sdist + :: PackageDescription + -- ^ information from the tarball + -> SDistFlags + -- ^ verbosity & snapshot + -> (FilePath -> FilePath) + -- ^ build prefix (temp dir) + -> [PPSuffixHandler] + -- ^ extra preprocessors (includes suffixes) + -> IO () sdist pkg flags mkTmpDir pps = do - distPref <- findDistPrefOrDefault $ sDistDistPref flags - let targetPref = distPref + let targetPref = distPref tmpTargetDir = mkTmpDir distPref -- When given --list-sources, just output the list of sources to a file. @@ -89,20 +92,19 @@ sdist pkg flags mkTmpDir pps = do ordinary <- listPackageSources verbosity "." pkg pps traverse_ (hPutStrLn outHandle) ordinary notice verbosity $ "List of package sources written to file '" ++ path ++ "'" - - NoFlag -> do + NoFlag -> do -- do some QA printPackageProblems verbosity pkg date <- getCurrentTime - let pkg' | snapshot = snapshotPackage date pkg - | otherwise = pkg + let pkg' + | snapshot = snapshotPackage date pkg + | otherwise = pkg case flagToMaybe (sDistDirectory flags) of Just targetDir -> do generateSourceDir targetDir pkg' info verbosity $ "Source directory created: " ++ targetDir - Nothing -> do createDirectoryIfMissingVerbose verbosity True tmpTargetDir withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do @@ -110,7 +112,6 @@ sdist pkg flags mkTmpDir pps = do generateSourceDir targetDir pkg' targzFile <- createArchive verbosity pkg' tmpDir targetPref notice verbosity $ "Source tarball created: " ++ targzFile - where generateSourceDir :: FilePath -> PackageDescription -> IO () generateSourceDir targetDir pkg' = do @@ -120,22 +121,26 @@ sdist pkg flags mkTmpDir pps = do overwriteSnapshotPackageDesc verbosity pkg' targetDir verbosity = fromFlag (sDistVerbosity flags) - snapshot = fromFlag (sDistSnapshot flags) + snapshot = fromFlag (sDistSnapshot flags) -- | List all source files of a package. -- -- Since @Cabal-3.4@ returns a single list. There shouldn't be any -- executable files, they are hardly portable. --- listPackageSources - :: Verbosity -- ^ verbosity - -> FilePath -- ^ directory with cabal file - -> PackageDescription -- ^ info from the cabal file - -> [PPSuffixHandler] -- ^ extra preprocessors (include suffixes) - -> IO [FilePath] -- ^ relative paths + :: Verbosity + -- ^ verbosity + -> FilePath + -- ^ directory with cabal file + -> PackageDescription + -- ^ info from the cabal file + -> [PPSuffixHandler] + -- ^ extra preprocessors (include suffixes) + -> IO [FilePath] + -- ^ relative paths listPackageSources verbosity cwd pkg_descr0 pps = do - -- Call helpers that actually do all work. - listPackageSources' verbosity die' cwd pkg_descr pps + -- Call helpers that actually do all work. + listPackageSources' verbosity die' cwd pkg_descr pps where pkg_descr = filterAutogenModules pkg_descr0 @@ -145,163 +150,170 @@ listPackageSources verbosity cwd pkg_descr0 pps = do -- -- Since @3.4.0.0 listPackageSourcesWithDie - :: Verbosity -- ^ verbosity - -> (Verbosity -> String -> IO [FilePath]) - -- ^ 'die'' alternative. - -- Since 'die'' prefixes the error message with 'errorPrefix', - -- whatever is passed in here and wants to die should do the same. - -- See issue #7331. - -> FilePath -- ^ directory with cabal file - -> PackageDescription -- ^ info from the cabal file - -> [PPSuffixHandler] -- ^ extra preprocessors (include suffixes) - -> IO [FilePath] -- ^ relative paths + :: Verbosity + -- ^ verbosity + -> (Verbosity -> String -> IO [FilePath]) + -- ^ 'die'' alternative. + -- Since 'die'' prefixes the error message with 'errorPrefix', + -- whatever is passed in here and wants to die should do the same. + -- See issue #7331. + -> FilePath + -- ^ directory with cabal file + -> PackageDescription + -- ^ info from the cabal file + -> [PPSuffixHandler] + -- ^ extra preprocessors (include suffixes) + -> IO [FilePath] + -- ^ relative paths listPackageSourcesWithDie verbosity rip cwd pkg_descr0 pps = do - -- Call helpers that actually do all work. - listPackageSources' verbosity rip cwd pkg_descr pps + -- Call helpers that actually do all work. + listPackageSources' verbosity rip cwd pkg_descr pps where pkg_descr = filterAutogenModules pkg_descr0 - listPackageSources' :: Verbosity - -- ^ verbosity + -- ^ verbosity -> (Verbosity -> String -> IO [FilePath]) - -- ^ 'die'' alternative. - -- Since 'die'' prefixes the error message with 'errorPrefix', - -- whatever is passed in here and wants to die should do the same. - -- See issue #7331. + -- ^ 'die'' alternative. + -- Since 'die'' prefixes the error message with 'errorPrefix', + -- whatever is passed in here and wants to die should do the same. + -- See issue #7331. -> FilePath - -- ^ directory with cabal file + -- ^ directory with cabal file -> PackageDescription - -- ^ info from the cabal file + -- ^ info from the cabal file -> [PPSuffixHandler] - -- ^ extra preprocessors (include suffixes) + -- ^ extra preprocessors (include suffixes) -> IO [FilePath] - -- ^ relative paths + -- ^ relative paths listPackageSources' verbosity rip cwd pkg_descr pps = fmap concat . sequenceA $ - [ - -- Library sources. - fmap concat - . withAllLib $ \Library { - exposedModules = modules, - signatures = sigs, - libBuildInfo = libBi - } -> - allSourcesBuildInfo verbosity rip cwd libBi pps (modules ++ sigs) - - -- Executables sources. - , fmap concat - . withAllExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do - biSrcs <- allSourcesBuildInfo verbosity rip cwd exeBi pps [] - mainSrc <- findMainExeFile verbosity cwd exeBi pps mainPath - return (mainSrc:biSrcs) - - -- Foreign library sources - , fmap concat - . withAllFLib $ \flib@(ForeignLib { foreignLibBuildInfo = flibBi }) -> do - biSrcs <- allSourcesBuildInfo verbosity rip cwd flibBi pps [] - defFiles <- traverse (findModDefFile verbosity cwd flibBi pps) - (foreignLibModDefFile flib) - return (defFiles ++ biSrcs) - - -- Test suites sources. - , fmap concat - . withAllTest $ \t -> do - let bi = testBuildInfo t - case testInterface t of - TestSuiteExeV10 _ mainPath -> do - biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps [] - srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath - return (srcMainFile:biSrcs) - TestSuiteLibV09 _ m -> - allSourcesBuildInfo verbosity rip cwd bi pps [m] - TestSuiteUnsupported tp -> - rip verbosity $ "Unsupported test suite type: " ++ show tp - - -- Benchmarks sources. - , fmap concat - . withAllBenchmark $ \bm -> do - let bi = benchmarkBuildInfo bm - case benchmarkInterface bm of - BenchmarkExeV10 _ mainPath -> do - biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps [] - srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath - return (srcMainFile:biSrcs) - BenchmarkUnsupported tp -> - rip verbosity $ "Unsupported benchmark type: " ++ show tp - - -- Data files. - , fmap concat - . for (dataFiles pkg_descr) $ \filename -> do - let srcDataDirRaw = dataDir pkg_descr - srcDataDir | null srcDataDirRaw = "." - | otherwise = srcDataDirRaw - matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd (srcDataDir filename) - - -- Extra source files. - , fmap concat . for (extraSrcFiles pkg_descr) $ \fpath -> - matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd fpath - - -- Extra doc files. - , fmap concat - . for (extraDocFiles pkg_descr) $ \ filename -> - matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd filename - - -- License file(s). - , return (map getSymbolicPath $ licenseFiles pkg_descr) - - -- Install-include files, without autogen-include files - , fmap concat - . withAllLib $ \ l -> do - let lbi = libBuildInfo l - incls = filter (`notElem` autogenIncludes lbi) (installIncludes lbi) - relincdirs = "." : filter isRelative (includeDirs lbi) - traverse (fmap snd . findIncludeFile verbosity cwd relincdirs) incls - - -- Setup script, if it exists. - , fmap (maybe [] (\f -> [f])) $ findSetupFile cwd - - -- The .cabal file itself. - , fmap (\d -> [d]) (tryFindPackageDescCwd verbosity cwd ".") - - ] + [ -- Library sources. + fmap concat + . withAllLib + $ \Library + { exposedModules = modules + , signatures = sigs + , libBuildInfo = libBi + } -> + allSourcesBuildInfo verbosity rip cwd libBi pps (modules ++ sigs) + , -- Executables sources. + fmap concat + . withAllExe + $ \Executable{modulePath = mainPath, buildInfo = exeBi} -> do + biSrcs <- allSourcesBuildInfo verbosity rip cwd exeBi pps [] + mainSrc <- findMainExeFile verbosity cwd exeBi pps mainPath + return (mainSrc : biSrcs) + , -- Foreign library sources + fmap concat + . withAllFLib + $ \flib@(ForeignLib{foreignLibBuildInfo = flibBi}) -> do + biSrcs <- allSourcesBuildInfo verbosity rip cwd flibBi pps [] + defFiles <- + traverse + (findModDefFile verbosity cwd flibBi pps) + (foreignLibModDefFile flib) + return (defFiles ++ biSrcs) + , -- Test suites sources. + fmap concat + . withAllTest + $ \t -> do + let bi = testBuildInfo t + case testInterface t of + TestSuiteExeV10 _ mainPath -> do + biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps [] + srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath + return (srcMainFile : biSrcs) + TestSuiteLibV09 _ m -> + allSourcesBuildInfo verbosity rip cwd bi pps [m] + TestSuiteUnsupported tp -> + rip verbosity $ "Unsupported test suite type: " ++ show tp + , -- Benchmarks sources. + fmap concat + . withAllBenchmark + $ \bm -> do + let bi = benchmarkBuildInfo bm + case benchmarkInterface bm of + BenchmarkExeV10 _ mainPath -> do + biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps [] + srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath + return (srcMainFile : biSrcs) + BenchmarkUnsupported tp -> + rip verbosity $ "Unsupported benchmark type: " ++ show tp + , -- Data files. + fmap concat + . for (dataFiles pkg_descr) + $ \filename -> do + let srcDataDirRaw = dataDir pkg_descr + srcDataDir + | null srcDataDirRaw = "." + | otherwise = srcDataDirRaw + matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd (srcDataDir filename) + , -- Extra source files. + fmap concat . for (extraSrcFiles pkg_descr) $ \fpath -> + matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd fpath + , -- Extra doc files. + fmap concat + . for (extraDocFiles pkg_descr) + $ \filename -> + matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd filename + , -- License file(s). + return (map getSymbolicPath $ licenseFiles pkg_descr) + , -- Install-include files, without autogen-include files + fmap concat + . withAllLib + $ \l -> do + let lbi = libBuildInfo l + incls = filter (`notElem` autogenIncludes lbi) (installIncludes lbi) + relincdirs = "." : filter isRelative (includeDirs lbi) + traverse (fmap snd . findIncludeFile verbosity cwd relincdirs) incls + , -- Setup script, if it exists. + fmap (maybe [] (\f -> [f])) $ findSetupFile cwd + , -- The .cabal file itself. + fmap (\d -> [d]) (tryFindPackageDescCwd verbosity cwd ".") + ] where -- We have to deal with all libs and executables, so we have local -- versions of these functions that ignore the 'buildable' attribute: - withAllLib action = traverse action (allLibraries pkg_descr) - withAllFLib action = traverse action (foreignLibs pkg_descr) - withAllExe action = traverse action (executables pkg_descr) - withAllTest action = traverse action (testSuites pkg_descr) + withAllLib action = traverse action (allLibraries pkg_descr) + withAllFLib action = traverse action (foreignLibs pkg_descr) + withAllExe action = traverse action (executables pkg_descr) + withAllTest action = traverse action (testSuites pkg_descr) withAllBenchmark action = traverse action (benchmarks pkg_descr) - --- |Prepare a directory tree of source files. -prepareTree :: Verbosity -- ^ verbosity - -> PackageDescription -- ^ info from the cabal file - -> FilePath -- ^ source tree to populate - -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) - -> IO () +-- | Prepare a directory tree of source files. +prepareTree + :: Verbosity + -- ^ verbosity + -> PackageDescription + -- ^ info from the cabal file + -> FilePath + -- ^ source tree to populate + -> [PPSuffixHandler] + -- ^ extra preprocessors (includes suffixes) + -> IO () prepareTree verbosity pkg_descr0 targetDir pps = do - ordinary <- listPackageSources verbosity "." pkg_descr pps - installOrdinaryFiles verbosity targetDir (zip (repeat []) ordinary) - maybeCreateDefaultSetupScript targetDir + ordinary <- listPackageSources verbosity "." pkg_descr pps + installOrdinaryFiles verbosity targetDir (zip (repeat []) ordinary) + maybeCreateDefaultSetupScript targetDir where pkg_descr = filterAutogenModules pkg_descr0 -- | Find the setup script file, if it exists. findSetupFile :: FilePath -> IO (Maybe FilePath) findSetupFile targetDir = do - hsExists <- doesFileExist (targetDir setupHs) + hsExists <- doesFileExist (targetDir setupHs) lhsExists <- doesFileExist (targetDir setupLhs) if hsExists then return (Just setupHs) - else if lhsExists - then return (Just setupLhs) - else return Nothing - where - setupHs = "Setup.hs" - setupLhs = "Setup.lhs" + else + if lhsExists + then return (Just setupLhs) + else return Nothing + where + setupHs = "Setup.hs" + setupLhs = "Setup.lhs" -- | Create a default setup script in the target directory, if it doesn't exist. maybeCreateDefaultSetupScript :: FilePath -> IO () @@ -309,22 +321,30 @@ maybeCreateDefaultSetupScript targetDir = do mSetupFile <- findSetupFile targetDir case mSetupFile of Just _setupFile -> return () - Nothing -> do - writeUTF8File (targetDir "Setup.hs") $ unlines [ - "import Distribution.Simple", - "main = defaultMain"] + Nothing -> do + writeUTF8File (targetDir "Setup.hs") $ + unlines + [ "import Distribution.Simple" + , "main = defaultMain" + ] -- | Find the main executable file. findMainExeFile :: Verbosity - -> FilePath -- ^ cwd + -> FilePath + -- ^ cwd -> BuildInfo -> [PPSuffixHandler] - -> FilePath -- ^ main-is + -> FilePath + -- ^ main-is -> IO FilePath findMainExeFile verbosity cwd exeBi pps mainPath = do - ppFile <- findFileCwdWithExtension cwd (ppSuffixes pps) (map getSymbolicPath (hsSourceDirs exeBi)) - (dropExtension mainPath) + ppFile <- + findFileCwdWithExtension + cwd + (ppSuffixes pps) + (map getSymbolicPath (hsSourceDirs exeBi)) + (dropExtension mainPath) case ppFile of Nothing -> findFileCwd verbosity cwd (map getSymbolicPath (hsSourceDirs exeBi)) mainPath Just pp -> return pp @@ -335,153 +355,184 @@ findMainExeFile verbosity cwd exeBi pps mainPath = do findModDefFile :: Verbosity -> FilePath -> BuildInfo -> [PPSuffixHandler] -> FilePath -> IO FilePath findModDefFile verbosity cwd flibBi _pps modDefPath = - findFileCwd verbosity cwd ("." : map getSymbolicPath (hsSourceDirs flibBi)) modDefPath + findFileCwd verbosity cwd ("." : map getSymbolicPath (hsSourceDirs flibBi)) modDefPath -- | Given a list of include paths, try to find the include file named -- @f@. Return the name of the file and the full path, or exit with error if -- there's no such file. findIncludeFile :: Verbosity -> FilePath -> [FilePath] -> String -> IO (String, FilePath) findIncludeFile verbosity _ [] f = die' verbosity ("can't find include file " ++ f) -findIncludeFile verbosity cwd (d:ds) f = do +findIncludeFile verbosity cwd (d : ds) f = do let path = (d f) b <- doesFileExist (cwd path) - if b then return (f,path) else findIncludeFile verbosity cwd ds f + if b then return (f, path) else findIncludeFile verbosity cwd ds f -- | Remove the auto-generated modules (like 'Paths_*') from 'exposed-modules' -- and 'other-modules'. filterAutogenModules :: PackageDescription -> PackageDescription -filterAutogenModules pkg_descr0 = mapLib filterAutogenModuleLib $ - mapAllBuildInfo filterAutogenModuleBI pkg_descr0 +filterAutogenModules pkg_descr0 = + mapLib filterAutogenModuleLib $ + mapAllBuildInfo filterAutogenModuleBI pkg_descr0 where - mapLib f pkg = pkg { library = fmap f (library pkg) - , subLibraries = map f (subLibraries pkg) } - filterAutogenModuleLib lib = lib { - exposedModules = filter (filterFunction (libBuildInfo lib)) (exposedModules lib) - } - filterAutogenModuleBI bi = bi { - otherModules = filter (filterFunction bi) (otherModules bi) - } + mapLib f pkg = + pkg + { library = fmap f (library pkg) + , subLibraries = map f (subLibraries pkg) + } + filterAutogenModuleLib lib = + lib + { exposedModules = filter (filterFunction (libBuildInfo lib)) (exposedModules lib) + } + filterAutogenModuleBI bi = + bi + { otherModules = filter (filterFunction bi) (otherModules bi) + } pathsModule = autogenPathsModuleName pkg_descr0 packageInfoModule = autogenPackageInfoModuleName pkg_descr0 filterFunction bi = \mn -> - mn /= pathsModule - && mn /= packageInfoModule - && not (mn `elem` autogenModules bi) + mn /= pathsModule + && mn /= packageInfoModule + && not (mn `elem` autogenModules bi) -- | Prepare a directory tree of source files for a snapshot version. -- It is expected that the appropriate snapshot version has already been set -- in the package description, eg using 'snapshotPackage' or 'snapshotVersion'. --- prepareSnapshotTree - :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from the cabal file - -> FilePath -- ^source tree to populate - -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) + :: Verbosity + -- ^ verbosity + -> PackageDescription + -- ^ info from the cabal file + -> FilePath + -- ^ source tree to populate + -> [PPSuffixHandler] + -- ^ extra preprocessors (includes suffixes) -> IO () prepareSnapshotTree verbosity pkg targetDir pps = do prepareTree verbosity pkg targetDir pps overwriteSnapshotPackageDesc verbosity pkg targetDir -overwriteSnapshotPackageDesc :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from the cabal file - -> FilePath -- ^source tree - -> IO () +overwriteSnapshotPackageDesc + :: Verbosity + -- ^ verbosity + -> PackageDescription + -- ^ info from the cabal file + -> FilePath + -- ^ source tree + -> IO () overwriteSnapshotPackageDesc verbosity pkg targetDir = do - -- We could just writePackageDescription targetDescFile pkg_descr, - -- but that would lose comments and formatting. - descFile <- defaultPackageDesc verbosity - withUTF8FileContents descFile $ - writeUTF8File (targetDir descFile) - . unlines . map (replaceVersion (packageVersion pkg)) . lines - + -- We could just writePackageDescription targetDescFile pkg_descr, + -- but that would lose comments and formatting. + descFile <- defaultPackageDesc verbosity + withUTF8FileContents descFile $ + writeUTF8File (targetDir descFile) + . unlines + . map (replaceVersion (packageVersion pkg)) + . lines where replaceVersion :: Version -> String -> String replaceVersion version line - | "version:" `isPrefixOf` map toLower line - = "version: " ++ prettyShow version + | "version:" `isPrefixOf` map toLower line = + "version: " ++ prettyShow version | otherwise = line -- | Modifies a 'PackageDescription' by appending a snapshot number -- corresponding to the given date. --- snapshotPackage :: UTCTime -> PackageDescription -> PackageDescription snapshotPackage date pkg = - pkg { - package = pkgid { pkgVersion = snapshotVersion date (pkgVersion pkgid) } - } - where pkgid = packageId pkg + pkg + { package = pkgid{pkgVersion = snapshotVersion date (pkgVersion pkgid)} + } + where + pkgid = packageId pkg -- | Modifies a 'Version' by appending a snapshot number corresponding -- to the given date. --- snapshotVersion :: UTCTime -> Version -> Version snapshotVersion date = alterVersion (++ [dateToSnapshotNumber date]) -- | Given a date produce a corresponding integer representation. -- For example given a date @18/03/2008@ produce the number @20080318@. --- dateToSnapshotNumber :: UTCTime -> Int dateToSnapshotNumber date = case toGregorian (utctDay date) of - (year, month, day) -> - fromIntegral year * 10000 - + month * 100 - + day + (year, month, day) -> + fromIntegral year * 10000 + + month * 100 + + day -- | Create an archive from a tree of source files, and clean up the tree. createArchive - :: Verbosity -- ^ verbosity - -> PackageDescription -- ^ info from cabal file - -> FilePath -- ^ source tree to archive - -> FilePath -- ^ name of archive to create - -> IO FilePath + :: Verbosity + -- ^ verbosity + -> PackageDescription + -- ^ info from cabal file + -> FilePath + -- ^ source tree to archive + -> FilePath + -- ^ name of archive to create + -> IO FilePath createArchive verbosity pkg_descr tmpDir targetPref = do let tarBallFilePath = targetPref tarBallName pkg_descr <.> "tar.gz" (tarProg, _) <- requireProgram verbosity tarProgram defaultProgramDb - let formatOptSupported = maybe False (== "YES") $ - Map.lookup "Supports --format" - (programProperties tarProg) + let formatOptSupported = + maybe False (== "YES") $ + Map.lookup + "Supports --format" + (programProperties tarProg) runProgram verbosity tarProg $ -- Hmm: I could well be skating on thinner ice here by using the -C option -- (=> seems to be supported at least by GNU and *BSD tar) [The -- prev. solution used pipes and sub-command sequences to set up the paths -- correctly, which is problematic in a Windows setting.] ["-czf", tarBallFilePath, "-C", tmpDir] - ++ (if formatOptSupported then ["--format", "ustar"] else []) - ++ [tarBallName pkg_descr] + ++ (if formatOptSupported then ["--format", "ustar"] else []) + ++ [tarBallName pkg_descr] return tarBallFilePath -- | Given a buildinfo, return the names of all source files. allSourcesBuildInfo - :: Verbosity - -> (Verbosity -> String -> IO [FilePath]) - -- ^ 'die'' alternative. - -- Since 'die'' prefixes the error message with 'errorPrefix', - -- whatever is passed in here and wants to die should do the same. - -- See issue #7331. - -> FilePath -- ^ cwd -- change me to 'BuildPath Absolute PackageDir' - -> BuildInfo - -> [PPSuffixHandler] -- ^ Extra preprocessors - -> [ModuleName] -- ^ Exposed modules - -> IO [FilePath] + :: Verbosity + -> (Verbosity -> String -> IO [FilePath]) + -- ^ 'die'' alternative. + -- Since 'die'' prefixes the error message with 'errorPrefix', + -- whatever is passed in here and wants to die should do the same. + -- See issue #7331. + -> FilePath + -- ^ cwd -- change me to 'BuildPath Absolute PackageDir' + -> BuildInfo + -> [PPSuffixHandler] + -- ^ Extra preprocessors + -> [ModuleName] + -- ^ Exposed modules + -> IO [FilePath] allSourcesBuildInfo verbosity rip cwd bi pps modules = do let searchDirs = map getSymbolicPath (hsSourceDirs bi) - sources <- fmap concat $ sequenceA $ - [ let file = ModuleName.toFilePath module_ - -- NB: *Not* findFileWithExtension, because the same source - -- file may show up in multiple paths due to a conditional; - -- we need to package all of them. See #367. - in findAllFilesCwdWithExtension cwd suffixes searchDirs file - >>= nonEmpty' (notFound module_) return - | module_ <- modules ++ otherModules bi ] - bootFiles <- sequenceA - [ let file = ModuleName.toFilePath module_ - fileExts = ["hs-boot", "lhs-boot"] - in findFileCwdWithExtension cwd fileExts (map getSymbolicPath (hsSourceDirs bi)) file - | module_ <- modules ++ otherModules bi ] - - return $ sources ++ catMaybes bootFiles ++ cSources bi ++ cxxSources bi ++ - cmmSources bi ++ asmSources bi ++ jsSources bi - + sources <- + fmap concat $ + sequenceA $ + [ let file = ModuleName.toFilePath module_ + in -- NB: *Not* findFileWithExtension, because the same source + -- file may show up in multiple paths due to a conditional; + -- we need to package all of them. See #367. + findAllFilesCwdWithExtension cwd suffixes searchDirs file + >>= nonEmpty' (notFound module_) return + | module_ <- modules ++ otherModules bi + ] + bootFiles <- + sequenceA + [ let file = ModuleName.toFilePath module_ + fileExts = ["hs-boot", "lhs-boot"] + in findFileCwdWithExtension cwd fileExts (map getSymbolicPath (hsSourceDirs bi)) file + | module_ <- modules ++ otherModules bi + ] + + return $ + sources + ++ catMaybes bootFiles + ++ cSources bi + ++ cxxSources bi + ++ cmmSources bi + ++ asmSources bi + ++ jsSources bi where nonEmpty' :: b -> ([a] -> b) -> [a] -> b nonEmpty' x _ [] = x @@ -490,48 +541,56 @@ allSourcesBuildInfo verbosity rip cwd bi pps modules = do suffixes = ppSuffixes pps ++ ["hs", "lhs", "hsig", "lhsig"] notFound :: ModuleName -> IO [FilePath] - notFound m = rip verbosity $ "Could not find module: " ++ prettyShow m - ++ " with any suffix: " ++ show suffixes ++ ". If the module " - ++ "is autogenerated it should be added to 'autogen-modules'." - + notFound m = + rip verbosity $ + "Could not find module: " + ++ prettyShow m + ++ " with any suffix: " + ++ show suffixes + ++ ". If the module " + ++ "is autogenerated it should be added to 'autogen-modules'." -- | Note: must be called with the CWD set to the directory containing -- the '.cabal' file. printPackageProblems :: Verbosity -> PackageDescription -> IO () printPackageProblems verbosity pkg_descr = do - ioChecks <- checkPackageFiles verbosity pkg_descr "." + ioChecks <- checkPackageFiles verbosity pkg_descr "." let pureChecks = checkConfiguredPackage pkg_descr (errors, warnings) = partition isHackageDistError (pureChecks ++ ioChecks) unless (null errors) $ - notice verbosity $ "Distribution quality errors:\n" - ++ unlines (map ppPackageCheck errors) + notice verbosity $ + "Distribution quality errors:\n" + ++ unlines (map ppPackageCheck errors) unless (null warnings) $ - notice verbosity $ "Distribution quality warnings:\n" - ++ unlines (map ppPackageCheck warnings) + notice verbosity $ + "Distribution quality warnings:\n" + ++ unlines (map ppPackageCheck warnings) unless (null errors) $ - notice verbosity - "Note: the public hackage server would reject this package." + notice + verbosity + "Note: the public hackage server would reject this package." ------------------------------------------------------------ -- | The name of the tarball without extension --- tarBallName :: PackageDescription -> String tarBallName = prettyShow . packageId -mapAllBuildInfo :: (BuildInfo -> BuildInfo) - -> (PackageDescription -> PackageDescription) -mapAllBuildInfo f pkg = pkg { - library = fmap mapLibBi (library pkg), - subLibraries = fmap mapLibBi (subLibraries pkg), - foreignLibs = fmap mapFLibBi (foreignLibs pkg), - executables = fmap mapExeBi (executables pkg), - testSuites = fmap mapTestBi (testSuites pkg), - benchmarks = fmap mapBenchBi (benchmarks pkg) - } +mapAllBuildInfo + :: (BuildInfo -> BuildInfo) + -> (PackageDescription -> PackageDescription) +mapAllBuildInfo f pkg = + pkg + { library = fmap mapLibBi (library pkg) + , subLibraries = fmap mapLibBi (subLibraries pkg) + , foreignLibs = fmap mapFLibBi (foreignLibs pkg) + , executables = fmap mapExeBi (executables pkg) + , testSuites = fmap mapTestBi (testSuites pkg) + , benchmarks = fmap mapBenchBi (benchmarks pkg) + } where - mapLibBi lib = lib { libBuildInfo = f (libBuildInfo lib) } - mapFLibBi flib = flib { foreignLibBuildInfo = f (foreignLibBuildInfo flib) } - mapExeBi exe = exe { buildInfo = f (buildInfo exe) } - mapTestBi tst = tst { testBuildInfo = f (testBuildInfo tst) } - mapBenchBi bm = bm { benchmarkBuildInfo = f (benchmarkBuildInfo bm) } + mapLibBi lib = lib{libBuildInfo = f (libBuildInfo lib)} + mapFLibBi flib = flib{foreignLibBuildInfo = f (foreignLibBuildInfo flib)} + mapExeBi exe = exe{buildInfo = f (buildInfo exe)} + mapTestBi tst = tst{testBuildInfo = f (testBuildInfo tst)} + mapBenchBi bm = bm{benchmarkBuildInfo = f (benchmarkBuildInfo bm)} diff --git a/Cabal/src/Distribution/Simple/Test.hs b/Cabal/src/Distribution/Simple/Test.hs index 90adfb3852e..0a8406e2574 100644 --- a/Cabal/src/Distribution/Simple/Test.hs +++ b/Cabal/src/Distribution/Simple/Test.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Test -- Copyright : Thomas Tuegel 2010 @@ -13,125 +14,145 @@ -- This is the entry point into testing a built package. It performs the -- \"@.\/setup test@\" action. It runs test suites designated in the package -- description and reports on the results. - module Distribution.Simple.Test - ( test - ) where + ( test + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.UnqualComponentName import qualified Distribution.PackageDescription as PD +import Distribution.Pretty import Distribution.Simple.Compiler +import Distribution.Simple.Flag (fromFlag) import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI -import qualified Distribution.Types.LocalBuildInfo as LBI -import Distribution.Simple.Flag ( fromFlag ) import Distribution.Simple.Setup.Test -import Distribution.Simple.UserHooks import qualified Distribution.Simple.Test.ExeV10 as ExeV10 import qualified Distribution.Simple.Test.LibV09 as LibV09 import Distribution.Simple.Test.Log +import Distribution.Simple.UserHooks import Distribution.Simple.Utils import Distribution.TestSuite -import Distribution.Pretty +import qualified Distribution.Types.LocalBuildInfo as LBI +import Distribution.Types.UnqualComponentName import System.Directory - ( createDirectoryIfMissing, doesFileExist, getDirectoryContents - , removeFile ) -import System.FilePath ( () ) - --- |Perform the \"@.\/setup test@\" action. -test :: Args -- ^positional command-line arguments - -> PD.PackageDescription -- ^information from the .cabal file - -> LBI.LocalBuildInfo -- ^information from the configure step - -> TestFlags -- ^flags sent to test - -> IO () + ( createDirectoryIfMissing + , doesFileExist + , getDirectoryContents + , removeFile + ) +import System.FilePath (()) + +-- | Perform the \"@.\/setup test@\" action. +test + :: Args + -- ^ positional command-line arguments + -> PD.PackageDescription + -- ^ information from the .cabal file + -> LBI.LocalBuildInfo + -- ^ information from the configure step + -> TestFlags + -- ^ flags sent to test + -> IO () test args pkg_descr lbi flags = do - let verbosity = fromFlag $ testVerbosity flags - machineTemplate = fromFlag $ testMachineLog flags - distPref = fromFlag $ testDistPref flags - testLogDir = distPref "test" - testNames = args - pkgTests = PD.testSuites pkg_descr - enabledTests = LBI.enabledTestLBIs pkg_descr lbi - - doTest :: ((PD.TestSuite, LBI.ComponentLocalBuildInfo), - Maybe TestSuiteLog) -> IO TestSuiteLog - doTest ((suite, clbi), _) = - case PD.testInterface suite of - PD.TestSuiteExeV10 _ _ -> - ExeV10.runTest pkg_descr lbi clbi flags suite - - PD.TestSuiteLibV09 _ _ -> - LibV09.runTest pkg_descr lbi clbi flags suite - - _ -> return TestSuiteLog - { testSuiteName = PD.testName suite - , testLogs = TestLog + let verbosity = fromFlag $ testVerbosity flags + machineTemplate = fromFlag $ testMachineLog flags + distPref = fromFlag $ testDistPref flags + testLogDir = distPref "test" + testNames = args + pkgTests = PD.testSuites pkg_descr + enabledTests = LBI.enabledTestLBIs pkg_descr lbi + + doTest + :: ( (PD.TestSuite, LBI.ComponentLocalBuildInfo) + , Maybe TestSuiteLog + ) + -> IO TestSuiteLog + doTest ((suite, clbi), _) = + case PD.testInterface suite of + PD.TestSuiteExeV10 _ _ -> + ExeV10.runTest pkg_descr lbi clbi flags suite + PD.TestSuiteLibV09 _ _ -> + LibV09.runTest pkg_descr lbi clbi flags suite + _ -> + return + TestSuiteLog + { testSuiteName = PD.testName suite + , testLogs = + TestLog { testName = unUnqualComponentName $ PD.testName suite , testOptionsReturned = [] , testResult = - Error $ "No support for running test suite type: " - ++ show (pretty $ PD.testType suite) + Error $ + "No support for running test suite type: " + ++ show (pretty $ PD.testType suite) } - , logFile = "" - } - - unless (PD.hasTests pkg_descr) $ do - notice verbosity "Package has no test suites." - exitSuccess - - when (PD.hasTests pkg_descr && null enabledTests) $ - die' verbosity $ - "No test suites enabled. Did you remember to configure with " - ++ "\'--enable-tests\'?" - - testsToRun <- case testNames of - [] -> return $ zip enabledTests $ repeat Nothing - names -> for names $ \tName -> - let testMap = zip enabledNames enabledTests - enabledNames = map (PD.testName . fst) enabledTests - allNames = map PD.testName pkgTests - tCompName = mkUnqualComponentName tName - in case lookup tCompName testMap of - Just t -> return (t, Nothing) - _ | tCompName `elem` allNames -> - die' verbosity $ "Package configured with test suite " - ++ tName ++ " disabled." - | otherwise -> die' verbosity $ "no such test: " ++ tName - - createDirectoryIfMissing True testLogDir - - -- Delete ordinary files from test log directory. - getDirectoryContents testLogDir - >>= filterM doesFileExist . map (testLogDir ) - >>= traverse_ removeFile - - let totalSuites = length testsToRun - notice verbosity $ "Running " ++ show totalSuites ++ " test suites..." - suites <- traverse doTest testsToRun - let packageLog = (localPackageLog pkg_descr lbi) { testSuites = suites } - packageLogFile = () testLogDir - $ packageLogPath machineTemplate pkg_descr lbi - allOk <- summarizePackage verbosity packageLog - writeFile packageLogFile $ show packageLog - - when (LBI.testCoverage lbi) $ - markupPackage verbosity lbi distPref pkg_descr $ - map (fst . fst) testsToRun - - unless allOk exitFailure - -packageLogPath :: PathTemplate - -> PD.PackageDescription - -> LBI.LocalBuildInfo - -> FilePath + , logFile = "" + } + + unless (PD.hasTests pkg_descr) $ do + notice verbosity "Package has no test suites." + exitSuccess + + when (PD.hasTests pkg_descr && null enabledTests) $ + die' verbosity $ + "No test suites enabled. Did you remember to configure with " + ++ "\'--enable-tests\'?" + + testsToRun <- case testNames of + [] -> return $ zip enabledTests $ repeat Nothing + names -> for names $ \tName -> + let testMap = zip enabledNames enabledTests + enabledNames = map (PD.testName . fst) enabledTests + allNames = map PD.testName pkgTests + tCompName = mkUnqualComponentName tName + in case lookup tCompName testMap of + Just t -> return (t, Nothing) + _ + | tCompName `elem` allNames -> + die' verbosity $ + "Package configured with test suite " + ++ tName + ++ " disabled." + | otherwise -> die' verbosity $ "no such test: " ++ tName + + createDirectoryIfMissing True testLogDir + + -- Delete ordinary files from test log directory. + getDirectoryContents testLogDir + >>= filterM doesFileExist . map (testLogDir ) + >>= traverse_ removeFile + + let totalSuites = length testsToRun + notice verbosity $ "Running " ++ show totalSuites ++ " test suites..." + suites <- traverse doTest testsToRun + let packageLog = (localPackageLog pkg_descr lbi){testSuites = suites} + packageLogFile = + () testLogDir $ + packageLogPath machineTemplate pkg_descr lbi + allOk <- summarizePackage verbosity packageLog + writeFile packageLogFile $ show packageLog + + when (LBI.testCoverage lbi) $ + markupPackage verbosity lbi distPref pkg_descr $ + map (fst . fst) testsToRun + + unless allOk exitFailure + +packageLogPath + :: PathTemplate + -> PD.PackageDescription + -> LBI.LocalBuildInfo + -> FilePath packageLogPath template pkg_descr lbi = - fromPathTemplate $ substPathTemplate env template - where - env = initialPathTemplateEnv - (PD.package pkg_descr) (LBI.localUnitId lbi) - (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) + fromPathTemplate $ substPathTemplate env template + where + env = + initialPathTemplateEnv + (PD.package pkg_descr) + (LBI.localUnitId lbi) + (compilerInfo $ LBI.compiler lbi) + (LBI.hostPlatform lbi) diff --git a/Cabal/src/Distribution/Simple/Test/ExeV10.hs b/Cabal/src/Distribution/Simple/Test/ExeV10.hs index 6d120bc58c5..927e1fce1a8 100644 --- a/Cabal/src/Distribution/Simple/Test/ExeV10.hs +++ b/Cabal/src/Distribution/Simple/Test/ExeV10.hs @@ -2,155 +2,183 @@ {-# LANGUAGE RankNTypes #-} module Distribution.Simple.Test.ExeV10 - ( runTest - ) where + ( runTest + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.UnqualComponentName import Distribution.Compat.Environment import qualified Distribution.PackageDescription as PD +import Distribution.Pretty import Distribution.Simple.Build.PathsModule import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler +import Distribution.Simple.Flag import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI -import qualified Distribution.Types.LocalBuildInfo as LBI -import Distribution.Simple.Flag import Distribution.Simple.Setup.Test import Distribution.Simple.Test.Log import Distribution.Simple.Utils import Distribution.System import Distribution.TestSuite -import Distribution.Pretty +import qualified Distribution.Types.LocalBuildInfo as LBI +import Distribution.Types.UnqualComponentName import Distribution.Verbosity import System.Directory - ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist - , getCurrentDirectory, removeDirectoryRecursive ) -import System.FilePath ( (), (<.>) ) -import System.IO ( stdout, stderr ) -import System.Process ( createPipe ) + ( createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , getCurrentDirectory + , removeDirectoryRecursive + ) +import System.FilePath ((<.>), ()) +import System.IO (stderr, stdout) +import System.Process (createPipe) import qualified Data.ByteString.Lazy as LBS -runTest :: PD.PackageDescription - -> LBI.LocalBuildInfo - -> LBI.ComponentLocalBuildInfo - -> TestFlags - -> PD.TestSuite - -> IO TestSuiteLog +runTest + :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> LBI.ComponentLocalBuildInfo + -> TestFlags + -> PD.TestSuite + -> IO TestSuiteLog runTest pkg_descr lbi clbi flags suite = do - let isCoverageEnabled = LBI.testCoverage lbi - way = guessWay lbi - tixDir_ = tixDir distPref way testName' - - pwd <- getCurrentDirectory - existingEnv <- getEnvironment - - let cmd = LBI.buildDir lbi testName' - testName' <.> exeExtension (LBI.hostPlatform lbi) - -- Check that the test executable exists. - exists <- doesFileExist cmd - unless exists $ die' verbosity $ "Could not find test program \"" ++ cmd - ++ "\". Did you build the package first?" - - -- Remove old .tix files if appropriate. - unless (fromFlag $ testKeepTix flags) $ do - exists' <- doesDirectoryExist tixDir_ - when exists' $ removeDirectoryRecursive tixDir_ - - -- Create directory for HPC files. - createDirectoryIfMissing True tixDir_ - - -- Write summary notices indicating start of test suite - notice verbosity $ summarizeSuiteStart $ testName' - - - -- Run the test executable - let opts = map (testOption pkg_descr lbi suite) - (testOptions flags) - dataDirPath = pwd PD.dataDir pkg_descr - tixFile = pwd tixFilePath distPref way (testName') - pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath) - : existingEnv - shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] ++ pkgPathEnv - - -- Add (DY)LD_LIBRARY_PATH if needed - shellEnv' <- if LBI.withDynExe lbi - then do let (Platform _ os) = LBI.hostPlatform lbi - paths <- LBI.depLibraryPaths True False lbi clbi - return (addLibraryPath os paths shellEnv) - else return shellEnv - - -- Output logger - (wOut, wErr, getLogText) <- case details of - Direct -> return (stdout, stderr, return LBS.empty) - _ -> do - (rOut, wOut) <- createPipe - - return $ (,,) wOut wOut $ do - -- Read test executables' output - logText <- LBS.hGetContents rOut - - -- '--show-details=streaming': print the log output in another thread - when (details == Streaming) $ LBS.putStr logText - - -- drain the output. - evaluate (force logText) - - (exit, logText) <- case testWrapper flags of - Flag path -> rawSystemIOWithEnvAndAction - verbosity path (cmd:opts) Nothing (Just shellEnv') - getLogText - -- these handles are automatically closed - Nothing (Just wOut) (Just wErr) - - NoFlag -> rawSystemIOWithEnvAndAction - verbosity cmd opts Nothing (Just shellEnv') - getLogText - -- these handles are automatically closed - Nothing (Just wOut) (Just wErr) - - -- Generate TestSuiteLog from executable exit code and a machine- - -- readable test log. - let suiteLog = buildLog exit - - -- Write summary notice to log file indicating start of test suite - appendFile (logFile suiteLog) $ summarizeSuiteStart testName' - - -- Append contents of temporary log file to the final human- - -- readable log file - LBS.appendFile (logFile suiteLog) logText - - -- Write end-of-suite summary notice to log file - appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog - - -- Show the contents of the human-readable log file on the terminal - -- if there is a failure and/or detailed output is requested - let whenPrinting = when $ - ( details == Always || - details == Failures && not (suitePassed $ testLogs suiteLog)) + let isCoverageEnabled = LBI.testCoverage lbi + way = guessWay lbi + tixDir_ = tixDir distPref way testName' + + pwd <- getCurrentDirectory + existingEnv <- getEnvironment + + let cmd = + LBI.buildDir lbi + testName' + testName' <.> exeExtension (LBI.hostPlatform lbi) + -- Check that the test executable exists. + exists <- doesFileExist cmd + unless exists $ + die' verbosity $ + "Could not find test program \"" + ++ cmd + ++ "\". Did you build the package first?" + + -- Remove old .tix files if appropriate. + unless (fromFlag $ testKeepTix flags) $ do + exists' <- doesDirectoryExist tixDir_ + when exists' $ removeDirectoryRecursive tixDir_ + + -- Create directory for HPC files. + createDirectoryIfMissing True tixDir_ + + -- Write summary notices indicating start of test suite + notice verbosity $ summarizeSuiteStart $ testName' + + -- Run the test executable + let opts = + map + (testOption pkg_descr lbi suite) + (testOptions flags) + dataDirPath = pwd PD.dataDir pkg_descr + tixFile = pwd tixFilePath distPref way (testName') + pkgPathEnv = + (pkgPathEnvVar pkg_descr "datadir", dataDirPath) + : existingEnv + shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] ++ pkgPathEnv + + -- Add (DY)LD_LIBRARY_PATH if needed + shellEnv' <- + if LBI.withDynExe lbi + then do + let (Platform _ os) = LBI.hostPlatform lbi + paths <- LBI.depLibraryPaths True False lbi clbi + return (addLibraryPath os paths shellEnv) + else return shellEnv + + -- Output logger + (wOut, wErr, getLogText) <- case details of + Direct -> return (stdout, stderr, return LBS.empty) + _ -> do + (rOut, wOut) <- createPipe + + return $ (,,) wOut wOut $ do + -- Read test executables' output + logText <- LBS.hGetContents rOut + + -- '--show-details=streaming': print the log output in another thread + when (details == Streaming) $ LBS.putStr logText + + -- drain the output. + evaluate (force logText) + + (exit, logText) <- case testWrapper flags of + Flag path -> + rawSystemIOWithEnvAndAction + verbosity + path + (cmd : opts) + Nothing + (Just shellEnv') + getLogText + -- these handles are automatically closed + Nothing + (Just wOut) + (Just wErr) + NoFlag -> + rawSystemIOWithEnvAndAction + verbosity + cmd + opts + Nothing + (Just shellEnv') + getLogText + -- these handles are automatically closed + Nothing + (Just wOut) + (Just wErr) + + -- Generate TestSuiteLog from executable exit code and a machine- + -- readable test log. + let suiteLog = buildLog exit + + -- Write summary notice to log file indicating start of test suite + appendFile (logFile suiteLog) $ summarizeSuiteStart testName' + + -- Append contents of temporary log file to the final human- + -- readable log file + LBS.appendFile (logFile suiteLog) logText + + -- Write end-of-suite summary notice to log file + appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog + + -- Show the contents of the human-readable log file on the terminal + -- if there is a failure and/or detailed output is requested + let whenPrinting = + when $ + ( details == Always + || details == Failures && not (suitePassed $ testLogs suiteLog) + ) -- verbosity overrides show-details && verbosity >= normal - whenPrinting $ do - LBS.putStr logText - putChar '\n' - - -- Write summary notice to terminal indicating end of test suite - notice verbosity $ summarizeSuiteFinish suiteLog + whenPrinting $ do + LBS.putStr logText + putChar '\n' - when isCoverageEnabled $ - case PD.library pkg_descr of - Nothing -> - die' verbosity "Test coverage is only supported for packages with a library component." + -- Write summary notice to terminal indicating end of test suite + notice verbosity $ summarizeSuiteFinish suiteLog - Just library -> - markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library + when isCoverageEnabled $ + case PD.library pkg_descr of + Nothing -> + die' verbosity "Test coverage is only supported for packages with a library component." + Just library -> + markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library - return suiteLog + return suiteLog where testName' = unUnqualComponentName $ PD.testName suite @@ -160,35 +188,44 @@ runTest pkg_descr lbi clbi flags suite = do testLogDir = distPref "test" buildLog exit = - let r = case exit of - ExitSuccess -> Pass - ExitFailure c -> Fail $ "exit code: " ++ show c - --n = unUnqualComponentName $ PD.testName suite - l = TestLog - { testName = testName' - , testOptionsReturned = [] - , testResult = r - } - in TestSuiteLog - { testSuiteName = PD.testName suite - , testLogs = l - , logFile = - testLogDir - testSuiteLogPath (fromFlag $ testHumanLog flags) - pkg_descr lbi testName' l - } + let r = case exit of + ExitSuccess -> Pass + ExitFailure c -> Fail $ "exit code: " ++ show c + -- n = unUnqualComponentName $ PD.testName suite + l = + TestLog + { testName = testName' + , testOptionsReturned = [] + , testResult = r + } + in TestSuiteLog + { testSuiteName = PD.testName suite + , testLogs = l + , logFile = + testLogDir + testSuiteLogPath + (fromFlag $ testHumanLog flags) + pkg_descr + lbi + testName' + l + } -- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't -- necessarily a path. -testOption :: PD.PackageDescription - -> LBI.LocalBuildInfo - -> PD.TestSuite - -> PathTemplate - -> String +testOption + :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> PD.TestSuite + -> PathTemplate + -> String testOption pkg_descr lbi suite template = - fromPathTemplate $ substPathTemplate env template + fromPathTemplate $ substPathTemplate env template where - env = initialPathTemplateEnv - (PD.package pkg_descr) (LBI.localUnitId lbi) - (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++ - [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)] + env = + initialPathTemplateEnv + (PD.package pkg_descr) + (LBI.localUnitId lbi) + (compilerInfo $ LBI.compiler lbi) + (LBI.hostPlatform lbi) + ++ [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)] diff --git a/Cabal/src/Distribution/Simple/Test/LibV09.hs b/Cabal/src/Distribution/Simple/Test/LibV09.hs index f1cc099d691..4da06192141 100644 --- a/Cabal/src/Distribution/Simple/Test/LibV09.hs +++ b/Cabal/src/Distribution/Simple/Test/LibV09.hs @@ -2,198 +2,231 @@ {-# LANGUAGE RankNTypes #-} module Distribution.Simple.Test.LibV09 - ( runTest - -- Test stub - , simpleTestStub - , stubFilePath, stubMain, stubName, stubWriteLog - , writeSimpleTestStub - ) where + ( runTest + -- Test stub + , simpleTestStub + , stubFilePath + , stubMain + , stubName + , stubWriteLog + , writeSimpleTestStub + ) where -import Prelude () import Distribution.Compat.Prelude import Distribution.Types.UnqualComponentName +import Prelude () import Distribution.Compat.Environment import Distribution.Compat.Internal.TempFile import Distribution.ModuleName import qualified Distribution.PackageDescription as PD +import Distribution.Pretty import Distribution.Simple.Build.PathsModule import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler +import Distribution.Simple.Flag (Flag (Flag, NoFlag), fromFlag) import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI -import qualified Distribution.Types.LocalBuildInfo as LBI -import Distribution.Simple.Flag ( Flag(NoFlag, Flag), fromFlag ) import Distribution.Simple.Setup.Test import Distribution.Simple.Test.Log import Distribution.Simple.Utils import Distribution.System import Distribution.TestSuite -import Distribution.Pretty +import qualified Distribution.Types.LocalBuildInfo as LBI import Distribution.Verbosity import qualified Control.Exception as CE import qualified Data.ByteString.Lazy as LBS -import System.Directory - ( createDirectoryIfMissing, canonicalizePath - , doesDirectoryExist, doesFileExist - , getCurrentDirectory, removeDirectoryRecursive, removeFile - , setCurrentDirectory ) -import System.FilePath ( (), (<.>) ) -import System.IO ( hClose, hPutStr ) import Distribution.Compat.Process (proc) +import System.Directory + ( canonicalizePath + , createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , getCurrentDirectory + , removeDirectoryRecursive + , removeFile + , setCurrentDirectory + ) +import System.FilePath ((<.>), ()) +import System.IO (hClose, hPutStr) import qualified System.Process as Process -runTest :: PD.PackageDescription - -> LBI.LocalBuildInfo - -> LBI.ComponentLocalBuildInfo - -> TestFlags - -> PD.TestSuite - -> IO TestSuiteLog +runTest + :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> LBI.ComponentLocalBuildInfo + -> TestFlags + -> PD.TestSuite + -> IO TestSuiteLog runTest pkg_descr lbi clbi flags suite = do - let isCoverageEnabled = LBI.testCoverage lbi - way = guessWay lbi - - pwd <- getCurrentDirectory - existingEnv <- getEnvironment - - let cmd = LBI.buildDir lbi stubName suite - stubName suite <.> exeExtension (LBI.hostPlatform lbi) - -- Check that the test executable exists. - exists <- doesFileExist cmd - unless exists $ - die' verbosity $ "Could not find test program \"" ++ cmd - ++ "\". Did you build the package first?" - - -- Remove old .tix files if appropriate. - unless (fromFlag $ testKeepTix flags) $ do - let tDir = tixDir distPref way testName' - exists' <- doesDirectoryExist tDir - when exists' $ removeDirectoryRecursive tDir - - -- Create directory for HPC files. - createDirectoryIfMissing True $ tixDir distPref way testName' - - -- Write summary notices indicating start of test suite - notice verbosity $ summarizeSuiteStart testName' - - suiteLog <- CE.bracket openCabalTemp deleteIfExists $ \tempLog -> do - - -- Run test executable - let opts = map (testOption pkg_descr lbi suite) $ testOptions flags - dataDirPath = pwd PD.dataDir pkg_descr - tixFile = pwd tixFilePath distPref way testName' - pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath) - : existingEnv - shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] - ++ pkgPathEnv - -- Add (DY)LD_LIBRARY_PATH if needed - shellEnv' <- - if LBI.withDynExe lbi - then do - let (Platform _ os) = LBI.hostPlatform lbi - paths <- LBI.depLibraryPaths True False lbi clbi - cpath <- canonicalizePath $ LBI.componentBuildDir lbi clbi - return (addLibraryPath os (cpath : paths) shellEnv) - else return shellEnv - let (cmd', opts') = case testWrapper flags of - Flag path -> (path, cmd:opts) - NoFlag -> (cmd, opts) - - -- TODO: this setup is broken, - -- if the test output is too big, we will deadlock. - (rOut, wOut) <- Process.createPipe - (exitcode, logText) <- rawSystemProcAction verbosity - (proc cmd' opts') { Process.env = Just shellEnv' - , Process.std_in = Process.CreatePipe - , Process.std_out = Process.UseHandle wOut - , Process.std_err = Process.UseHandle wOut - } $ \mIn _ _ -> do - let wIn = fromCreatePipe mIn - hPutStr wIn $ show (tempLog, PD.testName suite) - hClose wIn - - -- Append contents of temporary log file to the final human- - -- readable log file - logText <- LBS.hGetContents rOut - -- Force the IO manager to drain the test output pipe - _ <- evaluate (force logText) - return logText - unless (exitcode == ExitSuccess) $ - debug verbosity $ cmd ++ " returned " ++ show exitcode - - -- Generate final log file name - let finalLogName l = testLogDir - testSuiteLogPath - (fromFlag $ testHumanLog flags) pkg_descr lbi - (unUnqualComponentName $ testSuiteName l) (testLogs l) - -- Generate TestSuiteLog from executable exit code and a machine- - -- readable test log - suiteLog <- fmap (\s -> (\l -> l { logFile = finalLogName l }) - . fromMaybe (error $ "panic! read @TestSuiteLog " ++ show s) $ readMaybe s) -- TODO: eradicateNoParse - $ readFile tempLog - - -- Write summary notice to log file indicating start of test suite - appendFile (logFile suiteLog) $ summarizeSuiteStart testName' - - LBS.appendFile (logFile suiteLog) logText - - -- Write end-of-suite summary notice to log file - appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog - - -- Show the contents of the human-readable log file on the terminal - -- if there is a failure and/or detailed output is requested - let details = fromFlag $ testShowDetails flags - whenPrinting = when $ (details > Never) - && (not (suitePassed $ testLogs suiteLog) || details == Always) - && verbosity >= normal - whenPrinting $ do - LBS.putStr logText - putChar '\n' - - return suiteLog - - -- Write summary notice to terminal indicating end of test suite - notice verbosity $ summarizeSuiteFinish suiteLog - - when isCoverageEnabled $ - case PD.library pkg_descr of - Nothing -> - die' verbosity "Test coverage is only supported for packages with a library component." - Just library -> - markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library + let isCoverageEnabled = LBI.testCoverage lbi + way = guessWay lbi + + pwd <- getCurrentDirectory + existingEnv <- getEnvironment + + let cmd = + LBI.buildDir lbi + stubName suite + stubName suite <.> exeExtension (LBI.hostPlatform lbi) + -- Check that the test executable exists. + exists <- doesFileExist cmd + unless exists $ + die' verbosity $ + "Could not find test program \"" + ++ cmd + ++ "\". Did you build the package first?" + + -- Remove old .tix files if appropriate. + unless (fromFlag $ testKeepTix flags) $ do + let tDir = tixDir distPref way testName' + exists' <- doesDirectoryExist tDir + when exists' $ removeDirectoryRecursive tDir + + -- Create directory for HPC files. + createDirectoryIfMissing True $ tixDir distPref way testName' + + -- Write summary notices indicating start of test suite + notice verbosity $ summarizeSuiteStart testName' + + suiteLog <- CE.bracket openCabalTemp deleteIfExists $ \tempLog -> do + -- Run test executable + let opts = map (testOption pkg_descr lbi suite) $ testOptions flags + dataDirPath = pwd PD.dataDir pkg_descr + tixFile = pwd tixFilePath distPref way testName' + pkgPathEnv = + (pkgPathEnvVar pkg_descr "datadir", dataDirPath) + : existingEnv + shellEnv = + [("HPCTIXFILE", tixFile) | isCoverageEnabled] + ++ pkgPathEnv + -- Add (DY)LD_LIBRARY_PATH if needed + shellEnv' <- + if LBI.withDynExe lbi + then do + let (Platform _ os) = LBI.hostPlatform lbi + paths <- LBI.depLibraryPaths True False lbi clbi + cpath <- canonicalizePath $ LBI.componentBuildDir lbi clbi + return (addLibraryPath os (cpath : paths) shellEnv) + else return shellEnv + let (cmd', opts') = case testWrapper flags of + Flag path -> (path, cmd : opts) + NoFlag -> (cmd, opts) + + -- TODO: this setup is broken, + -- if the test output is too big, we will deadlock. + (rOut, wOut) <- Process.createPipe + (exitcode, logText) <- rawSystemProcAction + verbosity + (proc cmd' opts') + { Process.env = Just shellEnv' + , Process.std_in = Process.CreatePipe + , Process.std_out = Process.UseHandle wOut + , Process.std_err = Process.UseHandle wOut + } + $ \mIn _ _ -> do + let wIn = fromCreatePipe mIn + hPutStr wIn $ show (tempLog, PD.testName suite) + hClose wIn + + -- Append contents of temporary log file to the final human- + -- readable log file + logText <- LBS.hGetContents rOut + -- Force the IO manager to drain the test output pipe + _ <- evaluate (force logText) + return logText + unless (exitcode == ExitSuccess) $ + debug verbosity $ + cmd ++ " returned " ++ show exitcode + + -- Generate final log file name + let finalLogName l = + testLogDir + testSuiteLogPath + (fromFlag $ testHumanLog flags) + pkg_descr + lbi + (unUnqualComponentName $ testSuiteName l) + (testLogs l) + -- Generate TestSuiteLog from executable exit code and a machine- + -- readable test log + suiteLog <- + fmap + ( \s -> + (\l -> l{logFile = finalLogName l}) + . fromMaybe (error $ "panic! read @TestSuiteLog " ++ show s) + $ readMaybe s -- TODO: eradicateNoParse + ) + $ readFile tempLog + + -- Write summary notice to log file indicating start of test suite + appendFile (logFile suiteLog) $ summarizeSuiteStart testName' + + LBS.appendFile (logFile suiteLog) logText + + -- Write end-of-suite summary notice to log file + appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog + + -- Show the contents of the human-readable log file on the terminal + -- if there is a failure and/or detailed output is requested + let details = fromFlag $ testShowDetails flags + whenPrinting = + when $ + (details > Never) + && (not (suitePassed $ testLogs suiteLog) || details == Always) + && verbosity >= normal + whenPrinting $ do + LBS.putStr logText + putChar '\n' return suiteLog + + -- Write summary notice to terminal indicating end of test suite + notice verbosity $ summarizeSuiteFinish suiteLog + + when isCoverageEnabled $ + case PD.library pkg_descr of + Nothing -> + die' verbosity "Test coverage is only supported for packages with a library component." + Just library -> + markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library + + return suiteLog where testName' = unUnqualComponentName $ PD.testName suite deleteIfExists file = do - exists <- doesFileExist file - when exists $ removeFile file + exists <- doesFileExist file + when exists $ removeFile file testLogDir = distPref "test" openCabalTemp = do - (f, h) <- openTempFile testLogDir $ "cabal-test-" <.> "log" - hClose h >> return f + (f, h) <- openTempFile testLogDir $ "cabal-test-" <.> "log" + hClose h >> return f distPref = fromFlag $ testDistPref flags verbosity = fromFlag $ testVerbosity flags -- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't -- necessarily a path. -testOption :: PD.PackageDescription - -> LBI.LocalBuildInfo - -> PD.TestSuite - -> PathTemplate - -> String +testOption + :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> PD.TestSuite + -> PathTemplate + -> String testOption pkg_descr lbi suite template = - fromPathTemplate $ substPathTemplate env template + fromPathTemplate $ substPathTemplate env template where - env = initialPathTemplateEnv - (PD.package pkg_descr) (LBI.localUnitId lbi) - (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++ - [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)] + env = + initialPathTemplateEnv + (PD.package pkg_descr) + (LBI.localUnitId lbi) + (compilerInfo $ LBI.compiler lbi) + (LBI.hostPlatform lbi) + ++ [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)] -- Test stub ---------- @@ -207,22 +240,26 @@ stubFilePath :: PD.TestSuite -> FilePath stubFilePath t = stubName t <.> "hs" -- | Write the source file for a library 'TestSuite' stub executable. -writeSimpleTestStub :: PD.TestSuite -- ^ library 'TestSuite' for which a stub - -- is being created - -> FilePath -- ^ path to directory where stub source - -- should be located - -> IO () +writeSimpleTestStub + :: PD.TestSuite + -- ^ library 'TestSuite' for which a stub + -- is being created + -> FilePath + -- ^ path to directory where stub source + -- should be located + -> IO () writeSimpleTestStub t dir = do - createDirectoryIfMissing True dir - let filename = dir stubFilePath t - m = case PD.testInterface t of - PD.TestSuiteLibV09 _ m' -> m' - _ -> error "writeSimpleTestStub: invalid TestSuite passed" - writeFile filename $ simpleTestStub m + createDirectoryIfMissing True dir + let filename = dir stubFilePath t + m = case PD.testInterface t of + PD.TestSuiteLibV09 _ m' -> m' + _ -> error "writeSimpleTestStub: invalid TestSuite passed" + writeFile filename $ simpleTestStub m -- | Source code for library test suite stub executable simpleTestStub :: ModuleName -> String -simpleTestStub m = unlines +simpleTestStub m = + unlines [ "module Main ( main ) where" , "import Distribution.Simple.Test.LibV09 ( stubMain )" , "import " ++ show (pretty m) ++ " ( tests )" @@ -235,18 +272,22 @@ simpleTestStub m = unlines -- of detectable errors when Cabal is compiled. stubMain :: IO [Test] -> IO () stubMain tests = do - (f, n) <- fmap (\s -> fromMaybe (error $ "panic! read " ++ show s) $ readMaybe s) getContents -- TODO: eradicateNoParse - dir <- getCurrentDirectory - results <- (tests >>= stubRunTests) `CE.catch` errHandler - setCurrentDirectory dir - stubWriteLog f n results + (f, n) <- fmap (\s -> fromMaybe (error $ "panic! read " ++ show s) $ readMaybe s) getContents -- TODO: eradicateNoParse + dir <- getCurrentDirectory + results <- (tests >>= stubRunTests) `CE.catch` errHandler + setCurrentDirectory dir + stubWriteLog f n results where errHandler :: CE.SomeException -> IO TestLogs errHandler e = case CE.fromException e of - Just CE.UserInterrupt -> CE.throwIO e - _ -> return $ TestLog { testName = "Cabal test suite exception", - testOptionsReturned = [], - testResult = Error $ show e } + Just CE.UserInterrupt -> CE.throwIO e + _ -> + return $ + TestLog + { testName = "Cabal test suite exception" + , testOptionsReturned = [] + , testResult = Error $ show e + } -- | The test runner used in library "TestSuite" stub executables. Runs a list -- of 'Test's. An executable calling this function is meant to be invoked as @@ -257,35 +298,36 @@ stubMain tests = do -- by the calling Cabal process. stubRunTests :: [Test] -> IO TestLogs stubRunTests tests = do - logs <- traverse stubRunTests' tests - return $ GroupLogs "Default" logs + logs <- traverse stubRunTests' tests + return $ GroupLogs "Default" logs where stubRunTests' (Test t) = do - l <- run t >>= finish - summarizeTest normal Always l - return l + l <- run t >>= finish + summarizeTest normal Always l + return l where finish (Finished result) = - return TestLog - { testName = name t - , testOptionsReturned = defaultOptions t - , testResult = result - } + return + TestLog + { testName = name t + , testOptionsReturned = defaultOptions t + , testResult = result + } finish (Progress _ next) = next >>= finish - stubRunTests' g@(Group {}) = do - logs <- traverse stubRunTests' $ groupTests g - return $ GroupLogs (groupName g) logs + stubRunTests' g@(Group{}) = do + logs <- traverse stubRunTests' $ groupTests g + return $ GroupLogs (groupName g) logs stubRunTests' (ExtraOptions _ t) = stubRunTests' t maybeDefaultOption opt = - maybe Nothing (\d -> Just (optionName opt, d)) $ optionDefault opt + maybe Nothing (\d -> Just (optionName opt, d)) $ optionDefault opt defaultOptions testInst = mapMaybe maybeDefaultOption $ options testInst -- | From a test stub, write the 'TestSuiteLog' to temporary file for the calling -- Cabal process to read. stubWriteLog :: FilePath -> UnqualComponentName -> TestLogs -> IO () stubWriteLog f n logs = do - let testLog = TestSuiteLog { testSuiteName = n, testLogs = logs, logFile = f } - writeFile (logFile testLog) $ show testLog - when (suiteError logs) $ exitWith $ ExitFailure 2 - when (suiteFailed logs) $ exitWith $ ExitFailure 1 - exitSuccess + let testLog = TestSuiteLog{testSuiteName = n, testLogs = logs, logFile = f} + writeFile (logFile testLog) $ show testLog + when (suiteError logs) $ exitWith $ ExitFailure 2 + when (suiteFailed logs) $ exitWith $ ExitFailure 1 + exitSuccess diff --git a/Cabal/src/Distribution/Simple/Test/Log.hs b/Cabal/src/Distribution/Simple/Test/Log.hs index 973d56f358b..8287b30f6bf 100644 --- a/Cabal/src/Distribution/Simple/Test/Log.hs +++ b/Cabal/src/Distribution/Simple/Test/Log.hs @@ -2,49 +2,53 @@ {-# LANGUAGE RankNTypes #-} module Distribution.Simple.Test.Log - ( PackageLog(..) - , TestLogs(..) - , TestSuiteLog(..) - , countTestResults - , localPackageLog - , summarizePackage - , summarizeSuiteFinish, summarizeSuiteStart - , summarizeTest - , suiteError, suiteFailed, suitePassed - , testSuiteLogPath - ) where + ( PackageLog (..) + , TestLogs (..) + , TestSuiteLog (..) + , countTestResults + , localPackageLog + , summarizePackage + , summarizeSuiteFinish + , summarizeSuiteStart + , summarizeTest + , suiteError + , suiteFailed + , suitePassed + , testSuiteLogPath + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Package -import Distribution.Types.UnqualComponentName import qualified Distribution.PackageDescription as PD +import Distribution.Pretty import Distribution.Simple.Compiler import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI -import Distribution.Simple.Setup.Test ( TestShowDetails(Always, Never) ) +import Distribution.Simple.Setup.Test (TestShowDetails (Always, Never)) import Distribution.Simple.Utils import Distribution.System import Distribution.TestSuite +import Distribution.Types.UnqualComponentName import Distribution.Verbosity -import Distribution.Pretty import qualified Prelude (foldl1) -- | Logs all test results for a package, broken down first by test suite and -- then by test case. data PackageLog = PackageLog - { package :: PackageId - , compiler :: CompilerId - , platform :: Platform - , testSuites :: [TestSuiteLog] - } - deriving (Read, Show, Eq) + { package :: PackageId + , compiler :: CompilerId + , platform :: Platform + , testSuites :: [TestSuiteLog] + } + deriving (Read, Show, Eq) -- | A 'PackageLog' with package and platform information specified. localPackageLog :: PD.PackageDescription -> LBI.LocalBuildInfo -> PackageLog -localPackageLog pkg_descr lbi = PackageLog +localPackageLog pkg_descr lbi = + PackageLog { package = PD.package pkg_descr , compiler = compilerId $ LBI.compiler lbi , platform = LBI.hostPlatform lbi @@ -53,114 +57,137 @@ localPackageLog pkg_descr lbi = PackageLog -- | Logs test suite results, itemized by test case. data TestSuiteLog = TestSuiteLog - { testSuiteName :: UnqualComponentName - , testLogs :: TestLogs - , logFile :: FilePath -- path to human-readable log file - } - deriving (Read, Show, Eq) + { testSuiteName :: UnqualComponentName + , testLogs :: TestLogs + , logFile :: FilePath -- path to human-readable log file + } + deriving (Read, Show, Eq) data TestLogs - = TestLog - { testName :: String - , testOptionsReturned :: Options - , testResult :: Result - } - | GroupLogs String [TestLogs] - deriving (Read, Show, Eq) + = TestLog + { testName :: String + , testOptionsReturned :: Options + , testResult :: Result + } + | GroupLogs String [TestLogs] + deriving (Read, Show, Eq) -- | Count the number of pass, fail, and error test results in a 'TestLogs' -- tree. -countTestResults :: TestLogs - -> (Int, Int, Int) -- ^ Passes, fails, and errors, - -- respectively. +countTestResults + :: TestLogs + -> (Int, Int, Int) + -- ^ Passes, fails, and errors, + -- respectively. countTestResults = go (0, 0, 0) where - go (p, f, e) (TestLog { testResult = r }) = - case r of - Pass -> (p + 1, f, e) - Fail _ -> (p, f + 1, e) - Error _ -> (p, f, e + 1) + go (p, f, e) (TestLog{testResult = r}) = + case r of + Pass -> (p + 1, f, e) + Fail _ -> (p, f + 1, e) + Error _ -> (p, f, e + 1) go (p, f, e) (GroupLogs _ ts) = foldl go (p, f, e) ts -- | From a 'TestSuiteLog', determine if the test suite passed. suitePassed :: TestLogs -> Bool suitePassed l = - case countTestResults l of - (_, 0, 0) -> True - _ -> False + case countTestResults l of + (_, 0, 0) -> True + _ -> False -- | From a 'TestSuiteLog', determine if the test suite failed. suiteFailed :: TestLogs -> Bool suiteFailed l = - case countTestResults l of - (_, 0, _) -> False - _ -> True + case countTestResults l of + (_, 0, _) -> False + _ -> True -- | From a 'TestSuiteLog', determine if the test suite encountered errors. suiteError :: TestLogs -> Bool suiteError l = - case countTestResults l of - (_, _, 0) -> False - _ -> True + case countTestResults l of + (_, _, 0) -> False + _ -> True resultString :: TestLogs -> String -resultString l | suiteError l = "error" - | suiteFailed l = "fail" - | otherwise = "pass" - -testSuiteLogPath :: PathTemplate - -> PD.PackageDescription - -> LBI.LocalBuildInfo - -> String -- ^ test suite name - -> TestLogs -- ^ test suite results - -> FilePath +resultString l + | suiteError l = "error" + | suiteFailed l = "fail" + | otherwise = "pass" + +testSuiteLogPath + :: PathTemplate + -> PD.PackageDescription + -> LBI.LocalBuildInfo + -> String + -- ^ test suite name + -> TestLogs + -- ^ test suite results + -> FilePath testSuiteLogPath template pkg_descr lbi test_name result = - fromPathTemplate $ substPathTemplate env template - where - env = initialPathTemplateEnv - (PD.package pkg_descr) (LBI.localUnitId lbi) - (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) - ++ [ (TestSuiteNameVar, toPathTemplate test_name) - , (TestSuiteResultVar, toPathTemplate $ resultString result) - ] + fromPathTemplate $ substPathTemplate env template + where + env = + initialPathTemplateEnv + (PD.package pkg_descr) + (LBI.localUnitId lbi) + (compilerInfo $ LBI.compiler lbi) + (LBI.hostPlatform lbi) + ++ [ (TestSuiteNameVar, toPathTemplate test_name) + , (TestSuiteResultVar, toPathTemplate $ resultString result) + ] -- | Print a summary to the console after all test suites have been run -- indicating the number of successful test suites and cases. Returns 'True' if -- all test suites passed and 'False' otherwise. summarizePackage :: Verbosity -> PackageLog -> IO Bool summarizePackage verbosity packageLog = do - let counts = map (countTestResults . testLogs) $ testSuites packageLog - (passed, failed, errors) = Prelude.foldl1 addTriple counts - totalCases = passed + failed + errors - passedSuites = length - $ filter (suitePassed . testLogs) - $ testSuites packageLog - totalSuites = length $ testSuites packageLog - notice verbosity $ show passedSuites ++ " of " ++ show totalSuites - ++ " test suites (" ++ show passed ++ " of " - ++ show totalCases ++ " test cases) passed." - return $! passedSuites == totalSuites + let counts = map (countTestResults . testLogs) $ testSuites packageLog + (passed, failed, errors) = Prelude.foldl1 addTriple counts + totalCases = passed + failed + errors + passedSuites = + length $ + filter (suitePassed . testLogs) $ + testSuites packageLog + totalSuites = length $ testSuites packageLog + notice verbosity $ + show passedSuites + ++ " of " + ++ show totalSuites + ++ " test suites (" + ++ show passed + ++ " of " + ++ show totalCases + ++ " test cases) passed." + return $! passedSuites == totalSuites where addTriple (p1, f1, e1) (p2, f2, e2) = (p1 + p2, f1 + f2, e1 + e2) -- | Print a summary of a single test case's result to the console, suppressing -- output for certain verbosity or test filter levels. summarizeTest :: Verbosity -> TestShowDetails -> TestLogs -> IO () -summarizeTest _ _ (GroupLogs {}) = return () +summarizeTest _ _ (GroupLogs{}) = return () summarizeTest verbosity details t = - when shouldPrint $ notice verbosity $ "Test case " ++ testName t - ++ ": " ++ show (testResult t) - where shouldPrint = (details > Never) && (notPassed || details == Always) - notPassed = testResult t /= Pass + when shouldPrint $ + notice verbosity $ + "Test case " + ++ testName t + ++ ": " + ++ show (testResult t) + where + shouldPrint = (details > Never) && (notPassed || details == Always) + notPassed = testResult t /= Pass -- | Print a summary of the test suite's results on the console, suppressing -- output for certain verbosity or test filter levels. summarizeSuiteFinish :: TestSuiteLog -> String -summarizeSuiteFinish testLog = unlines +summarizeSuiteFinish testLog = + unlines [ "Test suite " ++ prettyShow (testSuiteName testLog) ++ ": " ++ resStr , "Test suite logged to: " ++ logFile testLog ] - where resStr = map toUpper (resultString $ testLogs testLog) + where + resStr = map toUpper (resultString $ testLogs testLog) summarizeSuiteStart :: String -> String summarizeSuiteStart n = "Test suite " ++ n ++ ": RUNNING...\n" diff --git a/Cabal/src/Distribution/Simple/UHC.hs b/Cabal/src/Distribution/Simple/UHC.hs index afc886c423c..ce6bb95d0e7 100644 --- a/Cabal/src/Distribution/Simple/UHC.hs +++ b/Cabal/src/Distribution/Simple/UHC.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.UHC -- Copyright : Andres Loeh 2009 @@ -16,57 +17,67 @@ -- Thanks to the authors of the other implementation-specific files, in -- particular to Isaac Jones, Duncan Coutts and Henning Thielemann, for -- inspiration on how to design this module. - -module Distribution.Simple.UHC ( - configure, getInstalledPackages, - buildLib, buildExe, installLib, registerPackage, inplacePackageDbPath +module Distribution.Simple.UHC + ( configure + , getInstalledPackages + , buildLib + , buildExe + , installLib + , registerPackage + , inplacePackageDbPath ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.InstalledPackageInfo import Distribution.Package hiding (installedUnitId) import Distribution.PackageDescription +import Distribution.Parsec +import Distribution.Pretty import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PackageIndex import Distribution.Simple.Program import Distribution.Simple.Utils -import Distribution.Pretty -import Distribution.Parsec +import Distribution.System import Distribution.Types.MungedPackageId +import Distribution.Utils.Path import Distribution.Verbosity import Distribution.Version -import Distribution.System import Language.Haskell.Extension -import Distribution.Utils.Path -import qualified Data.Map as Map ( empty ) +import qualified Data.Map as Map (empty) import System.Directory import System.FilePath -- ----------------------------------------------------------------------------- -- Configuring -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb) +configure + :: Verbosity + -> Maybe FilePath + -> Maybe FilePath + -> ProgramDb + -> IO (Compiler, Maybe Platform, ProgramDb) configure verbosity hcPath _hcPkgPath progdb = do - (_uhcProg, uhcVersion, progdb') <- - requireProgramVersion verbosity uhcProgram - (orLaterVersion (mkVersion [1,0,2])) - (userMaybeSpecifyPath "uhc" hcPath progdb) - - let comp = Compiler { - compilerId = CompilerId UHC uhcVersion, - compilerAbiTag = NoAbiTag, - compilerCompat = [], - compilerLanguages = uhcLanguages, - compilerExtensions = uhcLanguageExtensions, - compilerProperties = Map.empty - } + requireProgramVersion + verbosity + uhcProgram + (orLaterVersion (mkVersion [1, 0, 2])) + (userMaybeSpecifyPath "uhc" hcPath progdb) + + let comp = + Compiler + { compilerId = CompilerId UHC uhcVersion + , compilerAbiTag = NoAbiTag + , compilerCompat = [] + , compilerLanguages = uhcLanguages + , compilerExtensions = uhcLanguageExtensions + , compilerProperties = Map.empty + } compPlatform = Nothing return (comp, compPlatform, progdb') @@ -76,64 +87,78 @@ uhcLanguages = [(Haskell98, "")] -- | The flags for the supported extensions. uhcLanguageExtensions :: [(Extension, Maybe CompilerFlag)] uhcLanguageExtensions = - let doFlag (f, (enable, disable)) = [(EnableExtension f, enable), - (DisableExtension f, disable)] - alwaysOn = (Nothing, Nothing{- wrong -}) - in concatMap doFlag - [(CPP, (Just "--cpp", Nothing{- wrong -})), - (PolymorphicComponents, alwaysOn), - (ExistentialQuantification, alwaysOn), - (ForeignFunctionInterface, alwaysOn), - (UndecidableInstances, alwaysOn), - (MultiParamTypeClasses, alwaysOn), - (Rank2Types, alwaysOn), - (PatternSignatures, alwaysOn), - (EmptyDataDecls, alwaysOn), - (ImplicitPrelude, (Nothing, Just "--no-prelude"{- wrong -})), - (TypeOperators, alwaysOn), - (OverlappingInstances, alwaysOn), - (FlexibleInstances, alwaysOn)] - -getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramDb - -> IO InstalledPackageIndex + let doFlag (f, (enable, disable)) = + [ (EnableExtension f, enable) + , (DisableExtension f, disable) + ] + alwaysOn = (Nothing, Nothing {- wrong -}) + in concatMap + doFlag + [ (CPP, (Just "--cpp", Nothing {- wrong -})) + , (PolymorphicComponents, alwaysOn) + , (ExistentialQuantification, alwaysOn) + , (ForeignFunctionInterface, alwaysOn) + , (UndecidableInstances, alwaysOn) + , (MultiParamTypeClasses, alwaysOn) + , (Rank2Types, alwaysOn) + , (PatternSignatures, alwaysOn) + , (EmptyDataDecls, alwaysOn) + , (ImplicitPrelude, (Nothing, Just "--no-prelude" {- wrong -})) + , (TypeOperators, alwaysOn) + , (OverlappingInstances, alwaysOn) + , (FlexibleInstances, alwaysOn) + ] + +getInstalledPackages + :: Verbosity + -> Compiler + -> PackageDBStack + -> ProgramDb + -> IO InstalledPackageIndex getInstalledPackages verbosity comp packagedbs progdb = do let compilerid = compilerId comp systemPkgDir <- getGlobalPackageDir verbosity progdb - userPkgDir <- getUserPackageDir - let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs) + userPkgDir <- getUserPackageDir + let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs) -- putStrLn $ "pkgdirs: " ++ show pkgDirs - pkgs <- liftM (map addBuiltinVersions . concat) $ - traverse (\ d -> getDirectoryContents d >>= filterM (isPkgDir (prettyShow compilerid) d)) - pkgDirs + pkgs <- + liftM (map addBuiltinVersions . concat) $ + traverse + (\d -> getDirectoryContents d >>= filterM (isPkgDir (prettyShow compilerid) d)) + pkgDirs -- putStrLn $ "pkgs: " ++ show pkgs let iPkgs = map mkInstalledPackageInfo $ - concatMap parsePackage $ - pkgs + concatMap parsePackage $ + pkgs -- putStrLn $ "installed pkgs: " ++ show iPkgs return (fromList iPkgs) getGlobalPackageDir :: Verbosity -> ProgramDb -> IO FilePath getGlobalPackageDir verbosity progdb = do - output <- getDbProgramOutput verbosity - uhcProgram progdb ["--meta-pkgdir-system"] - -- we need to trim because pkgdir contains an extra newline at the end - let pkgdir = trimEnd output - return pkgdir + output <- + getDbProgramOutput + verbosity + uhcProgram + progdb + ["--meta-pkgdir-system"] + -- we need to trim because pkgdir contains an extra newline at the end + let pkgdir = trimEnd output + return pkgdir where trimEnd = dropWhileEnd isSpace getUserPackageDir :: IO FilePath getUserPackageDir = do - homeDir <- getHomeDirectory - return $ homeDir ".cabal" "lib" -- TODO: determine in some other way + homeDir <- getHomeDirectory + return $ homeDir ".cabal" "lib" -- TODO: determine in some other way packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath] packageDbPaths user system db = case db of - GlobalPackageDB -> [ system ] - UserPackageDB -> [ user ] - SpecificPackageDB path -> [ path ] + GlobalPackageDB -> [system] + UserPackageDB -> [user] + SpecificPackageDB path -> [path] -- | Hack to add version numbers to UHC-built-in packages. This should sooner or -- later be fixed on the UHC side. @@ -143,7 +168,7 @@ addBuiltinVersions "uhcbase" = "uhcbase-1.0" addBuiltinVersions "base" = "base-3.0" addBuiltinVersions "array" = "array-0.2" -} -addBuiltinVersions xs = xs +addBuiltinVersions xs = xs -- | Name of the installed package config file. installedPkgConfig :: String @@ -153,121 +178,164 @@ installedPkgConfig = "installed-pkg-config" -- looking only for the presence of an installed package configuration. -- TODO: Actually make use of the information provided in the file. isPkgDir :: String -> String -> String -> IO Bool -isPkgDir _ _ ('.' : _) = return False -- ignore files starting with a . -isPkgDir c dir xs = do - let candidate = dir uhcPackageDir xs c - -- putStrLn $ "trying: " ++ candidate - doesFileExist (candidate installedPkgConfig) +isPkgDir _ _ ('.' : _) = return False -- ignore files starting with a . +isPkgDir c dir xs = do + let candidate = dir uhcPackageDir xs c + -- putStrLn $ "trying: " ++ candidate + doesFileExist (candidate installedPkgConfig) parsePackage :: String -> [PackageId] -parsePackage = toList . simpleParsec +parsePackage = toList . simpleParsec -- | Create a trivial package info from a directory name. mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo -mkInstalledPackageInfo p = emptyInstalledPackageInfo - { installedUnitId = mkLegacyUnitId p, - sourcePackageId = p } - +mkInstalledPackageInfo p = + emptyInstalledPackageInfo + { installedUnitId = mkLegacyUnitId p + , sourcePackageId = p + } -- ----------------------------------------------------------------------------- -- Building -buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () +buildLib + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () buildLib verbosity pkg_descr lbi lib clbi = do - systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi) - userPkgDir <- getUserPackageDir + userPkgDir <- getUserPackageDir let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi) - let uhcArgs = -- set package name - ["--pkg-build=" ++ prettyShow (packageId pkg_descr)] - -- common flags lib/exe - ++ constructUHCCmdLine userPkgDir systemPkgDir - lbi (libBuildInfo lib) clbi - (buildDir lbi) verbosity - -- source files - -- suboptimal: UHC does not understand module names, so - -- we replace periods by path separators - ++ map (map (\ c -> if c == '.' then pathSeparator else c)) - (map prettyShow (allLibModules lib clbi)) + let uhcArgs = + -- set package name + ["--pkg-build=" ++ prettyShow (packageId pkg_descr)] + -- common flags lib/exe + ++ constructUHCCmdLine + userPkgDir + systemPkgDir + lbi + (libBuildInfo lib) + clbi + (buildDir lbi) + verbosity + -- source files + -- suboptimal: UHC does not understand module names, so + -- we replace periods by path separators + ++ map + (map (\c -> if c == '.' then pathSeparator else c)) + (map prettyShow (allLibModules lib clbi)) runUhcProg uhcArgs return () -buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () buildExe verbosity _pkg_descr lbi exe clbi = do systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi) - userPkgDir <- getUserPackageDir + userPkgDir <- getUserPackageDir let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi) - let uhcArgs = -- common flags lib/exe - constructUHCCmdLine userPkgDir systemPkgDir - lbi (buildInfo exe) clbi - (buildDir lbi) verbosity - -- output file - ++ ["--output", buildDir lbi prettyShow (exeName exe)] - -- main source module - ++ [modulePath exe] + let uhcArgs = + -- common flags lib/exe + constructUHCCmdLine + userPkgDir + systemPkgDir + lbi + (buildInfo exe) + clbi + (buildDir lbi) + verbosity + -- output file + ++ ["--output", buildDir lbi prettyShow (exeName exe)] + -- main source module + ++ [modulePath exe] runUhcProg uhcArgs -constructUHCCmdLine :: FilePath -> FilePath - -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> Verbosity -> [String] +constructUHCCmdLine + :: FilePath + -> FilePath + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> Verbosity + -> [String] constructUHCCmdLine user system lbi bi clbi odir verbosity = - -- verbosity - (if verbosity >= deafening then ["-v4"] - else if verbosity >= normal then [] - else ["-v0"]) - ++ hcOptions UHC bi - -- flags for language extensions - ++ languageToFlags (compiler lbi) (defaultLanguage bi) - ++ extensionsToFlags (compiler lbi) (usedExtensions bi) - -- packages - ++ ["--hide-all-packages"] - ++ uhcPackageDbOptions user system (withPackageDB lbi) - ++ ["--package=uhcbase"] - ++ ["--package=" ++ prettyShow (mungedName pkgid) | (_, pkgid) <- componentPackageDeps clbi ] - -- search paths - ++ ["-i" ++ odir] - ++ ["-i" ++ getSymbolicPath l | l <- nub (hsSourceDirs bi)] - ++ ["-i" ++ autogenComponentModulesDir lbi clbi] - ++ ["-i" ++ autogenPackageModulesDir lbi] - -- cpp options - ++ ["--optP=" ++ opt | opt <- cppOptions bi] - -- output path - ++ ["--odir=" ++ odir] - -- optimization - ++ (case withOptimization lbi of - NoOptimisation -> ["-O0"] - NormalOptimisation -> ["-O1"] - MaximumOptimisation -> ["-O2"]) + -- verbosity + ( if verbosity >= deafening + then ["-v4"] + else + if verbosity >= normal + then [] + else ["-v0"] + ) + ++ hcOptions UHC bi + -- flags for language extensions + ++ languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (usedExtensions bi) + -- packages + ++ ["--hide-all-packages"] + ++ uhcPackageDbOptions user system (withPackageDB lbi) + ++ ["--package=uhcbase"] + ++ ["--package=" ++ prettyShow (mungedName pkgid) | (_, pkgid) <- componentPackageDeps clbi] + -- search paths + ++ ["-i" ++ odir] + ++ ["-i" ++ getSymbolicPath l | l <- nub (hsSourceDirs bi)] + ++ ["-i" ++ autogenComponentModulesDir lbi clbi] + ++ ["-i" ++ autogenPackageModulesDir lbi] + -- cpp options + ++ ["--optP=" ++ opt | opt <- cppOptions bi] + -- output path + ++ ["--odir=" ++ odir] + -- optimization + ++ ( case withOptimization lbi of + NoOptimisation -> ["-O0"] + NormalOptimisation -> ["-O1"] + MaximumOptimisation -> ["-O2"] + ) uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String] -uhcPackageDbOptions user system db = map (\ x -> "--pkg-searchpath=" ++ x) - (concatMap (packageDbPaths user system) db) +uhcPackageDbOptions user system db = + map + (\x -> "--pkg-searchpath=" ++ x) + (concatMap (packageDbPaths user system) db) -- ----------------------------------------------------------------------------- -- Installation -installLib :: Verbosity -> LocalBuildInfo - -> FilePath -> FilePath -> FilePath - -> PackageDescription -> Library -> ComponentLocalBuildInfo -> IO () +installLib + :: Verbosity + -> LocalBuildInfo + -> FilePath + -> FilePath + -> FilePath + -> PackageDescription + -> Library + -> ComponentLocalBuildInfo + -> IO () installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library _clbi = do - -- putStrLn $ "dest: " ++ targetDir - -- putStrLn $ "built: " ++ builtDir - installDirectoryContents verbosity (builtDir prettyShow (packageId pkg)) targetDir + -- putStrLn $ "dest: " ++ targetDir + -- putStrLn $ "built: " ++ builtDir + installDirectoryContents verbosity (builtDir prettyShow (packageId pkg)) targetDir -- currently hard-coded UHC code generator and variant to use uhcTarget, uhcTargetVariant :: String -uhcTarget = "bc" +uhcTarget = "bc" uhcTargetVariant = "plain" -- root directory for a package in UHC -uhcPackageDir :: String -> String -> FilePath -uhcPackageSubDir :: String -> FilePath -uhcPackageDir pkgid compilerid = pkgid uhcPackageSubDir compilerid -uhcPackageSubDir compilerid = compilerid uhcTarget uhcTargetVariant +uhcPackageDir :: String -> String -> FilePath +uhcPackageSubDir :: String -> FilePath +uhcPackageDir pkgid compilerid = pkgid uhcPackageSubDir compilerid +uhcPackageSubDir compilerid = compilerid uhcTarget uhcTargetVariant -- ----------------------------------------------------------------------------- -- Registering @@ -280,16 +348,17 @@ registerPackage -> InstalledPackageInfo -> IO () registerPackage verbosity comp progdb packageDbs installedPkgInfo = do - dbdir <- case registrationPackageDB packageDbs of - GlobalPackageDB -> getGlobalPackageDir verbosity progdb - UserPackageDB -> getUserPackageDir - SpecificPackageDB dir -> return dir - let pkgdir = dbdir uhcPackageDir (prettyShow pkgid) (prettyShow compilerid) - createDirectoryIfMissingVerbose verbosity True pkgdir - writeUTF8File (pkgdir installedPkgConfig) - (showInstalledPackageInfo installedPkgInfo) + dbdir <- case registrationPackageDB packageDbs of + GlobalPackageDB -> getGlobalPackageDir verbosity progdb + UserPackageDB -> getUserPackageDir + SpecificPackageDB dir -> return dir + let pkgdir = dbdir uhcPackageDir (prettyShow pkgid) (prettyShow compilerid) + createDirectoryIfMissingVerbose verbosity True pkgdir + writeUTF8File + (pkgdir installedPkgConfig) + (showInstalledPackageInfo installedPkgInfo) where - pkgid = sourcePackageId installedPkgInfo + pkgid = sourcePackageId installedPkgInfo compilerid = compilerId comp inplacePackageDbPath :: LocalBuildInfo -> FilePath diff --git a/Cabal/src/Distribution/Simple/UserHooks.hs b/Cabal/src/Distribution/Simple/UserHooks.hs index 19454e4a713..b27cd0b875f 100644 --- a/Cabal/src/Distribution/Simple/UserHooks.hs +++ b/Cabal/src/Distribution/Simple/UserHooks.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.UserHooks -- Copyright : Isaac Jones 2003-2005 @@ -25,21 +26,21 @@ -- pass any extra parameters to most of the functions that implement the -- various phases because it would involve changing the types of the -- corresponding hook. At some point it will have to be replaced. - -module Distribution.Simple.UserHooks ( - UserHooks(..), Args, - emptyUserHooks, +module Distribution.Simple.UserHooks + ( UserHooks (..) + , Args + , emptyUserHooks ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.PackageDescription -import Distribution.Simple.Program import Distribution.Simple.Command +import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PreProcess +import Distribution.Simple.Program import Distribution.Simple.Setup -import Distribution.Simple.LocalBuildInfo type Args = [String] @@ -49,149 +50,137 @@ type Args = [String] -- * WARNING: The hooks interface is under rather constant flux as we try to -- understand users needs. Setup files that depend on this interface may -- break in future releases. -data UserHooks = UserHooks { - - -- | Read the description file - readDesc :: IO (Maybe GenericPackageDescription), - -- | Custom preprocessors in addition to and overriding 'knownSuffixHandlers'. - hookedPreProcessors :: [ PPSuffixHandler ], - -- | These programs are detected at configure time. Arguments for them are - -- added to the configure command. - hookedPrograms :: [Program], - - -- |Hook to run before configure command - preConf :: Args -> ConfigFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during configure. - confHook :: (GenericPackageDescription, HookedBuildInfo) - -> ConfigFlags -> IO LocalBuildInfo, - -- |Hook to run after configure command - postConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before build command. Second arg indicates verbosity level. - preBuild :: Args -> BuildFlags -> IO HookedBuildInfo, - - -- |Over-ride this hook to get different behavior during build. - buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO (), - -- |Hook to run after build command. Second arg indicates verbosity level. - postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before repl command. Second arg indicates verbosity level. - preRepl :: Args -> ReplFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during interpretation. - replHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO (), - -- |Hook to run after repl command. Second arg indicates verbosity level. - postRepl :: Args -> ReplFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before clean command. Second arg indicates verbosity level. - preClean :: Args -> CleanFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during clean. - cleanHook :: PackageDescription -> () -> UserHooks -> CleanFlags -> IO (), - -- |Hook to run after clean command. Second arg indicates verbosity level. - postClean :: Args -> CleanFlags -> PackageDescription -> () -> IO (), - - -- |Hook to run before copy command - preCopy :: Args -> CopyFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during copy. - copyHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO (), - -- |Hook to run after copy command - postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before install command - preInst :: Args -> InstallFlags -> IO HookedBuildInfo, - - -- |Over-ride this hook to get different behavior during install. - instHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO (), - -- |Hook to run after install command. postInst should be run - -- on the target, not on the build machine. - postInst :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before register command - preReg :: Args -> RegisterFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during registration. - regHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), - -- |Hook to run after register command - postReg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before unregister command - preUnreg :: Args -> RegisterFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during unregistration. - unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), - -- |Hook to run after unregister command - postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before hscolour command. Second arg indicates verbosity level. - preHscolour :: Args -> HscolourFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during hscolour. - hscolourHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HscolourFlags -> IO (), - -- |Hook to run after hscolour command. Second arg indicates verbosity level. - postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before haddock command. Second arg indicates verbosity level. - preHaddock :: Args -> HaddockFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during haddock. - haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO (), - -- |Hook to run after haddock command. Second arg indicates verbosity level. - postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before test command. - preTest :: Args -> TestFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during test. - testHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO (), - -- |Hook to run after test command. - postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before bench command. - preBench :: Args -> BenchmarkFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during bench. - benchHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> BenchmarkFlags -> IO (), - -- |Hook to run after bench command. - postBench :: Args -> BenchmarkFlags -> PackageDescription -> LocalBuildInfo -> IO () +data UserHooks = UserHooks + { readDesc :: IO (Maybe GenericPackageDescription) + -- ^ Read the description file + , hookedPreProcessors :: [PPSuffixHandler] + -- ^ Custom preprocessors in addition to and overriding 'knownSuffixHandlers'. + , hookedPrograms :: [Program] + -- ^ These programs are detected at configure time. Arguments for them are + -- added to the configure command. + , preConf :: Args -> ConfigFlags -> IO HookedBuildInfo + -- ^ Hook to run before configure command + , confHook + :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags + -> IO LocalBuildInfo + -- ^ Over-ride this hook to get different behavior during configure. + , postConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after configure command + , preBuild :: Args -> BuildFlags -> IO HookedBuildInfo + -- ^ Hook to run before build command. Second arg indicates verbosity level. + , buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO () + -- ^ Over-ride this hook to get different behavior during build. + , postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after build command. Second arg indicates verbosity level. + , preRepl :: Args -> ReplFlags -> IO HookedBuildInfo + -- ^ Hook to run before repl command. Second arg indicates verbosity level. + , replHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO () + -- ^ Over-ride this hook to get different behavior during interpretation. + , postRepl :: Args -> ReplFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after repl command. Second arg indicates verbosity level. + , preClean :: Args -> CleanFlags -> IO HookedBuildInfo + -- ^ Hook to run before clean command. Second arg indicates verbosity level. + , cleanHook :: PackageDescription -> () -> UserHooks -> CleanFlags -> IO () + -- ^ Over-ride this hook to get different behavior during clean. + , postClean :: Args -> CleanFlags -> PackageDescription -> () -> IO () + -- ^ Hook to run after clean command. Second arg indicates verbosity level. + , preCopy :: Args -> CopyFlags -> IO HookedBuildInfo + -- ^ Hook to run before copy command + , copyHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO () + -- ^ Over-ride this hook to get different behavior during copy. + , postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after copy command + , preInst :: Args -> InstallFlags -> IO HookedBuildInfo + -- ^ Hook to run before install command + , instHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO () + -- ^ Over-ride this hook to get different behavior during install. + , postInst :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after install command. postInst should be run + -- on the target, not on the build machine. + , preReg :: Args -> RegisterFlags -> IO HookedBuildInfo + -- ^ Hook to run before register command + , regHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO () + -- ^ Over-ride this hook to get different behavior during registration. + , postReg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after register command + , preUnreg :: Args -> RegisterFlags -> IO HookedBuildInfo + -- ^ Hook to run before unregister command + , unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO () + -- ^ Over-ride this hook to get different behavior during unregistration. + , postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after unregister command + , preHscolour :: Args -> HscolourFlags -> IO HookedBuildInfo + -- ^ Hook to run before hscolour command. Second arg indicates verbosity level. + , hscolourHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HscolourFlags -> IO () + -- ^ Over-ride this hook to get different behavior during hscolour. + , postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after hscolour command. Second arg indicates verbosity level. + , preHaddock :: Args -> HaddockFlags -> IO HookedBuildInfo + -- ^ Hook to run before haddock command. Second arg indicates verbosity level. + , haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO () + -- ^ Over-ride this hook to get different behavior during haddock. + , postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after haddock command. Second arg indicates verbosity level. + , preTest :: Args -> TestFlags -> IO HookedBuildInfo + -- ^ Hook to run before test command. + , testHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO () + -- ^ Over-ride this hook to get different behavior during test. + , postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after test command. + , preBench :: Args -> BenchmarkFlags -> IO HookedBuildInfo + -- ^ Hook to run before bench command. + , benchHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> BenchmarkFlags -> IO () + -- ^ Over-ride this hook to get different behavior during bench. + , postBench :: Args -> BenchmarkFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after bench command. } --- |Empty 'UserHooks' which do nothing. +-- | Empty 'UserHooks' which do nothing. emptyUserHooks :: UserHooks -emptyUserHooks - = UserHooks { - readDesc = return Nothing, - hookedPreProcessors = [], - hookedPrograms = [], - preConf = rn', - confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")), - postConf = ru, - preBuild = rn', - buildHook = ru, - postBuild = ru, - preRepl = \_ _ -> return emptyHookedBuildInfo, - replHook = \_ _ _ _ _ -> return (), - postRepl = ru, - preClean = rn, - cleanHook = ru, - postClean = ru, - preCopy = rn', - copyHook = ru, - postCopy = ru, - preInst = rn, - instHook = ru, - postInst = ru, - preReg = rn', - regHook = ru, - postReg = ru, - preUnreg = rn, - unregHook = ru, - postUnreg = ru, - preHscolour = rn, - hscolourHook = ru, - postHscolour = ru, - preHaddock = rn', - haddockHook = ru, - postHaddock = ru, - preTest = rn', - testHook = \_ -> ru, - postTest = ru, - preBench = rn', - benchHook = \_ -> ru, - postBench = ru +emptyUserHooks = + UserHooks + { readDesc = return Nothing + , hookedPreProcessors = [] + , hookedPrograms = [] + , preConf = rn' + , confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")) + , postConf = ru + , preBuild = rn' + , buildHook = ru + , postBuild = ru + , preRepl = \_ _ -> return emptyHookedBuildInfo + , replHook = \_ _ _ _ _ -> return () + , postRepl = ru + , preClean = rn + , cleanHook = ru + , postClean = ru + , preCopy = rn' + , copyHook = ru + , postCopy = ru + , preInst = rn + , instHook = ru + , postInst = ru + , preReg = rn' + , regHook = ru + , postReg = ru + , preUnreg = rn + , unregHook = ru + , postUnreg = ru + , preHscolour = rn + , hscolourHook = ru + , postHscolour = ru + , preHaddock = rn' + , haddockHook = ru + , postHaddock = ru + , preTest = rn' + , testHook = \_ -> ru + , postTest = ru + , preBench = rn' + , benchHook = \_ -> ru + , postBench = ru } - where rn args _ = noExtraFlags args >> return emptyHookedBuildInfo - rn' _ _ = return emptyHookedBuildInfo - ru _ _ _ _ = return () + where + rn args _ = noExtraFlags args >> return emptyHookedBuildInfo + rn' _ _ = return emptyHookedBuildInfo + ru _ _ _ _ = return () diff --git a/Cabal/src/Distribution/Simple/Utils.hs b/Cabal/src/Distribution/Simple/Utils.hs index 3fb6f56c738..e141e5bbff4 100644 --- a/Cabal/src/Distribution/Simple/Utils.hs +++ b/Cabal/src/Distribution/Simple/Utils.hs @@ -1,13 +1,14 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Utils -- Copyright : Isaac Jones, Simon Marlow 2003-2004 @@ -22,176 +23,185 @@ -- lib like @cabal-install@. It has a very simple set of logging actions. It -- has low level functions for running programs, a bunch of wrappers for -- various directory and file functions that do extra logging. +module Distribution.Simple.Utils + ( cabalVersion + + -- * logging and errors + , dieNoVerbosity + , die' + , dieWithLocation' + , dieNoWrap + , topHandler + , topHandlerWith + , warn + , notice + , noticeNoWrap + , noticeDoc + , setupMessage + , info + , infoNoWrap + , debug + , debugNoWrap + , chattyTry + , annotateIO + , withOutputMarker + + -- * exceptions + , handleDoesNotExist + , ignoreSigPipe + + -- * running programs + , rawSystemExit + , rawSystemExitCode + , rawSystemProc + , rawSystemProcAction + , rawSystemExitWithEnv + , rawSystemStdout + , rawSystemStdInOut + , rawSystemIOWithEnv + , rawSystemIOWithEnvAndAction + , fromCreatePipe + , maybeExit + , xargs + , findProgramVersion + + -- ** 'IOData' re-export -module Distribution.Simple.Utils ( - cabalVersion, - - -- * logging and errors - dieNoVerbosity, - die', dieWithLocation', - dieNoWrap, - topHandler, topHandlerWith, - warn, - notice, noticeNoWrap, noticeDoc, - setupMessage, - info, infoNoWrap, - debug, debugNoWrap, - chattyTry, - annotateIO, - withOutputMarker, - - -- * exceptions - handleDoesNotExist, - ignoreSigPipe, - - -- * running programs - rawSystemExit, - rawSystemExitCode, - rawSystemProc, - rawSystemProcAction, - rawSystemExitWithEnv, - rawSystemStdout, - rawSystemStdInOut, - rawSystemIOWithEnv, - rawSystemIOWithEnvAndAction, - fromCreatePipe, - maybeExit, - xargs, - findProgramVersion, - - -- ** 'IOData' re-export - -- - -- These types are re-exported from - -- "Distribution.Utils.IOData" for convenience as they're - -- exposed in the API of 'rawSystemStdInOut' - IOData(..), - KnownIODataMode (..), - IODataMode (..), - - -- * copying files - createDirectoryIfMissingVerbose, - copyFileVerbose, - copyFiles, - copyFileTo, - - -- * installing files - installOrdinaryFile, - installExecutableFile, - installMaybeExecutableFile, - installOrdinaryFiles, - installExecutableFiles, - installMaybeExecutableFiles, - installDirectoryContents, - copyDirectoryRecursive, - - -- * File permissions - doesExecutableExist, - setFileOrdinary, - setFileExecutable, - - -- * file names - currentDir, - shortRelativePath, - dropExeExtension, - exeExtensions, - - -- * finding files - findFileEx, - findFileCwd, - findFirstFile, - findFileWithExtension, - findFileCwdWithExtension, - findFileWithExtension', - findAllFilesWithExtension, - findAllFilesCwdWithExtension, - findModuleFileEx, - findModuleFilesEx, - getDirectoryContentsRecursive, - - -- * environment variables - isInSearchPath, - addLibraryPath, - - -- * modification time - moreRecentFile, - existsAndIsMoreRecentThan, - - -- * temp files and dirs - TempFileOptions(..), defaultTempFileOptions, - withTempFile, withTempFileEx, - withTempDirectory, withTempDirectoryEx, - createTempDirectory, - - -- * .cabal and .buildinfo files - defaultPackageDesc, - findPackageDesc, - findPackageDescCwd, - tryFindPackageDesc, - tryFindPackageDescCwd, - findHookedPackageDesc, - - -- * reading and writing files safely - withFileContents, - writeFileAtomic, - rewriteFileEx, - rewriteFileLBS, - - -- * Unicode - fromUTF8BS, - fromUTF8LBS, - toUTF8BS, - toUTF8LBS, - readUTF8File, - withUTF8FileContents, - writeUTF8File, - normaliseLineEndings, - - -- * BOM - ignoreBOM, - - -- * generic utils - dropWhileEndLE, - takeWhileEndLE, - equating, - comparing, - isInfixOf, - intercalate, - lowercase, - listUnion, - listUnionRight, - ordNub, - ordNubBy, - ordNubRight, - safeHead, - safeTail, - safeLast, - safeInit, - unintersperse, - wrapText, - wrapLine, - - -- * FilePath stuff - isAbsoluteOnAnyPlatform, - isRelativeOnAnyPlatform, + -- + -- These types are re-exported from + -- "Distribution.Utils.IOData" for convenience as they're + -- exposed in the API of 'rawSystemStdInOut' + , IOData (..) + , KnownIODataMode (..) + , IODataMode (..) + + -- * copying files + , createDirectoryIfMissingVerbose + , copyFileVerbose + , copyFiles + , copyFileTo + + -- * installing files + , installOrdinaryFile + , installExecutableFile + , installMaybeExecutableFile + , installOrdinaryFiles + , installExecutableFiles + , installMaybeExecutableFiles + , installDirectoryContents + , copyDirectoryRecursive + + -- * File permissions + , doesExecutableExist + , setFileOrdinary + , setFileExecutable + + -- * file names + , currentDir + , shortRelativePath + , dropExeExtension + , exeExtensions + + -- * finding files + , findFileEx + , findFileCwd + , findFirstFile + , findFileWithExtension + , findFileCwdWithExtension + , findFileWithExtension' + , findAllFilesWithExtension + , findAllFilesCwdWithExtension + , findModuleFileEx + , findModuleFilesEx + , getDirectoryContentsRecursive + + -- * environment variables + , isInSearchPath + , addLibraryPath + + -- * modification time + , moreRecentFile + , existsAndIsMoreRecentThan + + -- * temp files and dirs + , TempFileOptions (..) + , defaultTempFileOptions + , withTempFile + , withTempFileEx + , withTempDirectory + , withTempDirectoryEx + , createTempDirectory + + -- * .cabal and .buildinfo files + , defaultPackageDesc + , findPackageDesc + , findPackageDescCwd + , tryFindPackageDesc + , tryFindPackageDescCwd + , findHookedPackageDesc + + -- * reading and writing files safely + , withFileContents + , writeFileAtomic + , rewriteFileEx + , rewriteFileLBS + + -- * Unicode + , fromUTF8BS + , fromUTF8LBS + , toUTF8BS + , toUTF8LBS + , readUTF8File + , withUTF8FileContents + , writeUTF8File + , normaliseLineEndings + + -- * BOM + , ignoreBOM + + -- * generic utils + , dropWhileEndLE + , takeWhileEndLE + , equating + , comparing + , isInfixOf + , intercalate + , lowercase + , listUnion + , listUnionRight + , ordNub + , ordNubBy + , ordNubRight + , safeHead + , safeTail + , safeLast + , safeInit + , unintersperse + , wrapText + , wrapLine + + -- * FilePath stuff + , isAbsoluteOnAnyPlatform + , isRelativeOnAnyPlatform ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Utils.Generic -import Distribution.Utils.IOData (IOData(..), IODataMode (..), KnownIODataMode (..)) -import qualified Distribution.Utils.IOData as IOData -import Distribution.ModuleName as ModuleName -import Distribution.System -import Distribution.Version import Distribution.Compat.Async (waitCatch, withAsyncNF) import Distribution.Compat.CopyFile import Distribution.Compat.FilePath as FilePath import Distribution.Compat.Internal.TempFile import Distribution.Compat.Lens (Lens', over) import Distribution.Compat.Stack -import Distribution.Verbosity +import Distribution.ModuleName as ModuleName +import Distribution.System import Distribution.Types.PackageId +import Distribution.Utils.Generic +import Distribution.Utils.IOData (IOData (..), IODataMode (..), KnownIODataMode (..)) +import qualified Distribution.Utils.IOData as IOData +import Distribution.Verbosity +import Distribution.Version #ifdef CURRENT_PACKAGE_KEY #define BOOTSTRAPPED_CABAL 1 @@ -201,37 +211,64 @@ import Distribution.Types.PackageId import qualified Paths_Cabal (version) #endif -import Distribution.Pretty import Distribution.Parsec +import Distribution.Pretty -import Data.Typeable - ( cast ) import qualified Data.ByteString.Lazy as BS +import Data.Typeable + ( cast + ) +import qualified Control.Exception as Exception import System.Directory - ( Permissions(executable), getDirectoryContents, getPermissions - , doesDirectoryExist, doesFileExist, removeFile - , getModificationTime, createDirectory, removeDirectoryRecursive ) + ( Permissions (executable) + , createDirectory + , doesDirectoryExist + , doesFileExist + , getDirectoryContents + , getModificationTime + , getPermissions + , removeDirectoryRecursive + , removeFile + ) import System.Environment - ( getProgName ) + ( getProgName + ) import System.FilePath as FilePath - ( normalise, (), (<.>) - , getSearchPath, joinPath, takeDirectory, splitExtension - , splitDirectories, searchPathSeparator ) + ( getSearchPath + , joinPath + , normalise + , searchPathSeparator + , splitDirectories + , splitExtension + , takeDirectory + , (<.>) + , () + ) import System.IO - ( Handle, hSetBinaryMode, hGetContents, stderr, stdout, hPutStr, hFlush - , hClose, hSetBuffering, BufferMode(..), hPutStrLn ) + ( BufferMode (..) + , Handle + , hClose + , hFlush + , hGetContents + , hPutStr + , hPutStrLn + , hSetBinaryMode + , hSetBuffering + , stderr + , stdout + ) import System.IO.Error import System.IO.Unsafe - ( unsafeInterleaveIO ) -import qualified Control.Exception as Exception + ( unsafeInterleaveIO + ) +import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) +import Distribution.Compat.Process (proc) import Foreign.C.Error (Errno (..), ePIPE) -import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime) +import qualified GHC.IO.Exception as GHC import Numeric (showFFloat) -import Distribution.Compat.Process (proc) import qualified System.Process as Process -import qualified GHC.IO.Exception as GHC import qualified Text.PrettyPrint as Disp @@ -299,8 +336,8 @@ cabalVersion = mkVersion [3,0] --used when bootstrapping -- dieNoVerbosity :: String -> IO a -dieNoVerbosity msg - = ioError (userError msg) +dieNoVerbosity msg = + ioError (userError msg) where _ = callStack -- TODO: Attach CallStack to exception @@ -319,37 +356,41 @@ verbatimUserError = ioeSetVerbatim . userError dieWithLocation' :: Verbosity -> FilePath -> Maybe Int -> String -> IO a dieWithLocation' verbosity filename mb_lineno msg = - die' verbosity $ - filename ++ (case mb_lineno of - Just lineno -> ":" ++ show lineno - Nothing -> "") ++ - ": " ++ msg + die' verbosity $ + filename + ++ ( case mb_lineno of + Just lineno -> ":" ++ show lineno + Nothing -> "" + ) + ++ ": " + ++ msg die' :: Verbosity -> String -> IO a die' verbosity msg = withFrozenCallStack $ do - ioError . verbatimUserError - =<< annotateErrorString verbosity - =<< pure . wrapTextVerbosity verbosity - =<< pure . addErrorPrefix - =<< prefixWithProgName msg + ioError . verbatimUserError + =<< annotateErrorString verbosity + =<< pure . wrapTextVerbosity verbosity + =<< pure . addErrorPrefix + =<< prefixWithProgName msg dieNoWrap :: Verbosity -> String -> IO a dieNoWrap verbosity msg = withFrozenCallStack $ do - -- TODO: should this have program name or not? - ioError . verbatimUserError - =<< annotateErrorString verbosity - (addErrorPrefix msg) + -- TODO: should this have program name or not? + ioError . verbatimUserError + =<< annotateErrorString + verbosity + (addErrorPrefix msg) -- | Prefixing a message to indicate that it is a fatal error, -- if the 'errorPrefix' is not already present. addErrorPrefix :: String -> String addErrorPrefix msg | errorPrefix `isPrefixOf` msg = msg - -- Backpack prefixes its errors already with "Error:", see - -- 'Distribution.Utils.LogProgress.dieProgress'. - -- Taking it away there destroys the layout, so we rather - -- check here whether the prefix is already present. - | otherwise = unwords [errorPrefix, msg] + -- Backpack prefixes its errors already with "Error:", see + -- 'Distribution.Utils.LogProgress.dieProgress'. + -- Taking it away there destroys the layout, so we rather + -- check here whether the prefix is already present. + | otherwise = unwords [errorPrefix, msg] -- | A prefix indicating that a message is a fatal error. errorPrefix :: String @@ -358,14 +399,14 @@ errorPrefix = "Error:" -- | Prefix an error string with program name from 'getProgName' prefixWithProgName :: String -> IO String prefixWithProgName msg = do - pname <- getProgName - return $ pname ++ ": " ++ msg + pname <- getProgName + return $ pname ++ ": " ++ msg -- | Annotate an error string with timestamp and 'withMetadata'. annotateErrorString :: Verbosity -> String -> IO String annotateErrorString verbosity msg = do - ts <- getPOSIXTime - return $ withMetadata ts AlwaysMark VerboseTrace verbosity msg + ts <- getPOSIXTime + return $ withMetadata ts AlwaysMark VerboseTrace verbosity msg -- | Given a block of IO code that may raise an exception, annotate -- it with the metadata from the current scope. Use this as close @@ -374,9 +415,10 @@ annotateErrorString verbosity msg = do -- (so it is NOT idempotent.) annotateIO :: Verbosity -> IO a -> IO a annotateIO verbosity act = do - ts <- getPOSIXTime - flip modifyIOError act $ - ioeModifyErrorString $ withMetadata ts NeverMark VerboseTrace verbosity + ts <- getPOSIXTime + flip modifyIOError act $ + ioeModifyErrorString $ + withMetadata ts NeverMark VerboseTrace verbosity -- | A semantic editor for the error message inside an 'IOError'. ioeModifyErrorString :: (String -> String) -> IOError -> IOError @@ -386,18 +428,18 @@ ioeModifyErrorString = over ioeErrorString ioeErrorString :: Lens' IOError String ioeErrorString f ioe = ioeSetErrorString ioe <$> f (ioeGetErrorString ioe) - {-# NOINLINE topHandlerWith #-} topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a topHandlerWith cont prog = do - -- By default, stderr to a terminal device is NoBuffering. But this - -- is *really slow* - hSetBuffering stderr LineBuffering - Exception.catches prog [ - Exception.Handler rethrowAsyncExceptions - , Exception.Handler rethrowExitStatus - , Exception.Handler handle - ] + -- By default, stderr to a terminal device is NoBuffering. But this + -- is *really slow* + hSetBuffering stderr LineBuffering + Exception.catches + prog + [ Exception.Handler rethrowAsyncExceptions + , Exception.Handler rethrowExitStatus + , Exception.Handler handle + ] where -- Let async exceptions rise to the top for the default top-handler rethrowAsyncExceptions :: Exception.AsyncException -> IO a @@ -419,18 +461,18 @@ topHandlerWith cont prog = do message pname (Exception.SomeException se) = case cast se :: Maybe Exception.IOException of Just ioe - | ioeGetVerbatim ioe -> - -- Use the message verbatim - ioeGetErrorString ioe ++ "\n" - | isUserError ioe -> - let file = case ioeGetFileName ioe of - Nothing -> "" - Just path -> path ++ location ++ ": " - location = case ioeGetLocation ioe of - l@(n:_) | isDigit n -> ':' : l - _ -> "" - detail = ioeGetErrorString ioe - in wrapText $ addErrorPrefix $ pname ++ ": " ++ file ++ detail + | ioeGetVerbatim ioe -> + -- Use the message verbatim + ioeGetErrorString ioe ++ "\n" + | isUserError ioe -> + let file = case ioeGetFileName ioe of + Nothing -> "" + Just path -> path ++ location ++ ": " + location = case ioeGetLocation ioe of + l@(n : _) | isDigit n -> ':' : l + _ -> "" + detail = ioeGetErrorString ioe + in wrapText $ addErrorPrefix $ pname ++ ": " ++ file ++ detail _ -> displaySomeException se ++ "\n" @@ -444,21 +486,21 @@ topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog -- | Depending on 'isVerboseStderr', set the output handle to 'stderr' or 'stdout'. verbosityHandle :: Verbosity -> Handle verbosityHandle verbosity - | isVerboseStderr verbosity = stderr - | otherwise = stdout + | isVerboseStderr verbosity = stderr + | otherwise = stdout -- | Non fatal conditions that may be indicative of an error or problem. -- -- We display these at the 'normal' verbosity level. --- warn :: Verbosity -> String -> IO () warn verbosity msg = withFrozenCallStack $ do when ((verbosity >= normal) && not (isVerboseNoWarn verbosity)) $ do ts <- getPOSIXTime hFlush stdout - hPutStr stderr . withMetadata ts NormalMark FlagTrace verbosity - . wrapTextVerbosity verbosity - $ "Warning: " ++ msg + hPutStr stderr + . withMetadata ts NormalMark FlagTrace verbosity + . wrapTextVerbosity verbosity + $ "Warning: " ++ msg -- | Useful status messages. -- @@ -466,20 +508,18 @@ warn verbosity msg = withFrozenCallStack $ do -- -- This is for the ordinary helpful status messages that users see. Just -- enough information to know that things are working but not floods of detail. --- notice :: Verbosity -> String -> IO () notice verbosity msg = withFrozenCallStack $ do when (verbosity >= normal) $ do let h = verbosityHandle verbosity ts <- getPOSIXTime - hPutStr h - $ withMetadata ts NormalMark FlagTrace verbosity - $ wrapTextVerbosity verbosity - $ msg + hPutStr h $ + withMetadata ts NormalMark FlagTrace verbosity $ + wrapTextVerbosity verbosity $ + msg -- | Display a message at 'normal' verbosity level, but without -- wrapping. --- noticeNoWrap :: Verbosity -> String -> IO () noticeNoWrap verbosity msg = withFrozenCallStack $ do when (verbosity >= normal) $ do @@ -489,59 +529,56 @@ noticeNoWrap verbosity msg = withFrozenCallStack $ do -- | Pretty-print a 'Disp.Doc' status message at 'normal' verbosity -- level. Use this if you need fancy formatting. --- noticeDoc :: Verbosity -> Disp.Doc -> IO () noticeDoc verbosity msg = withFrozenCallStack $ do when (verbosity >= normal) $ do let h = verbosityHandle verbosity ts <- getPOSIXTime - hPutStr h - $ withMetadata ts NormalMark FlagTrace verbosity - $ Disp.renderStyle defaultStyle - $ msg + hPutStr h $ + withMetadata ts NormalMark FlagTrace verbosity $ + Disp.renderStyle defaultStyle $ + msg -- | Display a "setup status message". Prefer using setupMessage' -- if possible. --- setupMessage :: Verbosity -> String -> PackageIdentifier -> IO () setupMessage verbosity msg pkgid = withFrozenCallStack $ do - noticeNoWrap verbosity (msg ++ ' ': prettyShow pkgid ++ "...") + noticeNoWrap verbosity (msg ++ ' ' : prettyShow pkgid ++ "...") -- | More detail on the operation of some action. -- -- We display these messages when the verbosity level is 'verbose' --- info :: Verbosity -> String -> IO () info verbosity msg = withFrozenCallStack $ when (verbosity >= verbose) $ do let h = verbosityHandle verbosity ts <- getPOSIXTime - hPutStr h - $ withMetadata ts NeverMark FlagTrace verbosity - $ wrapTextVerbosity verbosity - $ msg + hPutStr h $ + withMetadata ts NeverMark FlagTrace verbosity $ + wrapTextVerbosity verbosity $ + msg infoNoWrap :: Verbosity -> String -> IO () infoNoWrap verbosity msg = withFrozenCallStack $ when (verbosity >= verbose) $ do let h = verbosityHandle verbosity ts <- getPOSIXTime - hPutStr h - $ withMetadata ts NeverMark FlagTrace verbosity - $ msg + hPutStr h $ + withMetadata ts NeverMark FlagTrace verbosity $ + msg -- | Detailed internal debugging information -- -- We display these messages when the verbosity level is 'deafening' --- debug :: Verbosity -> String -> IO () debug verbosity msg = withFrozenCallStack $ when (verbosity >= deafening) $ do let h = verbosityHandle verbosity ts <- getPOSIXTime - hPutStr h $ withMetadata ts NeverMark FlagTrace verbosity - $ wrapTextVerbosity verbosity - $ msg + hPutStr h $ + withMetadata ts NeverMark FlagTrace verbosity $ + wrapTextVerbosity verbosity $ + msg -- ensure that we don't lose output if we segfault/infinite loop hFlush stdout @@ -552,17 +589,20 @@ debugNoWrap verbosity msg = withFrozenCallStack $ when (verbosity >= deafening) $ do let h = verbosityHandle verbosity ts <- getPOSIXTime - hPutStr h - $ withMetadata ts NeverMark FlagTrace verbosity - $ msg + hPutStr h $ + withMetadata ts NeverMark FlagTrace verbosity $ + msg -- ensure that we don't lose output if we segfault/infinite loop hFlush stdout -- | Perform an IO action, catching any IO exceptions and printing an error -- if one occurs. -chattyTry :: String -- ^ a description of the action we were attempting - -> IO () -- ^ the action itself - -> IO () +chattyTry + :: String + -- ^ a description of the action we were attempting + -> IO () + -- ^ the action itself + -> IO () chattyTry desc action = catchIO action $ \exception -> hPutStrLn stderr $ "Error while " ++ desc ++ ": " ++ show exception @@ -571,9 +611,9 @@ chattyTry desc action = -- does not exist" error. handleDoesNotExist :: a -> IO a -> IO a handleDoesNotExist e = - Exception.handleJust - (\ioe -> if isDoesNotExistError ioe then Just ioe else Nothing) - (\_ -> return e) + Exception.handleJust + (\ioe -> if isDoesNotExistError ioe then Just ioe else Nothing) + (\_ -> return e) -- ----------------------------------------------------------------------------- -- Helper functions @@ -582,21 +622,19 @@ handleDoesNotExist e = wrapTextVerbosity :: Verbosity -> String -> String wrapTextVerbosity verb | isVerboseNoWrap verb = withTrailingNewline - | otherwise = withTrailingNewline . wrapText - + | otherwise = withTrailingNewline . wrapText -- | Prepends a timestamp if @+timestamp@ verbosity flag is set -- -- This is used by 'withMetadata' --- withTimestamp :: Verbosity -> POSIXTime -> String -> String withTimestamp v ts msg - | isVerboseTimestamp v = msg' - | otherwise = msg -- no-op + | isVerboseTimestamp v = msg' + | otherwise = msg -- no-op where msg' = case lines msg of - [] -> tsstr "\n" - l1:rest -> unlines (tsstr (' ':l1) : map (contpfx++) rest) + [] -> tsstr "\n" + l1 : rest -> unlines (tsstr (' ' : l1) : map (contpfx ++) rest) -- format timestamp to be prepended to first line with msec precision tsstr = showFFloat (Just 3) (realToFrac ts :: Double) @@ -615,93 +653,96 @@ withTimestamp v ts msg -- we don't have the ability to interpose on the output. -- -- This is used by 'withMetadata' --- withOutputMarker :: Verbosity -> String -> String withOutputMarker v xs | not (isVerboseMarkOutput v) = xs withOutputMarker _ "" = "" -- Minor optimization, don't mark uselessly withOutputMarker _ xs = - "-----BEGIN CABAL OUTPUT-----\n" ++ - withTrailingNewline xs ++ - "-----END CABAL OUTPUT-----\n" + "-----BEGIN CABAL OUTPUT-----\n" + ++ withTrailingNewline xs + ++ "-----END CABAL OUTPUT-----\n" -- | Append a trailing newline to a string if it does not -- already have a trailing newline. --- withTrailingNewline :: String -> String withTrailingNewline "" = "" -withTrailingNewline (x:xs) = x : go x xs +withTrailingNewline (x : xs) = x : go x xs where - go _ (c:cs) = c : go c cs + go _ (c : cs) = c : go c cs go '\n' "" = "" - go _ "" = "\n" + go _ "" = "\n" -- | Prepend a call-site and/or call-stack based on Verbosity --- withCallStackPrefix :: WithCallStack (TraceWhen -> Verbosity -> String -> String) -withCallStackPrefix tracer verbosity s = withFrozenCallStack $ - (if isVerboseCallSite verbosity - then parentSrcLocPrefix ++ - -- Hack: need a newline before starting output marker :( - if isVerboseMarkOutput verbosity - then "\n" - else "" - else "") ++ - (case traceWhen verbosity tracer of - Just pre -> pre ++ prettyCallStack callStack ++ "\n" - Nothing -> "") ++ - s +withCallStackPrefix tracer verbosity s = + withFrozenCallStack $ + ( if isVerboseCallSite verbosity + then + parentSrcLocPrefix + ++ + -- Hack: need a newline before starting output marker :( + if isVerboseMarkOutput verbosity + then "\n" + else "" + else "" + ) + ++ ( case traceWhen verbosity tracer of + Just pre -> pre ++ prettyCallStack callStack ++ "\n" + Nothing -> "" + ) + ++ s -- | When should we emit the call stack? We always emit -- for internal errors, emit the trace for errors when we -- are in verbose mode, and otherwise only emit it if -- explicitly asked for using the @+callstack@ verbosity -- flag. (At the moment, 'AlwaysTrace' is not used. --- data TraceWhen - = AlwaysTrace - | VerboseTrace - | FlagTrace - deriving (Eq) + = AlwaysTrace + | VerboseTrace + | FlagTrace + deriving (Eq) -- | Determine if we should emit a call stack. -- If we trace, it also emits any prefix we should append. traceWhen :: Verbosity -> TraceWhen -> Maybe String traceWhen _ AlwaysTrace = Just "" -traceWhen v VerboseTrace | v >= verbose = Just "" -traceWhen v FlagTrace | isVerboseCallStack v = Just "----\n" +traceWhen v VerboseTrace | v >= verbose = Just "" +traceWhen v FlagTrace | isVerboseCallStack v = Just "----\n" traceWhen _ _ = Nothing -- | When should we output the marker? Things like 'die' -- always get marked, but a 'NormalMark' will only be -- output if we're not a quiet verbosity. --- data MarkWhen = AlwaysMark | NormalMark | NeverMark -- | Add all necessary metadata to a logging message --- withMetadata :: WithCallStack (POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String) -withMetadata ts marker tracer verbosity x = withFrozenCallStack $ +withMetadata ts marker tracer verbosity x = + withFrozenCallStack + $ -- NB: order matters. Output marker first because we -- don't want to capture call stacks. - withTrailingNewline - . withCallStackPrefix tracer verbosity - . (case marker of - AlwaysMark -> withOutputMarker verbosity - NormalMark | not (isVerboseQuiet verbosity) - -> withOutputMarker verbosity - | otherwise - -> id - NeverMark -> id) - -- Clear out any existing markers - . clearMarkers - . withTimestamp verbosity ts + withTrailingNewline + . withCallStackPrefix tracer verbosity + . ( case marker of + AlwaysMark -> withOutputMarker verbosity + NormalMark + | not (isVerboseQuiet verbosity) -> + withOutputMarker verbosity + | otherwise -> + id + NeverMark -> id + ) + -- Clear out any existing markers + . clearMarkers + . withTimestamp verbosity ts $ x clearMarkers :: String -> String clearMarkers s = unlines . filter isMarker $ lines s where isMarker "-----BEGIN CABAL OUTPUT-----" = False - isMarker "-----END CABAL OUTPUT-----" = False + isMarker "-----END CABAL OUTPUT-----" = False isMarker _ = True -- ----------------------------------------------------------------------------- @@ -724,12 +765,12 @@ maybeExit cmd = do -- | Log a command execution (that's typically about to happen) -- at info level, and log working directory and environment overrides -- at debug level if specified. --- logCommand :: Verbosity -> Process.CreateProcess -> IO () logCommand verbosity cp = do - infoNoWrap verbosity $ "Running: " <> case Process.cmdspec cp of - Process.ShellCommand sh -> sh - Process.RawCommand path args -> Process.showCommandForUser path args + infoNoWrap verbosity $ + "Running: " <> case Process.cmdspec cp of + Process.ShellCommand sh -> sh + Process.RawCommand path args -> Process.showCommandForUser path args case Process.env cp of Just env -> debugNoWrap verbosity $ "with environment: " ++ show env Nothing -> return () @@ -740,17 +781,19 @@ logCommand verbosity cp = do -- | Execute the given command with the given arguments, exiting -- with the same exit code if the command fails. --- rawSystemExit :: Verbosity -> FilePath -> [String] -> IO () -rawSystemExit verbosity path args = withFrozenCallStack $ - maybeExit $ rawSystemExitCode verbosity path args +rawSystemExit verbosity path args = + withFrozenCallStack $ + maybeExit $ + rawSystemExitCode verbosity path args -- | Execute the given command with the given arguments, returning -- the command's exit code. --- rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode -rawSystemExitCode verbosity path args = withFrozenCallStack $ - rawSystemProc verbosity $ proc path args +rawSystemExitCode verbosity path args = + withFrozenCallStack $ + rawSystemProc verbosity $ + proc path args -- | Execute the given command with the given arguments, returning -- the command's exit code. @@ -758,7 +801,6 @@ rawSystemExitCode verbosity path args = withFrozenCallStack $ -- Create the process argument with 'Distribution.Compat.Process.proc' -- to ensure consistent options with other 'rawSystem' functions in this -- module. --- rawSystemProc :: Verbosity -> Process.CreateProcess -> IO ExitCode rawSystemProc verbosity cp = withFrozenCallStack $ do (exitcode, _) <- rawSystemProcAction verbosity cp $ \_ _ _ -> return () @@ -772,10 +814,11 @@ rawSystemProc verbosity cp = withFrozenCallStack $ do -- Create the process argument with 'Distribution.Compat.Process.proc' -- to ensure consistent options with other 'rawSystem' functions in this -- module. --- -rawSystemProcAction :: Verbosity -> Process.CreateProcess - -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a) - -> IO (ExitCode, a) +rawSystemProcAction + :: Verbosity + -> Process.CreateProcess + -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a) + -> IO (ExitCode, a) rawSystemProcAction verbosity cp action = withFrozenCallStack $ do logCommand verbosity cp (exitcode, a) <- Process.withCreateProcess cp $ \mStdin mStdout mStderr p -> do @@ -792,41 +835,57 @@ rawSystemProcAction verbosity cp action = withFrozenCallStack $ do -- | fromJust for dealing with 'Maybe Handle' values as obtained via -- 'System.Process.CreatePipe'. Creating a pipe using 'CreatePipe' guarantees -- a 'Just' value for the corresponding handle. --- fromCreatePipe :: Maybe Handle -> Handle fromCreatePipe = maybe (error "fromCreatePipe: Nothing") id -- | Execute the given command with the given arguments and -- environment, exiting with the same exit code if the command fails. --- -rawSystemExitWithEnv :: Verbosity - -> FilePath - -> [String] - -> [(String, String)] - -> IO () -rawSystemExitWithEnv verbosity path args env = withFrozenCallStack $ - maybeExit $ rawSystemProc verbosity $ - (proc path args) { Process.env = Just env - } +rawSystemExitWithEnv + :: Verbosity + -> FilePath + -> [String] + -> [(String, String)] + -> IO () +rawSystemExitWithEnv verbosity path args env = + withFrozenCallStack $ + maybeExit $ + rawSystemProc verbosity $ + (proc path args) + { Process.env = Just env + } -- | Execute the given command with the given arguments, returning -- the command's exit code. -- -- Optional arguments allow setting working directory, environment -- and input and output handles. --- -rawSystemIOWithEnv :: Verbosity - -> FilePath - -> [String] - -> Maybe FilePath -- ^ New working dir or inherit - -> Maybe [(String, String)] -- ^ New environment or inherit - -> Maybe Handle -- ^ stdin - -> Maybe Handle -- ^ stdout - -> Maybe Handle -- ^ stderr - -> IO ExitCode +rawSystemIOWithEnv + :: Verbosity + -> FilePath + -> [String] + -> Maybe FilePath + -- ^ New working dir or inherit + -> Maybe [(String, String)] + -- ^ New environment or inherit + -> Maybe Handle + -- ^ stdin + -> Maybe Handle + -- ^ stdout + -> Maybe Handle + -- ^ stderr + -> IO ExitCode rawSystemIOWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do - (exitcode, _) <- rawSystemIOWithEnvAndAction - verbosity path args mcwd menv action inp out err + (exitcode, _) <- + rawSystemIOWithEnvAndAction + verbosity + path + args + mcwd + menv + action + inp + out + err return exitcode where action = return () @@ -838,25 +897,32 @@ rawSystemIOWithEnv verbosity path args mcwd menv inp out err = withFrozenCallSta -- -- Optional arguments allow setting working directory, environment -- and input and output handles. --- rawSystemIOWithEnvAndAction - :: Verbosity - -> FilePath - -> [String] - -> Maybe FilePath -- ^ New working dir or inherit - -> Maybe [(String, String)] -- ^ New environment or inherit - -> IO a -- ^ action to perform after process is created, but before 'waitForProcess'. - -> Maybe Handle -- ^ stdin - -> Maybe Handle -- ^ stdout - -> Maybe Handle -- ^ stderr - -> IO (ExitCode, a) + :: Verbosity + -> FilePath + -> [String] + -> Maybe FilePath + -- ^ New working dir or inherit + -> Maybe [(String, String)] + -- ^ New environment or inherit + -> IO a + -- ^ action to perform after process is created, but before 'waitForProcess'. + -> Maybe Handle + -- ^ stdin + -> Maybe Handle + -- ^ stdout + -> Maybe Handle + -- ^ stderr + -> IO (ExitCode, a) rawSystemIOWithEnvAndAction verbosity path args mcwd menv action inp out err = withFrozenCallStack $ do - let cp = (proc path args) { Process.cwd = mcwd - , Process.env = menv - , Process.std_in = mbToStd inp - , Process.std_out = mbToStd out - , Process.std_err = mbToStd err - } + let cp = + (proc path args) + { Process.cwd = mcwd + , Process.env = menv + , Process.std_in = mbToStd inp + , Process.std_out = mbToStd out + , Process.std_err = mbToStd err + } rawSystemProcAction verbosity cp (\_ _ _ -> action) where mbToStd :: Maybe Handle -> Process.StdStream @@ -866,11 +932,17 @@ rawSystemIOWithEnvAndAction verbosity path args mcwd menv action inp out err = w -- the command's output. Exits if the command exits with error. -- -- Provides control over the binary/text mode of the output. --- rawSystemStdout :: forall mode. KnownIODataMode mode => Verbosity -> FilePath -> [String] -> IO mode rawSystemStdout verbosity path args = withFrozenCallStack $ do - (output, errors, exitCode) <- rawSystemStdInOut verbosity path args - Nothing Nothing Nothing (IOData.iodataMode :: IODataMode mode) + (output, errors, exitCode) <- + rawSystemStdInOut + verbosity + path + args + Nothing + Nothing + Nothing + (IOData.iodataMode :: IODataMode mode) when (exitCode /= ExitSuccess) $ die' verbosity errors return output @@ -882,23 +954,32 @@ rawSystemStdout verbosity path args = withFrozenCallStack $ do -- and command input. -- -- Provides control over the binary/text mode of the input and output. --- -rawSystemStdInOut :: KnownIODataMode mode - => Verbosity - -> FilePath -- ^ Program location - -> [String] -- ^ Arguments - -> Maybe FilePath -- ^ New working dir or inherit - -> Maybe [(String, String)] -- ^ New environment or inherit - -> Maybe IOData -- ^ input text and binary mode - -> IODataMode mode -- ^ iodata mode, acts as proxy - -> IO (mode, String, ExitCode) -- ^ output, errors, exit +rawSystemStdInOut + :: KnownIODataMode mode + => Verbosity + -> FilePath + -- ^ Program location + -> [String] + -- ^ Arguments + -> Maybe FilePath + -- ^ New working dir or inherit + -> Maybe [(String, String)] + -- ^ New environment or inherit + -> Maybe IOData + -- ^ input text and binary mode + -> IODataMode mode + -- ^ iodata mode, acts as proxy + -> IO (mode, String, ExitCode) + -- ^ output, errors, exit rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $ do - let cp = (proc path args) { Process.cwd = mcwd - , Process.env = menv - , Process.std_in = Process.CreatePipe - , Process.std_out = Process.CreatePipe - , Process.std_err = Process.CreatePipe - } + let cp = + (proc path args) + { Process.cwd = mcwd + , Process.env = menv + , Process.std_in = Process.CreatePipe + , Process.std_out = Process.CreatePipe + , Process.std_err = Process.CreatePipe + } (exitcode, (mberr1, mberr2)) <- rawSystemProcAction verbosity cp $ \mb_in mb_out mb_err -> do let (inh, outh, errh) = (fromCreatePipe mb_in, fromCreatePipe mb_out, fromCreatePipe mb_err) @@ -913,7 +994,7 @@ rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $ withAsyncNF (hGetContents errh) $ \errA -> withAsyncNF (IOData.hGetIODataContents outh) $ \outA -> do -- push all the input, if any ignoreSigPipe $ case input of - Nothing -> hClose inh + Nothing -> hClose inh Just inputData -> IOData.hPutContents inh inputData -- wait for both to finish @@ -925,14 +1006,20 @@ rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $ err <- reportOutputIOError mberr2 unless (exitcode == ExitSuccess) $ - debug verbosity $ path ++ " returned " ++ show exitcode - ++ if null err then "" else - " with error message:\n" ++ err - ++ case input of - Nothing -> "" - Just d | IOData.null d -> "" - Just (IODataText inp) -> "\nstdin input:\n" ++ inp - Just (IODataBinary inp) -> "\nstdin input (binary):\n" ++ show inp + debug verbosity $ + path + ++ " returned " + ++ show exitcode + ++ if null err + then "" + else + " with error message:\n" + ++ err + ++ case input of + Nothing -> "" + Just d | IOData.null d -> "" + Just (IODataText inp) -> "\nstdin input:\n" ++ inp + Just (IODataBinary inp) -> "\nstdin input (binary):\n" ++ show inp -- Check if we hit an exception while consuming the output -- (e.g. a text decoding error) @@ -943,40 +1030,46 @@ rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $ reportOutputIOError :: Either Exception.SomeException a -> IO a reportOutputIOError (Right x) = return x reportOutputIOError (Left exc) = case fromException exc of - Just ioe -> throwIO (ioeSetFileName ioe ("output of " ++ path)) - Nothing -> throwIO exc + Just ioe -> throwIO (ioeSetFileName ioe ("output of " ++ path)) + Nothing -> throwIO exc -- | Ignore SIGPIPE in a subcomputation. --- ignoreSigPipe :: IO () -> IO () ignoreSigPipe = Exception.handle $ \case - GHC.IOError { GHC.ioe_type = GHC.ResourceVanished, GHC.ioe_errno = Just ioe } - | Errno ioe == ePIPE -> return () - e -> throwIO e + GHC.IOError{GHC.ioe_type = GHC.ResourceVanished, GHC.ioe_errno = Just ioe} + | Errno ioe == ePIPE -> return () + e -> throwIO e -- | Look for a program and try to find it's version number. It can accept -- either an absolute path or the name of a program binary, in which case we -- will look for the program on the path. --- -findProgramVersion :: String -- ^ version args - -> (String -> String) -- ^ function to select version - -- number from program output - -> Verbosity - -> FilePath -- ^ location - -> IO (Maybe Version) +findProgramVersion + :: String + -- ^ version args + -> (String -> String) + -- ^ function to select version + -- number from program output + -> Verbosity + -> FilePath + -- ^ location + -> IO (Maybe Version) findProgramVersion versionArg selectVersion verbosity path = withFrozenCallStack $ do - str <- rawSystemStdout verbosity path [versionArg] - `catchIO` (\_ -> return "") - `catchExit` (\_ -> return "") + str <- + rawSystemStdout verbosity path [versionArg] + `catchIO` (\_ -> return "") + `catchExit` (\_ -> return "") let version :: Maybe Version version = simpleParsec (selectVersion str) case version of - Nothing -> warn verbosity $ "cannot determine version of " ++ path - ++ " :\n" ++ show str - Just v -> debug verbosity $ path ++ " is version " ++ prettyShow v + Nothing -> + warn verbosity $ + "cannot determine version of " + ++ path + ++ " :\n" + ++ show str + Just v -> debug verbosity $ path ++ " is version " ++ prettyShow v return version - -- | Like the Unix xargs program. Useful for when we've got very long command -- lines that might overflow an OS limit on command line length and so you -- need to invoke a command multiple times to get all the args in. @@ -984,143 +1077,177 @@ findProgramVersion versionArg selectVersion verbosity path = withFrozenCallStack -- Use it with either of the rawSystem variants above. For example: -- -- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs --- -xargs :: Int -> ([String] -> IO ()) - -> [String] -> [String] -> IO () +xargs + :: Int + -> ([String] -> IO ()) + -> [String] + -> [String] + -> IO () xargs maxSize rawSystemFun fixedArgs bigArgs = let fixedArgSize = sum (map length fixedArgs) + length fixedArgs chunkSize = maxSize - fixedArgSize in traverse_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs) - - where chunks len = unfoldr $ \s -> - if null s then Nothing - else Just (chunk [] len s) - - chunk acc _ [] = (reverse acc,[]) - chunk acc len (s:ss) - | len' < len = chunk (s:acc) (len-len'-1) ss - | otherwise = (reverse acc, s:ss) - where len' = length s + where + chunks len = unfoldr $ \s -> + if null s + then Nothing + else Just (chunk [] len s) + + chunk acc _ [] = (reverse acc, []) + chunk acc len (s : ss) + | len' < len = chunk (s : acc) (len - len' - 1) ss + | otherwise = (reverse acc, s : ss) + where + len' = length s -- ------------------------------------------------------------ + -- * File Utilities + -- ------------------------------------------------------------ ---------------- -- Finding files - -- | Find a file by looking in a search path. The file path must match exactly. -- -- @since 3.4.0.0 findFileCwd - :: Verbosity - -> FilePath -- ^ cwd - -> [FilePath] -- ^ relative search location - -> FilePath -- ^ File Name - -> IO FilePath + :: Verbosity + -> FilePath + -- ^ cwd + -> [FilePath] + -- ^ relative search location + -> FilePath + -- ^ File Name + -> IO FilePath findFileCwd verbosity cwd searchPath fileName = - findFirstFile (cwd ) + findFirstFile + (cwd ) [ path fileName - | path <- nub searchPath] - >>= maybe (die' verbosity $ fileName ++ " doesn't exist") return + | path <- nub searchPath + ] + >>= maybe (die' verbosity $ fileName ++ " doesn't exist") return -- | Find a file by looking in a search path. The file path must match exactly. --- -findFileEx :: Verbosity - -> [FilePath] -- ^search locations - -> FilePath -- ^File Name - -> IO FilePath +findFileEx + :: Verbosity + -> [FilePath] + -- ^ search locations + -> FilePath + -- ^ File Name + -> IO FilePath findFileEx verbosity searchPath fileName = - findFirstFile id + findFirstFile + id [ path fileName - | path <- nub searchPath] - >>= maybe (die' verbosity $ fileName ++ " doesn't exist") return + | path <- nub searchPath + ] + >>= maybe (die' verbosity $ fileName ++ " doesn't exist") return -- | Find a file by looking in a search path with one of a list of possible -- file extensions. The file base name should be given and it will be tried -- with each of the extensions in each element of the search path. --- -findFileWithExtension :: [String] - -> [FilePath] - -> FilePath - -> IO (Maybe FilePath) +findFileWithExtension + :: [String] + -> [FilePath] + -> FilePath + -> IO (Maybe FilePath) findFileWithExtension extensions searchPath baseName = - findFirstFile id + findFirstFile + id [ path baseName <.> ext | path <- nub searchPath - , ext <- nub extensions ] + , ext <- nub extensions + ] -- | @since 3.4.0.0 findFileCwdWithExtension - :: FilePath - -> [String] - -> [FilePath] - -> FilePath - -> IO (Maybe FilePath) + :: FilePath + -> [String] + -> [FilePath] + -> FilePath + -> IO (Maybe FilePath) findFileCwdWithExtension cwd extensions searchPath baseName = - findFirstFile (cwd ) + findFirstFile + (cwd ) [ path baseName <.> ext | path <- nub searchPath - , ext <- nub extensions ] + , ext <- nub extensions + ] -- | @since 3.4.0.0 findAllFilesCwdWithExtension - :: FilePath -- ^ cwd - -> [String] -- ^ extensions - -> [FilePath] -- ^ relative search locations - -> FilePath -- ^ basename - -> IO [FilePath] + :: FilePath + -- ^ cwd + -> [String] + -- ^ extensions + -> [FilePath] + -- ^ relative search locations + -> FilePath + -- ^ basename + -> IO [FilePath] findAllFilesCwdWithExtension cwd extensions searchPath basename = - findAllFiles (cwd ) + findAllFiles + (cwd ) [ path basename <.> ext | path <- nub searchPath - , ext <- nub extensions ] - -findAllFilesWithExtension :: [String] - -> [FilePath] - -> FilePath - -> IO [FilePath] + , ext <- nub extensions + ] + +findAllFilesWithExtension + :: [String] + -> [FilePath] + -> FilePath + -> IO [FilePath] findAllFilesWithExtension extensions searchPath basename = - findAllFiles id + findAllFiles + id [ path basename <.> ext | path <- nub searchPath - , ext <- nub extensions ] + , ext <- nub extensions + ] -- | Like 'findFileWithExtension' but returns which element of the search path -- the file was found in, and the file path relative to that base directory. --- -findFileWithExtension' :: [String] - -> [FilePath] - -> FilePath - -> IO (Maybe (FilePath, FilePath)) +findFileWithExtension' + :: [String] + -> [FilePath] + -> FilePath + -> IO (Maybe (FilePath, FilePath)) findFileWithExtension' extensions searchPath baseName = - findFirstFile (uncurry ()) + findFirstFile + (uncurry ()) [ (path, baseName <.> ext) | path <- nub searchPath - , ext <- nub extensions ] + , ext <- nub extensions + ] findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a) findFirstFile file = findFirst - where findFirst [] = return Nothing - findFirst (x:xs) = do exists <- doesFileExist (file x) - if exists - then return (Just x) - else findFirst xs + where + findFirst [] = return Nothing + findFirst (x : xs) = do + exists <- doesFileExist (file x) + if exists + then return (Just x) + else findFirst xs findAllFiles :: (a -> FilePath) -> [a] -> IO [a] findAllFiles file = filterM (doesFileExist . file) - -- | Finds the files corresponding to a list of Haskell module names. -- -- As 'findModuleFile' but for a list of module names. --- -findModuleFilesEx :: Verbosity - -> [FilePath] -- ^ build prefix (location of objects) - -> [String] -- ^ search suffixes - -> [ModuleName] -- ^ modules - -> IO [(FilePath, FilePath)] +findModuleFilesEx + :: Verbosity + -> [FilePath] + -- ^ build prefix (location of objects) + -> [String] + -- ^ search suffixes + -> [ModuleName] + -- ^ modules + -> IO [(FilePath, FilePath)] findModuleFilesEx verbosity searchPath extensions moduleNames = traverse (findModuleFileEx verbosity searchPath extensions) moduleNames @@ -1128,53 +1255,64 @@ findModuleFilesEx verbosity searchPath extensions moduleNames = -- -- This is similar to 'findFileWithExtension'' but specialised to a module -- name. The function fails if the file corresponding to the module is missing. --- -findModuleFileEx :: Verbosity - -> [FilePath] -- ^ build prefix (location of objects) - -> [String] -- ^ search suffixes - -> ModuleName -- ^ module - -> IO (FilePath, FilePath) +findModuleFileEx + :: Verbosity + -> [FilePath] + -- ^ build prefix (location of objects) + -> [String] + -- ^ search suffixes + -> ModuleName + -- ^ module + -> IO (FilePath, FilePath) findModuleFileEx verbosity searchPath extensions mod_name = - maybe notFound return - =<< findFileWithExtension' extensions searchPath - (ModuleName.toFilePath mod_name) + maybe notFound return + =<< findFileWithExtension' + extensions + searchPath + (ModuleName.toFilePath mod_name) where - notFound = die' verbosity $ - "Could not find module: " ++ prettyShow mod_name - ++ " with any suffix: " ++ show extensions - ++ " in the search path: " ++ show searchPath + notFound = + die' verbosity $ + "Could not find module: " + ++ prettyShow mod_name + ++ " with any suffix: " + ++ show extensions + ++ " in the search path: " + ++ show searchPath -- | List all the files in a directory and all subdirectories. -- -- The order places files in sub-directories after all the files in their -- parent directories. The list is generated lazily so is not well defined if -- the source directory structure changes before the list is used. --- getDirectoryContentsRecursive :: FilePath -> IO [FilePath] getDirectoryContentsRecursive topdir = recurseDirectories [""] where recurseDirectories :: [FilePath] -> IO [FilePath] - recurseDirectories [] = return [] - recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do + recurseDirectories [] = return [] + recurseDirectories (dir : dirs) = unsafeInterleaveIO $ do (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir dir) files' <- recurseDirectories (dirs' ++ dirs) return (files ++ files') - where - collect files dirs' [] = return (reverse files - ,reverse dirs') - collect files dirs' (entry:entries) | ignore entry - = collect files dirs' entries - collect files dirs' (entry:entries) = do + collect files dirs' [] = + return + ( reverse files + , reverse dirs' + ) + collect files dirs' (entry : entries) + | ignore entry = + collect files dirs' entries + collect files dirs' (entry : entries) = do let dirEntry = dir entry isDirectory <- doesDirectoryExist (topdir dirEntry) if isDirectory - then collect files (dirEntry:dirs') entries - else collect (dirEntry:files) dirs' entries + then collect files (dirEntry : dirs') entries + else collect (dirEntry : files) dirs' entries - ignore ['.'] = True + ignore ['.'] = True ignore ['.', '.'] = True - ignore _ = False + ignore _ = False ------------------------ -- Environment variables @@ -1183,24 +1321,25 @@ getDirectoryContentsRecursive topdir = recurseDirectories [""] isInSearchPath :: FilePath -> IO Bool isInSearchPath path = fmap (elem path) getSearchPath -addLibraryPath :: OS - -> [FilePath] - -> [(String,String)] - -> [(String,String)] +addLibraryPath + :: OS + -> [FilePath] + -> [(String, String)] + -> [(String, String)] addLibraryPath os paths = addEnv where pathsString = intercalate [searchPathSeparator] paths ldPath = case os of - OSX -> "DYLD_LIBRARY_PATH" - _ -> "LD_LIBRARY_PATH" + OSX -> "DYLD_LIBRARY_PATH" + _ -> "LD_LIBRARY_PATH" - addEnv [] = [(ldPath,pathsString)] - addEnv ((key,value):xs) + addEnv [] = [(ldPath, pathsString)] + addEnv ((key, value) : xs) | key == ldPath = if null value - then (key,pathsString):xs - else (key,value ++ (searchPathSeparator:pathsString)):xs - | otherwise = (key,value):addEnv xs + then (key, pathsString) : xs + else (key, value ++ (searchPathSeparator : pathsString)) : xs + | otherwise = (key, value) : addEnv xs -------------------- -- Modification time @@ -1209,15 +1348,15 @@ addLibraryPath os paths = addEnv -- than the second. The first file must exist but the second need not. -- The expected use case is when the second file is generated using the first. -- In this use case, if the result is True then the second file is out of date. --- moreRecentFile :: FilePath -> FilePath -> IO Bool moreRecentFile a b = do exists <- doesFileExist b if not exists then return True - else do tb <- getModificationTime b - ta <- getModificationTime a - return (ta > tb) + else do + tb <- getModificationTime b + ta <- getModificationTime a + return (ta > tb) -- | Like 'moreRecentFile', but also checks that the first file exists. existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool @@ -1231,20 +1370,21 @@ existsAndIsMoreRecentThan a b = do -- Copying and installing files and dirs -- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels. --- -createDirectoryIfMissingVerbose :: Verbosity - -> Bool -- ^ Create its parents too? - -> FilePath - -> IO () +createDirectoryIfMissingVerbose + :: Verbosity + -> Bool + -- ^ Create its parents too? + -> FilePath + -> IO () createDirectoryIfMissingVerbose verbosity create_parents path0 | create_parents = withFrozenCallStack $ createDirs (parents path0) - | otherwise = withFrozenCallStack $ createDirs (take 1 (parents path0)) + | otherwise = withFrozenCallStack $ createDirs (take 1 (parents path0)) where parents = reverse . scanl1 () . splitDirectories . normalise - createDirs [] = return () - createDirs (dir:[]) = createDir dir throwIO - createDirs (dir:dirs) = + createDirs [] = return () + createDirs (dir : []) = createDir dir throwIO + createDirs (dir : dirs) = createDir dir $ \_ -> do createDirs dirs createDir dir throwIO @@ -1253,9 +1393,9 @@ createDirectoryIfMissingVerbose verbosity create_parents path0 createDir dir notExistHandler = do r <- tryIO $ createDirectoryVerbose verbosity dir case (r :: Either IOException ()) of - Right () -> return () - Left e - | isDoesNotExistError e -> notExistHandler e + Right () -> return () + Left e + | isDoesNotExistError e -> notExistHandler e -- createDirectory (and indeed POSIX mkdir) does not distinguish -- between a dir already existing and a file already existing. So we -- check for it here. Unfortunately there is a slight race condition @@ -1263,11 +1403,13 @@ createDirectoryIfMissingVerbose verbosity create_parents path0 -- the case that the dir did exist but another process deletes the -- directory and creates a file in its place before we can check -- that the directory did indeed exist. - | isAlreadyExistsError e -> (do - isDir <- doesDirectoryExist dir - unless isDir $ throwIO e - ) `catchIO` ((\_ -> return ()) :: IOException -> IO ()) - | otherwise -> throwIO e + | isAlreadyExistsError e -> + ( do + isDir <- doesDirectoryExist dir + unless isDir $ throwIO e + ) + `catchIO` ((\_ -> return ()) :: IOException -> IO ()) + | otherwise -> throwIO e createDirectoryVerbose :: Verbosity -> FilePath -> IO () createDirectoryVerbose verbosity dir = withFrozenCallStack $ do @@ -1279,7 +1421,6 @@ createDirectoryVerbose verbosity dir = withFrozenCallStack $ do -- with default permissions. Any existing target file is replaced. -- -- At higher verbosity levels it logs an info message. --- copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO () copyFileVerbose verbosity src dest = withFrozenCallStack $ do info verbosity ("copy " ++ src ++ " to " ++ dest) @@ -1288,7 +1429,6 @@ copyFileVerbose verbosity src dest = withFrozenCallStack $ do -- | Install an ordinary file. This is like a file copy but the permissions -- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\" -- while on Windows it uses the default permissions for the target directory. --- installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO () installOrdinaryFile verbosity src dest = withFrozenCallStack $ do info verbosity ("Installing " ++ src ++ " to " ++ dest) @@ -1297,7 +1437,6 @@ installOrdinaryFile verbosity src dest = withFrozenCallStack $ do -- | Install an executable file. This is like a file copy but the permissions -- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\" -- while on Windows it uses the default permissions for the target directory. --- installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () installExecutableFile verbosity src dest = withFrozenCallStack $ do info verbosity ("Installing executable " ++ src ++ " to " ++ dest) @@ -1307,9 +1446,9 @@ installExecutableFile verbosity src dest = withFrozenCallStack $ do installMaybeExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () installMaybeExecutableFile verbosity src dest = withFrozenCallStack $ do perms <- getPermissions src - if (executable perms) --only checks user x bit + if (executable perms) -- only checks user x bit then installExecutableFile verbosity src dest - else installOrdinaryFile verbosity src dest + else installOrdinaryFile verbosity src dest -- | Given a relative path to a file, copy it to the given directory, preserving -- the relative path and creating the parent directories if needed. @@ -1321,19 +1460,24 @@ copyFileTo verbosity dir file = withFrozenCallStack $ do -- | Common implementation of 'copyFiles', 'installOrdinaryFiles', -- 'installExecutableFiles' and 'installMaybeExecutableFiles'. -copyFilesWith :: (Verbosity -> FilePath -> FilePath -> IO ()) - -> Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () +copyFilesWith + :: (Verbosity -> FilePath -> FilePath -> IO ()) + -> Verbosity + -> FilePath + -> [(FilePath, FilePath)] + -> IO () copyFilesWith doCopy verbosity targetDir srcFiles = withFrozenCallStack $ do - -- Create parent directories for everything let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles traverse_ (createDirectoryIfMissingVerbose verbosity True) dirs -- Copy all the files - sequence_ [ let src = srcBase srcFile - dest = targetDir srcFile - in doCopy verbosity src dest - | (srcBase, srcFile) <- srcFiles ] + sequence_ + [ let src = srcBase srcFile + dest = targetDir srcFile + in doCopy verbosity src dest + | (srcBase, srcFile) <- srcFiles + ] -- | Copies a bunch of files to a target directory, preserving the directory -- structure in the target location. The target directories are created if they @@ -1355,44 +1499,50 @@ copyFilesWith doCopy verbosity targetDir srcFiles = withFrozenCallStack $ do -- missing source files) leaves the target in an unknown state so it is best to -- use it with a freshly created directory so that it can be simply deleted if -- anything goes wrong. --- copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () copyFiles v fp fs = withFrozenCallStack (copyFilesWith copyFileVerbose v fp fs) -- | This is like 'copyFiles' but uses 'installOrdinaryFile'. --- installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () installOrdinaryFiles v fp fs = withFrozenCallStack (copyFilesWith installOrdinaryFile v fp fs) -- | This is like 'copyFiles' but uses 'installExecutableFile'. --- -installExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] - -> IO () +installExecutableFiles + :: Verbosity + -> FilePath + -> [(FilePath, FilePath)] + -> IO () installExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installExecutableFile v fp fs) -- | This is like 'copyFiles' but uses 'installMaybeExecutableFile'. --- -installMaybeExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] - -> IO () +installMaybeExecutableFiles + :: Verbosity + -> FilePath + -> [(FilePath, FilePath)] + -> IO () installMaybeExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installMaybeExecutableFile v fp fs) -- | This installs all the files in a directory to a target location, -- preserving the directory layout. All the files are assumed to be ordinary -- rather than executable files. --- installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO () installDirectoryContents verbosity srcDir destDir = withFrozenCallStack $ do info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") srcFiles <- getDirectoryContentsRecursive srcDir - installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] + installOrdinaryFiles verbosity destDir [(srcDir, f) | f <- srcFiles] -- | Recursively copy the contents of one directory to another path. copyDirectoryRecursive :: Verbosity -> FilePath -> FilePath -> IO () copyDirectoryRecursive verbosity srcDir destDir = withFrozenCallStack $ do info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") srcFiles <- getDirectoryContentsRecursive srcDir - copyFilesWith (const copyFile) verbosity destDir [ (srcDir, f) - | f <- srcFiles ] + copyFilesWith + (const copyFile) + verbosity + destDir + [ (srcDir, f) + | f <- srcFiles + ] ------------------- -- File permissions @@ -1402,41 +1552,53 @@ doesExecutableExist :: FilePath -> IO Bool doesExecutableExist f = do exists <- doesFileExist f if exists - then do perms <- getPermissions f - return (executable perms) + then do + perms <- getPermissions f + return (executable perms) else return False --------------------------- -- Temporary files and dirs -- | Advanced options for 'withTempFile' and 'withTempDirectory'. -data TempFileOptions = TempFileOptions { - optKeepTempFiles :: Bool -- ^ Keep temporary files? +data TempFileOptions = TempFileOptions + { optKeepTempFiles :: Bool + -- ^ Keep temporary files? } defaultTempFileOptions :: TempFileOptions -defaultTempFileOptions = TempFileOptions { optKeepTempFiles = False } +defaultTempFileOptions = TempFileOptions{optKeepTempFiles = False} -- | Use a temporary filename that doesn't already exist. --- -withTempFile :: FilePath -- ^ Temp dir to create the file in - -> String -- ^ File name template. See 'openTempFile'. - -> (FilePath -> Handle -> IO a) -> IO a +withTempFile + :: FilePath + -- ^ Temp dir to create the file in + -> String + -- ^ File name template. See 'openTempFile'. + -> (FilePath -> Handle -> IO a) + -> IO a withTempFile tmpDir template action = withTempFileEx defaultTempFileOptions tmpDir template action -- | A version of 'withTempFile' that additionally takes a 'TempFileOptions' -- argument. -withTempFileEx :: TempFileOptions - -> FilePath -- ^ Temp dir to create the file in - -> String -- ^ File name template. See 'openTempFile'. - -> (FilePath -> Handle -> IO a) -> IO a +withTempFileEx + :: TempFileOptions + -> FilePath + -- ^ Temp dir to create the file in + -> String + -- ^ File name template. See 'openTempFile'. + -> (FilePath -> Handle -> IO a) + -> IO a withTempFileEx opts tmpDir template action = Exception.bracket (openTempFile tmpDir template) - (\(name, handle) -> do hClose handle - unless (optKeepTempFiles opts) $ - handleDoesNotExist () . removeFile $ name) + ( \(name, handle) -> do + hClose handle + unless (optKeepTempFiles opts) $ + handleDoesNotExist () . removeFile $ + name + ) (withLexicalCallStack (\x -> uncurry action x)) -- | Create and use a temporary directory. @@ -1448,22 +1610,34 @@ withTempFileEx opts tmpDir template action = -- -- The @tmpDir@ will be a new subdirectory of the given directory, e.g. -- @src/sdist.342@. --- withTempDirectory :: Verbosity -> FilePath -> String -> (FilePath -> IO a) -> IO a -withTempDirectory verbosity targetDir template f = withFrozenCallStack $ - withTempDirectoryEx verbosity defaultTempFileOptions targetDir template - (withLexicalCallStack (\x -> f x)) +withTempDirectory verbosity targetDir template f = + withFrozenCallStack $ + withTempDirectoryEx + verbosity + defaultTempFileOptions + targetDir + template + (withLexicalCallStack (\x -> f x)) -- | A version of 'withTempDirectory' that additionally takes a -- 'TempFileOptions' argument. -withTempDirectoryEx :: Verbosity -> TempFileOptions - -> FilePath -> String -> (FilePath -> IO a) -> IO a -withTempDirectoryEx _verbosity opts targetDir template f = withFrozenCallStack $ - Exception.bracket - (createTempDirectory targetDir template) - (unless (optKeepTempFiles opts) - . handleDoesNotExist () . removeDirectoryRecursive) - (withLexicalCallStack (\x -> f x)) +withTempDirectoryEx + :: Verbosity + -> TempFileOptions + -> FilePath + -> String + -> (FilePath -> IO a) + -> IO a +withTempDirectoryEx _verbosity opts targetDir template f = + withFrozenCallStack $ + Exception.bracket + (createTempDirectory targetDir template) + ( unless (optKeepTempFiles opts) + . handleDoesNotExist () + . removeDirectoryRecursive + ) + (withLexicalCallStack (\x -> f x)) ----------------------------------- -- Safely reading and writing files @@ -1489,11 +1663,11 @@ rewriteFileLBS verbosity path newContent = annotateIO verbosity $ writeFileAtomic path newContent where - mightNotExist e | isDoesNotExistError e - = annotateIO verbosity $ writeFileAtomic path newContent - | otherwise - = ioError e - + mightNotExist e + | isDoesNotExistError e = + annotateIO verbosity $ writeFileAtomic path newContent + | otherwise = + ioError e -- | The path name that represents the current directory. -- In Unix, it's @\".\"@, but this is system-specific. @@ -1503,13 +1677,13 @@ currentDir = "." shortRelativePath :: FilePath -> FilePath -> FilePath shortRelativePath from to = - case dropCommonPrefix (splitDirectories from) (splitDirectories to) of - (stuff, path) -> joinPath (map (const "..") stuff ++ path) + case dropCommonPrefix (splitDirectories from) (splitDirectories to) of + (stuff, path) -> joinPath (map (const "..") stuff ++ path) where - dropCommonPrefix :: Eq a => [a] -> [a] -> ([a],[a]) - dropCommonPrefix (x:xs) (y:ys) - | x == y = dropCommonPrefix xs ys - dropCommonPrefix xs ys = (xs,ys) + dropCommonPrefix :: Eq a => [a] -> [a] -> ([a], [a]) + dropCommonPrefix (x : xs) (y : ys) + | x == y = dropCommonPrefix xs ys + dropCommonPrefix xs ys = (xs, ys) -- | Drop the extension if it's one of 'exeExtensions', or return the path -- unchanged. @@ -1527,10 +1701,10 @@ dropExeExtension filepath = -- -- Since by "" in exeExtensions we mean 'no extension' anyways we can -- just always ignore it here. - let exts = [ ext | ext <- exeExtensions, ext /= "" ] in - fromMaybe filepath $ do - ext <- find (`FilePath.isExtensionOf` filepath) exts - ext `FilePath.stripExtension` filepath + let exts = [ext | ext <- exeExtensions, ext /= ""] + in fromMaybe filepath $ do + ext <- find (`FilePath.isExtensionOf` filepath) exts + ext `FilePath.stripExtension` filepath -- | List of possible executable file extensions on the current build -- platform. @@ -1540,54 +1714,67 @@ exeExtensions = case (buildArch, buildOS) of -- PATHEXT environment variable. By default PATHEXT is ".com; .exe; .bat; -- .cmd". (_, Windows) -> ["", "exe"] - (_, Ghcjs) -> ["", "exe"] - (Wasm32, _) -> ["", "wasm"] - _ -> [""] + (_, Ghcjs) -> ["", "exe"] + (Wasm32, _) -> ["", "wasm"] + _ -> [""] -- ------------------------------------------------------------ + -- * Finding the description file + -- ------------------------------------------------------------ -- | Package description file (/pkgname/@.cabal@) defaultPackageDesc :: Verbosity -> IO FilePath defaultPackageDesc verbosity = tryFindPackageDesc verbosity currentDir --- |Find a package description file in the given directory. Looks for --- @.cabal@ files. -findPackageDesc :: FilePath -- ^Where to look - -> IO (Either String FilePath) -- ^.cabal +-- | Find a package description file in the given directory. Looks for +-- @.cabal@ files. +findPackageDesc + :: FilePath + -- ^ Where to look + -> IO (Either String FilePath) + -- ^ .cabal findPackageDesc = findPackageDescCwd "." -- | @since 3.4.0.0 findPackageDescCwd - :: FilePath -- ^ project root - -> FilePath -- ^ relative directory - -> IO (Either String FilePath) -- ^ .cabal relative to the project root -findPackageDescCwd cwd dir - = do files <- getDirectoryContents (cwd dir) - -- to make sure we do not mistake a ~/.cabal/ dir for a .cabal - -- file we filter to exclude dirs and null base file names: - cabalFiles <- filterM (doesFileExist . snd) - [ (dir file, cwd dir file) - | file <- files - , let (name, ext) = splitExtension file - , not (null name) && ext == ".cabal" ] - case map fst cabalFiles of - [] -> return (Left noDesc) - [cabalFile] -> return (Right cabalFile) - multiple -> return (Left $ multiDesc multiple) - + :: FilePath + -- ^ project root + -> FilePath + -- ^ relative directory + -> IO (Either String FilePath) + -- ^ .cabal relative to the project root +findPackageDescCwd cwd dir = + do + files <- getDirectoryContents (cwd dir) + -- to make sure we do not mistake a ~/.cabal/ dir for a .cabal + -- file we filter to exclude dirs and null base file names: + cabalFiles <- + filterM + (doesFileExist . snd) + [ (dir file, cwd dir file) + | file <- files + , let (name, ext) = splitExtension file + , not (null name) && ext == ".cabal" + ] + case map fst cabalFiles of + [] -> return (Left noDesc) + [cabalFile] -> return (Right cabalFile) + multiple -> return (Left $ multiDesc multiple) where noDesc :: String - noDesc = "No cabal file found.\n" - ++ "Please create a package description file .cabal" + noDesc = + "No cabal file found.\n" + ++ "Please create a package description file .cabal" multiDesc :: [String] -> String - multiDesc l = "Multiple cabal files found.\n" - ++ "Please use only one of: " - ++ intercalate ", " l + multiDesc l = + "Multiple cabal files found.\n" + ++ "Please use only one of: " + ++ intercalate ", " l --- |Like 'findPackageDesc', but calls 'die' in case of error. +-- | Like 'findPackageDesc', but calls 'die' in case of error. tryFindPackageDesc :: Verbosity -> FilePath -> IO FilePath tryFindPackageDesc verbosity dir = either (die' verbosity) return =<< findPackageDesc dir @@ -1599,23 +1786,28 @@ tryFindPackageDescCwd :: Verbosity -> FilePath -> FilePath -> IO FilePath tryFindPackageDescCwd verbosity cwd dir = either (die' verbosity) return =<< findPackageDescCwd cwd dir --- |Find auxiliary package information in the given directory. --- Looks for @.buildinfo@ files. +-- | Find auxiliary package information in the given directory. +-- Looks for @.buildinfo@ files. findHookedPackageDesc - :: Verbosity - -> FilePath -- ^Directory to search - -> IO (Maybe FilePath) -- ^/dir/@\/@/pkgname/@.buildinfo@, if present + :: Verbosity + -> FilePath + -- ^ Directory to search + -> IO (Maybe FilePath) + -- ^ /dir/@\/@/pkgname/@.buildinfo@, if present findHookedPackageDesc verbosity dir = do - files <- getDirectoryContents dir - buildInfoFiles <- filterM doesFileExist - [ dir file - | file <- files - , let (name, ext) = splitExtension file - , not (null name) && ext == buildInfoExt ] - case buildInfoFiles of - [] -> return Nothing - [f] -> return (Just f) - _ -> die' verbosity ("Multiple files with extension " ++ buildInfoExt) - -buildInfoExt :: String + files <- getDirectoryContents dir + buildInfoFiles <- + filterM + doesFileExist + [ dir file + | file <- files + , let (name, ext) = splitExtension file + , not (null name) && ext == buildInfoExt + ] + case buildInfoFiles of + [] -> return Nothing + [f] -> return (Just f) + _ -> die' verbosity ("Multiple files with extension " ++ buildInfoExt) + +buildInfoExt :: String buildInfoExt = ".buildinfo" diff --git a/Cabal/src/Distribution/TestSuite.hs b/Cabal/src/Distribution/TestSuite.hs index 7276bfa2c39..5e6fa42dac2 100644 --- a/Cabal/src/Distribution/TestSuite.hs +++ b/Cabal/src/Distribution/TestSuite.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.TestSuite -- Copyright : Thomas Tuegel 2010 @@ -12,91 +13,97 @@ -- -- This module defines the detailed test suite interface which makes it -- possible to expose individual tests to Cabal or other test agents. - module Distribution.TestSuite - ( TestInstance(..) - , OptionDescr(..) - , OptionType(..) - , Test(..) - , Options - , Progress(..) - , Result(..) - , testGroup - ) where + ( TestInstance (..) + , OptionDescr (..) + , OptionType (..) + , Test (..) + , Options + , Progress (..) + , Result (..) + , testGroup + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () data TestInstance = TestInstance - { run :: IO Progress -- ^ Perform the test. - , name :: String -- ^ A name for the test, unique within a - -- test suite. - , tags :: [String] -- ^ Users can select groups of tests by - -- their tags. - , options :: [OptionDescr] -- ^ Descriptions of the options recognized - -- by this test. - , setOption :: String -> String -> Either String TestInstance - -- ^ Try to set the named option to the given value. Returns an error - -- message if the option is not supported or the value could not be - -- correctly parsed; otherwise, a 'TestInstance' with the option set to - -- the given value is returned. - } + { run :: IO Progress + -- ^ Perform the test. + , name :: String + -- ^ A name for the test, unique within a + -- test suite. + , tags :: [String] + -- ^ Users can select groups of tests by + -- their tags. + , options :: [OptionDescr] + -- ^ Descriptions of the options recognized + -- by this test. + , setOption :: String -> String -> Either String TestInstance + -- ^ Try to set the named option to the given value. Returns an error + -- message if the option is not supported or the value could not be + -- correctly parsed; otherwise, a 'TestInstance' with the option set to + -- the given value is returned. + } data OptionDescr = OptionDescr - { optionName :: String - , optionDescription :: String -- ^ A human-readable description of the - -- option to guide the user setting it. - , optionType :: OptionType - , optionDefault :: Maybe String - } + { optionName :: String + , optionDescription :: String + -- ^ A human-readable description of the + -- option to guide the user setting it. + , optionType :: OptionType + , optionDefault :: Maybe String + } deriving (Eq, Read, Show) data OptionType - = OptionFile - { optionFileMustExist :: Bool - , optionFileIsDir :: Bool - , optionFileExtensions :: [String] - } - | OptionString - { optionStringMultiline :: Bool - } - | OptionNumber - { optionNumberIsInt :: Bool - , optionNumberBounds :: (Maybe String, Maybe String) - } - | OptionBool - | OptionEnum [String] - | OptionSet [String] - | OptionRngSeed + = OptionFile + { optionFileMustExist :: Bool + , optionFileIsDir :: Bool + , optionFileExtensions :: [String] + } + | OptionString + { optionStringMultiline :: Bool + } + | OptionNumber + { optionNumberIsInt :: Bool + , optionNumberBounds :: (Maybe String, Maybe String) + } + | OptionBool + | OptionEnum [String] + | OptionSet [String] + | OptionRngSeed deriving (Eq, Read, Show) data Test - = Test TestInstance - | Group - { groupName :: String - , concurrently :: Bool - -- ^ If true, then children of this group may be run in parallel. - -- Note that this setting is not inherited by children. In - -- particular, consider a group F with "concurrently = False" that - -- has some children, including a group T with "concurrently = - -- True". The children of group T may be run concurrently with each - -- other, as long as none are run at the same time as any of the - -- direct children of group F. - , groupTests :: [Test] - } - | ExtraOptions [OptionDescr] Test + = Test TestInstance + | Group + { groupName :: String + , concurrently :: Bool + -- ^ If true, then children of this group may be run in parallel. + -- Note that this setting is not inherited by children. In + -- particular, consider a group F with "concurrently = False" that + -- has some children, including a group T with "concurrently = + -- True". The children of group T may be run concurrently with each + -- other, as long as none are run at the same time as any of the + -- direct children of group F. + , groupTests :: [Test] + } + | ExtraOptions [OptionDescr] Test type Options = [(String, String)] -data Progress = Finished Result - | Progress String (IO Progress) +data Progress + = Finished Result + | Progress String (IO Progress) -data Result = Pass - | Fail String - | Error String +data Result + = Pass + | Fail String + | Error String deriving (Eq, Read, Show) -- | Create a named group of tests, which are assumed to be safe to run in -- parallel. testGroup :: String -> [Test] -> Test -testGroup n ts = Group { groupName = n, concurrently = True, groupTests = ts } +testGroup n ts = Group{groupName = n, concurrently = True, groupTests = ts} diff --git a/Cabal/src/Distribution/Types/AnnotatedId.hs b/Cabal/src/Distribution/Types/AnnotatedId.hs index 49a3c0f4039..a273fadde34 100644 --- a/Cabal/src/Distribution/Types/AnnotatedId.hs +++ b/Cabal/src/Distribution/Types/AnnotatedId.hs @@ -1,9 +1,9 @@ -module Distribution.Types.AnnotatedId ( - AnnotatedId(..) -) where +module Distribution.Types.AnnotatedId + ( AnnotatedId (..) + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Package import Distribution.Types.ComponentName @@ -14,21 +14,21 @@ import Distribution.Types.ComponentName -- -- Invariant: if ann_id x == ann_id y, then ann_pid x == ann_pid y -- and ann_cname x == ann_cname y -data AnnotatedId id = AnnotatedId { - ann_pid :: PackageId, - ann_cname :: ComponentName, - ann_id :: id - } - deriving (Show) +data AnnotatedId id = AnnotatedId + { ann_pid :: PackageId + , ann_cname :: ComponentName + , ann_id :: id + } + deriving (Show) instance Eq id => Eq (AnnotatedId id) where - x == y = ann_id x == ann_id y + x == y = ann_id x == ann_id y instance Ord id => Ord (AnnotatedId id) where - compare x y = compare (ann_id x) (ann_id y) + compare x y = compare (ann_id x) (ann_id y) instance Package (AnnotatedId id) where - packageId = ann_pid + packageId = ann_pid instance Functor AnnotatedId where - fmap f (AnnotatedId pid cn x) = AnnotatedId pid cn (f x) + fmap f (AnnotatedId pid cn x) = AnnotatedId pid cn (f x) diff --git a/Cabal/src/Distribution/Types/ComponentInclude.hs b/Cabal/src/Distribution/Types/ComponentInclude.hs index f60f696808f..6999b6544d7 100644 --- a/Cabal/src/Distribution/Types/ComponentInclude.hs +++ b/Cabal/src/Distribution/Types/ComponentInclude.hs @@ -1,25 +1,25 @@ -module Distribution.Types.ComponentInclude ( - ComponentInclude(..), - ci_id, - ci_pkgid, - ci_cname -) where +module Distribution.Types.ComponentInclude + ( ComponentInclude (..) + , ci_id + , ci_pkgid + , ci_cname + ) where -import Distribution.Types.PackageId -import Distribution.Types.ComponentName import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentName +import Distribution.Types.PackageId -- Once ci_id is refined to an 'OpenUnitId' or 'DefUnitId', -- the 'includeRequiresRn' is not so useful (because it -- includes the requirements renaming that is no longer -- needed); use 'ci_prov_renaming' instead. -data ComponentInclude id rn = ComponentInclude { - ci_ann_id :: AnnotatedId id, - ci_renaming :: rn, - -- | Did this come from an entry in @mixins@, or - -- was implicitly generated by @build-depends@? - ci_implicit :: Bool - } +data ComponentInclude id rn = ComponentInclude + { ci_ann_id :: AnnotatedId id + , ci_renaming :: rn + , ci_implicit :: Bool + -- ^ Did this come from an entry in @mixins@, or + -- was implicitly generated by @build-depends@? + } ci_id :: ComponentInclude id rn -> id ci_id = ann_id . ci_ann_id diff --git a/Cabal/src/Distribution/Types/ComponentLocalBuildInfo.hs b/Cabal/src/Distribution/Types/ComponentLocalBuildInfo.hs index 02aa6551152..0728656620e 100644 --- a/Cabal/src/Distribution/Types/ComponentLocalBuildInfo.hs +++ b/Cabal/src/Distribution/Types/ComponentLocalBuildInfo.hs @@ -2,128 +2,127 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} -module Distribution.Types.ComponentLocalBuildInfo ( - ComponentLocalBuildInfo(..), - componentIsIndefinite, - maybeComponentInstantiatedWith, +module Distribution.Types.ComponentLocalBuildInfo + ( ComponentLocalBuildInfo (..) + , componentIsIndefinite + , maybeComponentInstantiatedWith ) where -import Prelude () import Distribution.Compat.Prelude import Distribution.ModuleName +import Prelude () import Distribution.Backpack import Distribution.Compat.Graph import Distribution.Types.ComponentId -import Distribution.Types.MungedPackageId -import Distribution.Types.UnitId import Distribution.Types.ComponentName -import Distribution.Types.MungedPackageName import Distribution.Types.ModuleRenaming +import Distribution.Types.MungedPackageId +import Distribution.Types.MungedPackageName +import Distribution.Types.UnitId import qualified Distribution.InstalledPackageInfo as Installed -- | The first five fields are common across all algebraic variants. data ComponentLocalBuildInfo - = LibComponentLocalBuildInfo { - -- | It would be very convenient to store the literal Library here, - -- but if we do that, it will get serialized (via the Binary) - -- instance twice. So instead we just provide the ComponentName, - -- which can be used to find the Component in the - -- PackageDescription. NB: eventually, this will NOT uniquely - -- identify the ComponentLocalBuildInfo. - componentLocalName :: ComponentName, - -- | The computed 'ComponentId' of this component. - componentComponentId :: ComponentId, - -- | The computed 'UnitId' which uniquely identifies this - -- component. Might be hashed. - componentUnitId :: UnitId, - -- | Is this an indefinite component (i.e. has unfilled holes)? - componentIsIndefinite_ :: Bool, - -- | How the component was instantiated - componentInstantiatedWith :: [(ModuleName, OpenModule)], - -- | Resolved internal and external package dependencies for this component. - -- The 'BuildInfo' specifies a set of build dependencies that must be - -- satisfied in terms of version ranges. This field fixes those dependencies - -- to the specific versions available on this machine for this compiler. - componentPackageDeps :: [(UnitId, MungedPackageId)], - -- | The set of packages that are brought into scope during - -- compilation, including a 'ModuleRenaming' which may used - -- to hide or rename modules. This is what gets translated into - -- @-package-id@ arguments. This is a modernized version of - -- 'componentPackageDeps', which is kept around for BC purposes. - componentIncludes :: [(OpenUnitId, ModuleRenaming)], - componentExeDeps :: [UnitId], - -- | The internal dependencies which induce a graph on the - -- 'ComponentLocalBuildInfo' of this package. This does NOT - -- coincide with 'componentPackageDeps' because it ALSO records - -- 'build-tool' dependencies on executables. Maybe one day - -- @cabal-install@ will also handle these correctly too! - componentInternalDeps :: [UnitId], - -- | Compatibility "package key" that we pass to older versions of GHC. - componentCompatPackageKey :: String, - -- | Compatibility "package name" that we register this component as. - componentCompatPackageName :: MungedPackageName, - -- | A list of exposed modules (either defined in this component, - -- or reexported from another component.) - componentExposedModules :: [Installed.ExposedModule], - -- | Convenience field, specifying whether or not this is the - -- "public library" that has the same name as the package. - componentIsPublic :: Bool - } - -- TODO: refactor all these duplicates - | FLibComponentLocalBuildInfo { - componentLocalName :: ComponentName, - componentComponentId :: ComponentId, - componentUnitId :: UnitId, - componentPackageDeps :: [(UnitId, MungedPackageId)], - componentIncludes :: [(OpenUnitId, ModuleRenaming)], - componentExeDeps :: [UnitId], - componentInternalDeps :: [UnitId] - } - | ExeComponentLocalBuildInfo { - componentLocalName :: ComponentName, - componentComponentId :: ComponentId, - componentUnitId :: UnitId, - componentPackageDeps :: [(UnitId, MungedPackageId)], - componentIncludes :: [(OpenUnitId, ModuleRenaming)], - componentExeDeps :: [UnitId], - componentInternalDeps :: [UnitId] - } - | TestComponentLocalBuildInfo { - componentLocalName :: ComponentName, - componentComponentId :: ComponentId, - componentUnitId :: UnitId, - componentPackageDeps :: [(UnitId, MungedPackageId)], - componentIncludes :: [(OpenUnitId, ModuleRenaming)], - componentExeDeps :: [UnitId], - componentInternalDeps :: [UnitId] - - } - | BenchComponentLocalBuildInfo { - componentLocalName :: ComponentName, - componentComponentId :: ComponentId, - componentUnitId :: UnitId, - componentPackageDeps :: [(UnitId, MungedPackageId)], - componentIncludes :: [(OpenUnitId, ModuleRenaming)], - componentExeDeps :: [UnitId], - componentInternalDeps :: [UnitId] - } + = LibComponentLocalBuildInfo + { componentLocalName :: ComponentName + -- ^ It would be very convenient to store the literal Library here, + -- but if we do that, it will get serialized (via the Binary) + -- instance twice. So instead we just provide the ComponentName, + -- which can be used to find the Component in the + -- PackageDescription. NB: eventually, this will NOT uniquely + -- identify the ComponentLocalBuildInfo. + , componentComponentId :: ComponentId + -- ^ The computed 'ComponentId' of this component. + , componentUnitId :: UnitId + -- ^ The computed 'UnitId' which uniquely identifies this + -- component. Might be hashed. + , componentIsIndefinite_ :: Bool + -- ^ Is this an indefinite component (i.e. has unfilled holes)? + , componentInstantiatedWith :: [(ModuleName, OpenModule)] + -- ^ How the component was instantiated + , componentPackageDeps :: [(UnitId, MungedPackageId)] + -- ^ Resolved internal and external package dependencies for this component. + -- The 'BuildInfo' specifies a set of build dependencies that must be + -- satisfied in terms of version ranges. This field fixes those dependencies + -- to the specific versions available on this machine for this compiler. + , componentIncludes :: [(OpenUnitId, ModuleRenaming)] + -- ^ The set of packages that are brought into scope during + -- compilation, including a 'ModuleRenaming' which may used + -- to hide or rename modules. This is what gets translated into + -- @-package-id@ arguments. This is a modernized version of + -- 'componentPackageDeps', which is kept around for BC purposes. + , componentExeDeps :: [UnitId] + , componentInternalDeps :: [UnitId] + -- ^ The internal dependencies which induce a graph on the + -- 'ComponentLocalBuildInfo' of this package. This does NOT + -- coincide with 'componentPackageDeps' because it ALSO records + -- 'build-tool' dependencies on executables. Maybe one day + -- @cabal-install@ will also handle these correctly too! + , componentCompatPackageKey :: String + -- ^ Compatibility "package key" that we pass to older versions of GHC. + , componentCompatPackageName :: MungedPackageName + -- ^ Compatibility "package name" that we register this component as. + , componentExposedModules :: [Installed.ExposedModule] + -- ^ A list of exposed modules (either defined in this component, + -- or reexported from another component.) + , componentIsPublic :: Bool + -- ^ Convenience field, specifying whether or not this is the + -- "public library" that has the same name as the package. + } + | -- TODO: refactor all these duplicates + FLibComponentLocalBuildInfo + { componentLocalName :: ComponentName + , componentComponentId :: ComponentId + , componentUnitId :: UnitId + , componentPackageDeps :: [(UnitId, MungedPackageId)] + , componentIncludes :: [(OpenUnitId, ModuleRenaming)] + , componentExeDeps :: [UnitId] + , componentInternalDeps :: [UnitId] + } + | ExeComponentLocalBuildInfo + { componentLocalName :: ComponentName + , componentComponentId :: ComponentId + , componentUnitId :: UnitId + , componentPackageDeps :: [(UnitId, MungedPackageId)] + , componentIncludes :: [(OpenUnitId, ModuleRenaming)] + , componentExeDeps :: [UnitId] + , componentInternalDeps :: [UnitId] + } + | TestComponentLocalBuildInfo + { componentLocalName :: ComponentName + , componentComponentId :: ComponentId + , componentUnitId :: UnitId + , componentPackageDeps :: [(UnitId, MungedPackageId)] + , componentIncludes :: [(OpenUnitId, ModuleRenaming)] + , componentExeDeps :: [UnitId] + , componentInternalDeps :: [UnitId] + } + | BenchComponentLocalBuildInfo + { componentLocalName :: ComponentName + , componentComponentId :: ComponentId + , componentUnitId :: UnitId + , componentPackageDeps :: [(UnitId, MungedPackageId)] + , componentIncludes :: [(OpenUnitId, ModuleRenaming)] + , componentExeDeps :: [UnitId] + , componentInternalDeps :: [UnitId] + } deriving (Generic, Read, Show, Typeable) instance Binary ComponentLocalBuildInfo instance Structured ComponentLocalBuildInfo instance IsNode ComponentLocalBuildInfo where - type Key ComponentLocalBuildInfo = UnitId - nodeKey = componentUnitId - nodeNeighbors = componentInternalDeps + type Key ComponentLocalBuildInfo = UnitId + nodeKey = componentUnitId + nodeNeighbors = componentInternalDeps componentIsIndefinite :: ComponentLocalBuildInfo -> Bool -componentIsIndefinite LibComponentLocalBuildInfo{ componentIsIndefinite_ = b } = b +componentIsIndefinite LibComponentLocalBuildInfo{componentIsIndefinite_ = b} = b componentIsIndefinite _ = False maybeComponentInstantiatedWith :: ComponentLocalBuildInfo -> Maybe [(ModuleName, OpenModule)] maybeComponentInstantiatedWith - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } = Just insts + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} = Just insts maybeComponentInstantiatedWith _ = Nothing diff --git a/Cabal/src/Distribution/Types/DumpBuildInfo.hs b/Cabal/src/Distribution/Types/DumpBuildInfo.hs index 5657a65aa71..2b3dae8888f 100644 --- a/Cabal/src/Distribution/Types/DumpBuildInfo.hs +++ b/Cabal/src/Distribution/Types/DumpBuildInfo.hs @@ -1,8 +1,9 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} + module Distribution.Types.DumpBuildInfo - ( DumpBuildInfo(..) - ) where + ( DumpBuildInfo (..) + ) where import Distribution.Compat.Prelude diff --git a/Cabal/src/Distribution/Types/GivenComponent.hs b/Cabal/src/Distribution/Types/GivenComponent.hs index 3908ec07cc9..c8314311d89 100644 --- a/Cabal/src/Distribution/Types/GivenComponent.hs +++ b/Cabal/src/Distribution/Types/GivenComponent.hs @@ -1,8 +1,9 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.GivenComponent ( - GivenComponent(..) -) where + +module Distribution.Types.GivenComponent + ( GivenComponent (..) + ) where import Distribution.Compat.Prelude @@ -16,12 +17,12 @@ import Distribution.Types.PackageName -- It enables Cabal to know which 'ComponentId' to associate with a library -- -- @since 2.3.0.0 -data GivenComponent = - GivenComponent - { givenComponentPackage :: PackageName - , givenComponentName :: LibraryName -- --dependency is for libraries - -- only, not for any component - , givenComponentId :: ComponentId } +data GivenComponent = GivenComponent + { givenComponentPackage :: PackageName + , givenComponentName :: LibraryName -- --dependency is for libraries + -- only, not for any component + , givenComponentId :: ComponentId + } deriving (Generic, Read, Show, Eq, Typeable) instance Binary GivenComponent diff --git a/Cabal/src/Distribution/Types/LocalBuildInfo.hs b/Cabal/src/Distribution/Types/LocalBuildInfo.hs index c8753d68200..ef2a1c8c875 100644 --- a/Cabal/src/Distribution/Types/LocalBuildInfo.hs +++ b/Cabal/src/Distribution/Types/LocalBuildInfo.hs @@ -3,161 +3,183 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} -module Distribution.Types.LocalBuildInfo ( - -- * The type - - LocalBuildInfo(..), +module Distribution.Types.LocalBuildInfo + ( -- * The type + LocalBuildInfo (..) -- * Convenience accessors - - localComponentId, - localUnitId, - localCompatPackageKey, - localPackage, + , localComponentId + , localUnitId + , localCompatPackageKey + , localPackage -- * Build targets of the 'LocalBuildInfo'. - - componentNameCLBIs, - - -- NB: the primes mean that they take a 'PackageDescription' - -- which may not match 'localPkgDescr' in 'LocalBuildInfo'. - -- More logical types would drop this argument, but - -- at the moment, this is the ONLY supported function, because - -- 'localPkgDescr' is not guaranteed to match. At some point - -- we will fix it and then we can use the (free) unprimed - -- namespace for the correct commands. - -- - -- See https://github.com/haskell/cabal/issues/3606 for more - -- details. - - componentNameTargets', - unitIdTarget', - allTargetsInBuildOrder', - withAllTargetsInBuildOrder', - neededTargetsInBuildOrder', - withNeededTargetsInBuildOrder', - testCoverage, + , componentNameCLBIs + -- NB: the primes mean that they take a 'PackageDescription' + -- which may not match 'localPkgDescr' in 'LocalBuildInfo'. + -- More logical types would drop this argument, but + -- at the moment, this is the ONLY supported function, because + -- 'localPkgDescr' is not guaranteed to match. At some point + -- we will fix it and then we can use the (free) unprimed + -- namespace for the correct commands. + -- + -- See https://github.com/haskell/cabal/issues/3606 for more + -- details. + + , componentNameTargets' + , unitIdTarget' + , allTargetsInBuildOrder' + , withAllTargetsInBuildOrder' + , neededTargetsInBuildOrder' + , withNeededTargetsInBuildOrder' + , testCoverage -- * Functions you SHOULD NOT USE (yet), but are defined here to - -- prevent someone from accidentally defining them - componentNameTargets, - unitIdTarget, - allTargetsInBuildOrder, - withAllTargetsInBuildOrder, - neededTargetsInBuildOrder, - withNeededTargetsInBuildOrder, + -- prevent someone from accidentally defining them + + , componentNameTargets + , unitIdTarget + , allTargetsInBuildOrder + , withAllTargetsInBuildOrder + , neededTargetsInBuildOrder + , withNeededTargetsInBuildOrder ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.PackageDescription +import Distribution.Types.ComponentId import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.ComponentId +import Distribution.Types.PackageDescription import Distribution.Types.PackageId -import Distribution.Types.UnitId import Distribution.Types.TargetInfo +import Distribution.Types.UnitId -import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs, - prefixRelativeInstallDirs, - substPathTemplate, ) -import Distribution.Simple.Program import Distribution.PackageDescription +import Distribution.Pretty import Distribution.Simple.Compiler +import Distribution.Simple.InstallDirs hiding + ( absoluteInstallDirs + , prefixRelativeInstallDirs + , substPathTemplate + ) import Distribution.Simple.PackageIndex +import Distribution.Simple.Program import Distribution.Simple.Setup.Config import Distribution.System -import Distribution.Pretty +import qualified Data.Map as Map import Distribution.Compat.Graph (Graph) import qualified Distribution.Compat.Graph as Graph -import qualified Data.Map as Map -- | Data cached after configuration step. See also -- 'Distribution.Simple.Setup.ConfigFlags'. -data LocalBuildInfo = LocalBuildInfo { - configFlags :: ConfigFlags, - -- ^ Options passed to the configuration step. - -- Needed to re-run configuration when .cabal is out of date - flagAssignment :: FlagAssignment, - -- ^ The final set of flags which were picked for this package - componentEnabledSpec :: ComponentRequestedSpec, - -- ^ What components were enabled during configuration, and why. - extraConfigArgs :: [String], - -- ^ Extra args on the command line for the configuration step. - -- Needed to re-run configuration when .cabal is out of date - installDirTemplates :: InstallDirTemplates, - -- ^ The installation directories for the various different - -- kinds of files - --TODO: inplaceDirTemplates :: InstallDirs FilePath - compiler :: Compiler, - -- ^ The compiler we're building with - hostPlatform :: Platform, - -- ^ The platform we're building for - buildDir :: FilePath, - -- ^ Where to build the package. - cabalFilePath :: Maybe FilePath, - -- ^ Path to the cabal file, if given during configuration. - componentGraph :: Graph ComponentLocalBuildInfo, - -- ^ All the components to build, ordered by topological - -- sort, and with their INTERNAL dependencies over the - -- intrapackage dependency graph. - -- TODO: this is assumed to be short; otherwise we want - -- some sort of ordered map. - componentNameMap :: Map ComponentName [ComponentLocalBuildInfo], - -- ^ A map from component name to all matching - -- components. These coincide with 'componentGraph' - installedPkgs :: InstalledPackageIndex, - -- ^ All the info about the installed packages that the - -- current package depends on (directly or indirectly). - -- The copy saved on disk does NOT include internal - -- dependencies (because we just don't have enough - -- information at this point to have an - -- 'InstalledPackageInfo' for an internal dep), but we - -- will often update it with the internal dependencies; - -- see for example 'Distribution.Simple.Build.build'. - -- (This admonition doesn't apply for per-component builds.) - pkgDescrFile :: Maybe FilePath, - -- ^ the filename containing the .cabal file, if available - localPkgDescr :: PackageDescription, - -- ^ WARNING WARNING WARNING Be VERY careful about using - -- this function; we haven't deprecated it but using it - -- could introduce subtle bugs related to - -- 'HookedBuildInfo'. - -- - -- In principle, this is supposed to contain the - -- resolved package description, that does not contain - -- any conditionals. However, it MAY NOT contain - -- the description with a 'HookedBuildInfo' applied - -- to it; see 'HookedBuildInfo' for the whole sordid saga. - -- As much as possible, Cabal library should avoid using - -- this parameter. - withPrograms :: ProgramDb, -- ^Location and args for all programs - withPackageDB :: PackageDBStack, -- ^What package database to use, global\/user - withVanillaLib:: Bool, -- ^Whether to build normal libs. - withProfLib :: Bool, -- ^Whether to build profiling versions of libs. - withSharedLib :: Bool, -- ^Whether to build shared versions of libs. - withStaticLib :: Bool, -- ^Whether to build static versions of libs (with all other libs rolled in) - withDynExe :: Bool, -- ^Whether to link executables dynamically - withFullyStaticExe :: Bool, -- ^Whether to link executables fully statically - withProfExe :: Bool, -- ^Whether to build executables for profiling. - withProfLibDetail :: ProfDetailLevel, -- ^Level of automatic profile detail. - withProfExeDetail :: ProfDetailLevel, -- ^Level of automatic profile detail. - withOptimization :: OptimisationLevel, -- ^Whether to build with optimization (if available). - withDebugInfo :: DebugInfoLevel, -- ^Whether to emit debug info (if available). - withGHCiLib :: Bool, -- ^Whether to build libs suitable for use with GHCi. - splitSections :: Bool, -- ^Use -split-sections with GHC, if available - splitObjs :: Bool, -- ^Use -split-objs with GHC, if available - stripExes :: Bool, -- ^Whether to strip executables during install - stripLibs :: Bool, -- ^Whether to strip libraries during install - exeCoverage :: Bool, -- ^Whether to enable executable program coverage - libCoverage :: Bool, -- ^Whether to enable library program coverage - progPrefix :: PathTemplate, -- ^Prefix to be prepended to installed executables - progSuffix :: PathTemplate, -- ^Suffix to be appended to installed executables - relocatable :: Bool -- ^Whether to build a relocatable package - } deriving (Generic, Read, Show, Typeable) +data LocalBuildInfo = LocalBuildInfo + { configFlags :: ConfigFlags + -- ^ Options passed to the configuration step. + -- Needed to re-run configuration when .cabal is out of date + , flagAssignment :: FlagAssignment + -- ^ The final set of flags which were picked for this package + , componentEnabledSpec :: ComponentRequestedSpec + -- ^ What components were enabled during configuration, and why. + , extraConfigArgs :: [String] + -- ^ Extra args on the command line for the configuration step. + -- Needed to re-run configuration when .cabal is out of date + , installDirTemplates :: InstallDirTemplates + -- ^ The installation directories for the various different + -- kinds of files + -- TODO: inplaceDirTemplates :: InstallDirs FilePath + , compiler :: Compiler + -- ^ The compiler we're building with + , hostPlatform :: Platform + -- ^ The platform we're building for + , buildDir :: FilePath + -- ^ Where to build the package. + , cabalFilePath :: Maybe FilePath + -- ^ Path to the cabal file, if given during configuration. + , componentGraph :: Graph ComponentLocalBuildInfo + -- ^ All the components to build, ordered by topological + -- sort, and with their INTERNAL dependencies over the + -- intrapackage dependency graph. + -- TODO: this is assumed to be short; otherwise we want + -- some sort of ordered map. + , componentNameMap :: Map ComponentName [ComponentLocalBuildInfo] + -- ^ A map from component name to all matching + -- components. These coincide with 'componentGraph' + , installedPkgs :: InstalledPackageIndex + -- ^ All the info about the installed packages that the + -- current package depends on (directly or indirectly). + -- The copy saved on disk does NOT include internal + -- dependencies (because we just don't have enough + -- information at this point to have an + -- 'InstalledPackageInfo' for an internal dep), but we + -- will often update it with the internal dependencies; + -- see for example 'Distribution.Simple.Build.build'. + -- (This admonition doesn't apply for per-component builds.) + , pkgDescrFile :: Maybe FilePath + -- ^ the filename containing the .cabal file, if available + , localPkgDescr :: PackageDescription + -- ^ WARNING WARNING WARNING Be VERY careful about using + -- this function; we haven't deprecated it but using it + -- could introduce subtle bugs related to + -- 'HookedBuildInfo'. + -- + -- In principle, this is supposed to contain the + -- resolved package description, that does not contain + -- any conditionals. However, it MAY NOT contain + -- the description with a 'HookedBuildInfo' applied + -- to it; see 'HookedBuildInfo' for the whole sordid saga. + -- As much as possible, Cabal library should avoid using + -- this parameter. + , withPrograms :: ProgramDb + -- ^ Location and args for all programs + , withPackageDB :: PackageDBStack + -- ^ What package database to use, global\/user + , withVanillaLib :: Bool + -- ^ Whether to build normal libs. + , withProfLib :: Bool + -- ^ Whether to build profiling versions of libs. + , withSharedLib :: Bool + -- ^ Whether to build shared versions of libs. + , withStaticLib :: Bool + -- ^ Whether to build static versions of libs (with all other libs rolled in) + , withDynExe :: Bool + -- ^ Whether to link executables dynamically + , withFullyStaticExe :: Bool + -- ^ Whether to link executables fully statically + , withProfExe :: Bool + -- ^ Whether to build executables for profiling. + , withProfLibDetail :: ProfDetailLevel + -- ^ Level of automatic profile detail. + , withProfExeDetail :: ProfDetailLevel + -- ^ Level of automatic profile detail. + , withOptimization :: OptimisationLevel + -- ^ Whether to build with optimization (if available). + , withDebugInfo :: DebugInfoLevel + -- ^ Whether to emit debug info (if available). + , withGHCiLib :: Bool + -- ^ Whether to build libs suitable for use with GHCi. + , splitSections :: Bool + -- ^ Use -split-sections with GHC, if available + , splitObjs :: Bool + -- ^ Use -split-objs with GHC, if available + , stripExes :: Bool + -- ^ Whether to strip executables during install + , stripLibs :: Bool + -- ^ Whether to strip libraries during install + , exeCoverage :: Bool + -- ^ Whether to enable executable program coverage + , libCoverage :: Bool + -- ^ Whether to enable library program coverage + , progPrefix :: PathTemplate + -- ^ Prefix to be prepended to installed executables + , progSuffix :: PathTemplate + -- ^ Suffix to be appended to installed executables + , relocatable :: Bool -- ^Whether to build a relocatable package + } + deriving (Generic, Read, Show, Typeable) instance Binary LocalBuildInfo instance Structured LocalBuildInfo @@ -173,10 +195,10 @@ instance Structured LocalBuildInfo -- on the package ID. localComponentId :: LocalBuildInfo -> ComponentId localComponentId lbi = - case componentNameCLBIs lbi (CLibName LMainLibName) of - [LibComponentLocalBuildInfo { componentComponentId = cid }] - -> cid - _ -> mkComponentId (prettyShow (localPackage lbi)) + case componentNameCLBIs lbi (CLibName LMainLibName) of + [LibComponentLocalBuildInfo{componentComponentId = cid}] -> + cid + _ -> mkComponentId (prettyShow (localPackage lbi)) -- | Extract the 'PackageIdentifier' of a 'LocalBuildInfo'. -- This is a "safe" use of 'localPkgDescr' @@ -188,32 +210,34 @@ localPackage lbi = package (localPkgDescr lbi) -- the package ID. localUnitId :: LocalBuildInfo -> UnitId localUnitId lbi = - case componentNameCLBIs lbi (CLibName LMainLibName) of - [LibComponentLocalBuildInfo { componentUnitId = uid }] - -> uid - _ -> mkLegacyUnitId $ localPackage lbi + case componentNameCLBIs lbi (CLibName LMainLibName) of + [LibComponentLocalBuildInfo{componentUnitId = uid}] -> + uid + _ -> mkLegacyUnitId $ localPackage lbi -- | Extract the compatibility package key from the public library component of a -- 'LocalBuildInfo' if it exists, or make a fake package key based -- on the package ID. localCompatPackageKey :: LocalBuildInfo -> String localCompatPackageKey lbi = - case componentNameCLBIs lbi (CLibName LMainLibName) of - [LibComponentLocalBuildInfo { componentCompatPackageKey = pk }] - -> pk - _ -> prettyShow (localPackage lbi) + case componentNameCLBIs lbi (CLibName LMainLibName) of + [LibComponentLocalBuildInfo{componentCompatPackageKey = pk}] -> + pk + _ -> prettyShow (localPackage lbi) -- | Convenience function to generate a default 'TargetInfo' from a -- 'ComponentLocalBuildInfo'. The idea is to call this once, and then -- use 'TargetInfo' everywhere else. Private to this module. mkTargetInfo :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> TargetInfo mkTargetInfo pkg_descr _lbi clbi = - TargetInfo { - targetCLBI = clbi, - -- NB: @pkg_descr@, not @localPkgDescr lbi@! - targetComponent = getComponent pkg_descr - (componentLocalName clbi) - } + TargetInfo + { targetCLBI = clbi + , -- NB: @pkg_descr@, not @localPkgDescr lbi@! + targetComponent = + getComponent + pkg_descr + (componentLocalName clbi) + } -- | Return all 'TargetInfo's associated with 'ComponentName'. -- In the presence of Backpack there may be more than one! @@ -221,23 +245,23 @@ mkTargetInfo pkg_descr _lbi clbi = -- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. componentNameTargets' :: PackageDescription -> LocalBuildInfo -> ComponentName -> [TargetInfo] componentNameTargets' pkg_descr lbi cname = - case Map.lookup cname (componentNameMap lbi) of - Just clbis -> map (mkTargetInfo pkg_descr lbi) clbis - Nothing -> [] + case Map.lookup cname (componentNameMap lbi) of + Just clbis -> map (mkTargetInfo pkg_descr lbi) clbis + Nothing -> [] unitIdTarget' :: PackageDescription -> LocalBuildInfo -> UnitId -> Maybe TargetInfo unitIdTarget' pkg_descr lbi uid = - case Graph.lookup uid (componentGraph lbi) of - Just clbi -> Just (mkTargetInfo pkg_descr lbi clbi) - Nothing -> Nothing + case Graph.lookup uid (componentGraph lbi) of + Just clbi -> Just (mkTargetInfo pkg_descr lbi clbi) + Nothing -> Nothing -- | Return all 'ComponentLocalBuildInfo's associated with 'ComponentName'. -- In the presence of Backpack there may be more than one! componentNameCLBIs :: LocalBuildInfo -> ComponentName -> [ComponentLocalBuildInfo] componentNameCLBIs lbi cname = - case Map.lookup cname (componentNameMap lbi) of - Just clbis -> clbis - Nothing -> [] + case Map.lookup cname (componentNameMap lbi) of + Just clbis -> clbis + Nothing -> [] -- TODO: Maybe cache topsort (Graph can do this) @@ -246,16 +270,16 @@ componentNameCLBIs lbi cname = -- Has a prime because it takes a 'PackageDescription' argument -- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. allTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [TargetInfo] -allTargetsInBuildOrder' pkg_descr lbi - = map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort (componentGraph lbi)) +allTargetsInBuildOrder' pkg_descr lbi = + map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort (componentGraph lbi)) -- | Execute @f@ for every 'TargetInfo' in the package, respecting the -- build dependency order. (TODO: We should use Shake!) -- Has a prime because it takes a 'PackageDescription' argument -- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. withAllTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> (TargetInfo -> IO ()) -> IO () -withAllTargetsInBuildOrder' pkg_descr lbi f - = sequence_ [ f target | target <- allTargetsInBuildOrder' pkg_descr lbi ] +withAllTargetsInBuildOrder' pkg_descr lbi f = + sequence_ [f target | target <- allTargetsInBuildOrder' pkg_descr lbi] -- | Return the list of all targets needed to build the @uids@, in -- the order they need to be built. @@ -272,8 +296,8 @@ neededTargetsInBuildOrder' pkg_descr lbi uids = -- Has a prime because it takes a 'PackageDescription' argument -- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. withNeededTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [UnitId] -> (TargetInfo -> IO ()) -> IO () -withNeededTargetsInBuildOrder' pkg_descr lbi uids f - = sequence_ [ f target | target <- neededTargetsInBuildOrder' pkg_descr lbi uids ] +withNeededTargetsInBuildOrder' pkg_descr lbi uids f = + sequence_ [f target | target <- neededTargetsInBuildOrder' pkg_descr lbi uids] -- | Is coverage enabled for test suites? In practice, this requires library -- and executable profiling to be enabled. @@ -284,21 +308,15 @@ testCoverage lbi = exeCoverage lbi && libCoverage lbi -- Stub functions to prevent someone from accidentally defining them {-# WARNING componentNameTargets, unitIdTarget, allTargetsInBuildOrder, withAllTargetsInBuildOrder, neededTargetsInBuildOrder, withNeededTargetsInBuildOrder "By using this function, you may be introducing a bug where you retrieve a 'Component' which does not have 'HookedBuildInfo' applied to it. See the documentation for 'HookedBuildInfo' for an explanation of the issue. If you have a 'PackageDescription' handy (NOT from the 'LocalBuildInfo'), try using the primed version of the function, which takes it as an extra argument." #-} - componentNameTargets :: LocalBuildInfo -> ComponentName -> [TargetInfo] componentNameTargets lbi = componentNameTargets' (localPkgDescr lbi) lbi - unitIdTarget :: LocalBuildInfo -> UnitId -> Maybe TargetInfo unitIdTarget lbi = unitIdTarget' (localPkgDescr lbi) lbi - allTargetsInBuildOrder :: LocalBuildInfo -> [TargetInfo] allTargetsInBuildOrder lbi = allTargetsInBuildOrder' (localPkgDescr lbi) lbi - withAllTargetsInBuildOrder :: LocalBuildInfo -> (TargetInfo -> IO ()) -> IO () withAllTargetsInBuildOrder lbi = withAllTargetsInBuildOrder' (localPkgDescr lbi) lbi - neededTargetsInBuildOrder :: LocalBuildInfo -> [UnitId] -> [TargetInfo] neededTargetsInBuildOrder lbi = neededTargetsInBuildOrder' (localPkgDescr lbi) lbi - withNeededTargetsInBuildOrder :: LocalBuildInfo -> [UnitId] -> (TargetInfo -> IO ()) -> IO () withNeededTargetsInBuildOrder lbi = withNeededTargetsInBuildOrder' (localPkgDescr lbi) lbi diff --git a/Cabal/src/Distribution/Types/TargetInfo.hs b/Cabal/src/Distribution/Types/TargetInfo.hs index 52b11308fe1..8f724d894d1 100644 --- a/Cabal/src/Distribution/Types/TargetInfo.hs +++ b/Cabal/src/Distribution/Types/TargetInfo.hs @@ -1,33 +1,34 @@ {-# LANGUAGE TypeFamilies #-} -module Distribution.Types.TargetInfo ( - TargetInfo(..) -) where -import Prelude () +module Distribution.Types.TargetInfo + ( TargetInfo (..) + ) where + import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.Component +import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.UnitId -import Distribution.Compat.Graph (IsNode(..)) +import Distribution.Compat.Graph (IsNode (..)) -- | The 'TargetInfo' contains all the information necessary to build a -- specific target (e.g., component/module/file) in a package. In -- principle, one can get the 'Component' from a -- 'ComponentLocalBuildInfo' and 'LocalBuildInfo', but it is much more -- convenient to have the component in hand. -data TargetInfo = TargetInfo { - targetCLBI :: ComponentLocalBuildInfo, - targetComponent :: Component - -- TODO: BuildTargets supporting parsing these is dumb, - -- we don't have support for compiling single modules or - -- file paths. Accommodating it now is premature - -- generalization. Figure it out later. - -- targetSub :: Maybe (Either ModuleName FilePath) - } +data TargetInfo = TargetInfo + { targetCLBI :: ComponentLocalBuildInfo + , targetComponent :: Component + -- TODO: BuildTargets supporting parsing these is dumb, + -- we don't have support for compiling single modules or + -- file paths. Accommodating it now is premature + -- generalization. Figure it out later. + -- targetSub :: Maybe (Either ModuleName FilePath) + } instance IsNode TargetInfo where - type Key TargetInfo = UnitId - nodeKey = nodeKey . targetCLBI - nodeNeighbors = nodeNeighbors . targetCLBI + type Key TargetInfo = UnitId + nodeKey = nodeKey . targetCLBI + nodeNeighbors = nodeNeighbors . targetCLBI diff --git a/Cabal/src/Distribution/Utils/IOData.hs b/Cabal/src/Distribution/Utils/IOData.hs index e71fb5099a4..074576ceaf9 100644 --- a/Cabal/src/Distribution/Utils/IOData.hs +++ b/Cabal/src/Distribution/Utils/IOData.hs @@ -1,78 +1,78 @@ {-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} + -- | @since 2.2.0 module Distribution.Utils.IOData - ( -- * 'IOData' & 'IODataMode' type - IOData (..) - , IODataMode (..) - , KnownIODataMode (..) - , withIOData - , null - , hPutContents - ) where + ( -- * 'IOData' & 'IODataMode' type + IOData (..) + , IODataMode (..) + , KnownIODataMode (..) + , withIOData + , null + , hPutContents + ) where import qualified Data.ByteString.Lazy as LBS -import Distribution.Compat.Prelude hiding (null) -import qualified Prelude +import Distribution.Compat.Prelude hiding (null) import qualified System.IO +import qualified Prelude -- | Represents either textual or binary data passed via I/O functions -- which support binary/text mode -- -- @since 2.2 data IOData - = IODataText String - -- ^ How Text gets encoded is usually locale-dependent. - | IODataBinary LBS.ByteString - -- ^ Raw binary which gets read/written in binary mode. + = -- | How Text gets encoded is usually locale-dependent. + IODataText String + | -- | Raw binary which gets read/written in binary mode. + IODataBinary LBS.ByteString withIOData :: IOData -> (forall mode. IODataMode mode -> mode -> r) -> r -withIOData (IODataText str) k = k IODataModeText str +withIOData (IODataText str) k = k IODataModeText str withIOData (IODataBinary lbs) k = k IODataModeBinary lbs -- | Test whether 'IOData' is empty null :: IOData -> Bool -null (IODataText s) = Prelude.null s +null (IODataText s) = Prelude.null s null (IODataBinary b) = LBS.null b instance NFData IOData where - rnf (IODataText s) = rnf s - rnf (IODataBinary lbs) = rnf lbs + rnf (IODataText s) = rnf s + rnf (IODataBinary lbs) = rnf lbs -- | @since 2.2 class NFData mode => KnownIODataMode mode where - -- | 'IOData' Wrapper for 'System.IO.hGetContents' - -- - -- __Note__: This operation uses lazy I/O. Use 'NFData' to force all - -- data to be read and consequently the internal file handle to be - -- closed. - -- - hGetIODataContents :: System.IO.Handle -> Prelude.IO mode + -- | 'IOData' Wrapper for 'System.IO.hGetContents' + -- + -- __Note__: This operation uses lazy I/O. Use 'NFData' to force all + -- data to be read and consequently the internal file handle to be + -- closed. + hGetIODataContents :: System.IO.Handle -> Prelude.IO mode - toIOData :: mode -> IOData - iodataMode :: IODataMode mode + toIOData :: mode -> IOData + iodataMode :: IODataMode mode -- | @since 3.2 data IODataMode mode where - IODataModeText :: IODataMode String - IODataModeBinary :: IODataMode LBS.ByteString + IODataModeText :: IODataMode String + IODataModeBinary :: IODataMode LBS.ByteString instance a ~ Char => KnownIODataMode [a] where - hGetIODataContents h = do - System.IO.hSetBinaryMode h False - System.IO.hGetContents h + hGetIODataContents h = do + System.IO.hSetBinaryMode h False + System.IO.hGetContents h - toIOData = IODataText - iodataMode = IODataModeText + toIOData = IODataText + iodataMode = IODataModeText instance KnownIODataMode LBS.ByteString where - hGetIODataContents h = do - System.IO.hSetBinaryMode h True - LBS.hGetContents h + hGetIODataContents h = do + System.IO.hSetBinaryMode h True + LBS.hGetContents h - toIOData = IODataBinary - iodataMode = IODataModeBinary + toIOData = IODataBinary + iodataMode = IODataModeBinary -- | 'IOData' Wrapper for 'System.IO.hPutStr' and 'System.IO.hClose' -- @@ -84,10 +84,10 @@ instance KnownIODataMode LBS.ByteString where -- @since 2.2 hPutContents :: System.IO.Handle -> IOData -> Prelude.IO () hPutContents h (IODataText c) = do - System.IO.hSetBinaryMode h False - System.IO.hPutStr h c - System.IO.hClose h + System.IO.hSetBinaryMode h False + System.IO.hPutStr h c + System.IO.hClose h hPutContents h (IODataBinary c) = do - System.IO.hSetBinaryMode h True - LBS.hPutStr h c - System.IO.hClose h + System.IO.hSetBinaryMode h True + LBS.hPutStr h c + System.IO.hClose h diff --git a/Cabal/src/Distribution/Utils/Json.hs b/Cabal/src/Distribution/Utils/Json.hs index cef32f04d6d..873e60631ac 100644 --- a/Cabal/src/Distribution/Utils/Json.hs +++ b/Cabal/src/Distribution/Utils/Json.hs @@ -1,55 +1,60 @@ -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} --- | Extremely simple JSON helper. Don't do anything too fancy with this! +{-# LANGUAGE RankNTypes #-} +-- | Extremely simple JSON helper. Don't do anything too fancy with this! module Distribution.Utils.Json - ( Json(..) - , (.=) - , renderJson - ) where + ( Json (..) + , (.=) + , renderJson + ) where -import Distribution.Compat.Prelude -import qualified Data.ByteString.Lazy as LBS import Data.ByteString.Builder - ( Builder, stringUtf8, intDec, toLazyByteString ) + ( Builder + , intDec + , stringUtf8 + , toLazyByteString + ) +import qualified Data.ByteString.Lazy as LBS +import Distribution.Compat.Prelude -data Json = JsonArray [Json] - | JsonBool !Bool - | JsonNull - | JsonNumber !Int -- No support for Floats, Doubles just yet - | JsonObject [(String, Json)] - | JsonString !String - deriving Show +data Json + = JsonArray [Json] + | JsonBool !Bool + | JsonNull + | JsonNumber !Int -- No support for Floats, Doubles just yet + | JsonObject [(String, Json)] + | JsonString !String + deriving (Show) -- | Convert a 'Json' into a 'ByteString' renderJson :: Json -> LBS.ByteString renderJson json = toLazyByteString (go json) where - go (JsonArray objs) = + go (JsonArray objs) = surround "[" "]" $ mconcat $ intersperse "," $ map go objs - go (JsonBool True) = stringUtf8 "true" - go (JsonBool False) = stringUtf8 "false" - go JsonNull = stringUtf8 "null" - go (JsonNumber n) = intDec n + go (JsonBool True) = stringUtf8 "true" + go (JsonBool False) = stringUtf8 "false" + go JsonNull = stringUtf8 "null" + go (JsonNumber n) = intDec n go (JsonObject attrs) = surround "{" "}" $ mconcat $ intersperse "," $ map render attrs where - render (k,v) = (surround "\"" "\"" $ stringUtf8 (escape k)) <> ":" <> go v - go (JsonString s) = surround "\"" "\"" $ stringUtf8 (escape s) + render (k, v) = (surround "\"" "\"" $ stringUtf8 (escape k)) <> ":" <> go v + go (JsonString s) = surround "\"" "\"" $ stringUtf8 (escape s) surround :: Builder -> Builder -> Builder -> Builder -surround begin end middle = mconcat [ begin , middle , end] +surround begin end middle = mconcat [begin, middle, end] escape :: String -> String -escape ('\"':xs) = "\\\"" <> escape xs -escape ('\\':xs) = "\\\\" <> escape xs -escape ('\b':xs) = "\\b" <> escape xs -escape ('\f':xs) = "\\f" <> escape xs -escape ('\n':xs) = "\\n" <> escape xs -escape ('\r':xs) = "\\r" <> escape xs -escape ('\t':xs) = "\\t" <> escape xs -escape (x:xs) = x : escape xs -escape [] = mempty +escape ('\"' : xs) = "\\\"" <> escape xs +escape ('\\' : xs) = "\\\\" <> escape xs +escape ('\b' : xs) = "\\b" <> escape xs +escape ('\f' : xs) = "\\f" <> escape xs +escape ('\n' : xs) = "\\n" <> escape xs +escape ('\r' : xs) = "\\r" <> escape xs +escape ('\t' : xs) = "\\t" <> escape xs +escape (x : xs) = x : escape xs +escape [] = mempty -- | A shorthand for building up 'JsonObject's -- >>> JsonObject [ "a" .= JsonNumber 42, "b" .= JsonBool True ] diff --git a/Cabal/src/Distribution/Utils/LogProgress.hs b/Cabal/src/Distribution/Utils/LogProgress.hs index 9a2dced9392..114e01ab5a5 100644 --- a/Cabal/src/Distribution/Utils/LogProgress.hs +++ b/Cabal/src/Distribution/Utils/LogProgress.hs @@ -1,83 +1,85 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE FlexibleContexts #-} -module Distribution.Utils.LogProgress ( - LogProgress, - runLogProgress, - warnProgress, - infoProgress, - dieProgress, - addProgressCtx, -) where -import Prelude () +module Distribution.Utils.LogProgress + ( LogProgress + , runLogProgress + , warnProgress + , infoProgress + , dieProgress + , addProgressCtx + ) where + import Distribution.Compat.Prelude +import Prelude () +import Distribution.Simple.Utils import Distribution.Utils.Progress import Distribution.Verbosity -import Distribution.Simple.Utils import Text.PrettyPrint type CtxMsg = Doc type LogMsg = Doc type ErrMsg = Doc -data LogEnv = LogEnv { - le_verbosity :: Verbosity, - le_context :: [CtxMsg] - } +data LogEnv = LogEnv + { le_verbosity :: Verbosity + , le_context :: [CtxMsg] + } -- | The 'Progress' monad with specialized logging and -- error messages. -newtype LogProgress a = LogProgress { unLogProgress :: LogEnv -> Progress LogMsg ErrMsg a } +newtype LogProgress a = LogProgress {unLogProgress :: LogEnv -> Progress LogMsg ErrMsg a} instance Functor LogProgress where - fmap f (LogProgress m) = LogProgress (fmap (fmap f) m) + fmap f (LogProgress m) = LogProgress (fmap (fmap f) m) instance Applicative LogProgress where - pure x = LogProgress (pure (pure x)) - LogProgress f <*> LogProgress x = LogProgress $ \r -> f r `ap` x r + pure x = LogProgress (pure (pure x)) + LogProgress f <*> LogProgress x = LogProgress $ \r -> f r `ap` x r instance Monad LogProgress where - return = pure - LogProgress m >>= f = LogProgress $ \r -> m r >>= \x -> unLogProgress (f x) r + return = pure + LogProgress m >>= f = LogProgress $ \r -> m r >>= \x -> unLogProgress (f x) r -- | Run 'LogProgress', outputting traces according to 'Verbosity', -- 'die' if there is an error. runLogProgress :: Verbosity -> LogProgress a -> IO a runLogProgress verbosity (LogProgress m) = - foldProgress step_fn fail_fn return (m env) + foldProgress step_fn fail_fn return (m env) where - env = LogEnv { - le_verbosity = verbosity, - le_context = [] - } + env = + LogEnv + { le_verbosity = verbosity + , le_context = [] + } step_fn :: LogMsg -> IO a -> IO a step_fn doc go = do - putStrLn (render doc) - go + putStrLn (render doc) + go fail_fn :: Doc -> IO a fail_fn doc = do - dieNoWrap verbosity (render doc) + dieNoWrap verbosity (render doc) -- | Output a warning trace message in 'LogProgress'. warnProgress :: Doc -> LogProgress () warnProgress s = LogProgress $ \env -> - when (le_verbosity env >= normal) $ - stepProgress $ - hang (text "Warning:") 4 (formatMsg (le_context env) s) + when (le_verbosity env >= normal) $ + stepProgress $ + hang (text "Warning:") 4 (formatMsg (le_context env) s) -- | Output an informational trace message in 'LogProgress'. infoProgress :: Doc -> LogProgress () infoProgress s = LogProgress $ \env -> - when (le_verbosity env >= verbose) $ - stepProgress s + when (le_verbosity env >= verbose) $ + stepProgress s -- | Fail the computation with an error message. dieProgress :: Doc -> LogProgress a dieProgress s = LogProgress $ \env -> - failProgress $ - hang (text "Error:") 4 (formatMsg (le_context env) s) + failProgress $ + hang (text "Error:") 4 (formatMsg (le_context env) s) -- | Format a message with context. (Something simple for now.) formatMsg :: [CtxMsg] -> Doc -> Doc @@ -86,4 +88,4 @@ formatMsg ctx doc = doc $$ vcat ctx -- | Add a message to the error/warning context. addProgressCtx :: CtxMsg -> LogProgress a -> LogProgress a addProgressCtx s (LogProgress m) = LogProgress $ \env -> - m env { le_context = s : le_context env } + m env{le_context = s : le_context env} diff --git a/Cabal/src/Distribution/Utils/MapAccum.hs b/Cabal/src/Distribution/Utils/MapAccum.hs index 6dc3d2509d1..31f62d7d02f 100644 --- a/Cabal/src/Distribution/Utils/MapAccum.hs +++ b/Cabal/src/Distribution/Utils/MapAccum.hs @@ -1,22 +1,28 @@ {-# LANGUAGE CPP #-} + module Distribution.Utils.MapAccum (mapAccumM) where import Distribution.Compat.Prelude import Prelude () -- Like StateT but with return tuple swapped -newtype StateM s m a = StateM { runStateM :: s -> m (s, a) } +newtype StateM s m a = StateM {runStateM :: s -> m (s, a)} instance Functor m => Functor (StateM s m) where - fmap f (StateM x) = StateM $ \s -> fmap (\(s', a) -> (s', f a)) (x s) + fmap f (StateM x) = StateM $ \s -> fmap (\(s', a) -> (s', f a)) (x s) instance Monad m => Applicative (StateM s m) where - pure x = StateM $ \s -> return (s, x) - StateM f <*> StateM x = StateM $ \s -> do (s', f') <- f s - (s'', x') <- x s' - return (s'', f' x') + pure x = StateM $ \s -> return (s, x) + StateM f <*> StateM x = StateM $ \s -> do + (s', f') <- f s + (s'', x') <- x s' + return (s'', f' x') -- | Monadic variant of 'mapAccumL'. -mapAccumM :: (Monad m, Traversable t) - => (a -> b -> m (a, c)) -> a -> t b -> m (a, t c) +mapAccumM + :: (Monad m, Traversable t) + => (a -> b -> m (a, c)) + -> a + -> t b + -> m (a, t c) mapAccumM f s t = runStateM (traverse (\x -> StateM (\s' -> f s' x)) t) s diff --git a/Cabal/src/Distribution/Utils/NubList.hs b/Cabal/src/Distribution/Utils/NubList.hs index 25b8b74d648..2a7e69a7a85 100644 --- a/Cabal/src/Distribution/Utils/NubList.hs +++ b/Cabal/src/Distribution/Utils/NubList.hs @@ -1,17 +1,17 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Utils.NubList - ( NubList -- opaque - , toNubList -- smart constructor - , fromNubList - , overNubList - , NubListR - , toNubListR - , fromNubListR - , overNubListR - ) where +module Distribution.Utils.NubList + ( NubList -- opaque + , toNubList -- smart constructor + , fromNubList + , overNubList + , NubListR + , toNubListR + , fromNubListR + , overNubListR + ) where import Distribution.Compat.Prelude import Prelude () @@ -21,9 +21,8 @@ import Distribution.Simple.Utils import qualified Text.Read as R -- | NubList : A de-duplicated list that maintains the original order. -newtype NubList a = - NubList { fromNubList :: [a] } - deriving (Eq, Generic, Typeable) +newtype NubList a = NubList {fromNubList :: [a]} + deriving (Eq, Generic, Typeable) -- NubList assumes that nub retains the list order while removing duplicate -- elements (keeping the first occurrence). Documentation for "Data.List.nub" @@ -51,30 +50,29 @@ overNubList f (NubList list) = toNubList . f $ list -- -- Closure : appending two lists of type a and removing duplicates obviously -- does not change the type. - instance Ord a => Monoid (NubList a) where - mempty = NubList [] - mappend = (<>) + mempty = NubList [] + mappend = (<>) instance Ord a => Semigroup (NubList a) where - (NubList xs) <> (NubList ys) = NubList $ xs `listUnion` ys + (NubList xs) <> (NubList ys) = NubList $ xs `listUnion` ys instance Show a => Show (NubList a) where - show (NubList list) = show list + show (NubList list) = show list instance (Ord a, Read a) => Read (NubList a) where - readPrec = readNubList toNubList + readPrec = readNubList toNubList -- | Helper used by NubList/NubListR's Read instances. -readNubList :: (Read a) => ([a] -> l a) -> R.ReadPrec (l a) +readNubList :: Read a => ([a] -> l a) -> R.ReadPrec (l a) readNubList listToL = R.parens . R.prec 10 $ fmap listToL R.readPrec -- | Binary instance for 'NubList a' is the same as for '[a]'. For 'put', we -- just pull off constructor and put the list. For 'get', we get the list and -- make a 'NubList' out of it using 'toNubList'. instance (Ord a, Binary a) => Binary (NubList a) where - put (NubList l) = put l - get = fmap toNubList get + put (NubList l) = put l + get = fmap toNubList get instance Structured a => Structured (NubList a) @@ -82,9 +80,8 @@ instance Structured a => Structured (NubList a) -- ["-XNoFoo", "-XFoo", "-XNoFoo"]@ will result in @["-XFoo", "-XNoFoo"]@, -- unlike the normal 'NubList', which is left-biased. Built on top of -- 'ordNubRight' and 'listUnionRight'. -newtype NubListR a = - NubListR { fromNubListR :: [a] } - deriving Eq +newtype NubListR a = NubListR {fromNubListR :: [a]} + deriving (Eq) -- | Smart constructor for the NubListR type. toNubListR :: Ord a => [a] -> NubListR a @@ -105,4 +102,4 @@ instance Show a => Show (NubListR a) where show (NubListR list) = show list instance (Ord a, Read a) => Read (NubListR a) where - readPrec = readNubList toNubListR + readPrec = readNubList toNubListR diff --git a/Cabal/src/Distribution/Utils/Progress.hs b/Cabal/src/Distribution/Utils/Progress.hs index d834c87962c..a2c17b69113 100644 --- a/Cabal/src/Distribution/Utils/Progress.hs +++ b/Cabal/src/Distribution/Utils/Progress.hs @@ -1,22 +1,22 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} + -- Note: This module was copied from cabal-install. -- | A progress monad, which we use to report failure and logging from -- otherwise pure code. module Distribution.Utils.Progress - ( Progress - , stepProgress - , failProgress - , foldProgress - ) where + ( Progress + , stepProgress + , failProgress + , foldProgress + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import qualified Data.Monoid as Mon - -- | A type to represent the unfolding of an expensive long running -- calculation that may fail (or maybe not expensive, but complicated!) -- We may get intermediate steps before the final @@ -25,14 +25,13 @@ import qualified Data.Monoid as Mon -- TODO: Apply Codensity to avoid left-associativity problem. -- See http://comonad.com/reader/2011/free-monads-for-less/ and -- http://blog.ezyang.com/2012/01/problem-set-the-codensity-transformation/ --- -data Progress step fail done = Step step (Progress step fail done) - | Fail fail - | Done done +data Progress step fail done + = Step step (Progress step fail done) + | Fail fail + | Done done deriving (Functor) -- | Emit a step and then continue. --- stepProgress :: step -> Progress step fail () stepProgress step = Step step (Done ()) @@ -46,22 +45,26 @@ failProgress err = Fail err -- Eg to convert into a simple 'Either' result use: -- -- > foldProgress (flip const) Left Right --- -foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a) - -> Progress step fail done -> a +foldProgress + :: (step -> a -> a) + -> (fail -> a) + -> (done -> a) + -> Progress step fail done + -> a foldProgress step err done = fold - where fold (Step s p) = step s (fold p) - fold (Fail f) = err f - fold (Done r) = done r + where + fold (Step s p) = step s (fold p) + fold (Fail f) = err f + fold (Done r) = done r instance Monad (Progress step fail) where - return = pure - p >>= f = foldProgress Step Fail f p + return = pure + p >>= f = foldProgress Step Fail f p instance Applicative (Progress step fail) where - pure a = Done a + pure a = Done a p <*> x = foldProgress Step Fail (flip fmap x) p instance Monoid fail => Alternative (Progress step fail) where - empty = Fail Mon.mempty + empty = Fail Mon.mempty p <|> q = foldProgress Step (const q) Done p diff --git a/Cabal/src/Distribution/Utils/UnionFind.hs b/Cabal/src/Distribution/Utils/UnionFind.hs index 7af4177ccae..b22f07c0e43 100644 --- a/Cabal/src/Distribution/Utils/UnionFind.hs +++ b/Cabal/src/Distribution/Utils/UnionFind.hs @@ -1,27 +1,27 @@ {-# LANGUAGE NondecreasingIndentation #-} + -- | A simple mutable union-find data structure. -- -- It is used in a unification algorithm for backpack mix-in linking. -- -- This implementation is based off of the one in \"The Essence of ML Type -- Inference\". (N.B. the union-find package is also based off of this.) --- -module Distribution.Utils.UnionFind ( - Point, - fresh, - find, - union, - equivalent, -) where +module Distribution.Utils.UnionFind + ( Point + , fresh + , find + , union + , equivalent + ) where -import Data.STRef import Control.Monad import Control.Monad.ST +import Data.STRef -- | A variable which can be unified; alternately, this can be thought -- of as an equivalence class with a distinguished representative. newtype Point s a = Point (STRef s (Link s a)) - deriving (Eq) + deriving (Eq) -- | Mutable write to a 'Point' writePoint :: Point s a -> Link s a -> ST s () @@ -35,39 +35,41 @@ readPoint (Point v) = readSTRef v -- the representative element of an equivalence class, or a link to -- the 'Point' that actually stores the representative type. data Link s a - -- NB: it is too bad we can't say STRef Int#; the weights remain boxed - = Info {-# UNPACK #-} !(STRef s Int) {-# UNPACK #-} !(STRef s a) - | Link {-# UNPACK #-} !(Point s a) + = -- NB: it is too bad we can't say STRef Int#; the weights remain boxed + Info {-# UNPACK #-} !(STRef s Int) {-# UNPACK #-} !(STRef s a) + | Link {-# UNPACK #-} !(Point s a) -- | Create a fresh equivalence class with one element. fresh :: a -> ST s (Point s a) fresh desc = do - weight <- newSTRef 1 - descriptor <- newSTRef desc - Point `fmap` newSTRef (Info weight descriptor) + weight <- newSTRef 1 + descriptor <- newSTRef desc + Point `fmap` newSTRef (Info weight descriptor) -- | Flatten any chains of links, returning a 'Point' -- which points directly to the canonical representation. repr :: Point s a -> ST s (Point s a) -repr point = readPoint point >>= \r -> - case r of - Link point' -> do +repr point = + readPoint point >>= \r -> + case r of + Link point' -> do point'' <- repr point' when (point'' /= point') $ do - writePoint point =<< readPoint point' + writePoint point =<< readPoint point' return point'' - Info _ _ -> return point + Info _ _ -> return point -- | Return the canonical element of an equivalence -- class 'Point'. find :: Point s a -> ST s a find point = - -- Optimize length 0 and 1 case at expense of - -- general case - readPoint point >>= \r -> - case r of - Info _ d_ref -> readSTRef d_ref - Link point' -> readPoint point' >>= \r' -> + -- Optimize length 0 and 1 case at expense of + -- general case + readPoint point >>= \r -> + case r of + Info _ d_ref -> readSTRef d_ref + Link point' -> + readPoint point' >>= \r' -> case r' of Info _ d_ref -> readSTRef d_ref Link _ -> repr point >>= find @@ -76,26 +78,26 @@ find point = -- a canonical element. Keeps the descriptor of point2. union :: Point s a -> Point s a -> ST s () union refpoint1 refpoint2 = do - point1 <- repr refpoint1 - point2 <- repr refpoint2 - when (point1 /= point2) $ do + point1 <- repr refpoint1 + point2 <- repr refpoint2 + when (point1 /= point2) $ do l1 <- readPoint point1 l2 <- readPoint point2 case (l1, l2) of - (Info wref1 dref1, Info wref2 dref2) -> do - weight1 <- readSTRef wref1 - weight2 <- readSTRef wref2 - -- Should be able to optimize the == case separately - if weight1 >= weight2 - then do - writePoint point2 (Link point1) - -- The weight calculation here seems a bit dodgy - writeSTRef wref1 (weight1 + weight2) - writeSTRef dref1 =<< readSTRef dref2 - else do - writePoint point1 (Link point2) - writeSTRef wref2 (weight1 + weight2) - _ -> error "UnionFind.union: repr invariant broken" + (Info wref1 dref1, Info wref2 dref2) -> do + weight1 <- readSTRef wref1 + weight2 <- readSTRef wref2 + -- Should be able to optimize the == case separately + if weight1 >= weight2 + then do + writePoint point2 (Link point1) + -- The weight calculation here seems a bit dodgy + writeSTRef wref1 (weight1 + weight2) + writeSTRef dref1 =<< readSTRef dref2 + else do + writePoint point1 (Link point2) + writeSTRef wref2 (weight1 + weight2) + _ -> error "UnionFind.union: repr invariant broken" -- | Test if two points are in the same equivalence class. equivalent :: Point s a -> Point s a -> ST s Bool diff --git a/Cabal/src/Distribution/Verbosity.hs b/Cabal/src/Distribution/Verbosity.hs index d7fdeae24e9..bab48bbed21 100644 --- a/Cabal/src/Distribution/Verbosity.hs +++ b/Cabal/src/Distribution/Verbosity.hs @@ -2,6 +2,9 @@ {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- + +-- Verbosity for Cabal functions. + -- | -- Module : Distribution.Verbosity -- Copyright : Ian Lynagh 2007 @@ -21,79 +24,92 @@ -- settings (e.g., so that you can trace only particular things you -- are interested in.) It's important to note that the instances -- for 'Verbosity' assume that this does not exist. - --- Verbosity for Cabal functions. - -module Distribution.Verbosity ( - -- * Verbosity - Verbosity, - silent, normal, verbose, deafening, - moreVerbose, lessVerbose, isVerboseQuiet, - intToVerbosity, flagToVerbosity, - showForCabal, showForGHC, - verboseNoFlags, verboseHasFlags, - modifyVerbosity, - - -- * Call stacks - verboseCallSite, verboseCallStack, - isVerboseCallSite, isVerboseCallStack, - - -- * Output markets - verboseMarkOutput, isVerboseMarkOutput, - verboseUnmarkOutput, - - -- * Line wrapping - verboseNoWrap, isVerboseNoWrap, - - -- * Time stamps - verboseTimestamp, isVerboseTimestamp, - verboseNoTimestamp, - - -- * Stderr - verboseStderr, isVerboseStderr, - verboseNoStderr, - - -- * No warnings - verboseNoWarn, isVerboseNoWarn +module Distribution.Verbosity + ( -- * Verbosity + Verbosity + , silent + , normal + , verbose + , deafening + , moreVerbose + , lessVerbose + , isVerboseQuiet + , intToVerbosity + , flagToVerbosity + , showForCabal + , showForGHC + , verboseNoFlags + , verboseHasFlags + , modifyVerbosity + + -- * Call stacks + , verboseCallSite + , verboseCallStack + , isVerboseCallSite + , isVerboseCallStack + + -- * Output markets + , verboseMarkOutput + , isVerboseMarkOutput + , verboseUnmarkOutput + + -- * Line wrapping + , verboseNoWrap + , isVerboseNoWrap + + -- * Time stamps + , verboseTimestamp + , isVerboseTimestamp + , verboseNoTimestamp + + -- * Stderr + , verboseStderr + , isVerboseStderr + , verboseNoStderr + + -- * No warnings + , verboseNoWarn + , isVerboseNoWarn ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.ReadE import Data.List (elemIndex) import Distribution.Parsec import Distribution.Pretty -import Distribution.Verbosity.Internal import Distribution.Utils.Generic (isAsciiAlpha) +import Distribution.Verbosity.Internal import qualified Data.Set as Set import qualified Distribution.Compat.CharParsing as P import qualified Text.PrettyPrint as PP -data Verbosity = Verbosity { - vLevel :: VerbosityLevel, - vFlags :: Set VerbosityFlag, - vQuiet :: Bool - } deriving (Generic, Show, Read, Typeable) +data Verbosity = Verbosity + { vLevel :: VerbosityLevel + , vFlags :: Set VerbosityFlag + , vQuiet :: Bool + } + deriving (Generic, Show, Read, Typeable) mkVerbosity :: VerbosityLevel -> Verbosity -mkVerbosity l = Verbosity { vLevel = l, vFlags = Set.empty, vQuiet = False } +mkVerbosity l = Verbosity{vLevel = l, vFlags = Set.empty, vQuiet = False} instance Eq Verbosity where - x == y = vLevel x == vLevel y + x == y = vLevel x == vLevel y instance Ord Verbosity where - compare x y = compare (vLevel x) (vLevel y) + compare x y = compare (vLevel x) (vLevel y) instance Enum Verbosity where - toEnum = mkVerbosity . toEnum - fromEnum = fromEnum . vLevel + toEnum = mkVerbosity . toEnum + fromEnum = fromEnum . vLevel instance Bounded Verbosity where - minBound = mkVerbosity minBound - maxBound = mkVerbosity maxBound + minBound = mkVerbosity minBound + maxBound = mkVerbosity maxBound instance Binary Verbosity instance Structured Verbosity @@ -118,21 +134,21 @@ deafening = mkVerbosity Deafening -- | Increase verbosity level, but stay 'silent' if we are. moreVerbose :: Verbosity -> Verbosity moreVerbose v = - case vLevel v of - Silent -> v -- silent should stay silent - Normal -> v { vLevel = Verbose } - Verbose -> v { vLevel = Deafening } - Deafening -> v + case vLevel v of + Silent -> v -- silent should stay silent + Normal -> v{vLevel = Verbose} + Verbose -> v{vLevel = Deafening} + Deafening -> v -- | Decrease verbosity level, but stay 'deafening' if we are. lessVerbose :: Verbosity -> Verbosity lessVerbose v = - verboseQuiet $ + verboseQuiet $ case vLevel v of - Deafening -> v -- deafening stays deafening - Verbose -> v { vLevel = Normal } - Normal -> v { vLevel = Silent } - Silent -> v + Deafening -> v -- deafening stays deafening + Verbose -> v{vLevel = Normal} + Normal -> v{vLevel = Silent} + Silent -> v -- | Combinator for transforming verbosity level while retaining the -- original hidden state. @@ -146,7 +162,7 @@ lessVerbose v = -- -- @since 2.0.1.0 modifyVerbosity :: (Verbosity -> Verbosity) -> Verbosity -> Verbosity -modifyVerbosity f v = v { vLevel = vLevel (f v) } +modifyVerbosity f v = v{vLevel = vLevel (f v)} -- | Numeric verbosity level @0..3@: @0@ is 'silent', @3@ is 'deafening'. intToVerbosity :: Int -> Maybe Verbosity @@ -177,81 +193,82 @@ intToVerbosity _ = Nothing -- Right (Verbosity {vLevel = Deafening, vFlags = fromList [VCallStack,VCallSite,VNoWrap,VStderr], vQuiet = False}) -- -- /Note:/ this parser will eat trailing spaces. --- instance Parsec Verbosity where - parsec = parsecVerbosity + parsec = parsecVerbosity instance Pretty Verbosity where - pretty = PP.text . showForCabal + pretty = PP.text . showForCabal parsecVerbosity :: CabalParsing m => m Verbosity parsecVerbosity = parseIntVerbosity <|> parseStringVerbosity where parseIntVerbosity = do - i <- P.integral - case intToVerbosity i of - Just v -> return v - Nothing -> P.unexpected $ "Bad integral verbosity: " ++ show i ++ ". Valid values are 0..3" + i <- P.integral + case intToVerbosity i of + Just v -> return v + Nothing -> P.unexpected $ "Bad integral verbosity: " ++ show i ++ ". Valid values are 0..3" parseStringVerbosity = do - level <- parseVerbosityLevel - _ <- P.spaces - flags <- many (parseFlag <* P.spaces) - return $ foldl' (flip ($)) (mkVerbosity level) flags + level <- parseVerbosityLevel + _ <- P.spaces + flags <- many (parseFlag <* P.spaces) + return $ foldl' (flip ($)) (mkVerbosity level) flags parseVerbosityLevel = do - token <- P.munch1 isAsciiAlpha - case token of - "silent" -> return Silent - "normal" -> return Normal - "verbose" -> return Verbose - "debug" -> return Deafening - "deafening" -> return Deafening - _ -> P.unexpected $ "Bad verbosity level: " ++ token + token <- P.munch1 isAsciiAlpha + case token of + "silent" -> return Silent + "normal" -> return Normal + "verbose" -> return Verbose + "debug" -> return Deafening + "deafening" -> return Deafening + _ -> P.unexpected $ "Bad verbosity level: " ++ token parseFlag = do - _ <- P.char '+' - token <- P.munch1 isAsciiAlpha - case token of - "callsite" -> return verboseCallSite - "callstack" -> return verboseCallStack - "nowrap" -> return verboseNoWrap - "markoutput" -> return verboseMarkOutput - "timestamp" -> return verboseTimestamp - "stderr" -> return verboseStderr - "stdout" -> return verboseNoStderr - "nowarn" -> return verboseNoWarn - _ -> P.unexpected $ "Bad verbosity flag: " ++ token + _ <- P.char '+' + token <- P.munch1 isAsciiAlpha + case token of + "callsite" -> return verboseCallSite + "callstack" -> return verboseCallStack + "nowrap" -> return verboseNoWrap + "markoutput" -> return verboseMarkOutput + "timestamp" -> return verboseTimestamp + "stderr" -> return verboseStderr + "stdout" -> return verboseNoStderr + "nowarn" -> return verboseNoWarn + _ -> P.unexpected $ "Bad verbosity flag: " ++ token flagToVerbosity :: ReadE Verbosity flagToVerbosity = parsecToReadE id parsecVerbosity showForCabal :: Verbosity -> String showForCabal v - | Set.null (vFlags v) - = maybe (error "unknown verbosity") show $ - elemIndex v [silent,normal,verbose,deafening] - | otherwise - = unwords - $ showLevel (vLevel v) - : concatMap showFlag (Set.toList (vFlags v)) + | Set.null (vFlags v) = + maybe (error "unknown verbosity") show $ + elemIndex v [silent, normal, verbose, deafening] + | otherwise = + unwords $ + showLevel (vLevel v) + : concatMap showFlag (Set.toList (vFlags v)) where - showLevel Silent = "silent" - showLevel Normal = "normal" - showLevel Verbose = "verbose" + showLevel Silent = "silent" + showLevel Normal = "normal" + showLevel Verbose = "verbose" showLevel Deafening = "debug" - showFlag VCallSite = ["+callsite"] - showFlag VCallStack = ["+callstack"] - showFlag VNoWrap = ["+nowrap"] + showFlag VCallSite = ["+callsite"] + showFlag VCallStack = ["+callstack"] + showFlag VNoWrap = ["+nowrap"] showFlag VMarkOutput = ["+markoutput"] - showFlag VTimestamp = ["+timestamp"] - showFlag VStderr = ["+stderr"] - showFlag VNoWarn = ["+nowarn"] + showFlag VTimestamp = ["+timestamp"] + showFlag VStderr = ["+stderr"] + showFlag VNoWarn = ["+nowarn"] showForGHC :: Verbosity -> String -showForGHC v = maybe (error "unknown verbosity") show $ - elemIndex v [silent,normal,__,verbose,deafening] - where __ = silent -- this will be always ignored by elemIndex +showForGHC v = + maybe (error "unknown verbosity") show $ + elemIndex v [silent, normal, __, verbose, deafening] + where + __ = silent -- this will be always ignored by elemIndex -- | Turn on verbose call-site printing when we log. verboseCallSite :: Verbosity -> Verbosity @@ -276,7 +293,7 @@ verboseNoWrap = verboseFlag VNoWrap -- | Mark the verbosity as quiet. verboseQuiet :: Verbosity -> Verbosity -verboseQuiet v = v { vQuiet = True } +verboseQuiet v = v{vQuiet = True} -- | Turn on timestamps for log messages. verboseTimestamp :: Verbosity -> Verbosity @@ -304,15 +321,15 @@ verboseNoWarn = verboseFlag VNoWarn -- | Helper function for flag enabling functions. verboseFlag :: VerbosityFlag -> (Verbosity -> Verbosity) -verboseFlag flag v = v { vFlags = Set.insert flag (vFlags v) } +verboseFlag flag v = v{vFlags = Set.insert flag (vFlags v)} -- | Helper function for flag disabling functions. verboseNoFlag :: VerbosityFlag -> (Verbosity -> Verbosity) -verboseNoFlag flag v = v { vFlags = Set.delete flag (vFlags v) } +verboseNoFlag flag v = v{vFlags = Set.delete flag (vFlags v)} -- | Turn off all flags. verboseNoFlags :: Verbosity -> Verbosity -verboseNoFlags v = v { vFlags = Set.empty } +verboseNoFlags v = v{vFlags = Set.empty} verboseHasFlags :: Verbosity -> Bool verboseHasFlags = not . Set.null . vFlags diff --git a/Cabal/src/Distribution/Verbosity/Internal.hs b/Cabal/src/Distribution/Verbosity/Internal.hs index 21a4e6932c2..b8f55cf5b98 100644 --- a/Cabal/src/Distribution/Verbosity/Internal.hs +++ b/Cabal/src/Distribution/Verbosity/Internal.hs @@ -1,28 +1,30 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} + module Distribution.Verbosity.Internal - ( VerbosityLevel(..) - , VerbosityFlag(..) + ( VerbosityLevel (..) + , VerbosityFlag (..) ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () data VerbosityLevel = Silent | Normal | Verbose | Deafening - deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable) + deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable) instance Binary VerbosityLevel instance Structured VerbosityLevel data VerbosityFlag - = VCallStack - | VCallSite - | VNoWrap - | VMarkOutput - | VTimestamp - | VStderr -- ^ @since 3.4.0.0 - | VNoWarn - deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable) + = VCallStack + | VCallSite + | VNoWrap + | VMarkOutput + | VTimestamp + | -- | @since 3.4.0.0 + VStderr + | VNoWarn + deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable) instance Binary VerbosityFlag instance Structured VerbosityFlag diff --git a/Cabal/src/Distribution/ZinzaPrelude.hs b/Cabal/src/Distribution/ZinzaPrelude.hs index 61e8295617b..bc1d0ed6a70 100644 --- a/Cabal/src/Distribution/ZinzaPrelude.hs +++ b/Cabal/src/Distribution/ZinzaPrelude.hs @@ -1,40 +1,41 @@ -- | A small prelude used in @zinza@ generated -- template modules. -module Distribution.ZinzaPrelude ( - Writer, - execWriter, - tell, +module Distribution.ZinzaPrelude + ( Writer + , execWriter + , tell + -- * Re-exports - forM_, - Generic, - PackageName, - Version, - prettyShow - ) where + , forM_ + , Generic + , PackageName + , Version + , prettyShow + ) where import Distribution.Compat.Prelude import Prelude () -import Control.Monad (forM_) -import Distribution.Pretty (prettyShow) +import Control.Monad (forM_) +import Distribution.Pretty (prettyShow) import Distribution.Types.PackageName (PackageName) -import Distribution.Types.Version (Version) +import Distribution.Types.Version (Version) -newtype Writer a = W { unW :: ShowS -> (ShowS, a) } +newtype Writer a = W {unW :: ShowS -> (ShowS, a)} instance Functor Writer where - fmap = liftM + fmap = liftM instance Applicative Writer where - pure x = W $ \ss -> (ss, x) - (<*>) = ap + pure x = W $ \ss -> (ss, x) + (<*>) = ap instance Monad Writer where - return = pure - m >>= k = W $ \s1 -> - let (s2, x) = unW m s1 - in unW (k x) s2 - {-# INLINE (>>=) #-} + return = pure + m >>= k = W $ \s1 -> + let (s2, x) = unW m s1 + in unW (k x) s2 + {-# INLINE (>>=) #-} execWriter :: Writer a -> String execWriter w = fst (unW w id) "" diff --git a/cabal-install/Setup.hs b/cabal-install/Setup.hs index b55cb169539..00bfe1fe441 100644 --- a/cabal-install/Setup.hs +++ b/cabal-install/Setup.hs @@ -1,3 +1,4 @@ import Distribution.Simple + main :: IO () main = defaultMain diff --git a/cabal-install/main/Main.hs b/cabal-install/main/Main.hs index 56898bd8be2..767da7d0118 100644 --- a/cabal-install/main/Main.hs +++ b/cabal-install/main/Main.hs @@ -1,7 +1,7 @@ module Main (main) where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () import System.Environment (getArgs) diff --git a/cabal-install/src/Distribution/Client/BuildReports/Anonymous.hs b/cabal-install/src/Distribution/Client/BuildReports/Anonymous.hs index 6e483e2f815..ce1d1665327 100644 --- a/cabal-install/src/Distribution/Client/BuildReports/Anonymous.hs +++ b/cabal-install/src/Distribution/Client/BuildReports/Anonymous.hs @@ -1,6 +1,10 @@ -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.Reporting -- Copyright : (c) David Waern 2008 @@ -11,22 +15,20 @@ -- Portability : portable -- -- Anonymous build report data structure, printing and parsing --- ------------------------------------------------------------------------------ -module Distribution.Client.BuildReports.Anonymous ( - BuildReport(..), - InstallOutcome(..), - Outcome(..), +module Distribution.Client.BuildReports.Anonymous + ( BuildReport (..) + , InstallOutcome (..) + , Outcome (..) -- * Constructing and writing reports - newBuildReport, + , newBuildReport -- * parsing and pretty printing - parseBuildReport, - parseBuildReportList, - showBuildReport, - cabalInstallID --- showList, + , parseBuildReport + , parseBuildReportList + , showBuildReport + , cabalInstallID + -- showList, ) where import Distribution.Client.Compat.Prelude @@ -34,64 +36,70 @@ import Prelude () import Distribution.CabalSpecVersion import Distribution.Client.BuildReports.Types -import Distribution.Client.Version (cabalInstallVersion) -import Distribution.Compiler (CompilerId (..)) +import Distribution.Client.Version (cabalInstallVersion) +import Distribution.Compiler (CompilerId (..)) import Distribution.FieldGrammar import Distribution.Fields -import Distribution.Package (PackageIdentifier (..), mkPackageName) -import Distribution.PackageDescription (FlagAssignment) +import Distribution.Package (PackageIdentifier (..), mkPackageName) +import Distribution.PackageDescription (FlagAssignment) import Distribution.Parsec -import Distribution.System (Arch, OS) +import Distribution.System (Arch, OS) import qualified Distribution.Client.BuildReports.Lens as L -import qualified Distribution.Client.Types as BR (BuildFailure (..), BuildOutcome, BuildResult (..), DocsResult (..), TestsResult (..)) +import qualified Distribution.Client.Types as BR (BuildFailure (..), BuildOutcome, BuildResult (..), DocsResult (..), TestsResult (..)) -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 - ------------------------------------------------------------------------------- -- New ------------------------------------------------------------------------------- -newBuildReport :: OS -> Arch -> CompilerId -> PackageIdentifier -> FlagAssignment - -> [PackageIdentifier] -> BR.BuildOutcome -> BuildReport +newBuildReport + :: OS + -> Arch + -> CompilerId + -> PackageIdentifier + -> FlagAssignment + -> [PackageIdentifier] + -> BR.BuildOutcome + -> BuildReport newBuildReport os' arch' comp pkgid flags deps result = - BuildReport { - package = pkgid, - os = os', - arch = arch', - compiler = comp, - client = cabalInstallID, - flagAssignment = flags, - dependencies = deps, - installOutcome = convertInstallOutcome, --- cabalVersion = undefined - docsOutcome = convertDocsOutcome, - testsOutcome = convertTestsOutcome - } + BuildReport + { package = pkgid + , os = os' + , arch = arch' + , compiler = comp + , client = cabalInstallID + , flagAssignment = flags + , dependencies = deps + , installOutcome = convertInstallOutcome + , -- cabalVersion = undefined + docsOutcome = convertDocsOutcome + , testsOutcome = convertTestsOutcome + } where convertInstallOutcome = case result of - Left BR.PlanningFailed -> PlanningFailed - Left (BR.GracefulFailure _) -> PlanningFailed - Left (BR.DependentFailed p) -> DependencyFailed p - Left (BR.DownloadFailed _) -> DownloadFailed - Left (BR.UnpackFailed _) -> UnpackFailed - Left (BR.ConfigureFailed _) -> ConfigureFailed - Left (BR.BuildFailed _) -> BuildFailed - Left (BR.TestsFailed _) -> TestsFailed - Left (BR.InstallFailed _) -> InstallFailed + Left BR.PlanningFailed -> PlanningFailed + Left (BR.GracefulFailure _) -> PlanningFailed + Left (BR.DependentFailed p) -> DependencyFailed p + Left (BR.DownloadFailed _) -> DownloadFailed + Left (BR.UnpackFailed _) -> UnpackFailed + Left (BR.ConfigureFailed _) -> ConfigureFailed + Left (BR.BuildFailed _) -> BuildFailed + Left (BR.TestsFailed _) -> TestsFailed + Left (BR.InstallFailed _) -> InstallFailed Right (BR.BuildResult _ _ _) -> InstallOk convertDocsOutcome = case result of - Left _ -> NotTried - Right (BR.BuildResult BR.DocsNotTried _ _) -> NotTried - Right (BR.BuildResult BR.DocsFailed _ _) -> Failed - Right (BR.BuildResult BR.DocsOk _ _) -> Ok + Left _ -> NotTried + Right (BR.BuildResult BR.DocsNotTried _ _) -> NotTried + Right (BR.BuildResult BR.DocsFailed _ _) -> Failed + Right (BR.BuildResult BR.DocsOk _ _) -> Ok convertTestsOutcome = case result of - Left (BR.TestsFailed _) -> Failed - Left _ -> NotTried + Left (BR.TestsFailed _) -> Failed + Left _ -> NotTried Right (BR.BuildResult _ BR.TestsNotTried _) -> NotTried - Right (BR.BuildResult _ BR.TestsOk _) -> Ok + Right (BR.BuildResult _ BR.TestsOk _) -> Ok cabalInstallID :: PackageIdentifier cabalInstallID = @@ -102,35 +110,37 @@ cabalInstallID = ------------------------------------------------------------------------------- fieldDescrs - :: ( Applicative (g BuildReport), FieldGrammar c g - , c (Identity Arch) - , c (Identity CompilerId) - , c (Identity FlagAssignment) - , c (Identity InstallOutcome) - , c (Identity OS) - , c (Identity Outcome) - , c (Identity PackageIdentifier) - , c (List VCat (Identity PackageIdentifier) PackageIdentifier) - ) - => g BuildReport BuildReport -fieldDescrs = BuildReport - <$> uniqueField "package" L.package - <*> uniqueField "os" L.os - <*> uniqueField "arch" L.arch - <*> uniqueField "compiler" L.compiler - <*> uniqueField "client" L.client - <*> monoidalField "flags" L.flagAssignment - <*> monoidalFieldAla "dependencies" (alaList VCat) L.dependencies - <*> uniqueField "install-outcome" L.installOutcome - <*> uniqueField "docs-outcome" L.docsOutcome - <*> uniqueField "tests-outcome" L.testsOutcome + :: ( Applicative (g BuildReport) + , FieldGrammar c g + , c (Identity Arch) + , c (Identity CompilerId) + , c (Identity FlagAssignment) + , c (Identity InstallOutcome) + , c (Identity OS) + , c (Identity Outcome) + , c (Identity PackageIdentifier) + , c (List VCat (Identity PackageIdentifier) PackageIdentifier) + ) + => g BuildReport BuildReport +fieldDescrs = + BuildReport + <$> uniqueField "package" L.package + <*> uniqueField "os" L.os + <*> uniqueField "arch" L.arch + <*> uniqueField "compiler" L.compiler + <*> uniqueField "client" L.client + <*> monoidalField "flags" L.flagAssignment + <*> monoidalFieldAla "dependencies" (alaList VCat) L.dependencies + <*> uniqueField "install-outcome" L.installOutcome + <*> uniqueField "docs-outcome" L.docsOutcome + <*> uniqueField "tests-outcome" L.testsOutcome -- ----------------------------------------------------------------------------- -- Parsing parseBuildReport :: BS.ByteString -> Either String BuildReport parseBuildReport s = case snd $ runParseResult $ parseFields s of - Left (_, perrors) -> Left $ unlines [ err | PError _ err <- toList perrors ] + Left (_, perrors) -> Left $ unlines [err | PError _ err <- toList perrors] Right report -> Right report parseFields :: BS.ByteString -> ParseResult BuildReport @@ -138,18 +148,17 @@ parseFields input = do fields <- either (parseFatalFailure zeroPos . show) pure $ readFields input case partitionFields fields of (fields', []) -> parseFieldGrammar CabalSpecV2_4 fields' fieldDescrs - _otherwise -> parseFatalFailure zeroPos "found sections in BuildReport" + _otherwise -> parseFatalFailure zeroPos "found sections in BuildReport" parseBuildReportList :: BS.ByteString -> [BuildReport] parseBuildReportList str = - [ report | Right report <- map parseBuildReport (split str) ] - + [report | Right report <- map parseBuildReport (split str)] where split :: BS.ByteString -> [BS.ByteString] split = filter (not . BS.null) . unfoldr chunk . BS8.lines chunk [] = Nothing chunk ls = case break BS.null ls of - (r, rs) -> Just (BS8.unlines r, dropWhile BS.null rs) + (r, rs) -> Just (BS8.unlines r, dropWhile BS.null rs) -- ----------------------------------------------------------------------------- -- Pretty-printing diff --git a/cabal-install/src/Distribution/Client/BuildReports/Lens.hs b/cabal-install/src/Distribution/Client/BuildReports/Lens.hs index ca38c463415..bbf7216ee61 100644 --- a/cabal-install/src/Distribution/Client/BuildReports/Lens.hs +++ b/cabal-install/src/Distribution/Client/BuildReports/Lens.hs @@ -1,46 +1,46 @@ -module Distribution.Client.BuildReports.Lens ( - BuildReport, - module Distribution.Client.BuildReports.Lens, -) where +module Distribution.Client.BuildReports.Lens + ( BuildReport + , module Distribution.Client.BuildReports.Lens + ) where import Distribution.Client.Compat.Prelude import Distribution.Compat.Lens import Prelude () import Distribution.Client.BuildReports.Types (BuildReport, InstallOutcome, Outcome) -import Distribution.Compiler (CompilerId) -import Distribution.System (Arch, OS) -import Distribution.Types.Flag (FlagAssignment) -import Distribution.Types.PackageId (PackageIdentifier) +import Distribution.Compiler (CompilerId) +import Distribution.System (Arch, OS) +import Distribution.Types.Flag (FlagAssignment) +import Distribution.Types.PackageId (PackageIdentifier) import qualified Distribution.Client.BuildReports.Types as T package :: Lens' BuildReport PackageIdentifier -package f s = fmap (\x -> s { T.package = x }) (f (T.package s)) +package f s = fmap (\x -> s{T.package = x}) (f (T.package s)) os :: Lens' BuildReport OS -os f s = fmap (\x -> s { T.os = x }) (f (T.os s)) +os f s = fmap (\x -> s{T.os = x}) (f (T.os s)) arch :: Lens' BuildReport Arch -arch f s = fmap (\x -> s { T.arch = x }) (f (T.arch s)) +arch f s = fmap (\x -> s{T.arch = x}) (f (T.arch s)) compiler :: Lens' BuildReport CompilerId -compiler f s = fmap (\x -> s { T.compiler = x }) (f (T.compiler s)) +compiler f s = fmap (\x -> s{T.compiler = x}) (f (T.compiler s)) client :: Lens' BuildReport PackageIdentifier -client f s = fmap (\x -> s { T.client = x }) (f (T.client s)) +client f s = fmap (\x -> s{T.client = x}) (f (T.client s)) flagAssignment :: Lens' BuildReport FlagAssignment -flagAssignment f s = fmap (\x -> s { T.flagAssignment = x }) (f (T.flagAssignment s)) +flagAssignment f s = fmap (\x -> s{T.flagAssignment = x}) (f (T.flagAssignment s)) dependencies :: Lens' BuildReport [PackageIdentifier] -dependencies f s = fmap (\x -> s { T.dependencies = x }) (f (T.dependencies s)) +dependencies f s = fmap (\x -> s{T.dependencies = x}) (f (T.dependencies s)) installOutcome :: Lens' BuildReport InstallOutcome -installOutcome f s = fmap (\x -> s { T.installOutcome = x }) (f (T.installOutcome s)) +installOutcome f s = fmap (\x -> s{T.installOutcome = x}) (f (T.installOutcome s)) docsOutcome :: Lens' BuildReport Outcome -docsOutcome f s = fmap (\x -> s { T.docsOutcome = x }) (f (T.docsOutcome s)) +docsOutcome f s = fmap (\x -> s{T.docsOutcome = x}) (f (T.docsOutcome s)) testsOutcome :: Lens' BuildReport Outcome -testsOutcome f s = fmap (\x -> s { T.testsOutcome = x }) (f (T.testsOutcome s)) +testsOutcome f s = fmap (\x -> s{T.testsOutcome = x}) (f (T.testsOutcome s)) diff --git a/cabal-install/src/Distribution/Client/BuildReports/Storage.hs b/cabal-install/src/Distribution/Client/BuildReports/Storage.hs index a20f8697259..34f2c380035 100644 --- a/cabal-install/src/Distribution/Client/BuildReports/Storage.hs +++ b/cabal-install/src/Distribution/Client/BuildReports/Storage.hs @@ -1,5 +1,9 @@ {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.Reporting -- Copyright : (c) David Waern 2008 @@ -10,154 +14,204 @@ -- Portability : portable -- -- Anonymous build report data structure, printing and parsing --- ------------------------------------------------------------------------------ -module Distribution.Client.BuildReports.Storage ( - - -- * Storing and retrieving build reports - storeAnonymous, - storeLocal, --- retrieve, +module Distribution.Client.BuildReports.Storage + ( -- * Storing and retrieving build reports + storeAnonymous + , storeLocal + -- retrieve, -- * 'InstallPlan' support - fromInstallPlan, - fromPlanningFailure, + , fromInstallPlan + , fromPlanningFailure ) where import Distribution.Client.Compat.Prelude import Prelude () -import Distribution.Client.BuildReports.Anonymous (BuildReport, showBuildReport, newBuildReport) +import Distribution.Client.BuildReports.Anonymous (BuildReport, newBuildReport, showBuildReport) import qualified Distribution.Client.BuildReports.Anonymous as BuildReport -import Distribution.Client.Types -import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan - ( InstallPlan ) + ( InstallPlan + ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.Types import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.SourcePackage +import Distribution.Compiler + ( CompilerId (..) + , CompilerInfo (..) + ) import Distribution.Package - ( PackageId, packageId ) + ( PackageId + , packageId + ) import Distribution.PackageDescription - ( FlagAssignment ) + ( FlagAssignment + ) import Distribution.Simple.InstallDirs - ( PathTemplate, fromPathTemplate - , initialPathTemplateEnv, substPathTemplate ) -import Distribution.System - ( Platform(Platform) ) -import Distribution.Compiler - ( CompilerId(..), CompilerInfo(..) ) + ( PathTemplate + , fromPathTemplate + , initialPathTemplateEnv + , substPathTemplate + ) import Distribution.Simple.Utils - ( equating ) + ( equating + ) +import Distribution.System + ( Platform (Platform) + ) -import Data.List.NonEmpty - ( groupBy ) import qualified Data.List as L -import System.FilePath - ( (), takeDirectory ) +import Data.List.NonEmpty + ( groupBy + ) import System.Directory - ( createDirectoryIfMissing ) + ( createDirectoryIfMissing + ) +import System.FilePath + ( takeDirectory + , () + ) storeAnonymous :: [(BuildReport, Maybe Repo)] -> IO () -storeAnonymous reports = sequence_ - [ appendFile file (concatMap format reports') - | (repo, reports') <- separate reports - , let file = repoLocalDir repo "build-reports.log" ] - --TODO: make this concurrency safe, either lock the report file or make sure - -- the writes for each report are atomic (under 4k and flush at boundaries) - +storeAnonymous reports = + sequence_ + [ appendFile file (concatMap format reports') + | (repo, reports') <- separate reports + , let file = repoLocalDir repo "build-reports.log" + ] where + -- TODO: make this concurrency safe, either lock the report file or make sure + -- the writes for each report are atomic (under 4k and flush at boundaries) + format r = '\n' : showBuildReport r ++ "\n" - separate :: [(BuildReport, Maybe Repo)] - -> [(Repo, [BuildReport])] - separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ])) - . map (concatMap toList) - . L.groupBy (equating (repoName' . head)) - . sortBy (comparing (repoName' . head)) - . groupBy (equating repoName') - . onlyRemote - - repoName' (_,_,rrepo) = remoteRepoName rrepo - - onlyRemote :: [(BuildReport, Maybe Repo)] - -> [(BuildReport, Repo, RemoteRepo)] + separate + :: [(BuildReport, Maybe Repo)] + -> [(Repo, [BuildReport])] + separate = + map (\rs@((_, repo, _) : _) -> (repo, [r | (r, _, _) <- rs])) + . map (concatMap toList) + . L.groupBy (equating (repoName' . head)) + . sortBy (comparing (repoName' . head)) + . groupBy (equating repoName') + . onlyRemote + + repoName' (_, _, rrepo) = remoteRepoName rrepo + + onlyRemote + :: [(BuildReport, Maybe Repo)] + -> [(BuildReport, Repo, RemoteRepo)] onlyRemote rs = [ (report, repo, remoteRepo) | (report, Just repo) <- rs - , Just remoteRepo <- [maybeRepoRemote repo] + , Just remoteRepo <- [maybeRepoRemote repo] ] -storeLocal :: CompilerInfo -> [PathTemplate] -> [(BuildReport, Maybe Repo)] - -> Platform -> IO () -storeLocal cinfo templates reports platform = sequence_ - [ do createDirectoryIfMissing True (takeDirectory file) - appendFile file output - --TODO: make this concurrency safe, either lock the report file or make - -- sure the writes for each report are atomic - | (file, reports') <- groupByFileName - [ (reportFileName template report, report) - | template <- templates - , (report, _repo) <- reports ] - , let output = concatMap format reports' - ] +storeLocal + :: CompilerInfo + -> [PathTemplate] + -> [(BuildReport, Maybe Repo)] + -> Platform + -> IO () +storeLocal cinfo templates reports platform = + sequence_ + [ do + createDirectoryIfMissing True (takeDirectory file) + appendFile file output + | -- TODO: make this concurrency safe, either lock the report file or make + -- sure the writes for each report are atomic + (file, reports') <- + groupByFileName + [ (reportFileName template report, report) + | template <- templates + , (report, _repo) <- reports + ] + , let output = concatMap format reports' + ] where format r = '\n' : showBuildReport r ++ "\n" reportFileName template report = - fromPathTemplate (substPathTemplate env template) - where env = initialPathTemplateEnv - (BuildReport.package report) - -- TODO: In principle, we can support $pkgkey, but only - -- if the configure step succeeds. So add a Maybe field - -- to the build report, and either use that or make up - -- a fake identifier if it's not available. - (error "storeLocal: package key not available") - cinfo - platform - - groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp)) - . L.groupBy (equating fst) - . sortBy (comparing fst) + fromPathTemplate (substPathTemplate env template) + where + env = + initialPathTemplateEnv + (BuildReport.package report) + -- TODO: In principle, we can support $pkgkey, but only + -- if the configure step succeeds. So add a Maybe field + -- to the build report, and either use that or make up + -- a fake identifier if it's not available. + (error "storeLocal: package key not available") + cinfo + platform + + groupByFileName = + map (\grp@((filename, _) : _) -> (filename, map snd grp)) + . L.groupBy (equating fst) + . sortBy (comparing fst) -- ------------------------------------------------------------ + -- * InstallPlan support + -- ------------------------------------------------------------ -fromInstallPlan :: Platform -> CompilerId - -> InstallPlan - -> BuildOutcomes - -> [(BuildReport, Maybe Repo)] +fromInstallPlan + :: Platform + -> CompilerId + -> InstallPlan + -> BuildOutcomes + -> [(BuildReport, Maybe Repo)] fromInstallPlan platform comp plan buildOutcomes = - mapMaybe (\pkg -> fromPlanPackage - platform comp pkg - (InstallPlan.lookupBuildOutcome pkg buildOutcomes)) - . InstallPlan.toList - $ plan - -fromPlanPackage :: Platform -> CompilerId - -> InstallPlan.PlanPackage - -> Maybe BuildOutcome - -> Maybe (BuildReport, Maybe Repo) -fromPlanPackage (Platform arch os) comp - (InstallPlan.Configured (ConfiguredPackage _ srcPkg flags _ deps)) - (Just buildResult) = - Just ( newBuildReport os arch comp - (packageId srcPkg) flags - (map packageId (CD.nonSetupDeps deps)) - buildResult - , extractRepo srcPkg) - where - extractRepo (SourcePackage { srcpkgSource = RepoTarballPackage repo _ _ }) - = Just repo - extractRepo _ = Nothing - + mapMaybe + ( \pkg -> + fromPlanPackage + platform + comp + pkg + (InstallPlan.lookupBuildOutcome pkg buildOutcomes) + ) + . InstallPlan.toList + $ plan + +fromPlanPackage + :: Platform + -> CompilerId + -> InstallPlan.PlanPackage + -> Maybe BuildOutcome + -> Maybe (BuildReport, Maybe Repo) +fromPlanPackage + (Platform arch os) + comp + (InstallPlan.Configured (ConfiguredPackage _ srcPkg flags _ deps)) + (Just buildResult) = + Just + ( newBuildReport + os + arch + comp + (packageId srcPkg) + flags + (map packageId (CD.nonSetupDeps deps)) + buildResult + , extractRepo srcPkg + ) + where + extractRepo (SourcePackage{srcpkgSource = RepoTarballPackage repo _ _}) = + Just repo + extractRepo _ = Nothing fromPlanPackage _ _ _ _ = Nothing - -fromPlanningFailure :: Platform -> CompilerId - -> [PackageId] -> FlagAssignment -> [(BuildReport, Maybe Repo)] +fromPlanningFailure + :: Platform + -> CompilerId + -> [PackageId] + -> FlagAssignment + -> [(BuildReport, Maybe Repo)] fromPlanningFailure (Platform arch os) comp pkgids flags = [ (newBuildReport os arch comp pkgid flags [] (Left PlanningFailed), Nothing) - | pkgid <- pkgids ] + | pkgid <- pkgids + ] diff --git a/cabal-install/src/Distribution/Client/BuildReports/Types.hs b/cabal-install/src/Distribution/Client/BuildReports/Types.hs index dc5b8e2ce1b..576d058c4bf 100644 --- a/cabal-install/src/Distribution/Client/BuildReports/Types.hs +++ b/cabal-install/src/Distribution/Client/BuildReports/Types.hs @@ -1,5 +1,9 @@ {-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.BuildReports.Types -- Copyright : (c) Duncan Coutts 2009 @@ -9,25 +13,23 @@ -- Portability : portable -- -- Types related to build reporting --- ------------------------------------------------------------------------------ -module Distribution.Client.BuildReports.Types ( - ReportLevel(..), - BuildReport (..), - InstallOutcome(..), - Outcome(..), -) where +module Distribution.Client.BuildReports.Types + ( ReportLevel (..) + , BuildReport (..) + , InstallOutcome (..) + , Outcome (..) + ) where import Distribution.Client.Compat.Prelude import Prelude () import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp +import qualified Text.PrettyPrint as Disp -import Distribution.Compiler (CompilerId (..)) +import Distribution.Compiler (CompilerId (..)) import Distribution.PackageDescription (FlagAssignment) -import Distribution.System (Arch, OS) -import Distribution.Types.PackageId (PackageIdentifier) +import Distribution.System (Arch, OS) +import Distribution.Types.PackageId (PackageIdentifier) ------------------------------------------------------------------------------- -- ReportLevel @@ -40,18 +42,18 @@ instance Binary ReportLevel instance Structured ReportLevel instance Pretty ReportLevel where - pretty NoReports = Disp.text "none" + pretty NoReports = Disp.text "none" pretty AnonymousReports = Disp.text "anonymous" - pretty DetailedReports = Disp.text "detailed" + pretty DetailedReports = Disp.text "detailed" instance Parsec ReportLevel where parsec = do name <- P.munch1 isAlpha case lowercase name of - "none" -> return NoReports - "anonymous" -> return AnonymousReports - "detailed" -> return DetailedReports - _ -> P.unexpected $ "ReportLevel: " ++ name + "none" -> return NoReports + "anonymous" -> return AnonymousReports + "detailed" -> return DetailedReports + _ -> P.unexpected $ "ReportLevel: " ++ name lowercase :: String -> String lowercase = map toLower @@ -60,89 +62,79 @@ lowercase = map toLower -- BuildReport ------------------------------------------------------------------------------- -data BuildReport = BuildReport { - -- | The package this build report is about - package :: PackageIdentifier, - - -- | The OS and Arch the package was built on - os :: OS, - arch :: Arch, - - -- | The Haskell compiler (and hopefully version) used - compiler :: CompilerId, - - -- | The uploading client, ie cabal-install-x.y.z - client :: PackageIdentifier, - - -- | Which configurations flags we used - flagAssignment :: FlagAssignment, - - -- | Which dependent packages we were using exactly - dependencies :: [PackageIdentifier], - - -- | Did installing work ok? - installOutcome :: InstallOutcome, - - -- Which version of the Cabal library was used to compile the Setup.hs --- cabalVersion :: Version, +data BuildReport = BuildReport + { package :: PackageIdentifier + -- ^ The package this build report is about + , os :: OS + -- ^ The OS and Arch the package was built on + , arch :: Arch + , compiler :: CompilerId + -- ^ The Haskell compiler (and hopefully version) used + , client :: PackageIdentifier + -- ^ The uploading client, ie cabal-install-x.y.z + , flagAssignment :: FlagAssignment + -- ^ Which configurations flags we used + , dependencies :: [PackageIdentifier] + -- ^ Which dependent packages we were using exactly + , installOutcome :: InstallOutcome + -- ^ Did installing work ok? + , -- Which version of the Cabal library was used to compile the Setup.hs + -- cabalVersion :: Version, -- Which build tools we were using (with versions) --- tools :: [PackageIdentifier], - - -- | Configure outcome, did configure work ok? - docsOutcome :: Outcome, + -- tools :: [PackageIdentifier], - -- | Configure outcome, did configure work ok? - testsOutcome :: Outcome + docsOutcome :: Outcome + -- ^ Configure outcome, did configure work ok? + , testsOutcome :: Outcome + -- ^ Configure outcome, did configure work ok? } deriving (Eq, Show, Generic) - - ------------------------------------------------------------------------------- -- InstallOutcome ------------------------------------------------------------------------------- data InstallOutcome - = PlanningFailed - | DependencyFailed PackageIdentifier - | DownloadFailed - | UnpackFailed - | SetupFailed - | ConfigureFailed - | BuildFailed - | TestsFailed - | InstallFailed - | InstallOk + = PlanningFailed + | DependencyFailed PackageIdentifier + | DownloadFailed + | UnpackFailed + | SetupFailed + | ConfigureFailed + | BuildFailed + | TestsFailed + | InstallFailed + | InstallOk deriving (Eq, Show, Generic) instance Pretty InstallOutcome where - pretty PlanningFailed = Disp.text "PlanningFailed" + pretty PlanningFailed = Disp.text "PlanningFailed" pretty (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> pretty pkgid - pretty DownloadFailed = Disp.text "DownloadFailed" - pretty UnpackFailed = Disp.text "UnpackFailed" - pretty SetupFailed = Disp.text "SetupFailed" + pretty DownloadFailed = Disp.text "DownloadFailed" + pretty UnpackFailed = Disp.text "UnpackFailed" + pretty SetupFailed = Disp.text "SetupFailed" pretty ConfigureFailed = Disp.text "ConfigureFailed" - pretty BuildFailed = Disp.text "BuildFailed" - pretty TestsFailed = Disp.text "TestsFailed" - pretty InstallFailed = Disp.text "InstallFailed" - pretty InstallOk = Disp.text "InstallOk" + pretty BuildFailed = Disp.text "BuildFailed" + pretty TestsFailed = Disp.text "TestsFailed" + pretty InstallFailed = Disp.text "InstallFailed" + pretty InstallOk = Disp.text "InstallOk" instance Parsec InstallOutcome where parsec = do name <- P.munch1 isAlpha case name of - "PlanningFailed" -> return PlanningFailed + "PlanningFailed" -> return PlanningFailed "DependencyFailed" -> DependencyFailed <$ P.spaces <*> parsec - "DownloadFailed" -> return DownloadFailed - "UnpackFailed" -> return UnpackFailed - "SetupFailed" -> return SetupFailed - "ConfigureFailed" -> return ConfigureFailed - "BuildFailed" -> return BuildFailed - "TestsFailed" -> return TestsFailed - "InstallFailed" -> return InstallFailed - "InstallOk" -> return InstallOk - _ -> P.unexpected $ "InstallOutcome: " ++ name + "DownloadFailed" -> return DownloadFailed + "UnpackFailed" -> return UnpackFailed + "SetupFailed" -> return SetupFailed + "ConfigureFailed" -> return ConfigureFailed + "BuildFailed" -> return BuildFailed + "TestsFailed" -> return TestsFailed + "InstallFailed" -> return InstallFailed + "InstallOk" -> return InstallOk + _ -> P.unexpected $ "InstallOutcome: " ++ name ------------------------------------------------------------------------------- -- Outcome @@ -153,14 +145,14 @@ data Outcome = NotTried | Failed | Ok instance Pretty Outcome where pretty NotTried = Disp.text "NotTried" - pretty Failed = Disp.text "Failed" - pretty Ok = Disp.text "Ok" + pretty Failed = Disp.text "Failed" + pretty Ok = Disp.text "Ok" instance Parsec Outcome where parsec = do name <- P.munch1 isAlpha case name of "NotTried" -> return NotTried - "Failed" -> return Failed - "Ok" -> return Ok - _ -> P.unexpected $ "Outcome: " ++ name + "Failed" -> return Failed + "Ok" -> return Ok + _ -> P.unexpected $ "Outcome: " ++ name diff --git a/cabal-install/src/Distribution/Client/BuildReports/Upload.hs b/cabal-install/src/Distribution/Client/BuildReports/Upload.hs index 28ca9353882..d7ce5d0e7bc 100644 --- a/cabal-install/src/Distribution/Client/BuildReports/Upload.hs +++ b/cabal-install/src/Distribution/Client/BuildReports/Upload.hs @@ -1,11 +1,13 @@ -{-# LANGUAGE CPP, PatternGuards #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternGuards #-} + -- This is a quick hack for uploading build reports to Hackage. module Distribution.Client.BuildReports.Upload - ( BuildLog - , BuildReportId - , uploadReports - ) where + ( BuildLog + , BuildReportId + , uploadReports + ) where import Distribution.Client.Compat.Prelude import Prelude () @@ -18,16 +20,18 @@ import Network.HTTP , Request(..), RequestMethod(..), Response(..) ) import Network.TCP (HandleStream) -} -import Network.URI (URI, uriPath) --parseRelativeReference, relativeTo) +import Network.URI (URI, uriPath) -- parseRelativeReference, relativeTo) -import System.FilePath.Posix - ( () ) -import qualified Distribution.Client.BuildReports.Anonymous as BuildReport import Distribution.Client.BuildReports.Anonymous (BuildReport, showBuildReport) -import Distribution.Simple.Utils (die') +import qualified Distribution.Client.BuildReports.Anonymous as BuildReport import Distribution.Client.HttpUtils import Distribution.Client.Setup - ( RepoContext(..) ) + ( RepoContext (..) + ) +import Distribution.Simple.Utils (die') +import System.FilePath.Posix + ( () + ) type BuildReportId = URI type BuildLog = String @@ -35,20 +39,21 @@ type BuildLog = String uploadReports :: Verbosity -> RepoContext -> (String, String) -> URI -> [(BuildReport, Maybe BuildLog)] -> IO () uploadReports verbosity repoCtxt auth uri reports = do for_ reports $ \(report, mbBuildLog) -> do - buildId <- postBuildReport verbosity repoCtxt auth uri report - case mbBuildLog of - Just buildLog -> putBuildLog verbosity repoCtxt auth buildId buildLog - Nothing -> return () + buildId <- postBuildReport verbosity repoCtxt auth uri report + case mbBuildLog of + Just buildLog -> putBuildLog verbosity repoCtxt auth buildId buildLog + Nothing -> return () postBuildReport :: Verbosity -> RepoContext -> (String, String) -> URI -> BuildReport -> IO BuildReportId postBuildReport verbosity repoCtxt auth uri buildReport = do - let fullURI = uri { uriPath = "/package" prettyShow (BuildReport.package buildReport) "reports" } + let fullURI = uri{uriPath = "/package" prettyShow (BuildReport.package buildReport) "reports"} transport <- repoContextGetTransport repoCtxt res <- postHttp transport verbosity fullURI (showBuildReport buildReport) (Just auth) case res of - (303, redir) -> return $ undefined redir --TODO parse redir + (303, redir) -> return $ undefined redir -- TODO parse redir _ -> die' verbosity "unrecognized response" -- give response +{- FOURMOLU_DISABLE -} {- setAllowRedirects False (_, response) <- request Request { @@ -75,15 +80,19 @@ postBuildReport verbosity repoCtxt auth uri buildReport = do _ -> error "Unrecognised response from server." where body = BuildReport.show buildReport -} - +{- FOURMOLU_ENABLE -} -- TODO force this to be a PUT? -putBuildLog :: Verbosity -> RepoContext -> (String, String) - -> BuildReportId -> BuildLog - -> IO () +putBuildLog + :: Verbosity + -> RepoContext + -> (String, String) + -> BuildReportId + -> BuildLog + -> IO () putBuildLog verbosity repoCtxt auth reportId buildLog = do - let fullURI = reportId {uriPath = uriPath reportId "log"} + let fullURI = reportId{uriPath = uriPath reportId "log"} transport <- repoContextGetTransport repoCtxt res <- postHttp transport verbosity fullURI buildLog (Just auth) case res of diff --git a/cabal-install/src/Distribution/Client/Check.hs b/cabal-install/src/Distribution/Client/Check.hs index f032b148555..654725971bc 100644 --- a/cabal-install/src/Distribution/Client/Check.hs +++ b/cabal-install/src/Distribution/Client/Check.hs @@ -1,5 +1,9 @@ {-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.Check -- Copyright : (c) Lennart Kolmodin 2008 @@ -10,43 +14,42 @@ -- Portability : portable -- -- Check a package for common mistakes --- ------------------------------------------------------------------------------ -module Distribution.Client.Check ( - check +module Distribution.Client.Check + ( check ) where - import Distribution.Client.Compat.Prelude import Prelude () -import Distribution.Client.Utils.Parsec (renderParseError) -import Distribution.PackageDescription (GenericPackageDescription) +import Distribution.Client.Utils.Parsec (renderParseError) +import Distribution.PackageDescription (GenericPackageDescription) import Distribution.PackageDescription.Check import Distribution.PackageDescription.Configuration (flattenPackageDescription) import Distribution.PackageDescription.Parsec - (parseGenericPackageDescription, runParseResult) -import Distribution.Parsec (PWarning (..), showPError) -import Distribution.Simple.Utils (defaultPackageDesc, die', notice, warn) -import System.IO (hPutStr, stderr) + ( parseGenericPackageDescription + , runParseResult + ) +import Distribution.Parsec (PWarning (..), showPError) +import Distribution.Simple.Utils (defaultPackageDesc, die', notice, warn) +import System.IO (hPutStr, stderr) -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS import qualified System.Directory as Dir readGenericPackageDescriptionCheck :: Verbosity -> FilePath -> IO ([PWarning], GenericPackageDescription) readGenericPackageDescriptionCheck verbosity fpath = do - exists <- Dir.doesFileExist fpath - unless exists $ - die' verbosity $ - "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue." - bs <- BS.readFile fpath - let (warnings, result) = runParseResult (parseGenericPackageDescription bs) - case result of - Left (_, errors) -> do - traverse_ (warn verbosity . showPError fpath) errors - hPutStr stderr $ renderParseError fpath bs errors warnings - die' verbosity "parse error" - Right x -> return (warnings, x) + exists <- Dir.doesFileExist fpath + unless exists $ + die' verbosity $ + "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue." + bs <- BS.readFile fpath + let (warnings, result) = runParseResult (parseGenericPackageDescription bs) + case result of + Left (_, errors) -> do + traverse_ (warn verbosity . showPError fpath) errors + hPutStr stderr $ renderParseError fpath bs errors warnings + die' verbosity "parse error" + Right x -> return (warnings, x) -- | Checks a packge for common errors. Returns @True@ if the package -- is fit to upload to Hackage, @False@ otherwise. @@ -54,59 +57,60 @@ readGenericPackageDescriptionCheck verbosity fpath = do -- the '.cabal' file. check :: Verbosity -> IO Bool check verbosity = do - pdfile <- defaultPackageDesc verbosity - (ws, ppd) <- readGenericPackageDescriptionCheck verbosity pdfile - -- convert parse warnings into PackageChecks - let ws' = map (wrapParseWarning pdfile) ws - -- flatten the generic package description into a regular package - -- description - -- TODO: this may give more warnings than it should give; - -- consider two branches of a condition, one saying - -- ghc-options: -Wall - -- and the other - -- ghc-options: -Werror - -- joined into - -- ghc-options: -Wall -Werror - -- checkPackages will yield a warning on the last line, but it - -- would not on each individual branch. - -- However, this is the same way hackage does it, so we will yield - -- the exact same errors as it will. - let pkg_desc = flattenPackageDescription ppd - ioChecks <- checkPackageFiles verbosity pkg_desc "." - let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc) ++ ws' - buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ] - buildWarning = [ x | x@PackageBuildWarning {} <- packageChecks ] - distSuspicious = [ x | x@PackageDistSuspicious {} <- packageChecks ] - ++ [ x | x@PackageDistSuspiciousWarn {} <- packageChecks ] - distInexusable = [ x | x@PackageDistInexcusable {} <- packageChecks ] - - unless (null buildImpossible) $ do - warn verbosity "The package will not build sanely due to these errors:" - printCheckMessages buildImpossible - - unless (null buildWarning) $ do - warn verbosity "The following warnings are likely to affect your build negatively:" - printCheckMessages buildWarning - - unless (null distSuspicious) $ do - warn verbosity "These warnings may cause trouble when distributing the package:" - printCheckMessages distSuspicious - - unless (null distInexusable) $ do - warn verbosity "The following errors will cause portability problems on other environments:" - printCheckMessages distInexusable - - let errors = filter isHackageDistError packageChecks - - unless (null errors) $ - warn verbosity "Hackage would reject this package." - - when (null packageChecks) $ - notice verbosity "No errors or warnings could be found in the package." - - return (null errors) + pdfile <- defaultPackageDesc verbosity + (ws, ppd) <- readGenericPackageDescriptionCheck verbosity pdfile + -- convert parse warnings into PackageChecks + let ws' = map (wrapParseWarning pdfile) ws + -- flatten the generic package description into a regular package + -- description + -- TODO: this may give more warnings than it should give; + -- consider two branches of a condition, one saying + -- ghc-options: -Wall + -- and the other + -- ghc-options: -Werror + -- joined into + -- ghc-options: -Wall -Werror + -- checkPackages will yield a warning on the last line, but it + -- would not on each individual branch. + -- However, this is the same way hackage does it, so we will yield + -- the exact same errors as it will. + let pkg_desc = flattenPackageDescription ppd + ioChecks <- checkPackageFiles verbosity pkg_desc "." + let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc) ++ ws' + buildImpossible = [x | x@PackageBuildImpossible{} <- packageChecks] + buildWarning = [x | x@PackageBuildWarning{} <- packageChecks] + distSuspicious = + [x | x@PackageDistSuspicious{} <- packageChecks] + ++ [x | x@PackageDistSuspiciousWarn{} <- packageChecks] + distInexusable = [x | x@PackageDistInexcusable{} <- packageChecks] + + unless (null buildImpossible) $ do + warn verbosity "The package will not build sanely due to these errors:" + printCheckMessages buildImpossible + unless (null buildWarning) $ do + warn verbosity "The following warnings are likely to affect your build negatively:" + printCheckMessages buildWarning + + unless (null distSuspicious) $ do + warn verbosity "These warnings may cause trouble when distributing the package:" + printCheckMessages distSuspicious + + unless (null distInexusable) $ do + warn verbosity "The following errors will cause portability problems on other environments:" + printCheckMessages distInexusable + + let errors = filter isHackageDistError packageChecks + + unless (null errors) $ + warn verbosity "Hackage would reject this package." + + when (null packageChecks) $ + notice verbosity "No errors or warnings could be found in the package." + + return (null errors) where printCheckMessages :: [PackageCheck] -> IO () printCheckMessages = traverse_ (warn verbosity) . map show - -- xxx mapM_ o traverse? + +-- xxx mapM_ o traverse? diff --git a/cabal-install/src/Distribution/Client/CmdBench.hs b/cabal-install/src/Distribution/Client/CmdBench.hs index ee90cf09498..8c69633ac96 100644 --- a/cabal-install/src/Distribution/Client/CmdBench.hs +++ b/cabal-install/src/Distribution/Client/CmdBench.hs @@ -1,81 +1,106 @@ {-# LANGUAGE RecordWildCards #-} -- | cabal-install CLI command: bench --- -module Distribution.Client.CmdBench ( - -- * The @bench@ CLI and action - benchCommand, - benchAction, +module Distribution.Client.CmdBench + ( -- * The @bench@ CLI and action + benchCommand + , benchAction -- * Internals exposed for testing - componentNotBenchmarkProblem, - isSubComponentProblem, - noBenchmarksProblem, - selectPackageTargets, - selectComponentTarget + , componentNotBenchmarkProblem + , isSubComponentProblem + , noBenchmarksProblem + , selectPackageTargets + , selectComponentTarget ) where import Distribution.Client.Compat.Prelude import Prelude () -import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages - ( renderTargetSelector, showTargetSelector, renderTargetProblem, - renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs, - targetSelectorFilter ) -import Distribution.Client.TargetProblem - ( TargetProblem (..) ) + ( plural + , renderTargetProblem + , renderTargetProblemNoTargets + , renderTargetSelector + , showTargetSelector + , targetSelectorFilter + , targetSelectorPluralPkgs + ) import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) + ( NixStyleFlags (..) + , defaultNixStyleFlags + , nixStyleOptions + ) +import Distribution.Client.ProjectOrchestration import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..) ) + ( ConfigFlags (..) + , GlobalFlags + ) +import Distribution.Client.TargetProblem + ( TargetProblem (..) + ) import Distribution.Client.Utils - ( giveRTSWarning ) -import Distribution.Simple.Flag - ( fromFlagOrDefault ) + ( giveRTSWarning + ) import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) -import Distribution.Verbosity - ( normal ) + ( CommandUI (..) + , usageAlternatives + ) +import Distribution.Simple.Flag + ( fromFlagOrDefault + ) import Distribution.Simple.Utils - ( wrapText, die', warn ) + ( die' + , warn + , wrapText + ) +import Distribution.Verbosity + ( normal + ) import GHC.Environment - ( getFullArgs ) + ( getFullArgs + ) benchCommand :: CommandUI (NixStyleFlags ()) -benchCommand = CommandUI { - commandName = "v2-bench", - commandSynopsis = "Run benchmarks.", - commandUsage = usageAlternatives "v2-bench" [ "[TARGETS] [FLAGS]" ], - commandDescription = Just $ \_ -> wrapText $ - "Runs the specified benchmarks, first ensuring they are up to " - ++ "date.\n\n" - - ++ "Any benchmark in any package in the project can be specified. " - ++ "A package can be specified in which case all the benchmarks in the " - ++ "package are run. The default is to run all the benchmarks in the " - ++ "package in the current directory.\n\n" - - ++ "Dependencies are built or rebuilt as necessary. Additional " - ++ "configuration flags can be specified on the command line and these " - ++ "extend the project configuration from the 'cabal.project', " - ++ "'cabal.project.local' and other files.", - commandNotes = Just $ \pname -> +benchCommand = + CommandUI + { commandName = "v2-bench" + , commandSynopsis = "Run benchmarks." + , commandUsage = usageAlternatives "v2-bench" ["[TARGETS] [FLAGS]"] + , commandDescription = Just $ \_ -> + wrapText $ + "Runs the specified benchmarks, first ensuring they are up to " + ++ "date.\n\n" + ++ "Any benchmark in any package in the project can be specified. " + ++ "A package can be specified in which case all the benchmarks in the " + ++ "package are run. The default is to run all the benchmarks in the " + ++ "package in the current directory.\n\n" + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files." + , commandNotes = Just $ \pname -> "Examples:\n" - ++ " " ++ pname ++ " v2-bench\n" - ++ " Run all the benchmarks in the package in the current directory\n" - ++ " " ++ pname ++ " v2-bench pkgname\n" - ++ " Run all the benchmarks in the package named pkgname\n" - ++ " " ++ pname ++ " v2-bench cname\n" - ++ " Run the benchmark named cname\n" - ++ " " ++ pname ++ " v2-bench cname -O2\n" - ++ " Run the benchmark built with '-O2' (including local libs used)\n" - - , commandDefaultFlags = defaultNixStyleFlags () - , commandOptions = nixStyleOptions (const []) - } - + ++ " " + ++ pname + ++ " v2-bench\n" + ++ " Run all the benchmarks in the package in the current directory\n" + ++ " " + ++ pname + ++ " v2-bench pkgname\n" + ++ " Run all the benchmarks in the package named pkgname\n" + ++ " " + ++ pname + ++ " v2-bench cname\n" + ++ " Run the benchmark named cname\n" + ++ " " + ++ pname + ++ " v2-bench cname -O2\n" + ++ " Run the benchmark built with '-O2' (including local libs used)\n" + , commandDefaultFlags = defaultNixStyleFlags () + , commandOptions = nixStyleOptions (const []) + } -- | The @build@ command does a lot. It brings the install plan up to date, -- selects that part of the plan needed by the given or implicit targets and @@ -83,52 +108,56 @@ benchCommand = CommandUI { -- -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" --- benchAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -benchAction flags@NixStyleFlags {..} targetStrings globalFlags = do - - baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand - - targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) (Just BenchKind) targetStrings - - buildCtx <- - runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - - when (buildSettingOnlyDeps (buildSettings baseCtx)) $ - die' verbosity $ - "The bench command does not support '--only-dependencies'. " - ++ "You may wish to use 'build --only-dependencies' and then " - ++ "use 'bench'." - - fullArgs <- getFullArgs - when ("+RTS" `elem` fullArgs) $ - warn verbosity $ giveRTSWarning "bench" - - -- Interpret the targets on the command line as bench targets - -- (as opposed to say build or haddock targets). - targets <- either (reportTargetProblems verbosity) return - $ resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors - - let elaboratedPlan' = pruneInstallPlanToTargets - TargetActionBench - targets - elaboratedPlan - return (elaboratedPlan', targets) - - printPlan verbosity baseCtx buildCtx - - buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx - runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes +benchAction flags@NixStyleFlags{..} targetStrings globalFlags = do + baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand + + targetSelectors <- + either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx) (Just BenchKind) targetStrings + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + die' verbosity $ + "The bench command does not support '--only-dependencies'. " + ++ "You may wish to use 'build --only-dependencies' and then " + ++ "use 'bench'." + + fullArgs <- getFullArgs + when ("+RTS" `elem` fullArgs) $ + warn verbosity $ + giveRTSWarning "bench" + + -- Interpret the targets on the command line as bench targets + -- (as opposed to say build or haddock targets). + targets <- + either (reportTargetProblems verbosity) return $ + resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + let elaboratedPlan' = + pruneInstallPlanToTargets + TargetActionBench + targets + elaboratedPlan + return (elaboratedPlan', targets) + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - cliConfig = commandLineFlagsToProjectConfig globalFlags flags - mempty -- ClientInstallFlags, not needed here + cliConfig = + commandLineFlagsToProjectConfig + globalFlags + flags + mempty -- ClientInstallFlags, not needed here -- | This defines what a 'TargetSelector' means for the @bench@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, @@ -136,126 +165,133 @@ benchAction flags@NixStyleFlags {..} targetStrings globalFlags = do -- -- For the @bench@ command we select all buildable benchmarks, -- or fail if there are no benchmarks or no buildable benchmarks. --- -selectPackageTargets :: TargetSelector - -> [AvailableTarget k] -> Either BenchTargetProblem [k] +selectPackageTargets + :: TargetSelector + -> [AvailableTarget k] + -> Either BenchTargetProblem [k] selectPackageTargets targetSelector targets - - -- If there are any buildable benchmark targets then we select those - | not (null targetsBenchBuildable) - = Right targetsBenchBuildable - - -- If there are benchmarks but none are buildable then we report those - | not (null targetsBench) - = Left (TargetProblemNoneEnabled targetSelector targetsBench) - - -- If there are no benchmarks but some other targets then we report that - | not (null targets) - = Left (noBenchmarksProblem targetSelector) - - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) + -- If there are any buildable benchmark targets then we select those + | not (null targetsBenchBuildable) = + Right targetsBenchBuildable + -- If there are benchmarks but none are buildable then we report those + | not (null targetsBench) = + Left (TargetProblemNoneEnabled targetSelector targetsBench) + -- If there are no benchmarks but some other targets then we report that + | not (null targets) = + Left (noBenchmarksProblem targetSelector) + -- If there are no targets at all then we report that + | otherwise = + Left (TargetProblemNoTargets targetSelector) where - targetsBenchBuildable = selectBuildableTargets - . filterTargetsKind BenchKind - $ targets - - targetsBench = forgetTargetsDetail - . filterTargetsKind BenchKind - $ targets + targetsBenchBuildable = + selectBuildableTargets + . filterTargetsKind BenchKind + $ targets + targetsBench = + forgetTargetsDetail + . filterTargetsKind BenchKind + $ targets -- | For a 'TargetComponent' 'TargetSelector', check if the component can be -- selected. -- -- For the @bench@ command we just need to check it is a benchmark, in addition -- to the basic checks on being buildable etc. --- -selectComponentTarget :: SubComponentTarget - -> AvailableTarget k -> Either BenchTargetProblem k +selectComponentTarget + :: SubComponentTarget + -> AvailableTarget k + -> Either BenchTargetProblem k selectComponentTarget subtarget@WholeComponent t - | CBenchName _ <- availableTargetComponentName t - = selectComponentTargetBasic subtarget t - | otherwise - = Left (componentNotBenchmarkProblem - (availableTargetPackageId t) - (availableTargetComponentName t)) - -selectComponentTarget subtarget t - = Left (isSubComponentProblem - (availableTargetPackageId t) - (availableTargetComponentName t) - subtarget) + | CBenchName _ <- availableTargetComponentName t = + selectComponentTargetBasic subtarget t + | otherwise = + Left + ( componentNotBenchmarkProblem + (availableTargetPackageId t) + (availableTargetComponentName t) + ) +selectComponentTarget subtarget t = + Left + ( isSubComponentProblem + (availableTargetPackageId t) + (availableTargetComponentName t) + subtarget + ) -- | The various error conditions that can occur when matching a -- 'TargetSelector' against 'AvailableTarget's for the @bench@ command. --- -data BenchProblem = - -- | The 'TargetSelector' matches targets but no benchmarks - TargetProblemNoBenchmarks TargetSelector - - -- | The 'TargetSelector' refers to a component that is not a benchmark - | TargetProblemComponentNotBenchmark PackageId ComponentName - - -- | Asking to benchmark an individual file or module is not supported - | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget +data BenchProblem + = -- | The 'TargetSelector' matches targets but no benchmarks + TargetProblemNoBenchmarks TargetSelector + | -- | The 'TargetSelector' refers to a component that is not a benchmark + TargetProblemComponentNotBenchmark PackageId ComponentName + | -- | Asking to benchmark an individual file or module is not supported + TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget deriving (Eq, Show) - type BenchTargetProblem = TargetProblem BenchProblem noBenchmarksProblem :: TargetSelector -> TargetProblem BenchProblem noBenchmarksProblem = CustomTargetProblem . TargetProblemNoBenchmarks componentNotBenchmarkProblem :: PackageId -> ComponentName -> TargetProblem BenchProblem -componentNotBenchmarkProblem pkgid name = CustomTargetProblem $ - TargetProblemComponentNotBenchmark pkgid name +componentNotBenchmarkProblem pkgid name = + CustomTargetProblem $ + TargetProblemComponentNotBenchmark pkgid name isSubComponentProblem :: PackageId -> ComponentName -> SubComponentTarget -> TargetProblem BenchProblem -isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $ +isSubComponentProblem pkgid name subcomponent = + CustomTargetProblem $ TargetProblemIsSubComponent pkgid name subcomponent reportTargetProblems :: Verbosity -> [BenchTargetProblem] -> IO a reportTargetProblems verbosity = - die' verbosity . unlines . map renderBenchTargetProblem + die' verbosity . unlines . map renderBenchTargetProblem renderBenchTargetProblem :: BenchTargetProblem -> String renderBenchTargetProblem (TargetProblemNoTargets targetSelector) = - case targetSelectorFilter targetSelector of - Just kind | kind /= BenchKind - -> "The bench command is for running benchmarks, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ "." - - _ -> renderTargetProblemNoTargets "benchmark" targetSelector + case targetSelectorFilter targetSelector of + Just kind + | kind /= BenchKind -> + "The bench command is for running benchmarks, but the target '" + ++ showTargetSelector targetSelector + ++ "' refers to " + ++ renderTargetSelector targetSelector + ++ "." + _ -> renderTargetProblemNoTargets "benchmark" targetSelector renderBenchTargetProblem problem = - renderTargetProblem "benchmark" renderBenchProblem problem + renderTargetProblem "benchmark" renderBenchProblem problem renderBenchProblem :: BenchProblem -> String renderBenchProblem (TargetProblemNoBenchmarks targetSelector) = - "Cannot run benchmarks for the target '" ++ showTargetSelector targetSelector - ++ "' which refers to " ++ renderTargetSelector targetSelector - ++ " because " - ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" - ++ " not contain any benchmarks." - + "Cannot run benchmarks for the target '" + ++ showTargetSelector targetSelector + ++ "' which refers to " + ++ renderTargetSelector targetSelector + ++ " because " + ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" + ++ " not contain any benchmarks." renderBenchProblem (TargetProblemComponentNotBenchmark pkgid cname) = - "The bench command is for running benchmarks, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ " from the package " - ++ prettyShow pkgid ++ "." + "The bench command is for running benchmarks, but the target '" + ++ showTargetSelector targetSelector + ++ "' refers to " + ++ renderTargetSelector targetSelector + ++ " from the package " + ++ prettyShow pkgid + ++ "." where targetSelector = TargetComponent pkgid cname WholeComponent - renderBenchProblem (TargetProblemIsSubComponent pkgid cname subtarget) = - "The bench command can only run benchmarks as a whole, " - ++ "not files or modules within them, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ "." + "The bench command can only run benchmarks as a whole, " + ++ "not files or modules within them, but the target '" + ++ showTargetSelector targetSelector + ++ "' refers to " + ++ renderTargetSelector targetSelector + ++ "." where targetSelector = TargetComponent pkgid cname subtarget diff --git a/cabal-install/src/Distribution/Client/CmdBuild.hs b/cabal-install/src/Distribution/Client/CmdBuild.hs index 9c8943d939e..8f423cd0839 100644 --- a/cabal-install/src/Distribution/Client/CmdBuild.hs +++ b/cabal-install/src/Distribution/Client/CmdBuild.hs @@ -1,94 +1,128 @@ {-# LANGUAGE RecordWildCards #-} --- | cabal-install CLI command: build --- -module Distribution.Client.CmdBuild ( - -- * The @build@ CLI and action - buildCommand, - buildAction, - BuildFlags(..), - defaultBuildFlags, +-- | cabal-install CLI command: build +module Distribution.Client.CmdBuild + ( -- * The @build@ CLI and action + buildCommand + , buildAction + , BuildFlags (..) + , defaultBuildFlags -- * Internals exposed for testing - selectPackageTargets, - selectComponentTarget + , selectPackageTargets + , selectComponentTarget ) where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () +import Distribution.Client.CmdErrorMessages import Distribution.Client.ProjectFlags - ( removeIgnoreProjectOption ) + ( removeIgnoreProjectOption + ) import Distribution.Client.ProjectOrchestration import Distribution.Client.TargetProblem - ( TargetProblem (..), TargetProblem' ) -import Distribution.Client.CmdErrorMessages + ( TargetProblem (..) + , TargetProblem' + ) import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) + ( NixStyleFlags (..) + , defaultNixStyleFlags + , nixStyleOptions + ) +import Distribution.Client.ScriptUtils + ( AcceptNoTargets (..) + , TargetContext (..) + , updateContextAndWriteProjectFile + , withContextAndSelectors + ) import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), yesNoOpt ) -import Distribution.Simple.Flag ( Flag(..), toFlag, fromFlag, fromFlagOrDefault ) + ( ConfigFlags (..) + , GlobalFlags + , yesNoOpt + ) import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives, option ) -import Distribution.Verbosity - ( normal ) + ( CommandUI (..) + , option + , usageAlternatives + ) +import Distribution.Simple.Flag (Flag (..), fromFlag, fromFlagOrDefault, toFlag) import Distribution.Simple.Utils - ( wrapText, die' ) -import Distribution.Client.ScriptUtils - ( AcceptNoTargets(..), withContextAndSelectors, updateContextAndWriteProjectFile, TargetContext(..) ) + ( die' + , wrapText + ) +import Distribution.Verbosity + ( normal + ) import qualified Data.Map as Map - buildCommand :: CommandUI (NixStyleFlags BuildFlags) -buildCommand = CommandUI { - commandName = "v2-build", - commandSynopsis = "Compile targets within the project.", - commandUsage = usageAlternatives "v2-build" [ "[TARGETS] [FLAGS]" ], - commandDescription = Just $ \_ -> wrapText $ - "Build one or more targets from within the project. The available " - ++ "targets are the packages in the project as well as individual " - ++ "components within those packages, including libraries, executables, " - ++ "test-suites or benchmarks. Targets can be specified by name or " - ++ "location. If no target is specified then the default is to build " - ++ "the package in the current directory.\n\n" - - ++ "Dependencies are built or rebuilt as necessary. Additional " - ++ "configuration flags can be specified on the command line and these " - ++ "extend the project configuration from the 'cabal.project', " - ++ "'cabal.project.local' and other files.", - commandNotes = Just $ \pname -> +buildCommand = + CommandUI + { commandName = "v2-build" + , commandSynopsis = "Compile targets within the project." + , commandUsage = usageAlternatives "v2-build" ["[TARGETS] [FLAGS]"] + , commandDescription = Just $ \_ -> + wrapText $ + "Build one or more targets from within the project. The available " + ++ "targets are the packages in the project as well as individual " + ++ "components within those packages, including libraries, executables, " + ++ "test-suites or benchmarks. Targets can be specified by name or " + ++ "location. If no target is specified then the default is to build " + ++ "the package in the current directory.\n\n" + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files." + , commandNotes = Just $ \pname -> "Examples:\n" - ++ " " ++ pname ++ " v2-build\n" - ++ " Build the package in the current directory " - ++ "or all packages in the project\n" - ++ " " ++ pname ++ " v2-build pkgname\n" - ++ " Build the package named pkgname in the project\n" - ++ " " ++ pname ++ " v2-build ./pkgfoo\n" - ++ " Build the package in the ./pkgfoo directory\n" - ++ " " ++ pname ++ " v2-build cname\n" - ++ " Build the component named cname in the project\n" - ++ " " ++ pname ++ " v2-build cname --enable-profiling\n" - ++ " Build the component in profiling mode " - ++ "(including dependencies as needed)\n" - - , commandDefaultFlags = defaultNixStyleFlags defaultBuildFlags - , commandOptions = removeIgnoreProjectOption - . nixStyleOptions (\showOrParseArgs -> - [ option [] ["only-configure"] - "Instead of performing a full build just run the configure step" - buildOnlyConfigure (\v flags -> flags { buildOnlyConfigure = v }) - (yesNoOpt showOrParseArgs) - ]) - } + ++ " " + ++ pname + ++ " v2-build\n" + ++ " Build the package in the current directory " + ++ "or all packages in the project\n" + ++ " " + ++ pname + ++ " v2-build pkgname\n" + ++ " Build the package named pkgname in the project\n" + ++ " " + ++ pname + ++ " v2-build ./pkgfoo\n" + ++ " Build the package in the ./pkgfoo directory\n" + ++ " " + ++ pname + ++ " v2-build cname\n" + ++ " Build the component named cname in the project\n" + ++ " " + ++ pname + ++ " v2-build cname --enable-profiling\n" + ++ " Build the component in profiling mode " + ++ "(including dependencies as needed)\n" + , commandDefaultFlags = defaultNixStyleFlags defaultBuildFlags + , commandOptions = + removeIgnoreProjectOption + . nixStyleOptions + ( \showOrParseArgs -> + [ option + [] + ["only-configure"] + "Instead of performing a full build just run the configure step" + buildOnlyConfigure + (\v flags -> flags{buildOnlyConfigure = v}) + (yesNoOpt showOrParseArgs) + ] + ) + } data BuildFlags = BuildFlags - { buildOnlyConfigure :: Flag Bool - } + { buildOnlyConfigure :: Flag Bool + } defaultBuildFlags :: BuildFlags -defaultBuildFlags = BuildFlags +defaultBuildFlags = + BuildFlags { buildOnlyConfigure = toFlag False } @@ -98,47 +132,52 @@ defaultBuildFlags = BuildFlags -- -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" --- buildAction :: NixStyleFlags BuildFlags -> [String] -> GlobalFlags -> IO () -buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings globalFlags - = withContextAndSelectors RejectNoTargets Nothing flags targetStrings globalFlags BuildCommand $ \targetCtx ctx targetSelectors -> do +buildAction flags@NixStyleFlags{extraFlags = buildFlags, ..} targetStrings globalFlags = + withContextAndSelectors RejectNoTargets Nothing flags targetStrings globalFlags BuildCommand $ \targetCtx ctx targetSelectors -> do -- TODO: This flags defaults business is ugly - let onlyConfigure = fromFlag (buildOnlyConfigure defaultBuildFlags - <> buildOnlyConfigure buildFlags) + let onlyConfigure = + fromFlag + ( buildOnlyConfigure defaultBuildFlags + <> buildOnlyConfigure buildFlags + ) targetAction - | onlyConfigure = TargetActionConfigure - | otherwise = TargetActionBuild + | onlyConfigure = TargetActionConfigure + | otherwise = TargetActionBuild baseCtx <- case targetCtx of - ProjectContext -> return ctx - GlobalContext -> return ctx + ProjectContext -> return ctx + GlobalContext -> return ctx ScriptContext path exemeta -> updateContextAndWriteProjectFile ctx path exemeta buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - - -- Interpret the targets on the command line as build targets - -- (as opposed to say repl or haddock targets). - targets <- either (reportBuildTargetProblems verbosity) return - $ resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors - - let elaboratedPlan' = pruneInstallPlanToTargets - targetAction - targets - elaboratedPlan - elaboratedPlan'' <- - if buildSettingOnlyDeps (buildSettings baseCtx) - then either (reportCannotPruneDependencies verbosity) return $ - pruneInstallPlanToDependencies (Map.keysSet targets) - elaboratedPlan' - else return elaboratedPlan' - - return (elaboratedPlan'', targets) + -- Interpret the targets on the command line as build targets + -- (as opposed to say repl or haddock targets). + targets <- + either (reportBuildTargetProblems verbosity) return $ + resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + let elaboratedPlan' = + pruneInstallPlanToTargets + targetAction + targets + elaboratedPlan + elaboratedPlan'' <- + if buildSettingOnlyDeps (buildSettings baseCtx) + then + either (reportCannotPruneDependencies verbosity) return $ + pruneInstallPlanToDependencies + (Map.keysSet targets) + elaboratedPlan' + else return elaboratedPlan' + + return (elaboratedPlan'', targets) printPlan verbosity baseCtx buildCtx @@ -154,42 +193,42 @@ buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings glo -- For the @build@ command select all components except non-buildable -- and disabled tests\/benchmarks, fail if there are no such -- components --- -selectPackageTargets :: TargetSelector - -> [AvailableTarget k] -> Either TargetProblem' [k] +selectPackageTargets + :: TargetSelector + -> [AvailableTarget k] + -> Either TargetProblem' [k] selectPackageTargets targetSelector targets - - -- If there are any buildable targets then we select those - | not (null targetsBuildable) - = Right targetsBuildable - - -- If there are targets but none are buildable then we report those - | not (null targets) - = Left (TargetProblemNoneEnabled targetSelector targets') - - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) + -- If there are any buildable targets then we select those + | not (null targetsBuildable) = + Right targetsBuildable + -- If there are targets but none are buildable then we report those + | not (null targets) = + Left (TargetProblemNoneEnabled targetSelector targets') + -- If there are no targets at all then we report that + | otherwise = + Left (TargetProblemNoTargets targetSelector) where - targets' = forgetTargetsDetail targets - targetsBuildable = selectBuildableTargetsWith - (buildable targetSelector) - targets + targets' = forgetTargetsDetail targets + targetsBuildable = + selectBuildableTargetsWith + (buildable targetSelector) + targets -- When there's a target filter like "pkg:tests" then we do select tests, -- but if it's just a target like "pkg" then we don't build tests unless -- they are requested by default (i.e. by using --enable-tests) - buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False - buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False + buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False + buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False buildable _ _ = True -- | For a 'TargetComponent' 'TargetSelector', check if the component can be -- selected. -- -- For the @build@ command we just need the basic checks on being buildable etc. --- -selectComponentTarget :: SubComponentTarget - -> AvailableTarget k -> Either TargetProblem' k +selectComponentTarget + :: SubComponentTarget + -> AvailableTarget k + -> Either TargetProblem' k selectComponentTarget = selectComponentTargetBasic reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a @@ -198,4 +237,4 @@ reportBuildTargetProblems verbosity problems = reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a reportCannotPruneDependencies verbosity = - die' verbosity . renderCannotPruneDependencies + die' verbosity . renderCannotPruneDependencies diff --git a/cabal-install/src/Distribution/Client/CmdClean.hs b/cabal-install/src/Distribution/Client/CmdClean.hs index f09e7ccb603..fda4b38921d 100644 --- a/cabal-install/src/Distribution/Client/CmdClean.hs +++ b/cabal-install/src/Distribution/Client/CmdClean.hs @@ -1,146 +1,191 @@ {-# LANGUAGE RecordWildCards #-} + module Distribution.Client.CmdClean (cleanCommand, cleanAction) where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () import Distribution.Client.Config - ( defaultScriptBuildsDir ) + ( defaultScriptBuildsDir + ) import Distribution.Client.DistDirLayout - ( DistDirLayout(..), defaultDistDirLayout ) + ( DistDirLayout (..) + , defaultDistDirLayout + ) import Distribution.Client.ProjectConfig - ( findProjectRoot ) + ( findProjectRoot + ) import Distribution.Client.Setup - ( GlobalFlags ) -import Distribution.ReadE ( succeedReadE ) -import Distribution.Simple.Setup - ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe - , optionDistPref, optionVerbosity, falseArg - ) + ( GlobalFlags + ) +import Distribution.ReadE (succeedReadE) import Distribution.Simple.Command - ( CommandUI(..), option, reqArg ) + ( CommandUI (..) + , option + , reqArg + ) +import Distribution.Simple.Setup + ( Flag (..) + , falseArg + , flagToList + , flagToMaybe + , fromFlagOrDefault + , optionDistPref + , optionVerbosity + , toFlag + ) import Distribution.Simple.Utils - ( info, die', wrapText, handleDoesNotExist ) + ( die' + , handleDoesNotExist + , info + , wrapText + ) import Distribution.Verbosity - ( normal ) + ( normal + ) import Control.Monad - ( forM, forM_, mapM ) + ( forM + , forM_ + , mapM + ) import qualified Data.Set as Set import System.Directory - ( removeDirectoryRecursive, removeFile - , doesDirectoryExist, doesFileExist - , getDirectoryContents, listDirectory - , canonicalizePath ) + ( canonicalizePath + , doesDirectoryExist + , doesFileExist + , getDirectoryContents + , listDirectory + , removeDirectoryRecursive + , removeFile + ) import System.FilePath - ( () ) + ( () + ) data CleanFlags = CleanFlags - { cleanSaveConfig :: Flag Bool - , cleanVerbosity :: Flag Verbosity - , cleanDistDir :: Flag FilePath - , cleanProjectDir :: Flag FilePath - , cleanProjectFile :: Flag FilePath - } deriving (Eq) + { cleanSaveConfig :: Flag Bool + , cleanVerbosity :: Flag Verbosity + , cleanDistDir :: Flag FilePath + , cleanProjectDir :: Flag FilePath + , cleanProjectFile :: Flag FilePath + } + deriving (Eq) defaultCleanFlags :: CleanFlags -defaultCleanFlags = CleanFlags - { cleanSaveConfig = toFlag False - , cleanVerbosity = toFlag normal - , cleanDistDir = NoFlag - , cleanProjectDir = mempty +defaultCleanFlags = + CleanFlags + { cleanSaveConfig = toFlag False + , cleanVerbosity = toFlag normal + , cleanDistDir = NoFlag + , cleanProjectDir = mempty , cleanProjectFile = mempty } cleanCommand :: CommandUI CleanFlags -cleanCommand = CommandUI - { commandName = "v2-clean" - , commandSynopsis = "Clean the package store and remove temporary files." - , commandUsage = \pname -> +cleanCommand = + CommandUI + { commandName = "v2-clean" + , commandSynopsis = "Clean the package store and remove temporary files." + , commandUsage = \pname -> "Usage: " ++ pname ++ " new-clean [FLAGS]\n" - , commandDescription = Just $ \_ -> wrapText $ - "Removes all temporary files created during the building process " - ++ "(.hi, .o, preprocessed sources, etc.) and also empties out the " - ++ "local caches (by default).\n\n" - , commandNotes = Nothing + , commandDescription = Just $ \_ -> + wrapText $ + "Removes all temporary files created during the building process " + ++ "(.hi, .o, preprocessed sources, etc.) and also empties out the " + ++ "local caches (by default).\n\n" + , commandNotes = Nothing , commandDefaultFlags = defaultCleanFlags - , commandOptions = \showOrParseArgs -> + , commandOptions = \showOrParseArgs -> [ optionVerbosity - cleanVerbosity (\v flags -> flags { cleanVerbosity = v }) + cleanVerbosity + (\v flags -> flags{cleanVerbosity = v}) , optionDistPref - cleanDistDir (\dd flags -> flags { cleanDistDir = dd }) + cleanDistDir + (\dd flags -> flags{cleanDistDir = dd}) showOrParseArgs - , option [] ["project-dir"] + , option + [] + ["project-dir"] "Set the path of the project directory" - cleanProjectDir (\path flags -> flags {cleanProjectDir = path}) + cleanProjectDir + (\path flags -> flags{cleanProjectDir = path}) (reqArg "DIR" (succeedReadE Flag) flagToList) - , option [] ["project-file"] + , option + [] + ["project-file"] "Set the path of the cabal.project file (relative to the project directory when relative)" - cleanProjectFile (\pf flags -> flags {cleanProjectFile = pf}) + cleanProjectFile + (\pf flags -> flags{cleanProjectFile = pf}) (reqArg "FILE" (succeedReadE Flag) flagToList) - , option ['s'] ["save-config"] + , option + ['s'] + ["save-config"] "Save configuration, only remove build artifacts" - cleanSaveConfig (\sc flags -> flags { cleanSaveConfig = sc }) + cleanSaveConfig + (\sc flags -> flags{cleanSaveConfig = sc}) falseArg ] - } + } cleanAction :: CleanFlags -> [String] -> GlobalFlags -> IO () cleanAction CleanFlags{..} extraArgs _ = do - let verbosity = fromFlagOrDefault normal cleanVerbosity - saveConfig = fromFlagOrDefault False cleanSaveConfig - mdistDirectory = flagToMaybe cleanDistDir - mprojectDir = flagToMaybe cleanProjectDir - mprojectFile = flagToMaybe cleanProjectFile - - -- TODO interpret extraArgs as targets and clean those targets only (issue #7506) - -- - -- For now assume all files passed are the names of scripts - notScripts <- filterM (fmap not . doesFileExist) extraArgs - unless (null notScripts) $ - die' verbosity $ "'clean' extra arguments should be script files: " - ++ unwords notScripts - - projectRoot <- either throwIO return =<< findProjectRoot verbosity mprojectDir mprojectFile - - let distLayout = defaultDistDirLayout projectRoot mdistDirectory Nothing - - -- Do not clean a project if just running a script in it's directory - when (null extraArgs || isJust mdistDirectory) $ do - if saveConfig then do - let buildRoot = distBuildRootDirectory distLayout - - buildRootExists <- doesDirectoryExist buildRoot - - when buildRootExists $ do - info verbosity ("Deleting build root (" ++ buildRoot ++ ")") - handleDoesNotExist () $ removeDirectoryRecursive buildRoot - else do - let distRoot = distDirectory distLayout - - info verbosity ("Deleting dist-newstyle (" ++ distRoot ++ ")") - handleDoesNotExist () $ removeDirectoryRecursive distRoot - - removeEnvFiles (distProjectRootDirectory distLayout) - - -- Clean specified script build caches and orphaned caches. - -- There is currently no good way to specify to only clean orphaned caches. - -- It would be better as part of an explicit gc step (see issue #3333) - toClean <- Set.fromList <$> mapM canonicalizePath extraArgs - cacheDir <- defaultScriptBuildsDir - existsCD <- doesDirectoryExist cacheDir - caches <- if existsCD then listDirectory cacheDir else return [] - paths <- fmap concat . forM caches $ \cache -> do - let locFile = cacheDir cache "scriptlocation" - exists <- doesFileExist locFile - if exists then pure . (,) (cacheDir cache) <$> readFile locFile else return [] - forM_ paths $ \(cache, script) -> do - exists <- doesFileExist script - when (not exists || script `Set.member` toClean) $ do - info verbosity ("Deleting cache (" ++ cache ++ ") for script (" ++ script ++ ")") - removeDirectoryRecursive cache + let verbosity = fromFlagOrDefault normal cleanVerbosity + saveConfig = fromFlagOrDefault False cleanSaveConfig + mdistDirectory = flagToMaybe cleanDistDir + mprojectDir = flagToMaybe cleanProjectDir + mprojectFile = flagToMaybe cleanProjectFile + + -- TODO interpret extraArgs as targets and clean those targets only (issue #7506) + -- + -- For now assume all files passed are the names of scripts + notScripts <- filterM (fmap not . doesFileExist) extraArgs + unless (null notScripts) $ + die' verbosity $ + "'clean' extra arguments should be script files: " + ++ unwords notScripts + + projectRoot <- either throwIO return =<< findProjectRoot verbosity mprojectDir mprojectFile + + let distLayout = defaultDistDirLayout projectRoot mdistDirectory Nothing + + -- Do not clean a project if just running a script in it's directory + when (null extraArgs || isJust mdistDirectory) $ do + if saveConfig + then do + let buildRoot = distBuildRootDirectory distLayout + + buildRootExists <- doesDirectoryExist buildRoot + + when buildRootExists $ do + info verbosity ("Deleting build root (" ++ buildRoot ++ ")") + handleDoesNotExist () $ removeDirectoryRecursive buildRoot + else do + let distRoot = distDirectory distLayout + + info verbosity ("Deleting dist-newstyle (" ++ distRoot ++ ")") + handleDoesNotExist () $ removeDirectoryRecursive distRoot + + removeEnvFiles (distProjectRootDirectory distLayout) + + -- Clean specified script build caches and orphaned caches. + -- There is currently no good way to specify to only clean orphaned caches. + -- It would be better as part of an explicit gc step (see issue #3333) + toClean <- Set.fromList <$> mapM canonicalizePath extraArgs + cacheDir <- defaultScriptBuildsDir + existsCD <- doesDirectoryExist cacheDir + caches <- if existsCD then listDirectory cacheDir else return [] + paths <- fmap concat . forM caches $ \cache -> do + let locFile = cacheDir cache "scriptlocation" + exists <- doesFileExist locFile + if exists then pure . (,) (cacheDir cache) <$> readFile locFile else return [] + forM_ paths $ \(cache, script) -> do + exists <- doesFileExist script + when (not exists || script `Set.member` toClean) $ do + info verbosity ("Deleting cache (" ++ cache ++ ") for script (" ++ script ++ ")") + removeDirectoryRecursive cache removeEnvFiles :: FilePath -> IO () removeEnvFiles dir = (traverse_ (removeFile . (dir )) . filter ((".ghc.environment" ==) . take 16)) - =<< getDirectoryContents dir + =<< getDirectoryContents dir diff --git a/cabal-install/src/Distribution/Client/CmdConfigure.hs b/cabal-install/src/Distribution/Client/CmdConfigure.hs index 80742f4fcff..d8e91668095 100644 --- a/cabal-install/src/Distribution/Client/CmdConfigure.hs +++ b/cabal-install/src/Distribution/Client/CmdConfigure.hs @@ -1,10 +1,10 @@ {-# LANGUAGE RecordWildCards #-} + -- | cabal-install CLI command: configure --- -module Distribution.Client.CmdConfigure ( - configureCommand, - configureAction, - configureAction', +module Distribution.Client.CmdConfigure + ( configureCommand + , configureAction + , configureAction' ) where import Distribution.Client.Compat.Prelude @@ -13,77 +13,97 @@ import Prelude () import System.Directory import System.FilePath -import Distribution.Simple.Flag -import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectConfig - ( writeProjectLocalExtraConfig, readProjectLocalExtraConfig ) + ( readProjectLocalExtraConfig + , writeProjectLocalExtraConfig + ) import Distribution.Client.ProjectFlags - ( removeIgnoreProjectOption ) + ( removeIgnoreProjectOption + ) +import Distribution.Client.ProjectOrchestration +import Distribution.Simple.Flag import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) + ( NixStyleFlags (..) + , defaultNixStyleFlags + , nixStyleOptions + ) import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags(..) ) + ( ConfigExFlags (..) + , ConfigFlags (..) + , GlobalFlags + ) import Distribution.Verbosity - ( normal ) + ( normal + ) import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) + ( CommandUI (..) + , usageAlternatives + ) import Distribution.Simple.Utils - ( wrapText, notice, die' ) + ( die' + , notice + , wrapText + ) import Distribution.Client.DistDirLayout - ( DistDirLayout(..) ) -import Distribution.Client.RebuildMonad (runRebuild) -import Distribution.Client.ProjectConfig.Types + ( DistDirLayout (..) + ) import Distribution.Client.HttpUtils -import Distribution.Utils.NubList - ( fromNubList ) +import Distribution.Client.ProjectConfig.Types +import Distribution.Client.RebuildMonad (runRebuild) import Distribution.Types.CondTree - ( CondTree (..) ) + ( CondTree (..) + ) +import Distribution.Utils.NubList + ( fromNubList + ) configureCommand :: CommandUI (NixStyleFlags ()) -configureCommand = CommandUI { - commandName = "v2-configure", - commandSynopsis = "Add extra project configuration.", - commandUsage = usageAlternatives "v2-configure" [ "[FLAGS]" ], - commandDescription = Just $ \_ -> wrapText $ - "Adjust how the project is built by setting additional package flags " - ++ "and other flags.\n\n" - - ++ "The configuration options are written to the 'cabal.project.local' " - ++ "file (or '$project_file.local', if '--project-file' is specified) " - ++ "which extends the configuration from the 'cabal.project' file " - ++ "(if any). This combination is used as the project configuration for " - ++ "all other commands (such as 'v2-build', 'v2-repl' etc) though it " - ++ "can be extended/overridden on a per-command basis.\n\n" - - ++ "The v2-configure command also checks that the project configuration " - ++ "will work. In particular it checks that there is a consistent set of " - ++ "dependencies for the project as a whole.\n\n" - - ++ "The 'cabal.project.local' file persists across 'v2-clean' but is " - ++ "overwritten on the next use of the 'v2-configure' command. The " - ++ "intention is that the 'cabal.project' file should be kept in source " - ++ "control but the 'cabal.project.local' should not.\n\n" - - ++ "It is never necessary to use the 'v2-configure' command. It is " - ++ "merely a convenience in cases where you do not want to specify flags " - ++ "to 'v2-build' (and other commands) every time and yet do not want " - ++ "to alter the 'cabal.project' persistently.", - commandNotes = Just $ \pname -> +configureCommand = + CommandUI + { commandName = "v2-configure" + , commandSynopsis = "Add extra project configuration." + , commandUsage = usageAlternatives "v2-configure" ["[FLAGS]"] + , commandDescription = Just $ \_ -> + wrapText $ + "Adjust how the project is built by setting additional package flags " + ++ "and other flags.\n\n" + ++ "The configuration options are written to the 'cabal.project.local' " + ++ "file (or '$project_file.local', if '--project-file' is specified) " + ++ "which extends the configuration from the 'cabal.project' file " + ++ "(if any). This combination is used as the project configuration for " + ++ "all other commands (such as 'v2-build', 'v2-repl' etc) though it " + ++ "can be extended/overridden on a per-command basis.\n\n" + ++ "The v2-configure command also checks that the project configuration " + ++ "will work. In particular it checks that there is a consistent set of " + ++ "dependencies for the project as a whole.\n\n" + ++ "The 'cabal.project.local' file persists across 'v2-clean' but is " + ++ "overwritten on the next use of the 'v2-configure' command. The " + ++ "intention is that the 'cabal.project' file should be kept in source " + ++ "control but the 'cabal.project.local' should not.\n\n" + ++ "It is never necessary to use the 'v2-configure' command. It is " + ++ "merely a convenience in cases where you do not want to specify flags " + ++ "to 'v2-build' (and other commands) every time and yet do not want " + ++ "to alter the 'cabal.project' persistently." + , commandNotes = Just $ \pname -> "Examples:\n" - ++ " " ++ pname ++ " v2-configure --with-compiler ghc-7.10.3\n" - ++ " Adjust the project configuration to use the given compiler\n" - ++ " program and check the resulting configuration works.\n" - ++ " " ++ pname ++ " v2-configure\n" - ++ " Reset the local configuration to empty. To check that the\n" - ++ " project configuration works, use 'cabal build'.\n" - - , commandDefaultFlags = defaultNixStyleFlags () - , commandOptions = removeIgnoreProjectOption - . nixStyleOptions (const []) - } + ++ " " + ++ pname + ++ " v2-configure --with-compiler ghc-7.10.3\n" + ++ " Adjust the project configuration to use the given compiler\n" + ++ " program and check the resulting configuration works.\n" + ++ " " + ++ pname + ++ " v2-configure\n" + ++ " Reset the local configuration to empty. To check that the\n" + ++ " project configuration works, use 'cabal build'.\n" + , commandDefaultFlags = defaultNixStyleFlags () + , commandOptions = + removeIgnoreProjectOption + . nixStyleOptions (const []) + } -- | To a first approximation, the @configure@ just runs the first phase of -- the @build@ command where we bring the install plan up to date (thus @@ -94,60 +114,65 @@ configureCommand = CommandUI { -- -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" --- configureAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -configureAction flags@NixStyleFlags {..} extraArgs globalFlags = do - (baseCtx, projConfig) <- configureAction' flags extraArgs globalFlags +configureAction flags@NixStyleFlags{..} extraArgs globalFlags = do + (baseCtx, projConfig) <- configureAction' flags extraArgs globalFlags - if shouldNotWriteFile baseCtx - then notice v "Config file not written due to flag(s)." - else writeProjectLocalExtraConfig (distDirLayout baseCtx) projConfig + if shouldNotWriteFile baseCtx + then notice v "Config file not written due to flag(s)." + else writeProjectLocalExtraConfig (distDirLayout baseCtx) projConfig where v = fromFlagOrDefault normal (configVerbosity configFlags) configureAction' :: NixStyleFlags () -> [String] -> GlobalFlags -> IO (ProjectBaseContext, ProjectConfig) -configureAction' flags@NixStyleFlags {..} _extraArgs globalFlags = do - --TODO: deal with _extraArgs, since flags with wrong syntax end up there - - baseCtx <- establishProjectBaseContext v cliConfig OtherCommand - - let localFile = distProjectFile (distDirLayout baseCtx) "local" - -- If cabal.project.local already exists, and the flags allow, back up to cabal.project.local~ - let backups = fromFlagOrDefault True $ configBackup configExFlags - appends = fromFlagOrDefault False $ configAppend configExFlags - backupFile = localFile <> "~" - - if shouldNotWriteFile baseCtx - then - return (baseCtx, cliConfig) - else do - exists <- doesFileExist localFile - when (exists && backups) $ do - notice v $ - quote (takeFileName localFile) <> " already exists, backing it up to " - <> quote (takeFileName backupFile) <> "." - copyFile localFile backupFile - - -- If the flag @configAppend@ is set to true, append and do not overwrite - if exists && appends - then do - httpTransport <- configureTransport v - (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig) - (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig) - (CondNode conf imps bs) <- runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $ +configureAction' flags@NixStyleFlags{..} _extraArgs globalFlags = do + -- TODO: deal with _extraArgs, since flags with wrong syntax end up there + + baseCtx <- establishProjectBaseContext v cliConfig OtherCommand + + let localFile = distProjectFile (distDirLayout baseCtx) "local" + -- If cabal.project.local already exists, and the flags allow, back up to cabal.project.local~ + let backups = fromFlagOrDefault True $ configBackup configExFlags + appends = fromFlagOrDefault False $ configAppend configExFlags + backupFile = localFile <> "~" + + if shouldNotWriteFile baseCtx + then return (baseCtx, cliConfig) + else do + exists <- doesFileExist localFile + when (exists && backups) $ do + notice v $ + quote (takeFileName localFile) + <> " already exists, backing it up to " + <> quote (takeFileName backupFile) + <> "." + copyFile localFile backupFile + + -- If the flag @configAppend@ is set to true, append and do not overwrite + if exists && appends + then do + httpTransport <- + configureTransport + v + (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig) + (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig) + (CondNode conf imps bs) <- + runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $ readProjectLocalExtraConfig v httpTransport (distDirLayout baseCtx) - when (not (null imps && null bs)) $ die' v "local project file has conditional and/or import logic, unable to perform and automatic in-place update" - return (baseCtx, conf <> cliConfig) - else - return (baseCtx, cliConfig) + when (not (null imps && null bs)) $ die' v "local project file has conditional and/or import logic, unable to perform and automatic in-place update" + return (baseCtx, conf <> cliConfig) + else return (baseCtx, cliConfig) where v = fromFlagOrDefault normal (configVerbosity configFlags) - cliConfig = commandLineFlagsToProjectConfig globalFlags flags - mempty -- ClientInstallFlags, not needed here + cliConfig = + commandLineFlagsToProjectConfig + globalFlags + flags + mempty -- ClientInstallFlags, not needed here quote s = "'" <> s <> "'" -- Config file should not be written when certain flags are present shouldNotWriteFile :: ProjectBaseContext -> Bool shouldNotWriteFile baseCtx = - buildSettingDryRun (buildSettings baseCtx) - || buildSettingOnlyDownload (buildSettings baseCtx) + buildSettingDryRun (buildSettings baseCtx) + || buildSettingOnlyDownload (buildSettings baseCtx) diff --git a/cabal-install/src/Distribution/Client/CmdErrorMessages.hs b/cabal-install/src/Distribution/Client/CmdErrorMessages.hs index cf41fc4ebac..e8b5a415db6 100644 --- a/cabal-install/src/Distribution/Client/CmdErrorMessages.hs +++ b/cabal-install/src/Distribution/Client/CmdErrorMessages.hs @@ -2,64 +2,74 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} - -- | Utilities to help format error messages for the various CLI commands. --- -module Distribution.Client.CmdErrorMessages ( - module Distribution.Client.CmdErrorMessages, - module Distribution.Client.TargetSelector, +module Distribution.Client.CmdErrorMessages + ( module Distribution.Client.CmdErrorMessages + , module Distribution.Client.TargetSelector ) where import Distribution.Client.Compat.Prelude import Prelude () import Distribution.Client.ProjectPlanning - ( AvailableTarget(..), AvailableTargetStatus(..), - CannotPruneDependencies(..), TargetRequested(..) ) -import Distribution.Client.TargetSelector - ( SubComponentTarget(..) ) + ( AvailableTarget (..) + , AvailableTargetStatus (..) + , CannotPruneDependencies (..) + , TargetRequested (..) + ) import Distribution.Client.TargetProblem - ( TargetProblem(..), TargetProblem' ) + ( TargetProblem (..) + , TargetProblem' + ) import Distribution.Client.TargetSelector - ( ComponentKind(..), ComponentKindFilter, TargetSelector(..), - componentKind, showTargetSelector ) + ( ComponentKind (..) + , ComponentKindFilter + , SubComponentTarget (..) + , TargetSelector (..) + , componentKind + , showTargetSelector + ) import Distribution.Package - ( PackageId, packageId, PackageName, packageName ) + ( PackageId + , PackageName + , packageId + , packageName + ) import Distribution.Simple.Utils - ( die' ) + ( die' + ) +import Distribution.Solver.Types.OptionalStanza + ( OptionalStanza (..) + ) import Distribution.Types.ComponentName - ( ComponentName(..), showComponentName ) + ( ComponentName (..) + , showComponentName + ) import Distribution.Types.LibraryName - ( LibraryName(..) ) -import Distribution.Solver.Types.OptionalStanza - ( OptionalStanza(..) ) + ( LibraryName (..) + ) import qualified Data.List.NonEmpty as NE - ----------------------- -- Singular or plural -- -- | A tag used in rendering messages to distinguish singular or plural. --- data Plural = Singular | Plural -- | Used to render a singular or plural version of something -- -- > plural (listPlural theThings) "it is" "they are" --- plural :: Plural -> a -> a -> a plural Singular si _pl = si -plural Plural _si pl = pl +plural Plural _si pl = pl -- | Singular for singleton lists and plural otherwise. --- listPlural :: [a] -> Plural listPlural [_] = Singular -listPlural _ = Plural - +listPlural _ = Plural -------------------- -- Rendering lists @@ -67,24 +77,26 @@ listPlural _ = Plural -- | Render a list of things in the style @foo, bar and baz@ renderListCommaAnd :: [String] -> String -renderListCommaAnd [] = "" -renderListCommaAnd [x] = x -renderListCommaAnd [x,x'] = x ++ " and " ++ x' -renderListCommaAnd (x:xs) = x ++ ", " ++ renderListCommaAnd xs +renderListCommaAnd [] = "" +renderListCommaAnd [x] = x +renderListCommaAnd [x, x'] = x ++ " and " ++ x' +renderListCommaAnd (x : xs) = x ++ ", " ++ renderListCommaAnd xs renderListTabular :: [String] -> String -renderListTabular = ("\n"++) . unlines . map ("| * "++) +renderListTabular = ("\n" ++) . unlines . map ("| * " ++) renderListPretty :: [String] -> String -renderListPretty xs = if length xs > 5 then renderListTabular xs - else renderListCommaAnd xs +renderListPretty xs = + if length xs > 5 + then renderListTabular xs + else renderListCommaAnd xs -- | Render a list of things in the style @blah blah; this that; and the other@ renderListSemiAnd :: [String] -> String -renderListSemiAnd [] = "" -renderListSemiAnd [x] = x -renderListSemiAnd [x,x'] = x ++ "; and " ++ x' -renderListSemiAnd (x:xs) = x ++ "; " ++ renderListSemiAnd xs +renderListSemiAnd [] = "" +renderListSemiAnd [x] = x +renderListSemiAnd [x, x'] = x ++ "; and " ++ x' +renderListSemiAnd (x : xs) = x ++ "; " ++ renderListSemiAnd xs -- | When rendering lists of things it often reads better to group related -- things, e.g. grouping components by package name @@ -93,12 +105,11 @@ renderListSemiAnd (x:xs) = x ++ "; " ++ renderListSemiAnd xs -- > [ "the package " ++ prettyShow pkgname ++ " components " -- > ++ renderListCommaAnd showComponentName components -- > | (pkgname, components) <- sortGroupOn packageName allcomponents ] --- sortGroupOn :: Ord b => (a -> b) -> [a] -> [(b, [a])] -sortGroupOn key = map (\(x:|xs) -> (key x, x:xs)) - . NE.groupBy ((==) `on` key) - . sortBy (compare `on` key) - +sortGroupOn key = + map (\(x :| xs) -> (key x, x : xs)) + . NE.groupBy ((==) `on` key) + . sortBy (compare `on` key) ---------------------------------------------------- -- Rendering for a few project and package types @@ -106,107 +117,109 @@ sortGroupOn key = map (\(x:|xs) -> (key x, x:xs)) renderTargetSelector :: TargetSelector -> String renderTargetSelector (TargetPackage _ pkgids Nothing) = - "the " ++ plural (listPlural pkgids) "package" "packages" ++ " " - ++ renderListCommaAnd (map prettyShow pkgids) - + "the " + ++ plural (listPlural pkgids) "package" "packages" + ++ " " + ++ renderListCommaAnd (map prettyShow pkgids) renderTargetSelector (TargetPackage _ pkgids (Just kfilter)) = - "the " ++ renderComponentKind Plural kfilter - ++ " in the " ++ plural (listPlural pkgids) "package" "packages" ++ " " - ++ renderListCommaAnd (map prettyShow pkgids) - + "the " + ++ renderComponentKind Plural kfilter + ++ " in the " + ++ plural (listPlural pkgids) "package" "packages" + ++ " " + ++ renderListCommaAnd (map prettyShow pkgids) renderTargetSelector (TargetPackageNamed pkgname Nothing) = - "the package " ++ prettyShow pkgname - + "the package " ++ prettyShow pkgname renderTargetSelector (TargetPackageNamed pkgname (Just kfilter)) = - "the " ++ renderComponentKind Plural kfilter - ++ " in the package " ++ prettyShow pkgname - + "the " + ++ renderComponentKind Plural kfilter + ++ " in the package " + ++ prettyShow pkgname renderTargetSelector (TargetAllPackages Nothing) = - "all the packages in the project" - + "all the packages in the project" renderTargetSelector (TargetAllPackages (Just kfilter)) = - "all the " ++ renderComponentKind Plural kfilter - ++ " in the project" - + "all the " + ++ renderComponentKind Plural kfilter + ++ " in the project" renderTargetSelector (TargetComponent pkgid cname subtarget) = - renderSubComponentTarget subtarget ++ "the " - ++ renderComponentName (packageName pkgid) cname - + renderSubComponentTarget subtarget + ++ "the " + ++ renderComponentName (packageName pkgid) cname renderTargetSelector (TargetComponentUnknown pkgname (Left ucname) subtarget) = - renderSubComponentTarget subtarget ++ "the component " ++ prettyShow ucname - ++ " in the package " ++ prettyShow pkgname - + renderSubComponentTarget subtarget + ++ "the component " + ++ prettyShow ucname + ++ " in the package " + ++ prettyShow pkgname renderTargetSelector (TargetComponentUnknown pkgname (Right cname) subtarget) = - renderSubComponentTarget subtarget ++ "the " - ++ renderComponentName pkgname cname + renderSubComponentTarget subtarget + ++ "the " + ++ renderComponentName pkgname cname renderSubComponentTarget :: SubComponentTarget -> String -renderSubComponentTarget WholeComponent = "" -renderSubComponentTarget (FileTarget filename) = +renderSubComponentTarget WholeComponent = "" +renderSubComponentTarget (FileTarget filename) = "the file " ++ filename ++ " in " renderSubComponentTarget (ModuleTarget modname) = "the module " ++ prettyShow modname ++ " in " - renderOptionalStanza :: Plural -> OptionalStanza -> String -renderOptionalStanza Singular TestStanzas = "test suite" -renderOptionalStanza Plural TestStanzas = "test suites" +renderOptionalStanza Singular TestStanzas = "test suite" +renderOptionalStanza Plural TestStanzas = "test suites" renderOptionalStanza Singular BenchStanzas = "benchmark" -renderOptionalStanza Plural BenchStanzas = "benchmarks" +renderOptionalStanza Plural BenchStanzas = "benchmarks" -- | The optional stanza type (test suite or benchmark), if it is one. optionalStanza :: ComponentName -> Maybe OptionalStanza -optionalStanza (CTestName _) = Just TestStanzas +optionalStanza (CTestName _) = Just TestStanzas optionalStanza (CBenchName _) = Just BenchStanzas -optionalStanza _ = Nothing +optionalStanza _ = Nothing -- | Does the 'TargetSelector' potentially refer to one package or many? --- targetSelectorPluralPkgs :: TargetSelector -> Plural -targetSelectorPluralPkgs (TargetAllPackages _) = Plural -targetSelectorPluralPkgs (TargetPackage _ pids _) = listPlural pids -targetSelectorPluralPkgs (TargetPackageNamed _ _) = Singular -targetSelectorPluralPkgs TargetComponent{} = Singular -targetSelectorPluralPkgs TargetComponentUnknown{} = Singular +targetSelectorPluralPkgs (TargetAllPackages _) = Plural +targetSelectorPluralPkgs (TargetPackage _ pids _) = listPlural pids +targetSelectorPluralPkgs (TargetPackageNamed _ _) = Singular +targetSelectorPluralPkgs TargetComponent{} = Singular +targetSelectorPluralPkgs TargetComponentUnknown{} = Singular -- | Does the 'TargetSelector' refer to packages or to components? targetSelectorRefersToPkgs :: TargetSelector -> Bool -targetSelectorRefersToPkgs (TargetAllPackages mkfilter) = isNothing mkfilter -targetSelectorRefersToPkgs (TargetPackage _ _ mkfilter) = isNothing mkfilter +targetSelectorRefersToPkgs (TargetAllPackages mkfilter) = isNothing mkfilter +targetSelectorRefersToPkgs (TargetPackage _ _ mkfilter) = isNothing mkfilter targetSelectorRefersToPkgs (TargetPackageNamed _ mkfilter) = isNothing mkfilter -targetSelectorRefersToPkgs TargetComponent{} = False -targetSelectorRefersToPkgs TargetComponentUnknown{} = False +targetSelectorRefersToPkgs TargetComponent{} = False +targetSelectorRefersToPkgs TargetComponentUnknown{} = False targetSelectorFilter :: TargetSelector -> Maybe ComponentKindFilter -targetSelectorFilter (TargetPackage _ _ mkfilter) = mkfilter +targetSelectorFilter (TargetPackage _ _ mkfilter) = mkfilter targetSelectorFilter (TargetPackageNamed _ mkfilter) = mkfilter -targetSelectorFilter (TargetAllPackages mkfilter) = mkfilter -targetSelectorFilter TargetComponent{} = Nothing -targetSelectorFilter TargetComponentUnknown{} = Nothing +targetSelectorFilter (TargetAllPackages mkfilter) = mkfilter +targetSelectorFilter TargetComponent{} = Nothing +targetSelectorFilter TargetComponentUnknown{} = Nothing renderComponentName :: PackageName -> ComponentName -> String renderComponentName pkgname (CLibName LMainLibName) = "library " ++ prettyShow pkgname renderComponentName _ (CLibName (LSubLibName name)) = "library " ++ prettyShow name -renderComponentName _ (CFLibName name) = "foreign library " ++ prettyShow name -renderComponentName _ (CExeName name) = "executable " ++ prettyShow name -renderComponentName _ (CTestName name) = "test suite " ++ prettyShow name -renderComponentName _ (CBenchName name) = "benchmark " ++ prettyShow name +renderComponentName _ (CFLibName name) = "foreign library " ++ prettyShow name +renderComponentName _ (CExeName name) = "executable " ++ prettyShow name +renderComponentName _ (CTestName name) = "test suite " ++ prettyShow name +renderComponentName _ (CBenchName name) = "benchmark " ++ prettyShow name renderComponentKind :: Plural -> ComponentKind -> String renderComponentKind Singular ckind = case ckind of - LibKind -> "library" -- internal/sub libs? - FLibKind -> "foreign library" - ExeKind -> "executable" - TestKind -> "test suite" + LibKind -> "library" -- internal/sub libs? + FLibKind -> "foreign library" + ExeKind -> "executable" + TestKind -> "test suite" BenchKind -> "benchmark" renderComponentKind Plural ckind = case ckind of - LibKind -> "libraries" -- internal/sub libs? - FLibKind -> "foreign libraries" - ExeKind -> "executables" - TestKind -> "test suites" + LibKind -> "libraries" -- internal/sub libs? + FLibKind -> "foreign libraries" + ExeKind -> "executables" + TestKind -> "test suites" BenchKind -> "benchmarks" - ------------------------------------------------------- -- Rendering error messages for TargetProblem -- @@ -218,95 +231,135 @@ reportTargetProblems verbosity verb = -- | Default implementation of 'renderTargetProblem'. renderTargetProblem - :: String -- ^ verb - -> (a -> String) -- ^ how to render custom problems - -> TargetProblem a - -> String + :: String + -- ^ verb + -> (a -> String) + -- ^ how to render custom problems + -> TargetProblem a + -> String renderTargetProblem _verb f (CustomTargetProblem x) = f x -renderTargetProblem verb _ (TargetProblemNoneEnabled targetSelector targets) = - renderTargetProblemNoneEnabled verb targetSelector targets -renderTargetProblem verb _ (TargetProblemNoTargets targetSelector) = - renderTargetProblemNoTargets verb targetSelector - +renderTargetProblem verb _ (TargetProblemNoneEnabled targetSelector targets) = + renderTargetProblemNoneEnabled verb targetSelector targets +renderTargetProblem verb _ (TargetProblemNoTargets targetSelector) = + renderTargetProblemNoTargets verb targetSelector renderTargetProblem verb _ (TargetNotInProject pkgname) = - "Cannot " ++ verb ++ " the package " ++ prettyShow pkgname ++ ", it is not " - ++ "in this project (either directly or indirectly). If you want to add it " - ++ "to the project then edit the cabal.project file." - + "Cannot " + ++ verb + ++ " the package " + ++ prettyShow pkgname + ++ ", it is not " + ++ "in this project (either directly or indirectly). If you want to add it " + ++ "to the project then edit the cabal.project file." renderTargetProblem verb _ (TargetAvailableInIndex pkgname) = - "Cannot " ++ verb ++ " the package " ++ prettyShow pkgname ++ ", it is not " - ++ "in this project (either directly or indirectly), but it is in the current " - ++ "package index. If you want to add it to the project then edit the " - ++ "cabal.project file." - + "Cannot " + ++ verb + ++ " the package " + ++ prettyShow pkgname + ++ ", it is not " + ++ "in this project (either directly or indirectly), but it is in the current " + ++ "package index. If you want to add it to the project then edit the " + ++ "cabal.project file." renderTargetProblem verb _ (TargetComponentNotProjectLocal pkgid cname _) = - "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the " - ++ "package " ++ prettyShow pkgid ++ " is not local to the project, and cabal " - ++ "does not currently support building test suites or benchmarks of " - ++ "non-local dependencies. To run test suites or benchmarks from " - ++ "dependencies you can unpack the package locally and adjust the " - ++ "cabal.project file to include that package directory." - + "Cannot " + ++ verb + ++ " the " + ++ showComponentName cname + ++ " because the " + ++ "package " + ++ prettyShow pkgid + ++ " is not local to the project, and cabal " + ++ "does not currently support building test suites or benchmarks of " + ++ "non-local dependencies. To run test suites or benchmarks from " + ++ "dependencies you can unpack the package locally and adjust the " + ++ "cabal.project file to include that package directory." renderTargetProblem verb _ (TargetComponentNotBuildable pkgid cname _) = - "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because it is " - ++ "marked as 'buildable: False' within the '" ++ prettyShow (packageName pkgid) - ++ ".cabal' file (at least for the current configuration). If you believe it " - ++ "should be buildable then check the .cabal file to see if the buildable " - ++ "property is conditional on flags. Alternatively you may simply have to " - ++ "edit the .cabal file to declare it as buildable and fix any resulting " - ++ "build problems." - + "Cannot " + ++ verb + ++ " the " + ++ showComponentName cname + ++ " because it is " + ++ "marked as 'buildable: False' within the '" + ++ prettyShow (packageName pkgid) + ++ ".cabal' file (at least for the current configuration). If you believe it " + ++ "should be buildable then check the .cabal file to see if the buildable " + ++ "property is conditional on flags. Alternatively you may simply have to " + ++ "edit the .cabal file to declare it as buildable and fix any resulting " + ++ "build problems." renderTargetProblem verb _ (TargetOptionalStanzaDisabledByUser _ cname _) = - "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because " - ++ "building " ++ compkinds ++ " has been explicitly disabled in the " - ++ "configuration. You can adjust this configuration in the " - ++ "cabal.project{.local} file either for all packages in the project or on " - ++ "a per-package basis. Note that if you do not explicitly disable " - ++ compkinds ++ " then the solver will merely try to make a plan with " - ++ "them available, so you may wish to explicitly enable them which will " - ++ "require the solver to find a plan with them available or to fail with an " - ++ "explanation." - where - compkinds = renderComponentKind Plural (componentKind cname) - + "Cannot " + ++ verb + ++ " the " + ++ showComponentName cname + ++ " because " + ++ "building " + ++ compkinds + ++ " has been explicitly disabled in the " + ++ "configuration. You can adjust this configuration in the " + ++ "cabal.project{.local} file either for all packages in the project or on " + ++ "a per-package basis. Note that if you do not explicitly disable " + ++ compkinds + ++ " then the solver will merely try to make a plan with " + ++ "them available, so you may wish to explicitly enable them which will " + ++ "require the solver to find a plan with them available or to fail with an " + ++ "explanation." + where + compkinds = renderComponentKind Plural (componentKind cname) renderTargetProblem verb _ (TargetOptionalStanzaDisabledBySolver pkgid cname _) = - "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the " - ++ "solver did not find a plan that included the " ++ compkinds - ++ " for " ++ prettyShow pkgid ++ ". It is probably worth trying again with " - ++ compkinds ++ " explicitly enabled in the configuration in the " - ++ "cabal.project{.local} file. This will ask the solver to find a plan with " - ++ "the " ++ compkinds ++ " available. It will either fail with an " - ++ "explanation or find a different plan that uses different versions of some " - ++ "other packages. Use the '--dry-run' flag to see package versions and " - ++ "check that you are happy with the choices." - where - compkinds = renderComponentKind Plural (componentKind cname) - + "Cannot " + ++ verb + ++ " the " + ++ showComponentName cname + ++ " because the " + ++ "solver did not find a plan that included the " + ++ compkinds + ++ " for " + ++ prettyShow pkgid + ++ ". It is probably worth trying again with " + ++ compkinds + ++ " explicitly enabled in the configuration in the " + ++ "cabal.project{.local} file. This will ask the solver to find a plan with " + ++ "the " + ++ compkinds + ++ " available. It will either fail with an " + ++ "explanation or find a different plan that uses different versions of some " + ++ "other packages. Use the '--dry-run' flag to see package versions and " + ++ "check that you are happy with the choices." + where + compkinds = renderComponentKind Plural (componentKind cname) renderTargetProblem verb _ (TargetProblemUnknownComponent pkgname ecname) = - "Cannot " ++ verb ++ " the " - ++ (case ecname of - Left ucname -> "component " ++ prettyShow ucname - Right cname -> renderComponentName pkgname cname) - ++ " from the package " ++ prettyShow pkgname - ++ ", because the package does not contain a " - ++ (case ecname of - Left _ -> "component" - Right cname -> renderComponentKind Singular (componentKind cname)) - ++ " with that name." - + "Cannot " + ++ verb + ++ " the " + ++ ( case ecname of + Left ucname -> "component " ++ prettyShow ucname + Right cname -> renderComponentName pkgname cname + ) + ++ " from the package " + ++ prettyShow pkgname + ++ ", because the package does not contain a " + ++ ( case ecname of + Left _ -> "component" + Right cname -> renderComponentKind Singular (componentKind cname) + ) + ++ " with that name." renderTargetProblem verb _ (TargetProblemNoSuchPackage pkgid) = - "Internal error when trying to " ++ verb ++ " the package " - ++ prettyShow pkgid ++ ". The package is not in the set of available targets " - ++ "for the project plan, which would suggest an inconsistency " - ++ "between readTargetSelectors and resolveTargets." - + "Internal error when trying to " + ++ verb + ++ " the package " + ++ prettyShow pkgid + ++ ". The package is not in the set of available targets " + ++ "for the project plan, which would suggest an inconsistency " + ++ "between readTargetSelectors and resolveTargets." renderTargetProblem verb _ (TargetProblemNoSuchComponent pkgid cname) = - "Internal error when trying to " ++ verb ++ " the " - ++ showComponentName cname ++ " from the package " ++ prettyShow pkgid - ++ ". The package,component pair is not in the set of available targets " - ++ "for the project plan, which would suggest an inconsistency " - ++ "between readTargetSelectors and resolveTargets." - + "Internal error when trying to " + ++ verb + ++ " the " + ++ showComponentName cname + ++ " from the package " + ++ prettyShow pkgid + ++ ". The package,component pair is not in the set of available targets " + ++ "for the project plan, which would suggest an inconsistency " + ++ "between readTargetSelectors and resolveTargets." ------------------------------------------------------------ -- Rendering error messages for TargetProblemNoneEnabled @@ -314,65 +367,79 @@ renderTargetProblem verb _ (TargetProblemNoSuchComponent pkgid cname) = -- | Several commands have a @TargetProblemNoneEnabled@ problem constructor. -- This renders an error message for those cases. --- -renderTargetProblemNoneEnabled :: String - -> TargetSelector - -> [AvailableTarget ()] - -> String +renderTargetProblemNoneEnabled + :: String + -> TargetSelector + -> [AvailableTarget ()] + -> String renderTargetProblemNoneEnabled verb targetSelector targets = - "Cannot " ++ verb ++ " " ++ renderTargetSelector targetSelector - ++ " because none of the components are available to build: " - ++ renderListSemiAnd - [ case (status, mstanza) of + "Cannot " + ++ verb + ++ " " + ++ renderTargetSelector targetSelector + ++ " because none of the components are available to build: " + ++ renderListSemiAnd + [ case (status, mstanza) of (TargetDisabledByUser, Just stanza) -> - renderListCommaAnd - [ "the " ++ showComponentName availableTargetComponentName - | AvailableTarget {availableTargetComponentName} <- targets' ] - ++ plural (listPlural targets') " is " " are " - ++ " not available because building " - ++ renderOptionalStanza Plural stanza - ++ " has been disabled in the configuration" + renderListCommaAnd + [ "the " ++ showComponentName availableTargetComponentName + | AvailableTarget{availableTargetComponentName} <- targets' + ] + ++ plural (listPlural targets') " is " " are " + ++ " not available because building " + ++ renderOptionalStanza Plural stanza + ++ " has been disabled in the configuration" (TargetDisabledBySolver, Just stanza) -> - renderListCommaAnd - [ "the " ++ showComponentName availableTargetComponentName - | AvailableTarget {availableTargetComponentName} <- targets' ] - ++ plural (listPlural targets') " is " " are " - ++ "not available because the solver picked a plan that does not " - ++ "include the " ++ renderOptionalStanza Plural stanza - ++ ", perhaps because no such plan exists. To see the error message " - ++ "explaining the problems with such plans, force the solver to " - ++ "include the " ++ renderOptionalStanza Plural stanza ++ " for all " - ++ "packages, by adding the line 'tests: True' to the " - ++ "'cabal.project.local' file." + renderListCommaAnd + [ "the " ++ showComponentName availableTargetComponentName + | AvailableTarget{availableTargetComponentName} <- targets' + ] + ++ plural (listPlural targets') " is " " are " + ++ "not available because the solver picked a plan that does not " + ++ "include the " + ++ renderOptionalStanza Plural stanza + ++ ", perhaps because no such plan exists. To see the error message " + ++ "explaining the problems with such plans, force the solver to " + ++ "include the " + ++ renderOptionalStanza Plural stanza + ++ " for all " + ++ "packages, by adding the line 'tests: True' to the " + ++ "'cabal.project.local' file." (TargetNotBuildable, _) -> - renderListCommaAnd - [ "the " ++ showComponentName availableTargetComponentName - | AvailableTarget {availableTargetComponentName} <- targets' ] - ++ plural (listPlural targets') " is " " are all " - ++ "marked as 'buildable: False'" + renderListCommaAnd + [ "the " ++ showComponentName availableTargetComponentName + | AvailableTarget{availableTargetComponentName} <- targets' + ] + ++ plural (listPlural targets') " is " " are all " + ++ "marked as 'buildable: False'" (TargetNotLocal, _) -> - renderListCommaAnd - [ "the " ++ showComponentName availableTargetComponentName - | AvailableTarget {availableTargetComponentName} <- targets' ] - ++ " cannot be built because cabal does not currently support " - ++ "building test suites or benchmarks of non-local dependencies" + renderListCommaAnd + [ "the " ++ showComponentName availableTargetComponentName + | AvailableTarget{availableTargetComponentName} <- targets' + ] + ++ " cannot be built because cabal does not currently support " + ++ "building test suites or benchmarks of non-local dependencies" (TargetBuildable () TargetNotRequestedByDefault, Just stanza) -> - renderListCommaAnd - [ "the " ++ showComponentName availableTargetComponentName - | AvailableTarget {availableTargetComponentName} <- targets' ] - ++ " will not be built because " ++ renderOptionalStanza Plural stanza - ++ " are not built by default in the current configuration (but you " - ++ "can still build them specifically)" --TODO: say how - _ -> error $ "renderBuildTargetProblem: unexpected status " - ++ show (status, mstanza) - | ((status, mstanza), targets') <- sortGroupOn groupingKey targets - ] + renderListCommaAnd + [ "the " ++ showComponentName availableTargetComponentName + | AvailableTarget{availableTargetComponentName} <- targets' + ] + ++ " will not be built because " + ++ renderOptionalStanza Plural stanza + ++ " are not built by default in the current configuration (but you " + ++ "can still build them specifically)" -- TODO: say how + _ -> + error $ + "renderBuildTargetProblem: unexpected status " + ++ show (status, mstanza) + | ((status, mstanza), targets') <- sortGroupOn groupingKey targets + ] where groupingKey t = ( availableTargetStatus t , case availableTargetStatus t of TargetNotBuildable -> Nothing - TargetNotLocal -> Nothing + TargetNotLocal -> Nothing _ -> optionalStanza (availableTargetComponentName t) ) @@ -382,34 +449,39 @@ renderTargetProblemNoneEnabled verb targetSelector targets = -- | Several commands have a @TargetProblemNoTargets@ problem constructor. -- This renders an error message for those cases. --- renderTargetProblemNoTargets :: String -> TargetSelector -> String renderTargetProblemNoTargets verb targetSelector = - "Cannot " ++ verb ++ " " ++ renderTargetSelector targetSelector - ++ " because " ++ reason targetSelector ++ ". " - ++ "Check the .cabal " - ++ plural (targetSelectorPluralPkgs targetSelector) + "Cannot " + ++ verb + ++ " " + ++ renderTargetSelector targetSelector + ++ " because " + ++ reason targetSelector + ++ ". " + ++ "Check the .cabal " + ++ plural + (targetSelectorPluralPkgs targetSelector) "file for the package and make sure that it properly declares " "files for the packages and make sure that they properly declare " - ++ "the components that you expect." + ++ "the components that you expect." where reason (TargetPackage _ _ Nothing) = - "it does not contain any components at all" + "it does not contain any components at all" reason (TargetPackage _ _ (Just kfilter)) = - "it does not contain any " ++ renderComponentKind Plural kfilter + "it does not contain any " ++ renderComponentKind Plural kfilter reason (TargetPackageNamed _ Nothing) = - "it does not contain any components at all" + "it does not contain any components at all" reason (TargetPackageNamed _ (Just kfilter)) = - "it does not contain any " ++ renderComponentKind Plural kfilter + "it does not contain any " ++ renderComponentKind Plural kfilter reason (TargetAllPackages Nothing) = - "none of them contain any components at all" + "none of them contain any components at all" reason (TargetAllPackages (Just kfilter)) = - "none of the packages contain any " - ++ renderComponentKind Plural kfilter + "none of the packages contain any " + ++ renderComponentKind Plural kfilter reason ts@TargetComponent{} = - error $ "renderTargetProblemNoTargets: " ++ show ts + error $ "renderTargetProblemNoTargets: " ++ show ts reason ts@TargetComponentUnknown{} = - error $ "renderTargetProblemNoTargets: " ++ show ts + error $ "renderTargetProblemNoTargets: " ++ show ts ----------------------------------------------------------- -- Rendering error messages for CannotPruneDependencies @@ -417,13 +489,16 @@ renderTargetProblemNoTargets verb targetSelector = renderCannotPruneDependencies :: CannotPruneDependencies -> String renderCannotPruneDependencies (CannotPruneDependencies brokenPackages) = - "Cannot select only the dependencies (as requested by the " - ++ "'--only-dependencies' flag), " - ++ (case pkgids of + "Cannot select only the dependencies (as requested by the " + ++ "'--only-dependencies' flag), " + ++ ( case pkgids of [pkgid] -> "the package " ++ prettyShow pkgid ++ " is " - _ -> "the packages " - ++ renderListCommaAnd (map prettyShow pkgids) ++ " are ") - ++ "required by a dependency of one of the other targets." + _ -> + "the packages " + ++ renderListCommaAnd (map prettyShow pkgids) + ++ " are " + ) + ++ "required by a dependency of one of the other targets." where -- throw away the details and just list the deps that are needed pkgids :: [PackageId] diff --git a/cabal-install/src/Distribution/Client/CmdExec.hs b/cabal-install/src/Distribution/Client/CmdExec.hs index 80220592498..9ac7a101fc8 100644 --- a/cabal-install/src/Distribution/Client/CmdExec.hs +++ b/cabal-install/src/Distribution/Client/CmdExec.hs @@ -1,4 +1,7 @@ ------------------------------------------------------------------------------- +------------------------------------------------------------------------------- +{-# LANGUAGE RecordWildCards #-} + -- | -- Module : Distribution.Client.Exec -- Maintainer : cabal-devel@haskell.org @@ -6,153 +9,165 @@ -- -- Implementation of the 'v2-exec' command for running an arbitrary executable -- in an environment suited to the part of the store built for a project. -------------------------------------------------------------------------------- - -{-# LANGUAGE RecordWildCards #-} module Distribution.Client.CmdExec ( execAction , execCommand ) where import Distribution.Client.DistDirLayout - ( DistDirLayout(..) + ( DistDirLayout (..) ) import Distribution.Client.InstallPlan - ( GenericPlanPackage(..) + ( GenericPlanPackage (..) , toGraph ) import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.Setup - ( ConfigFlags(configVerbosity) - , GlobalFlags + ( NixStyleFlags (..) + , defaultNixStyleFlags + , nixStyleOptions ) import Distribution.Client.ProjectFlags ( removeIgnoreProjectOption ) import Distribution.Client.ProjectOrchestration - ( ProjectBuildContext(..) - , runProjectPreBuildPhase - , CurrentCommand(..) - , establishProjectBaseContext - , distDirLayout + ( BuildTimeSettings (..) + , CurrentCommand (..) + , ProjectBaseContext (..) + , ProjectBuildContext (..) , commandLineFlagsToProjectConfig - , ProjectBaseContext(..) - , BuildTimeSettings(..) + , distDirLayout + , establishProjectBaseContext + , runProjectPreBuildPhase ) import Distribution.Client.ProjectPlanOutput - ( updatePostBuildProjectStatus - , createPackageEnvironment + ( PostBuildProjectStatus , argsEquivalentOfGhcEnvironmentFile - , PostBuildProjectStatus + , createPackageEnvironment + , updatePostBuildProjectStatus ) -import qualified Distribution.Client.ProjectPlanning as Planning import Distribution.Client.ProjectPlanning ( ElaboratedInstallPlan - , ElaboratedSharedConfig(..) + , ElaboratedSharedConfig (..) + ) +import qualified Distribution.Client.ProjectPlanning as Planning +import Distribution.Client.Setup + ( ConfigFlags (configVerbosity) + , GlobalFlags ) import Distribution.Simple.Command - ( CommandUI(..) ) + ( CommandUI (..) + ) +import Distribution.Simple.Flag + ( fromFlagOrDefault + ) +import Distribution.Simple.GHC + ( GhcImplInfo (supportsPkgEnvFiles) + , getImplInfo + ) import Distribution.Simple.Program.Db - ( modifyProgramSearchPath + ( configuredPrograms + , modifyProgramSearchPath , requireProgram - , configuredPrograms ) import Distribution.Simple.Program.Find - ( ProgramSearchPathEntry(..) + ( ProgramSearchPathEntry (..) ) import Distribution.Simple.Program.Run ( programInvocation , runProgramInvocation ) import Distribution.Simple.Program.Types - ( programOverrideEnv + ( ConfiguredProgram , programDefaultArgs + , programOverrideEnv , programPath , simpleProgram - , ConfiguredProgram - ) -import Distribution.Simple.GHC - ( getImplInfo - , GhcImplInfo(supportsPkgEnvFiles) ) -import Distribution.Simple.Flag - ( fromFlagOrDefault ) import Distribution.Simple.Utils - ( die' + ( createDirectoryIfMissingVerbose + , die' , info - , createDirectoryIfMissingVerbose + , notice , withTempDirectory , wrapText - , notice ) import Distribution.Verbosity ( normal ) -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () -import qualified Data.Set as S import qualified Data.Map as M +import qualified Data.Set as S execCommand :: CommandUI (NixStyleFlags ()) -execCommand = CommandUI - { commandName = "v2-exec" - , commandSynopsis = "Give a command access to the store." - , commandUsage = \pname -> - "Usage: " ++ pname ++ " v2-exec [FLAGS] [--] COMMAND [--] [ARGS]\n" - , commandDescription = Just $ \pname -> wrapText $ - "During development it is often useful to run build tasks and perform" - ++ " one-off program executions to experiment with the behavior of build" - ++ " tools. It is convenient to run these tools in the same way " ++ pname - ++ " itself would. The `" ++ pname ++ " v2-exec` command provides a way to" - ++ " do so.\n" - ++ "\n" - ++ "Compiler tools will be configured to see the same subset of the store" - ++ " that builds would see. The PATH is modified to make all executables in" - ++ " the dependency tree available (provided they have been built already)." - ++ " Commands are also rewritten in the way cabal itself would. For" - ++ " example, `" ++ pname ++ " v2-exec ghc` will consult the configuration" - ++ " to choose an appropriate version of ghc and to include any" - ++ " ghc-specific flags requested." - , commandNotes = Nothing - , commandOptions = removeIgnoreProjectOption - . nixStyleOptions (const []) - , commandDefaultFlags = defaultNixStyleFlags () - } +execCommand = + CommandUI + { commandName = "v2-exec" + , commandSynopsis = "Give a command access to the store." + , commandUsage = \pname -> + "Usage: " ++ pname ++ " v2-exec [FLAGS] [--] COMMAND [--] [ARGS]\n" + , commandDescription = Just $ \pname -> + wrapText $ + "During development it is often useful to run build tasks and perform" + ++ " one-off program executions to experiment with the behavior of build" + ++ " tools. It is convenient to run these tools in the same way " + ++ pname + ++ " itself would. The `" + ++ pname + ++ " v2-exec` command provides a way to" + ++ " do so.\n" + ++ "\n" + ++ "Compiler tools will be configured to see the same subset of the store" + ++ " that builds would see. The PATH is modified to make all executables in" + ++ " the dependency tree available (provided they have been built already)." + ++ " Commands are also rewritten in the way cabal itself would. For" + ++ " example, `" + ++ pname + ++ " v2-exec ghc` will consult the configuration" + ++ " to choose an appropriate version of ghc and to include any" + ++ " ghc-specific flags requested." + , commandNotes = Nothing + , commandOptions = + removeIgnoreProjectOption + . nixStyleOptions (const []) + , commandDefaultFlags = defaultNixStyleFlags () + } execAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -execAction flags@NixStyleFlags {..} extraArgs globalFlags = do - +execAction flags@NixStyleFlags{..} extraArgs globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand -- To set up the environment, we'd like to select the libraries in our -- dependency tree that we've already built. So first we set up an install -- plan, but we walk the dependency tree without first executing the plan. - buildCtx <- runProjectPreBuildPhase - verbosity - baseCtx - (\plan -> return (plan, M.empty)) + buildCtx <- + runProjectPreBuildPhase + verbosity + baseCtx + (\plan -> return (plan, M.empty)) -- We use the build status below to decide what libraries to include in the -- compiler environment, but we don't want to actually build anything. So we -- pass mempty to indicate that nothing happened and we just want the current -- status. - buildStatus <- updatePostBuildProjectStatus - verbosity - (distDirLayout baseCtx) - (elaboratedPlanOriginal buildCtx) - (pkgsBuildStatus buildCtx) - mempty + buildStatus <- + updatePostBuildProjectStatus + verbosity + (distDirLayout baseCtx) + (elaboratedPlanOriginal buildCtx) + (pkgsBuildStatus buildCtx) + mempty -- Some dependencies may have executables. Let's put those on the PATH. extraPaths <- pathAdditions verbosity baseCtx buildCtx - let programDb = modifyProgramSearchPath - (map ProgramSearchPathDir extraPaths ++) - . pkgConfigCompilerProgs - . elaboratedShared - $ buildCtx + let programDb = + modifyProgramSearchPath + (map ProgramSearchPathDir extraPaths ++) + . pkgConfigCompilerProgs + . elaboratedShared + $ buildCtx -- 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 @@ -164,7 +179,7 @@ execAction flags@NixStyleFlags {..} extraArgs globalFlags = do envFilesSupported = supportsPkgEnvFiles (getImplInfo compiler) case extraArgs of [] -> die' verbosity "Please specify an executable to run" - exe:args -> do + exe : args -> do (program, _) <- requireProgram verbosity (simpleProgram exe) programDb let argOverrides = argsEquivalentOfGhcEnvironmentFile @@ -172,89 +187,103 @@ execAction flags@NixStyleFlags {..} extraArgs globalFlags = do (distDirLayout baseCtx) (elaboratedPlanOriginal buildCtx) buildStatus - programIsConfiguredCompiler = matchCompilerPath - (elaboratedShared buildCtx) - program + programIsConfiguredCompiler = + matchCompilerPath + (elaboratedShared buildCtx) + program argOverrides' = if envFilesSupported - || not programIsConfiguredCompiler - then [] - else argOverrides + || not programIsConfiguredCompiler + then [] + else argOverrides - (if envFilesSupported - then withTempEnvFile verbosity baseCtx buildCtx buildStatus - else \f -> f []) $ \envOverrides -> do - let program' = withOverrides - envOverrides - argOverrides' - program - invocation = programInvocation program' args - dryRun = buildSettingDryRun (buildSettings baseCtx) + ( if envFilesSupported + then withTempEnvFile verbosity baseCtx buildCtx buildStatus + else \f -> f [] + ) + $ \envOverrides -> do + let program' = + withOverrides + envOverrides + argOverrides' + program + invocation = programInvocation program' args + dryRun = + buildSettingDryRun (buildSettings baseCtx) || buildSettingOnlyDownload (buildSettings baseCtx) - if dryRun - then notice verbosity "Running of executable suppressed by flag(s)" - else runProgramInvocation verbosity invocation + if dryRun + then notice verbosity "Running of executable suppressed by flag(s)" + else runProgramInvocation verbosity invocation where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - cliConfig = commandLineFlagsToProjectConfig globalFlags flags - mempty -- ClientInstallFlags, not needed here - withOverrides env args program = program - { programOverrideEnv = programOverrideEnv program ++ env - , programDefaultArgs = programDefaultArgs program ++ args} + cliConfig = + commandLineFlagsToProjectConfig + globalFlags + flags + mempty -- ClientInstallFlags, not needed here + withOverrides env args program = + program + { programOverrideEnv = programOverrideEnv program ++ env + , programDefaultArgs = programDefaultArgs program ++ args + } matchCompilerPath :: ElaboratedSharedConfig -> ConfiguredProgram -> Bool matchCompilerPath elaboratedShared program = programPath program - `elem` - (programPath <$> configuredCompilers) + `elem` (programPath <$> configuredCompilers) where configuredCompilers = configuredPrograms $ pkgConfigCompilerProgs elaboratedShared -- | Execute an action with a temporary .ghc.environment file reflecting the -- current environment. The action takes an environment containing the env -- variable which points ghc to the file. -withTempEnvFile :: Verbosity - -> ProjectBaseContext - -> ProjectBuildContext - -> PostBuildProjectStatus - -> ([(String, Maybe String)] -> IO a) - -> IO a +withTempEnvFile + :: Verbosity + -> ProjectBaseContext + -> ProjectBuildContext + -> PostBuildProjectStatus + -> ([(String, Maybe String)] -> IO a) + -> IO a withTempEnvFile verbosity baseCtx buildCtx buildStatus action = do createDirectoryIfMissingVerbose verbosity True (distTempDirectory (distDirLayout baseCtx)) withTempDirectory - verbosity - (distTempDirectory (distDirLayout baseCtx)) - "environment." - (\tmpDir -> do - envOverrides <- createPackageEnvironment - verbosity - tmpDir - (elaboratedPlanToExecute buildCtx) - (elaboratedShared buildCtx) - buildStatus - action envOverrides) + verbosity + (distTempDirectory (distDirLayout baseCtx)) + "environment." + ( \tmpDir -> do + envOverrides <- + createPackageEnvironment + verbosity + tmpDir + (elaboratedPlanToExecute buildCtx) + (elaboratedShared buildCtx) + buildStatus + action envOverrides + ) pathAdditions :: Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO [FilePath] -pathAdditions verbosity ProjectBaseContext{..}ProjectBuildContext{..} = do - info verbosity . unlines $ "Including the following directories in PATH:" - : paths +pathAdditions verbosity ProjectBaseContext{..} ProjectBuildContext{..} = do + info verbosity . unlines $ + "Including the following directories in PATH:" + : paths return paths where - paths = S.toList - $ binDirectories distDirLayout elaboratedShared elaboratedPlanToExecute + paths = + S.toList $ + binDirectories distDirLayout elaboratedShared elaboratedPlanToExecute binDirectories :: DistDirLayout -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> Set FilePath -binDirectories layout config = fromElaboratedInstallPlan where - fromElaboratedInstallPlan = fromGraph . toGraph - fromGraph = foldMap fromPlan - fromSrcPkg = S.fromList . Planning.binDirectories layout config - - fromPlan (PreExisting _) = mempty - fromPlan (Configured pkg) = fromSrcPkg pkg - fromPlan (Installed pkg) = fromSrcPkg pkg +binDirectories layout config = fromElaboratedInstallPlan + where + fromElaboratedInstallPlan = fromGraph . toGraph + fromGraph = foldMap fromPlan + fromSrcPkg = S.fromList . Planning.binDirectories layout config + fromPlan (PreExisting _) = mempty + fromPlan (Configured pkg) = fromSrcPkg pkg + fromPlan (Installed pkg) = fromSrcPkg pkg diff --git a/cabal-install/src/Distribution/Client/CmdFreeze.hs b/cabal-install/src/Distribution/Client/CmdFreeze.hs index 273e9046833..db8ef81fca2 100644 --- a/cabal-install/src/Distribution/Client/CmdFreeze.hs +++ b/cabal-install/src/Distribution/Client/CmdFreeze.hs @@ -1,92 +1,120 @@ -{-# LANGUAGE NamedFieldPuns, RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} -- | cabal-install CLI command: freeze --- -module Distribution.Client.CmdFreeze ( - freezeCommand, - freezeAction, +module Distribution.Client.CmdFreeze + ( freezeCommand + , freezeAction ) where import Distribution.Client.Compat.Prelude import Prelude () +import Distribution.Client.DistDirLayout + ( DistDirLayout (distProjectFile) + ) +import Distribution.Client.IndexUtils (ActiveRepos, TotalIndexState, filterSkippedActiveRepos) +import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) + ( NixStyleFlags (..) + , defaultNixStyleFlags + , nixStyleOptions + ) +import Distribution.Client.ProjectConfig + ( ProjectConfig (..) + , ProjectConfigShared (..) + , writeProjectLocalFreezeConfig + ) import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning -import Distribution.Client.ProjectConfig - ( ProjectConfig(..), ProjectConfigShared(..) - , writeProjectLocalFreezeConfig ) -import Distribution.Client.IndexUtils (TotalIndexState, ActiveRepos, filterSkippedActiveRepos) import Distribution.Client.Targets - ( UserQualifier(..), UserConstraintScope(..), UserConstraint(..) ) -import Distribution.Solver.Types.PackageConstraint - ( PackageProperty(..) ) + ( UserConstraint (..) + , UserConstraintScope (..) + , UserQualifier (..) + ) import Distribution.Solver.Types.ConstraintSource - ( ConstraintSource(..) ) -import Distribution.Client.DistDirLayout - ( DistDirLayout(distProjectFile) ) -import qualified Distribution.Client.InstallPlan as InstallPlan - + ( ConstraintSource (..) + ) +import Distribution.Solver.Types.PackageConstraint + ( PackageProperty (..) + ) +import Distribution.Client.Setup + ( ConfigFlags (..) + , GlobalFlags + ) import Distribution.Package - ( PackageName, packageName, packageVersion ) -import Distribution.Version - ( VersionRange, thisVersion - , unionVersionRanges, simplifyVersionRange ) + ( PackageName + , packageName + , packageVersion + ) import Distribution.PackageDescription - ( FlagAssignment, nullFlagAssignment ) -import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..) ) -import Distribution.Simple.Flag - ( fromFlagOrDefault ) -import Distribution.Simple.Flag (Flag (..)) + ( FlagAssignment + , nullFlagAssignment + ) +import Distribution.Simple.Flag (Flag (..), fromFlagOrDefault) import Distribution.Simple.Utils - ( die', notice, wrapText ) + ( die' + , notice + , wrapText + ) import Distribution.Verbosity - ( normal ) + ( normal + ) +import Distribution.Version + ( VersionRange + , simplifyVersionRange + , thisVersion + , unionVersionRanges + ) import qualified Data.Map as Map import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) + ( CommandUI (..) + , usageAlternatives + ) freezeCommand :: CommandUI (NixStyleFlags ()) -freezeCommand = CommandUI { - commandName = "v2-freeze", - commandSynopsis = "Freeze dependencies.", - commandUsage = usageAlternatives "v2-freeze" [ "[FLAGS]" ], - commandDescription = Just $ \_ -> wrapText $ - "The project configuration is frozen so that it will be reproducible " - ++ "in future.\n\n" - - ++ "The precise dependency configuration for the project is written to " - ++ "the 'cabal.project.freeze' file (or '$project_file.freeze' if " - ++ "'--project-file' is specified). This file extends the configuration " - ++ "from the 'cabal.project' file and thus is used as the project " - ++ "configuration for all other commands (such as 'v2-build', " - ++ "'v2-repl' etc).\n\n" - - ++ "The freeze file can be kept in source control. To make small " - ++ "adjustments it may be edited manually, or to make bigger changes " - ++ "you may wish to delete the file and re-freeze. For more control, " - ++ "one approach is to try variations using 'v2-build --dry-run' with " - ++ "solver flags such as '--constraint=\"pkg < 1.2\"' and once you have " - ++ "a satisfactory solution to freeze it using the 'v2-freeze' command " - ++ "with the same set of flags.", - - commandNotes = Just $ \pname -> +freezeCommand = + CommandUI + { commandName = "v2-freeze" + , commandSynopsis = "Freeze dependencies." + , commandUsage = usageAlternatives "v2-freeze" ["[FLAGS]"] + , commandDescription = Just $ \_ -> + wrapText $ + "The project configuration is frozen so that it will be reproducible " + ++ "in future.\n\n" + ++ "The precise dependency configuration for the project is written to " + ++ "the 'cabal.project.freeze' file (or '$project_file.freeze' if " + ++ "'--project-file' is specified). This file extends the configuration " + ++ "from the 'cabal.project' file and thus is used as the project " + ++ "configuration for all other commands (such as 'v2-build', " + ++ "'v2-repl' etc).\n\n" + ++ "The freeze file can be kept in source control. To make small " + ++ "adjustments it may be edited manually, or to make bigger changes " + ++ "you may wish to delete the file and re-freeze. For more control, " + ++ "one approach is to try variations using 'v2-build --dry-run' with " + ++ "solver flags such as '--constraint=\"pkg < 1.2\"' and once you have " + ++ "a satisfactory solution to freeze it using the 'v2-freeze' command " + ++ "with the same set of flags." + , commandNotes = Just $ \pname -> "Examples:\n" - ++ " " ++ pname ++ " v2-freeze\n" - ++ " Freeze the configuration of the current project\n\n" - ++ " " ++ pname ++ " v2-build --dry-run --constraint=\"aeson < 1\"\n" - ++ " Check what a solution with the given constraints would look like\n" - ++ " " ++ pname ++ " v2-freeze --constraint=\"aeson < 1\"\n" - ++ " Freeze a solution using the given constraints\n" - - , commandDefaultFlags = defaultNixStyleFlags () - , commandOptions = nixStyleOptions (const []) - } + ++ " " + ++ pname + ++ " v2-freeze\n" + ++ " Freeze the configuration of the current project\n\n" + ++ " " + ++ pname + ++ " v2-build --dry-run --constraint=\"aeson < 1\"\n" + ++ " Check what a solution with the given constraints would look like\n" + ++ " " + ++ pname + ++ " v2-freeze --constraint=\"aeson < 1\"\n" + ++ " Freeze a solution using the given constraints\n" + , commandDefaultFlags = defaultNixStyleFlags () + , commandOptions = nixStyleOptions (const []) + } -- | To a first approximation, the @freeze@ command runs the first phase of -- the @build@ command where we bring the install plan up to date, and then @@ -94,60 +122,66 @@ freezeCommand = CommandUI { -- -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" --- freezeAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -freezeAction flags@NixStyleFlags {..} extraArgs globalFlags = do - - unless (null extraArgs) $ - die' verbosity $ "'freeze' doesn't take any extra arguments: " - ++ unwords extraArgs - - ProjectBaseContext { - distDirLayout, - cabalDirLayout, - projectConfig, - localPackages, - buildSettings - } <- establishProjectBaseContext verbosity cliConfig OtherCommand - - (_, elaboratedPlan, _, totalIndexState, activeRepos) <- - rebuildInstallPlan verbosity - distDirLayout cabalDirLayout - projectConfig - localPackages - Nothing - - let freezeConfig = projectFreezeConfig elaboratedPlan totalIndexState activeRepos - dryRun = buildSettingDryRun buildSettings - || buildSettingOnlyDownload buildSettings - - if dryRun - then notice verbosity "Freeze file not written due to flag(s)" - else do - writeProjectLocalFreezeConfig distDirLayout freezeConfig - notice verbosity $ - "Wrote freeze file: " ++ distProjectFile distDirLayout "freeze" +freezeAction flags@NixStyleFlags{..} extraArgs globalFlags = do + unless (null extraArgs) $ + die' verbosity $ + "'freeze' doesn't take any extra arguments: " + ++ unwords extraArgs + + ProjectBaseContext + { distDirLayout + , cabalDirLayout + , projectConfig + , localPackages + , buildSettings + } <- + establishProjectBaseContext verbosity cliConfig OtherCommand + + (_, elaboratedPlan, _, totalIndexState, activeRepos) <- + rebuildInstallPlan + verbosity + distDirLayout + cabalDirLayout + projectConfig + localPackages + Nothing + let freezeConfig = projectFreezeConfig elaboratedPlan totalIndexState activeRepos + dryRun = + buildSettingDryRun buildSettings + || buildSettingOnlyDownload buildSettings + + if dryRun + then notice verbosity "Freeze file not written due to flag(s)" + else do + writeProjectLocalFreezeConfig distDirLayout freezeConfig + notice verbosity $ + "Wrote freeze file: " ++ distProjectFile distDirLayout "freeze" where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - cliConfig = commandLineFlagsToProjectConfig globalFlags flags - mempty -- ClientInstallFlags, not needed here + cliConfig = + commandLineFlagsToProjectConfig + globalFlags + flags + mempty -- ClientInstallFlags, not needed here -- | Given the install plan, produce a config value with constraints that -- freezes the versions of packages used in the plan. --- projectFreezeConfig - :: ElaboratedInstallPlan - -> TotalIndexState - -> ActiveRepos - -> ProjectConfig -projectFreezeConfig elaboratedPlan totalIndexState activeRepos0 = mempty - { projectConfigShared = mempty - { projectConfigConstraints = - concat (Map.elems (projectFreezeConstraints elaboratedPlan)) - , projectConfigIndexState = Flag totalIndexState - , projectConfigActiveRepos = Flag activeRepos - } + :: ElaboratedInstallPlan + -> TotalIndexState + -> ActiveRepos + -> ProjectConfig +projectFreezeConfig elaboratedPlan totalIndexState activeRepos0 = + mempty + { projectConfigShared = + mempty + { projectConfigConstraints = + concat (Map.elems (projectFreezeConstraints elaboratedPlan)) + , projectConfigIndexState = Flag totalIndexState + , projectConfigActiveRepos = Flag activeRepos + } } where activeRepos :: ActiveRepos @@ -155,50 +189,60 @@ projectFreezeConfig elaboratedPlan totalIndexState activeRepos0 = mempty -- | Given the install plan, produce solver constraints that will ensure the -- solver picks the same solution again in future in different environments. --- -projectFreezeConstraints :: ElaboratedInstallPlan - -> Map PackageName [(UserConstraint, ConstraintSource)] +projectFreezeConstraints + :: ElaboratedInstallPlan + -> Map PackageName [(UserConstraint, ConstraintSource)] projectFreezeConstraints plan = - -- - -- TODO: [required eventually] this is currently an underapproximation - -- since the constraints language is not expressive enough to specify the - -- precise solution. See https://github.com/haskell/cabal/issues/3502. - -- - -- For the moment we deal with multiple versions in the solution by using - -- constraints that allow either version. Also, we do not include any - -- /version/ constraints for packages that are local to the project (e.g. - -- if the solution has two instances of Cabal, one from the local project - -- and one pulled in as a setup deps then we exclude all constraints on - -- Cabal, not just the constraint for the local instance since any - -- constraint would apply to both instances). We do however keep flag - -- constraints of local packages. - -- - deleteLocalPackagesVersionConstraints - (Map.unionWith (++) versionConstraints flagConstraints) + -- + -- TODO: [required eventually] this is currently an underapproximation + -- since the constraints language is not expressive enough to specify the + -- precise solution. See https://github.com/haskell/cabal/issues/3502. + -- + -- For the moment we deal with multiple versions in the solution by using + -- constraints that allow either version. Also, we do not include any + -- /version/ constraints for packages that are local to the project (e.g. + -- if the solution has two instances of Cabal, one from the local project + -- and one pulled in as a setup deps then we exclude all constraints on + -- Cabal, not just the constraint for the local instance since any + -- constraint would apply to both instances). We do however keep flag + -- constraints of local packages. + -- + deleteLocalPackagesVersionConstraints + (Map.unionWith (++) versionConstraints flagConstraints) where versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)] versionConstraints = Map.mapWithKey - (\p v -> [(UserConstraint (UserAnyQualifier p) (PackagePropertyVersion v), - ConstraintSourceFreeze)]) + ( \p v -> + [ + ( UserConstraint (UserAnyQualifier p) (PackagePropertyVersion v) + , ConstraintSourceFreeze + ) + ] + ) versionRanges versionRanges :: Map PackageName VersionRange versionRanges = Map.map simplifyVersionRange $ - Map.fromListWith unionVersionRanges $ + Map.fromListWith unionVersionRanges $ [ (packageName pkg, thisVersion (packageVersion pkg)) | InstallPlan.PreExisting pkg <- InstallPlan.toList plan ] - ++ [ (packageName pkg, thisVersion (packageVersion pkg)) - | InstallPlan.Configured pkg <- InstallPlan.toList plan - ] + ++ [ (packageName pkg, thisVersion (packageVersion pkg)) + | InstallPlan.Configured pkg <- InstallPlan.toList plan + ] flagConstraints :: Map PackageName [(UserConstraint, ConstraintSource)] flagConstraints = Map.mapWithKey - (\p f -> [(UserConstraint (UserQualified UserQualToplevel p) (PackagePropertyFlags f), - ConstraintSourceFreeze)]) + ( \p f -> + [ + ( UserConstraint (UserQualified UserQualToplevel p) (PackagePropertyFlags f) + , ConstraintSourceFreeze + ) + ] + ) flagAssignments flagAssignments :: Map PackageName FlagAssignment @@ -206,9 +250,10 @@ projectFreezeConstraints plan = Map.fromList [ (pkgname, flags) | InstallPlan.Configured elab <- InstallPlan.toList plan - , let flags = elabFlagAssignment elab + , let flags = elabFlagAssignment elab pkgname = packageName elab - , not (nullFlagAssignment flags) ] + , not (nullFlagAssignment flags) + ] -- As described above, remove the version constraints on local packages, -- but leave any flag constraints. @@ -217,15 +262,17 @@ projectFreezeConstraints plan = -> Map PackageName [(UserConstraint, ConstraintSource)] deleteLocalPackagesVersionConstraints = Map.mergeWithKey - (\_pkgname () constraints -> + ( \_pkgname () constraints -> case filter (not . isVersionConstraint . fst) constraints of - [] -> Nothing - constraints' -> Just constraints') - (const Map.empty) id + [] -> Nothing + constraints' -> Just constraints' + ) + (const Map.empty) + id localPackages isVersionConstraint (UserConstraint _ (PackagePropertyVersion _)) = True - isVersionConstraint _ = False + isVersionConstraint _ = False localPackages :: Map PackageName () localPackages = diff --git a/cabal-install/src/Distribution/Client/CmdHaddock.hs b/cabal-install/src/Distribution/Client/CmdHaddock.hs index f3c7baa17ca..fea0cb4411d 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddock.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddock.hs @@ -1,173 +1,217 @@ {-# LANGUAGE RecordWildCards #-} -- | cabal-install CLI command: haddock --- -module Distribution.Client.CmdHaddock ( - -- * The @haddock@ CLI and action - haddockCommand, - haddockAction, - - ClientHaddockFlags(..), +module Distribution.Client.CmdHaddock + ( -- * The @haddock@ CLI and action + haddockCommand + , haddockAction + , ClientHaddockFlags (..) -- * Internals exposed for testing - selectPackageTargets, - selectComponentTarget + , selectPackageTargets + , selectComponentTarget ) where import Distribution.Client.Compat.Prelude -import Prelude () import System.Directory (makeAbsolute) +import Prelude () +import Distribution.Client.CmdErrorMessages +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..) + , defaultNixStyleFlags + , nixStyleOptions + ) import Distribution.Client.ProjectConfig.Types - (PackageConfig (..), ProjectConfig (..)) + ( PackageConfig (..) + , ProjectConfig (..) + ) import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning - ( ElaboratedSharedConfig(..) ) -import Distribution.Client.CmdErrorMessages -import Distribution.Client.TargetProblem - ( TargetProblem (..), TargetProblem' ) -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) + ( ElaboratedSharedConfig (..) + ) import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), InstallFlags (..)) -import Distribution.Simple.Setup - ( HaddockFlags(..), fromFlagOrDefault, trueArg ) + ( ConfigFlags (..) + , GlobalFlags + , InstallFlags (..) + ) +import Distribution.Client.TargetProblem + ( TargetProblem (..) + , TargetProblem' + ) import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives, ShowOrParseArgs, OptionField, option ) + ( CommandUI (..) + , OptionField + , ShowOrParseArgs + , option + , usageAlternatives + ) +import Distribution.Simple.Flag (Flag (..)) import Distribution.Simple.Program.Builtin - ( haddockProgram ) + ( haddockProgram + ) import Distribution.Simple.Program.Db - ( addKnownProgram, reconfigurePrograms ) -import Distribution.Verbosity - ( normal ) + ( addKnownProgram + , reconfigurePrograms + ) +import Distribution.Simple.Setup + ( HaddockFlags (..) + , fromFlagOrDefault + , trueArg + ) import Distribution.Simple.Utils - ( wrapText, die', notice ) -import Distribution.Simple.Flag (Flag(..)) + ( die' + , notice + , wrapText + ) +import Distribution.Verbosity + ( normal + ) import qualified System.Exit (exitSuccess) -newtype ClientHaddockFlags = ClientHaddockFlags { openInBrowser :: Flag Bool } +newtype ClientHaddockFlags = ClientHaddockFlags {openInBrowser :: Flag Bool} haddockCommand :: CommandUI (NixStyleFlags ClientHaddockFlags) -haddockCommand = CommandUI { - commandName = "v2-haddock", - commandSynopsis = "Build Haddock documentation.", - commandUsage = usageAlternatives "v2-haddock" [ "[FLAGS] TARGET" ], - commandDescription = Just $ \_ -> wrapText $ - "Build Haddock documentation for the specified packages within the " - ++ "project.\n\n" - - ++ "Any package in the project can be specified. If no package is " - ++ "specified, the default is to build the documentation for the package " - ++ "in the current directory. The default behaviour is to build " - ++ "documentation for the exposed modules of the library component (if " - ++ "any). This can be changed with the '--internal', '--executables', " - ++ "'--tests', '--benchmarks' or '--all' flags.\n\n" - - ++ "Currently, documentation for dependencies is NOT built. This " - ++ "behavior may change in future.\n\n" - - ++ "Additional configuration flags can be specified on the command line " - ++ "and these extend the project configuration from the 'cabal.project', " - ++ "'cabal.project.local' and other files.", - commandNotes = Just $ \pname -> +haddockCommand = + CommandUI + { commandName = "v2-haddock" + , commandSynopsis = "Build Haddock documentation." + , commandUsage = usageAlternatives "v2-haddock" ["[FLAGS] TARGET"] + , commandDescription = Just $ \_ -> + wrapText $ + "Build Haddock documentation for the specified packages within the " + ++ "project.\n\n" + ++ "Any package in the project can be specified. If no package is " + ++ "specified, the default is to build the documentation for the package " + ++ "in the current directory. The default behaviour is to build " + ++ "documentation for the exposed modules of the library component (if " + ++ "any). This can be changed with the '--internal', '--executables', " + ++ "'--tests', '--benchmarks' or '--all' flags.\n\n" + ++ "Currently, documentation for dependencies is NOT built. This " + ++ "behavior may change in future.\n\n" + ++ "Additional configuration flags can be specified on the command line " + ++ "and these extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files." + , commandNotes = Just $ \pname -> "Examples:\n" - ++ " " ++ pname ++ " v2-haddock pkgname" - ++ " Build documentation for the package named pkgname\n" - , commandOptions = nixStyleOptions haddockOptions - , commandDefaultFlags = defaultNixStyleFlags (ClientHaddockFlags (Flag False)) - } - --TODO: [nice to have] support haddock on specific components, not just - -- whole packages and the silly --executables etc modifiers. + ++ " " + ++ pname + ++ " v2-haddock pkgname" + ++ " Build documentation for the package named pkgname\n" + , commandOptions = nixStyleOptions haddockOptions + , commandDefaultFlags = defaultNixStyleFlags (ClientHaddockFlags (Flag False)) + } + +-- TODO: [nice to have] support haddock on specific components, not just +-- whole packages and the silly --executables etc modifiers. haddockOptions :: ShowOrParseArgs -> [OptionField ClientHaddockFlags] haddockOptions _ = - [ option [] ["open"] "Open generated documentation in the browser" - openInBrowser (\v f -> f { openInBrowser = v}) trueArg + [ option + [] + ["open"] + "Open generated documentation in the browser" + openInBrowser + (\v f -> f{openInBrowser = v}) + trueArg ] mkConfigAbsolute :: ProjectConfig -> IO ProjectConfig mkConfigAbsolute relConfig = do let relPackageConfig = projectConfigLocalPackages relConfig absHaddockOutputDir <- traverse makeAbsolute (packageConfigHaddockOutputDir relPackageConfig) - return (relConfig { projectConfigLocalPackages = relPackageConfig { - packageConfigHaddockOutputDir = absHaddockOutputDir} }) + return + ( relConfig + { projectConfigLocalPackages = + relPackageConfig + { packageConfigHaddockOutputDir = absHaddockOutputDir + } + } + ) mkFlagsAbsolute :: NixStyleFlags ClientHaddockFlags -> IO (NixStyleFlags ClientHaddockFlags) mkFlagsAbsolute relFlags = do let relHaddockFlags = haddockFlags relFlags absHaddockOutputDir <- traverse makeAbsolute (haddockOutputDir relHaddockFlags) - return (relFlags { haddockFlags = relHaddockFlags { haddockOutputDir = absHaddockOutputDir } }) + return (relFlags{haddockFlags = relHaddockFlags{haddockOutputDir = absHaddockOutputDir}}) -- | The @haddock@ command is TODO. -- -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" --- haddockAction :: NixStyleFlags ClientHaddockFlags -> [String] -> GlobalFlags -> IO () haddockAction relFlags targetStrings globalFlags = do - -- It's important to make --haddock-output-dir absolute since we change the working directory later. - flags@NixStyleFlags {..} <- mkFlagsAbsolute relFlags - - let - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - installDoc = fromFlagOrDefault True (installDocumentation installFlags) - flags' = flags { installFlags = installFlags { installDocumentation = Flag installDoc } } - cliConfig = commandLineFlagsToProjectConfig globalFlags flags' mempty -- ClientInstallFlags, not needed here - - projCtx <- establishProjectBaseContext verbosity cliConfig HaddockCommand - - let relBaseCtx@ProjectBaseContext { projectConfig = relProjectConfig } - | fromFlagOrDefault False (openInBrowser extraFlags) - = projCtx { buildSettings = (buildSettings projCtx) { buildSettingHaddockOpen = True } } - | otherwise - = projCtx - absProjectConfig <- mkConfigAbsolute relProjectConfig - let baseCtx = relBaseCtx { projectConfig = absProjectConfig } - - targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings - - buildCtx <- - runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - - when (buildSettingOnlyDeps (buildSettings baseCtx)) $ - die' verbosity - "The haddock command does not support '--only-dependencies'." - - -- When we interpret the targets on the command line, interpret them as - -- haddock targets - targets <- either (reportBuildDocumentationTargetProblems verbosity) return - $ resolveTargets - (selectPackageTargets haddockFlags) - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors - - let elaboratedPlan' = pruneInstallPlanToTargets - TargetActionHaddock - targets - elaboratedPlan - return (elaboratedPlan', targets) - - printPlan verbosity baseCtx buildCtx - - progs <- reconfigurePrograms verbosity - (haddockProgramPaths haddockFlags) - (haddockProgramArgs haddockFlags) - -- we need to insert 'haddockProgram' before we reconfigure it, - -- otherwise 'set - . addKnownProgram haddockProgram - . pkgConfigCompilerProgs - . elaboratedShared - $ buildCtx - let buildCtx' = buildCtx { elaboratedShared = - (elaboratedShared buildCtx) - { pkgConfigCompilerProgs = progs } } - - buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx' - runProjectPostBuildPhase verbosity baseCtx buildCtx' buildOutcomes + -- It's important to make --haddock-output-dir absolute since we change the working directory later. + flags@NixStyleFlags{..} <- mkFlagsAbsolute relFlags + + let + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + installDoc = fromFlagOrDefault True (installDocumentation installFlags) + flags' = flags{installFlags = installFlags{installDocumentation = Flag installDoc}} + cliConfig = commandLineFlagsToProjectConfig globalFlags flags' mempty -- ClientInstallFlags, not needed here + projCtx <- establishProjectBaseContext verbosity cliConfig HaddockCommand + + let relBaseCtx@ProjectBaseContext{projectConfig = relProjectConfig} + | fromFlagOrDefault False (openInBrowser extraFlags) = + projCtx{buildSettings = (buildSettings projCtx){buildSettingHaddockOpen = True}} + | otherwise = + projCtx + absProjectConfig <- mkConfigAbsolute relProjectConfig + let baseCtx = relBaseCtx{projectConfig = absProjectConfig} + + targetSelectors <- + either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + die' + verbosity + "The haddock command does not support '--only-dependencies'." + + -- When we interpret the targets on the command line, interpret them as + -- haddock targets + targets <- + either (reportBuildDocumentationTargetProblems verbosity) return $ + resolveTargets + (selectPackageTargets haddockFlags) + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + let elaboratedPlan' = + pruneInstallPlanToTargets + TargetActionHaddock + targets + elaboratedPlan + return (elaboratedPlan', targets) + + printPlan verbosity baseCtx buildCtx + + progs <- + reconfigurePrograms + verbosity + (haddockProgramPaths haddockFlags) + (haddockProgramArgs haddockFlags) + -- we need to insert 'haddockProgram' before we reconfigure it, + -- otherwise 'set + . addKnownProgram haddockProgram + . pkgConfigCompilerProgs + . elaboratedShared + $ buildCtx + let buildCtx' = + buildCtx + { elaboratedShared = + (elaboratedShared buildCtx) + { pkgConfigCompilerProgs = progs + } + } + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx' + runProjectPostBuildPhase verbosity baseCtx buildCtx' buildOutcomes -- | This defines what a 'TargetSelector' means for the @haddock@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, @@ -176,38 +220,37 @@ haddockAction relFlags targetStrings globalFlags = do -- For the @haddock@ command we select all buildable libraries. Additionally, -- depending on the @--executables@ flag we also select all the buildable exes. -- We do similarly for test-suites, benchmarks and foreign libs. --- -selectPackageTargets :: HaddockFlags -> TargetSelector - -> [AvailableTarget k] -> Either TargetProblem' [k] +selectPackageTargets + :: HaddockFlags + -> TargetSelector + -> [AvailableTarget k] + -> Either TargetProblem' [k] selectPackageTargets haddockFlags targetSelector targets - - -- If there are any buildable targets then we select those - | not (null targetsBuildable) - = Right targetsBuildable - - -- If there are targets but none are buildable then we report those - | not (null targets) - = Left (TargetProblemNoneEnabled targetSelector targets') - - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) + -- If there are any buildable targets then we select those + | not (null targetsBuildable) = + Right targetsBuildable + -- If there are targets but none are buildable then we report those + | not (null targets) = + Left (TargetProblemNoneEnabled targetSelector targets') + -- If there are no targets at all then we report that + | otherwise = + Left (TargetProblemNoTargets targetSelector) where - targets' = forgetTargetsDetail (map disableNotRequested targets) + targets' = forgetTargetsDetail (map disableNotRequested targets) targetsBuildable = selectBuildableTargets (map disableNotRequested targets) -- When there's a target filter like "pkg:exes" then we do select exes, -- but if it's just a target like "pkg" then we don't build docs for exes -- unless they are requested by default (i.e. by using --executables) disableNotRequested t@(AvailableTarget _ cname (TargetBuildable _ _) _) - | not (isRequested targetSelector (componentKind cname)) - = t { availableTargetStatus = TargetDisabledByUser } + | not (isRequested targetSelector (componentKind cname)) = + t{availableTargetStatus = TargetDisabledByUser} disableNotRequested t = t isRequested (TargetPackage _ _ (Just _)) _ = True isRequested (TargetAllPackages (Just _)) _ = True - isRequested _ LibKind = True --- isRequested _ SubLibKind = True --TODO: what about sublibs? + isRequested _ LibKind = True + -- isRequested _ SubLibKind = True --TODO: what about sublibs? -- TODO/HACK, we encode some defaults here as v2-haddock's logic; -- make sure this matches the defaults applied in @@ -215,31 +258,32 @@ selectPackageTargets haddockFlags targetSelector targets -- to be done properly -- -- See also https://github.com/haskell/cabal/pull/4886 - isRequested _ FLibKind = fromFlagOrDefault False (haddockForeignLibs haddockFlags) - isRequested _ ExeKind = fromFlagOrDefault False (haddockExecutables haddockFlags) - isRequested _ TestKind = fromFlagOrDefault False (haddockTestSuites haddockFlags) - isRequested _ BenchKind = fromFlagOrDefault False (haddockBenchmarks haddockFlags) - + isRequested _ FLibKind = fromFlagOrDefault False (haddockForeignLibs haddockFlags) + isRequested _ ExeKind = fromFlagOrDefault False (haddockExecutables haddockFlags) + isRequested _ TestKind = fromFlagOrDefault False (haddockTestSuites haddockFlags) + isRequested _ BenchKind = fromFlagOrDefault False (haddockBenchmarks haddockFlags) -- | For a 'TargetComponent' 'TargetSelector', check if the component can be -- selected. -- -- For the @haddock@ command we just need the basic checks on being buildable -- etc. --- -selectComponentTarget :: SubComponentTarget - -> AvailableTarget k -> Either TargetProblem' k +selectComponentTarget + :: SubComponentTarget + -> AvailableTarget k + -> Either TargetProblem' k selectComponentTarget = selectComponentTargetBasic reportBuildDocumentationTargetProblems :: Verbosity -> [TargetProblem'] -> IO a reportBuildDocumentationTargetProblems verbosity problems = case problems of [TargetProblemNoneEnabled _ _] -> do - notice verbosity $ unwords - [ "No documentation was generated as this package does not contain a library." - , "Perhaps you want to use the --haddock-all flag, or one or more of the" - , "--haddock-executables, --haddock-tests, --haddock-benchmarks or" - , "--haddock-internal flags." - ] + notice verbosity $ + unwords + [ "No documentation was generated as this package does not contain a library." + , "Perhaps you want to use the --haddock-all flag, or one or more of the" + , "--haddock-executables, --haddock-tests, --haddock-benchmarks or" + , "--haddock-internal flags." + ] System.Exit.exitSuccess _ -> reportTargetProblems verbosity "build documentation for" problems diff --git a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs index aaa65f837cc..535d2aacb3d 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs @@ -3,299 +3,368 @@ module Distribution.Client.CmdHaddockProject , haddockProjectAction ) where -import Prelude () import Data.Bool (bool) import Distribution.Client.Compat.Prelude hiding (get) +import Prelude () -import qualified Distribution.Client.CmdBuild as CmdBuild +import qualified Distribution.Client.CmdBuild as CmdBuild import qualified Distribution.Client.CmdHaddock as CmdHaddock -import Distribution.Client.DistDirLayout (DistDirLayout(..) - ,CabalDirLayout(..) - ,StoreDirLayout(..)) -import Distribution.Client.InstallPlan (foldPlanPackage) +import Distribution.Client.DistDirLayout + ( CabalDirLayout (..) + , DistDirLayout (..) + , StoreDirLayout (..) + ) +import Distribution.Client.InstallPlan (foldPlanPackage) import qualified Distribution.Client.InstallPlan as InstallPlan import qualified Distribution.Client.NixStyleOptions as NixStyleOptions import Distribution.Client.ProjectOrchestration - (AvailableTarget(..) - ,AvailableTargetStatus(..) - ,CurrentCommand(..) - ,ProjectBaseContext(..) - ,ProjectBuildContext(..) - ,TargetSelector(..) - ,printPlan - ,pruneInstallPlanToTargets - ,resolveTargets - ,runProjectPreBuildPhase - ,selectComponentTargetBasic) -import Distribution.Client.ProjectPlanning (ElaboratedConfiguredPackage(..) - ,ElaboratedInstallPlan - ,ElaboratedSharedConfig(..) - ,TargetAction(..)) + ( AvailableTarget (..) + , AvailableTargetStatus (..) + , CurrentCommand (..) + , ProjectBaseContext (..) + , ProjectBuildContext (..) + , TargetSelector (..) + , printPlan + , pruneInstallPlanToTargets + , resolveTargets + , runProjectPreBuildPhase + , selectComponentTargetBasic + ) +import Distribution.Client.ProjectPlanning + ( ElaboratedConfiguredPackage (..) + , ElaboratedInstallPlan + , ElaboratedSharedConfig (..) + , TargetAction (..) + ) import Distribution.Client.ProjectPlanning.Types - (elabDistDirParams) -import Distribution.Client.Setup (GlobalFlags(..) - ,ConfigFlags(..)) -import Distribution.Client.ScriptUtils (AcceptNoTargets(..) - ,TargetContext(..) - ,updateContextAndWriteProjectFile - ,withContextAndSelectors) -import Distribution.Client.TargetProblem (TargetProblem(..)) + ( elabDistDirParams + ) +import Distribution.Client.ScriptUtils + ( AcceptNoTargets (..) + , TargetContext (..) + , updateContextAndWriteProjectFile + , withContextAndSelectors + ) +import Distribution.Client.Setup + ( ConfigFlags (..) + , GlobalFlags (..) + ) +import Distribution.Client.TargetProblem (TargetProblem (..)) -import Distribution.Types.PackageId (pkgName) -import Distribution.Types.PackageName (unPackageName) -import Distribution.Types.Version (mkVersion) -import Distribution.Types.VersionRange (orLaterVersion) -import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo (..)) import Distribution.Simple.Command - ( CommandUI(..) ) + ( CommandUI (..) + ) import Distribution.Simple.Compiler - ( Compiler (..) ) + ( Compiler (..) + ) import Distribution.Simple.Flag - ( Flag(..) - , flagElim - , flagToList - , fromFlag - , fromFlagOrDefault - ) -import Distribution.Simple.InstallDirs - ( toPathTemplate ) + ( Flag (..) + , flagElim + , flagToList + , fromFlag + , fromFlagOrDefault + ) import Distribution.Simple.Haddock (createHaddockIndex) -import Distribution.Simple.Utils - ( die', createDirectoryIfMissingVerbose - , copyDirectoryRecursive, warn ) +import Distribution.Simple.InstallDirs + ( toPathTemplate + ) import Distribution.Simple.Program.Builtin - ( haddockProgram ) + ( haddockProgram + ) import Distribution.Simple.Program.Db - ( addKnownProgram, reconfigurePrograms, requireProgramVersion ) + ( addKnownProgram + , reconfigurePrograms + , requireProgramVersion + ) import Distribution.Simple.Setup - ( HaddockFlags(..), defaultHaddockFlags - , HaddockProjectFlags(..) - , Visibility(..) - , haddockProjectCommand - ) + ( HaddockFlags (..) + , HaddockProjectFlags (..) + , Visibility (..) + , defaultHaddockFlags + , haddockProjectCommand + ) +import Distribution.Simple.Utils + ( copyDirectoryRecursive + , createDirectoryIfMissingVerbose + , die' + , warn + ) +import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo (..)) +import Distribution.Types.PackageId (pkgName) +import Distribution.Types.PackageName (unPackageName) +import Distribution.Types.Version (mkVersion) +import Distribution.Types.VersionRange (orLaterVersion) import Distribution.Verbosity as Verbosity - ( normal ) + ( normal + ) -import System.FilePath ( takeDirectory, normalise, (), (<.>) ) -import System.Directory ( doesDirectoryExist, doesFileExist ) +import System.Directory (doesDirectoryExist, doesFileExist) +import System.FilePath (normalise, takeDirectory, (<.>), ()) haddockProjectAction :: HaddockProjectFlags -> [String] -> GlobalFlags -> IO () haddockProjectAction flags _extraArgs globalFlags = do - -- create destination directory if it does not exist - let outputDir = normalise $ fromFlag (haddockProjectDir flags) - createDirectoryIfMissingVerbose verbosity True outputDir + -- create destination directory if it does not exist + let outputDir = normalise $ fromFlag (haddockProjectDir flags) + createDirectoryIfMissingVerbose verbosity True outputDir - when ((2::Int) <= - ( flagElim 0 (bool 0 1) (haddockProjectHackage flags) - + flagElim 0 (bool 0 1) (haddockProjectLocal flags) - + flagElim 0 (const 1) (haddockProjectHtmlLocation flags) - )) $ - die' verbosity "Options `--local`, `--hackage` and `--html-location` are mutually exclusive`" + when + ( (2 :: Int) + <= ( flagElim 0 (bool 0 1) (haddockProjectHackage flags) + + flagElim 0 (bool 0 1) (haddockProjectLocal flags) + + flagElim 0 (const 1) (haddockProjectHtmlLocation flags) + ) + ) + $ die' verbosity "Options `--local`, `--hackage` and `--html-location` are mutually exclusive`" - warn verbosity "haddock-project command is experimental, it might break in the future" + warn verbosity "haddock-project command is experimental, it might break in the future" - -- build all packages with appropriate haddock flags - let haddockFlags = defaultHaddockFlags - { haddockHtml = Flag True - -- one can either use `--haddock-base-url` or - -- `--haddock-html-location`. - , haddockBaseUrl = if localStyle - then Flag ".." - else NoFlag - , haddockProgramPaths = haddockProjectProgramPaths flags - , haddockProgramArgs = haddockProjectProgramArgs flags - , haddockHtmlLocation = if fromFlagOrDefault False (haddockProjectHackage flags) - then Flag "https://hackage.haskell.org/package/$pkg-$version/docs" - else haddockProjectHtmlLocation flags - , haddockHoogle = haddockProjectHoogle flags - , haddockExecutables = haddockProjectExecutables flags - , haddockTestSuites = haddockProjectTestSuites flags - , haddockBenchmarks = haddockProjectBenchmarks flags - , haddockForeignLibs = haddockProjectForeignLibs flags - , haddockInternal = haddockProjectInternal flags - , haddockCss = haddockProjectCss flags - , haddockLinkedSource = if localOrHackage - then Flag True - else haddockProjectLinkedSource flags - , haddockQuickJump = if localOrHackage - then Flag True - else haddockProjectQuickJump flags - , haddockHscolourCss = haddockProjectHscolourCss flags - , haddockContents = if localStyle then Flag (toPathTemplate "../index.html") - else NoFlag - , haddockIndex = if localStyle then Flag (toPathTemplate "../doc-index.html") - else NoFlag - , haddockKeepTempFiles= haddockProjectKeepTempFiles flags - , haddockVerbosity = haddockProjectVerbosity flags - , haddockLib = haddockProjectLib flags - , haddockOutputDir = haddockProjectOutputDir flags + -- build all packages with appropriate haddock flags + let haddockFlags = + defaultHaddockFlags + { haddockHtml = Flag True + , -- one can either use `--haddock-base-url` or + -- `--haddock-html-location`. + haddockBaseUrl = + if localStyle + then Flag ".." + else NoFlag + , haddockProgramPaths = haddockProjectProgramPaths flags + , haddockProgramArgs = haddockProjectProgramArgs flags + , haddockHtmlLocation = + if fromFlagOrDefault False (haddockProjectHackage flags) + then Flag "https://hackage.haskell.org/package/$pkg-$version/docs" + else haddockProjectHtmlLocation flags + , haddockHoogle = haddockProjectHoogle flags + , haddockExecutables = haddockProjectExecutables flags + , haddockTestSuites = haddockProjectTestSuites flags + , haddockBenchmarks = haddockProjectBenchmarks flags + , haddockForeignLibs = haddockProjectForeignLibs flags + , haddockInternal = haddockProjectInternal flags + , haddockCss = haddockProjectCss flags + , haddockLinkedSource = + if localOrHackage + then Flag True + else haddockProjectLinkedSource flags + , haddockQuickJump = + if localOrHackage + then Flag True + else haddockProjectQuickJump flags + , haddockHscolourCss = haddockProjectHscolourCss flags + , haddockContents = + if localStyle + then Flag (toPathTemplate "../index.html") + else NoFlag + , haddockIndex = + if localStyle + then Flag (toPathTemplate "../doc-index.html") + else NoFlag + , haddockKeepTempFiles = haddockProjectKeepTempFiles flags + , haddockVerbosity = haddockProjectVerbosity flags + , haddockLib = haddockProjectLib flags + , haddockOutputDir = haddockProjectOutputDir flags + } + nixFlags = + (commandDefaultFlags CmdHaddock.haddockCommand) + { NixStyleOptions.haddockFlags = haddockFlags + , NixStyleOptions.configFlags = + (NixStyleOptions.configFlags (commandDefaultFlags CmdBuild.buildCommand)) + { configVerbosity = haddockProjectVerbosity flags + } } - nixFlags = (commandDefaultFlags CmdHaddock.haddockCommand) - { NixStyleOptions.haddockFlags = haddockFlags - , NixStyleOptions.configFlags = - (NixStyleOptions.configFlags (commandDefaultFlags CmdBuild.buildCommand)) - { configVerbosity = haddockProjectVerbosity flags } - } - -- - -- Construct the build plan and infer the list of packages which haddocks - -- we need. - -- + -- + -- Construct the build plan and infer the list of packages which haddocks + -- we need. + -- - withContextAndSelectors RejectNoTargets Nothing nixFlags ["all"] globalFlags HaddockCommand $ \targetCtx ctx targetSelectors -> do - baseCtx <- case targetCtx of - ProjectContext -> return ctx - GlobalContext -> return ctx - ScriptContext path exemeta -> updateContextAndWriteProjectFile ctx path exemeta - let distLayout = distDirLayout baseCtx - cabalLayout = cabalDirLayout baseCtx - buildCtx <- - runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - -- Interpret the targets on the command line as build targets - -- (as opposed to say repl or haddock targets). - targets <- either reportTargetProblems return - $ resolveTargets - selectPackageTargets - selectComponentTargetBasic - elaboratedPlan - Nothing - targetSelectors + withContextAndSelectors RejectNoTargets Nothing nixFlags ["all"] globalFlags HaddockCommand $ \targetCtx ctx targetSelectors -> do + baseCtx <- case targetCtx of + ProjectContext -> return ctx + GlobalContext -> return ctx + ScriptContext path exemeta -> updateContextAndWriteProjectFile ctx path exemeta + let distLayout = distDirLayout baseCtx + cabalLayout = cabalDirLayout baseCtx + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + -- Interpret the targets on the command line as build targets + -- (as opposed to say repl or haddock targets). + targets <- + either reportTargetProblems return $ + resolveTargets + selectPackageTargets + selectComponentTargetBasic + elaboratedPlan + Nothing + targetSelectors - let elaboratedPlan' = pruneInstallPlanToTargets - TargetActionBuild - targets - elaboratedPlan - return (elaboratedPlan', targets) + let elaboratedPlan' = + pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan + return (elaboratedPlan', targets) - printPlan verbosity baseCtx buildCtx + printPlan verbosity baseCtx buildCtx - let elaboratedPlan :: ElaboratedInstallPlan - elaboratedPlan = elaboratedPlanOriginal buildCtx + let elaboratedPlan :: ElaboratedInstallPlan + elaboratedPlan = elaboratedPlanOriginal buildCtx - sharedConfig :: ElaboratedSharedConfig - sharedConfig = elaboratedShared buildCtx + sharedConfig :: ElaboratedSharedConfig + sharedConfig = elaboratedShared buildCtx - pkgs :: [Either InstalledPackageInfo ElaboratedConfiguredPackage ] - pkgs = matchingPackages elaboratedPlan + pkgs :: [Either InstalledPackageInfo ElaboratedConfiguredPackage] + pkgs = matchingPackages elaboratedPlan - progs <- reconfigurePrograms verbosity - (haddockProjectProgramPaths flags) - (haddockProjectProgramArgs flags) - -- we need to insert 'haddockProgram' before we reconfigure it, - -- otherwise 'set - . addKnownProgram haddockProgram - . pkgConfigCompilerProgs - $ sharedConfig - let sharedConfig' = sharedConfig { pkgConfigCompilerProgs = progs } + progs <- + reconfigurePrograms + verbosity + (haddockProjectProgramPaths flags) + (haddockProjectProgramArgs flags) + -- we need to insert 'haddockProgram' before we reconfigure it, + -- otherwise 'set + . addKnownProgram haddockProgram + . pkgConfigCompilerProgs + $ sharedConfig + let sharedConfig' = sharedConfig{pkgConfigCompilerProgs = progs} - _ <- requireProgramVersion - verbosity haddockProgram - (orLaterVersion (mkVersion [2,26,1])) progs + _ <- + requireProgramVersion + verbosity + haddockProgram + (orLaterVersion (mkVersion [2, 26, 1])) + progs - -- - -- Build haddocks of each components - -- + -- + -- Build haddocks of each components + -- - CmdHaddock.haddockAction - nixFlags - ["all"] - globalFlags + CmdHaddock.haddockAction + nixFlags + ["all"] + globalFlags - -- - -- Copy haddocks to the destination folder - -- + -- + -- Copy haddocks to the destination folder + -- - packageInfos <- fmap (nub . concat) $ for pkgs $ \pkg -> - case pkg of - Left _ | not localStyle -> - return [] - Left package -> do - let packageName = unPackageName (pkgName $ sourcePackageId package) - destDir = outputDir packageName - fmap catMaybes $ for (haddockInterfaces package) $ \interfacePath -> do - let docDir = takeDirectory interfacePath - a <- doesFileExist interfacePath + packageInfos <- fmap (nub . concat) $ for pkgs $ \pkg -> + case pkg of + Left _ + | not localStyle -> + return [] + Left package -> 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 -> + copyDirectoryRecursive verbosity docDir destDir + >> return + ( Just + ( packageName + , interfacePath + , Hidden + ) + ) + False -> return Nothing + Right package -> + case elabLocalToProject package of + True -> do + let distDirParams = elabDistDirParams sharedConfig' package + buildDir = distBuildDirectory distLayout distDirParams + packageName = unPackageName (pkgName $ elabPkgSourceId package) + let docDir = + buildDir + "doc" + "html" + packageName + destDir = outputDir packageName + interfacePath = + destDir + packageName + <.> "haddock" + a <- doesDirectoryExist docDir case a of - True -> copyDirectoryRecursive verbosity docDir destDir - >> return (Just ( packageName - , interfacePath - , Hidden - )) - False -> return Nothing - - Right package -> - case elabLocalToProject package of - True -> do - let distDirParams = elabDistDirParams sharedConfig' package - buildDir = distBuildDirectory distLayout distDirParams - packageName = unPackageName (pkgName $ elabPkgSourceId package) - let docDir = buildDir - "doc" "html" - packageName - destDir = outputDir packageName - interfacePath = destDir - packageName <.> "haddock" - a <- doesDirectoryExist docDir - case a of - True -> copyDirectoryRecursive verbosity docDir destDir - >> return [( packageName - , interfacePath - , Visible - )] - False -> return [] - False | not localStyle -> - return [] - False -> do - let packageName = unPackageName (pkgName $ elabPkgSourceId package) - packageDir = storePackageDirectory (cabalStoreDirLayout cabalLayout) - (compilerId (pkgConfigCompiler sharedConfig')) - (elabUnitId package) - docDir = packageDir "share" "doc" "html" - destDir = outputDir packageName - interfacePath = destDir - packageName <.> "haddock" - a <- doesDirectoryExist docDir - case a of - True -> copyDirectoryRecursive verbosity docDir destDir - -- non local packages will be hidden in haddock's - -- generated contents page - >> return [( packageName - , interfacePath - , Hidden - )] - False -> return [] + True -> + copyDirectoryRecursive verbosity docDir destDir + >> return + [ + ( packageName + , interfacePath + , Visible + ) + ] + False -> return [] + False + | not localStyle -> + return [] + False -> do + let packageName = unPackageName (pkgName $ elabPkgSourceId package) + packageDir = + storePackageDirectory + (cabalStoreDirLayout cabalLayout) + (compilerId (pkgConfigCompiler sharedConfig')) + (elabUnitId package) + docDir = packageDir "share" "doc" "html" + destDir = outputDir packageName + interfacePath = + destDir + packageName + <.> "haddock" + a <- doesDirectoryExist docDir + case a of + True -> + copyDirectoryRecursive verbosity docDir destDir + -- non local packages will be hidden in haddock's + -- generated contents page + >> return + [ + ( packageName + , interfacePath + , Hidden + ) + ] + False -> return [] - -- - -- generate index, content, etc. - -- + -- + -- generate index, content, etc. + -- - let flags' = flags - { haddockProjectDir = Flag outputDir - , haddockProjectGenIndex = if localOrHackage - then Flag True - else haddockProjectGenIndex flags - , haddockProjectGenContents = if localOrHackage - then Flag True - else haddockProjectGenContents flags - , haddockProjectQuickJump = if localOrHackage - then Flag True - else haddockProjectQuickJump flags + let flags' = + flags + { haddockProjectDir = Flag outputDir + , haddockProjectGenIndex = + if localOrHackage + then Flag True + else haddockProjectGenIndex flags + , haddockProjectGenContents = + if localOrHackage + then Flag True + else haddockProjectGenContents flags + , haddockProjectQuickJump = + if localOrHackage + then Flag True + else haddockProjectQuickJump flags , haddockProjectLinkedSource = haddockLinkedSource haddockFlags - , haddockProjectInterfaces = Flag - [ ( interfacePath - , Just packageName - , Just packageName - , visibility - ) - | (packageName, interfacePath, visibility) <- packageInfos - ] + , haddockProjectInterfaces = + Flag + [ ( interfacePath + , Just packageName + , Just packageName + , visibility + ) + | (packageName, interfacePath, visibility) <- packageInfos + ] } - createHaddockIndex verbosity - (pkgConfigCompilerProgs sharedConfig') - (pkgConfigCompiler sharedConfig') - (pkgConfigPlatform sharedConfig') - flags' + createHaddockIndex + verbosity + (pkgConfigCompilerProgs sharedConfig') + (pkgConfigCompiler sharedConfig') + (pkgConfigPlatform sharedConfig') + flags' where verbosity = fromFlagOrDefault normal (haddockProjectVerbosity flags) @@ -303,36 +372,41 @@ haddockProjectAction flags _extraArgs globalFlags = do -- transitive dependencies; or depend on `--haddocks-html-location` to -- provide location of the documentation of dependencies. localStyle = - let local = fromFlagOrDefault False (haddockProjectLocal flags) - hackage = fromFlagOrDefault False (haddockProjectHackage flags) + let local = fromFlagOrDefault False (haddockProjectLocal flags) + hackage = fromFlagOrDefault False (haddockProjectHackage flags) location = fromFlagOrDefault False (const True <$> haddockProjectHtmlLocation flags) - in local && not hackage && not location - -- or if none of the flags is given set `localStyle` to `True` - || not local && not hackage && not location - + in local && not hackage && not location + -- or if none of the flags is given set `localStyle` to `True` + || not local && not hackage && not location localOrHackage = - any id $ flagToList (haddockProjectLocal flags) - ++ flagToList (haddockProjectHackage flags) + any id $ + flagToList (haddockProjectLocal flags) + ++ flagToList (haddockProjectHackage flags) reportTargetProblems :: Show x => [x] -> IO a reportTargetProblems = - die' verbosity . unlines . map show + die' verbosity . unlines . map show -- TODO: this is just a sketch - selectPackageTargets :: TargetSelector - -> [AvailableTarget k] - -> Either (TargetProblem ()) [k] - selectPackageTargets _ ts = Right $ - mapMaybe - (\t -> case availableTargetStatus t of - TargetBuildable k _ | availableTargetLocalToProject t - -> Just k - _ -> Nothing) - ts + selectPackageTargets + :: TargetSelector + -> [AvailableTarget k] + -> Either (TargetProblem ()) [k] + selectPackageTargets _ ts = + Right $ + mapMaybe + ( \t -> case availableTargetStatus t of + TargetBuildable k _ + | availableTargetLocalToProject t -> + Just k + _ -> Nothing + ) + ts - matchingPackages :: ElaboratedInstallPlan - -> [Either InstalledPackageInfo ElaboratedConfiguredPackage] + matchingPackages + :: ElaboratedInstallPlan + -> [Either InstalledPackageInfo ElaboratedConfiguredPackage] matchingPackages = - fmap (foldPlanPackage Left Right) - . InstallPlan.toList + fmap (foldPlanPackage Left Right) + . InstallPlan.toList diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index 8cf8c57ccf8..46ce2cd6e5a 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -1,183 +1,289 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -- | cabal-install CLI command: build --- -module Distribution.Client.CmdInstall ( - -- * The @build@ CLI and action - installCommand, - installAction, +module Distribution.Client.CmdInstall + ( -- * The @build@ CLI and action + installCommand + , installAction -- * Internals exposed for testing - selectPackageTargets, - selectComponentTarget, + , selectPackageTargets + , selectComponentTarget + -- * Internals exposed for CmdRepl + CmdRun - establishDummyDistDirLayout, - establishDummyProjectBaseContext + , establishDummyDistDirLayout + , establishDummyProjectBaseContext ) where -import Prelude () import Distribution.Client.Compat.Prelude import Distribution.Compat.Directory - ( doesPathExist ) + ( doesPathExist + ) +import Prelude () -import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages import Distribution.Client.CmdSdist +import Distribution.Client.ProjectOrchestration import Distribution.Client.TargetProblem - ( TargetProblem', TargetProblem (..) ) + ( TargetProblem (..) + , TargetProblem' + ) import Distribution.Client.CmdInstall.ClientInstallFlags import Distribution.Client.CmdInstall.ClientInstallTargetSelector -import Distribution.Client.Setup - ( GlobalFlags(..), ConfigFlags(..), InstallFlags(..) ) -import Distribution.Client.Types - ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage - , SourcePackageDb(..) ) +import Distribution.Client.Config + ( SavedConfig (..) + , defaultInstallPath + , loadConfig + ) +import Distribution.Client.DistDirLayout + ( CabalDirLayout (..) + , DistDirLayout (..) + , StoreDirLayout (..) + , cabalStoreDirLayout + , mkCabalDirLayout + ) +import Distribution.Client.IndexUtils + ( getInstalledPackages + , getSourcePackages + ) import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Package - ( Package(..), PackageName, mkPackageName, unPackageName ) -import Distribution.Types.PackageId - ( PackageIdentifier(..) ) -import Distribution.Client.ProjectConfig - ( ProjectPackageLocation(..) - , fetchAndReadSourcePackages - , projectConfigWithBuilderRepoContext - , resolveBuildTimeSettings, withProjectOrGlobalConfig ) +import Distribution.Client.InstallSymlink + ( promptRun + , symlinkBinary + , trySymlink + ) import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.ProjectFlags (ProjectFlags (..)) + ( NixStyleFlags (..) + , defaultNixStyleFlags + , nixStyleOptions + ) +import Distribution.Client.ProjectConfig + ( ProjectPackageLocation (..) + , fetchAndReadSourcePackages + , projectConfigWithBuilderRepoContext + , resolveBuildTimeSettings + , withProjectOrGlobalConfig + ) import Distribution.Client.ProjectConfig.Types - ( ProjectConfig(..), ProjectConfigShared(..) - , ProjectConfigBuildOnly(..), PackageConfig(..) - , MapMappend(..) - , getMapLast, getMapMappend, projectConfigLogsDir - , projectConfigStoreDir, projectConfigBuildOnly - , projectConfigConfigFile ) -import Distribution.Simple.Program.Db - ( userSpecifyPaths, userSpecifyArgss, defaultProgramDb - , modifyProgramSearchPath ) -import Distribution.Simple.BuildPaths - ( exeExtension ) -import Distribution.Simple.Program.Find - ( ProgramSearchPathEntry(..) ) -import Distribution.Client.Config - ( defaultInstallPath, loadConfig, SavedConfig(..) ) -import qualified Distribution.Simple.PackageIndex as PI -import Distribution.Solver.Types.PackageIndex - ( lookupPackageName, searchByName ) -import Distribution.Types.InstalledPackageInfo - ( InstalledPackageInfo(..) ) -import Distribution.Types.Version - ( Version, nullVersion ) -import Distribution.Types.VersionRange - ( thisVersion ) -import Distribution.Solver.Types.PackageConstraint - ( PackageProperty(..) ) -import Distribution.Client.IndexUtils - ( getSourcePackages, getInstalledPackages ) + ( MapMappend (..) + , PackageConfig (..) + , ProjectConfig (..) + , ProjectConfigBuildOnly (..) + , ProjectConfigShared (..) + , getMapLast + , getMapMappend + , projectConfigBuildOnly + , projectConfigConfigFile + , projectConfigLogsDir + , projectConfigStoreDir + ) +import Distribution.Client.ProjectFlags (ProjectFlags (..)) import Distribution.Client.ProjectPlanning - ( storePackageInstallDirs' ) + ( storePackageInstallDirs' + ) import Distribution.Client.ProjectPlanning.Types - ( ElaboratedInstallPlan ) -import qualified Distribution.Simple.InstallDirs as InstallDirs -import Distribution.Client.DistDirLayout - ( DistDirLayout(..), mkCabalDirLayout - , cabalStoreDirLayout - , CabalDirLayout(..), StoreDirLayout(..) ) + ( ElaboratedInstallPlan + ) import Distribution.Client.RebuildMonad - ( runRebuild ) -import Distribution.Client.InstallSymlink - ( symlinkBinary, trySymlink, promptRun ) + ( runRebuild + ) +import Distribution.Client.Setup + ( ConfigFlags (..) + , GlobalFlags (..) + , InstallFlags (..) + ) +import Distribution.Client.Types + ( PackageLocation (..) + , PackageSpecifier (..) + , SourcePackageDb (..) + , UnresolvedSourcePackage + ) import Distribution.Client.Types.OverwritePolicy - ( OverwritePolicy (..) ) -import Distribution.Simple.Flag - ( fromFlagOrDefault, flagToMaybe, flagElim ) -import Distribution.Simple.Setup - ( Flag(..), installDirsOptions ) -import Distribution.Solver.Types.SourcePackage - ( SourcePackage(..) ) + ( OverwritePolicy (..) + ) +import Distribution.Package + ( Package (..) + , PackageName + , mkPackageName + , unPackageName + ) +import Distribution.Simple.BuildPaths + ( exeExtension + ) import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives, optionName ) -import Distribution.Simple.Configure - ( configCompilerEx ) + ( CommandUI (..) + , optionName + , usageAlternatives + ) import Distribution.Simple.Compiler - ( Compiler(..), CompilerId(..), CompilerFlavor(..) - , PackageDBStack, PackageDB(..) ) + ( Compiler (..) + , CompilerFlavor (..) + , CompilerId (..) + , PackageDB (..) + , PackageDBStack + ) +import Distribution.Simple.Configure + ( configCompilerEx + ) +import Distribution.Simple.Flag + ( flagElim + , flagToMaybe + , fromFlagOrDefault + ) import Distribution.Simple.GHC - ( ghcPlatformAndVersionString, getGhcAppDir - , GhcImplInfo(..), getImplInfo - , GhcEnvironmentFileEntry(..) - , renderGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc ) + ( GhcEnvironmentFileEntry (..) + , GhcImplInfo (..) + , ParseErrorExc + , getGhcAppDir + , getImplInfo + , ghcPlatformAndVersionString + , readGhcEnvironmentFile + , renderGhcEnvironmentFile + ) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import qualified Distribution.Simple.PackageIndex as PI +import Distribution.Simple.Program.Db + ( defaultProgramDb + , modifyProgramSearchPath + , userSpecifyArgss + , userSpecifyPaths + ) +import Distribution.Simple.Program.Find + ( ProgramSearchPathEntry (..) + ) +import Distribution.Simple.Setup + ( Flag (..) + , installDirsOptions + ) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose + , die' + , notice + , ordNub + , safeHead + , warn + , withTempDirectory + , wrapText + ) +import Distribution.Solver.Types.PackageConstraint + ( PackageProperty (..) + ) +import Distribution.Solver.Types.PackageIndex + ( lookupPackageName + , searchByName + ) +import Distribution.Solver.Types.SourcePackage + ( SourcePackage (..) + ) import Distribution.System - ( Platform , buildOS, OS (Windows) ) + ( OS (Windows) + , Platform + , buildOS + ) +import Distribution.Types.InstalledPackageInfo + ( InstalledPackageInfo (..) + ) +import Distribution.Types.PackageId + ( PackageIdentifier (..) + ) import Distribution.Types.UnitId - ( UnitId ) + ( UnitId + ) import Distribution.Types.UnqualComponentName - ( UnqualComponentName, unUnqualComponentName ) -import Distribution.Verbosity - ( normal, lessVerbose ) -import Distribution.Simple.Utils - ( wrapText, die', notice, warn - , withTempDirectory, createDirectoryIfMissingVerbose - , ordNub, safeHead ) + ( UnqualComponentName + , unUnqualComponentName + ) +import Distribution.Types.Version + ( Version + , nullVersion + ) +import Distribution.Types.VersionRange + ( thisVersion + ) import Distribution.Utils.Generic - ( writeFileAtomic ) + ( writeFileAtomic + ) +import Distribution.Verbosity + ( lessVerbose + , normal + ) import qualified Data.ByteString.Lazy.Char8 as BS -import Data.Ord - ( Down(..) ) +import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map +import Data.Ord + ( Down (..) + ) import qualified Data.Set as S -import qualified Data.List.NonEmpty as NE import Distribution.Utils.NubList - ( fromNubList ) + ( fromNubList + ) import Network.URI (URI) import System.Directory - ( doesFileExist, createDirectoryIfMissing - , getTemporaryDirectory, makeAbsolute, doesDirectoryExist - , removeFile, removeDirectory, copyFile ) + ( copyFile + , createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , getTemporaryDirectory + , makeAbsolute + , removeDirectory + , removeFile + ) import System.FilePath - ( (), (<.>), takeDirectory, takeBaseName ) + ( takeBaseName + , takeDirectory + , (<.>) + , () + ) installCommand :: CommandUI (NixStyleFlags ClientInstallFlags) -installCommand = CommandUI - { commandName = "v2-install" - , commandSynopsis = "Install packages." - , commandUsage = usageAlternatives - "v2-install" [ "[TARGETS] [FLAGS]" ] - , commandDescription = Just $ \_ -> wrapText $ - "Installs one or more packages. This is done by installing them " - ++ "in the store and symlinking/copying the executables in the directory " - ++ "specified by the --installdir flag (`~/.local/bin/` by default). " - ++ "If you want the installed executables to be available globally, " - ++ "make sure that the PATH environment variable contains that directory. " - ++ "\n\n" - ++ "If TARGET is a library and --lib (provisional) is used, " - ++ "it will be added to the global environment. " - ++ "When doing this, cabal will try to build a plan that includes all " - ++ "the previously installed libraries. This is currently not implemented." - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v2-install\n" - ++ " Install the package in the current directory\n" - ++ " " ++ pname ++ " v2-install pkgname\n" - ++ " Install the package named pkgname" - ++ " (fetching it from hackage if necessary)\n" - ++ " " ++ pname ++ " v2-install ./pkgfoo\n" - ++ " Install the package in the ./pkgfoo directory\n" - - , commandOptions = \x -> filter notInstallDirOpt $ nixStyleOptions clientInstallOptions x - , commandDefaultFlags = defaultNixStyleFlags defaultClientInstallFlags - } - where - -- install doesn't take installDirs flags, since it always installs into the store in a fixed way. - notInstallDirOpt x = not $ optionName x `elem` installDirOptNames - installDirOptNames = map optionName installDirsOptions - +installCommand = + CommandUI + { commandName = "v2-install" + , commandSynopsis = "Install packages." + , commandUsage = + usageAlternatives + "v2-install" + ["[TARGETS] [FLAGS]"] + , commandDescription = Just $ \_ -> + wrapText $ + "Installs one or more packages. This is done by installing them " + ++ "in the store and symlinking/copying the executables in the directory " + ++ "specified by the --installdir flag (`~/.local/bin/` by default). " + ++ "If you want the installed executables to be available globally, " + ++ "make sure that the PATH environment variable contains that directory. " + ++ "\n\n" + ++ "If TARGET is a library and --lib (provisional) is used, " + ++ "it will be added to the global environment. " + ++ "When doing this, cabal will try to build a plan that includes all " + ++ "the previously installed libraries. This is currently not implemented." + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " + ++ pname + ++ " v2-install\n" + ++ " Install the package in the current directory\n" + ++ " " + ++ pname + ++ " v2-install pkgname\n" + ++ " Install the package named pkgname" + ++ " (fetching it from hackage if necessary)\n" + ++ " " + ++ pname + ++ " v2-install ./pkgfoo\n" + ++ " Install the package in the ./pkgfoo directory\n" + , commandOptions = \x -> filter notInstallDirOpt $ nixStyleOptions clientInstallOptions x + , commandDefaultFlags = defaultNixStyleFlags defaultClientInstallFlags + } + where + -- install doesn't take installDirs flags, since it always installs into the store in a fixed way. + notInstallDirOpt x = not $ optionName x `elem` installDirOptNames + installDirOptNames = map optionName installDirsOptions -- | The @install@ command actually serves four different needs. It installs: -- * exes: @@ -195,9 +301,8 @@ installCommand = CommandUI -- -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" --- installAction :: NixStyleFlags ClientInstallFlags -> [String] -> GlobalFlags -> IO () -installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targetStrings globalFlags = do +installAction flags@NixStyleFlags{extraFlags = clientInstallFlags', ..} targetStrings globalFlags = do -- Ensure there were no invalid configuration options specified. verifyPreconditionsOrDie verbosity configFlags' @@ -207,8 +312,8 @@ installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targe clientInstallFlags <- getClientInstallFlags verbosity globalFlags clientInstallFlags' let - installLibs = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags) - targetFilter = if installLibs then Just LibKind else Just ExeKind + installLibs = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags) + targetFilter = if installLibs then Just LibKind else Just ExeKind targetStrings' = if null targetStrings then ["."] else targetStrings -- Note the logic here is rather goofy. Target selectors of the form "foo:bar" also parse as uris. @@ -228,24 +333,30 @@ installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targe localBaseCtx <- establishProjectBaseContext reducedVerbosity cliConfig InstallCommand let localDistDirLayout = distDirLayout localBaseCtx - pkgDb <- projectConfigWithBuilderRepoContext reducedVerbosity - (buildSettings localBaseCtx) (getSourcePackages verbosity) + pkgDb <- + projectConfigWithBuilderRepoContext + reducedVerbosity + (buildSettings localBaseCtx) + (getSourcePackages verbosity) let (targetStrings'', packageIds) = - partitionEithers . - flip fmap targetStrings' $ - \str -> case simpleParsec str of - Just (pkgId :: PackageId) - | pkgVersion pkgId /= nullVersion -> Right pkgId - _ -> Left str + partitionEithers + . flip fmap targetStrings' + $ \str -> case simpleParsec str of + Just (pkgId :: PackageId) + | pkgVersion pkgId /= nullVersion -> Right pkgId + _ -> Left str packageSpecifiers = flip fmap packageIds $ \case - PackageIdentifier{..} - | pkgVersion == nullVersion -> NamedPackage pkgName [] - | otherwise -> NamedPackage pkgName - [PackagePropertyVersion - (thisVersion pkgVersion)] + PackageIdentifier{..} + | pkgVersion == nullVersion -> NamedPackage pkgName [] + | otherwise -> + NamedPackage + pkgName + [ PackagePropertyVersion + (thisVersion pkgVersion) + ] packageTargets = flip TargetPackageNamed targetFilter . pkgName <$> packageIds @@ -254,17 +365,27 @@ installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targe else do targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages localBaseCtx) - Nothing targetStrings'' + =<< readTargetSelectors + (localPackages localBaseCtx) + Nothing + targetStrings'' (specs, selectors) <- getSpecsAndTargetSelectors - verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter - - return ( specs ++ packageSpecifiers - , [] - , selectors ++ packageTargets - , projectConfig localBaseCtx ) + verbosity + reducedVerbosity + pkgDb + targetSelectors + localDistDirLayout + localBaseCtx + targetFilter + + return + ( specs ++ packageSpecifiers + , [] + , selectors ++ packageTargets + , projectConfig localBaseCtx + ) withoutProject :: ProjectConfig -> IO ([PackageSpecifier UnresolvedSourcePackage], [URI], [TargetSelector], ProjectConfig) withoutProject _ | null targetStrings = withProject -- if there's no targets, we don't parse specially, but treat it as install in a standard cabal package dir @@ -273,86 +394,106 @@ installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targe let projectConfig = globalConfig <> cliConfig - ProjectConfigBuildOnly { - projectConfigLogsDir - } = projectConfigBuildOnly projectConfig + ProjectConfigBuildOnly + { projectConfigLogsDir + } = projectConfigBuildOnly projectConfig - ProjectConfigShared { - projectConfigStoreDir - } = projectConfigShared projectConfig + ProjectConfigShared + { projectConfigStoreDir + } = projectConfigShared projectConfig mlogsDir = flagToMaybe projectConfigLogsDir mstoreDir = flagToMaybe projectConfigStoreDir cabalDirLayout <- mkCabalDirLayout mstoreDir mlogsDir let - buildSettings = resolveBuildTimeSettings - verbosity cabalDirLayout - projectConfig - - SourcePackageDb { packageIndex } <- projectConfigWithBuilderRepoContext - verbosity buildSettings - (getSourcePackages verbosity) + buildSettings = + resolveBuildTimeSettings + verbosity + cabalDirLayout + projectConfig + + SourcePackageDb{packageIndex} <- + projectConfigWithBuilderRepoContext + verbosity + buildSettings + (getSourcePackages verbosity) for_ (concatMap woPackageNames tss) $ \name -> do when (null (lookupPackageName packageIndex name)) $ do let xs = searchByName packageIndex (unPackageName name) - let emptyIf True _ = [] + let emptyIf True _ = [] emptyIf False zs = zs - die' verbosity $ concat $ - [ "Unknown package \"", unPackageName name, "\". " - ] ++ emptyIf (null xs) - [ "Did you mean any of the following?\n" - , unlines (("- " ++) . unPackageName . fst <$> xs) - ] + die' verbosity $ + concat $ + [ "Unknown package \"" + , unPackageName name + , "\". " + ] + ++ emptyIf + (null xs) + [ "Did you mean any of the following?\n" + , unlines (("- " ++) . unPackageName . fst <$> xs) + ] let (uris, packageSpecifiers) = partitionEithers $ map woPackageSpecifiers tss - packageTargets = map woPackageTargets tss + packageTargets = map woPackageTargets tss return (packageSpecifiers, uris, packageTargets, projectConfig) (specs, uris, targetSelectors, config) <- - withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject + withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject let - ProjectConfig { - projectConfigBuildOnly = ProjectConfigBuildOnly { - projectConfigLogsDir - }, - projectConfigShared = ProjectConfigShared { - projectConfigHcFlavor, - projectConfigHcPath, - projectConfigHcPkg, - projectConfigStoreDir - }, - projectConfigLocalPackages = PackageConfig { - packageConfigProgramPaths, - packageConfigProgramArgs, - packageConfigProgramPathExtra - } - } = config + ProjectConfig + { projectConfigBuildOnly = + ProjectConfigBuildOnly + { projectConfigLogsDir + } + , projectConfigShared = + ProjectConfigShared + { projectConfigHcFlavor + , projectConfigHcPath + , projectConfigHcPkg + , projectConfigStoreDir + } + , projectConfigLocalPackages = + PackageConfig + { packageConfigProgramPaths + , packageConfigProgramArgs + , packageConfigProgramPathExtra + } + } = config hcFlavor = flagToMaybe projectConfigHcFlavor - hcPath = flagToMaybe projectConfigHcPath - hcPkg = flagToMaybe projectConfigHcPkg + hcPath = flagToMaybe projectConfigHcPath + hcPkg = flagToMaybe projectConfigHcPkg -- ProgramDb with directly user specified paths preProgDb = - userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) - . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs)) - . modifyProgramSearchPath - (++ [ ProgramSearchPathDir dir - | dir <- fromNubList packageConfigProgramPathExtra ]) - $ defaultProgramDb + userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) + . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs)) + . modifyProgramSearchPath + ( ++ + [ ProgramSearchPathDir dir + | dir <- fromNubList packageConfigProgramPathExtra + ] + ) + $ defaultProgramDb -- progDb is a program database with compiler tools configured properly - (compiler@Compiler { compilerId = - compilerId@(CompilerId compilerFlavor compilerVersion) }, platform, progDb) <- - configCompilerEx hcFlavor hcPath hcPkg preProgDb verbosity + ( compiler@Compiler + { compilerId = + compilerId@(CompilerId compilerFlavor compilerVersion) + } + , platform + , progDb + ) <- + configCompilerEx hcFlavor hcPath hcPkg preProgDb verbosity let - GhcImplInfo{ supportsPkgEnvFiles } = getImplInfo compiler + GhcImplInfo{supportsPkgEnvFiles} = getImplInfo compiler envFile <- getEnvFile clientInstallFlags platform compilerVersion existingEnvEntries <- @@ -372,12 +513,14 @@ installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targe withTempDirectory verbosity globalTmp "cabal-install." $ \tmpDir -> do distDirLayout <- establishDummyDistDirLayout verbosity config tmpDir - uriSpecs <- runRebuild tmpDir $ fetchAndReadSourcePackages - verbosity - distDirLayout - (projectConfigShared config) - (projectConfigBuildOnly config) - [ ProjectPackageRemoteTarball uri | uri <- uris ] + uriSpecs <- + runRebuild tmpDir $ + fetchAndReadSourcePackages + verbosity + distDirLayout + (projectConfigShared config) + (projectConfigBuildOnly config) + [ProjectPackageRemoteTarball uri | uri <- uris] -- check for targets already in env let getPackageName :: PackageSpecifier UnresolvedSourcePackage -> PackageName @@ -389,27 +532,31 @@ installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targe nameIntersection = S.intersection targetNames envNames -- we check for intersections in targets with the existing env - (envSpecs', nonGlobalEnvEntries') <- if null nameIntersection - then pure (envSpecs, map snd nonGlobalEnvEntries) - else if forceInstall - then let es = filter (\e -> not $ getPackageName e `S.member` nameIntersection) envSpecs - nge = map snd . filter (\e -> not $ fst e `S.member` nameIntersection) $ nonGlobalEnvEntries - in pure (es, nge) - else die' verbosity $ "Packages requested to install already exist in environment file at " ++ envFile ++ ". Overwriting them may break other packages. Use --force-reinstalls to proceed anyway. Packages: " ++ intercalate ", " (map prettyShow $ S.toList nameIntersection) + (envSpecs', nonGlobalEnvEntries') <- + if null nameIntersection + then pure (envSpecs, map snd nonGlobalEnvEntries) + else + if forceInstall + then + let es = filter (\e -> not $ getPackageName e `S.member` nameIntersection) envSpecs + nge = map snd . filter (\e -> not $ fst e `S.member` nameIntersection) $ nonGlobalEnvEntries + in pure (es, nge) + else die' verbosity $ "Packages requested to install already exist in environment file at " ++ envFile ++ ". Overwriting them may break other packages. Use --force-reinstalls to proceed anyway. Packages: " ++ intercalate ", " (map prettyShow $ S.toList nameIntersection) -- we construct an installed index of files in the cleaned target environment (absent overwrites) so that we can solve with regards to packages installed locally but not in the upstream repo let installedPacks = PI.allPackagesByName installedIndex newEnvNames = S.fromList $ map getPackageName envSpecs' installedIndex' = PI.fromList . concatMap snd . filter (\p -> fst p `S.member` newEnvNames) $ installedPacks - baseCtx <- establishDummyProjectBaseContext - verbosity - config - distDirLayout - (envSpecs' ++ specs ++ uriSpecs) - InstallCommand + baseCtx <- + establishDummyProjectBaseContext + verbosity + config + distDirLayout + (envSpecs' ++ specs ++ uriSpecs) + InstallCommand - buildCtx <- constructProjectBuildContext verbosity (baseCtx {installedPackages = Just installedIndex'}) targetSelectors + buildCtx <- constructProjectBuildContext verbosity (baseCtx{installedPackages = Just installedIndex'}) targetSelectors printPlan verbosity baseCtx buildCtx @@ -419,33 +566,50 @@ installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targe -- Now that we built everything we can do the installation part. -- First, figure out if / what parts we want to install: let - dryRun = buildSettingDryRun (buildSettings baseCtx) - || buildSettingOnlyDownload (buildSettings baseCtx) + dryRun = + buildSettingDryRun (buildSettings baseCtx) + || buildSettingOnlyDownload (buildSettings baseCtx) -- Then, install! unless dryRun $ if installLibs - then installLibraries verbosity - buildCtx installedIndex compiler packageDbs envFile nonGlobalEnvEntries' - else installExes verbosity - baseCtx buildCtx platform compiler configFlags clientInstallFlags + then + installLibraries + verbosity + buildCtx + installedIndex + compiler + packageDbs + envFile + nonGlobalEnvEntries' + else + installExes + verbosity + baseCtx + buildCtx + platform + compiler + configFlags + clientInstallFlags where configFlags' = disableTestsBenchsByDefault configFlags verbosity = fromFlagOrDefault normal (configVerbosity configFlags') ignoreProject = flagIgnoreProject projectFlags - baseCliConfig = commandLineFlagsToProjectConfig - globalFlags - flags { configFlags = configFlags' } - clientInstallFlags' + baseCliConfig = + commandLineFlagsToProjectConfig + globalFlags + flags{configFlags = configFlags'} + clientInstallFlags' cliConfig = addLocalConfigToTargets baseCliConfig targetStrings globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) -- | Treat all direct targets of install command as local packages: #8637 addLocalConfigToTargets :: ProjectConfig -> [String] -> ProjectConfig -addLocalConfigToTargets config targetStrings - = config { - projectConfigSpecificPackage = projectConfigSpecificPackage config - <> MapMappend (Map.fromList targetPackageConfigs) +addLocalConfigToTargets config targetStrings = + config + { projectConfigSpecificPackage = + projectConfigSpecificPackage config + <> MapMappend (Map.fromList targetPackageConfigs) } where localConfig = projectConfigLocalPackages config @@ -460,11 +624,13 @@ verifyPreconditionsOrDie verbosity configFlags = do -- So we set them as disabled by default and error if they are explicitly -- enabled. when (configTests configFlags == Flag True) $ - die' verbosity $ "--enable-tests was specified, but tests can't " - ++ "be enabled in a remote package" + die' verbosity $ + "--enable-tests was specified, but tests can't " + ++ "be enabled in a remote package" when (configBenchmarks configFlags == Flag True) $ - die' verbosity $ "--enable-benchmarks was specified, but benchmarks can't " - ++ "be enabled in a remote package" + die' verbosity $ + "--enable-benchmarks was specified, but benchmarks can't " + ++ "be enabled in a remote package" getClientInstallFlags :: Verbosity -> GlobalFlags -> ClientInstallFlags -> IO ClientInstallFlags getClientInstallFlags verbosity globalFlags existingClientInstallFlags = do @@ -472,7 +638,6 @@ getClientInstallFlags verbosity globalFlags existingClientInstallFlags = do savedConfig <- loadConfig verbosity configFileFlag pure $ savedClientInstallFlags savedConfig `mappend` existingClientInstallFlags - getSpecsAndTargetSelectors :: Verbosity -> Verbosity @@ -484,50 +649,57 @@ getSpecsAndTargetSelectors -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector]) getSpecsAndTargetSelectors verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter = withInstallPlan reducedVerbosity localBaseCtx $ \elaboratedPlan _ -> do - -- Split into known targets and hackage packages. - (targets, hackageNames) <- - partitionToKnownTargetsAndHackagePackages - verbosity pkgDb elaboratedPlan targetSelectors - - let - planMap = InstallPlan.toMap elaboratedPlan - targetIds = Map.keys targets - - sdistize (SpecificSourcePackage spkg) = - SpecificSourcePackage spkg' - where - sdistPath = distSdistFile localDistDirLayout (packageId spkg) - spkg' = spkg { srcpkgSource = LocalTarballPackage sdistPath } - sdistize named = named - - local = sdistize <$> localPackages localBaseCtx - - gatherTargets :: UnitId -> TargetSelector - gatherTargets targetId = TargetPackageNamed pkgName targetFilter - where - targetUnit = Map.findWithDefault (error "cannot find target unit") targetId planMap - PackageIdentifier{..} = packageId targetUnit - - targets' = fmap gatherTargets targetIds - - hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage] - hackagePkgs = flip NamedPackage [] <$> hackageNames - - hackageTargets :: [TargetSelector] - hackageTargets = - flip TargetPackageNamed targetFilter <$> hackageNames - - createDirectoryIfMissing True (distSdistDirectory localDistDirLayout) + -- Split into known targets and hackage packages. + (targets, hackageNames) <- + partitionToKnownTargetsAndHackagePackages + verbosity + pkgDb + elaboratedPlan + targetSelectors - unless (Map.null targets) $ for_ (localPackages localBaseCtx) $ \lpkg -> case lpkg of - SpecificSourcePackage pkg -> packageToSdist verbosity - (distProjectRootDirectory localDistDirLayout) TarGzArchive - (distSdistFile localDistDirLayout (packageId pkg)) pkg + let + planMap = InstallPlan.toMap elaboratedPlan + targetIds = Map.keys targets + + sdistize (SpecificSourcePackage spkg) = + SpecificSourcePackage spkg' + where + sdistPath = distSdistFile localDistDirLayout (packageId spkg) + spkg' = spkg{srcpkgSource = LocalTarballPackage sdistPath} + sdistize named = named + + local = sdistize <$> localPackages localBaseCtx + + gatherTargets :: UnitId -> TargetSelector + gatherTargets targetId = TargetPackageNamed pkgName targetFilter + where + targetUnit = Map.findWithDefault (error "cannot find target unit") targetId planMap + PackageIdentifier{..} = packageId targetUnit + + targets' = fmap gatherTargets targetIds + + hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage] + hackagePkgs = flip NamedPackage [] <$> hackageNames + + hackageTargets :: [TargetSelector] + hackageTargets = + flip TargetPackageNamed targetFilter <$> hackageNames + + createDirectoryIfMissing True (distSdistDirectory localDistDirLayout) + + unless (Map.null targets) $ for_ (localPackages localBaseCtx) $ \lpkg -> case lpkg of + SpecificSourcePackage pkg -> + packageToSdist + verbosity + (distProjectRootDirectory localDistDirLayout) + TarGzArchive + (distSdistFile localDistDirLayout (packageId pkg)) + pkg NamedPackage pkgName _ -> error $ "Got NamedPackage " ++ prettyShow pkgName - if null targets - then return (hackagePkgs, hackageTargets) - else return (local ++ hackagePkgs, targets' ++ hackageTargets) + if null targets + then return (hackagePkgs, hackageTargets) + else return (local ++ hackagePkgs, targets' ++ hackageTargets) -- | Partitions the target selectors into known local targets and hackage packages. partitionToKnownTargetsAndHackagePackages @@ -537,33 +709,37 @@ partitionToKnownTargetsAndHackagePackages -> [TargetSelector] -> IO (TargetsMap, [PackageName]) partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetSelectors = do - let mTargets = resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - (Just pkgDb) - targetSelectors + let mTargets = + resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + (Just pkgDb) + targetSelectors case mTargets of Right targets -> -- Everything is a local dependency. return (targets, []) - Left errs -> do + Left errs -> do -- Not everything is local. let (errs', hackageNames) = partitionEithers . flip fmap errs $ \case TargetAvailableInIndex name -> Right name - err -> Left err + err -> Left err -- report incorrect case for known package. for_ errs' $ \case TargetNotInProject hn -> case searchByName (packageIndex pkgDb) (unPackageName hn) of [] -> return () - xs -> die' verbosity . concat $ - [ "Unknown package \"", unPackageName hn, "\". " - , "Did you mean any of the following?\n" - , unlines (("- " ++) . unPackageName . fst <$> xs) - ] + xs -> + die' verbosity . concat $ + [ "Unknown package \"" + , unPackageName hn + , "\". " + , "Did you mean any of the following?\n" + , unlines (("- " ++) . unPackageName . fst <$> xs) + ] _ -> return () when (not . null $ errs') $ reportBuildTargetProblems verbosity errs' @@ -574,52 +750,52 @@ partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetS | name `elem` hackageNames -> False TargetPackageNamed name _ | name `elem` hackageNames -> False - _ -> True + _ -> True -- This can't fail, because all of the errors are -- removed (or we've given up). targets <- either (reportBuildTargetProblems verbosity) return $ - resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors' + resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors' return (targets, hackageNames) - - constructProjectBuildContext :: Verbosity -> ProjectBaseContext - -- ^ The synthetic base context to use to produce the full build context. + -- ^ The synthetic base context to use to produce the full build context. -> [TargetSelector] -> IO ProjectBuildContext constructProjectBuildContext verbosity baseCtx targetSelectors = do runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do -- Interpret the targets on the command line as build targets - targets <- either (reportBuildTargetProblems verbosity) return $ - resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors + targets <- + either (reportBuildTargetProblems verbosity) return $ + resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors let prunedToTargetsElaboratedPlan = pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan prunedElaboratedPlan <- if buildSettingOnlyDeps (buildSettings baseCtx) - then either (reportCannotPruneDependencies verbosity) return $ - pruneInstallPlanToDependencies (Map.keysSet targets) - prunedToTargetsElaboratedPlan - else return prunedToTargetsElaboratedPlan + then + either (reportCannotPruneDependencies verbosity) return $ + pruneInstallPlanToDependencies + (Map.keysSet targets) + prunedToTargetsElaboratedPlan + else return prunedToTargetsElaboratedPlan return (prunedElaboratedPlan, targets) - -- | Install any built exe by symlinking/copying it -- we don't use BuildOutcomes because we also need the component names installExes @@ -631,59 +807,74 @@ installExes -> ConfigFlags -> ClientInstallFlags -> IO () -installExes verbosity baseCtx buildCtx platform compiler - configFlags clientInstallFlags = do - installPath <- defaultInstallPath - let storeDirLayout = cabalStoreDirLayout $ cabalDirLayout baseCtx - - prefix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgPrefix configFlags)) - suffix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgSuffix configFlags)) - - mkUnitBinDir :: UnitId -> FilePath - mkUnitBinDir = - InstallDirs.bindir . - storePackageInstallDirs' storeDirLayout (compilerId compiler) - - mkExeName :: UnqualComponentName -> FilePath - mkExeName exe = unUnqualComponentName exe <.> exeExtension platform - - mkFinalExeName :: UnqualComponentName -> FilePath - mkFinalExeName exe = prefix <> unUnqualComponentName exe <> suffix <.> exeExtension platform - installdirUnknown = - "installdir is not defined. Set it in your cabal config file " - ++ "or use --installdir=. Using default installdir: " ++ show installPath - - installdir <- fromFlagOrDefault - (warn verbosity installdirUnknown >> pure installPath) $ - pure <$> cinstInstalldir clientInstallFlags - createDirectoryIfMissingVerbose verbosity True installdir - warnIfNoExes verbosity buildCtx - - installMethod <- flagElim defaultMethod return $ - cinstInstallMethod clientInstallFlags +installExes + verbosity + baseCtx + buildCtx + platform + compiler + configFlags + clientInstallFlags = do + installPath <- defaultInstallPath + let storeDirLayout = cabalStoreDirLayout $ cabalDirLayout baseCtx + + prefix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgPrefix configFlags)) + suffix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgSuffix configFlags)) + + mkUnitBinDir :: UnitId -> FilePath + mkUnitBinDir = + InstallDirs.bindir + . storePackageInstallDirs' storeDirLayout (compilerId compiler) + + mkExeName :: UnqualComponentName -> FilePath + mkExeName exe = unUnqualComponentName exe <.> exeExtension platform + + mkFinalExeName :: UnqualComponentName -> FilePath + mkFinalExeName exe = prefix <> unUnqualComponentName exe <> suffix <.> exeExtension platform + installdirUnknown = + "installdir is not defined. Set it in your cabal config file " + ++ "or use --installdir=. Using default installdir: " + ++ show installPath + + installdir <- + fromFlagOrDefault + (warn verbosity installdirUnknown >> pure installPath) + $ pure <$> cinstInstalldir clientInstallFlags + createDirectoryIfMissingVerbose verbosity True installdir + warnIfNoExes verbosity buildCtx + + installMethod <- + flagElim defaultMethod return $ + cinstInstallMethod clientInstallFlags - let - doInstall = installUnitExes - verbosity - overwritePolicy - mkUnitBinDir mkExeName mkFinalExeName - installdir installMethod - in traverse_ doInstall $ Map.toList $ targetsMap buildCtx - where - overwritePolicy = fromFlagOrDefault NeverOverwrite $ - cinstOverwritePolicy clientInstallFlags - isWindows = buildOS == Windows - - -- This is in IO as we will make environment checks, - -- to decide which method is best - defaultMethod :: IO InstallMethod - defaultMethod - -- Try symlinking in temporary directory, if it works default to - -- symlinking even on windows - | isWindows = do - symlinks <- trySymlink verbosity - return $ if symlinks then InstallMethodSymlink else InstallMethodCopy - | otherwise = return InstallMethodSymlink + let + doInstall = + installUnitExes + verbosity + overwritePolicy + mkUnitBinDir + mkExeName + mkFinalExeName + installdir + installMethod + in + traverse_ doInstall $ Map.toList $ targetsMap buildCtx + where + overwritePolicy = + fromFlagOrDefault NeverOverwrite $ + cinstOverwritePolicy clientInstallFlags + isWindows = buildOS == Windows + + -- This is in IO as we will make environment checks, + -- to decide which method is best + defaultMethod :: IO InstallMethod + defaultMethod + -- Try symlinking in temporary directory, if it works default to + -- symlinking even on windows + | isWindows = do + symlinks <- trySymlink verbosity + return $ if symlinks then InstallMethodSymlink else InstallMethodCopy + | otherwise = return InstallMethodSymlink -- | Install any built library by adding it to the default ghc environment installLibraries @@ -692,70 +883,82 @@ installLibraries -> PI.PackageIndex InstalledPackageInfo -> Compiler -> PackageDBStack - -> FilePath -- ^ Environment file + -> FilePath + -- ^ Environment file -> [GhcEnvironmentFileEntry] -> IO () -installLibraries verbosity buildCtx installedIndex compiler - packageDbs' envFile envEntries = do - if supportsPkgEnvFiles $ getImplInfo compiler - then do - let validDb (SpecificPackageDB fp) = doesPathExist fp - validDb _ = pure True - -- if a user "installs" a global package and no existing cabal db exists, none will be created. - -- this ensures we don't add the "phantom" path to the file. - packageDbs <- filterM validDb packageDbs' - let - getLatest = (=<<) (maybeToList . safeHead . snd) . take 1 . sortBy (comparing (Down . fst)) - . PI.lookupPackageName installedIndex - globalLatest = concat (getLatest <$> globalPackages) - globalEntries = GhcEnvFilePackageId . installedUnitId <$> globalLatest - baseEntries = - GhcEnvFileClearPackageDbStack : fmap GhcEnvFilePackageDb packageDbs - pkgEntries = ordNub $ - globalEntries - ++ envEntries - ++ entriesForLibraryComponents (targetsMap buildCtx) - contents' = renderGhcEnvironmentFile (baseEntries ++ pkgEntries) - createDirectoryIfMissing True (takeDirectory envFile) - writeFileAtomic envFile (BS.pack contents') - else - warn verbosity $ +installLibraries + verbosity + buildCtx + installedIndex + compiler + packageDbs' + envFile + envEntries = do + if supportsPkgEnvFiles $ getImplInfo compiler + then do + let validDb (SpecificPackageDB fp) = doesPathExist fp + validDb _ = pure True + -- if a user "installs" a global package and no existing cabal db exists, none will be created. + -- this ensures we don't add the "phantom" path to the file. + packageDbs <- filterM validDb packageDbs' + let + getLatest = + (=<<) (maybeToList . safeHead . snd) + . take 1 + . sortBy (comparing (Down . fst)) + . PI.lookupPackageName installedIndex + globalLatest = concat (getLatest <$> globalPackages) + globalEntries = GhcEnvFilePackageId . installedUnitId <$> globalLatest + baseEntries = + GhcEnvFileClearPackageDbStack : fmap GhcEnvFilePackageDb packageDbs + pkgEntries = + ordNub $ + globalEntries + ++ envEntries + ++ entriesForLibraryComponents (targetsMap buildCtx) + contents' = renderGhcEnvironmentFile (baseEntries ++ pkgEntries) + createDirectoryIfMissing True (takeDirectory envFile) + writeFileAtomic envFile (BS.pack contents') + else + warn verbosity $ "The current compiler doesn't support safely installing libraries, " - ++ "so only executables will be available. (Library installation is " - ++ "supported on GHC 8.0+ only)" + ++ "so only executables will be available. (Library installation is " + ++ "supported on GHC 8.0+ only)" -- See ticket #8894. This is safe to include any nonreinstallable boot pkg, -- but the particular package users will always expect to be in scope without specific installation -- is base, so that they can access prelude, regardles of if they specifically asked for it. globalPackages :: [PackageName] -globalPackages = mkPackageName <$> [ "base" ] +globalPackages = mkPackageName <$> ["base"] warnIfNoExes :: Verbosity -> ProjectBuildContext -> IO () warnIfNoExes verbosity buildCtx = when noExes $ warn verbosity $ - "\n" <> - "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" <> - "@ WARNING: Installation might not be completed as desired! @\n" <> - "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" <> - "The command \"cabal install [TARGETS]\" doesn't expose libraries.\n" <> - "* You might have wanted to add them as dependencies to your package." <> - " In this case add \"" <> - intercalate ", " (showTargetSelector <$> selectors) <> - "\" to the build-depends field(s) of your package's .cabal file.\n" <> - "* You might have wanted to add them to a GHC environment. In this case" <> - " use \"cabal install --lib " <> - unwords (showTargetSelector <$> selectors) <> "\". " <> - " The \"--lib\" flag is provisional: see" <> - " https://github.com/haskell/cabal/issues/6481 for more information." + "\n" + <> "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" + <> "@ WARNING: Installation might not be completed as desired! @\n" + <> "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" + <> "The command \"cabal install [TARGETS]\" doesn't expose libraries.\n" + <> "* You might have wanted to add them as dependencies to your package." + <> " In this case add \"" + <> intercalate ", " (showTargetSelector <$> selectors) + <> "\" to the build-depends field(s) of your package's .cabal file.\n" + <> "* You might have wanted to add them to a GHC environment. In this case" + <> " use \"cabal install --lib " + <> unwords (showTargetSelector <$> selectors) + <> "\". " + <> " The \"--lib\" flag is provisional: see" + <> " https://github.com/haskell/cabal/issues/6481 for more information." where - targets = concat $ Map.elems $ targetsMap buildCtx + targets = concat $ Map.elems $ targetsMap buildCtx components = fst <$> targets - selectors = concatMap (NE.toList . snd) targets - noExes = null $ catMaybes $ exeMaybe <$> components + selectors = concatMap (NE.toList . snd) targets + noExes = null $ catMaybes $ exeMaybe <$> components exeMaybe (ComponentTarget (CExeName exe) _) = Just exe - exeMaybe _ = Nothing + exeMaybe _ = Nothing -- | Return the package specifiers and non-global environment file entries. getEnvSpecsAndNonGlobalEntries @@ -765,122 +968,161 @@ getEnvSpecsAndNonGlobalEntries -> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)]) getEnvSpecsAndNonGlobalEntries installedIndex entries installLibs = if installLibs - then (envSpecs, envEntries') - else ([], envEntries') + then (envSpecs, envEntries') + else ([], envEntries') where (envSpecs, envEntries') = environmentFileToSpecifiers installedIndex entries environmentFileToSpecifiers - :: PI.InstalledPackageIndex -> [GhcEnvironmentFileEntry] + :: PI.InstalledPackageIndex + -> [GhcEnvironmentFileEntry] -> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)]) environmentFileToSpecifiers ipi = foldMap $ \case - (GhcEnvFilePackageId unitId) - | Just InstalledPackageInfo - { sourcePackageId = PackageIdentifier{..}, installedUnitId } - <- PI.lookupUnitId ipi unitId - , let pkgSpec = NamedPackage pkgName - [PackagePropertyVersion (thisVersion pkgVersion)] - -> ([pkgSpec], [(pkgName, GhcEnvFilePackageId installedUnitId)]) - _ -> ([], []) - + (GhcEnvFilePackageId unitId) + | Just + InstalledPackageInfo + { sourcePackageId = PackageIdentifier{..} + , installedUnitId + } <- + PI.lookupUnitId ipi unitId + , let pkgSpec = + NamedPackage + pkgName + [PackagePropertyVersion (thisVersion pkgVersion)] -> + ([pkgSpec], [(pkgName, GhcEnvFilePackageId installedUnitId)]) + _ -> ([], []) -- | Disables tests and benchmarks if they weren't explicitly enabled. disableTestsBenchsByDefault :: ConfigFlags -> ConfigFlags disableTestsBenchsByDefault configFlags = - configFlags { configTests = Flag False <> configTests configFlags - , configBenchmarks = Flag False <> configBenchmarks configFlags } + configFlags + { configTests = Flag False <> configTests configFlags + , configBenchmarks = Flag False <> configBenchmarks configFlags + } -- | Symlink/copy every exe from a package from the store to a given location installUnitExes :: Verbosity - -> OverwritePolicy -- ^ Whether to overwrite existing files - -> (UnitId -> FilePath) -- ^ A function to get an UnitId's - -- ^ store directory - -> (UnqualComponentName -> FilePath) -- ^ A function to get an - -- ^ exe's filename - -> (UnqualComponentName -> FilePath) -- ^ A function to get an - -- ^ exe's final possibly - -- ^ different to the name in the store. + -> OverwritePolicy + -- ^ Whether to overwrite existing files + -> (UnitId -> FilePath) + -- ^ A function to get an UnitId's + -- ^ store directory + -> (UnqualComponentName -> FilePath) + -- ^ A function to get an + -- ^ exe's filename + -> (UnqualComponentName -> FilePath) + -- ^ A function to get an + -- ^ exe's final possibly + -- ^ different to the name in the store. -> FilePath -> InstallMethod -> ( UnitId - , [(ComponentTarget, NonEmpty TargetSelector)] ) + , [(ComponentTarget, NonEmpty TargetSelector)] + ) -> IO () -installUnitExes verbosity overwritePolicy - mkSourceBinDir mkExeName mkFinalExeName - installdir installMethod - (unit, components) = - traverse_ installAndWarn exes - where - exes = catMaybes $ (exeMaybe . fst) <$> components - exeMaybe (ComponentTarget (CExeName exe) _) = Just exe - exeMaybe _ = Nothing - installAndWarn exe = do - success <- installBuiltExe - verbosity overwritePolicy - (mkSourceBinDir unit) (mkExeName exe) - (mkFinalExeName exe) - installdir installMethod - let errorMessage = case overwritePolicy of - NeverOverwrite -> - "Path '" <> (installdir prettyShow exe) <> "' already exists. " - <> "Use --overwrite-policy=always to overwrite." - -- This shouldn't even be possible, but we keep it in case - -- symlinking/copying logic changes - _ -> - case installMethod of - InstallMethodSymlink -> "Symlinking" - InstallMethodCopy -> - "Copying" <> " '" <> prettyShow exe <> "' failed." - unless success $ die' verbosity errorMessage +installUnitExes + verbosity + overwritePolicy + mkSourceBinDir + mkExeName + mkFinalExeName + installdir + installMethod + (unit, components) = + traverse_ installAndWarn exes + where + exes = catMaybes $ (exeMaybe . fst) <$> components + exeMaybe (ComponentTarget (CExeName exe) _) = Just exe + exeMaybe _ = Nothing + installAndWarn exe = do + success <- + installBuiltExe + verbosity + overwritePolicy + (mkSourceBinDir unit) + (mkExeName exe) + (mkFinalExeName exe) + installdir + installMethod + let errorMessage = case overwritePolicy of + NeverOverwrite -> + "Path '" + <> (installdir prettyShow exe) + <> "' already exists. " + <> "Use --overwrite-policy=always to overwrite." + -- This shouldn't even be possible, but we keep it in case + -- symlinking/copying logic changes + _ -> + case installMethod of + InstallMethodSymlink -> "Symlinking" + InstallMethodCopy -> + "Copying" <> " '" <> prettyShow exe <> "' failed." + unless success $ die' verbosity errorMessage -- | Install a specific exe. installBuiltExe - :: Verbosity -> OverwritePolicy - -> FilePath -- ^ The directory where the built exe is located - -> FilePath -- ^ The exe's filename - -> FilePath -- ^ The exe's filename in the public install directory - -> FilePath -- ^ the directory where it should be installed + :: Verbosity + -> OverwritePolicy + -> FilePath + -- ^ The directory where the built exe is located + -> FilePath + -- ^ The exe's filename + -> FilePath + -- ^ The exe's filename in the public install directory + -> FilePath + -- ^ the directory where it should be installed -> InstallMethod - -> IO Bool -- ^ Whether the installation was successful -installBuiltExe verbosity overwritePolicy - sourceDir exeName finalExeName - installdir InstallMethodSymlink = do - notice verbosity $ "Symlinking '" <> exeName <> "' to '" <> destination <> "'" - symlinkBinary - overwritePolicy - installdir - sourceDir - finalExeName - exeName - where - destination = installdir finalExeName -installBuiltExe verbosity overwritePolicy - sourceDir exeName finalExeName - installdir InstallMethodCopy = do - notice verbosity $ "Copying '" <> exeName <> "' to '" <> destination <> "'" - exists <- doesPathExist destination - case (exists, overwritePolicy) of - (True , NeverOverwrite ) -> pure False - (True , AlwaysOverwrite) -> overwrite - (True , PromptOverwrite) -> maybeOverwrite - (False, _ ) -> copy - where - source = sourceDir exeName - destination = installdir finalExeName - remove = do - isDir <- doesDirectoryExist destination - if isDir - then removeDirectory destination - else removeFile destination - copy = copyFile source destination >> pure True - overwrite :: IO Bool - overwrite = remove >> copy - maybeOverwrite :: IO Bool - maybeOverwrite - = promptRun - "Existing file found while installing executable. Do you want to overwrite that file? (y/n)" - overwrite + -> IO Bool + -- ^ Whether the installation was successful +installBuiltExe + verbosity + overwritePolicy + sourceDir + exeName + finalExeName + installdir + InstallMethodSymlink = do + notice verbosity $ "Symlinking '" <> exeName <> "' to '" <> destination <> "'" + symlinkBinary + overwritePolicy + installdir + sourceDir + finalExeName + exeName + where + destination = installdir finalExeName +installBuiltExe + verbosity + overwritePolicy + sourceDir + exeName + finalExeName + installdir + InstallMethodCopy = do + notice verbosity $ "Copying '" <> exeName <> "' to '" <> destination <> "'" + exists <- doesPathExist destination + case (exists, overwritePolicy) of + (True, NeverOverwrite) -> pure False + (True, AlwaysOverwrite) -> overwrite + (True, PromptOverwrite) -> maybeOverwrite + (False, _) -> copy + where + source = sourceDir exeName + destination = installdir finalExeName + remove = do + isDir <- doesDirectoryExist destination + if isDir + then removeDirectory destination + else removeFile destination + copy = copyFile source destination >> pure True + overwrite :: IO Bool + overwrite = remove >> copy + maybeOverwrite :: IO Bool + maybeOverwrite = + promptRun + "Existing file found while installing executable. Do you want to overwrite that file? (y/n)" + overwrite -- | Create 'GhcEnvironmentFileEntry's for packages with exposed libraries. entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry] @@ -888,15 +1130,15 @@ entriesForLibraryComponents = Map.foldrWithKey' (\k v -> mappend (go k v)) [] where hasLib :: (ComponentTarget, NonEmpty TargetSelector) -> Bool hasLib (ComponentTarget (CLibName _) _, _) = True - hasLib _ = False + hasLib _ = False - go :: UnitId - -> [(ComponentTarget, NonEmpty TargetSelector)] - -> [GhcEnvironmentFileEntry] + go + :: UnitId + -> [(ComponentTarget, NonEmpty TargetSelector)] + -> [GhcEnvironmentFileEntry] go unitId targets | any hasLib targets = [GhcEnvFilePackageId unitId] - | otherwise = [] - + | otherwise = [] -- | Gets the file path to the request environment file. getEnvFile :: ClientInstallFlags -> Platform -> Version -> IO FilePath @@ -908,16 +1150,16 @@ getEnvFile clientInstallFlags platform compilerVersion = do -- a named global environment. | takeBaseName spec == spec -> return (getGlobalEnv appDir platform compilerVersion spec) - | otherwise -> do - spec' <- makeAbsolute spec - isDir <- doesDirectoryExist spec' - if isDir - -- If spec is a directory, then make an ambient environment inside - -- that directory. - then return (getLocalEnv spec' platform compilerVersion) - -- Otherwise, treat it like a literal file path. - else return spec' - Nothing -> + | otherwise -> do + spec' <- makeAbsolute spec + isDir <- doesDirectoryExist spec' + if isDir + then -- If spec is a directory, then make an ambient environment inside + -- that directory. + return (getLocalEnv spec' platform compilerVersion) + else -- Otherwise, treat it like a literal file path. + return spec' + Nothing -> return (getGlobalEnv appDir platform compilerVersion "default") -- | Returns the list of @GhcEnvFilePackageIj@ values already existing in the @@ -925,32 +1167,41 @@ getEnvFile clientInstallFlags platform compilerVersion = do getExistingEnvEntries :: Verbosity -> CompilerFlavor -> Bool -> FilePath -> IO [GhcEnvironmentFileEntry] getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile = do envFileExists <- doesFileExist envFile - filterEnvEntries <$> if - (compilerFlavor == GHC || compilerFlavor == GHCJS) - && supportsPkgEnvFiles && envFileExists - then catch (readGhcEnvironmentFile envFile) $ \(_ :: ParseErrorExc) -> - warn verbosity ("The environment file " ++ envFile ++ - " is unparsable. Libraries cannot be installed.") >> return [] - else return [] + filterEnvEntries + <$> if (compilerFlavor == GHC || compilerFlavor == GHCJS) + && supportsPkgEnvFiles + && envFileExists + then catch (readGhcEnvironmentFile envFile) $ \(_ :: ParseErrorExc) -> + warn + verbosity + ( "The environment file " + ++ envFile + ++ " is unparsable. Libraries cannot be installed." + ) + >> return [] + else return [] where -- Why? We know what the first part will be, we only care about the packages. filterEnvEntries = filter $ \case GhcEnvFilePackageId _ -> True - _ -> False + _ -> False -- | Constructs the path to the global GHC environment file. -- -- TODO(m-renaud): Create PkgEnvName newtype wrapper. getGlobalEnv :: FilePath -> Platform -> Version -> String -> FilePath getGlobalEnv appDir platform compilerVersion name = - appDir ghcPlatformAndVersionString platform compilerVersion - "environments" name + appDir + ghcPlatformAndVersionString platform compilerVersion + "environments" + name -- | Constructs the path to a local GHC environment file. getLocalEnv :: FilePath -> Platform -> Version -> FilePath -getLocalEnv dir platform compilerVersion = - dir - ".ghc.environment." <> ghcPlatformAndVersionString platform compilerVersion +getLocalEnv dir platform compilerVersion = + dir + ".ghc.environment." + <> ghcPlatformAndVersionString platform compilerVersion getPackageDbStack :: CompilerId @@ -960,7 +1211,7 @@ getPackageDbStack getPackageDbStack compilerId storeDirFlag logsDirFlag = do mstoreDir <- traverse makeAbsolute $ flagToMaybe storeDirFlag let - mlogsDir = flagToMaybe logsDirFlag + mlogsDir = flagToMaybe logsDirFlag cabalLayout <- mkCabalDirLayout mstoreDir mlogsDir pure $ storePackageDBStack (cabalStoreDirLayout cabalLayout) compilerId @@ -971,44 +1222,42 @@ getPackageDbStack compilerId storeDirFlag logsDirFlag = do -- For the @build@ command select all components except non-buildable -- and disabled tests\/benchmarks, fail if there are no such -- components --- selectPackageTargets :: TargetSelector - -> [AvailableTarget k] -> Either TargetProblem' [k] + -> [AvailableTarget k] + -> Either TargetProblem' [k] selectPackageTargets targetSelector targets - - -- If there are any buildable targets then we select those - | not (null targetsBuildable) - = Right targetsBuildable - - -- If there are targets but none are buildable then we report those - | not (null targets) - = Left (TargetProblemNoneEnabled targetSelector targets') - - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) + -- If there are any buildable targets then we select those + | not (null targetsBuildable) = + Right targetsBuildable + -- If there are targets but none are buildable then we report those + | not (null targets) = + Left (TargetProblemNoneEnabled targetSelector targets') + -- If there are no targets at all then we report that + | otherwise = + Left (TargetProblemNoTargets targetSelector) where - targets' = forgetTargetsDetail targets - targetsBuildable = selectBuildableTargetsWith - (buildable targetSelector) - targets + targets' = forgetTargetsDetail targets + targetsBuildable = + selectBuildableTargetsWith + (buildable targetSelector) + targets -- When there's a target filter like "pkg:tests" then we do select tests, -- but if it's just a target like "pkg" then we don't build tests unless -- they are requested by default (i.e. by using --enable-tests) - buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False - buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False + buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False + buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False buildable _ _ = True -- | For a 'TargetComponent' 'TargetSelector', check if the component can be -- selected. -- -- For the @build@ command we just need the basic checks on being buildable etc. --- selectComponentTarget :: SubComponentTarget - -> AvailableTarget k -> Either TargetProblem' k + -> AvailableTarget k + -> Either TargetProblem' k selectComponentTarget = selectComponentTargetBasic reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a @@ -1016,4 +1265,4 @@ reportBuildTargetProblems verbosity problems = reportTargetProblems verbosity "b reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a reportCannotPruneDependencies verbosity = - die' verbosity . renderCannotPruneDependencies + die' verbosity . renderCannotPruneDependencies diff --git a/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs b/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs index 9d85e55cce6..d5bbd5309f7 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs @@ -1,36 +1,50 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} + module Distribution.Client.CmdInstall.ClientInstallFlags -( InstallMethod(..) -, ClientInstallFlags(..) -, defaultClientInstallFlags -, clientInstallOptions -) where + ( InstallMethod (..) + , ClientInstallFlags (..) + , defaultClientInstallFlags + , clientInstallOptions + ) where import Distribution.Client.Compat.Prelude import Prelude () import Distribution.ReadE - ( succeedReadE, parsecToReadE ) + ( parsecToReadE + , succeedReadE + ) import Distribution.Simple.Command - ( ShowOrParseArgs(..), OptionField(..), option, reqArg ) + ( OptionField (..) + , ShowOrParseArgs (..) + , option + , reqArg + ) import Distribution.Simple.Setup - ( Flag(..), trueArg, flagToList, toFlag ) + ( Flag (..) + , flagToList + , toFlag + , trueArg + ) import Distribution.Client.Types.InstallMethod - ( InstallMethod (..) ) + ( InstallMethod (..) + ) import Distribution.Client.Types.OverwritePolicy - ( OverwritePolicy(..) ) + ( OverwritePolicy (..) + ) import qualified Distribution.Compat.CharParsing as P data ClientInstallFlags = ClientInstallFlags - { cinstInstallLibs :: Flag Bool + { cinstInstallLibs :: Flag Bool , cinstEnvironmentPath :: Flag FilePath , cinstOverwritePolicy :: Flag OverwritePolicy - , cinstInstallMethod :: Flag InstallMethod - , cinstInstalldir :: Flag FilePath - } deriving (Eq, Show, Generic) + , cinstInstallMethod :: Flag InstallMethod + , cinstInstalldir :: Flag FilePath + } + deriving (Eq, Show, Generic) instance Monoid ClientInstallFlags where mempty = gmempty @@ -43,48 +57,66 @@ instance Binary ClientInstallFlags instance Structured ClientInstallFlags defaultClientInstallFlags :: ClientInstallFlags -defaultClientInstallFlags = ClientInstallFlags - { cinstInstallLibs = toFlag False - , cinstEnvironmentPath = mempty - , cinstOverwritePolicy = mempty - , cinstInstallMethod = mempty - , cinstInstalldir = mempty - } +defaultClientInstallFlags = + ClientInstallFlags + { cinstInstallLibs = toFlag False + , cinstEnvironmentPath = mempty + , cinstOverwritePolicy = mempty + , cinstInstallMethod = mempty + , cinstInstalldir = mempty + } clientInstallOptions :: ShowOrParseArgs -> [OptionField ClientInstallFlags] clientInstallOptions _ = - [ option [] ["lib"] - ( "Install libraries rather than executables from the target package " <> - "(provisional, see https://github.com/haskell/cabal/issues/6481 for more information)." ) - cinstInstallLibs (\v flags -> flags { cinstInstallLibs = v }) - trueArg - , option [] ["package-env", "env"] - "Set the environment file that may be modified." - cinstEnvironmentPath (\pf flags -> flags { cinstEnvironmentPath = pf }) - (reqArg "ENV" (succeedReadE Flag) flagToList) - , option [] ["overwrite-policy"] - "How to handle already existing symlinks." - cinstOverwritePolicy (\v flags -> flags { cinstOverwritePolicy = v }) - $ reqArg "always|never|prompt" + [ option + [] + ["lib"] + ( "Install libraries rather than executables from the target package " + <> "(provisional, see https://github.com/haskell/cabal/issues/6481 for more information)." + ) + cinstInstallLibs + (\v flags -> flags{cinstInstallLibs = v}) + trueArg + , option + [] + ["package-env", "env"] + "Set the environment file that may be modified." + cinstEnvironmentPath + (\pf flags -> flags{cinstEnvironmentPath = pf}) + (reqArg "ENV" (succeedReadE Flag) flagToList) + , option + [] + ["overwrite-policy"] + "How to handle already existing symlinks." + cinstOverwritePolicy + (\v flags -> flags{cinstOverwritePolicy = v}) + $ reqArg + "always|never|prompt" (parsecToReadE (\err -> "Error parsing overwrite-policy: " ++ err) (toFlag `fmap` parsec)) (map prettyShow . flagToList) - , option [] ["install-method"] - "How to install the executables." - cinstInstallMethod (\v flags -> flags { cinstInstallMethod = v }) - $ reqArg + , option + [] + ["install-method"] + "How to install the executables." + cinstInstallMethod + (\v flags -> flags{cinstInstallMethod = v}) + $ reqArg "default|copy|symlink" (parsecToReadE (\err -> "Error parsing install-method: " ++ err) (toFlag `fmap` parsecInstallMethod)) (map prettyShow . flagToList) - , option [] ["installdir"] - "Where to install (by symlinking or copying) the executables in." - cinstInstalldir (\v flags -> flags { cinstInstalldir = v }) - $ reqArg "DIR" (succeedReadE Flag) flagToList + , option + [] + ["installdir"] + "Where to install (by symlinking or copying) the executables in." + cinstInstalldir + (\v flags -> flags{cinstInstalldir = v}) + $ reqArg "DIR" (succeedReadE Flag) flagToList ] parsecInstallMethod :: CabalParsing m => m InstallMethod parsecInstallMethod = do - name <- P.munch1 isAlpha - case name of - "copy" -> pure InstallMethodCopy - "symlink" -> pure InstallMethodSymlink - _ -> P.unexpected $ "InstallMethod: " ++ name + name <- P.munch1 isAlpha + case name of + "copy" -> pure InstallMethodCopy + "symlink" -> pure InstallMethodSymlink + _ -> P.unexpected $ "InstallMethod: " ++ name diff --git a/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs b/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs index 0127aea0f3c..e8e3f406276 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs @@ -1,10 +1,10 @@ -module Distribution.Client.CmdInstall.ClientInstallTargetSelector ( - WithoutProjectTargetSelector (..), - parseWithoutProjectTargetSelector, - woPackageNames, - woPackageTargets, - woPackageSpecifiers, - ) where +module Distribution.Client.CmdInstall.ClientInstallTargetSelector + ( WithoutProjectTargetSelector (..) + , parseWithoutProjectTargetSelector + , woPackageNames + , woPackageTargets + , woPackageSpecifiers + ) where import Distribution.Client.Compat.Prelude import Prelude () @@ -13,56 +13,58 @@ import Network.URI (URI, parseURI) import Distribution.Client.TargetSelector import Distribution.Client.Types -import Distribution.Compat.CharParsing (char, optional) +import Distribution.Compat.CharParsing (char, optional) import Distribution.Package -import Distribution.Simple.LocalBuildInfo (ComponentName (CExeName)) -import Distribution.Simple.Utils (die') +import Distribution.Simple.LocalBuildInfo (ComponentName (CExeName)) +import Distribution.Simple.Utils (die') import Distribution.Solver.Types.PackageConstraint (PackageProperty (..)) import Distribution.Version data WithoutProjectTargetSelector - = WoPackageId PackageId - | WoPackageComponent PackageId ComponentName - | WoURI URI + = WoPackageId PackageId + | WoPackageComponent PackageId ComponentName + | WoURI URI deriving (Show) parseWithoutProjectTargetSelector :: Verbosity -> String -> IO WithoutProjectTargetSelector parseWithoutProjectTargetSelector verbosity input = - case explicitEitherParsec parser input of - Right ts -> return ts - Left err -> case parseURI input of - Just uri -> return (WoURI uri) - Nothing -> die' verbosity $ "Invalid package ID: " ++ input ++ "\n" ++ err + case explicitEitherParsec parser input of + Right ts -> return ts + Left err -> case parseURI input of + Just uri -> return (WoURI uri) + Nothing -> die' verbosity $ "Invalid package ID: " ++ input ++ "\n" ++ err where parser :: CabalParsing m => m WithoutProjectTargetSelector parser = do - pid <- parsec - cn <- optional (char ':' *> parsec) - return $ case cn of - Nothing -> WoPackageId pid - Just cn' -> WoPackageComponent pid (CExeName cn') + pid <- parsec + cn <- optional (char ':' *> parsec) + return $ case cn of + Nothing -> WoPackageId pid + Just cn' -> WoPackageComponent pid (CExeName cn') -woPackageNames :: WithoutProjectTargetSelector -> [PackageName] -woPackageNames (WoPackageId pid) = [pkgName pid] +woPackageNames :: WithoutProjectTargetSelector -> [PackageName] +woPackageNames (WoPackageId pid) = [pkgName pid] woPackageNames (WoPackageComponent pid _) = [pkgName pid] -woPackageNames (WoURI _) = [] +woPackageNames (WoURI _) = [] -woPackageTargets :: WithoutProjectTargetSelector -> TargetSelector +woPackageTargets :: WithoutProjectTargetSelector -> TargetSelector woPackageTargets (WoPackageId pid) = - TargetPackageNamed (pkgName pid) Nothing + TargetPackageNamed (pkgName pid) Nothing woPackageTargets (WoPackageComponent pid cn) = - TargetComponentUnknown (pkgName pid) (Right cn) WholeComponent + TargetComponentUnknown (pkgName pid) (Right cn) WholeComponent woPackageTargets (WoURI _) = - TargetAllPackages (Just ExeKind) + TargetAllPackages (Just ExeKind) -woPackageSpecifiers :: WithoutProjectTargetSelector -> Either URI (PackageSpecifier pkg) -woPackageSpecifiers (WoPackageId pid) = Right (pidPackageSpecifiers pid) +woPackageSpecifiers :: WithoutProjectTargetSelector -> Either URI (PackageSpecifier pkg) +woPackageSpecifiers (WoPackageId pid) = Right (pidPackageSpecifiers pid) woPackageSpecifiers (WoPackageComponent pid _) = Right (pidPackageSpecifiers pid) -woPackageSpecifiers (WoURI uri) = Left uri +woPackageSpecifiers (WoURI uri) = Left uri pidPackageSpecifiers :: PackageId -> PackageSpecifier pkg pidPackageSpecifiers pid - | pkgVersion pid == nullVersion = NamedPackage (pkgName pid) [] - | otherwise = NamedPackage (pkgName pid) + | pkgVersion pid == nullVersion = NamedPackage (pkgName pid) [] + | otherwise = + NamedPackage + (pkgName pid) [ PackagePropertyVersion (thisVersion (pkgVersion pid)) ] diff --git a/cabal-install/src/Distribution/Client/CmdLegacy.hs b/cabal-install/src/Distribution/Client/CmdLegacy.hs index 6d51e844d44..4572c868f33 100644 --- a/cabal-install/src/Distribution/Client/CmdLegacy.hs +++ b/cabal-install/src/Distribution/Client/CmdLegacy.hs @@ -1,32 +1,41 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} -module Distribution.Client.CmdLegacy ( legacyCmd, legacyWrapperCmd, newCmd ) where -import Prelude () +module Distribution.Client.CmdLegacy (legacyCmd, legacyWrapperCmd, newCmd) where + import Distribution.Client.Compat.Prelude +import Prelude () import Distribution.Client.Sandbox - ( loadConfigOrSandboxConfig, findSavedDistPref ) + ( findSavedDistPref + , loadConfigOrSandboxConfig + ) import qualified Distribution.Client.Setup as Client import Distribution.Client.SetupWrapper - ( SetupScriptOptions(..), setupWrapper, defaultSetupScriptOptions ) -import qualified Distribution.Simple.Setup as Setup + ( SetupScriptOptions (..) + , defaultSetupScriptOptions + , setupWrapper + ) import Distribution.Simple.Command +import qualified Distribution.Simple.Setup as Setup import Distribution.Simple.Utils - ( wrapText ) + ( wrapText + ) import Distribution.Verbosity - ( normal ) + ( normal + ) import Control.Exception - ( try ) + ( try + ) import qualified Data.Text as T -- Tweaked versions of code from Main. -regularCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> CommandSpec (globals -> IO action) +regularCmd :: HasVerbosity flags => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> CommandSpec (globals -> IO action) regularCmd ui action = - CommandSpec ui ((flip commandAddAction) (\flags extra globals -> action flags extra globals)) NormalCommand + CommandSpec ui ((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 = @@ -34,89 +43,99 @@ wrapperCmd ui verbosity' distPref = wrapperAction :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> Command (Client.GlobalFlags -> IO ()) wrapperAction command verbosityFlag distPrefFlag = - commandAddAction command - { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do - let verbosity' = Setup.fromFlagOrDefault normal (verbosityFlag flags) - - load <- try (loadConfigOrSandboxConfig verbosity' globalFlags) - let config = either (\(SomeException _) -> mempty) id load - distPref <- findSavedDistPref config (distPrefFlag flags) - let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref } - - let command' = command { commandName = T.unpack . T.replace "v1-" "" . T.pack . commandName $ command } - - setupWrapper verbosity' setupScriptOptions Nothing - command' (const flags) (const extraArgs) + commandAddAction + command + { commandDefaultFlags = mempty + } + $ \flags extraArgs globalFlags -> do + let verbosity' = Setup.fromFlagOrDefault normal (verbosityFlag flags) + + load <- try (loadConfigOrSandboxConfig verbosity' globalFlags) + let config = either (\(SomeException _) -> mempty) id load + distPref <- findSavedDistPref config (distPrefFlag flags) + let setupScriptOptions = defaultSetupScriptOptions{useDistPref = distPref} + + let command' = command{commandName = T.unpack . T.replace "v1-" "" . T.pack . commandName $ command} + + setupWrapper + verbosity' + setupScriptOptions + Nothing + command' + (const flags) + (const extraArgs) -- class HasVerbosity a where - verbosity :: a -> Verbosity + verbosity :: a -> Verbosity instance HasVerbosity (Setup.Flag Verbosity) where - verbosity = Setup.fromFlagOrDefault normal + verbosity = Setup.fromFlagOrDefault normal -instance (HasVerbosity a) => HasVerbosity (a, b) where - verbosity (a, _) = verbosity a +instance HasVerbosity a => HasVerbosity (a, b) where + verbosity (a, _) = verbosity a -instance (HasVerbosity a) => HasVerbosity (a, b, c) where - verbosity (a , _, _) = verbosity a +instance HasVerbosity a => HasVerbosity (a, b, c) where + verbosity (a, _, _) = verbosity a -instance (HasVerbosity a) => HasVerbosity (a, b, c, d) where - verbosity (a, _, _, _) = verbosity a +instance HasVerbosity a => HasVerbosity (a, b, c, d) where + verbosity (a, _, _, _) = verbosity a -instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e) where - verbosity (a, _, _, _, _) = verbosity a +instance HasVerbosity a => HasVerbosity (a, b, c, d, e) where + verbosity (a, _, _, _, _) = verbosity a -instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e, f) where - verbosity (a, _, _, _, _, _) = verbosity a +instance HasVerbosity a => HasVerbosity (a, b, c, d, e, f) where + verbosity (a, _, _, _, _, _) = verbosity a instance HasVerbosity Setup.BuildFlags where - verbosity = verbosity . Setup.buildVerbosity + verbosity = verbosity . Setup.buildVerbosity instance HasVerbosity Setup.ConfigFlags where - verbosity = verbosity . Setup.configVerbosity + verbosity = verbosity . Setup.configVerbosity instance HasVerbosity Setup.ReplFlags where - verbosity = verbosity . Setup.replVerbosity + verbosity = verbosity . Setup.replVerbosity instance HasVerbosity Client.FreezeFlags where - verbosity = verbosity . Client.freezeVerbosity + verbosity = verbosity . Client.freezeVerbosity instance HasVerbosity Setup.HaddockFlags where - verbosity = verbosity . Setup.haddockVerbosity + verbosity = verbosity . Setup.haddockVerbosity instance HasVerbosity Client.UpdateFlags where - verbosity = verbosity . Client.updateVerbosity + verbosity = verbosity . Client.updateVerbosity instance HasVerbosity Setup.CleanFlags where - verbosity = verbosity . Setup.cleanVerbosity + verbosity = verbosity . Setup.cleanVerbosity -- legacyNote :: String -> String -legacyNote cmd = wrapText $ - "The v1-" ++ cmd ++ " command is a part of the legacy v1 style of cabal usage.\n\n" ++ - - "It is a legacy feature and will be removed in a future release of cabal-install." ++ - " Please file a bug if you cannot replicate a working v1- use case with the nix-style" ++ - " commands.\n\n" ++ - - "For more information, see: https://cabal.readthedocs.io/en/latest/nix-local-build-overview.html" +legacyNote cmd = + wrapText $ + "The v1-" + ++ cmd + ++ " command is a part of the legacy v1 style of cabal usage.\n\n" + ++ "It is a legacy feature and will be removed in a future release of cabal-install." + ++ " Please file a bug if you cannot replicate a working v1- use case with the nix-style" + ++ " commands.\n\n" + ++ "For more information, see: https://cabal.readthedocs.io/en/latest/nix-local-build-overview.html" toLegacyCmd :: CommandSpec (globals -> IO action) -> [CommandSpec (globals -> IO action)] toLegacyCmd mkSpec = [toLegacy mkSpec] where toLegacy (CommandSpec origUi@CommandUI{..} action type') = CommandSpec legUi action type' where - legUi = origUi + legUi = + origUi { commandName = "v1-" ++ commandName , commandNotes = Just $ \pname -> case commandNotes of Just notes -> notes pname ++ "\n" ++ legacyNote commandName Nothing -> legacyNote commandName } -legacyCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)] +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 ())] @@ -124,21 +143,23 @@ legacyWrapperCmd ui verbosity' distPref = toLegacyCmd (wrapperCmd ui verbosity' newCmd :: CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)] newCmd origUi@CommandUI{..} action = [cmd defaultUi, cmd newUi, cmd origUi] - where - cmd ui = CommandSpec ui (flip commandAddAction action) NormalCommand - - newMsg = T.unpack . T.replace "v2-" "new-" . T.pack - newUi = origUi - { commandName = newMsg commandName - , commandUsage = newMsg . commandUsage - , commandDescription = (newMsg .) <$> commandDescription - , commandNotes = (newMsg .) <$> commandNotes - } - - defaultMsg = T.unpack . T.replace "v2-" "" . T.pack - defaultUi = origUi - { commandName = defaultMsg commandName - , commandUsage = defaultMsg . commandUsage - , commandDescription = (defaultMsg .) <$> commandDescription - , commandNotes = (defaultMsg .) <$> commandNotes - } + where + cmd ui = CommandSpec ui (flip commandAddAction action) NormalCommand + + newMsg = T.unpack . T.replace "v2-" "new-" . T.pack + newUi = + origUi + { commandName = newMsg commandName + , commandUsage = newMsg . commandUsage + , commandDescription = (newMsg .) <$> commandDescription + , commandNotes = (newMsg .) <$> commandNotes + } + + defaultMsg = T.unpack . T.replace "v2-" "" . T.pack + defaultUi = + origUi + { commandName = defaultMsg commandName + , commandUsage = defaultMsg . commandUsage + , commandDescription = (defaultMsg .) <$> commandDescription + , commandNotes = (defaultMsg .) <$> commandNotes + } diff --git a/cabal-install/src/Distribution/Client/CmdListBin.hs b/cabal-install/src/Distribution/Client/CmdListBin.hs index 27674300849..d8366453224 100644 --- a/cabal-install/src/Distribution/Client/CmdListBin.hs +++ b/cabal-install/src/Distribution/Client/CmdListBin.hs @@ -1,51 +1,66 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -module Distribution.Client.CmdListBin ( - listbinCommand, - listbinAction, +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Distribution.Client.CmdListBin + ( listbinCommand + , listbinAction -- * Internals exposed for testing - selectPackageTargets, - selectComponentTarget, - noComponentsProblem, - matchesMultipleProblem, - multipleTargetsProblem, - componentNotRightKindProblem -) where + , selectPackageTargets + , selectComponentTarget + , noComponentsProblem + , matchesMultipleProblem + , multipleTargetsProblem + , componentNotRightKindProblem + ) where import Distribution.Client.Compat.Prelude import Prelude () import Distribution.Client.CmdErrorMessages - (plural, renderListCommaAnd, renderTargetProblem, renderTargetProblemNoTargets, - renderTargetSelector, showTargetSelector, targetSelectorFilter, targetSelectorPluralPkgs) -import Distribution.Client.DistDirLayout (DistDirLayout (..)) + ( plural + , renderListCommaAnd + , renderTargetProblem + , renderTargetProblemNoTargets + , renderTargetSelector + , showTargetSelector + , targetSelectorFilter + , targetSelectorPluralPkgs + ) +import Distribution.Client.DistDirLayout (DistDirLayout (..)) import Distribution.Client.NixStyleOptions - (NixStyleFlags (..), defaultNixStyleFlags, nixStyleOptions) + ( NixStyleFlags (..) + , defaultNixStyleFlags + , nixStyleOptions + ) import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning.Types import Distribution.Client.ScriptUtils - (AcceptNoTargets(..), TargetContext(..), updateContextAndWriteProjectFile, withContextAndSelectors) -import Distribution.Client.Setup (GlobalFlags (..)) -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.Utils (die', withOutputMarker, wrapText) -import Distribution.System (Platform) -import Distribution.Types.ComponentName (showComponentName) -import Distribution.Types.UnitId (UnitId) -import Distribution.Types.UnqualComponentName (UnqualComponentName) -import Distribution.Verbosity (silent, verboseStderr) -import System.FilePath ((<.>), ()) - -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Distribution.Client.InstallPlan as IP -import qualified Distribution.Simple.InstallDirs as InstallDirs + ( AcceptNoTargets (..) + , TargetContext (..) + , updateContextAndWriteProjectFile + , withContextAndSelectors + ) +import Distribution.Client.Setup (GlobalFlags (..)) +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.Utils (die', withOutputMarker, wrapText) +import Distribution.System (Platform) +import Distribution.Types.ComponentName (showComponentName) +import Distribution.Types.UnitId (UnitId) +import Distribution.Types.UnqualComponentName (UnqualComponentName) +import Distribution.Verbosity (silent, verboseStderr) +import System.FilePath ((<.>), ()) + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Distribution.Client.InstallPlan as IP +import qualified Distribution.Simple.InstallDirs as InstallDirs import qualified Distribution.Solver.Types.ComponentDeps as CD ------------------------------------------------------------------------------- @@ -53,16 +68,18 @@ import qualified Distribution.Solver.Types.ComponentDeps as CD ------------------------------------------------------------------------------- listbinCommand :: CommandUI (NixStyleFlags ()) -listbinCommand = CommandUI +listbinCommand = + CommandUI { commandName = "list-bin" , commandSynopsis = "List the path to a single executable." , commandUsage = \pname -> "Usage: " ++ pname ++ " list-bin [FLAGS] TARGET\n" - , commandDescription = Just $ \_ -> wrapText - "List the path to a build product." + , commandDescription = Just $ \_ -> + wrapText + "List the path to a build product." , commandNotes = Nothing , commandDefaultFlags = defaultNixStyleFlags () - , commandOptions = nixStyleOptions (const []) + , commandOptions = nixStyleOptions (const []) } ------------------------------------------------------------------------------- @@ -73,111 +90,122 @@ listbinAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () listbinAction flags@NixStyleFlags{..} args globalFlags = do -- fail early if multiple target selectors specified target <- case args of - [] -> die' verbosity "One target is required, none provided" - [x] -> return x - _ -> die' verbosity "One target is required, given multiple" + [] -> die' verbosity "One target is required, none provided" + [x] -> return x + _ -> die' verbosity "One target is required, given multiple" -- configure and elaborate target selectors withContextAndSelectors RejectNoTargets (Just ExeKind) flags [target] globalFlags OtherCommand $ \targetCtx ctx targetSelectors -> do baseCtx <- case targetCtx of - ProjectContext -> return ctx - GlobalContext -> return ctx + ProjectContext -> return ctx + GlobalContext -> return ctx ScriptContext path exemeta -> updateContextAndWriteProjectFile ctx path exemeta buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - -- Interpret the targets on the command line as build targets - -- (as opposed to say repl or haddock targets). - targets <- either (reportTargetProblems verbosity) return - $ resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors - - -- Reject multiple targets, or at least targets in different - -- components. It is ok to have two module/file targets in the - -- same component, but not two that live in different components. - -- - -- Note that we discard the target and return the whole 'TargetsMap', - -- so this check will be repeated (and must succeed) after - -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this. - _ <- singleComponentOrElse - (reportTargetProblems - verbosity - [multipleTargetsProblem targets]) - targets - - let elaboratedPlan' = pruneInstallPlanToTargets - TargetActionBuild - targets - elaboratedPlan - return (elaboratedPlan', targets) + -- Interpret the targets on the command line as build targets + -- (as opposed to say repl or haddock targets). + targets <- + either (reportTargetProblems verbosity) return $ + resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + -- Reject multiple targets, or at least targets in different + -- components. It is ok to have two module/file targets in the + -- same component, but not two that live in different components. + -- + -- Note that we discard the target and return the whole 'TargetsMap', + -- so this check will be repeated (and must succeed) after + -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this. + _ <- + singleComponentOrElse + ( reportTargetProblems + verbosity + [multipleTargetsProblem targets] + ) + targets + + let elaboratedPlan' = + pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan + return (elaboratedPlan', targets) (selectedUnitId, selectedComponent) <- -- Slight duplication with 'runProjectPreBuildPhase'. singleComponentOrElse - (die' verbosity $ "No or multiple targets given, but the run " - ++ "phase has been reached. This is a bug.") + ( die' verbosity $ + "No or multiple targets given, but the run " + ++ "phase has been reached. This is a bug." + ) $ targetsMap buildCtx printPlan verbosity baseCtx buildCtx binfiles <- case Map.lookup selectedUnitId $ IP.toMap (elaboratedPlanOriginal buildCtx) of - Nothing -> die' verbosity "No or multiple targets given..." - Just gpp -> return $ IP.foldPlanPackage + Nothing -> die' verbosity "No or multiple targets given..." + Just gpp -> + return $ + IP.foldPlanPackage (const []) -- IPI don't have executables (elaboratedPackage (distDirLayout baseCtx) (elaboratedShared buildCtx) selectedComponent) gpp case binfiles of - [] -> die' verbosity "No target found" - [exe] -> putStr $ withOutputMarker verbosity $ exe ++ "\n" - -- Andreas, 2023-01-13, issue #8400: - -- Regular output of `list-bin` should go to stdout unconditionally, - -- but for the sake of the testsuite, we want to mark it so it goes - -- into the golden value for the test. - -- Note: 'withOutputMarker' only checks 'isVerboseMarkOutput', - -- thus, we can reuse @verbosity@ here, even if other components - -- of @verbosity@ may be wrong (like 'VStderr', verbosity level etc.). - -- Andreas, 2023-01-20: - -- Appending the newline character here rather than using 'putStrLn' - -- because an active 'withOutputMarker' produces text that ends - -- in newline characters. - _ -> die' verbosity "Multiple targets found" + [] -> die' verbosity "No target found" + [exe] -> putStr $ withOutputMarker verbosity $ exe ++ "\n" + -- Andreas, 2023-01-13, issue #8400: + -- Regular output of `list-bin` should go to stdout unconditionally, + -- but for the sake of the testsuite, we want to mark it so it goes + -- into the golden value for the test. + -- Note: 'withOutputMarker' only checks 'isVerboseMarkOutput', + -- thus, we can reuse @verbosity@ here, even if other components + -- of @verbosity@ may be wrong (like 'VStderr', verbosity level etc.). + -- Andreas, 2023-01-20: + -- Appending the newline character here rather than using 'putStrLn' + -- because an active 'withOutputMarker' produces text that ends + -- in newline characters. + _ -> die' verbosity "Multiple targets found" where defaultVerbosity = verboseStderr silent verbosity = fromFlagOrDefault defaultVerbosity (configVerbosity configFlags) -- this is copied from elaboratedPackage - :: DistDirLayout - -> ElaboratedSharedConfig - -> UnqualComponentName - -> ElaboratedConfiguredPackage - -> [FilePath] + :: DistDirLayout + -> ElaboratedSharedConfig + -> UnqualComponentName + -> ElaboratedConfiguredPackage + -> [FilePath] elaboratedPackage distDirLayout elaboratedSharedConfig selectedComponent elab = case elabPkgOrComp elab of - ElabPackage pkg -> - [ bin - | (c, _) <- CD.toList $ CD.zip (pkgLibDependencies pkg) - (pkgExeDependencies pkg) - , bin <- bin_file c - ] - ElabComponent comp -> bin_file (compSolverName comp) + ElabPackage pkg -> + [ bin + | (c, _) <- + CD.toList $ + CD.zip + (pkgLibDependencies pkg) + (pkgExeDependencies pkg) + , bin <- bin_file c + ] + ElabComponent comp -> bin_file (compSolverName comp) where dist_dir = distBuildDirectory distDirLayout (elabDistDirParams elaboratedSharedConfig elab) bin_file c = case c of - CD.ComponentExe s - | s == selectedComponent -> [bin_file' s] - CD.ComponentTest s - | s == selectedComponent -> [bin_file' s] - CD.ComponentBench s - | s == selectedComponent -> [bin_file' s] - CD.ComponentFLib s - | s == selectedComponent -> [flib_file' s] - _ -> [] + CD.ComponentExe s + | s == selectedComponent -> [bin_file' s] + CD.ComponentTest s + | s == selectedComponent -> [bin_file' s] + CD.ComponentBench s + | s == selectedComponent -> [bin_file' s] + CD.ComponentFLib s + | s == selectedComponent -> [flib_file' s] + _ -> [] plat :: Platform plat = pkgConfigPlatform elaboratedSharedConfig @@ -185,12 +213,12 @@ listbinAction flags@NixStyleFlags{..} args globalFlags = do -- here and in PlanOutput, -- use binDirectoryFor? bin_file' s = - if elabBuildStyle elab == BuildInplaceOnly + if elabBuildStyle elab == BuildInplaceOnly then dist_dir "build" prettyShow s prettyShow s <.> exeExtension plat else InstallDirs.bindir (elabInstallDirs elab) prettyShow s <.> exeExtension plat flib_file' s = - if elabBuildStyle elab == BuildInplaceOnly + if elabBuildStyle elab == BuildInplaceOnly then dist_dir "build" prettyShow s ("lib" ++ prettyShow s) <.> dllExtension plat else InstallDirs.bindir (elabInstallDirs elab) ("lib" ++ prettyShow s) <.> dllExtension plat @@ -200,12 +228,12 @@ listbinAction flags@NixStyleFlags{..} args globalFlags = do singleComponentOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName) singleComponentOrElse action targetsMap = - case Set.toList . distinctTargetComponents $ targetsMap - of [(unitId, CExeName component)] -> return (unitId, component) - [(unitId, CTestName component)] -> return (unitId, component) - [(unitId, CBenchName component)] -> return (unitId, component) - [(unitId, CFLibName component)] -> return (unitId, component) - _ -> action + case Set.toList . distinctTargetComponents $ targetsMap of + [(unitId, CExeName component)] -> return (unitId, component) + [(unitId, CTestName component)] -> return (unitId, component) + [(unitId, CBenchName component)] -> return (unitId, component) + [(unitId, CFLibName component)] -> return (unitId, component) + _ -> action -- | This defines what a 'TargetSelector' means for the @list-bin@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, @@ -213,49 +241,45 @@ singleComponentOrElse action targetsMap = -- -- For the @list-bin@ command we select the exe or flib if there is only one -- and it's buildable. Fail if there are no or multiple buildable exe components. --- -selectPackageTargets :: TargetSelector - -> [AvailableTarget k] -> Either ListBinTargetProblem [k] +selectPackageTargets + :: TargetSelector + -> [AvailableTarget k] + -> Either ListBinTargetProblem [k] selectPackageTargets targetSelector targets - -- If there is a single executable component, select that. See #7403 - | [target] <- targetsExesBuildable - = Right [target] - + | [target] <- targetsExesBuildable = + Right [target] -- Otherwise, if there is a single executable-like component left, select that. - | [target] <- targetsExeLikesBuildable - = Right [target] - - -- but fail if there are multiple buildable executables. - | not (null targetsExeLikesBuildable) - = Left (matchesMultipleProblem targetSelector targetsExeLikesBuildable') - - -- If there are executables but none are buildable then we report those - | not (null targetsExeLikes') - = Left (TargetProblemNoneEnabled targetSelector targetsExeLikes') - - -- If there are no executables but some other targets then we report that - | not (null targets) - = Left (noComponentsProblem targetSelector) - - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) + | [target] <- targetsExeLikesBuildable = + Right [target] + -- but fail if there are multiple buildable executables. + | not (null targetsExeLikesBuildable) = + Left (matchesMultipleProblem targetSelector targetsExeLikesBuildable') + -- If there are executables but none are buildable then we report those + | not (null targetsExeLikes') = + Left (TargetProblemNoneEnabled targetSelector targetsExeLikes') + -- If there are no executables but some other targets then we report that + | not (null targets) = + Left (noComponentsProblem targetSelector) + -- If there are no targets at all then we report that + | otherwise = + Left (TargetProblemNoTargets targetSelector) where -- Targets that are precisely executables targetsExes = filterTargetsKind ExeKind targets targetsExesBuildable = selectBuildableTargets targetsExes -- Any target that could be executed - targetsExeLikes = targetsExes - ++ filterTargetsKind TestKind targets - ++ filterTargetsKind BenchKind targets - - (targetsExeLikesBuildable, - targetsExeLikesBuildable') = selectBuildableTargets' targetsExeLikes + targetsExeLikes = + targetsExes + ++ filterTargetsKind TestKind targets + ++ filterTargetsKind BenchKind targets - targetsExeLikes' = forgetTargetsDetail targetsExeLikes + ( targetsExeLikesBuildable + , targetsExeLikesBuildable' + ) = selectBuildableTargets' targetsExeLikes + targetsExeLikes' = forgetTargetsDetail targetsExeLikes -- | For a 'TargetComponent' 'TargetSelector', check if the component can be -- selected. @@ -263,43 +287,42 @@ selectPackageTargets targetSelector targets -- For the @run@ command we just need to check it is a executable-like -- (an executable, a test, or a benchmark), in addition -- to the basic checks on being buildable etc. --- -selectComponentTarget :: SubComponentTarget - -> AvailableTarget k -> Either ListBinTargetProblem k -selectComponentTarget subtarget@WholeComponent t - = case availableTargetComponentName t - of CExeName _ -> component - CTestName _ -> component - CBenchName _ -> component - CFLibName _ -> component - _ -> Left (componentNotRightKindProblem pkgid cname) - where pkgid = availableTargetPackageId t - cname = availableTargetComponentName t - component = selectComponentTargetBasic subtarget t - -selectComponentTarget subtarget t - = Left (isSubComponentProblem (availableTargetPackageId t) - (availableTargetComponentName t) - subtarget) +selectComponentTarget + :: SubComponentTarget + -> AvailableTarget k + -> Either ListBinTargetProblem k +selectComponentTarget subtarget@WholeComponent t = + case availableTargetComponentName t of + CExeName _ -> component + CTestName _ -> component + CBenchName _ -> component + CFLibName _ -> component + _ -> Left (componentNotRightKindProblem pkgid cname) + where + pkgid = availableTargetPackageId t + cname = availableTargetComponentName t + component = selectComponentTargetBasic subtarget t +selectComponentTarget subtarget t = + Left + ( isSubComponentProblem + (availableTargetPackageId t) + (availableTargetComponentName t) + subtarget + ) -- | The various error conditions that can occur when matching a -- 'TargetSelector' against 'AvailableTarget's for the @run@ command. --- -data ListBinProblem = - -- | The 'TargetSelector' matches targets but no executables - TargetProblemNoRightComps TargetSelector - - -- | A single 'TargetSelector' matches multiple targets - | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] - - -- | Multiple 'TargetSelector's match multiple targets - | TargetProblemMultipleTargets TargetsMap - - -- | The 'TargetSelector' refers to a component that is not an executable - | TargetProblemComponentNotRightKind PackageId ComponentName - - -- | Asking to run an individual file or module is not supported - | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget +data ListBinProblem + = -- | The 'TargetSelector' matches targets but no executables + TargetProblemNoRightComps TargetSelector + | -- | A single 'TargetSelector' matches multiple targets + TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] + | -- | Multiple 'TargetSelector's match multiple targets + TargetProblemMultipleTargets TargetsMap + | -- | The 'TargetSelector' refers to a component that is not an executable + TargetProblemComponentNotRightKind PackageId ComponentName + | -- | Asking to run an individual file or module is not supported + TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget deriving (Eq, Show) type ListBinTargetProblem = TargetProblem ListBinProblem @@ -308,14 +331,16 @@ noComponentsProblem :: TargetSelector -> ListBinTargetProblem noComponentsProblem = CustomTargetProblem . TargetProblemNoRightComps matchesMultipleProblem :: TargetSelector -> [AvailableTarget ()] -> ListBinTargetProblem -matchesMultipleProblem selector targets = CustomTargetProblem $ +matchesMultipleProblem selector targets = + CustomTargetProblem $ TargetProblemMatchesMultiple selector targets multipleTargetsProblem :: TargetsMap -> TargetProblem ListBinProblem multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets componentNotRightKindProblem :: PackageId -> ComponentName -> TargetProblem ListBinProblem -componentNotRightKindProblem pkgid name = CustomTargetProblem $ +componentNotRightKindProblem pkgid name = + CustomTargetProblem $ TargetProblemComponentNotRightKind pkgid name isSubComponentProblem @@ -323,63 +348,75 @@ isSubComponentProblem -> ComponentName -> SubComponentTarget -> TargetProblem ListBinProblem -isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $ +isSubComponentProblem pkgid name subcomponent = + CustomTargetProblem $ TargetProblemIsSubComponent pkgid name subcomponent reportTargetProblems :: Verbosity -> [ListBinTargetProblem] -> IO a reportTargetProblems verbosity = - die' verbosity . unlines . map renderListBinTargetProblem + die' verbosity . unlines . map renderListBinTargetProblem renderListBinTargetProblem :: ListBinTargetProblem -> String renderListBinTargetProblem (TargetProblemNoTargets targetSelector) = - case targetSelectorFilter targetSelector of - Just kind | kind /= ExeKind - -> "The list-bin command is for finding binaries, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ "." - - _ -> renderTargetProblemNoTargets "list-bin" targetSelector + case targetSelectorFilter targetSelector of + Just kind + | kind /= ExeKind -> + "The list-bin command is for finding binaries, but the target '" + ++ showTargetSelector targetSelector + ++ "' refers to " + ++ renderTargetSelector targetSelector + ++ "." + _ -> renderTargetProblemNoTargets "list-bin" targetSelector renderListBinTargetProblem problem = - renderTargetProblem "list-bin" renderListBinProblem problem + renderTargetProblem "list-bin" renderListBinProblem problem renderListBinProblem :: ListBinProblem -> String renderListBinProblem (TargetProblemMatchesMultiple targetSelector targets) = - "The list-bin command is for finding a single binary at once. The target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ " which includes " - ++ renderListCommaAnd ( ("the "++) <$> - showComponentName <$> - availableTargetComponentName <$> - foldMap - (\kind -> filterTargetsKind kind targets) - [ExeKind, TestKind, BenchKind] ) - ++ "." - + "The list-bin command is for finding a single binary at once. The target '" + ++ showTargetSelector targetSelector + ++ "' refers to " + ++ renderTargetSelector targetSelector + ++ " which includes " + ++ renderListCommaAnd + ( ("the " ++) + <$> showComponentName + <$> availableTargetComponentName + <$> foldMap + (\kind -> filterTargetsKind kind targets) + [ExeKind, TestKind, BenchKind] + ) + ++ "." renderListBinProblem (TargetProblemMultipleTargets selectorMap) = - "The list-bin command is for finding a single binary at once. The targets " - ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'" - | ts <- uniqueTargetSelectors selectorMap ] - ++ " refer to different executables." - + "The list-bin command is for finding a single binary at once. The targets " + ++ renderListCommaAnd + [ "'" ++ showTargetSelector ts ++ "'" + | ts <- uniqueTargetSelectors selectorMap + ] + ++ " refer to different executables." renderListBinProblem (TargetProblemComponentNotRightKind pkgid cname) = - "The list-bin command is for finding binaries, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ " from the package " - ++ prettyShow pkgid ++ "." + "The list-bin command is for finding binaries, but the target '" + ++ showTargetSelector targetSelector + ++ "' refers to " + ++ renderTargetSelector targetSelector + ++ " from the package " + ++ prettyShow pkgid + ++ "." where targetSelector = TargetComponent pkgid cname WholeComponent - renderListBinProblem (TargetProblemIsSubComponent pkgid cname subtarget) = - "The list-bin command can only find a binary as a whole, " - ++ "not files or modules within them, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ "." + "The list-bin command can only find a binary as a whole, " + ++ "not files or modules within them, but the target '" + ++ showTargetSelector targetSelector + ++ "' refers to " + ++ renderTargetSelector targetSelector + ++ "." where targetSelector = TargetComponent pkgid cname subtarget - renderListBinProblem (TargetProblemNoRightComps targetSelector) = - "Cannot list-bin the target '" ++ showTargetSelector targetSelector - ++ "' which refers to " ++ renderTargetSelector targetSelector - ++ " because " - ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" - ++ " not contain any executables or foreign libraries." + "Cannot list-bin the target '" + ++ showTargetSelector targetSelector + ++ "' which refers to " + ++ renderTargetSelector targetSelector + ++ " because " + ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" + ++ " not contain any executables or foreign libraries." diff --git a/cabal-install/src/Distribution/Client/CmdOutdated.hs b/cabal-install/src/Distribution/Client/CmdOutdated.hs index 1c98abd937e..7f143b9ec3b 100644 --- a/cabal-install/src/Distribution/Client/CmdOutdated.hs +++ b/cabal-install/src/Distribution/Client/CmdOutdated.hs @@ -1,7 +1,11 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.CmdOutdated -- Maintainer : cabal-devel@haskell.org @@ -9,184 +13,271 @@ -- -- Implementation of the 'outdated' command. Checks for outdated -- dependencies in the package description file or freeze file. ------------------------------------------------------------------------------ - module Distribution.Client.CmdOutdated - ( outdatedCommand, outdatedAction - , ListOutdatedSettings(..), listOutdated ) + ( outdatedCommand + , outdatedAction + , ListOutdatedSettings (..) + , listOutdated + ) where import Distribution.Client.Compat.Prelude import Distribution.Compat.Lens - ( _1, _2 ) + ( _1 + , _2 + ) import Prelude () import Distribution.Client.Config - ( SavedConfig(savedGlobalFlags, savedConfigureFlags - , savedConfigureExFlags) ) -import Distribution.Client.IndexUtils as IndexUtils + ( SavedConfig + ( savedConfigureExFlags + , savedConfigureFlags + , savedGlobalFlags + ) + ) import Distribution.Client.DistDirLayout - ( defaultDistDirLayout - , DistDirLayout(distProjectRootDirectory, distProjectFile) ) + ( DistDirLayout (distProjectFile, distProjectRootDirectory) + , defaultDistDirLayout + ) +import Distribution.Client.IndexUtils as IndexUtils import Distribution.Client.ProjectConfig import Distribution.Client.ProjectConfig.Legacy - ( instantiateProjectConfigSkeletonWithCompiler ) + ( instantiateProjectConfigSkeletonWithCompiler + ) import Distribution.Client.ProjectFlags - ( projectFlagsOptions, ProjectFlags(..), defaultProjectFlags - , removeIgnoreProjectOption ) + ( ProjectFlags (..) + , defaultProjectFlags + , projectFlagsOptions + , removeIgnoreProjectOption + ) import Distribution.Client.RebuildMonad - ( runRebuild ) + ( runRebuild + ) import Distribution.Client.Sandbox - ( loadConfigOrSandboxConfig ) + ( loadConfigOrSandboxConfig + ) +import Distribution.Client.Sandbox.PackageEnvironment + ( loadUserConfig + ) import Distribution.Client.Setup import Distribution.Client.Targets - ( userToPackageConstraint, UserConstraint ) + ( UserConstraint + , userToPackageConstraint + ) import Distribution.Client.Types.SourcePackageDb as SourcePackageDb import Distribution.Solver.Types.PackageConstraint - ( packageConstraintToDependency ) -import Distribution.Client.Sandbox.PackageEnvironment - ( loadUserConfig ) + ( packageConstraintToDependency + ) import Distribution.Utils.Generic - ( safeLast, wrapText ) + ( safeLast + , wrapText + ) +import Distribution.Client.HttpUtils +import qualified Distribution.Compat.CharParsing as P import Distribution.Package - ( PackageName, packageVersion ) + ( PackageName + , packageVersion + ) import Distribution.PackageDescription - ( allBuildDepends ) + ( allBuildDepends + ) import Distribution.PackageDescription.Configuration - ( finalizePD ) + ( finalizePD + ) +import Distribution.ReadE + ( parsecToReadE + ) +import Distribution.Simple.Command + ( CommandUI (..) + , OptionField + , ShowOrParseArgs + , liftOptionL + , optArg + , option + , reqArg + ) import Distribution.Simple.Compiler - ( Compiler, compilerInfo ) + ( Compiler + , compilerInfo + ) +import Distribution.Simple.Flag + ( Flag (..) + , flagToMaybe + , fromFlagOrDefault + , toFlag + ) +import Distribution.Simple.PackageDescription + ( readGenericPackageDescription + ) import Distribution.Simple.Setup - ( optionVerbosity, trueArg ) + ( optionVerbosity + , trueArg + ) import Distribution.Simple.Utils - ( die', notice, debug, tryFindPackageDesc ) + ( debug + , die' + , notice + , tryFindPackageDesc + ) import Distribution.System - ( Platform (..) ) + ( Platform (..) + ) import Distribution.Types.ComponentRequestedSpec - ( ComponentRequestedSpec(..) ) + ( ComponentRequestedSpec (..) + ) import Distribution.Types.Dependency - ( Dependency(..) ) -import Distribution.Verbosity - ( silent, normal ) -import Distribution.Version - ( Version, VersionInterval (..), VersionRange, LowerBound(..) - , UpperBound(..) , asVersionIntervals, majorBoundVersion ) + ( Dependency (..) + ) import Distribution.Types.PackageVersionConstraint - ( PackageVersionConstraint (..), simplifyPackageVersionConstraint ) -import Distribution.Simple.Flag - ( Flag(..), flagToMaybe, fromFlagOrDefault, toFlag ) -import Distribution.Simple.Command - ( ShowOrParseArgs, OptionField, CommandUI(..), optArg, option, reqArg, liftOptionL ) -import Distribution.Simple.PackageDescription - ( readGenericPackageDescription ) -import qualified Distribution.Compat.CharParsing as P -import Distribution.ReadE - ( parsecToReadE ) -import Distribution.Client.HttpUtils + ( PackageVersionConstraint (..) + , simplifyPackageVersionConstraint + ) import Distribution.Utils.NubList - ( fromNubList ) + ( fromNubList + ) +import Distribution.Verbosity + ( normal + , silent + ) +import Distribution.Version + ( LowerBound (..) + , UpperBound (..) + , Version + , VersionInterval (..) + , VersionRange + , asVersionIntervals + , majorBoundVersion + ) import qualified Data.Set as S import System.Directory - ( getCurrentDirectory, doesFileExist ) + ( doesFileExist + , getCurrentDirectory + ) ------------------------------------------------------------------------------- -- Command ------------------------------------------------------------------------------- outdatedCommand :: CommandUI (ProjectFlags, OutdatedFlags) -outdatedCommand = CommandUI - { commandName = "outdated" - , commandSynopsis = "Check for outdated dependencies." - , commandDescription = Just $ \_ -> wrapText $ - "Checks for outdated dependencies in the package description file " - ++ "or freeze file" - , commandNotes = Nothing - , commandUsage = \pname -> - "Usage: " ++ pname ++ " outdated [FLAGS] [PACKAGES]\n" - , commandDefaultFlags = (defaultProjectFlags, defaultOutdatedFlags) - , commandOptions = \showOrParseArgs -> - map (liftOptionL _1) - (removeIgnoreProjectOption (projectFlagsOptions showOrParseArgs)) ++ - map (liftOptionL _2) (outdatedOptions showOrParseArgs) - } +outdatedCommand = + CommandUI + { commandName = "outdated" + , commandSynopsis = "Check for outdated dependencies." + , commandDescription = Just $ \_ -> + wrapText $ + "Checks for outdated dependencies in the package description file " + ++ "or freeze file" + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " outdated [FLAGS] [PACKAGES]\n" + , commandDefaultFlags = (defaultProjectFlags, defaultOutdatedFlags) + , commandOptions = \showOrParseArgs -> + map + (liftOptionL _1) + (removeIgnoreProjectOption (projectFlagsOptions showOrParseArgs)) + ++ map (liftOptionL _2) (outdatedOptions showOrParseArgs) + } ------------------------------------------------------------------------------- -- Flags ------------------------------------------------------------------------------- -data IgnoreMajorVersionBumps = IgnoreMajorVersionBumpsNone - | IgnoreMajorVersionBumpsAll - | IgnoreMajorVersionBumpsSome [PackageName] +data IgnoreMajorVersionBumps + = IgnoreMajorVersionBumpsNone + | IgnoreMajorVersionBumpsAll + | IgnoreMajorVersionBumpsSome [PackageName] instance Monoid IgnoreMajorVersionBumps where - mempty = IgnoreMajorVersionBumpsNone + mempty = IgnoreMajorVersionBumpsNone mappend = (<>) instance Semigroup IgnoreMajorVersionBumps where - IgnoreMajorVersionBumpsNone <> r = r - l@IgnoreMajorVersionBumpsAll <> _ = l - l@(IgnoreMajorVersionBumpsSome _) <> IgnoreMajorVersionBumpsNone = l - (IgnoreMajorVersionBumpsSome _) <> r@IgnoreMajorVersionBumpsAll = r - (IgnoreMajorVersionBumpsSome a) <> (IgnoreMajorVersionBumpsSome b) = + IgnoreMajorVersionBumpsNone <> r = r + l@IgnoreMajorVersionBumpsAll <> _ = l + l@(IgnoreMajorVersionBumpsSome _) <> IgnoreMajorVersionBumpsNone = l + (IgnoreMajorVersionBumpsSome _) <> r@IgnoreMajorVersionBumpsAll = r + (IgnoreMajorVersionBumpsSome a) <> (IgnoreMajorVersionBumpsSome b) = IgnoreMajorVersionBumpsSome (a ++ b) data OutdatedFlags = OutdatedFlags - { outdatedVerbosity :: Flag Verbosity - , outdatedFreezeFile :: Flag Bool + { outdatedVerbosity :: Flag Verbosity + , outdatedFreezeFile :: Flag Bool , outdatedNewFreezeFile :: Flag Bool - , outdatedSimpleOutput :: Flag Bool - , outdatedExitCode :: Flag Bool - , outdatedQuiet :: Flag Bool - , outdatedIgnore :: [PackageName] - , outdatedMinor :: Maybe IgnoreMajorVersionBumps + , outdatedSimpleOutput :: Flag Bool + , outdatedExitCode :: Flag Bool + , outdatedQuiet :: Flag Bool + , outdatedIgnore :: [PackageName] + , outdatedMinor :: Maybe IgnoreMajorVersionBumps } defaultOutdatedFlags :: OutdatedFlags -defaultOutdatedFlags = OutdatedFlags - { outdatedVerbosity = toFlag normal - , outdatedFreezeFile = mempty - , outdatedNewFreezeFile = mempty - , outdatedSimpleOutput = mempty - , outdatedExitCode = mempty - , outdatedQuiet = mempty - , outdatedIgnore = mempty - , outdatedMinor = mempty - } +defaultOutdatedFlags = + OutdatedFlags + { outdatedVerbosity = toFlag normal + , outdatedFreezeFile = mempty + , outdatedNewFreezeFile = mempty + , outdatedSimpleOutput = mempty + , outdatedExitCode = mempty + , outdatedQuiet = mempty + , outdatedIgnore = mempty + , outdatedMinor = mempty + } outdatedOptions :: ShowOrParseArgs -> [OptionField OutdatedFlags] outdatedOptions _showOrParseArgs = [ optionVerbosity outdatedVerbosity - (\v flags -> flags {outdatedVerbosity = v}) - , option [] ["freeze-file", "v1-freeze-file"] + (\v flags -> flags{outdatedVerbosity = v}) + , option + [] + ["freeze-file", "v1-freeze-file"] "Act on the freeze file" - outdatedFreezeFile (\v flags -> flags {outdatedFreezeFile = v}) + outdatedFreezeFile + (\v flags -> flags{outdatedFreezeFile = v}) trueArg - , option [] ["v2-freeze-file", "new-freeze-file"] + , option + [] + ["v2-freeze-file", "new-freeze-file"] "Act on the new-style freeze file (default: cabal.project.freeze)" - outdatedNewFreezeFile (\v flags -> flags {outdatedNewFreezeFile = v}) + outdatedNewFreezeFile + (\v flags -> flags{outdatedNewFreezeFile = v}) trueArg - , option [] ["simple-output"] + , option + [] + ["simple-output"] "Only print names of outdated dependencies, one per line" - outdatedSimpleOutput (\v flags -> flags {outdatedSimpleOutput = v}) + outdatedSimpleOutput + (\v flags -> flags{outdatedSimpleOutput = v}) trueArg - , option [] ["exit-code"] + , option + [] + ["exit-code"] "Exit with non-zero when there are outdated dependencies" - outdatedExitCode (\v flags -> flags {outdatedExitCode = v}) + outdatedExitCode + (\v flags -> flags{outdatedExitCode = v}) trueArg - , option ['q'] ["quiet"] + , option + ['q'] + ["quiet"] "Don't print any output. Implies '--exit-code' and '-v0'" - outdatedQuiet (\v flags -> flags {outdatedQuiet = v}) + outdatedQuiet + (\v flags -> flags{outdatedQuiet = v}) trueArg - , option [] ["ignore"] + , option + [] + ["ignore"] "Packages to ignore" - outdatedIgnore (\v flags -> flags {outdatedIgnore = v}) + outdatedIgnore + (\v flags -> flags{outdatedIgnore = v}) (reqArg "PKGS" pkgNameListParser (map prettyShow)) - , option [] ["minor"] + , option + [] + ["minor"] "Ignore major version bumps for these packages" - outdatedMinor (\v flags -> flags {outdatedMinor = v}) + outdatedMinor + (\v flags -> flags{outdatedMinor = v}) ( optArg "PKGS" ignoreMajorVersionBumpsParser @@ -195,20 +286,22 @@ outdatedOptions _showOrParseArgs = ) ] where - ignoreMajorVersionBumpsPrinter :: Maybe IgnoreMajorVersionBumps - -> [Maybe String] + ignoreMajorVersionBumpsPrinter + :: Maybe IgnoreMajorVersionBumps + -> [Maybe String] ignoreMajorVersionBumpsPrinter Nothing = [] - ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsNone)= [] + ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsNone) = [] ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsAll) = [Nothing] ignoreMajorVersionBumpsPrinter (Just (IgnoreMajorVersionBumpsSome pkgs)) = map (Just . prettyShow) pkgs - ignoreMajorVersionBumpsParser = + ignoreMajorVersionBumpsParser = (Just . IgnoreMajorVersionBumpsSome) `fmap` pkgNameListParser - pkgNameListParser = parsecToReadE - ("Couldn't parse the list of package names: " ++) - (fmap toList (P.sepByNonEmpty parsec (P.char ','))) + pkgNameListParser = + parsecToReadE + ("Couldn't parse the list of package names: " ++) + (fmap toList (P.sepByNonEmpty parsec (P.char ','))) ------------------------------------------------------------------------------- -- Action @@ -219,7 +312,7 @@ outdatedAction :: (ProjectFlags, OutdatedFlags) -> [String] -> GlobalFlags -> IO outdatedAction (ProjectFlags{flagProjectDir, flagProjectFile}, OutdatedFlags{..}) _targetStrings globalFlags = do config <- loadConfigOrSandboxConfig verbosity globalFlags let globalFlags' = savedGlobalFlags config `mappend` globalFlags - configFlags = savedConfigureFlags config + configFlags = savedConfigureFlags config withRepoContext verbosity globalFlags' $ \repoContext -> do when (not newFreezeFile && (isJust mprojectDir || isJust mprojectFile)) $ die' verbosity $ @@ -227,58 +320,69 @@ outdatedAction (ProjectFlags{flagProjectDir, flagProjectFile}, OutdatedFlags{..} sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoContext (comp, platform, _progdb) <- configCompilerAux' configFlags - deps <- if freezeFile - then depsFromFreezeFile verbosity - else if newFreezeFile - then do - httpTransport <- configureTransport verbosity - (fromNubList . globalProgPathExtra $ globalFlags) - (flagToMaybe . globalHttpTransport $ globalFlags) - depsFromNewFreezeFile verbosity httpTransport comp platform mprojectDir mprojectFile - else do - depsFromPkgDesc verbosity comp platform - debug verbosity $ "Dependencies loaded: " - ++ intercalate ", " (map prettyShow deps) - let outdatedDeps = listOutdated deps sourcePkgDb - (ListOutdatedSettings ignorePred minorPred) + deps <- + if freezeFile + then depsFromFreezeFile verbosity + else + if newFreezeFile + then do + httpTransport <- + configureTransport + verbosity + (fromNubList . globalProgPathExtra $ globalFlags) + (flagToMaybe . globalHttpTransport $ globalFlags) + depsFromNewFreezeFile verbosity httpTransport comp platform mprojectDir mprojectFile + else do + depsFromPkgDesc verbosity comp platform + debug verbosity $ + "Dependencies loaded: " + ++ intercalate ", " (map prettyShow deps) + let outdatedDeps = + listOutdated + deps + sourcePkgDb + (ListOutdatedSettings ignorePred minorPred) when (not quiet) $ showResult verbosity outdatedDeps simpleOutput if exitCode && (not . null $ outdatedDeps) then exitFailure else return () where - verbosity = if quiet - then silent - else fromFlagOrDefault normal outdatedVerbosity - freezeFile = fromFlagOrDefault False outdatedFreezeFile + verbosity = + if quiet + then silent + else fromFlagOrDefault normal outdatedVerbosity + freezeFile = fromFlagOrDefault False outdatedFreezeFile newFreezeFile = fromFlagOrDefault False outdatedNewFreezeFile - mprojectDir = flagToMaybe flagProjectDir - mprojectFile = flagToMaybe flagProjectFile - simpleOutput = fromFlagOrDefault False outdatedSimpleOutput - quiet = fromFlagOrDefault False outdatedQuiet - exitCode = fromFlagOrDefault quiet outdatedExitCode - ignorePred = let ignoreSet = S.fromList outdatedIgnore - in \pkgname -> pkgname `S.member` ignoreSet - minorPred = case outdatedMinor of - Nothing -> const False - Just IgnoreMajorVersionBumpsNone -> const False - Just IgnoreMajorVersionBumpsAll -> const True - Just (IgnoreMajorVersionBumpsSome pkgs) -> - let minorSet = S.fromList pkgs - in \pkgname -> pkgname `S.member` minorSet - + mprojectDir = flagToMaybe flagProjectDir + mprojectFile = flagToMaybe flagProjectFile + simpleOutput = fromFlagOrDefault False outdatedSimpleOutput + quiet = fromFlagOrDefault False outdatedQuiet + exitCode = fromFlagOrDefault quiet outdatedExitCode + ignorePred = + let ignoreSet = S.fromList outdatedIgnore + in \pkgname -> pkgname `S.member` ignoreSet + minorPred = case outdatedMinor of + Nothing -> const False + Just IgnoreMajorVersionBumpsNone -> const False + Just IgnoreMajorVersionBumpsAll -> const True + Just (IgnoreMajorVersionBumpsSome pkgs) -> + let minorSet = S.fromList pkgs + in \pkgname -> pkgname `S.member` minorSet -- | Print either the list of all outdated dependencies, or a message -- that there are none. -showResult :: Verbosity -> [(PackageVersionConstraint,Version)] -> Bool -> IO () +showResult :: Verbosity -> [(PackageVersionConstraint, Version)] -> Bool -> IO () showResult verbosity outdatedDeps simpleOutput = if not . null $ outdatedDeps - then - do when (not simpleOutput) $ - notice verbosity "Outdated dependencies:" - for_ outdatedDeps $ \(d@(PackageVersionConstraint pn _), v) -> - let outdatedDep = if simpleOutput then prettyShow pn - else prettyShow d ++ " (latest: " ++ prettyShow v ++ ")" + then do + when (not simpleOutput) $ + notice verbosity "Outdated dependencies:" + for_ outdatedDeps $ \(d@(PackageVersionConstraint pn _), v) -> + let outdatedDep = + if simpleOutput + then prettyShow pn + else prettyShow d ++ " (latest: " ++ prettyShow v ++ ")" in notice verbosity outdatedDep else notice verbosity "All dependencies are up to date." @@ -290,55 +394,71 @@ userConstraintsToDependencies ucnstrs = -- | Read the list of dependencies from the freeze file. depsFromFreezeFile :: Verbosity -> IO [PackageVersionConstraint] depsFromFreezeFile verbosity = do - cwd <- getCurrentDirectory + cwd <- getCurrentDirectory userConfig <- loadUserConfig verbosity cwd Nothing - let ucnstrs = map fst . configExConstraints . savedConfigureExFlags $ - userConfig - deps = userConstraintsToDependencies ucnstrs + let ucnstrs = + map fst . configExConstraints . savedConfigureExFlags $ + userConfig + deps = userConstraintsToDependencies ucnstrs debug verbosity "Reading the list of dependencies from the freeze file" return deps -- | Read the list of dependencies from the new-style freeze file. depsFromNewFreezeFile :: Verbosity -> HttpTransport -> Compiler -> Platform -> Maybe FilePath -> Maybe FilePath -> IO [PackageVersionConstraint] depsFromNewFreezeFile verbosity httpTransport compiler (Platform arch os) mprojectDir mprojectFile = do - projectRoot <- either throwIO return =<< - findProjectRoot verbosity mprojectDir mprojectFile - let distDirLayout = defaultDistDirLayout projectRoot - {- TODO: Support dist dir override -} Nothing Nothing + projectRoot <- + either throwIO return + =<< findProjectRoot verbosity mprojectDir mprojectFile + let distDirLayout = + defaultDistDirLayout + projectRoot + {- TODO: Support dist dir override -} Nothing + Nothing projectConfig <- runRebuild (distProjectRootDirectory distDirLayout) $ do - pcs <- readProjectLocalFreezeConfig verbosity httpTransport distDirLayout - pure $ instantiateProjectConfigSkeletonWithCompiler os arch (compilerInfo compiler) mempty pcs - let ucnstrs = map fst . projectConfigConstraints . projectConfigShared - $ projectConfig - deps = userConstraintsToDependencies ucnstrs + pcs <- readProjectLocalFreezeConfig verbosity httpTransport distDirLayout + pure $ instantiateProjectConfigSkeletonWithCompiler os arch (compilerInfo compiler) mempty pcs + let ucnstrs = + map fst . projectConfigConstraints . projectConfigShared $ + projectConfig + deps = userConstraintsToDependencies ucnstrs freezeFile = distProjectFile distDirLayout "freeze" freezeFileExists <- doesFileExist freezeFile unless freezeFileExists $ die' verbosity $ - "Couldn't find a freeze file expected at: " ++ freezeFile ++ "\n\n" - ++ "We are looking for this file because you supplied '--project-file' or '--v2-freeze-file'. " - ++ "When one of these flags is given, we try to read the dependencies from a freeze file. " - ++ "If it is undesired behaviour, you should not use these flags, otherwise please generate " - ++ "a freeze file via 'cabal freeze'." + "Couldn't find a freeze file expected at: " + ++ freezeFile + ++ "\n\n" + ++ "We are looking for this file because you supplied '--project-file' or '--v2-freeze-file'. " + ++ "When one of these flags is given, we try to read the dependencies from a freeze file. " + ++ "If it is undesired behaviour, you should not use these flags, otherwise please generate " + ++ "a freeze file via 'cabal freeze'." debug verbosity $ "Reading the list of dependencies from the new-style freeze file " ++ freezeFile return deps -- | Read the list of dependencies from the package description. -depsFromPkgDesc :: Verbosity -> Compiler -> Platform -> IO [PackageVersionConstraint] +depsFromPkgDesc :: Verbosity -> Compiler -> Platform -> IO [PackageVersionConstraint] depsFromPkgDesc verbosity comp platform = do - cwd <- getCurrentDirectory + cwd <- getCurrentDirectory path <- tryFindPackageDesc verbosity cwd - gpd <- readGenericPackageDescription verbosity path + gpd <- readGenericPackageDescription verbosity path let cinfo = compilerInfo comp - epd = finalizePD mempty (ComponentRequestedSpec True True) - (const True) platform cinfo [] gpd + epd = + finalizePD + mempty + (ComponentRequestedSpec True True) + (const True) + platform + cinfo + [] + gpd case epd of - Left _ -> die' verbosity "finalizePD failed" + Left _ -> die' verbosity "finalizePD failed" Right (pd, _) -> do let bd = allBuildDepends pd - debug verbosity + debug + verbosity "Reading the list of dependencies from the package description" return $ map toPVC bd where @@ -346,17 +466,18 @@ depsFromPkgDesc verbosity comp platform = do -- | Various knobs for customising the behaviour of 'listOutdated'. data ListOutdatedSettings = ListOutdatedSettings - { -- | Should this package be ignored? - listOutdatedIgnorePred :: PackageName -> Bool - , -- | Should major version bumps be ignored for this package? - listOutdatedMinorPred :: PackageName -> Bool + { listOutdatedIgnorePred :: PackageName -> Bool + -- ^ Should this package be ignored? + , listOutdatedMinorPred :: PackageName -> Bool + -- ^ Should major version bumps be ignored for this package? } -- | Find all outdated dependencies. -listOutdated :: [PackageVersionConstraint] - -> SourcePackageDb - -> ListOutdatedSettings - -> [(PackageVersionConstraint, Version)] +listOutdated + :: [PackageVersionConstraint] + -> SourcePackageDb + -> ListOutdatedSettings + -> [(PackageVersionConstraint, Version)] listOutdated deps sourceDb (ListOutdatedSettings ignorePred minorPred) = mapMaybe isOutdated $ map simplifyPackageVersionConstraint deps where @@ -364,30 +485,31 @@ listOutdated deps sourceDb (ListOutdatedSettings ignorePred minorPred) = isOutdated dep@(PackageVersionConstraint pname vr) | ignorePred pname = Nothing | otherwise = - let this = map packageVersion $ SourcePackageDb.lookupDependency sourceDb pname vr + let this = map packageVersion $ SourcePackageDb.lookupDependency sourceDb pname vr latest = lookupLatest dep - in (\v -> (dep, v)) `fmap` isOutdated' this latest + in (\v -> (dep, v)) `fmap` isOutdated' this latest isOutdated' :: [Version] -> [Version] -> Maybe Version - isOutdated' [] _ = Nothing - isOutdated' _ [] = Nothing + isOutdated' [] _ = Nothing + isOutdated' _ [] = Nothing isOutdated' this latest = - let this' = maximum this + let this' = maximum this latest' = maximum latest - in if this' < latest' then Just latest' else Nothing + in if this' < latest' then Just latest' else Nothing lookupLatest :: PackageVersionConstraint -> [Version] lookupLatest (PackageVersionConstraint pname vr) | minorPred pname = - map packageVersion $ SourcePackageDb.lookupDependency sourceDb pname (relaxMinor vr) + map packageVersion $ SourcePackageDb.lookupDependency sourceDb pname (relaxMinor vr) | otherwise = - map packageVersion $ SourcePackageDb.lookupPackageName sourceDb pname + map packageVersion $ SourcePackageDb.lookupPackageName sourceDb pname relaxMinor :: VersionRange -> VersionRange relaxMinor vr = let vis = asVersionIntervals vr - in maybe vr relax (safeLast vis) - where relax (VersionInterval (LowerBound v0 _) upper) = - case upper of - NoUpperBound -> vr - UpperBound _v1 _ -> majorBoundVersion v0 + in maybe vr relax (safeLast vis) + where + relax (VersionInterval (LowerBound v0 _) upper) = + case upper of + NoUpperBound -> vr + UpperBound _v1 _ -> majorBoundVersion v0 diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs index dcf659f036a..01a39f3cc64 100644 --- a/cabal-install/src/Distribution/Client/CmdRepl.hs +++ b/cabal-install/src/Distribution/Client/CmdRepl.hs @@ -5,102 +5,170 @@ {-# LANGUAGE TupleSections #-} -- | cabal-install CLI command: repl --- -module Distribution.Client.CmdRepl ( - -- * The @repl@ CLI and action - replCommand, - replAction, +module Distribution.Client.CmdRepl + ( -- * The @repl@ CLI and action + replCommand + , replAction -- * Internals exposed for testing - matchesMultipleProblem, - selectPackageTargets, - selectComponentTarget + , matchesMultipleProblem + , selectPackageTargets + , selectComponentTarget ) where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () import Distribution.Compat.Lens import qualified Distribution.Types.Lens as L -import Distribution.Client.DistDirLayout - ( DistDirLayout(..) ) -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) import Distribution.Client.CmdErrorMessages - ( renderTargetSelector, showTargetSelector, - renderTargetProblem, - targetSelectorRefersToPkgs, - renderComponentKind, renderListCommaAnd, renderListSemiAnd, - componentKind, sortGroupOn, Plural(..) ) -import Distribution.Client.TargetProblem - ( TargetProblem(..) ) + ( Plural (..) + , componentKind + , renderComponentKind + , renderListCommaAnd + , renderListSemiAnd + , renderTargetProblem + , renderTargetSelector + , showTargetSelector + , sortGroupOn + , targetSelectorRefersToPkgs + ) +import Distribution.Client.DistDirLayout + ( DistDirLayout (..) + ) import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..) + , defaultNixStyleFlags + , nixStyleOptions + ) import Distribution.Client.ProjectBuilding - ( rebuildTargetsDryRun, improveInstallPlanWithUpToDatePackages ) + ( improveInstallPlanWithUpToDatePackages + , rebuildTargetsDryRun + ) import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning - ( ElaboratedSharedConfig(..), ElaboratedInstallPlan ) + ( ElaboratedInstallPlan + , ElaboratedSharedConfig (..) + ) import Distribution.Client.ProjectPlanning.Types - ( elabOrderExeDependencies ) + ( elabOrderExeDependencies + ) import Distribution.Client.ScriptUtils - ( AcceptNoTargets(..), withContextAndSelectors, TargetContext(..) - , updateContextAndWriteProjectFile, updateContextAndWriteProjectFile' - , fakeProjectSourcePackage, lSrcpkgDescription ) + ( AcceptNoTargets (..) + , TargetContext (..) + , fakeProjectSourcePackage + , lSrcpkgDescription + , updateContextAndWriteProjectFile + , updateContextAndWriteProjectFile' + , withContextAndSelectors + ) import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..) ) + ( ConfigFlags (..) + , GlobalFlags + ) import qualified Distribution.Client.Setup as Client +import Distribution.Client.TargetProblem + ( TargetProblem (..) + ) import Distribution.Client.Types - ( PackageSpecifier(..), UnresolvedSourcePackage ) -import Distribution.Simple.Setup - ( fromFlagOrDefault, ReplOptions(..), replOptions - , Flag(..), toFlag, falseArg ) -import Distribution.Simple.Command - ( CommandUI(..), liftOptionL, usageAlternatives, option - , ShowOrParseArgs, OptionField, reqArg ) + ( PackageSpecifier (..) + , UnresolvedSourcePackage + ) import Distribution.Compiler - ( CompilerFlavor(GHC) ) -import Distribution.Simple.Compiler - ( Compiler, compilerCompatVersion ) + ( CompilerFlavor (GHC) + ) import Distribution.Package - ( Package(..), packageName, UnitId, installedUnitId ) + ( Package (..) + , UnitId + , installedUnitId + , packageName + ) import Distribution.Parsec - ( parsecCommaList ) + ( parsecCommaList + ) import Distribution.ReadE - ( ReadE, parsecToReadE ) + ( ReadE + , parsecToReadE + ) +import Distribution.Simple.Command + ( CommandUI (..) + , OptionField + , ShowOrParseArgs + , liftOptionL + , option + , reqArg + , usageAlternatives + ) +import Distribution.Simple.Compiler + ( Compiler + , compilerCompatVersion + ) +import Distribution.Simple.Setup + ( Flag (..) + , ReplOptions (..) + , falseArg + , fromFlagOrDefault + , replOptions + , toFlag + ) +import Distribution.Simple.Utils + ( debugNoWrap + , die' + , wrapText + ) import Distribution.Solver.Types.SourcePackage - ( SourcePackage(..) ) + ( SourcePackage (..) + ) import Distribution.Types.BuildInfo - ( BuildInfo(..), emptyBuildInfo ) + ( BuildInfo (..) + , emptyBuildInfo + ) import Distribution.Types.ComponentName - ( componentNameString ) + ( componentNameString + ) import Distribution.Types.CondTree - ( CondTree(..) ) + ( CondTree (..) + ) import Distribution.Types.Dependency - ( Dependency(..), mainLibSet ) + ( Dependency (..) + , mainLibSet + ) import Distribution.Types.Library - ( Library(..), emptyLibrary ) + ( Library (..) + , emptyLibrary + ) import Distribution.Types.Version - ( Version, mkVersion ) + ( Version + , mkVersion + ) import Distribution.Types.VersionRange - ( anyVersion ) + ( anyVersion + ) import Distribution.Utils.Generic - ( safeHead ) + ( safeHead + ) import Distribution.Verbosity - ( normal, lessVerbose ) -import Distribution.Simple.Utils - ( wrapText, die', debugNoWrap ) + ( lessVerbose + , normal + ) import Language.Haskell.Extension - ( Language(..) ) + ( Language (..) + ) import Data.List - ( (\\) ) + ( (\\) + ) import qualified Data.Map as Map import qualified Data.Set as Set import System.Directory - ( doesFileExist, getCurrentDirectory ) + ( doesFileExist + , getCurrentDirectory + ) import System.FilePath - ( () ) + ( () + ) data EnvFlags = EnvFlags { envPackages :: [Dependency] @@ -108,21 +176,28 @@ data EnvFlags = EnvFlags } defaultEnvFlags :: EnvFlags -defaultEnvFlags = EnvFlags - { envPackages = [] - , envIncludeTransitive = toFlag True - } +defaultEnvFlags = + EnvFlags + { envPackages = [] + , envIncludeTransitive = toFlag True + } envOptions :: ShowOrParseArgs -> [OptionField EnvFlags] envOptions _ = - [ option ['b'] ["build-depends"] - "Include additional packages in the environment presented to GHCi." - envPackages (\p flags -> flags { envPackages = p ++ envPackages flags }) - (reqArg "DEPENDENCIES" dependenciesReadE (fmap prettyShow :: [Dependency] -> [String])) - , option [] ["no-transitive-deps"] - "Don't automatically include transitive dependencies of requested packages." - envIncludeTransitive (\p flags -> flags { envIncludeTransitive = p }) - falseArg + [ option + ['b'] + ["build-depends"] + "Include additional packages in the environment presented to GHCi." + envPackages + (\p flags -> flags{envPackages = p ++ envPackages flags}) + (reqArg "DEPENDENCIES" dependenciesReadE (fmap prettyShow :: [Dependency] -> [String])) + , option + [] + ["no-transitive-deps"] + "Don't automatically include transitive dependencies of requested packages." + envIncludeTransitive + (\p flags -> flags{envIncludeTransitive = p}) + falseArg ] where dependenciesReadE :: ReadE [Dependency] @@ -132,47 +207,61 @@ envOptions _ = (parsecCommaList parsec) replCommand :: CommandUI (NixStyleFlags (ReplOptions, EnvFlags)) -replCommand = Client.installCommand { - commandName = "v2-repl", - commandSynopsis = "Open an interactive session for the given component.", - commandUsage = usageAlternatives "v2-repl" [ "[TARGET] [FLAGS]" ], - commandDescription = Just $ \_ -> wrapText $ - "Open an interactive session for a component within the project. The " - ++ "available targets are the same as for the 'v2-build' command: " - ++ "individual components within packages in the project, including " - ++ "libraries, executables, test-suites or benchmarks. Packages can " - ++ "also be specified in which case the library component in the " - ++ "package will be used, or the (first listed) executable in the " - ++ "package if there is no library.\n\n" - - ++ "Dependencies are built or rebuilt as necessary. Additional " - ++ "configuration flags can be specified on the command line and these " - ++ "extend the project configuration from the 'cabal.project', " - ++ "'cabal.project.local' and other files.", - commandNotes = Just $ \pname -> +replCommand = + Client.installCommand + { commandName = "v2-repl" + , commandSynopsis = "Open an interactive session for the given component." + , commandUsage = usageAlternatives "v2-repl" ["[TARGET] [FLAGS]"] + , commandDescription = Just $ \_ -> + wrapText $ + "Open an interactive session for a component within the project. The " + ++ "available targets are the same as for the 'v2-build' command: " + ++ "individual components within packages in the project, including " + ++ "libraries, executables, test-suites or benchmarks. Packages can " + ++ "also be specified in which case the library component in the " + ++ "package will be used, or the (first listed) executable in the " + ++ "package if there is no library.\n\n" + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files." + , commandNotes = Just $ \pname -> "Examples, open an interactive session:\n" - ++ " " ++ pname ++ " v2-repl\n" - ++ " for the default component in the package in the current directory\n" - ++ " " ++ pname ++ " v2-repl pkgname\n" - ++ " for the default component in the package named 'pkgname'\n" - ++ " " ++ pname ++ " v2-repl ./pkgfoo\n" - ++ " for the default component in the package in the ./pkgfoo directory\n" - ++ " " ++ pname ++ " v2-repl cname\n" - ++ " for the component named 'cname'\n" - ++ " " ++ pname ++ " v2-repl pkgname:cname\n" - ++ " for the component 'cname' in the package 'pkgname'\n\n" - ++ " " ++ pname ++ " v2-repl --build-depends lens\n" - ++ " add the latest version of the library 'lens' to the default component " - ++ "(or no componentif there is no project present)\n" - ++ " " ++ pname ++ " v2-repl --build-depends \"lens >= 4.15 && < 4.18\"\n" - ++ " add a version (constrained between 4.15 and 4.18) of the library 'lens' " - ++ "to the default component (or no component if there is no project present)\n", - - commandDefaultFlags = defaultNixStyleFlags (mempty, defaultEnvFlags), - commandOptions = nixStyleOptions $ \showOrParseArgs -> - map (liftOptionL _1) (replOptions showOrParseArgs) ++ - map (liftOptionL _2) (envOptions showOrParseArgs) - } + ++ " " + ++ pname + ++ " v2-repl\n" + ++ " for the default component in the package in the current directory\n" + ++ " " + ++ pname + ++ " v2-repl pkgname\n" + ++ " for the default component in the package named 'pkgname'\n" + ++ " " + ++ pname + ++ " v2-repl ./pkgfoo\n" + ++ " for the default component in the package in the ./pkgfoo directory\n" + ++ " " + ++ pname + ++ " v2-repl cname\n" + ++ " for the component named 'cname'\n" + ++ " " + ++ pname + ++ " v2-repl pkgname:cname\n" + ++ " for the component 'cname' in the package 'pkgname'\n\n" + ++ " " + ++ pname + ++ " v2-repl --build-depends lens\n" + ++ " add the latest version of the library 'lens' to the default component " + ++ "(or no componentif there is no project present)\n" + ++ " " + ++ pname + ++ " v2-repl --build-depends \"lens >= 4.15 && < 4.18\"\n" + ++ " add a version (constrained between 4.15 and 4.18) of the library 'lens' " + ++ "to the default component (or no component if there is no project present)\n" + , commandDefaultFlags = defaultNixStyleFlags (mempty, defaultEnvFlags) + , commandOptions = nixStyleOptions $ \showOrParseArgs -> + map (liftOptionL _1) (replOptions showOrParseArgs) + ++ map (liftOptionL _2) (envOptions showOrParseArgs) + } -- | The @repl@ command is very much like @build@. It brings the install plan -- up to date, selects that part of the plan needed by the given or implicit @@ -184,12 +273,12 @@ replCommand = Client.installCommand { -- -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" --- replAction :: NixStyleFlags (ReplOptions, EnvFlags) -> [String] -> GlobalFlags -> IO () -replAction flags@NixStyleFlags { extraFlags = (replOpts, envFlags), ..} targetStrings globalFlags - = withContextAndSelectors AcceptNoTargets (Just LibKind) flags targetStrings globalFlags ReplCommand $ \targetCtx ctx targetSelectors -> do +replAction flags@NixStyleFlags{extraFlags = (replOpts, envFlags), ..} targetStrings globalFlags = + withContextAndSelectors AcceptNoTargets (Just LibKind) flags targetStrings globalFlags ReplCommand $ \targetCtx ctx targetSelectors -> do when (buildSettingOnlyDeps (buildSettings ctx)) $ - die' verbosity $ "The repl command does not support '--only-dependencies'. " + die' verbosity $ + "The repl command does not support '--only-dependencies'. " ++ "You may wish to use 'build --only-dependencies' and then " ++ "use 'repl'." @@ -197,35 +286,40 @@ replAction flags@NixStyleFlags { extraFlags = (replOpts, envFlags), ..} targetSt baseCtx <- case targetCtx of ProjectContext -> return ctx - GlobalContext -> do + GlobalContext -> do unless (null targetStrings) $ - die' verbosity $ "'repl' takes no arguments or a script argument outside a project: " ++ unwords targetStrings + die' verbosity $ + "'repl' takes no arguments or a script argument outside a project: " ++ unwords targetStrings let - sourcePackage = fakeProjectSourcePackage projectRoot - & lSrcpkgDescription . L.condLibrary - .~ Just (CondNode library [baseDep] []) - library = emptyLibrary { libBuildInfo = lBuildInfo } - lBuildInfo = emptyBuildInfo - { targetBuildDepends = [baseDep] - , defaultLanguage = Just Haskell2010 - } + sourcePackage = + fakeProjectSourcePackage projectRoot + & lSrcpkgDescription . L.condLibrary + .~ Just (CondNode library [baseDep] []) + library = emptyLibrary{libBuildInfo = lBuildInfo} + lBuildInfo = + emptyBuildInfo + { targetBuildDepends = [baseDep] + , defaultLanguage = Just Haskell2010 + } baseDep = Dependency "base" anyVersion mainLibSet updateContextAndWriteProjectFile' ctx sourcePackage ScriptContext scriptPath scriptExecutable -> do unless (length targetStrings == 1) $ - die' verbosity $ "'repl' takes a single argument which should be a script: " ++ unwords targetStrings + die' verbosity $ + "'repl' takes a single argument which should be a script: " ++ unwords targetStrings existsScriptPath <- doesFileExist scriptPath unless existsScriptPath $ - die' verbosity $ "'repl' takes a single argument which should be a script: " ++ unwords targetStrings + die' verbosity $ + "'repl' takes a single argument which should be a script: " ++ unwords targetStrings updateContextAndWriteProjectFile ctx scriptPath scriptExecutable - (originalComponent, baseCtx') <- if null (envPackages envFlags) - then return (Nothing, baseCtx) - else - -- Unfortunately, the best way to do this is to let the normal solver + (originalComponent, baseCtx') <- + if null (envPackages envFlags) + then return (Nothing, baseCtx) + else -- Unfortunately, the best way to do this is to let the normal solver -- help us resolve the targets, but that isn't ideal for performance, -- especially in the no-project case. withInstallPlan (lessVerbose verbosity) baseCtx $ \elaboratedPlan _ -> do @@ -257,39 +351,46 @@ replAction flags@NixStyleFlags { extraFlags = (replOpts, envFlags), ..} targetSt targets <- validatedTargets elaboratedPlan targetSelectors let - elaboratedPlan' = pruneInstallPlanToTargets - TargetActionRepl - targets - elaboratedPlan + elaboratedPlan' = + pruneInstallPlanToTargets + TargetActionRepl + targets + elaboratedPlan includeTransitive = fromFlagOrDefault True (envIncludeTransitive envFlags) - pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout elaboratedShared' - elaboratedPlan' + pkgsBuildStatus <- + rebuildTargetsDryRun + distDirLayout + elaboratedShared' + elaboratedPlan' - let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages - pkgsBuildStatus elaboratedPlan' + let elaboratedPlan'' = + improveInstallPlanWithUpToDatePackages + pkgsBuildStatus + elaboratedPlan' debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'') let - buildCtx = ProjectBuildContext - { elaboratedPlanOriginal = elaboratedPlan - , elaboratedPlanToExecute = elaboratedPlan'' - , elaboratedShared = elaboratedShared' - , pkgsBuildStatus - , targetsMap = targets - } + buildCtx = + ProjectBuildContext + { elaboratedPlanOriginal = elaboratedPlan + , elaboratedPlanToExecute = elaboratedPlan'' + , elaboratedShared = elaboratedShared' + , pkgsBuildStatus + , targetsMap = targets + } - ElaboratedSharedConfig { pkgConfigCompiler = compiler } = elaboratedShared' + ElaboratedSharedConfig{pkgConfigCompiler = compiler} = elaboratedShared' replFlags = case originalComponent of Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci - Nothing -> [] + Nothing -> [] return (buildCtx, compiler, replOpts & lReplOptionsFlags %~ (++ replFlags)) replOpts'' <- case targetCtx of ProjectContext -> return replOpts' - _ -> usingGhciScript compiler projectRoot replOpts' + _ -> usingGhciScript compiler projectRoot replOpts' let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts'' printPlan verbosity baseCtx' buildCtx' @@ -302,19 +403,21 @@ replAction flags@NixStyleFlags { extraFlags = (replOpts, envFlags), ..} targetSt validatedTargets elaboratedPlan targetSelectors = do -- Interpret the targets on the command line as repl targets -- (as opposed to say build or haddock targets). - targets <- either (reportTargetProblems verbosity) return - $ resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors + targets <- + either (reportTargetProblems verbosity) return $ + resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors -- Reject multiple targets, or at least targets in different -- components. It is ok to have two module/file targets in the -- same component, but not two that live in different components. when (Set.size (distinctTargetComponents targets) > 1) $ - reportTargetProblems verbosity + reportTargetProblems + verbosity [multipleTargetsProblem targets] return targets @@ -325,27 +428,32 @@ data OriginalComponentInfo = OriginalComponentInfo } deriving (Show) -addDepsToProjectTarget :: [Dependency] - -> PackageId - -> ProjectBaseContext - -> ProjectBaseContext +addDepsToProjectTarget + :: [Dependency] + -> PackageId + -> ProjectBaseContext + -> ProjectBaseContext addDepsToProjectTarget deps pkgId ctx = - (\p -> ctx { localPackages = p }) . fmap addDeps . localPackages $ ctx + (\p -> ctx{localPackages = p}) . fmap addDeps . localPackages $ ctx where - addDeps :: PackageSpecifier UnresolvedSourcePackage - -> PackageSpecifier UnresolvedSourcePackage + addDeps + :: PackageSpecifier UnresolvedSourcePackage + -> PackageSpecifier UnresolvedSourcePackage addDeps (SpecificSourcePackage pkg) | packageId pkg /= pkgId = SpecificSourcePackage pkg | SourcePackage{..} <- pkg = - SpecificSourcePackage $ pkg { srcpkgDescription = - -- New dependencies are added to the original ones found in the - -- `targetBuildDepends` field. - -- `traverseBuildInfos` is used in order to update _all_ the - -- occurrences of the field `targetBuildDepends`. It ensures that - -- fields depending on the latter are also consistently updated. - srcpkgDescription & (L.traverseBuildInfos . L.targetBuildDepends) - %~ (deps ++) - } + SpecificSourcePackage $ + pkg + { srcpkgDescription = + -- New dependencies are added to the original ones found in the + -- `targetBuildDepends` field. + -- `traverseBuildInfos` is used in order to update _all_ the + -- occurrences of the field `targetBuildDepends`. It ensures that + -- fields depending on the latter are also consistently updated. + srcpkgDescription + & (L.traverseBuildInfos . L.targetBuildDepends) + %~ (deps ++) + } addDeps spec = spec generateReplFlags :: Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> [String] @@ -359,12 +467,13 @@ generateReplFlags includeTransitive elaboratedPlan OriginalComponentInfo{..} = f deps, deps', trans, trans' :: [UnitId] flags :: [String] - deps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan ociUnitId - deps' = deps \\ ociOriginalDeps - trans = installedUnitId <$> InstallPlan.dependencyClosure elaboratedPlan deps' + deps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan ociUnitId + deps' = deps \\ ociOriginalDeps + trans = installedUnitId <$> InstallPlan.dependencyClosure elaboratedPlan deps' trans' = trans \\ ociOriginalDeps - flags = fmap (("-package-id " ++) . prettyShow) . (\\ exeDeps) - $ if includeTransitive then trans' else deps' + flags = + fmap (("-package-id " ++) . prettyShow) . (\\ exeDeps) $ + if includeTransitive then trans' else deps' -- | Add repl options to ensure the repl actually starts in the current working directory. -- @@ -402,84 +511,81 @@ minGhciScriptVersion = mkVersion [7, 6] -- -- Fail if there are no buildable lib\/exe components, or if there are -- multiple libs or exes. --- -selectPackageTargets :: TargetSelector - -> [AvailableTarget k] -> Either ReplTargetProblem [k] +selectPackageTargets + :: TargetSelector + -> [AvailableTarget k] + -> Either ReplTargetProblem [k] selectPackageTargets targetSelector targets - - -- If there is exactly one buildable library then we select that - | [target] <- targetsLibsBuildable - = Right [target] - - -- but fail if there are multiple buildable libraries. - | not (null targetsLibsBuildable) - = Left (matchesMultipleProblem targetSelector targetsLibsBuildable') - - -- If there is exactly one buildable executable then we select that - | [target] <- targetsExesBuildable - = Right [target] - - -- but fail if there are multiple buildable executables. - | not (null targetsExesBuildable) - = Left (matchesMultipleProblem targetSelector targetsExesBuildable') - - -- If there is exactly one other target then we select that - | [target] <- targetsBuildable - = Right [target] - - -- but fail if there are multiple such targets - | not (null targetsBuildable) - = Left (matchesMultipleProblem targetSelector targetsBuildable') - - -- If there are targets but none are buildable then we report those - | not (null targets) - = Left (TargetProblemNoneEnabled targetSelector targets') - - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) + -- If there is exactly one buildable library then we select that + | [target] <- targetsLibsBuildable = + Right [target] + -- but fail if there are multiple buildable libraries. + | not (null targetsLibsBuildable) = + Left (matchesMultipleProblem targetSelector targetsLibsBuildable') + -- If there is exactly one buildable executable then we select that + | [target] <- targetsExesBuildable = + Right [target] + -- but fail if there are multiple buildable executables. + | not (null targetsExesBuildable) = + Left (matchesMultipleProblem targetSelector targetsExesBuildable') + -- If there is exactly one other target then we select that + | [target] <- targetsBuildable = + Right [target] + -- but fail if there are multiple such targets + | not (null targetsBuildable) = + Left (matchesMultipleProblem targetSelector targetsBuildable') + -- If there are targets but none are buildable then we report those + | not (null targets) = + Left (TargetProblemNoneEnabled targetSelector targets') + -- If there are no targets at all then we report that + | otherwise = + Left (TargetProblemNoTargets targetSelector) where - targets' = forgetTargetsDetail targets - (targetsLibsBuildable, - targetsLibsBuildable') = selectBuildableTargets' - . filterTargetsKind LibKind - $ targets - (targetsExesBuildable, - targetsExesBuildable') = selectBuildableTargets' - . filterTargetsKind ExeKind - $ targets - (targetsBuildable, - targetsBuildable') = selectBuildableTargetsWith' - (isRequested targetSelector) targets + targets' = forgetTargetsDetail targets + ( targetsLibsBuildable + , targetsLibsBuildable' + ) = + selectBuildableTargets' + . filterTargetsKind LibKind + $ targets + ( targetsExesBuildable + , targetsExesBuildable' + ) = + selectBuildableTargets' + . filterTargetsKind ExeKind + $ targets + ( targetsBuildable + , targetsBuildable' + ) = + selectBuildableTargetsWith' + (isRequested targetSelector) + targets -- When there's a target filter like "pkg:tests" then we do select tests, -- but if it's just a target like "pkg" then we don't build tests unless -- they are requested by default (i.e. by using --enable-tests) - isRequested (TargetAllPackages Nothing) TargetNotRequestedByDefault = False - isRequested (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False + isRequested (TargetAllPackages Nothing) TargetNotRequestedByDefault = False + isRequested (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False isRequested _ _ = True - -- | For a 'TargetComponent' 'TargetSelector', check if the component can be -- selected. -- -- For the @repl@ command we just need the basic checks on being buildable etc. --- -selectComponentTarget :: SubComponentTarget - -> AvailableTarget k -> Either ReplTargetProblem k +selectComponentTarget + :: SubComponentTarget + -> AvailableTarget k + -> Either ReplTargetProblem k selectComponentTarget = selectComponentTargetBasic - data ReplProblem = TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] - - -- | Multiple 'TargetSelector's match multiple targets - | TargetProblemMultipleTargets TargetsMap + | -- | Multiple 'TargetSelector's match multiple targets + TargetProblemMultipleTargets TargetsMap deriving (Eq, Show) -- | The various error conditions that can occur when matching a -- 'TargetSelector' against 'AvailableTarget's for the @repl@ command. --- type ReplTargetProblem = TargetProblem ReplProblem matchesMultipleProblem @@ -496,55 +602,62 @@ multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets reportTargetProblems :: Verbosity -> [TargetProblem ReplProblem] -> IO a reportTargetProblems verbosity = - die' verbosity . unlines . map renderReplTargetProblem + die' verbosity . unlines . map renderReplTargetProblem renderReplTargetProblem :: TargetProblem ReplProblem -> String renderReplTargetProblem = renderTargetProblem "open a repl for" renderReplProblem renderReplProblem :: ReplProblem -> String renderReplProblem (TargetProblemMatchesMultiple targetSelector targets) = - "Cannot open a repl for multiple components at once. The target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ " which " - ++ (if targetSelectorRefersToPkgs targetSelector then "includes " else "are ") - ++ renderListSemiAnd - [ "the " ++ renderComponentKind Plural ckind ++ " " ++ - renderListCommaAnd + "Cannot open a repl for multiple components at once. The target '" + ++ showTargetSelector targetSelector + ++ "' refers to " + ++ renderTargetSelector targetSelector + ++ " which " + ++ (if targetSelectorRefersToPkgs targetSelector then "includes " else "are ") + ++ renderListSemiAnd + [ "the " + ++ renderComponentKind Plural ckind + ++ " " + ++ renderListCommaAnd [ maybe (prettyShow pkgname) prettyShow (componentNameString cname) | t <- ts - , let cname = availableTargetComponentName t + , let cname = availableTargetComponentName t pkgname = packageName (availableTargetPackageId t) ] | (ckind, ts) <- sortGroupOn availableTargetComponentKind targets ] - ++ ".\n\n" ++ explanationSingleComponentLimitation + ++ ".\n\n" + ++ explanationSingleComponentLimitation where - availableTargetComponentKind = componentKind - . availableTargetComponentName - + availableTargetComponentKind = + componentKind + . availableTargetComponentName renderReplProblem (TargetProblemMultipleTargets selectorMap) = - "Cannot open a repl for multiple components at once. The targets " - ++ renderListCommaAnd + "Cannot open a repl for multiple components at once. The targets " + ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'" - | ts <- uniqueTargetSelectors selectorMap ] - ++ " refer to different components." - ++ ".\n\n" ++ explanationSingleComponentLimitation + | ts <- uniqueTargetSelectors selectorMap + ] + ++ " refer to different components." + ++ ".\n\n" + ++ explanationSingleComponentLimitation explanationSingleComponentLimitation :: String explanationSingleComponentLimitation = - "The reason for this limitation is that current versions of ghci do not " - ++ "support loading multiple components as source. Load just one component " - ++ "and when you make changes to a dependent component then quit and reload." + "The reason for this limitation is that current versions of ghci do not " + ++ "support loading multiple components as source. Load just one component " + ++ "and when you make changes to a dependent component then quit and reload." -- Lenses lElaboratedShared :: Lens' ProjectBuildContext ElaboratedSharedConfig -lElaboratedShared f s = fmap (\x -> s { elaboratedShared = x }) (f (elaboratedShared s)) -{-# inline lElaboratedShared #-} +lElaboratedShared f s = fmap (\x -> s{elaboratedShared = x}) (f (elaboratedShared s)) +{-# INLINE lElaboratedShared #-} lPkgConfigReplOptions :: Lens' ElaboratedSharedConfig ReplOptions -lPkgConfigReplOptions f s = fmap (\x -> s { pkgConfigReplOptions = x }) (f (pkgConfigReplOptions s)) -{-# inline lPkgConfigReplOptions #-} +lPkgConfigReplOptions f s = fmap (\x -> s{pkgConfigReplOptions = x}) (f (pkgConfigReplOptions s)) +{-# INLINE lPkgConfigReplOptions #-} lReplOptionsFlags :: Lens' ReplOptions [String] -lReplOptionsFlags f s = fmap (\x -> s { replOptionsFlags = x }) (f (replOptionsFlags s)) -{-# inline lReplOptionsFlags #-} +lReplOptionsFlags f s = fmap (\x -> s{replOptionsFlags = x}) (f (replOptionsFlags s)) +{-# INLINE lReplOptionsFlags #-} diff --git a/cabal-install/src/Distribution/Client/CmdRun.hs b/cabal-install/src/Distribution/Client/CmdRun.hs index 664ffb30fca..a3134b32120 100644 --- a/cabal-install/src/Distribution/Client/CmdRun.hs +++ b/cabal-install/src/Distribution/Client/CmdRun.hs @@ -5,118 +5,172 @@ {-# LANGUAGE TupleSections #-} -- | cabal-install CLI command: run --- -module Distribution.Client.CmdRun ( - -- * The @run@ CLI and action - runCommand, - runAction, - handleShebang, validScript, +module Distribution.Client.CmdRun + ( -- * The @run@ CLI and action + runCommand + , runAction + , handleShebang + , validScript -- * Internals exposed for testing - matchesMultipleProblem, - noExesProblem, - selectPackageTargets, - selectComponentTarget + , matchesMultipleProblem + , noExesProblem + , selectPackageTargets + , selectComponentTarget ) where -import Prelude () import Distribution.Client.Compat.Prelude hiding (toList) +import Prelude () -import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages - ( renderTargetSelector, showTargetSelector, - renderTargetProblem, - renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs, - targetSelectorFilter, renderListCommaAnd, - renderListPretty ) + ( plural + , renderListCommaAnd + , renderListPretty + , renderTargetProblem + , renderTargetProblemNoTargets + , renderTargetSelector + , showTargetSelector + , targetSelectorFilter + , targetSelectorPluralPkgs + ) +import Distribution.Client.ProjectOrchestration import Distribution.Client.TargetProblem - ( TargetProblem (..) ) + ( TargetProblem (..) + ) -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) -import Distribution.Client.Setup - ( GlobalFlags(..), ConfigFlags(..) ) import Distribution.Client.GlobalFlags - ( defaultGlobalFlags ) -import Distribution.Simple.Flag - ( fromFlagOrDefault ) -import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) -import Distribution.Types.ComponentName - ( componentNameRaw ) -import Distribution.Verbosity - ( normal, silent ) -import Distribution.Simple.Utils - ( wrapText, die', info, notice, safeHead, warn ) + ( defaultGlobalFlags + ) +import Distribution.Client.InstallPlan + ( foldPlanPackage + , toList + ) +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..) + , defaultNixStyleFlags + , nixStyleOptions + ) import Distribution.Client.ProjectPlanning - ( ElaboratedConfiguredPackage(..) - , ElaboratedInstallPlan, binDirectoryFor ) + ( ElaboratedConfiguredPackage (..) + , ElaboratedInstallPlan + , binDirectoryFor + ) import Distribution.Client.ProjectPlanning.Types - ( dataDirsEnvironmentForPlan ) -import Distribution.Client.InstallPlan - ( toList, foldPlanPackage ) -import Distribution.Types.UnqualComponentName - ( UnqualComponentName, unUnqualComponentName ) -import Distribution.Simple.Program.Run - ( runProgramInvocation, ProgramInvocation(..), - emptyProgramInvocation ) -import Distribution.Types.UnitId - ( UnitId ) + ( dataDirsEnvironmentForPlan + ) import Distribution.Client.ScriptUtils - ( AcceptNoTargets(..), withContextAndSelectors, updateContextAndWriteProjectFile, TargetContext(..) ) + ( AcceptNoTargets (..) + , TargetContext (..) + , updateContextAndWriteProjectFile + , withContextAndSelectors + ) +import Distribution.Client.Setup + ( ConfigFlags (..) + , GlobalFlags (..) + ) import Distribution.Client.Utils - ( occursOnlyOrBefore, giveRTSWarning ) + ( giveRTSWarning + , occursOnlyOrBefore + ) +import Distribution.Simple.Command + ( CommandUI (..) + , usageAlternatives + ) +import Distribution.Simple.Flag + ( fromFlagOrDefault + ) +import Distribution.Simple.Program.Run + ( ProgramInvocation (..) + , emptyProgramInvocation + , runProgramInvocation + ) +import Distribution.Simple.Utils + ( die' + , info + , notice + , safeHead + , warn + , wrapText + ) +import Distribution.Types.ComponentName + ( componentNameRaw + ) +import Distribution.Types.UnitId + ( UnitId + ) +import Distribution.Types.UnqualComponentName + ( UnqualComponentName + , unUnqualComponentName + ) +import Distribution.Verbosity + ( normal + , silent + ) -import Data.List ( group ) +import Data.List (group) import qualified Data.Set as Set import GHC.Environment - ( getFullArgs ) + ( getFullArgs + ) import System.Directory - ( doesFileExist ) + ( doesFileExist + ) import System.FilePath - ( (), isValid, isPathSeparator ) + ( isPathSeparator + , isValid + , () + ) runCommand :: CommandUI (NixStyleFlags ()) -runCommand = CommandUI - { commandName = "v2-run" - , commandSynopsis = "Run an executable." - , commandUsage = usageAlternatives "v2-run" - [ "[TARGET] [FLAGS] [-- EXECUTABLE_FLAGS]" ] - , commandDescription = Just $ \pname -> wrapText $ - "Runs the specified executable-like component (an executable, a test, " - ++ "or a benchmark), first ensuring it is up to date.\n\n" - - ++ "Any executable-like component in any package in the project can be " - ++ "specified. A package can be specified if contains just one " - ++ "executable-like, preferring a single executable. The default is to " - ++ "use the package in the current directory if it contains just one " - ++ "executable-like.\n\n" - - ++ "Extra arguments can be passed to the program, but use '--' to " - ++ "separate arguments for the program from arguments for " ++ pname - ++ ". The executable is run in an environment where it can find its " - ++ "data files inplace in the build tree.\n\n" - - ++ "Dependencies are built or rebuilt as necessary. Additional " - ++ "configuration flags can be specified on the command line and these " - ++ "extend the project configuration from the 'cabal.project', " - ++ "'cabal.project.local' and other files." - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v2-run\n" - ++ " Run the executable-like in the package in the current directory\n" - ++ " " ++ pname ++ " v2-run foo-tool\n" - ++ " Run the named executable-like (in any package in the project)\n" - ++ " " ++ pname ++ " v2-run pkgfoo:foo-tool\n" - ++ " Run the executable-like 'foo-tool' in the package 'pkgfoo'\n" - ++ " " ++ pname ++ " v2-run foo -O2 -- dothing --fooflag\n" - ++ " Build with '-O2' and run the program, passing it extra arguments.\n" - - , commandDefaultFlags = defaultNixStyleFlags () - , commandOptions = nixStyleOptions (const []) - } +runCommand = + CommandUI + { commandName = "v2-run" + , commandSynopsis = "Run an executable." + , commandUsage = + usageAlternatives + "v2-run" + ["[TARGET] [FLAGS] [-- EXECUTABLE_FLAGS]"] + , commandDescription = Just $ \pname -> + wrapText $ + "Runs the specified executable-like component (an executable, a test, " + ++ "or a benchmark), first ensuring it is up to date.\n\n" + ++ "Any executable-like component in any package in the project can be " + ++ "specified. A package can be specified if contains just one " + ++ "executable-like, preferring a single executable. The default is to " + ++ "use the package in the current directory if it contains just one " + ++ "executable-like.\n\n" + ++ "Extra arguments can be passed to the program, but use '--' to " + ++ "separate arguments for the program from arguments for " + ++ pname + ++ ". The executable is run in an environment where it can find its " + ++ "data files inplace in the build tree.\n\n" + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files." + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " + ++ pname + ++ " v2-run\n" + ++ " Run the executable-like in the package in the current directory\n" + ++ " " + ++ pname + ++ " v2-run foo-tool\n" + ++ " Run the named executable-like (in any package in the project)\n" + ++ " " + ++ pname + ++ " v2-run pkgfoo:foo-tool\n" + ++ " Run the executable-like 'foo-tool' in the package 'pkgfoo'\n" + ++ " " + ++ pname + ++ " v2-run foo -O2 -- dothing --fooflag\n" + ++ " Build with '-O2' and run the program, passing it extra arguments.\n" + , commandDefaultFlags = defaultNixStyleFlags () + , commandOptions = nixStyleOptions (const []) + } -- | The @run@ command runs a specified executable-like component, building it -- first if necessary. The component can be either an executable, a test, @@ -125,64 +179,69 @@ runCommand = CommandUI -- -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" --- runAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -runAction flags@NixStyleFlags {..} targetAndArgs globalFlags - = withContextAndSelectors RejectNoTargets (Just ExeKind) flags targetStr globalFlags OtherCommand $ \targetCtx ctx targetSelectors -> do +runAction flags@NixStyleFlags{..} targetAndArgs globalFlags = + withContextAndSelectors RejectNoTargets (Just ExeKind) flags targetStr globalFlags OtherCommand $ \targetCtx ctx targetSelectors -> do (baseCtx, defaultVerbosity) <- case targetCtx of - ProjectContext -> return (ctx, normal) - GlobalContext -> return (ctx, normal) - ScriptContext path exemeta -> (, silent) <$> updateContextAndWriteProjectFile ctx path exemeta + ProjectContext -> return (ctx, normal) + GlobalContext -> return (ctx, normal) + ScriptContext path exemeta -> (,silent) <$> updateContextAndWriteProjectFile ctx path exemeta let verbosity = fromFlagOrDefault defaultVerbosity (configVerbosity configFlags) buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - - when (buildSettingOnlyDeps (buildSettings baseCtx)) $ - die' verbosity $ - "The run command does not support '--only-dependencies'. " - ++ "You may wish to use 'build --only-dependencies' and then " - ++ "use 'run'." - - fullArgs <- getFullArgs - when (occursOnlyOrBefore fullArgs "+RTS" "--") $ - warn verbosity $ giveRTSWarning "run" - - -- Interpret the targets on the command line as build targets - -- (as opposed to say repl or haddock targets). - targets <- either (reportTargetProblems verbosity) return - $ resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors - - -- Reject multiple targets, or at least targets in different - -- components. It is ok to have two module/file targets in the - -- same component, but not two that live in different components. - -- - -- Note that we discard the target and return the whole 'TargetsMap', - -- so this check will be repeated (and must succeed) after - -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this. - _ <- singleExeOrElse - (reportTargetProblems - verbosity - [multipleTargetsProblem targets]) - targets - - let elaboratedPlan' = pruneInstallPlanToTargets - TargetActionBuild - targets - elaboratedPlan - return (elaboratedPlan', targets) + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + die' verbosity $ + "The run command does not support '--only-dependencies'. " + ++ "You may wish to use 'build --only-dependencies' and then " + ++ "use 'run'." + + fullArgs <- getFullArgs + when (occursOnlyOrBefore fullArgs "+RTS" "--") $ + warn verbosity $ + giveRTSWarning "run" + + -- Interpret the targets on the command line as build targets + -- (as opposed to say repl or haddock targets). + targets <- + either (reportTargetProblems verbosity) return $ + resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + -- Reject multiple targets, or at least targets in different + -- components. It is ok to have two module/file targets in the + -- same component, but not two that live in different components. + -- + -- Note that we discard the target and return the whole 'TargetsMap', + -- so this check will be repeated (and must succeed) after + -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this. + _ <- + singleExeOrElse + ( reportTargetProblems + verbosity + [multipleTargetsProblem targets] + ) + targets + + let elaboratedPlan' = + pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan + return (elaboratedPlan', targets) (selectedUnitId, selectedComponent) <- -- Slight duplication with 'runProjectPreBuildPhase'. singleExeOrElse - (die' verbosity $ "No or multiple targets given, but the run " - ++ "phase has been reached. This is a bug.") + ( die' verbosity $ + "No or multiple targets given, but the run " + ++ "phase has been reached. This is a bug." + ) $ targetsMap buildCtx printPlan verbosity baseCtx buildCtx @@ -190,7 +249,6 @@ runAction flags@NixStyleFlags {..} targetAndArgs globalFlags buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes - let elaboratedPlan = elaboratedPlanToExecute buildCtx matchingElaboratedConfiguredPackages = matchingPackagesByUnitId @@ -212,40 +270,49 @@ runAction flags@NixStyleFlags {..} targetAndArgs globalFlags -- an error in all of these cases, even if some seem like they -- shouldn't happen. pkg <- case matchingElaboratedConfiguredPackages of - [] -> die' verbosity $ "Unknown executable " - ++ exeName - ++ " in package " - ++ prettyShow selectedUnitId + [] -> + die' verbosity $ + "Unknown executable " + ++ exeName + ++ " in package " + ++ prettyShow selectedUnitId [elabPkg] -> do - info verbosity $ "Selecting " - ++ prettyShow selectedUnitId - ++ " to supply " ++ exeName + info verbosity $ + "Selecting " + ++ prettyShow selectedUnitId + ++ " to supply " + ++ exeName return elabPkg - elabPkgs -> die' verbosity - $ "Multiple matching executables found matching " - ++ exeName - ++ ":\n" - ++ unlines (fmap (\p -> " - in package " ++ prettyShow (elabUnitId p)) elabPkgs) - let exePath = binDirectoryFor (distDirLayout baseCtx) - (elaboratedShared buildCtx) - pkg - exeName - exeName - let dryRun = buildSettingDryRun (buildSettings baseCtx) - || buildSettingOnlyDownload (buildSettings baseCtx) + elabPkgs -> + die' verbosity $ + "Multiple matching executables found matching " + ++ exeName + ++ ":\n" + ++ unlines (fmap (\p -> " - in package " ++ prettyShow (elabUnitId p)) elabPkgs) + let exePath = + binDirectoryFor + (distDirLayout baseCtx) + (elaboratedShared buildCtx) + pkg + exeName + exeName + let dryRun = + buildSettingDryRun (buildSettings baseCtx) + || buildSettingOnlyDownload (buildSettings baseCtx) if dryRun - then notice verbosity "Running of executable suppressed by flag(s)" - else - runProgramInvocation - verbosity - emptyProgramInvocation { - progInvokePath = exePath, - progInvokeArgs = args, - progInvokeEnv = dataDirsEnvironmentForPlan - (distDirLayout baseCtx) - elaboratedPlan - } + then notice verbosity "Running of executable suppressed by flag(s)" + else + runProgramInvocation + verbosity + emptyProgramInvocation + { progInvokePath = exePath + , progInvokeArgs = args + , progInvokeEnv = + dataDirsEnvironmentForPlan + (distDirLayout baseCtx) + elaboratedPlan + } where (targetStr, args) = splitAt 1 targetAndArgs @@ -273,30 +340,35 @@ validScript script -- argument is a list of arguments to be passed to the script. handleShebang :: FilePath -> [String] -> IO () handleShebang script args = - runAction (commandDefaultFlags runCommand) (script:args) defaultGlobalFlags + runAction (commandDefaultFlags runCommand) (script : args) defaultGlobalFlags singleExeOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName) singleExeOrElse action targetsMap = - case Set.toList . distinctTargetComponents $ targetsMap - of [(unitId, CExeName component)] -> return (unitId, component) - [(unitId, CTestName component)] -> return (unitId, component) - [(unitId, CBenchName component)] -> return (unitId, component) - _ -> action + case Set.toList . distinctTargetComponents $ targetsMap of + [(unitId, CExeName component)] -> return (unitId, component) + [(unitId, CTestName component)] -> return (unitId, component) + [(unitId, CBenchName component)] -> return (unitId, component) + _ -> action -- | Filter the 'ElaboratedInstallPlan' keeping only the -- 'ElaboratedConfiguredPackage's that match the specified -- 'UnitId'. -matchingPackagesByUnitId :: UnitId - -> ElaboratedInstallPlan - -> [ElaboratedConfiguredPackage] +matchingPackagesByUnitId + :: UnitId + -> ElaboratedInstallPlan + -> [ElaboratedConfiguredPackage] matchingPackagesByUnitId uid = - catMaybes - . fmap (foldPlanPackage - (const Nothing) - (\x -> if elabUnitId x == uid - then Just x - else Nothing)) - . toList + catMaybes + . fmap + ( foldPlanPackage + (const Nothing) + ( \x -> + if elabUnitId x == uid + then Just x + else Nothing + ) + ) + . toList -- | This defines what a 'TargetSelector' means for the @run@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, @@ -304,49 +376,45 @@ matchingPackagesByUnitId uid = -- -- For the @run@ command we select the exe if there is only one and it's -- buildable. Fail if there are no or multiple buildable exe components. --- -selectPackageTargets :: TargetSelector - -> [AvailableTarget k] -> Either RunTargetProblem [k] +selectPackageTargets + :: TargetSelector + -> [AvailableTarget k] + -> Either RunTargetProblem [k] selectPackageTargets targetSelector targets - -- If there is a single executable component, select that. See #7403 - | [target] <- targetsExesBuildable - = Right [target] - + | [target] <- targetsExesBuildable = + Right [target] -- Otherwise, if there is a single executable-like component left, select that. - | [target] <- targetsExeLikesBuildable - = Right [target] - + | [target] <- targetsExeLikesBuildable = + Right [target] -- but fail if there are multiple buildable executables. - | not (null targetsExeLikesBuildable) - = Left (matchesMultipleProblem targetSelector targetsExeLikesBuildable') - - -- If there are executables but none are buildable then we report those - | not (null targetsExeLikes') - = Left (TargetProblemNoneEnabled targetSelector targetsExeLikes') - - -- If there are no executables but some other targets then we report that - | not (null targets) - = Left (noExesProblem targetSelector) - - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) + | not (null targetsExeLikesBuildable) = + Left (matchesMultipleProblem targetSelector targetsExeLikesBuildable') + -- If there are executables but none are buildable then we report those + | not (null targetsExeLikes') = + Left (TargetProblemNoneEnabled targetSelector targetsExeLikes') + -- If there are no executables but some other targets then we report that + | not (null targets) = + Left (noExesProblem targetSelector) + -- If there are no targets at all then we report that + | otherwise = + Left (TargetProblemNoTargets targetSelector) where -- Targets that are precisely executables targetsExes = filterTargetsKind ExeKind targets targetsExesBuildable = selectBuildableTargets targetsExes -- Any target that could be executed - targetsExeLikes = targetsExes - ++ filterTargetsKind TestKind targets - ++ filterTargetsKind BenchKind targets - - (targetsExeLikesBuildable, - targetsExeLikesBuildable') = selectBuildableTargets' targetsExeLikes + targetsExeLikes = + targetsExes + ++ filterTargetsKind TestKind targets + ++ filterTargetsKind BenchKind targets - targetsExeLikes' = forgetTargetsDetail targetsExeLikes + ( targetsExeLikesBuildable + , targetsExeLikesBuildable' + ) = selectBuildableTargets' targetsExeLikes + targetsExeLikes' = forgetTargetsDetail targetsExeLikes -- | For a 'TargetComponent' 'TargetSelector', check if the component can be -- selected. @@ -354,42 +422,41 @@ selectPackageTargets targetSelector targets -- For the @run@ command we just need to check it is a executable-like -- (an executable, a test, or a benchmark), in addition -- to the basic checks on being buildable etc. --- -selectComponentTarget :: SubComponentTarget - -> AvailableTarget k -> Either RunTargetProblem k -selectComponentTarget subtarget@WholeComponent t - = case availableTargetComponentName t - of CExeName _ -> component - CTestName _ -> component - CBenchName _ -> component - _ -> Left (componentNotExeProblem pkgid cname) - where pkgid = availableTargetPackageId t - cname = availableTargetComponentName t - component = selectComponentTargetBasic subtarget t - -selectComponentTarget subtarget t - = Left (isSubComponentProblem (availableTargetPackageId t) - (availableTargetComponentName t) - subtarget) +selectComponentTarget + :: SubComponentTarget + -> AvailableTarget k + -> Either RunTargetProblem k +selectComponentTarget subtarget@WholeComponent t = + case availableTargetComponentName t of + CExeName _ -> component + CTestName _ -> component + CBenchName _ -> component + _ -> Left (componentNotExeProblem pkgid cname) + where + pkgid = availableTargetPackageId t + cname = availableTargetComponentName t + component = selectComponentTargetBasic subtarget t +selectComponentTarget subtarget t = + Left + ( isSubComponentProblem + (availableTargetPackageId t) + (availableTargetComponentName t) + subtarget + ) -- | The various error conditions that can occur when matching a -- 'TargetSelector' against 'AvailableTarget's for the @run@ command. --- -data RunProblem = - -- | The 'TargetSelector' matches targets but no executables - TargetProblemNoExes TargetSelector - - -- | A single 'TargetSelector' matches multiple targets - | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] - - -- | Multiple 'TargetSelector's match multiple targets - | TargetProblemMultipleTargets TargetsMap - - -- | The 'TargetSelector' refers to a component that is not an executable - | TargetProblemComponentNotExe PackageId ComponentName - - -- | Asking to run an individual file or module is not supported - | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget +data RunProblem + = -- | The 'TargetSelector' matches targets but no executables + TargetProblemNoExes TargetSelector + | -- | A single 'TargetSelector' matches multiple targets + TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] + | -- | Multiple 'TargetSelector's match multiple targets + TargetProblemMultipleTargets TargetsMap + | -- | The 'TargetSelector' refers to a component that is not an executable + TargetProblemComponentNotExe PackageId ComponentName + | -- | Asking to run an individual file or module is not supported + TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget deriving (Eq, Show) type RunTargetProblem = TargetProblem RunProblem @@ -398,14 +465,16 @@ noExesProblem :: TargetSelector -> RunTargetProblem noExesProblem = CustomTargetProblem . TargetProblemNoExes matchesMultipleProblem :: TargetSelector -> [AvailableTarget ()] -> RunTargetProblem -matchesMultipleProblem selector targets = CustomTargetProblem $ +matchesMultipleProblem selector targets = + CustomTargetProblem $ TargetProblemMatchesMultiple selector targets multipleTargetsProblem :: TargetsMap -> TargetProblem RunProblem multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets componentNotExeProblem :: PackageId -> ComponentName -> TargetProblem RunProblem -componentNotExeProblem pkgid name = CustomTargetProblem $ +componentNotExeProblem pkgid name = + CustomTargetProblem $ TargetProblemComponentNotExe pkgid name isSubComponentProblem @@ -413,62 +482,77 @@ isSubComponentProblem -> ComponentName -> SubComponentTarget -> TargetProblem RunProblem -isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $ +isSubComponentProblem pkgid name subcomponent = + CustomTargetProblem $ TargetProblemIsSubComponent pkgid name subcomponent reportTargetProblems :: Verbosity -> [RunTargetProblem] -> IO a reportTargetProblems verbosity = - die' verbosity . unlines . map renderRunTargetProblem + die' verbosity . unlines . map renderRunTargetProblem renderRunTargetProblem :: RunTargetProblem -> String renderRunTargetProblem (TargetProblemNoTargets targetSelector) = - case targetSelectorFilter targetSelector of - Just kind | kind /= ExeKind - -> "The run command is for running executables, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ "." - - _ -> renderTargetProblemNoTargets "run" targetSelector + case targetSelectorFilter targetSelector of + Just kind + | kind /= ExeKind -> + "The run command is for running executables, but the target '" + ++ showTargetSelector targetSelector + ++ "' refers to " + ++ renderTargetSelector targetSelector + ++ "." + _ -> renderTargetProblemNoTargets "run" targetSelector renderRunTargetProblem problem = - renderTargetProblem "run" renderRunProblem problem + renderTargetProblem "run" renderRunProblem problem renderRunProblem :: RunProblem -> String renderRunProblem (TargetProblemMatchesMultiple targetSelector targets) = - "The run command is for running a single executable at once. The target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ " which includes \n" - ++ unlines ((\(label, xs) -> "- " ++ label ++ ": " ++ renderListPretty xs) - <$> (zip ["executables", "test-suites", "benchmarks"] - $ filter (not . null) . map removeDuplicates - $ map (componentNameRaw . availableTargetComponentName) - <$> (flip filterTargetsKind $ targets) <$> [ExeKind, TestKind, BenchKind] )) - where removeDuplicates = catMaybes . map safeHead . group . sort - + "The run command is for running a single executable at once. The target '" + ++ showTargetSelector targetSelector + ++ "' refers to " + ++ renderTargetSelector targetSelector + ++ " which includes \n" + ++ unlines + ( (\(label, xs) -> "- " ++ label ++ ": " ++ renderListPretty xs) + <$> ( zip ["executables", "test-suites", "benchmarks"] $ + filter (not . null) . map removeDuplicates $ + map (componentNameRaw . availableTargetComponentName) + <$> (flip filterTargetsKind $ targets) + <$> [ExeKind, TestKind, BenchKind] + ) + ) + where + removeDuplicates = catMaybes . map safeHead . group . sort renderRunProblem (TargetProblemMultipleTargets selectorMap) = - "The run command is for running a single executable at once. The targets " - ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'" - | ts <- uniqueTargetSelectors selectorMap ] - ++ " refer to different executables." - + "The run command is for running a single executable at once. The targets " + ++ renderListCommaAnd + [ "'" ++ showTargetSelector ts ++ "'" + | ts <- uniqueTargetSelectors selectorMap + ] + ++ " refer to different executables." renderRunProblem (TargetProblemComponentNotExe pkgid cname) = - "The run command is for running executables, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ " from the package " - ++ prettyShow pkgid ++ "." + "The run command is for running executables, but the target '" + ++ showTargetSelector targetSelector + ++ "' refers to " + ++ renderTargetSelector targetSelector + ++ " from the package " + ++ prettyShow pkgid + ++ "." where targetSelector = TargetComponent pkgid cname WholeComponent - renderRunProblem (TargetProblemIsSubComponent pkgid cname subtarget) = - "The run command can only run an executable as a whole, " - ++ "not files or modules within them, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ "." + "The run command can only run an executable as a whole, " + ++ "not files or modules within them, but the target '" + ++ showTargetSelector targetSelector + ++ "' refers to " + ++ renderTargetSelector targetSelector + ++ "." where targetSelector = TargetComponent pkgid cname subtarget - renderRunProblem (TargetProblemNoExes targetSelector) = - "Cannot run the target '" ++ showTargetSelector targetSelector - ++ "' which refers to " ++ renderTargetSelector targetSelector - ++ " because " - ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" - ++ " not contain any executables." + "Cannot run the target '" + ++ showTargetSelector targetSelector + ++ "' which refers to " + ++ renderTargetSelector targetSelector + ++ " because " + ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" + ++ " not contain any executables." diff --git a/cabal-install/src/Distribution/Client/CmdSdist.hs b/cabal-install/src/Distribution/Client/CmdSdist.hs index 605403b0a3a..cd5946641ca 100644 --- a/cabal-install/src/Distribution/Client/CmdSdist.hs +++ b/cabal-install/src/Distribution/Client/CmdSdist.hs @@ -1,93 +1,161 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + module Distribution.Client.CmdSdist - ( sdistCommand, sdistAction, packageToSdist - , OutputFormat(..)) where + ( sdistCommand + , sdistAction + , packageToSdist + , OutputFormat (..) + ) where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () import Distribution.Client.CmdErrorMessages - ( Plural(..), renderComponentKind ) -import Distribution.Client.ProjectOrchestration - ( ProjectBaseContext(..), CurrentCommand(..), establishProjectBaseContext, establishProjectBaseContextWithRoot) -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), defaultNixStyleFlags ) -import Distribution.Client.TargetSelector - ( TargetSelector(..), ComponentKind - , readTargetSelectors, reportTargetSelectorProblems ) -import Distribution.Client.Setup - ( GlobalFlags(..) ) -import Distribution.Solver.Types.SourcePackage - ( SourcePackage(..) ) -import Distribution.Client.Types - ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage ) + ( Plural (..) + , renderComponentKind + ) import Distribution.Client.DistDirLayout - ( DistDirLayout(..), ProjectRoot (..) ) + ( DistDirLayout (..) + , ProjectRoot (..) + ) +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..) + , defaultNixStyleFlags + ) import Distribution.Client.ProjectConfig - ( ProjectConfig, withProjectOrGlobalConfig, commandLineFlagsToProjectConfig, projectConfigConfigFile, projectConfigShared ) + ( ProjectConfig + , commandLineFlagsToProjectConfig + , projectConfigConfigFile + , projectConfigShared + , withProjectOrGlobalConfig + ) import Distribution.Client.ProjectFlags - ( ProjectFlags (..), defaultProjectFlags, projectFlagsOptions ) + ( ProjectFlags (..) + , defaultProjectFlags + , projectFlagsOptions + ) +import Distribution.Client.ProjectOrchestration + ( CurrentCommand (..) + , ProjectBaseContext (..) + , establishProjectBaseContext + , establishProjectBaseContextWithRoot + ) +import Distribution.Client.Setup + ( GlobalFlags (..) + ) +import Distribution.Client.TargetSelector + ( ComponentKind + , TargetSelector (..) + , readTargetSelectors + , reportTargetSelectorProblems + ) +import Distribution.Client.Types + ( PackageLocation (..) + , PackageSpecifier (..) + , UnresolvedSourcePackage + ) +import Distribution.Solver.Types.SourcePackage + ( SourcePackage (..) + ) +import Distribution.Client.SrcDist + ( packageDirToSdist + ) import Distribution.Compat.Lens - ( _1, _2 ) + ( _1 + , _2 + ) import Distribution.Package - ( Package(packageId) ) + ( Package (packageId) + ) import Distribution.PackageDescription.Configuration - ( flattenPackageDescription ) + ( flattenPackageDescription + ) import Distribution.ReadE - ( succeedReadE ) + ( succeedReadE + ) import Distribution.Simple.Command - ( CommandUI(..), OptionField, option, reqArg, liftOptionL, ShowOrParseArgs ) + ( CommandUI (..) + , OptionField + , ShowOrParseArgs + , liftOptionL + , option + , reqArg + ) import Distribution.Simple.PreProcess - ( knownSuffixHandlers ) + ( knownSuffixHandlers + ) import Distribution.Simple.Setup - ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe - , optionVerbosity, optionDistPref, trueArg, configVerbosity, configDistPref - ) + ( Flag (..) + , configDistPref + , configVerbosity + , flagToList + , flagToMaybe + , fromFlagOrDefault + , optionDistPref + , optionVerbosity + , toFlag + , trueArg + ) import Distribution.Simple.SrcDist - ( listPackageSourcesWithDie ) -import Distribution.Client.SrcDist - ( packageDirToSdist ) + ( listPackageSourcesWithDie + ) import Distribution.Simple.Utils - ( die', notice, withOutputMarker, wrapText ) + ( die' + , notice + , withOutputMarker + , wrapText + ) import Distribution.Types.ComponentName - ( ComponentName, showComponentName ) + ( ComponentName + , showComponentName + ) +import Distribution.Types.GenericPackageDescription (GenericPackageDescription) import Distribution.Types.PackageName - ( PackageName, unPackageName ) + ( PackageName + , unPackageName + ) import Distribution.Verbosity - ( normal ) -import Distribution.Types.GenericPackageDescription (GenericPackageDescription) + ( normal + ) import qualified Data.ByteString.Lazy.Char8 as BSL import System.Directory - ( getCurrentDirectory - , createDirectoryIfMissing, makeAbsolute - ) + ( createDirectoryIfMissing + , getCurrentDirectory + , makeAbsolute + ) import System.FilePath - ( (), (<.>), makeRelative, normalise ) + ( makeRelative + , normalise + , (<.>) + , () + ) ------------------------------------------------------------------------------- -- Command ------------------------------------------------------------------------------- sdistCommand :: CommandUI (ProjectFlags, SdistFlags) -sdistCommand = CommandUI +sdistCommand = + CommandUI { commandName = "v2-sdist" , commandSynopsis = "Generate a source distribution file (.tar.gz)." , commandUsage = \pname -> "Usage: " ++ pname ++ " v2-sdist [FLAGS] [PACKAGES]\n" - , commandDescription = Just $ \_ -> wrapText - "Generates tarballs of project packages suitable for upload to Hackage." + , commandDescription = Just $ \_ -> + wrapText + "Generates tarballs of project packages suitable for upload to Hackage." , commandNotes = Nothing , commandDefaultFlags = (defaultProjectFlags, defaultSdistFlags) , commandOptions = \showOrParseArgs -> - map (liftOptionL _1) (projectFlagsOptions showOrParseArgs) ++ - map (liftOptionL _2) (sdistOptions showOrParseArgs) + map (liftOptionL _1) (projectFlagsOptions showOrParseArgs) + ++ map (liftOptionL _2) (sdistOptions showOrParseArgs) } ------------------------------------------------------------------------------- @@ -95,42 +163,54 @@ sdistCommand = CommandUI ------------------------------------------------------------------------------- data SdistFlags = SdistFlags - { sdistVerbosity :: Flag Verbosity - , sdistDistDir :: Flag FilePath - , sdistListSources :: Flag Bool - , sdistNulSeparated :: Flag Bool - , sdistOutputPath :: Flag FilePath - } + { sdistVerbosity :: Flag Verbosity + , sdistDistDir :: Flag FilePath + , sdistListSources :: Flag Bool + , sdistNulSeparated :: Flag Bool + , sdistOutputPath :: Flag FilePath + } defaultSdistFlags :: SdistFlags -defaultSdistFlags = SdistFlags - { sdistVerbosity = toFlag normal - , sdistDistDir = mempty - , sdistListSources = toFlag False - , sdistNulSeparated = toFlag False - , sdistOutputPath = mempty +defaultSdistFlags = + SdistFlags + { sdistVerbosity = toFlag normal + , sdistDistDir = mempty + , sdistListSources = toFlag False + , sdistNulSeparated = toFlag False + , sdistOutputPath = mempty } sdistOptions :: ShowOrParseArgs -> [OptionField SdistFlags] sdistOptions showOrParseArgs = - [ optionVerbosity - sdistVerbosity (\v flags -> flags { sdistVerbosity = v }) - , optionDistPref - sdistDistDir (\dd flags -> flags { sdistDistDir = dd }) - showOrParseArgs - , option ['l'] ["list-only"] - "Just list the sources, do not make a tarball" - sdistListSources (\v flags -> flags { sdistListSources = v }) - trueArg - , option [] ["null-sep"] - "Separate the source files with NUL bytes rather than newlines." - sdistNulSeparated (\v flags -> flags { sdistNulSeparated = v }) - trueArg - , option ['o'] ["output-directory", "outputdir"] - "Choose the output directory of this command. '-' sends all output to stdout" - sdistOutputPath (\o flags -> flags { sdistOutputPath = o }) - (reqArg "PATH" (succeedReadE Flag) flagToList) - ] + [ optionVerbosity + sdistVerbosity + (\v flags -> flags{sdistVerbosity = v}) + , optionDistPref + sdistDistDir + (\dd flags -> flags{sdistDistDir = dd}) + showOrParseArgs + , option + ['l'] + ["list-only"] + "Just list the sources, do not make a tarball" + sdistListSources + (\v flags -> flags{sdistListSources = v}) + trueArg + , option + [] + ["null-sep"] + "Separate the source files with NUL bytes rather than newlines." + sdistNulSeparated + (\v flags -> flags{sdistNulSeparated = v}) + trueArg + , option + ['o'] + ["output-directory", "outputdir"] + "Choose the output directory of this command. '-' sends all output to stdout" + sdistOutputPath + (\o flags -> flags{sdistOutputPath = o}) + (reqArg "PATH" (succeedReadE Flag) flagToList) + ] ------------------------------------------------------------------------------- -- Action @@ -138,64 +218,69 @@ sdistOptions showOrParseArgs = sdistAction :: (ProjectFlags, SdistFlags) -> [String] -> GlobalFlags -> IO () sdistAction (pf@ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do - (baseCtx, distDirLayout) <- withProjectOrGlobalConfig verbosity flagIgnoreProject globalConfigFlag withProject withoutProject - - let localPkgs = localPackages baseCtx - - targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors localPkgs Nothing targetStrings - - -- elaborate path, create target directory - mOutputPath' <- case mOutputPath of - Just "-" -> return (Just "-") - Just path -> do - abspath <- makeAbsolute path - createDirectoryIfMissing True abspath - return (Just abspath) - Nothing -> do - createDirectoryIfMissing True (distSdistDirectory distDirLayout) - return Nothing - - let format :: OutputFormat - format = - if | listSources, nulSeparated -> SourceList '\0' - | listSources -> SourceList '\n' - | otherwise -> TarGzArchive - - ext = case format of - SourceList _ -> "list" - TarGzArchive -> "tar.gz" - - outputPath pkg = case mOutputPath' of - Just path - | path == "-" -> "-" - | otherwise -> path prettyShow (packageId pkg) <.> ext - Nothing - | listSources -> "-" - | otherwise -> distSdistFile distDirLayout (packageId pkg) - - - case reifyTargetSelectors localPkgs targetSelectors of - Left errs -> die' verbosity . unlines . fmap renderTargetProblem $ errs - Right pkgs - | length pkgs > 1, not listSources, Just "-" <- mOutputPath' -> - die' verbosity "Can't write multiple tarballs to standard output!" - | otherwise -> - traverse_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distDirLayout) format (outputPath pkg) pkg) pkgs + (baseCtx, distDirLayout) <- withProjectOrGlobalConfig verbosity flagIgnoreProject globalConfigFlag withProject withoutProject + + let localPkgs = localPackages baseCtx + + targetSelectors <- + either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors localPkgs Nothing targetStrings + + -- elaborate path, create target directory + mOutputPath' <- case mOutputPath of + Just "-" -> return (Just "-") + Just path -> do + abspath <- makeAbsolute path + createDirectoryIfMissing True abspath + return (Just abspath) + Nothing -> do + createDirectoryIfMissing True (distSdistDirectory distDirLayout) + return Nothing + + let format :: OutputFormat + format = + if + | listSources, nulSeparated -> SourceList '\0' + | listSources -> SourceList '\n' + | otherwise -> TarGzArchive + + ext = case format of + SourceList _ -> "list" + TarGzArchive -> "tar.gz" + + outputPath pkg = case mOutputPath' of + Just path + | path == "-" -> "-" + | otherwise -> path prettyShow (packageId pkg) <.> ext + Nothing + | listSources -> "-" + | otherwise -> distSdistFile distDirLayout (packageId pkg) + + case reifyTargetSelectors localPkgs targetSelectors of + Left errs -> die' verbosity . unlines . fmap renderTargetProblem $ errs + Right pkgs + | length pkgs > 1 + , not listSources + , Just "-" <- mOutputPath' -> + die' verbosity "Can't write multiple tarballs to standard output!" + | otherwise -> + traverse_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distDirLayout) format (outputPath pkg) pkg) pkgs where - verbosity = fromFlagOrDefault normal sdistVerbosity - listSources = fromFlagOrDefault False sdistListSources - nulSeparated = fromFlagOrDefault False sdistNulSeparated - mOutputPath = flagToMaybe sdistOutputPath + verbosity = fromFlagOrDefault normal sdistVerbosity + listSources = fromFlagOrDefault False sdistListSources + nulSeparated = fromFlagOrDefault False sdistNulSeparated + mOutputPath = flagToMaybe sdistOutputPath prjConfig :: ProjectConfig - prjConfig = commandLineFlagsToProjectConfig + prjConfig = + commandLineFlagsToProjectConfig globalFlags (defaultNixStyleFlags ()) - { configFlags = (configFlags $ defaultNixStyleFlags ()) - { configVerbosity = sdistVerbosity - , configDistPref = sdistDistDir - } + { configFlags = + (configFlags $ defaultNixStyleFlags ()) + { configVerbosity = sdistVerbosity + , configDistPref = sdistDistDir + } , projectFlags = pf } mempty @@ -204,113 +289,117 @@ sdistAction (pf@ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do withProject :: IO (ProjectBaseContext, DistDirLayout) withProject = do - baseCtx <- establishProjectBaseContext verbosity prjConfig OtherCommand - return (baseCtx, distDirLayout baseCtx) + baseCtx <- establishProjectBaseContext verbosity prjConfig OtherCommand + return (baseCtx, distDirLayout baseCtx) withoutProject :: ProjectConfig -> IO (ProjectBaseContext, DistDirLayout) withoutProject config = do - cwd <- getCurrentDirectory - baseCtx <- establishProjectBaseContextWithRoot verbosity (config <> prjConfig) (ProjectRootImplicit cwd) OtherCommand - return (baseCtx, distDirLayout baseCtx) + cwd <- getCurrentDirectory + baseCtx <- establishProjectBaseContextWithRoot verbosity (config <> prjConfig) (ProjectRootImplicit cwd) OtherCommand + return (baseCtx, distDirLayout baseCtx) -data OutputFormat = SourceList Char - | TarGzArchive - deriving (Show, Eq) +data OutputFormat + = SourceList Char + | TarGzArchive + deriving (Show, Eq) packageToSdist :: Verbosity -> FilePath -> OutputFormat -> FilePath -> UnresolvedSourcePackage -> IO () packageToSdist verbosity projectRootDir format outputFile pkg = do - let death = die' verbosity ("The impossible happened: a local package isn't local" <> (show pkg)) - dir0 <- case srcpkgSource pkg of - LocalUnpackedPackage path -> pure (Right path) - RemoteSourceRepoPackage _ (Just tgz) -> pure (Left tgz) - RemoteSourceRepoPackage {} -> death - LocalTarballPackage tgz -> pure (Left tgz) - RemoteTarballPackage _ (Just tgz) -> pure (Left tgz) - RemoteTarballPackage {} -> death - RepoTarballPackage {} -> death - - let -- Write String to stdout or file, using the default TextEncoding. - write str - | outputFile == "-" = putStr (withOutputMarker verbosity str) - | otherwise = do - writeFile outputFile str - notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n" - -- Write raw ByteString to stdout or file as it is, without encoding. - writeLBS lbs - | outputFile == "-" = BSL.putStr lbs - | otherwise = do - BSL.writeFile outputFile lbs - notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n" - - case dir0 of - Left tgz -> do - case format of - TarGzArchive -> do - writeLBS =<< BSL.readFile tgz - _ -> die' verbosity ("cannot convert tarball package to " ++ show format) - - Right dir -> case format of - SourceList nulSep -> do - let gpd :: GenericPackageDescription - gpd = srcpkgDescription pkg - - let thisDie :: Verbosity -> String -> IO a - thisDie v s = die' v $ "sdist of " <> prettyShow (packageId gpd) ++ ": " ++ s - - files' <- listPackageSourcesWithDie verbosity thisDie dir (flattenPackageDescription gpd) knownSuffixHandlers - let files = nub $ sort $ map normalise files' - let prefix = makeRelative projectRootDir dir - write $ concat [prefix i ++ [nulSep] | i <- files] - + let death = die' verbosity ("The impossible happened: a local package isn't local" <> (show pkg)) + dir0 <- case srcpkgSource pkg of + LocalUnpackedPackage path -> pure (Right path) + RemoteSourceRepoPackage _ (Just tgz) -> pure (Left tgz) + RemoteSourceRepoPackage{} -> death + LocalTarballPackage tgz -> pure (Left tgz) + RemoteTarballPackage _ (Just tgz) -> pure (Left tgz) + RemoteTarballPackage{} -> death + RepoTarballPackage{} -> death + + let + -- Write String to stdout or file, using the default TextEncoding. + write str + | outputFile == "-" = putStr (withOutputMarker verbosity str) + | otherwise = do + writeFile outputFile str + notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n" + -- Write raw ByteString to stdout or file as it is, without encoding. + writeLBS lbs + | outputFile == "-" = BSL.putStr lbs + | otherwise = do + BSL.writeFile outputFile lbs + notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n" + + case dir0 of + Left tgz -> do + case format of TarGzArchive -> do - packageDirToSdist verbosity (srcpkgDescription pkg) dir >>= writeLBS + writeLBS =<< BSL.readFile tgz + _ -> die' verbosity ("cannot convert tarball package to " ++ show format) + Right dir -> case format of + SourceList nulSep -> do + let gpd :: GenericPackageDescription + gpd = srcpkgDescription pkg + + let thisDie :: Verbosity -> String -> IO a + thisDie v s = die' v $ "sdist of " <> prettyShow (packageId gpd) ++ ": " ++ s + + files' <- listPackageSourcesWithDie verbosity thisDie 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 -- reifyTargetSelectors :: [PackageSpecifier UnresolvedSourcePackage] -> [TargetSelector] -> Either [TargetProblem] [UnresolvedSourcePackage] reifyTargetSelectors pkgs sels = - case partitionEithers (foldMap go sels) of - ([], sels') -> Right sels' - (errs, _) -> Left errs - where - -- there can be pkgs which are in extra-packages: - -- these are not SpecificSourcePackage - -- - -- Why these packages are in localPkgs, it's confusing. - -- Anyhow, better to be lenient here. - -- - flatten (SpecificSourcePackage pkg@SourcePackage{}) = Just pkg - flatten _ = Nothing - - pkgs' = mapMaybe flatten pkgs - - getPkg pid = case find ((== pid) . packageId) pkgs' of - Just pkg -> Right pkg - Nothing -> error "The impossible happened: we have a reference to a local package that isn't in localPackages." - - go :: TargetSelector -> [Either TargetProblem UnresolvedSourcePackage] - go (TargetPackage _ pids Nothing) = fmap getPkg pids - go (TargetAllPackages Nothing) = Right <$> pkgs' - - go (TargetPackage _ _ (Just kind)) = [Left (AllComponentsOnly kind)] - go (TargetAllPackages (Just kind)) = [Left (AllComponentsOnly kind)] - - go (TargetPackageNamed pname _) = [Left (NonlocalPackageNotAllowed pname)] - go (TargetComponentUnknown pname _ _) = [Left (NonlocalPackageNotAllowed pname)] - - go (TargetComponent _ cname _) = [Left (ComponentsNotAllowed cname)] - -data TargetProblem = AllComponentsOnly ComponentKind - | NonlocalPackageNotAllowed PackageName - | ComponentsNotAllowed ComponentName + case partitionEithers (foldMap go sels) of + ([], sels') -> Right sels' + (errs, _) -> Left errs + where + -- there can be pkgs which are in extra-packages: + -- these are not SpecificSourcePackage + -- + -- Why these packages are in localPkgs, it's confusing. + -- Anyhow, better to be lenient here. + -- + flatten (SpecificSourcePackage pkg@SourcePackage{}) = Just pkg + flatten _ = Nothing + + pkgs' = mapMaybe flatten pkgs + + getPkg pid = case find ((== pid) . packageId) pkgs' of + Just pkg -> Right pkg + Nothing -> error "The impossible happened: we have a reference to a local package that isn't in localPackages." + + go :: TargetSelector -> [Either TargetProblem UnresolvedSourcePackage] + go (TargetPackage _ pids Nothing) = fmap getPkg pids + go (TargetAllPackages Nothing) = Right <$> pkgs' + go (TargetPackage _ _ (Just kind)) = [Left (AllComponentsOnly kind)] + go (TargetAllPackages (Just kind)) = [Left (AllComponentsOnly kind)] + go (TargetPackageNamed pname _) = [Left (NonlocalPackageNotAllowed pname)] + go (TargetComponentUnknown pname _ _) = [Left (NonlocalPackageNotAllowed pname)] + go (TargetComponent _ cname _) = [Left (ComponentsNotAllowed cname)] + +data TargetProblem + = AllComponentsOnly ComponentKind + | NonlocalPackageNotAllowed PackageName + | ComponentsNotAllowed ComponentName renderTargetProblem :: TargetProblem -> String renderTargetProblem (AllComponentsOnly kind) = - "It is not possible to package only the " ++ renderComponentKind Plural kind ++ " from a package " + "It is not possible to package only the " + ++ renderComponentKind Plural kind + ++ " from a package " ++ "for distribution. Only entire packages may be packaged for distribution." renderTargetProblem (ComponentsNotAllowed cname) = - "The component " ++ showComponentName cname ++ " cannot be packaged for distribution on its own. " + "The component " + ++ showComponentName cname + ++ " cannot be packaged for distribution on its own. " ++ "Only entire packages may be packaged for distribution." renderTargetProblem (NonlocalPackageNotAllowed pname) = - "The package " ++ unPackageName pname ++ " cannot be packaged for distribution, because it is not " + "The package " + ++ unPackageName pname + ++ " cannot be packaged for distribution, because it is not " ++ "local to this project." diff --git a/cabal-install/src/Distribution/Client/CmdTest.hs b/cabal-install/src/Distribution/Client/CmdTest.hs index dd5f0915eca..96a8fdc5cea 100644 --- a/cabal-install/src/Distribution/Client/CmdTest.hs +++ b/cabal-install/src/Distribution/Client/CmdTest.hs @@ -1,89 +1,115 @@ {-# LANGUAGE RecordWildCards #-} -- | cabal-install CLI command: test --- -module Distribution.Client.CmdTest ( - -- * The @test@ CLI and action - testCommand, - testAction, +module Distribution.Client.CmdTest + ( -- * The @test@ CLI and action + testCommand + , testAction -- * Internals exposed for testing - isSubComponentProblem, - notTestProblem, - noTestsProblem, - selectPackageTargets, - selectComponentTarget + , isSubComponentProblem + , notTestProblem + , noTestsProblem + , selectPackageTargets + , selectComponentTarget ) where import Distribution.Client.Compat.Prelude import Prelude () -import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages - ( renderTargetSelector, showTargetSelector, targetSelectorFilter, plural, - renderTargetProblem, - renderTargetProblemNoTargets, targetSelectorPluralPkgs ) -import Distribution.Client.TargetProblem - ( TargetProblem (..) ) + ( plural + , renderTargetProblem + , renderTargetProblemNoTargets + , renderTargetSelector + , showTargetSelector + , targetSelectorFilter + , targetSelectorPluralPkgs + ) import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) + ( NixStyleFlags (..) + , defaultNixStyleFlags + , nixStyleOptions + ) +import Distribution.Client.ProjectOrchestration import Distribution.Client.Setup - ( GlobalFlags(..), ConfigFlags(..) ) + ( ConfigFlags (..) + , GlobalFlags (..) + ) +import Distribution.Client.TargetProblem + ( TargetProblem (..) + ) import Distribution.Client.Utils - ( giveRTSWarning ) -import Distribution.Simple.Setup - ( TestFlags(..), fromFlagOrDefault ) + ( giveRTSWarning + ) import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) + ( CommandUI (..) + , usageAlternatives + ) import Distribution.Simple.Flag - ( Flag(..) ) -import Distribution.Verbosity - ( normal ) + ( Flag (..) + ) +import Distribution.Simple.Setup + ( TestFlags (..) + , fromFlagOrDefault + ) import Distribution.Simple.Utils - ( notice, wrapText, die', warn ) + ( die' + , notice + , warn + , wrapText + ) +import Distribution.Verbosity + ( normal + ) import qualified System.Exit (exitSuccess) import GHC.Environment - ( getFullArgs ) + ( getFullArgs + ) testCommand :: CommandUI (NixStyleFlags ()) -testCommand = CommandUI - { commandName = "v2-test" - , commandSynopsis = "Run test-suites." - , commandUsage = usageAlternatives "v2-test" [ "[TARGETS] [FLAGS]" ] - , commandDescription = Just $ \_ -> wrapText $ - "Runs the specified test-suites, first ensuring they are up to " - ++ "date.\n\n" - - ++ "Any test-suite in any package in the project can be specified. " - ++ "A package can be specified in which case all the test-suites in the " - ++ "package are run. The default is to run all the test-suites in the " - ++ "package in the current directory.\n\n" - - ++ "Dependencies are built or rebuilt as necessary. Additional " - ++ "configuration flags can be specified on the command line and these " - ++ "extend the project configuration from the 'cabal.project', " - ++ "'cabal.project.local' and other files.\n\n" - - ++ "To pass command-line arguments to a test suite, see the " - ++ "v2-run command." - , commandNotes = Just $ \pname -> +testCommand = + CommandUI + { commandName = "v2-test" + , commandSynopsis = "Run test-suites." + , commandUsage = usageAlternatives "v2-test" ["[TARGETS] [FLAGS]"] + , commandDescription = Just $ \_ -> + wrapText $ + "Runs the specified test-suites, first ensuring they are up to " + ++ "date.\n\n" + ++ "Any test-suite in any package in the project can be specified. " + ++ "A package can be specified in which case all the test-suites in the " + ++ "package are run. The default is to run all the test-suites in the " + ++ "package in the current directory.\n\n" + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files.\n\n" + ++ "To pass command-line arguments to a test suite, see the " + ++ "v2-run command." + , commandNotes = Just $ \pname -> "Examples:\n" - ++ " " ++ pname ++ " v2-test\n" - ++ " Run all the test-suites in the package in the current directory\n" - ++ " " ++ pname ++ " v2-test pkgname\n" - ++ " Run all the test-suites in the package named pkgname\n" - ++ " " ++ pname ++ " v2-test cname\n" - ++ " Run the test-suite named cname\n" - ++ " " ++ pname ++ " v2-test cname --enable-coverage\n" - ++ " Run the test-suite built with code coverage (including local libs used)\n" - - , commandDefaultFlags = defaultNixStyleFlags () - , commandOptions = nixStyleOptions (const []) - } - - + ++ " " + ++ pname + ++ " v2-test\n" + ++ " Run all the test-suites in the package in the current directory\n" + ++ " " + ++ pname + ++ " v2-test pkgname\n" + ++ " Run all the test-suites in the package named pkgname\n" + ++ " " + ++ pname + ++ " v2-test cname\n" + ++ " Run the test-suite named cname\n" + ++ " " + ++ pname + ++ " v2-test cname --enable-coverage\n" + ++ " Run the test-suite built with code coverage (including local libs used)\n" + , commandDefaultFlags = defaultNixStyleFlags () + , commandOptions = nixStyleOptions (const []) + } -- | The @test@ command is very much like @build@. It brings the install plan -- up to date, selects that part of the plan needed by the given or implicit @@ -94,48 +120,49 @@ testCommand = CommandUI -- -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" --- testAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -testAction flags@NixStyleFlags {..} targetStrings globalFlags = do - - baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand - - targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) (Just TestKind) targetStrings - - buildCtx <- - runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - - when (buildSettingOnlyDeps (buildSettings baseCtx)) $ - die' verbosity $ - "The test command does not support '--only-dependencies'. " - ++ "You may wish to use 'build --only-dependencies' and then " - ++ "use 'test'." - - fullArgs <- getFullArgs - when ("+RTS" `elem` fullArgs) $ - warn verbosity $ giveRTSWarning "test" - - -- Interpret the targets on the command line as test targets - -- (as opposed to say build or haddock targets). - targets <- either (reportTargetProblems verbosity failWhenNoTestSuites) return - $ resolveTargets - selectPackageTargets - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors - - let elaboratedPlan' = pruneInstallPlanToTargets - TargetActionTest - targets - elaboratedPlan - return (elaboratedPlan', targets) - - printPlan verbosity baseCtx buildCtx - - buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx - runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes +testAction flags@NixStyleFlags{..} targetStrings globalFlags = do + baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand + + targetSelectors <- + either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx) (Just TestKind) targetStrings + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + die' verbosity $ + "The test command does not support '--only-dependencies'. " + ++ "You may wish to use 'build --only-dependencies' and then " + ++ "use 'test'." + + fullArgs <- getFullArgs + when ("+RTS" `elem` fullArgs) $ + warn verbosity $ + giveRTSWarning "test" + + -- Interpret the targets on the command line as test targets + -- (as opposed to say build or haddock targets). + targets <- + either (reportTargetProblems verbosity failWhenNoTestSuites) return $ + resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + let elaboratedPlan' = + pruneInstallPlanToTargets + TargetActionTest + targets + elaboratedPlan + return (elaboratedPlan', targets) + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes where failWhenNoTestSuites = testFailWhenNoTestSuites testFlags verbosity = fromFlagOrDefault normal (configVerbosity configFlags) @@ -147,77 +174,74 @@ testAction flags@NixStyleFlags {..} targetStrings globalFlags = do -- -- For the @test@ command we select all buildable test-suites, -- or fail if there are no test-suites or no buildable test-suites. --- -selectPackageTargets :: TargetSelector - -> [AvailableTarget k] -> Either TestTargetProblem [k] +selectPackageTargets + :: TargetSelector + -> [AvailableTarget k] + -> Either TestTargetProblem [k] selectPackageTargets targetSelector targets - - -- If there are any buildable test-suite targets then we select those - | not (null targetsTestsBuildable) - = Right targetsTestsBuildable - - -- If there are test-suites but none are buildable then we report those - | not (null targetsTests) - = Left (TargetProblemNoneEnabled targetSelector targetsTests) - - -- If there are no test-suite but some other targets then we report that - | not (null targets) - = Left (noTestsProblem targetSelector) - - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) + -- If there are any buildable test-suite targets then we select those + | not (null targetsTestsBuildable) = + Right targetsTestsBuildable + -- If there are test-suites but none are buildable then we report those + | not (null targetsTests) = + Left (TargetProblemNoneEnabled targetSelector targetsTests) + -- If there are no test-suite but some other targets then we report that + | not (null targets) = + Left (noTestsProblem targetSelector) + -- If there are no targets at all then we report that + | otherwise = + Left (TargetProblemNoTargets targetSelector) where - targetsTestsBuildable = selectBuildableTargets - . filterTargetsKind TestKind - $ targets - - targetsTests = forgetTargetsDetail - . filterTargetsKind TestKind - $ targets + targetsTestsBuildable = + selectBuildableTargets + . filterTargetsKind TestKind + $ targets + targetsTests = + forgetTargetsDetail + . filterTargetsKind TestKind + $ targets -- | For a 'TargetComponent' 'TargetSelector', check if the component can be -- selected. -- -- For the @test@ command we just need to check it is a test-suite, in addition -- to the basic checks on being buildable etc. --- -selectComponentTarget :: SubComponentTarget - -> AvailableTarget k -> Either TestTargetProblem k +selectComponentTarget + :: SubComponentTarget + -> AvailableTarget k + -> Either TestTargetProblem k selectComponentTarget subtarget@WholeComponent t - | CTestName _ <- availableTargetComponentName t - = either Left return $ - selectComponentTargetBasic subtarget t - | otherwise - = Left (notTestProblem - (availableTargetPackageId t) - (availableTargetComponentName t)) - -selectComponentTarget subtarget t - = Left (isSubComponentProblem - (availableTargetPackageId t) - (availableTargetComponentName t) - subtarget) + | CTestName _ <- availableTargetComponentName t = + either Left return $ + selectComponentTargetBasic subtarget t + | otherwise = + Left + ( notTestProblem + (availableTargetPackageId t) + (availableTargetComponentName t) + ) +selectComponentTarget subtarget t = + Left + ( isSubComponentProblem + (availableTargetPackageId t) + (availableTargetComponentName t) + subtarget + ) -- | The various error conditions that can occur when matching a -- 'TargetSelector' against 'AvailableTarget's for the @test@ command. --- -data TestProblem = - -- | The 'TargetSelector' matches targets but no test-suites - TargetProblemNoTests TargetSelector - - -- | The 'TargetSelector' refers to a component that is not a test-suite - | TargetProblemComponentNotTest PackageId ComponentName - - -- | Asking to test an individual file or module is not supported - | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget +data TestProblem + = -- | The 'TargetSelector' matches targets but no test-suites + TargetProblemNoTests TargetSelector + | -- | The 'TargetSelector' refers to a component that is not a test-suite + TargetProblemComponentNotTest PackageId ComponentName + | -- | Asking to test an individual file or module is not supported + TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget deriving (Eq, Show) - type TestTargetProblem = TargetProblem TestProblem - noTestsProblem :: TargetSelector -> TargetProblem TestProblem noTestsProblem = CustomTargetProblem . TargetProblemNoTests @@ -229,8 +253,9 @@ isSubComponentProblem -> ComponentName -> SubComponentTarget -> TargetProblem TestProblem -isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $ - TargetProblemIsSubComponent pkgid name subcomponent +isSubComponentProblem pkgid name subcomponent = + CustomTargetProblem $ + TargetProblemIsSubComponent pkgid name subcomponent reportTargetProblems :: Verbosity -> Flag Bool -> [TestTargetProblem] -> IO a reportTargetProblems verbosity failWhenNoTestSuites problems = @@ -241,8 +266,8 @@ reportTargetProblems verbosity failWhenNoTestSuites problems = notice verbosity (renderAllowedNoTestsProblem selector) System.Exit.exitSuccess (_, _) -> die' verbosity problemsMessage - where - problemsMessage = unlines . map renderTestTargetProblem $ problems + where + problemsMessage = unlines . map renderTestTargetProblem $ problems -- | Unless @--test-fail-when-no-test-suites@ flag is passed, we don't -- @die@ when the target problem is 'TargetProblemNoTests'. @@ -250,42 +275,49 @@ reportTargetProblems verbosity failWhenNoTestSuites problems = -- indicate how this behaviour was enabled. renderAllowedNoTestsProblem :: TargetSelector -> String renderAllowedNoTestsProblem selector = - "No tests to run for " ++ renderTargetSelector selector + "No tests to run for " ++ renderTargetSelector selector renderTestTargetProblem :: TestTargetProblem -> String renderTestTargetProblem (TargetProblemNoTargets targetSelector) = - case targetSelectorFilter targetSelector of - Just kind | kind /= TestKind - -> "The test command is for running test suites, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ "." - ++ "\n" ++ show targetSelector - - _ -> renderTargetProblemNoTargets "test" targetSelector + case targetSelectorFilter targetSelector of + Just kind + | kind /= TestKind -> + "The test command is for running test suites, but the target '" + ++ showTargetSelector targetSelector + ++ "' refers to " + ++ renderTargetSelector targetSelector + ++ "." + ++ "\n" + ++ show targetSelector + _ -> renderTargetProblemNoTargets "test" targetSelector renderTestTargetProblem problem = - renderTargetProblem "test" renderTestProblem problem - + renderTargetProblem "test" renderTestProblem problem renderTestProblem :: TestProblem -> String renderTestProblem (TargetProblemNoTests targetSelector) = - "Cannot run tests for the target '" ++ showTargetSelector targetSelector - ++ "' which refers to " ++ renderTargetSelector targetSelector - ++ " because " - ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" - ++ " not contain any test suites." - + "Cannot run tests for the target '" + ++ showTargetSelector targetSelector + ++ "' which refers to " + ++ renderTargetSelector targetSelector + ++ " because " + ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" + ++ " not contain any test suites." renderTestProblem (TargetProblemComponentNotTest pkgid cname) = - "The test command is for running test suites, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ " from the package " - ++ prettyShow pkgid ++ "." + "The test command is for running test suites, but the target '" + ++ showTargetSelector targetSelector + ++ "' refers to " + ++ renderTargetSelector targetSelector + ++ " from the package " + ++ prettyShow pkgid + ++ "." where targetSelector = TargetComponent pkgid cname WholeComponent - renderTestProblem (TargetProblemIsSubComponent pkgid cname subtarget) = - "The test command can only run test suites as a whole, " - ++ "not files or modules within them, but the target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ "." + "The test command can only run test suites as a whole, " + ++ "not files or modules within them, but the target '" + ++ showTargetSelector targetSelector + ++ "' refers to " + ++ renderTargetSelector targetSelector + ++ "." where targetSelector = TargetComponent pkgid cname subtarget diff --git a/cabal-install/src/Distribution/Client/CmdUpdate.hs b/cabal-install/src/Distribution/Client/CmdUpdate.hs index f066788ec63..4ccd53ff286 100644 --- a/cabal-install/src/Distribution/Client/CmdUpdate.hs +++ b/cabal-install/src/Distribution/Client/CmdUpdate.hs @@ -1,196 +1,262 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} -- | cabal-install CLI command: update --- -module Distribution.Client.CmdUpdate ( - updateCommand, - updateAction, +module Distribution.Client.CmdUpdate + ( updateCommand + , updateAction ) where -import Prelude () import Control.Exception import Distribution.Client.Compat.Prelude +import Prelude () -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) import Distribution.Client.Compat.Directory - ( setModificationTime ) -import Distribution.Client.ProjectOrchestration -import Distribution.Client.ProjectConfig - ( ProjectConfig(..) - , ProjectConfigShared(projectConfigConfigFile) - , projectConfigWithSolverRepoContext - , withProjectOrGlobalConfig ) -import Distribution.Client.ProjectFlags - ( ProjectFlags (..) ) -import Distribution.Client.Types - ( Repo(..), RepoName (..), unRepoName, RemoteRepo(..), repoName ) -import Distribution.Client.HttpUtils - ( DownloadResult(..) ) + ( setModificationTime + ) import Distribution.Client.FetchUtils - ( downloadIndex ) + ( downloadIndex + ) +import Distribution.Client.HttpUtils + ( DownloadResult (..) + ) +import Distribution.Client.IndexUtils + ( Index (..) + , currentIndexTimestamp + , indexBaseName + , updatePackageIndexCacheFile + , updateRepoIndexCache + , writeIndexTimestamp + ) +import Distribution.Client.IndexUtils.IndexState import Distribution.Client.JobControl - ( newParallelJobControl, spawnJob, collectJob ) + ( collectJob + , newParallelJobControl + , spawnJob + ) +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..) + , defaultNixStyleFlags + , nixStyleOptions + ) +import Distribution.Client.ProjectConfig + ( ProjectConfig (..) + , ProjectConfigShared (projectConfigConfigFile) + , projectConfigWithSolverRepoContext + , withProjectOrGlobalConfig + ) +import Distribution.Client.ProjectFlags + ( ProjectFlags (..) + ) +import Distribution.Client.ProjectOrchestration import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..) - , UpdateFlags, defaultUpdateFlags - , RepoContext(..) ) + ( ConfigFlags (..) + , GlobalFlags + , RepoContext (..) + , UpdateFlags + , defaultUpdateFlags + ) +import Distribution.Client.Types + ( RemoteRepo (..) + , Repo (..) + , RepoName (..) + , repoName + , unRepoName + ) import Distribution.Simple.Flag - ( fromFlagOrDefault ) + ( fromFlagOrDefault + ) import Distribution.Simple.Utils - ( die', notice, wrapText, writeFileAtomic, noticeNoWrap, warn ) + ( die' + , notice + , noticeNoWrap + , warn + , wrapText + , writeFileAtomic + ) import Distribution.Verbosity - ( normal, lessVerbose ) -import Distribution.Client.IndexUtils.IndexState -import Distribution.Client.IndexUtils - ( updateRepoIndexCache, Index(..), writeIndexTimestamp - , currentIndexTimestamp, indexBaseName, updatePackageIndexCacheFile ) + ( lessVerbose + , normal + ) import qualified Data.Maybe as Unsafe (fromJust) import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp +import qualified Text.PrettyPrint as Disp -import qualified Data.ByteString.Lazy as BS -import Distribution.Client.GZipUtils (maybeDecompress) -import System.FilePath ((<.>), dropExtension) +import qualified Data.ByteString.Lazy as BS import Data.Time (getCurrentTime) +import Distribution.Client.GZipUtils (maybeDecompress) import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) + ( CommandUI (..) + , usageAlternatives + ) +import System.FilePath (dropExtension, (<.>)) -import qualified Hackage.Security.Client as Sec import Distribution.Client.IndexUtils.Timestamp (nullTimestamp) +import qualified Hackage.Security.Client as Sec updateCommand :: CommandUI (NixStyleFlags ()) -updateCommand = CommandUI - { commandName = "v2-update" - , commandSynopsis = "Updates list of known packages." - , commandUsage = usageAlternatives "v2-update" [ "[FLAGS] [REPOS]" ] - , commandDescription = Just $ \_ -> wrapText $ +updateCommand = + CommandUI + { commandName = "v2-update" + , commandSynopsis = "Updates list of known packages." + , commandUsage = usageAlternatives "v2-update" ["[FLAGS] [REPOS]"] + , commandDescription = Just $ \_ -> + wrapText $ "For all known remote repositories, download the package list." - - , commandNotes = Just $ \pname -> + , commandNotes = Just $ \pname -> "REPO has the format [,] where index-state follows\n" - ++ "the same format and syntax that is supported by the --index-state flag.\n\n" - ++ "Examples:\n" - ++ " " ++ pname ++ " v2-update\n" - ++ " Download the package list for all known remote repositories.\n\n" - ++ " " ++ pname ++ " v2-update hackage.haskell.org,@1474732068\n" - ++ " " ++ pname ++ " v2-update hackage.haskell.org,2016-09-24T17:47:48Z\n" - ++ " " ++ pname ++ " v2-update hackage.haskell.org,HEAD\n" - ++ " " ++ pname ++ " v2-update hackage.haskell.org\n" - ++ " Download hackage.haskell.org at a specific index state.\n\n" - ++ " " ++ pname ++ " v2-update hackage.haskell.org head.hackage\n" - ++ " Download hackage.haskell.org and head.hackage\n" - ++ " head.hackage must be a known repo-id. E.g. from\n" - ++ " your cabal.project(.local) file.\n" - - , commandOptions = nixStyleOptions $ const [] - , commandDefaultFlags = defaultNixStyleFlags () - } + ++ "the same format and syntax that is supported by the --index-state flag.\n\n" + ++ "Examples:\n" + ++ " " + ++ pname + ++ " v2-update\n" + ++ " Download the package list for all known remote repositories.\n\n" + ++ " " + ++ pname + ++ " v2-update hackage.haskell.org,@1474732068\n" + ++ " " + ++ pname + ++ " v2-update hackage.haskell.org,2016-09-24T17:47:48Z\n" + ++ " " + ++ pname + ++ " v2-update hackage.haskell.org,HEAD\n" + ++ " " + ++ pname + ++ " v2-update hackage.haskell.org\n" + ++ " Download hackage.haskell.org at a specific index state.\n\n" + ++ " " + ++ pname + ++ " v2-update hackage.haskell.org head.hackage\n" + ++ " Download hackage.haskell.org and head.hackage\n" + ++ " head.hackage must be a known repo-id. E.g. from\n" + ++ " your cabal.project(.local) file.\n" + , commandOptions = nixStyleOptions $ const [] + , commandDefaultFlags = defaultNixStyleFlags () + } data UpdateRequest = UpdateRequest - { _updateRequestRepoName :: RepoName + { _updateRequestRepoName :: RepoName , _updateRequestRepoState :: RepoIndexState - } deriving (Show) + } + deriving (Show) instance Pretty UpdateRequest where - pretty (UpdateRequest n s) = pretty n <<>> Disp.comma <<>> pretty s + pretty (UpdateRequest n s) = pretty n <<>> Disp.comma <<>> pretty s instance Parsec UpdateRequest where parsec = do - name <- parsec - state <- P.char ',' *> parsec <|> pure IndexStateHead - return (UpdateRequest name state) + name <- parsec + state <- P.char ',' *> parsec <|> pure IndexStateHead + return (UpdateRequest name state) updateAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -updateAction flags@NixStyleFlags {..} extraArgs globalFlags = do +updateAction flags@NixStyleFlags{..} extraArgs globalFlags = do let ignoreProject = flagIgnoreProject projectFlags - projectConfig <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag - (projectConfig <$> establishProjectBaseContext verbosity cliConfig OtherCommand) - (\globalConfig -> return $ globalConfig <> cliConfig) + projectConfig <- + withProjectOrGlobalConfig + verbosity + ignoreProject + globalConfigFlag + (projectConfig <$> establishProjectBaseContext verbosity cliConfig OtherCommand) + (\globalConfig -> return $ globalConfig <> cliConfig) - projectConfigWithSolverRepoContext verbosity - (projectConfigShared projectConfig) (projectConfigBuildOnly projectConfig) + projectConfigWithSolverRepoContext + verbosity + (projectConfigShared projectConfig) + (projectConfigBuildOnly projectConfig) $ \repoCtxt -> do + let repos :: [Repo] + repos = repoContextRepos repoCtxt - let repos :: [Repo] - repos = repoContextRepos repoCtxt - - parseArg :: String -> IO UpdateRequest - parseArg s = case simpleParsec s of - Just r -> return r - Nothing -> die' verbosity $ - "'v2-update' unable to parse repo: \"" ++ s ++ "\"" - - updateRepoRequests <- traverse parseArg extraArgs - - unless (null updateRepoRequests) $ do - let remoteRepoNames = map repoName repos - unknownRepos = [r | (UpdateRequest r _) <- updateRepoRequests - , not (r `elem` remoteRepoNames)] - unless (null unknownRepos) $ - die' verbosity $ "'v2-update' repo(s): \"" - ++ intercalate "\", \"" (map unRepoName unknownRepos) - ++ "\" can not be found in known remote repo(s): " - ++ intercalate ", " (map unRepoName remoteRepoNames) - - let reposToUpdate :: [(Repo, RepoIndexState)] - reposToUpdate = case updateRepoRequests of - -- If we are not given any specific repository, update all - -- repositories to HEAD. - [] -> map (,IndexStateHead) repos - updateRequests -> let repoMap = [(repoName r, r) | r <- repos] - lookup' k = Unsafe.fromJust (lookup k repoMap) - in [ (lookup' name, state) - | (UpdateRequest name state) <- updateRequests ] - - case reposToUpdate of - [] -> - notice verbosity "No remote repositories configured" - [(remoteRepo, _)] -> - notice verbosity $ "Downloading the latest package list from " - ++ unRepoName (repoName remoteRepo) - _ -> notice verbosity . unlines - $ "Downloading the latest package lists from: " - : map (("- " ++) . unRepoName . repoName . fst) reposToUpdate + parseArg :: String -> IO UpdateRequest + parseArg s = case simpleParsec s of + Just r -> return r + Nothing -> + die' verbosity $ + "'v2-update' unable to parse repo: \"" ++ s ++ "\"" + + updateRepoRequests <- traverse parseArg extraArgs + + unless (null updateRepoRequests) $ do + let remoteRepoNames = map repoName repos + unknownRepos = + [ r | (UpdateRequest r _) <- updateRepoRequests, not (r `elem` remoteRepoNames) + ] + unless (null unknownRepos) $ + die' verbosity $ + "'v2-update' repo(s): \"" + ++ intercalate "\", \"" (map unRepoName unknownRepos) + ++ "\" can not be found in known remote repo(s): " + ++ intercalate ", " (map unRepoName remoteRepoNames) - unless (null reposToUpdate) $ do - jobCtrl <- newParallelJobControl (length reposToUpdate) - traverse_ (spawnJob jobCtrl . updateRepo verbosity defaultUpdateFlags repoCtxt) - reposToUpdate - traverse_ (\_ -> collectJob jobCtrl) reposToUpdate + let reposToUpdate :: [(Repo, RepoIndexState)] + reposToUpdate = case updateRepoRequests of + -- If we are not given any specific repository, update all + -- repositories to HEAD. + [] -> map (,IndexStateHead) repos + updateRequests -> + let repoMap = [(repoName r, r) | r <- repos] + lookup' k = Unsafe.fromJust (lookup k repoMap) + in [ (lookup' name, state) + | (UpdateRequest name state) <- updateRequests + ] + case reposToUpdate of + [] -> + notice verbosity "No remote repositories configured" + [(remoteRepo, _)] -> + notice verbosity $ + "Downloading the latest package list from " + ++ unRepoName (repoName remoteRepo) + _ -> + notice verbosity . unlines $ + "Downloading the latest package lists from: " + : map (("- " ++) . unRepoName . repoName . fst) reposToUpdate + + unless (null reposToUpdate) $ do + jobCtrl <- newParallelJobControl (length reposToUpdate) + traverse_ + (spawnJob jobCtrl . updateRepo verbosity defaultUpdateFlags repoCtxt) + reposToUpdate + traverse_ (\_ -> collectJob jobCtrl) reposToUpdate where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) -updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, RepoIndexState) - -> IO () +updateRepo + :: Verbosity + -> UpdateFlags + -> RepoContext + -> (Repo, RepoIndexState) + -> IO () updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do transport <- repoContextGetTransport repoCtxt case repo of RepoLocalNoIndex{} -> do let index = RepoIndex repoCtxt repo updatePackageIndexCacheFile verbosity index - RepoRemote{..} -> do - downloadResult <- downloadIndex transport verbosity - repoRemote repoLocalDir + downloadResult <- + downloadIndex + transport + verbosity + repoRemote + repoLocalDir case downloadResult of FileAlreadyInCache -> setModificationTime (indexBaseName repo <.> "tar") - =<< getCurrentTime + =<< getCurrentTime FileDownloaded indexPath -> do writeFileAtomic (dropExtension indexPath) . maybeDecompress - =<< BS.readFile indexPath + =<< BS.readFile indexPath updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do let index = RepoIndex repoCtxt repo @@ -199,9 +265,10 @@ updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do -- NB: always update the timestamp, even if we didn't actually -- download anything writeIndexTimestamp index indexState - ce <- if repoContextIgnoreExpiry repoCtxt - then Just `fmap` getCurrentTime - else return Nothing + ce <- + if repoContextIgnoreExpiry repoCtxt + then Just `fmap` getCurrentTime + else return Nothing updated <- Sec.uncheckClientErrors $ Sec.checkForUpdates repoSecure ce -- this resolves indexState (which could be HEAD) into a timestamp new_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo @@ -210,13 +277,12 @@ updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do -- Update cabal's internal index as well so that it's not out of sync -- (If all access to the cache goes through hackage-security this can go) case updated of - Sec.NoUpdates -> do + Sec.NoUpdates -> do now <- getCurrentTime - setModificationTime (indexBaseName repo <.> "tar") now `catchIO` - (\e -> warn verbosity $ "Could not set modification time of index tarball -- " ++ displayException e) + setModificationTime (indexBaseName repo <.> "tar") now + `catchIO` (\e -> warn verbosity $ "Could not set modification time of index tarball -- " ++ displayException e) noticeNoWrap verbosity $ "Package list of " ++ prettyShow rname ++ " is up to date." - Sec.HasUpdates -> do updateRepoIndexCache verbosity index noticeNoWrap verbosity $ @@ -233,5 +299,7 @@ updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do -- the user know how to go back to current_ts when (current_ts /= nullTimestamp && new_ts /= current_ts) $ noticeNoWrap verbosity $ - "To revert to previous state run:\n" ++ - " cabal v2-update '" ++ prettyShow (UpdateRequest rname (IndexStateTime current_ts)) ++ "'\n" + "To revert to previous state run:\n" + ++ " cabal v2-update '" + ++ prettyShow (UpdateRequest rname (IndexStateTime current_ts)) + ++ "'\n" diff --git a/cabal-install/src/Distribution/Client/Compat/Directory.hs b/cabal-install/src/Distribution/Client/Compat/Directory.hs index 3c0997377b8..7b44596186d 100644 --- a/cabal-install/src/Distribution/Client/Compat/Directory.hs +++ b/cabal-install/src/Distribution/Client/Compat/Directory.hs @@ -1,10 +1,11 @@ {-# LANGUAGE CPP #-} -module Distribution.Client.Compat.Directory ( - setModificationTime, - createFileLink, - pathIsSymbolicLink, - getSymbolicLinkTarget, - ) where + +module Distribution.Client.Compat.Directory + ( setModificationTime + , createFileLink + , pathIsSymbolicLink + , getSymbolicLinkTarget + ) where #if MIN_VERSION_directory(1,2,3) import System.Directory (setModificationTime) diff --git a/cabal-install/src/Distribution/Client/Compat/ExecutablePath.hs b/cabal-install/src/Distribution/Client/Compat/ExecutablePath.hs index 8a799b6de7d..e805c110d60 100644 --- a/cabal-install/src/Distribution/Client/Compat/ExecutablePath.hs +++ b/cabal-install/src/Distribution/Client/Compat/ExecutablePath.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} -- Copied verbatim from base-4.6.0.0. We can't simply import -- System.Environment.getExecutablePath because we need compatibility with older -- GHCs. -module Distribution.Client.Compat.ExecutablePath ( getExecutablePath ) where +module Distribution.Client.Compat.ExecutablePath (getExecutablePath) where import Prelude @@ -118,6 +118,7 @@ getExecutablePath = readSymbolicLink $ "/proc/self/exe" -------------------------------------------------------------------------------- -- Windows +{- FOURMOLU_DISABLE -} #elif defined(mingw32_HOST_OS) # if defined(i386_HOST_ARCH) @@ -164,3 +165,4 @@ getExecutablePath = -------------------------------------------------------------------------------- #endif +{- FOURMOLU_ENABLE -} diff --git a/cabal-install/src/Distribution/Client/Compat/Orphans.hs b/cabal-install/src/Distribution/Client/Compat/Orphans.hs index aef25787f45..4a2e28a10fb 100644 --- a/cabal-install/src/Distribution/Client/Compat/Orphans.hs +++ b/cabal-install/src/Distribution/Client/Compat/Orphans.hs @@ -1,13 +1,14 @@ {-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + module Distribution.Client.Compat.Orphans () where -import Control.Exception (SomeException) -import Distribution.Compat.Binary (Binary (..)) -import Distribution.Compat.Typeable (typeRep) +import Control.Exception (SomeException) +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) +import Network.URI (URI (..), URIAuth (..)) +import Prelude (error, return) ------------------------------------------------------------------------------- -- network-uri @@ -17,25 +18,30 @@ import Prelude (error, return) -- versions do not, so we use manual Binary instances here instance Binary URI where put (URI a b c d e) = do put a; put b; put c; put d; put e - get = do !a <- get; !b <- get; !c <- get; !d <- get; !e <- get - return (URI a b c d e) + get = do + !a <- get + !b <- get + !c <- get + !d <- get + !e <- get + return (URI a b c d e) instance Structured URI where - structure p = Nominal (typeRep p) 0 "URI" [] + structure p = Nominal (typeRep p) 0 "URI" [] instance Binary URIAuth where - put (URIAuth a b c) = do put a; put b; put c - get = do !a <- get; !b <- get; !c <- get; return (URIAuth a b c) + put (URIAuth a b c) = do put a; put b; put c + get = do !a <- get; !b <- get; !c <- get; return (URIAuth a b c) ------------------------------------------------------------------------------- -- base ------------------------------------------------------------------------------- ---FIXME: Duncan Coutts: this is a total cheat ---Added in 46aa019ec85e313e257d122a3549cce01996c566 +-- FIXME: Duncan Coutts: this is a total cheat +-- Added in 46aa019ec85e313e257d122a3549cce01996c566 instance Binary SomeException where - put _ = return () - get = error "cannot serialise exceptions" + put _ = return () + get = error "cannot serialise exceptions" instance Structured SomeException where - structure p = Nominal (typeRep p) 0 "SomeException" [] + structure p = Nominal (typeRep p) 0 "SomeException" [] diff --git a/cabal-install/src/Distribution/Client/Compat/Prelude.hs b/cabal-install/src/Distribution/Client/Compat/Prelude.hs index 38978ef8d3f..42d048c9b61 100644 --- a/cabal-install/src/Distribution/Client/Compat/Prelude.hs +++ b/cabal-install/src/Distribution/Client/Compat/Prelude.hs @@ -9,7 +9,6 @@ -- -- This module is a superset of "Distribution.Compat.Prelude" (which -- this module re-exports) --- module Distribution.Client.Compat.Prelude ( module Distribution.Compat.Prelude.Internal , module X @@ -19,6 +18,6 @@ import Distribution.Client.Compat.Orphans () import Distribution.Compat.Prelude.Internal import Prelude () -import Distribution.Parsec as X (CabalParsing, Parsec (..), eitherParsec, explicitEitherParsec, simpleParsec) -import Distribution.Pretty as X (Pretty (..), prettyShow) +import Distribution.Parsec as X (CabalParsing, Parsec (..), eitherParsec, explicitEitherParsec, simpleParsec) +import Distribution.Pretty as X (Pretty (..), prettyShow) import Distribution.Verbosity as X (Verbosity) diff --git a/cabal-install/src/Distribution/Client/Compat/Semaphore.hs b/cabal-install/src/Distribution/Client/Compat/Semaphore.hs index e25442b019c..42c398b5c33 100644 --- a/cabal-install/src/Distribution/Client/Compat/Semaphore.hs +++ b/cabal-install/src/Distribution/Client/Compat/Semaphore.hs @@ -1,26 +1,32 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_GHC -funbox-strict-fields #-} + module Distribution.Client.Compat.Semaphore - ( QSem - , newQSem - , waitQSem - , signalQSem - ) where + ( QSem + , newQSem + , waitQSem + , signalQSem + ) where -import Prelude (IO, return, Eq (..), Int, Bool (..), ($), ($!), Num (..), flip) +import Prelude (Bool (..), Eq (..), IO, Int, Num (..), flip, return, ($), ($!)) -import Control.Concurrent.STM (TVar, atomically, newTVar, readTVar, retry, - writeTVar) +import Control.Concurrent.STM + ( TVar + , atomically + , newTVar + , readTVar + , retry + , writeTVar + ) import Control.Exception (mask_, onException) import Control.Monad (join, unless) -import Data.Typeable (Typeable) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE +import Data.Typeable (Typeable) -- | 'QSem' is a quantity semaphore in which the resource is acquired -- and released in units of one. It provides guaranteed FIFO ordering -- for satisfying blocked `waitQSem` calls. --- data QSem = QSem !(TVar Int) !(TVar [TVar Bool]) !(TVar [TVar Bool]) deriving (Eq, Typeable) @@ -34,18 +40,20 @@ newQSem i = atomically $ do waitQSem :: QSem -> IO () waitQSem s@(QSem q _b1 b2) = mask_ $ join $ atomically $ do - -- join, because if we need to block, we have to add a TVar to - -- the block queue. - -- mask_, because we need a chance to set up an exception handler - -- after the join returns. - v <- readTVar q - if v == 0 - then do b <- newTVar False - ys <- readTVar b2 - writeTVar b2 (b:ys) - return (wait b) - else do writeTVar q $! v - 1 - return (return ()) + -- join, because if we need to block, we have to add a TVar to + -- the block queue. + -- mask_, because we need a chance to set up an exception handler + -- after the join returns. + v <- readTVar q + if v == 0 + then do + b <- newTVar False + ys <- readTVar b2 + writeTVar b2 (b : ys) + return (wait b) + else do + writeTVar q $! v - 1 + return (return ()) where -- -- very careful here: if we receive an exception, then we need to @@ -59,17 +67,18 @@ waitQSem s@(QSem q _b1 b2) = -- wait t = flip onException (wake s t) $ - atomically $ do - b <- readTVar t - unless b retry - + atomically $ do + b <- readTVar t + unless b retry wake :: QSem -> TVar Bool -> IO () wake s x = join $ atomically $ do - b <- readTVar x - if b then return (signalQSem s) - else do writeTVar x True - return (return ()) + b <- readTVar x + if b + then return (signalQSem s) + else do + writeTVar x True + return (return ()) {- property we want: @@ -82,27 +91,29 @@ wake s x = join $ atomically $ do signalQSem :: QSem -> IO () signalQSem s@(QSem q b1 b2) = mask_ $ join $ atomically $ do - -- join, so we don't force the reverse inside the txn - -- mask_ is needed so we don't lose a wakeup + -- join, so we don't force the reverse inside the txn + -- mask_ is needed so we don't lose a wakeup v <- readTVar q if v /= 0 - then do writeTVar q $! v + 1 - return (return ()) - else do xs <- readTVar b1 - checkwake1 xs + then do + writeTVar q $! v + 1 + return (return ()) + else do + xs <- readTVar b1 + checkwake1 xs where checkwake1 [] = do ys <- readTVar b2 checkwake2 ys - checkwake1 (x:xs) = do + checkwake1 (x : xs) = do writeTVar b1 xs return (wake s x) checkwake2 [] = do writeTVar q 1 return (return ()) - checkwake2 (y:ys) = do - let (z:|zs) = NE.reverse (y:|ys) + checkwake2 (y : ys) = do + let (z :| zs) = NE.reverse (y :| ys) writeTVar b1 zs writeTVar b2 [] return (wake s z) diff --git a/cabal-install/src/Distribution/Client/Config.hs b/cabal-install/src/Distribution/Client/Config.hs index df9a5046a30..51de660808d 100644 --- a/cabal-install/src/Distribution/Client/Config.hs +++ b/cabal-install/src/Distribution/Client/Config.hs @@ -1,6 +1,9 @@ {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.Config -- Copyright : (c) David Himmelstrup 2005 @@ -12,185 +15,277 @@ -- -- Utilities for handling saved state such as known packages, known servers and -- downloaded packages. ------------------------------------------------------------------------------ -module Distribution.Client.Config ( - SavedConfig(..), - loadConfig, - getConfigFilePath, - - showConfig, - showConfigWithComments, - parseConfig, - - defaultConfigFile, - defaultCacheDir, - defaultScriptBuildsDir, - defaultStoreDir, - defaultCompiler, - defaultInstallPath, - defaultLogsDir, - defaultReportsDir, - defaultUserInstall, - - baseSavedConfig, - commentSavedConfig, - initialSavedConfig, - configFieldDescriptions, - haddockFlagsFields, - installDirsFields, - withProgramsFields, - withProgramOptionsFields, - userConfigDiff, - userConfigUpdate, - createDefaultConfigFile, - - remoteRepoFields, - postProcessRepo, +module Distribution.Client.Config + ( SavedConfig (..) + , loadConfig + , getConfigFilePath + , showConfig + , showConfigWithComments + , parseConfig + , defaultConfigFile + , defaultCacheDir + , defaultScriptBuildsDir + , defaultStoreDir + , defaultCompiler + , defaultInstallPath + , defaultLogsDir + , defaultReportsDir + , defaultUserInstall + , baseSavedConfig + , commentSavedConfig + , initialSavedConfig + , configFieldDescriptions + , haddockFlagsFields + , installDirsFields + , withProgramsFields + , withProgramOptionsFields + , userConfigDiff + , userConfigUpdate + , createDefaultConfigFile + , remoteRepoFields + , postProcessRepo ) where -import Distribution.Compat.Environment (lookupEnv) import Distribution.Client.Compat.Prelude +import Distribution.Compat.Environment (lookupEnv) import Prelude () -import Language.Haskell.Extension ( Language(Haskell2010) ) +import Language.Haskell.Extension (Language (Haskell2010)) import Distribution.Deprecated.ViewAsFieldDescr - ( viewAsFieldDescr ) + ( viewAsFieldDescr + ) -import Distribution.Client.Types - ( RemoteRepo(..), LocalRepo (..), emptyRemoteRepo - , AllowOlder(..), AllowNewer(..), RelaxDeps(..), isRelaxDeps - , RepoName (..), unRepoName - ) -import Distribution.Client.Types.Credentials (Username (..), Password (..)) import Distribution.Client.BuildReports.Types - ( ReportLevel(..) ) -import qualified Distribution.Client.Init.Types as IT - ( InitFlags(..) ) + ( ReportLevel (..) + ) +import Distribution.Client.CmdInstall.ClientInstallFlags + ( ClientInstallFlags (..) + , clientInstallOptions + , defaultClientInstallFlags + ) import qualified Distribution.Client.Init.Defaults as IT +import qualified Distribution.Client.Init.Types as IT + ( InitFlags (..) + ) import Distribution.Client.Setup - ( GlobalFlags(..), globalCommand, defaultGlobalFlags - , ConfigExFlags(..), configureExOptions, defaultConfigExFlags - , initOptions - , InstallFlags(..), installOptions, defaultInstallFlags - , UploadFlags(..), uploadCommand - , ReportFlags(..), reportCommand ) -import Distribution.Client.CmdInstall.ClientInstallFlags - ( ClientInstallFlags(..), defaultClientInstallFlags - , clientInstallOptions ) + ( ConfigExFlags (..) + , GlobalFlags (..) + , InstallFlags (..) + , ReportFlags (..) + , UploadFlags (..) + , configureExOptions + , defaultConfigExFlags + , defaultGlobalFlags + , defaultInstallFlags + , globalCommand + , initOptions + , installOptions + , reportCommand + , uploadCommand + ) +import Distribution.Client.Types + ( AllowNewer (..) + , AllowOlder (..) + , LocalRepo (..) + , RelaxDeps (..) + , RemoteRepo (..) + , RepoName (..) + , emptyRemoteRepo + , isRelaxDeps + , unRepoName + ) +import Distribution.Client.Types.Credentials (Password (..), Username (..)) import Distribution.Utils.NubList - ( NubList, fromNubList, toNubList, overNubList ) + ( NubList + , fromNubList + , overNubList + , toNubList + ) -import Distribution.Simple.Compiler - ( DebugInfoLevel(..), OptimisationLevel(..) ) -import Distribution.Simple.Setup - ( ConfigFlags(..), configureOptions, defaultConfigFlags - , HaddockFlags(..), haddockOptions, defaultHaddockFlags - , TestFlags(..), defaultTestFlags - , BenchmarkFlags(..), defaultBenchmarkFlags - , installDirsOptions, optionDistPref - , programDbPaths', programDbOptions - , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault ) -import Distribution.Simple.InstallDirs - ( InstallDirs(..), defaultInstallDirs - , PathTemplate, toPathTemplate) -import Distribution.Deprecated.ParseUtils - ( FieldDescr(..), liftField, runP - , ParseResult(..), PError(..), PWarning(..) - , locatedErrorMsg, showPWarning - , readFields, warning, lineNo - , simpleField, listField, spaceListField - , parseOptCommaList, parseTokenQ, syntaxError - , simpleFieldParsec, listFieldParsec - ) -import Distribution.Client.ParseUtils - ( parseFields, ppFields, ppSection ) import Distribution.Client.HttpUtils - ( isOldHackageURI ) + ( isOldHackageURI + ) +import Distribution.Client.ParseUtils + ( parseFields + , ppFields + , ppSection + ) +import Distribution.Client.ProjectFlags (ProjectFlags (..)) +import Distribution.Client.Version + ( cabalInstallVersion + ) +import qualified Distribution.Compat.CharParsing as P +import Distribution.Compiler + ( CompilerFlavor (..) + , defaultCompilerFlavor + ) +import Distribution.Deprecated.ParseUtils + ( FieldDescr (..) + , PError (..) + , PWarning (..) + , ParseResult (..) + , liftField + , lineNo + , listField + , listFieldParsec + , locatedErrorMsg + , parseOptCommaList + , parseTokenQ + , readFields + , runP + , showPWarning + , simpleField + , simpleFieldParsec + , spaceListField + , syntaxError + , warning + ) import qualified Distribution.Deprecated.ParseUtils as ParseUtils - ( Field(..) ) + ( Field (..) + ) import Distribution.Simple.Command - ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..) ) + ( CommandUI (commandOptions) + , ShowOrParseArgs (..) + , commandDefaultFlags + ) +import Distribution.Simple.Compiler + ( DebugInfoLevel (..) + , OptimisationLevel (..) + ) +import Distribution.Simple.InstallDirs + ( InstallDirs (..) + , PathTemplate + , defaultInstallDirs + , toPathTemplate + ) import Distribution.Simple.Program - ( defaultProgramDb ) + ( defaultProgramDb + ) +import Distribution.Simple.Setup + ( BenchmarkFlags (..) + , ConfigFlags (..) + , Flag (..) + , HaddockFlags (..) + , TestFlags (..) + , configureOptions + , defaultBenchmarkFlags + , defaultConfigFlags + , defaultHaddockFlags + , defaultTestFlags + , flagToMaybe + , fromFlagOrDefault + , haddockOptions + , installDirsOptions + , optionDistPref + , programDbOptions + , programDbPaths' + , toFlag + ) import Distribution.Simple.Utils - ( die', notice, warn, lowercase, cabalVersion, toUTF8BS ) -import Distribution.Client.Version - ( cabalInstallVersion ) -import Distribution.Compiler - ( CompilerFlavor(..), defaultCompilerFlavor ) -import Distribution.Verbosity - ( normal ) -import qualified Distribution.Compat.CharParsing as P -import Distribution.Client.ProjectFlags (ProjectFlags (..)) + ( cabalVersion + , die' + , lowercase + , notice + , toUTF8BS + , warn + ) import Distribution.Solver.Types.ConstraintSource +import Distribution.Verbosity + ( normal + ) -import qualified Text.PrettyPrint as Disp - ( render, text, empty ) -import Distribution.Parsec (parsecOptCommaList, ParsecParser, parsecToken, parsecFilePath) -import Text.PrettyPrint - ( ($+$) ) -import Text.PrettyPrint.HughesPJ - ( text, Doc ) -import System.Directory - ( createDirectoryIfMissing, getHomeDirectory, getXdgDirectory, XdgDirectory(XdgCache, XdgConfig, XdgState), renameFile, getAppUserDataDirectory, doesDirectoryExist ) +import qualified Data.ByteString as BS +import qualified Data.Map as M +import Distribution.Compat.Environment + ( getEnvironment + ) +import Distribution.Parsec (ParsecParser, parsecFilePath, parsecOptCommaList, parsecToken) import Network.URI - ( URI(..), URIAuth(..), parseURI ) + ( URI (..) + , URIAuth (..) + , parseURI + ) +import System.Directory + ( XdgDirectory (XdgCache, XdgConfig, XdgState) + , createDirectoryIfMissing + , doesDirectoryExist + , getAppUserDataDirectory + , getHomeDirectory + , getXdgDirectory + , renameFile + ) import System.FilePath - ( (<.>), (), takeDirectory ) + ( takeDirectory + , (<.>) + , () + ) import System.IO.Error - ( isDoesNotExistError ) -import Distribution.Compat.Environment - ( getEnvironment ) -import qualified Data.Map as M -import qualified Data.ByteString as BS + ( isDoesNotExistError + ) +import Text.PrettyPrint + ( ($+$) + ) +import qualified Text.PrettyPrint as Disp + ( empty + , render + , text + ) +import Text.PrettyPrint.HughesPJ + ( Doc + , text + ) -- + -- * Configuration saved in the config file + -- data SavedConfig = SavedConfig - { savedGlobalFlags :: GlobalFlags - , savedInitFlags :: IT.InitFlags - , savedInstallFlags :: InstallFlags - , savedClientInstallFlags :: ClientInstallFlags - , savedConfigureFlags :: ConfigFlags - , savedConfigureExFlags :: ConfigExFlags - , savedUserInstallDirs :: InstallDirs (Flag PathTemplate) - , savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate) - , savedUploadFlags :: UploadFlags - , savedReportFlags :: ReportFlags - , savedHaddockFlags :: HaddockFlags - , savedTestFlags :: TestFlags - , savedBenchmarkFlags :: BenchmarkFlags - , savedProjectFlags :: ProjectFlags - } deriving Generic + { savedGlobalFlags :: GlobalFlags + , savedInitFlags :: IT.InitFlags + , savedInstallFlags :: InstallFlags + , savedClientInstallFlags :: ClientInstallFlags + , savedConfigureFlags :: ConfigFlags + , savedConfigureExFlags :: ConfigExFlags + , savedUserInstallDirs :: InstallDirs (Flag PathTemplate) + , savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate) + , savedUploadFlags :: UploadFlags + , savedReportFlags :: ReportFlags + , savedHaddockFlags :: HaddockFlags + , savedTestFlags :: TestFlags + , savedBenchmarkFlags :: BenchmarkFlags + , savedProjectFlags :: ProjectFlags + } + deriving (Generic) instance Monoid SavedConfig where mempty = gmempty mappend = (<>) instance Semigroup SavedConfig where - a <> b = SavedConfig { - savedGlobalFlags = combinedSavedGlobalFlags, - savedInitFlags = combinedSavedInitFlags, - savedInstallFlags = combinedSavedInstallFlags, - savedClientInstallFlags = combinedSavedClientInstallFlags, - savedConfigureFlags = combinedSavedConfigureFlags, - savedConfigureExFlags = combinedSavedConfigureExFlags, - savedUserInstallDirs = combinedSavedUserInstallDirs, - savedGlobalInstallDirs = combinedSavedGlobalInstallDirs, - savedUploadFlags = combinedSavedUploadFlags, - savedReportFlags = combinedSavedReportFlags, - savedHaddockFlags = combinedSavedHaddockFlags, - savedTestFlags = combinedSavedTestFlags, - savedBenchmarkFlags = combinedSavedBenchmarkFlags, - savedProjectFlags = combinedSavedProjectFlags - } + a <> b = + SavedConfig + { savedGlobalFlags = combinedSavedGlobalFlags + , savedInitFlags = combinedSavedInitFlags + , savedInstallFlags = combinedSavedInstallFlags + , savedClientInstallFlags = combinedSavedClientInstallFlags + , savedConfigureFlags = combinedSavedConfigureFlags + , savedConfigureExFlags = combinedSavedConfigureExFlags + , savedUserInstallDirs = combinedSavedUserInstallDirs + , savedGlobalInstallDirs = combinedSavedGlobalInstallDirs + , savedUploadFlags = combinedSavedUploadFlags + , savedReportFlags = combinedSavedReportFlags + , savedHaddockFlags = combinedSavedHaddockFlags + , savedTestFlags = combinedSavedTestFlags + , savedBenchmarkFlags = combinedSavedBenchmarkFlags + , savedProjectFlags = combinedSavedProjectFlags + } where -- This is ugly, but necessary. If we're mappending two config files, we -- want the values of the *non-empty* list fields from the second one to - -- *override* the corresponding values from the first one. Default + -- \*override* the corresponding values from the first one. Default -- behaviour (concatenation) is confusing and makes some use cases (see -- #1884) impossible. -- @@ -206,391 +301,421 @@ instance Semigroup SavedConfig where -- NB: the signature prevents us from using 'combine' on lists. combine' :: (SavedConfig -> flags) -> (flags -> Flag a) -> Flag a - combine' field subfield = + combine' field subfield = (subfield . field $ a) `mappend` (subfield . field $ b) - combineMonoid :: Monoid mon => (SavedConfig -> flags) -> (flags -> mon) - -> mon + combineMonoid + :: Monoid mon + => (SavedConfig -> flags) + -> (flags -> mon) + -> mon combineMonoid field subfield = (subfield . field $ a) `mappend` (subfield . field $ b) lastNonEmpty' :: (SavedConfig -> flags) -> (flags -> [a]) -> [a] - lastNonEmpty' field subfield = + lastNonEmpty' field subfield = let a' = subfield . field $ a b' = subfield . field $ b - in case b' of [] -> a' - _ -> b' + in case b' of + [] -> a' + _ -> b' lastNonMempty' :: (Eq a, Monoid a) => (SavedConfig -> flags) -> (flags -> a) -> a - lastNonMempty' field subfield = + lastNonMempty' field subfield = let a' = subfield . field $ a b' = subfield . field $ b - in if b' == mempty then a' else b' + in if b' == mempty then a' else b' - lastNonEmptyNL' :: (SavedConfig -> flags) -> (flags -> NubList a) - -> NubList a + lastNonEmptyNL' + :: (SavedConfig -> flags) + -> (flags -> NubList a) + -> NubList a lastNonEmptyNL' field subfield = let a' = subfield . field $ a b' = subfield . field $ b - in case fromNubList b' of [] -> a' - _ -> b' - - combinedSavedGlobalFlags = GlobalFlags { - globalVersion = combine globalVersion, - globalNumericVersion = combine globalNumericVersion, - globalConfigFile = combine globalConfigFile, - globalConstraintsFile = combine globalConstraintsFile, - globalRemoteRepos = lastNonEmptyNL globalRemoteRepos, - globalCacheDir = combine globalCacheDir, - globalLocalNoIndexRepos = lastNonEmptyNL globalLocalNoIndexRepos, - globalActiveRepos = combine globalActiveRepos, - globalLogsDir = combine globalLogsDir, - globalIgnoreExpiry = combine globalIgnoreExpiry, - globalHttpTransport = combine globalHttpTransport, - globalNix = combine globalNix, - globalStoreDir = combine globalStoreDir, - globalProgPathExtra = lastNonEmptyNL globalProgPathExtra - } + in case fromNubList b' of + [] -> a' + _ -> b' + + combinedSavedGlobalFlags = + GlobalFlags + { globalVersion = combine globalVersion + , globalNumericVersion = combine globalNumericVersion + , globalConfigFile = combine globalConfigFile + , globalConstraintsFile = combine globalConstraintsFile + , globalRemoteRepos = lastNonEmptyNL globalRemoteRepos + , globalCacheDir = combine globalCacheDir + , globalLocalNoIndexRepos = lastNonEmptyNL globalLocalNoIndexRepos + , globalActiveRepos = combine globalActiveRepos + , globalLogsDir = combine globalLogsDir + , globalIgnoreExpiry = combine globalIgnoreExpiry + , globalHttpTransport = combine globalHttpTransport + , globalNix = combine globalNix + , globalStoreDir = combine globalStoreDir + , globalProgPathExtra = lastNonEmptyNL globalProgPathExtra + } where - combine = combine' savedGlobalFlags + combine = combine' savedGlobalFlags lastNonEmptyNL = lastNonEmptyNL' savedGlobalFlags - combinedSavedInitFlags = IT.InitFlags { - IT.applicationDirs = combineMonoid savedInitFlags IT.applicationDirs, - IT.author = combine IT.author, - IT.buildTools = combineMonoid savedInitFlags IT.buildTools, - IT.cabalVersion = combine IT.cabalVersion, - IT.category = combine IT.category, - IT.dependencies = combineMonoid savedInitFlags IT.dependencies, - IT.email = combine IT.email, - IT.exposedModules = combineMonoid savedInitFlags IT.exposedModules, - IT.extraSrc = combineMonoid savedInitFlags IT.extraSrc, - IT.extraDoc = combineMonoid savedInitFlags IT.extraDoc, - IT.homepage = combine IT.homepage, - IT.initHcPath = combine IT.initHcPath, - IT.initVerbosity = combine IT.initVerbosity, - IT.initializeTestSuite = combine IT.initializeTestSuite, - IT.interactive = combine IT.interactive, - IT.language = combine IT.language, - IT.license = combine IT.license, - IT.mainIs = combine IT.mainIs, - IT.minimal = combine IT.minimal, - IT.noComments = combine IT.noComments, - IT.otherExts = combineMonoid savedInitFlags IT.otherExts, - IT.otherModules = combineMonoid savedInitFlags IT.otherModules, - IT.overwrite = combine IT.overwrite, - IT.packageDir = combine IT.packageDir, - IT.packageName = combine IT.packageName, - IT.packageType = combine IT.packageType, - IT.quiet = combine IT.quiet, - IT.simpleProject = combine IT.simpleProject, - IT.sourceDirs = combineMonoid savedInitFlags IT.sourceDirs, - IT.synopsis = combine IT.synopsis, - IT.testDirs = combineMonoid savedInitFlags IT.testDirs, - IT.version = combine IT.version - } + combinedSavedInitFlags = + IT.InitFlags + { IT.applicationDirs = combineMonoid savedInitFlags IT.applicationDirs + , IT.author = combine IT.author + , IT.buildTools = combineMonoid savedInitFlags IT.buildTools + , IT.cabalVersion = combine IT.cabalVersion + , IT.category = combine IT.category + , IT.dependencies = combineMonoid savedInitFlags IT.dependencies + , IT.email = combine IT.email + , IT.exposedModules = combineMonoid savedInitFlags IT.exposedModules + , IT.extraSrc = combineMonoid savedInitFlags IT.extraSrc + , IT.extraDoc = combineMonoid savedInitFlags IT.extraDoc + , IT.homepage = combine IT.homepage + , IT.initHcPath = combine IT.initHcPath + , IT.initVerbosity = combine IT.initVerbosity + , IT.initializeTestSuite = combine IT.initializeTestSuite + , IT.interactive = combine IT.interactive + , IT.language = combine IT.language + , IT.license = combine IT.license + , IT.mainIs = combine IT.mainIs + , IT.minimal = combine IT.minimal + , IT.noComments = combine IT.noComments + , IT.otherExts = combineMonoid savedInitFlags IT.otherExts + , IT.otherModules = combineMonoid savedInitFlags IT.otherModules + , IT.overwrite = combine IT.overwrite + , IT.packageDir = combine IT.packageDir + , IT.packageName = combine IT.packageName + , IT.packageType = combine IT.packageType + , IT.quiet = combine IT.quiet + , IT.simpleProject = combine IT.simpleProject + , IT.sourceDirs = combineMonoid savedInitFlags IT.sourceDirs + , IT.synopsis = combine IT.synopsis + , IT.testDirs = combineMonoid savedInitFlags IT.testDirs + , IT.version = combine IT.version + } where combine = combine' savedInitFlags - combinedSavedInstallFlags = InstallFlags { - installDocumentation = combine installDocumentation, - installHaddockIndex = combine installHaddockIndex, - installDryRun = combine installDryRun, - installOnlyDownload = combine installOnlyDownload, - installDest = combine installDest, - installMaxBackjumps = combine installMaxBackjumps, - installReorderGoals = combine installReorderGoals, - installCountConflicts = combine installCountConflicts, - installFineGrainedConflicts = combine installFineGrainedConflicts, - installMinimizeConflictSet = combine installMinimizeConflictSet, - installIndependentGoals = combine installIndependentGoals, - installPreferOldest = combine installPreferOldest, - installShadowPkgs = combine installShadowPkgs, - installStrongFlags = combine installStrongFlags, - installAllowBootLibInstalls = combine installAllowBootLibInstalls, - installOnlyConstrained = combine installOnlyConstrained, - installReinstall = combine installReinstall, - installAvoidReinstalls = combine installAvoidReinstalls, - installOverrideReinstall = combine installOverrideReinstall, - installUpgradeDeps = combine installUpgradeDeps, - installOnly = combine installOnly, - installOnlyDeps = combine installOnlyDeps, - installIndexState = combine installIndexState, - installRootCmd = combine installRootCmd, - installSummaryFile = lastNonEmptyNL installSummaryFile, - installLogFile = combine installLogFile, - installBuildReports = combine installBuildReports, - installReportPlanningFailure = combine installReportPlanningFailure, - installSymlinkBinDir = combine installSymlinkBinDir, - installPerComponent = combine installPerComponent, - installNumJobs = combine installNumJobs, - installKeepGoing = combine installKeepGoing, - installRunTests = combine installRunTests, - installOfflineMode = combine installOfflineMode - } + combinedSavedInstallFlags = + InstallFlags + { installDocumentation = combine installDocumentation + , installHaddockIndex = combine installHaddockIndex + , installDryRun = combine installDryRun + , installOnlyDownload = combine installOnlyDownload + , installDest = combine installDest + , installMaxBackjumps = combine installMaxBackjumps + , installReorderGoals = combine installReorderGoals + , installCountConflicts = combine installCountConflicts + , installFineGrainedConflicts = combine installFineGrainedConflicts + , installMinimizeConflictSet = combine installMinimizeConflictSet + , installIndependentGoals = combine installIndependentGoals + , installPreferOldest = combine installPreferOldest + , installShadowPkgs = combine installShadowPkgs + , installStrongFlags = combine installStrongFlags + , installAllowBootLibInstalls = combine installAllowBootLibInstalls + , installOnlyConstrained = combine installOnlyConstrained + , installReinstall = combine installReinstall + , installAvoidReinstalls = combine installAvoidReinstalls + , installOverrideReinstall = combine installOverrideReinstall + , installUpgradeDeps = combine installUpgradeDeps + , installOnly = combine installOnly + , installOnlyDeps = combine installOnlyDeps + , installIndexState = combine installIndexState + , installRootCmd = combine installRootCmd + , installSummaryFile = lastNonEmptyNL installSummaryFile + , installLogFile = combine installLogFile + , installBuildReports = combine installBuildReports + , installReportPlanningFailure = combine installReportPlanningFailure + , installSymlinkBinDir = combine installSymlinkBinDir + , installPerComponent = combine installPerComponent + , installNumJobs = combine installNumJobs + , installKeepGoing = combine installKeepGoing + , installRunTests = combine installRunTests + , installOfflineMode = combine installOfflineMode + } where - combine = combine' savedInstallFlags + combine = combine' savedInstallFlags lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags - combinedSavedClientInstallFlags = ClientInstallFlags - { cinstInstallLibs = combine cinstInstallLibs - , cinstEnvironmentPath = combine cinstEnvironmentPath - , cinstOverwritePolicy = combine cinstOverwritePolicy - , cinstInstallMethod = combine cinstInstallMethod - , cinstInstalldir = combine cinstInstalldir - } + combinedSavedClientInstallFlags = + ClientInstallFlags + { cinstInstallLibs = combine cinstInstallLibs + , cinstEnvironmentPath = combine cinstEnvironmentPath + , cinstOverwritePolicy = combine cinstOverwritePolicy + , cinstInstallMethod = combine cinstInstallMethod + , cinstInstalldir = combine cinstInstalldir + } where - combine = combine' savedClientInstallFlags - - combinedSavedConfigureFlags = ConfigFlags { - configArgs = lastNonEmpty configArgs, - configPrograms_ = configPrograms_ . savedConfigureFlags $ b, - -- TODO: NubListify - configProgramPaths = lastNonEmpty configProgramPaths, - -- TODO: NubListify - configProgramArgs = lastNonEmpty configProgramArgs, - configProgramPathExtra = lastNonEmptyNL configProgramPathExtra, - configInstantiateWith = lastNonEmpty configInstantiateWith, - configHcFlavor = combine configHcFlavor, - configHcPath = combine configHcPath, - configHcPkg = combine configHcPkg, - configVanillaLib = combine configVanillaLib, - configProfLib = combine configProfLib, - configProf = combine configProf, - configSharedLib = combine configSharedLib, - configStaticLib = combine configStaticLib, - configDynExe = combine configDynExe, - configFullyStaticExe = combine configFullyStaticExe, - configProfExe = combine configProfExe, - configProfDetail = combine configProfDetail, - configProfLibDetail = combine configProfLibDetail, - -- TODO: NubListify - configConfigureArgs = lastNonEmpty configConfigureArgs, - configOptimization = combine configOptimization, - configDebugInfo = combine configDebugInfo, - configProgPrefix = combine configProgPrefix, - configProgSuffix = combine configProgSuffix, - -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'. - configInstallDirs = - (configInstallDirs . savedConfigureFlags $ a) - `mappend` (configInstallDirs . savedConfigureFlags $ b), - configScratchDir = combine configScratchDir, - -- TODO: NubListify - configExtraLibDirs = lastNonEmpty configExtraLibDirs, - configExtraLibDirsStatic = lastNonEmpty configExtraLibDirsStatic, - -- TODO: NubListify - configExtraFrameworkDirs = lastNonEmpty configExtraFrameworkDirs, - -- TODO: NubListify - configExtraIncludeDirs = lastNonEmpty configExtraIncludeDirs, - 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, - configGHCiLib = combine configGHCiLib, - configSplitSections = combine configSplitSections, - configSplitObjs = combine configSplitObjs, - configStripExes = combine configStripExes, - configStripLibs = combine configStripLibs, - -- TODO: NubListify - configConstraints = lastNonEmpty configConstraints, - -- TODO: NubListify - configDependencies = lastNonEmpty configDependencies, - -- TODO: NubListify - configConfigurationsFlags = lastNonMempty configConfigurationsFlags, - configTests = combine configTests, - configBenchmarks = combine configBenchmarks, - configCoverage = combine configCoverage, - configLibCoverage = combine configLibCoverage, - configExactConfiguration = combine configExactConfiguration, - configFlagError = combine configFlagError, - configRelocatable = combine configRelocatable, - configUseResponseFiles = combine configUseResponseFiles, - configDumpBuildInfo = combine configDumpBuildInfo, - configAllowDependingOnPrivateLibs = - combine configAllowDependingOnPrivateLibs - } + combine = combine' savedClientInstallFlags + + combinedSavedConfigureFlags = + ConfigFlags + { configArgs = lastNonEmpty configArgs + , configPrograms_ = configPrograms_ . savedConfigureFlags $ b + , -- TODO: NubListify + configProgramPaths = lastNonEmpty configProgramPaths + , -- TODO: NubListify + configProgramArgs = lastNonEmpty configProgramArgs + , configProgramPathExtra = lastNonEmptyNL configProgramPathExtra + , configInstantiateWith = lastNonEmpty configInstantiateWith + , configHcFlavor = combine configHcFlavor + , configHcPath = combine configHcPath + , configHcPkg = combine configHcPkg + , configVanillaLib = combine configVanillaLib + , configProfLib = combine configProfLib + , configProf = combine configProf + , configSharedLib = combine configSharedLib + , configStaticLib = combine configStaticLib + , configDynExe = combine configDynExe + , configFullyStaticExe = combine configFullyStaticExe + , configProfExe = combine configProfExe + , configProfDetail = combine configProfDetail + , configProfLibDetail = combine configProfLibDetail + , -- TODO: NubListify + configConfigureArgs = lastNonEmpty configConfigureArgs + , configOptimization = combine configOptimization + , configDebugInfo = combine configDebugInfo + , configProgPrefix = combine configProgPrefix + , configProgSuffix = combine configProgSuffix + , -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'. + configInstallDirs = + (configInstallDirs . savedConfigureFlags $ a) + `mappend` (configInstallDirs . savedConfigureFlags $ b) + , configScratchDir = combine configScratchDir + , -- TODO: NubListify + configExtraLibDirs = lastNonEmpty configExtraLibDirs + , configExtraLibDirsStatic = lastNonEmpty configExtraLibDirsStatic + , -- TODO: NubListify + configExtraFrameworkDirs = lastNonEmpty configExtraFrameworkDirs + , -- TODO: NubListify + configExtraIncludeDirs = lastNonEmpty configExtraIncludeDirs + , 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 + , configGHCiLib = combine configGHCiLib + , configSplitSections = combine configSplitSections + , configSplitObjs = combine configSplitObjs + , configStripExes = combine configStripExes + , configStripLibs = combine configStripLibs + , -- TODO: NubListify + configConstraints = lastNonEmpty configConstraints + , -- TODO: NubListify + configDependencies = lastNonEmpty configDependencies + , -- TODO: NubListify + configConfigurationsFlags = lastNonMempty configConfigurationsFlags + , configTests = combine configTests + , configBenchmarks = combine configBenchmarks + , configCoverage = combine configCoverage + , configLibCoverage = combine configLibCoverage + , configExactConfiguration = combine configExactConfiguration + , configFlagError = combine configFlagError + , configRelocatable = combine configRelocatable + , configUseResponseFiles = combine configUseResponseFiles + , configDumpBuildInfo = combine configDumpBuildInfo + , configAllowDependingOnPrivateLibs = + combine configAllowDependingOnPrivateLibs + } where - combine = combine' savedConfigureFlags - lastNonEmpty = lastNonEmpty' savedConfigureFlags + combine = combine' savedConfigureFlags + lastNonEmpty = lastNonEmpty' savedConfigureFlags lastNonEmptyNL = lastNonEmptyNL' savedConfigureFlags - lastNonMempty = lastNonMempty' savedConfigureFlags - - combinedSavedConfigureExFlags = ConfigExFlags { - configCabalVersion = combine configCabalVersion, - configAppend = combine configAppend, - configBackup = combine configBackup, - -- TODO: NubListify - configExConstraints = lastNonEmpty configExConstraints, - -- TODO: NubListify - configPreferences = lastNonEmpty configPreferences, - configSolver = combine configSolver, - configAllowNewer = - combineMonoid savedConfigureExFlags configAllowNewer, - configAllowOlder = - combineMonoid savedConfigureExFlags configAllowOlder, - configWriteGhcEnvironmentFilesPolicy - = combine configWriteGhcEnvironmentFilesPolicy - } + lastNonMempty = lastNonMempty' savedConfigureFlags + + combinedSavedConfigureExFlags = + ConfigExFlags + { configCabalVersion = combine configCabalVersion + , configAppend = combine configAppend + , configBackup = combine configBackup + , -- TODO: NubListify + configExConstraints = lastNonEmpty configExConstraints + , -- TODO: NubListify + configPreferences = lastNonEmpty configPreferences + , configSolver = combine configSolver + , configAllowNewer = + combineMonoid savedConfigureExFlags configAllowNewer + , configAllowOlder = + combineMonoid savedConfigureExFlags configAllowOlder + , configWriteGhcEnvironmentFilesPolicy = + combine configWriteGhcEnvironmentFilesPolicy + } where - combine = combine' savedConfigureExFlags + combine = combine' savedConfigureExFlags lastNonEmpty = lastNonEmpty' savedConfigureExFlags -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'. - combinedSavedUserInstallDirs = savedUserInstallDirs a - `mappend` savedUserInstallDirs b + combinedSavedUserInstallDirs = + savedUserInstallDirs a + `mappend` savedUserInstallDirs b -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'. - combinedSavedGlobalInstallDirs = savedGlobalInstallDirs a - `mappend` savedGlobalInstallDirs b - - combinedSavedUploadFlags = UploadFlags { - uploadCandidate = combine uploadCandidate, - uploadDoc = combine uploadDoc, - uploadUsername = combine uploadUsername, - uploadPassword = combine uploadPassword, - uploadPasswordCmd = combine uploadPasswordCmd, - uploadVerbosity = combine uploadVerbosity - } + combinedSavedGlobalInstallDirs = + savedGlobalInstallDirs a + `mappend` savedGlobalInstallDirs b + + combinedSavedUploadFlags = + UploadFlags + { uploadCandidate = combine uploadCandidate + , uploadDoc = combine uploadDoc + , uploadUsername = combine uploadUsername + , uploadPassword = combine uploadPassword + , uploadPasswordCmd = combine uploadPasswordCmd + , uploadVerbosity = combine uploadVerbosity + } where combine = combine' savedUploadFlags - combinedSavedReportFlags = ReportFlags { - reportUsername = combine reportUsername, - reportPassword = combine reportPassword, - reportVerbosity = combine reportVerbosity - } + combinedSavedReportFlags = + ReportFlags + { reportUsername = combine reportUsername + , reportPassword = combine reportPassword + , reportVerbosity = combine reportVerbosity + } where combine = combine' savedReportFlags - combinedSavedHaddockFlags = HaddockFlags { - -- TODO: NubListify - haddockProgramPaths = lastNonEmpty haddockProgramPaths, - -- TODO: NubListify - haddockProgramArgs = lastNonEmpty haddockProgramArgs, - haddockHoogle = combine haddockHoogle, - haddockHtml = combine haddockHtml, - haddockHtmlLocation = combine haddockHtmlLocation, - haddockForHackage = combine haddockForHackage, - haddockExecutables = combine haddockExecutables, - haddockTestSuites = combine haddockTestSuites, - haddockBenchmarks = combine haddockBenchmarks, - haddockForeignLibs = combine haddockForeignLibs, - haddockInternal = combine haddockInternal, - haddockCss = combine haddockCss, - haddockLinkedSource = combine haddockLinkedSource, - 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, - haddockOutputDir = combine haddockOutputDir, - haddockArgs = lastNonEmpty haddockArgs - } + combinedSavedHaddockFlags = + HaddockFlags + { -- TODO: NubListify + haddockProgramPaths = lastNonEmpty haddockProgramPaths + , -- TODO: NubListify + haddockProgramArgs = lastNonEmpty haddockProgramArgs + , haddockHoogle = combine haddockHoogle + , haddockHtml = combine haddockHtml + , haddockHtmlLocation = combine haddockHtmlLocation + , haddockForHackage = combine haddockForHackage + , haddockExecutables = combine haddockExecutables + , haddockTestSuites = combine haddockTestSuites + , haddockBenchmarks = combine haddockBenchmarks + , haddockForeignLibs = combine haddockForeignLibs + , haddockInternal = combine haddockInternal + , haddockCss = combine haddockCss + , haddockLinkedSource = combine haddockLinkedSource + , 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 + , haddockOutputDir = combine haddockOutputDir + , haddockArgs = lastNonEmpty haddockArgs + } where - combine = combine' savedHaddockFlags - lastNonEmpty = lastNonEmpty' savedHaddockFlags - - combinedSavedTestFlags = TestFlags { - testDistPref = combine testDistPref, - testVerbosity = combine testVerbosity, - testHumanLog = combine testHumanLog, - testMachineLog = combine testMachineLog, - testShowDetails = combine testShowDetails, - testKeepTix = combine testKeepTix, - testWrapper = combine testWrapper, - testFailWhenNoTestSuites = combine testFailWhenNoTestSuites, - testOptions = lastNonEmpty testOptions - } + combine = combine' savedHaddockFlags + lastNonEmpty = lastNonEmpty' savedHaddockFlags + + combinedSavedTestFlags = + TestFlags + { testDistPref = combine testDistPref + , testVerbosity = combine testVerbosity + , testHumanLog = combine testHumanLog + , testMachineLog = combine testMachineLog + , testShowDetails = combine testShowDetails + , testKeepTix = combine testKeepTix + , testWrapper = combine testWrapper + , testFailWhenNoTestSuites = combine testFailWhenNoTestSuites + , testOptions = lastNonEmpty testOptions + } where - combine = combine' savedTestFlags - lastNonEmpty = lastNonEmpty' savedTestFlags - - combinedSavedBenchmarkFlags = BenchmarkFlags { - benchmarkDistPref = combine benchmarkDistPref, - benchmarkVerbosity = combine benchmarkVerbosity, - benchmarkOptions = lastNonEmpty benchmarkOptions - } + combine = combine' savedTestFlags + lastNonEmpty = lastNonEmpty' savedTestFlags + + combinedSavedBenchmarkFlags = + BenchmarkFlags + { benchmarkDistPref = combine benchmarkDistPref + , benchmarkVerbosity = combine benchmarkVerbosity + , benchmarkOptions = lastNonEmpty benchmarkOptions + } where - combine = combine' savedBenchmarkFlags - lastNonEmpty = lastNonEmpty' savedBenchmarkFlags - - combinedSavedProjectFlags = ProjectFlags - { flagProjectDir = combine flagProjectDir - , flagProjectFile = combine flagProjectFile - , flagIgnoreProject = combine flagIgnoreProject - } + combine = combine' savedBenchmarkFlags + lastNonEmpty = lastNonEmpty' savedBenchmarkFlags + + combinedSavedProjectFlags = + ProjectFlags + { flagProjectDir = combine flagProjectDir + , flagProjectFile = combine flagProjectFile + , flagIgnoreProject = combine flagIgnoreProject + } where - combine = combine' savedProjectFlags + combine = combine' savedProjectFlags -- + -- * Default config + -- -- | These are the absolute basic defaults. The fields that must be -- initialised. When we load the config from the file we layer the loaded -- values over these ones, so any missing fields in the file take their values -- from here. --- baseSavedConfig :: IO SavedConfig baseSavedConfig = do userPrefix <- defaultInstallPrefix - cacheDir <- defaultCacheDir - logsDir <- defaultLogsDir - return mempty { - savedConfigureFlags = mempty { - configHcFlavor = toFlag defaultCompiler, - configUserInstall = toFlag defaultUserInstall, - configVerbosity = toFlag normal - }, - savedUserInstallDirs = mempty { - prefix = toFlag (toPathTemplate userPrefix) - }, - savedGlobalFlags = mempty { - globalCacheDir = toFlag cacheDir, - globalLogsDir = toFlag logsDir - } - } + cacheDir <- defaultCacheDir + logsDir <- defaultLogsDir + return + mempty + { savedConfigureFlags = + mempty + { configHcFlavor = toFlag defaultCompiler + , configUserInstall = toFlag defaultUserInstall + , configVerbosity = toFlag normal + } + , savedUserInstallDirs = + mempty + { prefix = toFlag (toPathTemplate userPrefix) + } + , savedGlobalFlags = + mempty + { globalCacheDir = toFlag cacheDir + , globalLogsDir = toFlag logsDir + } + } -- | This is the initial configuration that we write out to the config file -- if the file does not exist (or the config we use if the file cannot be read -- for some other reason). When the config gets loaded it gets layered on top -- of 'baseSavedConfig' so we do not need to include it into the initial -- values we save into the config file. --- initialSavedConfig :: IO SavedConfig initialSavedConfig = do - cacheDir <- defaultCacheDir - logsDir <- defaultLogsDir - extraPath <- defaultExtraPath + cacheDir <- defaultCacheDir + logsDir <- defaultLogsDir + extraPath <- defaultExtraPath installPath <- defaultInstallPath - return mempty { - savedGlobalFlags = mempty { - globalCacheDir = toFlag cacheDir, - globalRemoteRepos = toNubList [defaultRemoteRepo] - }, - savedConfigureFlags = mempty { - configProgramPathExtra = toNubList extraPath - }, - savedInstallFlags = mempty { - installSummaryFile = toNubList [toPathTemplate (logsDir "build.log")], - installBuildReports= toFlag NoReports, - installNumJobs = toFlag Nothing - }, - savedClientInstallFlags = mempty { - cinstInstalldir = toFlag installPath - } - } + return + mempty + { savedGlobalFlags = + mempty + { globalCacheDir = toFlag cacheDir + , globalRemoteRepos = toNubList [defaultRemoteRepo] + } + , savedConfigureFlags = + mempty + { configProgramPathExtra = toNubList extraPath + } + , savedInstallFlags = + mempty + { installSummaryFile = toNubList [toPathTemplate (logsDir "build.log")] + , installBuildReports = toFlag NoReports + , installNumJobs = toFlag Nothing + } + , savedClientInstallFlags = + mempty + { cinstInstalldir = toFlag installPath + } + } -- | If @CABAL\_DIR@ is set or @~/.cabal@ exists, return that -- directory. Otherwise returns Nothing. If this function returns @@ -606,9 +731,10 @@ maybeGetCabalDir = do Nothing -> do defaultDir <- getAppUserDataDirectory "cabal" dotCabalExists <- doesDirectoryExist defaultDir - return $ if dotCabalExists - then Just defaultDir - else Nothing + return $ + if dotCabalExists + then Just defaultDir + else Nothing -- | The default behaviour of cabal-install is to use the XDG -- directory standard. However, if @CABAL_DIR@ is set, we instead use @@ -683,19 +809,21 @@ defaultCompiler = fromMaybe GHC defaultCompilerFlavor defaultUserInstall :: Bool defaultUserInstall = True + -- We do per-user installs by default on all platforms. We used to default to -- global installs on Windows but that no longer works on Windows Vista or 7. defaultRemoteRepo :: RemoteRepo defaultRemoteRepo = RemoteRepo name uri Nothing [] 0 False where - str = "hackage.haskell.org" + str = "hackage.haskell.org" name = RepoName str - uri = URI "http:" (Just (URIAuth "" str "")) "/" "" "" - -- Note that lots of old config files will have the old url - -- http://hackage.haskell.org/packages/archive - -- but new config files can use the new url (without the /packages/archive) - -- and avoid having to do a http redirect + uri = URI "http:" (Just (URIAuth "" str "")) "/" "" "" + +-- Note that lots of old config files will have the old url +-- http://hackage.haskell.org/packages/archive +-- but new config files can use the new url (without the /packages/archive) +-- and avoid having to do a http redirect -- For the default repo we know extra information, fill this in. -- @@ -706,32 +834,35 @@ defaultRemoteRepo = RemoteRepo name uri Nothing [] 0 False -- addInfoForKnownRepos :: RemoteRepo -> RemoteRepo addInfoForKnownRepos repo - | remoteRepoName repo == remoteRepoName defaultRemoteRepo - = useSecure . tryHttps . fixOldURI $ repo + | remoteRepoName repo == remoteRepoName defaultRemoteRepo = + useSecure . tryHttps . fixOldURI $ repo where fixOldURI r - | isOldHackageURI (remoteRepoURI r) - = r { remoteRepoURI = remoteRepoURI defaultRemoteRepo } + | isOldHackageURI (remoteRepoURI r) = + r{remoteRepoURI = remoteRepoURI defaultRemoteRepo} | otherwise = r - tryHttps r = r { remoteRepoShouldTryHttps = True } + tryHttps r = r{remoteRepoShouldTryHttps = True} - useSecure r@RemoteRepo{ - remoteRepoSecure = secure, - remoteRepoRootKeys = [], - remoteRepoKeyThreshold = 0 - } | secure /= Just False - = r { - -- Use hackage-security by default unless you opt-out with + useSecure + r@RemoteRepo + { remoteRepoSecure = secure + , remoteRepoRootKeys = [] + , remoteRepoKeyThreshold = 0 + } + | secure /= Just False = + r + { -- Use hackage-security by default unless you opt-out with -- secure: False - remoteRepoSecure = Just True, - remoteRepoRootKeys = defaultHackageRemoteRepoKeys, - remoteRepoKeyThreshold = defaultHackageRemoteRepoKeyThreshold + remoteRepoSecure = Just True + , remoteRepoRootKeys = defaultHackageRemoteRepoKeys + , remoteRepoKeyThreshold = defaultHackageRemoteRepoKeyThreshold } useSecure r = r addInfoForKnownRepos other = other -- | The current hackage.haskell.org repo root keys that we ship with cabal. + --- -- This lets us bootstrap trust in this repo without user intervention. -- These keys need to be periodically updated when new root keys are added. @@ -739,39 +870,39 @@ addInfoForKnownRepos other = other -- defaultHackageRemoteRepoKeys :: [String] defaultHackageRemoteRepoKeys = - -- Key owners and public keys are provided as a convenience to readers. - -- The canonical source for this mapping data is the hackage-root-keys - -- repository and Hackage's root.json file. - -- - -- Links: - -- * https://github.com/haskell-infra/hackage-root-keys - -- * https://hackage.haskell.org/root.json - -- Please consult root.json on Hackage to map key IDs to public keys, - -- and the hackage-root-keys repository to map public keys to their - -- owners. - [ -- Adam Gundry (uRPdSiL3/MNsk50z6NB55ABo0OrrNDXigtCul4vtzmw=) - "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0", - -- Gershom Bazerman (bYoUXXQ9TtX10UriaMiQtTccuXPGnmldP68djzZ7cLo=) - "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42", - -- John Wiegley (zazm5w480r+zPO6Z0+8fjGuxZtb9pAuoVmQ+VkuCvgU=) - "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d", - -- Norman Ramsey (ZI8di3a9Un0s2RBrt5GwVRvfOXVuywADfXGPZfkiDb0=) - "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" - ] + -- Key owners and public keys are provided as a convenience to readers. + -- The canonical source for this mapping data is the hackage-root-keys + -- repository and Hackage's root.json file. + -- + -- Links: + -- * https://github.com/haskell-infra/hackage-root-keys + -- * https://hackage.haskell.org/root.json + -- Please consult root.json on Hackage to map key IDs to public keys, + -- and the hackage-root-keys repository to map public keys to their + -- owners. + [ -- Adam Gundry (uRPdSiL3/MNsk50z6NB55ABo0OrrNDXigtCul4vtzmw=) + "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" + , -- Gershom Bazerman (bYoUXXQ9TtX10UriaMiQtTccuXPGnmldP68djzZ7cLo=) + "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" + , -- John Wiegley (zazm5w480r+zPO6Z0+8fjGuxZtb9pAuoVmQ+VkuCvgU=) + "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" + , -- Norman Ramsey (ZI8di3a9Un0s2RBrt5GwVRvfOXVuywADfXGPZfkiDb0=) + "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" + ] -- | The required threshold of root key signatures for hackage.haskell.org --- defaultHackageRemoteRepoKeyThreshold :: Int defaultHackageRemoteRepoKeyThreshold = 3 -- + -- * Config file reading + -- -- | Loads the main configuration, and applies additional defaults to give the -- effective configuration. To loads just what is actually in the config file, -- use 'loadRawConfig'. --- loadConfig :: Verbosity -> Flag FilePath -> IO SavedConfig loadConfig verbosity configFileFlag = do config <- loadRawConfig verbosity configFileFlag @@ -780,22 +911,24 @@ loadConfig verbosity configFileFlag = do extendToEffectiveConfig :: SavedConfig -> IO SavedConfig extendToEffectiveConfig config = do base <- baseSavedConfig - let effective0 = base `mappend` config + let effective0 = base `mappend` config globalFlags0 = savedGlobalFlags effective0 - effective = effective0 { - savedGlobalFlags = globalFlags0 { - globalRemoteRepos = - overNubList (map addInfoForKnownRepos) - (globalRemoteRepos globalFlags0) - } - } + effective = + effective0 + { savedGlobalFlags = + globalFlags0 + { globalRemoteRepos = + overNubList + (map addInfoForKnownRepos) + (globalRemoteRepos globalFlags0) + } + } return effective -- | Like 'loadConfig' but does not apply any additional defaults, it just -- loads what is actually in the config file. This is thus suitable for -- comparing or editing a config file, but not suitable for using as the -- effective configuration. --- loadRawConfig :: Verbosity -> Flag FilePath -> IO SavedConfig loadRawConfig verbosity configFileFlag = do (source, configFile) <- getConfigFilePathAndSource configFileFlag @@ -811,34 +944,39 @@ loadRawConfig verbosity configFileFlag = do Default -> do notice verbosity msgNotFound createDefaultConfigFile verbosity [] configFile - CommandlineOption -> failNoConfigFile + CommandlineOption -> failNoConfigFile EnvironmentVariable -> failNoConfigFile where - msgNotFound = unwords [ "Config file not found:", configFile ] - failNoConfigFile = die' verbosity $ unlines - [ msgNotFound - , "(Config files can be created via the cabal-command 'user-config init'.)" - ] + msgNotFound = unwords ["Config file not found:", configFile] + failNoConfigFile = + die' verbosity $ + unlines + [ msgNotFound + , "(Config files can be created via the cabal-command 'user-config init'.)" + ] Just (ParseOk ws conf) -> do - unless (null ws) $ warn verbosity $ - unlines (map (showPWarning configFile) ws) + unless (null ws) $ + warn verbosity $ + unlines (map (showPWarning configFile) ws) return conf Just (ParseFailed err) -> do let (line, msg) = locatedErrorMsg err die' verbosity $ - "Error parsing config file " ++ configFile - ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg - + "Error parsing config file " + ++ configFile + ++ maybe "" (\n -> ':' : show n) line + ++ ":\n" + ++ msg where - sourceMsg CommandlineOption = "commandline option" + sourceMsg CommandlineOption = "commandline option" sourceMsg EnvironmentVariable = "environment variable CABAL_CONFIG" - sourceMsg Default = "default config file" + sourceMsg Default = "default config file" -- | Provenance of the config file. - -data ConfigFileSource = CommandlineOption - | EnvironmentVariable - | Default +data ConfigFileSource + = CommandlineOption + | EnvironmentVariable + | Default -- | Returns the config file path, without checking that the file exists. -- The order of precedence is: input flag, CABAL_CONFIG, default location. @@ -847,23 +985,25 @@ getConfigFilePath = fmap snd . getConfigFilePathAndSource getConfigFilePathAndSource :: Flag FilePath -> IO (ConfigFileSource, FilePath) getConfigFilePathAndSource configFileFlag = - getSource sources + getSource sources where sources = - [ (CommandlineOption, return . flagToMaybe $ configFileFlag) + [ (CommandlineOption, return . flagToMaybe $ configFileFlag) , (EnvironmentVariable, lookup "CABAL_CONFIG" `liftM` getEnvironment) - , (Default, Just `liftM` defaultConfigFile) ] + , (Default, Just `liftM` defaultConfigFile) + ] getSource [] = error "no config file path candidate found." - getSource ((source,action): xs) = - action >>= maybe (getSource xs) (return . (,) source) + getSource ((source, action) : xs) = + action >>= maybe (getSource xs) (return . (,) source) readConfigFile :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig)) -readConfigFile initial file = handleNotExists $ - fmap (Just . parseConfig (ConstraintSourceMainConfig file) initial) - (BS.readFile file) - +readConfigFile initial file = + handleNotExists $ + fmap + (Just . parseConfig (ConstraintSourceMainConfig file) initial) + (BS.readFile file) where handleNotExists action = catchIO action $ \ioe -> if isDoesNotExistError ioe @@ -871,10 +1011,10 @@ readConfigFile initial file = handleNotExists $ else ioError ioe createDefaultConfigFile :: Verbosity -> [String] -> FilePath -> IO SavedConfig -createDefaultConfigFile verbosity extraLines filePath = do +createDefaultConfigFile verbosity extraLines filePath = do commentConf <- commentSavedConfig initialConf <- initialSavedConfig - extraConf <- parseExtraLines verbosity extraLines + extraConf <- parseExtraLines verbosity extraLines notice verbosity $ "Writing default configuration to " ++ filePath writeConfigFile filePath commentConf (initialConf `mappend` extraConf) return initialConf @@ -887,523 +1027,656 @@ writeConfigFile file comments vals = do explanation ++ showConfigWithComments comments vals ++ "\n" renameFile tmpFile file where - explanation = unlines - ["-- This is the configuration file for the 'cabal' command line tool." - ,"--" - ,"-- The available configuration options are listed below." - ,"-- Some of them have default values listed." - ,"--" - ,"-- Lines (like this one) beginning with '--' are comments." - ,"-- Be careful with spaces and indentation because they are" - ,"-- used to indicate layout for nested sections." - ,"--" - ,"-- This config file was generated using the following versions" - ,"-- of Cabal and cabal-install:" - ,"-- Cabal library version: " ++ prettyShow cabalVersion - ,"-- cabal-install version: " ++ prettyShow cabalInstallVersion - ,"","" - ] + explanation = + unlines + [ "-- This is the configuration file for the 'cabal' command line tool." + , "--" + , "-- The available configuration options are listed below." + , "-- Some of them have default values listed." + , "--" + , "-- Lines (like this one) beginning with '--' are comments." + , "-- Be careful with spaces and indentation because they are" + , "-- used to indicate layout for nested sections." + , "--" + , "-- This config file was generated using the following versions" + , "-- of Cabal and cabal-install:" + , "-- Cabal library version: " ++ prettyShow cabalVersion + , "-- cabal-install version: " ++ prettyShow cabalInstallVersion + , "" + , "" + ] -- | These are the default values that get used in Cabal if a no value is -- given. We use these here to include in comments when we write out the -- initial config file so that the user can see what default value they are -- overriding. --- commentSavedConfig :: IO SavedConfig commentSavedConfig = do - userInstallDirs <- defaultInstallDirs defaultCompiler True True + userInstallDirs <- defaultInstallDirs defaultCompiler True True globalInstallDirs <- defaultInstallDirs defaultCompiler False True - let conf0 = mempty { - savedGlobalFlags = defaultGlobalFlags { - globalRemoteRepos = toNubList [defaultRemoteRepo], - globalNix = mempty - }, - savedInitFlags = mempty { - IT.interactive = toFlag False, - IT.cabalVersion = toFlag IT.defaultCabalVersion, - IT.language = toFlag Haskell2010, - IT.license = NoFlag, - IT.sourceDirs = Flag [IT.defaultSourceDir], - IT.applicationDirs = Flag [IT.defaultApplicationDir], - IT.quiet = Flag False, - IT.noComments = Flag False, - IT.minimal = Flag False, - IT.simpleProject = Flag False - }, - savedInstallFlags = defaultInstallFlags, - savedClientInstallFlags= defaultClientInstallFlags, - savedConfigureExFlags = defaultConfigExFlags { - configAllowNewer = Just (AllowNewer mempty), - configAllowOlder = Just (AllowOlder mempty) - }, - savedConfigureFlags = (defaultConfigFlags defaultProgramDb) { - configUserInstall = toFlag defaultUserInstall - }, - savedUserInstallDirs = fmap toFlag userInstallDirs, - savedGlobalInstallDirs = fmap toFlag globalInstallDirs, - savedUploadFlags = commandDefaultFlags uploadCommand, - savedReportFlags = commandDefaultFlags reportCommand, - savedHaddockFlags = defaultHaddockFlags, - savedTestFlags = defaultTestFlags, - savedBenchmarkFlags = defaultBenchmarkFlags - } + let conf0 = + mempty + { savedGlobalFlags = + defaultGlobalFlags + { globalRemoteRepos = toNubList [defaultRemoteRepo] + , globalNix = mempty + } + , savedInitFlags = + mempty + { IT.interactive = toFlag False + , IT.cabalVersion = toFlag IT.defaultCabalVersion + , IT.language = toFlag Haskell2010 + , IT.license = NoFlag + , IT.sourceDirs = Flag [IT.defaultSourceDir] + , IT.applicationDirs = Flag [IT.defaultApplicationDir] + , IT.quiet = Flag False + , IT.noComments = Flag False + , IT.minimal = Flag False + , IT.simpleProject = Flag False + } + , savedInstallFlags = defaultInstallFlags + , savedClientInstallFlags = defaultClientInstallFlags + , savedConfigureExFlags = + defaultConfigExFlags + { configAllowNewer = Just (AllowNewer mempty) + , configAllowOlder = Just (AllowOlder mempty) + } + , savedConfigureFlags = + (defaultConfigFlags defaultProgramDb) + { configUserInstall = toFlag defaultUserInstall + } + , savedUserInstallDirs = fmap toFlag userInstallDirs + , savedGlobalInstallDirs = fmap toFlag globalInstallDirs + , savedUploadFlags = commandDefaultFlags uploadCommand + , savedReportFlags = commandDefaultFlags reportCommand + , savedHaddockFlags = defaultHaddockFlags + , savedTestFlags = defaultTestFlags + , savedBenchmarkFlags = defaultBenchmarkFlags + } conf1 <- extendToEffectiveConfig conf0 let globalFlagsConf1 = savedGlobalFlags conf1 - conf2 = conf1 { - savedGlobalFlags = globalFlagsConf1 { - globalRemoteRepos = overNubList (map removeRootKeys) - (globalRemoteRepos globalFlagsConf1) - } - } + conf2 = + conf1 + { savedGlobalFlags = + globalFlagsConf1 + { globalRemoteRepos = + overNubList + (map removeRootKeys) + (globalRemoteRepos globalFlagsConf1) + } + } return conf2 - where - -- Most people don't want to see default root keys, so don't print them. - removeRootKeys :: RemoteRepo -> RemoteRepo - removeRootKeys r = r { remoteRepoRootKeys = [] } + where + -- Most people don't want to see default root keys, so don't print them. + removeRootKeys :: RemoteRepo -> RemoteRepo + removeRootKeys r = r{remoteRepoRootKeys = []} -- | All config file fields. --- configFieldDescriptions :: ConstraintSource -> [FieldDescr SavedConfig] configFieldDescriptions src = - - toSavedConfig liftGlobalFlag - (commandOptions (globalCommand []) ParseArgs) - ["version", "numeric-version", "config-file"] [] - - ++ toSavedConfig liftConfigFlag - (configureOptions ParseArgs) - (["builddir", "constraint", "dependency", "ipid"] - ++ map fieldName installDirsFields) - - -- This is only here because viewAsFieldDescr gives us a parser - -- that only recognises 'ghc' etc, the case-sensitive flag names, not - -- what the normal case-insensitive parser gives us. - [simpleFieldParsec "compiler" - (fromFlagOrDefault Disp.empty . fmap pretty) (Flag <$> parsec <|> pure NoFlag) - configHcFlavor (\v flags -> flags { configHcFlavor = v }) - - -- TODO: The following is a temporary fix. The "optimization" + toSavedConfig + liftGlobalFlag + (commandOptions (globalCommand []) ParseArgs) + ["version", "numeric-version", "config-file"] + [] + ++ toSavedConfig + liftConfigFlag + (configureOptions ParseArgs) + ( ["builddir", "constraint", "dependency", "ipid"] + ++ map fieldName installDirsFields + ) + -- This is only here because viewAsFieldDescr gives us a parser + -- that only recognises 'ghc' etc, the case-sensitive flag names, not + -- what the normal case-insensitive parser gives us. + [ simpleFieldParsec + "compiler" + (fromFlagOrDefault Disp.empty . fmap pretty) + (Flag <$> parsec <|> pure NoFlag) + configHcFlavor + (\v flags -> flags{configHcFlavor = v}) + , -- TODO: The following is a temporary fix. The "optimization" -- and "debug-info" fields are OptArg, and viewAsFieldDescr -- fails on that. Instead of a hand-written hackaged parser -- and printer, we should handle this case properly in the -- library. - ,liftField configOptimization (\v flags -> - flags { configOptimization = v }) $ - let name = "optimization" in - FieldDescr name - (\f -> case f of - Flag NoOptimisation -> Disp.text "False" - Flag NormalOptimisation -> Disp.text "True" - Flag MaximumOptimisation -> Disp.text "2" - _ -> Disp.empty) - (\line str _ -> case () of - _ | str == "False" -> ParseOk [] (Flag NoOptimisation) - | str == "True" -> ParseOk [] (Flag NormalOptimisation) - | str == "0" -> ParseOk [] (Flag NoOptimisation) - | str == "1" -> ParseOk [] (Flag NormalOptimisation) - | str == "2" -> ParseOk [] (Flag MaximumOptimisation) - | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation) - | lstr == "true" -> ParseOk [caseWarning] - (Flag NormalOptimisation) - | otherwise -> ParseFailed (NoParse name line) - where - lstr = lowercase str - caseWarning = PWarning $ - "The '" ++ name - ++ "' field is case sensitive, use 'True' or 'False'.") - ,liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $ - let name = "debug-info" in - FieldDescr name - (\f -> case f of - Flag NoDebugInfo -> Disp.text "False" - Flag MinimalDebugInfo -> Disp.text "1" - Flag NormalDebugInfo -> Disp.text "True" - Flag MaximalDebugInfo -> Disp.text "3" - _ -> Disp.empty) - (\line str _ -> case () of - _ | str == "False" -> ParseOk [] (Flag NoDebugInfo) - | str == "True" -> ParseOk [] (Flag NormalDebugInfo) - | str == "0" -> ParseOk [] (Flag NoDebugInfo) - | str == "1" -> ParseOk [] (Flag MinimalDebugInfo) - | str == "2" -> ParseOk [] (Flag NormalDebugInfo) - | str == "3" -> ParseOk [] (Flag MaximalDebugInfo) - | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo) - | lstr == "true" -> ParseOk [caseWarning] (Flag NormalDebugInfo) - | otherwise -> ParseFailed (NoParse name line) - where - lstr = lowercase str - caseWarning = PWarning $ - "The '" ++ name - ++ "' field is case sensitive, use 'True' or 'False'.") - ] - - ++ toSavedConfig liftConfigExFlag - (configureExOptions ParseArgs src) - [] - [let pkgs = (Just . AllowOlder . RelaxDepsSome) - `fmap` parsecOptCommaList parsec - parseAllowOlder = ((Just . AllowOlder . toRelaxDeps) - `fmap` parsec) <|> pkgs - in simpleFieldParsec "allow-older" - (showRelaxDeps . fmap unAllowOlder) parseAllowOlder - configAllowOlder (\v flags -> flags { configAllowOlder = v }) - ,let pkgs = (Just . AllowNewer . RelaxDepsSome) - `fmap` parsecOptCommaList parsec - parseAllowNewer = ((Just . AllowNewer . toRelaxDeps) - `fmap` parsec) <|> pkgs - in simpleFieldParsec "allow-newer" - (showRelaxDeps . fmap unAllowNewer) parseAllowNewer - configAllowNewer (\v flags -> flags { configAllowNewer = v }) + liftField + configOptimization + ( \v flags -> + flags{configOptimization = v} + ) + $ let name = "optimization" + in FieldDescr + name + ( \f -> case f of + Flag NoOptimisation -> Disp.text "False" + Flag NormalOptimisation -> Disp.text "True" + Flag MaximumOptimisation -> Disp.text "2" + _ -> Disp.empty + ) + ( \line str _ -> case () of + _ + | str == "False" -> ParseOk [] (Flag NoOptimisation) + | str == "True" -> ParseOk [] (Flag NormalOptimisation) + | str == "0" -> ParseOk [] (Flag NoOptimisation) + | str == "1" -> ParseOk [] (Flag NormalOptimisation) + | str == "2" -> ParseOk [] (Flag MaximumOptimisation) + | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation) + | lstr == "true" -> + ParseOk + [caseWarning] + (Flag NormalOptimisation) + | otherwise -> ParseFailed (NoParse name line) + where + lstr = lowercase str + caseWarning = + PWarning $ + "The '" + ++ name + ++ "' field is case sensitive, use 'True' or 'False'." + ) + , liftField configDebugInfo (\v flags -> flags{configDebugInfo = v}) $ + let name = "debug-info" + in FieldDescr + name + ( \f -> case f of + Flag NoDebugInfo -> Disp.text "False" + Flag MinimalDebugInfo -> Disp.text "1" + Flag NormalDebugInfo -> Disp.text "True" + Flag MaximalDebugInfo -> Disp.text "3" + _ -> Disp.empty + ) + ( \line str _ -> case () of + _ + | str == "False" -> ParseOk [] (Flag NoDebugInfo) + | str == "True" -> ParseOk [] (Flag NormalDebugInfo) + | str == "0" -> ParseOk [] (Flag NoDebugInfo) + | str == "1" -> ParseOk [] (Flag MinimalDebugInfo) + | str == "2" -> ParseOk [] (Flag NormalDebugInfo) + | str == "3" -> ParseOk [] (Flag MaximalDebugInfo) + | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo) + | lstr == "true" -> ParseOk [caseWarning] (Flag NormalDebugInfo) + | otherwise -> ParseFailed (NoParse name line) + where + lstr = lowercase str + caseWarning = + PWarning $ + "The '" + ++ name + ++ "' field is case sensitive, use 'True' or 'False'." + ) + ] + ++ toSavedConfig + liftConfigExFlag + (configureExOptions ParseArgs src) + [] + [ let pkgs = + (Just . AllowOlder . RelaxDepsSome) + `fmap` parsecOptCommaList parsec + parseAllowOlder = + ( (Just . AllowOlder . toRelaxDeps) + `fmap` parsec + ) + <|> pkgs + in simpleFieldParsec + "allow-older" + (showRelaxDeps . fmap unAllowOlder) + parseAllowOlder + configAllowOlder + (\v flags -> flags{configAllowOlder = v}) + , let pkgs = + (Just . AllowNewer . RelaxDepsSome) + `fmap` parsecOptCommaList parsec + parseAllowNewer = + ( (Just . AllowNewer . toRelaxDeps) + `fmap` parsec + ) + <|> pkgs + in simpleFieldParsec + "allow-newer" + (showRelaxDeps . fmap unAllowNewer) + parseAllowNewer + configAllowNewer + (\v flags -> flags{configAllowNewer = v}) + ] + ++ toSavedConfig + liftInstallFlag + (installOptions ParseArgs) + ["dry-run", "only", "only-dependencies", "dependencies-only"] + [] + ++ toSavedConfig + liftClientInstallFlag + (clientInstallOptions ParseArgs) + [] + [] + ++ toSavedConfig + liftUploadFlag + (commandOptions uploadCommand ParseArgs) + ["verbose", "check", "documentation", "publish"] + [] + ++ toSavedConfig + liftReportFlag + (commandOptions reportCommand ParseArgs) + ["verbose", "username", "password"] + [] + -- FIXME: this is a hack, hiding the user name and password. + -- But otherwise it masks the upload ones. Either need to + -- share the options or make then distinct. In any case + -- they should probably be per-server. + + ++ [ viewAsFieldDescr $ + optionDistPref + (configDistPref . savedConfigureFlags) + ( \distPref config -> + config + { savedConfigureFlags = + (savedConfigureFlags config) + { configDistPref = distPref + } + , savedHaddockFlags = + (savedHaddockFlags config) + { haddockDistPref = distPref + } + } + ) + ParseArgs ] - - ++ toSavedConfig liftInstallFlag - (installOptions ParseArgs) - ["dry-run", "only", "only-dependencies", "dependencies-only"] [] - - ++ toSavedConfig liftClientInstallFlag - (clientInstallOptions ParseArgs) - [] [] - - ++ toSavedConfig liftUploadFlag - (commandOptions uploadCommand ParseArgs) - ["verbose", "check", "documentation", "publish"] [] - - ++ toSavedConfig liftReportFlag - (commandOptions reportCommand ParseArgs) - ["verbose", "username", "password"] [] - --FIXME: this is a hack, hiding the user name and password. - -- But otherwise it masks the upload ones. Either need to - -- share the options or make then distinct. In any case - -- they should probably be per-server. - - ++ [ viewAsFieldDescr - $ optionDistPref - (configDistPref . savedConfigureFlags) - (\distPref config -> - config - { savedConfigureFlags = (savedConfigureFlags config) { - configDistPref = distPref } - , savedHaddockFlags = (savedHaddockFlags config) { - haddockDistPref = distPref } - } - ) - ParseArgs - ] - where toSavedConfig lift options exclusions replacements = [ lift (fromMaybe field replacement) | opt <- options - , let field = viewAsFieldDescr opt - name = fieldName field + , let field = viewAsFieldDescr opt + name = fieldName field replacement = find ((== name) . fieldName) replacements - , name `notElem` exclusions ] + , name `notElem` exclusions + ] - showRelaxDeps Nothing = mempty - showRelaxDeps (Just rd) | isRelaxDeps rd = Disp.text "True" - | otherwise = Disp.text "False" + showRelaxDeps Nothing = mempty + showRelaxDeps (Just rd) + | isRelaxDeps rd = Disp.text "True" + | otherwise = Disp.text "False" - toRelaxDeps True = RelaxDepsAll + toRelaxDeps True = RelaxDepsAll toRelaxDeps False = mempty - -- TODO: next step, make the deprecated fields elicit a warning. -- deprecatedFieldDescriptions :: [FieldDescr SavedConfig] deprecatedFieldDescriptions = [ liftGlobalFlag $ - listFieldParsec "repos" - pretty parsec - (fromNubList . globalRemoteRepos) - (\rs cfg -> cfg { globalRemoteRepos = toNubList rs }) + listFieldParsec + "repos" + pretty + parsec + (fromNubList . globalRemoteRepos) + (\rs cfg -> cfg{globalRemoteRepos = toNubList rs}) , liftGlobalFlag $ - simpleFieldParsec "cachedir" - (Disp.text . fromFlagOrDefault "") (optionalFlag parsecFilePath) - globalCacheDir (\d cfg -> cfg { globalCacheDir = d }) + simpleFieldParsec + "cachedir" + (Disp.text . fromFlagOrDefault "") + (optionalFlag parsecFilePath) + globalCacheDir + (\d cfg -> cfg{globalCacheDir = d}) , liftUploadFlag $ - simpleFieldParsec "hackage-username" - (Disp.text . fromFlagOrDefault "" . fmap unUsername) - (optionalFlag (fmap Username parsecToken)) - uploadUsername (\d cfg -> cfg { uploadUsername = d }) + simpleFieldParsec + "hackage-username" + (Disp.text . fromFlagOrDefault "" . fmap unUsername) + (optionalFlag (fmap Username parsecToken)) + uploadUsername + (\d cfg -> cfg{uploadUsername = d}) , liftUploadFlag $ - simpleFieldParsec "hackage-password" - (Disp.text . fromFlagOrDefault "" . fmap unPassword) - (optionalFlag (fmap Password parsecToken)) - uploadPassword (\d cfg -> cfg { uploadPassword = d }) + simpleFieldParsec + "hackage-password" + (Disp.text . fromFlagOrDefault "" . fmap unPassword) + (optionalFlag (fmap Password parsecToken)) + uploadPassword + (\d cfg -> cfg{uploadPassword = d}) , liftUploadFlag $ - spaceListField "hackage-password-command" - Disp.text parseTokenQ - (fromFlagOrDefault [] . uploadPasswordCmd) - (\d cfg -> cfg { uploadPasswordCmd = Flag d }) + spaceListField + "hackage-password-command" + Disp.text + parseTokenQ + (fromFlagOrDefault [] . uploadPasswordCmd) + (\d cfg -> cfg{uploadPasswordCmd = Flag d}) ] - ++ map (modifyFieldName ("user-"++) . liftUserInstallDirs) - installDirsFields - ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs) - installDirsFields + ++ map + (modifyFieldName ("user-" ++) . liftUserInstallDirs) + installDirsFields + ++ map + (modifyFieldName ("global-" ++) . liftGlobalInstallDirs) + installDirsFields where optionalFlag :: ParsecParser a -> ParsecParser (Flag a) optionalFlag p = toFlag <$> p <|> pure mempty modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a - modifyFieldName f d = d { fieldName = f (fieldName d) } - -liftUserInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate)) - -> FieldDescr SavedConfig -liftUserInstallDirs = liftField - savedUserInstallDirs (\flags conf -> conf { savedUserInstallDirs = flags }) - -liftGlobalInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate)) - -> FieldDescr SavedConfig + modifyFieldName f d = d{fieldName = f (fieldName d)} + +liftUserInstallDirs + :: FieldDescr (InstallDirs (Flag PathTemplate)) + -> FieldDescr SavedConfig +liftUserInstallDirs = + liftField + savedUserInstallDirs + (\flags conf -> conf{savedUserInstallDirs = flags}) + +liftGlobalInstallDirs + :: FieldDescr (InstallDirs (Flag PathTemplate)) + -> FieldDescr SavedConfig liftGlobalInstallDirs = - liftField savedGlobalInstallDirs - (\flags conf -> conf { savedGlobalInstallDirs = flags }) + liftField + savedGlobalInstallDirs + (\flags conf -> conf{savedGlobalInstallDirs = flags}) liftGlobalFlag :: FieldDescr GlobalFlags -> FieldDescr SavedConfig -liftGlobalFlag = liftField - savedGlobalFlags (\flags conf -> conf { savedGlobalFlags = flags }) +liftGlobalFlag = + liftField + savedGlobalFlags + (\flags conf -> conf{savedGlobalFlags = flags}) liftConfigFlag :: FieldDescr ConfigFlags -> FieldDescr SavedConfig -liftConfigFlag = liftField - savedConfigureFlags (\flags conf -> conf { savedConfigureFlags = flags }) +liftConfigFlag = + liftField + savedConfigureFlags + (\flags conf -> conf{savedConfigureFlags = flags}) liftConfigExFlag :: FieldDescr ConfigExFlags -> FieldDescr SavedConfig -liftConfigExFlag = liftField - savedConfigureExFlags (\flags conf -> conf { savedConfigureExFlags = flags }) +liftConfigExFlag = + liftField + savedConfigureExFlags + (\flags conf -> conf{savedConfigureExFlags = flags}) liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig -liftInstallFlag = liftField - savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags }) +liftInstallFlag = + liftField + savedInstallFlags + (\flags conf -> conf{savedInstallFlags = flags}) liftClientInstallFlag :: FieldDescr ClientInstallFlags -> FieldDescr SavedConfig liftClientInstallFlag = - liftField savedClientInstallFlags - (\flags conf -> conf { savedClientInstallFlags = flags }) + liftField + savedClientInstallFlags + (\flags conf -> conf{savedClientInstallFlags = flags}) liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig -liftUploadFlag = liftField - savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags }) +liftUploadFlag = + liftField + savedUploadFlags + (\flags conf -> conf{savedUploadFlags = flags}) liftReportFlag :: FieldDescr ReportFlags -> FieldDescr SavedConfig -liftReportFlag = liftField - savedReportFlags (\flags conf -> conf { savedReportFlags = flags }) - -parseConfig :: ConstraintSource - -> SavedConfig - -> BS.ByteString - -> ParseResult SavedConfig +liftReportFlag = + liftField + savedReportFlags + (\flags conf -> conf{savedReportFlags = flags}) + +parseConfig + :: ConstraintSource + -> SavedConfig + -> BS.ByteString + -> ParseResult SavedConfig parseConfig src initial = \str -> do fields <- readFields str let (knownSections, others) = partition isKnownSection fields config <- parse others - let init0 = savedInitFlags config - user0 = savedUserInstallDirs config + let init0 = savedInitFlags config + user0 = savedUserInstallDirs config global0 = savedGlobalInstallDirs config (remoteRepoSections0, localRepoSections0, haddockFlags, initFlags, user, global, paths, args) <- - foldM parseSections - ([], [], savedHaddockFlags config, init0, user0, global0, [], []) - knownSections + foldM + parseSections + ([], [], savedHaddockFlags config, init0, user0, global0, [], []) + knownSections let remoteRepoSections = - reverse - . nubBy ((==) `on` remoteRepoName) - $ remoteRepoSections0 + reverse + . nubBy ((==) `on` remoteRepoName) + $ remoteRepoSections0 let localRepoSections = - reverse - . nubBy ((==) `on` localRepoName) - $ localRepoSections0 - - return . fixConfigMultilines $ config { - savedGlobalFlags = (savedGlobalFlags config) { - globalRemoteRepos = toNubList remoteRepoSections, - globalLocalNoIndexRepos = toNubList localRepoSections, - -- the global extra prog path comes from the configure flag prog path - globalProgPathExtra = configProgramPathExtra (savedConfigureFlags config) - }, - savedConfigureFlags = (savedConfigureFlags config) { - configProgramPaths = paths, - configProgramArgs = args - }, - savedHaddockFlags = haddockFlags, - savedInitFlags = initFlags, - savedUserInstallDirs = user, - savedGlobalInstallDirs = global - } - + reverse + . nubBy ((==) `on` localRepoName) + $ localRepoSections0 + + return . fixConfigMultilines $ + config + { savedGlobalFlags = + (savedGlobalFlags config) + { globalRemoteRepos = toNubList remoteRepoSections + , globalLocalNoIndexRepos = toNubList localRepoSections + , -- the global extra prog path comes from the configure flag prog path + globalProgPathExtra = configProgramPathExtra (savedConfigureFlags config) + } + , savedConfigureFlags = + (savedConfigureFlags config) + { configProgramPaths = paths + , configProgramArgs = args + } + , savedHaddockFlags = haddockFlags + , savedInitFlags = initFlags + , savedUserInstallDirs = user + , savedGlobalInstallDirs = global + } where - isKnownSection (ParseUtils.Section _ "repository" _ _) = True - isKnownSection (ParseUtils.F _ "remote-repo" _) = True - isKnownSection (ParseUtils.Section _ "haddock" _ _) = True - isKnownSection (ParseUtils.Section _ "init" _ _) = True - isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True - isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True + isKnownSection (ParseUtils.Section _ "repository" _ _) = True + isKnownSection (ParseUtils.F _ "remote-repo" _) = True + isKnownSection (ParseUtils.Section _ "haddock" _ _) = True + isKnownSection (ParseUtils.Section _ "init" _ _) = True + isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True + isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True - isKnownSection _ = False + isKnownSection _ = False -- Attempt to split fields that can represent lists of paths into -- actual lists on failure, leave the field untouched. splitMultiPath :: [String] -> [String] splitMultiPath [s] = case runP 0 "" (parseOptCommaList parseTokenQ) s of - ParseOk _ res -> res - _ -> [s] + ParseOk _ res -> res + _ -> [s] splitMultiPath xs = xs -- 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. - fixConfigMultilines conf = conf { - savedConfigureFlags = - let scf = savedConfigureFlags conf - in scf { - configProgramPathExtra = - toNubList $ splitMultiPath - (fromNubList $ configProgramPathExtra scf) - , configExtraLibDirs = splitMultiPath - (configExtraLibDirs scf) - , configExtraLibDirsStatic = splitMultiPath - (configExtraLibDirsStatic scf) - , configExtraFrameworkDirs = splitMultiPath - (configExtraFrameworkDirs scf) - , configExtraIncludeDirs = splitMultiPath - (configExtraIncludeDirs scf) - , configConfigureArgs = splitMultiPath - (configConfigureArgs scf) - } - } + fixConfigMultilines conf = + conf + { savedConfigureFlags = + let scf = savedConfigureFlags conf + in scf + { configProgramPathExtra = + toNubList $ + splitMultiPath + (fromNubList $ configProgramPathExtra scf) + , configExtraLibDirs = + splitMultiPath + (configExtraLibDirs scf) + , configExtraLibDirsStatic = + splitMultiPath + (configExtraLibDirsStatic scf) + , configExtraFrameworkDirs = + splitMultiPath + (configExtraFrameworkDirs scf) + , configExtraIncludeDirs = + splitMultiPath + (configExtraIncludeDirs scf) + , configConfigureArgs = + splitMultiPath + (configConfigureArgs scf) + } + } - parse = parseFields (configFieldDescriptions src - ++ deprecatedFieldDescriptions) initial - - parseSections (rs, ls, h, i, u, g, p, a) - (ParseUtils.Section lineno "repository" name fs) = do - name' <- maybe (ParseFailed $ NoParse "repository name" lineno) return $ - simpleParsec name - r' <- parseFields remoteRepoFields (emptyRemoteRepo name') fs - r'' <- postProcessRepo lineno name r' - case r'' of - Left local -> return (rs, local:ls, h, i, u, g, p, a) - Right remote -> return (remote:rs, ls, h, i, u, g, p, a) - - parseSections (rs, ls, h, i, u, g, p, a) - (ParseUtils.F lno "remote-repo" raw) = do - let mr' = simpleParsec raw - r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr' - return (r':rs, ls, h, i, u, g, p, a) - - parseSections accum@(rs, ls, h, i, u, g, p, a) - (ParseUtils.Section _ "haddock" name fs) - | name == "" = do h' <- parseFields haddockFlagsFields h fs - return (rs, ls, h', i, u, g, p, a) - | otherwise = do - warning "The 'haddock' section should be unnamed" - return accum - - parseSections accum@(rs, ls, h, i, u, g, p, a) - (ParseUtils.Section _ "init" name fs) - | name == "" = do i' <- parseFields initFlagsFields i fs - return (rs, ls, h, i', u, g, p, a) - | otherwise = do - warning "The 'init' section should be unnamed" - return accum - - parseSections accum@(rs, ls, h, i, u, g, p, a) - (ParseUtils.Section _ "install-dirs" name fs) - | name' == "user" = do u' <- parseFields installDirsFields u fs - return (rs, ls, h, i, u', g, p, a) - | name' == "global" = do g' <- parseFields installDirsFields g fs - return (rs, ls, h, i, u, g', p, a) - | otherwise = do - warning "The 'install-paths' section should be for 'user' or 'global'" - return accum - where name' = lowercase name - parseSections accum@(rs, ls, h, i, u, g, p, a) - (ParseUtils.Section _ "program-locations" name fs) - | name == "" = do p' <- parseFields withProgramsFields p fs - return (rs, ls, h, i, u, g, p', a) - | otherwise = do - warning "The 'program-locations' section should be unnamed" - return accum - parseSections accum@(rs, ls, h, i, u, g, p, a) - (ParseUtils.Section _ "program-default-options" name fs) - | name == "" = do a' <- parseFields withProgramOptionsFields a fs - return (rs, ls, h, i, u, g, p, a') - | otherwise = do - warning "The 'program-default-options' section should be unnamed" - return accum + parse = + parseFields + ( configFieldDescriptions src + ++ deprecatedFieldDescriptions + ) + initial + + parseSections + (rs, ls, h, i, u, g, p, a) + (ParseUtils.Section lineno "repository" name fs) = do + name' <- + maybe (ParseFailed $ NoParse "repository name" lineno) return $ + simpleParsec name + r' <- parseFields remoteRepoFields (emptyRemoteRepo name') fs + r'' <- postProcessRepo lineno name r' + case r'' of + Left local -> return (rs, local : ls, h, i, u, g, p, a) + Right remote -> return (remote : rs, ls, h, i, u, g, p, a) + parseSections + (rs, ls, h, i, u, g, p, a) + (ParseUtils.F lno "remote-repo" raw) = do + let mr' = simpleParsec raw + r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr' + return (r' : rs, ls, h, i, u, g, p, a) + parseSections + accum@(rs, ls, h, i, u, g, p, a) + (ParseUtils.Section _ "haddock" name fs) + | name == "" = do + h' <- parseFields haddockFlagsFields h fs + return (rs, ls, h', i, u, g, p, a) + | otherwise = do + warning "The 'haddock' section should be unnamed" + return accum + parseSections + accum@(rs, ls, h, i, u, g, p, a) + (ParseUtils.Section _ "init" name fs) + | name == "" = do + i' <- parseFields initFlagsFields i fs + return (rs, ls, h, i', u, g, p, a) + | otherwise = do + warning "The 'init' section should be unnamed" + return accum + parseSections + accum@(rs, ls, h, i, u, g, p, a) + (ParseUtils.Section _ "install-dirs" name fs) + | name' == "user" = do + u' <- parseFields installDirsFields u fs + return (rs, ls, h, i, u', g, p, a) + | name' == "global" = do + g' <- parseFields installDirsFields g fs + return (rs, ls, h, i, u, g', p, a) + | otherwise = do + warning "The 'install-paths' section should be for 'user' or 'global'" + return accum + where + name' = lowercase name + parseSections + accum@(rs, ls, h, i, u, g, p, a) + (ParseUtils.Section _ "program-locations" name fs) + | name == "" = do + p' <- parseFields withProgramsFields p fs + return (rs, ls, h, i, u, g, p', a) + | otherwise = do + warning "The 'program-locations' section should be unnamed" + return accum + parseSections + accum@(rs, ls, h, i, u, g, p, a) + (ParseUtils.Section _ "program-default-options" name fs) + | name == "" = do + a' <- parseFields withProgramOptionsFields a fs + return (rs, ls, h, i, u, g, p, a') + | otherwise = do + warning "The 'program-default-options' section should be unnamed" + return accum parseSections accum f = do warning $ "Unrecognized stanza on line " ++ show (lineNo f) return accum postProcessRepo :: Int -> String -> RemoteRepo -> ParseResult (Either LocalRepo RemoteRepo) postProcessRepo lineno reponameStr repo0 = do - when (null reponameStr) $ - syntaxError lineno $ "a 'repository' section requires the " - ++ "repository name as an argument" - - reponame <- maybe (fail $ "Invalid repository name " ++ reponameStr) return $ - simpleParsec reponameStr - - case uriScheme (remoteRepoURI repo0) of - -- TODO: check that there are no authority, query or fragment - -- Note: the trailing colon is important - "file+noindex:" -> do - let uri = remoteRepoURI repo0 - return $ Left $ LocalRepo reponame (uriPath uri) (uriFragment uri == "#shared-cache") - - _ -> do - let repo = repo0 { remoteRepoName = reponame } - - when (remoteRepoKeyThreshold repo > length (remoteRepoRootKeys repo)) $ - warning $ "'key-threshold' for repository " - ++ show (remoteRepoName repo) - ++ " higher than number of keys" - - when (not (null (remoteRepoRootKeys repo)) && remoteRepoSecure repo /= Just True) $ - warning $ "'root-keys' for repository " - ++ show (remoteRepoName repo) - ++ " non-empty, but 'secure' not set to True." - - return $ Right repo + when (null reponameStr) $ + syntaxError lineno $ + "a 'repository' section requires the " + ++ "repository name as an argument" + + reponame <- + maybe (fail $ "Invalid repository name " ++ reponameStr) return $ + simpleParsec reponameStr + + case uriScheme (remoteRepoURI repo0) of + -- TODO: check that there are no authority, query or fragment + -- Note: the trailing colon is important + "file+noindex:" -> do + let uri = remoteRepoURI repo0 + return $ Left $ LocalRepo reponame (uriPath uri) (uriFragment uri == "#shared-cache") + _ -> do + let repo = repo0{remoteRepoName = reponame} + + when (remoteRepoKeyThreshold repo > length (remoteRepoRootKeys repo)) $ + warning $ + "'key-threshold' for repository " + ++ show (remoteRepoName repo) + ++ " higher than number of keys" + + when (not (null (remoteRepoRootKeys repo)) && remoteRepoSecure repo /= Just True) $ + warning $ + "'root-keys' for repository " + ++ show (remoteRepoName repo) + ++ " non-empty, but 'secure' not set to True." + + return $ Right repo showConfig :: SavedConfig -> String showConfig = showConfigWithComments mempty showConfigWithComments :: SavedConfig -> SavedConfig -> String -showConfigWithComments comment vals = Disp.render $ - case fmap (uncurry ppRemoteRepoSection) - (zip (getRemoteRepos comment) (getRemoteRepos vals)) of - [] -> Disp.text "" - (x:xs) -> foldl' (\ r r' -> r $+$ Disp.text "" $+$ r') x xs - $+$ Disp.text "" - $+$ ppFields - (skipSomeFields (configFieldDescriptions ConstraintSourceUnknown)) - mcomment vals - $+$ Disp.text "" - $+$ ppSection "haddock" "" haddockFlagsFields - (fmap savedHaddockFlags mcomment) (savedHaddockFlags vals) - $+$ Disp.text "" - $+$ ppSection "init" "" initFlagsFields - (fmap savedInitFlags mcomment) (savedInitFlags vals) - $+$ Disp.text "" - $+$ installDirsSection "user" savedUserInstallDirs - $+$ Disp.text "" - $+$ installDirsSection "global" savedGlobalInstallDirs - $+$ Disp.text "" - $+$ configFlagsSection "program-locations" withProgramsFields - configProgramPaths - $+$ Disp.text "" - $+$ configFlagsSection "program-default-options" withProgramOptionsFields - configProgramArgs +showConfigWithComments comment vals = + Disp.render $ + case fmap + (uncurry ppRemoteRepoSection) + (zip (getRemoteRepos comment) (getRemoteRepos vals)) of + [] -> Disp.text "" + (x : xs) -> foldl' (\r r' -> r $+$ Disp.text "" $+$ r') x xs + $+$ Disp.text "" + $+$ ppFields + (skipSomeFields (configFieldDescriptions ConstraintSourceUnknown)) + mcomment + vals + $+$ Disp.text "" + $+$ ppSection + "haddock" + "" + haddockFlagsFields + (fmap savedHaddockFlags mcomment) + (savedHaddockFlags vals) + $+$ Disp.text "" + $+$ ppSection + "init" + "" + initFlagsFields + (fmap savedInitFlags mcomment) + (savedInitFlags vals) + $+$ Disp.text "" + $+$ installDirsSection "user" savedUserInstallDirs + $+$ Disp.text "" + $+$ installDirsSection "global" savedGlobalInstallDirs + $+$ Disp.text "" + $+$ configFlagsSection + "program-locations" + withProgramsFields + configProgramPaths + $+$ Disp.text "" + $+$ configFlagsSection + "program-default-options" + withProgramOptionsFields + configProgramArgs where getRemoteRepos = fromNubList . globalRemoteRepos . savedGlobalFlags mcomment = Just comment installDirsSection name field = - ppSection "install-dirs" name installDirsFields - (fmap field mcomment) (field vals) + ppSection + "install-dirs" + name + installDirsFields + (fmap field mcomment) + (field vals) configFlagsSection name fields field = - ppSection name "" fields - (fmap (field . savedConfigureFlags) mcomment) - ((field . savedConfigureFlags) vals) + ppSection + name + "" + fields + (fmap (field . savedConfigureFlags) mcomment) + ((field . savedConfigureFlags) vals) -- skip fields based on field name. currently only skips "remote-repo", -- because that is rendered as a section. (see 'ppRemoteRepoSection'.) @@ -1414,33 +1687,50 @@ installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))] installDirsFields = map viewAsFieldDescr installDirsOptions ppRemoteRepoSection :: RemoteRepo -> RemoteRepo -> Doc -ppRemoteRepoSection def vals = ppSection "repository" (unRepoName (remoteRepoName vals)) - remoteRepoFields (Just def) vals +ppRemoteRepoSection def vals = + ppSection + "repository" + (unRepoName (remoteRepoName vals)) + remoteRepoFields + (Just def) + vals remoteRepoFields :: [FieldDescr RemoteRepo] remoteRepoFields = - [ simpleField "url" - (text . show) (parseTokenQ >>= parseURI') - remoteRepoURI (\x repo -> repo { remoteRepoURI = x }) - , simpleFieldParsec "secure" - showSecure (Just `fmap` parsec) - remoteRepoSecure (\x repo -> repo { remoteRepoSecure = x }) - , listField "root-keys" - text parseTokenQ - remoteRepoRootKeys (\x repo -> repo { remoteRepoRootKeys = x }) - , simpleFieldParsec "key-threshold" - showThreshold P.integral - remoteRepoKeyThreshold (\x repo -> repo { remoteRepoKeyThreshold = x }) + [ simpleField + "url" + (text . show) + (parseTokenQ >>= parseURI') + remoteRepoURI + (\x repo -> repo{remoteRepoURI = x}) + , simpleFieldParsec + "secure" + showSecure + (Just `fmap` parsec) + remoteRepoSecure + (\x repo -> repo{remoteRepoSecure = x}) + , listField + "root-keys" + text + parseTokenQ + remoteRepoRootKeys + (\x repo -> repo{remoteRepoRootKeys = x}) + , simpleFieldParsec + "key-threshold" + showThreshold + P.integral + remoteRepoKeyThreshold + (\x repo -> repo{remoteRepoKeyThreshold = x}) ] where parseURI' uriString = case parseURI uriString of - Nothing -> fail $ "remote-repo: no parse on " ++ show uriString + Nothing -> fail $ "remote-repo: no parse on " ++ show uriString Just uri -> return uri - showSecure Nothing = mempty -- default 'secure' setting - showSecure (Just True) = text "True" -- user explicitly enabled it - showSecure (Just False) = text "False" -- user explicitly disabled it + showSecure Nothing = mempty -- default 'secure' setting + showSecure (Just True) = text "True" -- user explicitly enabled it + showSecure (Just False) = text "False" -- user explicitly disabled it -- If the key-threshold is set to 0, we omit it as this is the default -- and it looks odd to have a value for key-threshold but not for 'secure' @@ -1451,28 +1741,48 @@ remoteRepoFields = -- | Fields for the 'haddock' section. haddockFlagsFields :: [FieldDescr HaddockFlags] -haddockFlagsFields = [ field - | opt <- haddockOptions ParseArgs - , let field = viewAsFieldDescr opt - name = fieldName field - , name `notElem` exclusions ] +haddockFlagsFields = + [ field + | opt <- haddockOptions ParseArgs + , let field = viewAsFieldDescr opt + name = fieldName field + , name `notElem` exclusions + ] where exclusions = ["verbose", "builddir", "for-hackage"] -- | Fields for the 'init' section. initFlagsFields :: [FieldDescr IT.InitFlags] -initFlagsFields = [ field - | opt <- initOptions ParseArgs - , let field = viewAsFieldDescr opt - name = fieldName field - , name `notElem` exclusions ] +initFlagsFields = + [ field + | opt <- initOptions ParseArgs + , let field = viewAsFieldDescr opt + name = fieldName field + , name `notElem` exclusions + ] where exclusions = - [ "author", "email", "overwrite" - , "package-dir", "packagedir", "package-name", "version", "homepage" - , "synopsis", "category", "extra-source-file", "lib", "exe", "libandexe" - , "main-is", "expose-module", "exposed-modules", "extension" - , "dependency", "build-tool", "with-compiler" + [ "author" + , "email" + , "overwrite" + , "package-dir" + , "packagedir" + , "package-name" + , "version" + , "homepage" + , "synopsis" + , "category" + , "extra-source-file" + , "lib" + , "exe" + , "libandexe" + , "main-is" + , "expose-module" + , "exposed-modules" + , "extension" + , "dependency" + , "build-tool" + , "with-compiler" , "verbose" ] @@ -1480,28 +1790,36 @@ initFlagsFields = [ field withProgramsFields :: [FieldDescr [(String, FilePath)]] withProgramsFields = map viewAsFieldDescr $ - programDbPaths' (++ "-location") defaultProgramDb - ParseArgs id (++) + programDbPaths' + (++ "-location") + defaultProgramDb + ParseArgs + id + (++) -- | Fields for the 'program-default-options' section. withProgramOptionsFields :: [FieldDescr [(String, [String])]] withProgramOptionsFields = map viewAsFieldDescr $ - programDbOptions defaultProgramDb ParseArgs id (++) + programDbOptions defaultProgramDb ParseArgs id (++) parseExtraLines :: Verbosity -> [String] -> IO SavedConfig parseExtraLines verbosity extraLines = - case parseConfig (ConstraintSourceMainConfig "additional lines") - mempty (toUTF8BS (unlines extraLines)) of + case parseConfig + (ConstraintSourceMainConfig "additional lines") + mempty + (toUTF8BS (unlines extraLines)) of ParseFailed err -> let (line, msg) = locatedErrorMsg err - in die' verbosity $ - "Error parsing additional config lines\n" - ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg + in die' verbosity $ + "Error parsing additional config lines\n" + ++ maybe "" (\n -> ':' : show n) line + ++ ":\n" + ++ msg ParseOk [] r -> return r ParseOk ws _ -> die' verbosity $ - unlines (map (showPWarning "Error parsing additional config lines") ws) + unlines (map (showPWarning "Error parsing additional config lines") ws) -- | Get the differences (as a pseudo code diff) between the user's -- config file and the one that cabal would generate if it didn't exist. @@ -1511,57 +1829,66 @@ userConfigDiff verbosity globalFlags extraLines = do extraConfig <- parseExtraLines verbosity extraLines testConfig <- initialSavedConfig return $ - reverse . foldl' createDiff [] . M.toList - $ M.unionWith combine - (M.fromList . map justFst $ filterShow testConfig) - (M.fromList . map justSnd $ filterShow (userConfig `mappend` extraConfig)) + reverse . foldl' createDiff [] . M.toList $ + M.unionWith + combine + (M.fromList . map justFst $ filterShow testConfig) + (M.fromList . map justSnd $ filterShow (userConfig `mappend` extraConfig)) where justFst (a, b) = (a, (Just b, Nothing)) justSnd (a, b) = (a, (Nothing, Just b)) combine (Nothing, Just b) (Just a, Nothing) = (Just a, Just b) combine (Just a, Nothing) (Nothing, Just b) = (Just a, Just b) - combine x y = error $ "Can't happen : userConfigDiff " - ++ show x ++ " " ++ show y + combine x y = + error $ + "Can't happen : userConfigDiff " + ++ show x + ++ " " + ++ show y createDiff :: [String] -> (String, (Maybe String, Maybe String)) -> [String] createDiff acc (key, (Just a, Just b)) - | a == b = acc - | otherwise = ("+ " ++ key ++ ": " ++ b) - : ("- " ++ key ++ ": " ++ a) : acc + | a == b = acc + | otherwise = + ("+ " ++ key ++ ": " ++ b) + : ("- " ++ key ++ ": " ++ a) + : acc createDiff acc (key, (Nothing, Just b)) = ("+ " ++ key ++ ": " ++ b) : acc createDiff acc (key, (Just a, Nothing)) = ("- " ++ key ++ ": " ++ a) : acc createDiff acc (_, (Nothing, Nothing)) = acc filterShow :: SavedConfig -> [(String, String)] - filterShow cfg = map keyValueSplit + filterShow cfg = + map keyValueSplit . filter (\s -> not (null s) && ':' `elem` s) . map nonComment . lines $ showConfig cfg nonComment [] = [] - nonComment ('-':'-':_) = [] - nonComment (x:xs) = x : nonComment xs + nonComment ('-' : '-' : _) = [] + nonComment (x : xs) = x : nonComment xs topAndTail = reverse . dropWhile isSpace . reverse . dropWhile isSpace keyValueSplit s = - let (left, right) = break (== ':') s - in (topAndTail left, topAndTail (drop 1 right)) - + let (left, right) = break (== ':') s + in (topAndTail left, topAndTail (drop 1 right)) -- | Update the user's config file keeping the user's customizations. userConfigUpdate :: Verbosity -> GlobalFlags -> [String] -> IO () userConfigUpdate verbosity globalFlags extraLines = do - userConfig <- loadRawConfig normal (globalConfigFile globalFlags) + userConfig <- loadRawConfig normal (globalConfigFile globalFlags) extraConfig <- parseExtraLines verbosity extraLines - newConfig <- initialSavedConfig + newConfig <- initialSavedConfig commentConf <- commentSavedConfig cabalFile <- getConfigFilePath $ globalConfigFile globalFlags let backup = cabalFile ++ ".backup" notice verbosity $ "Renaming " ++ cabalFile ++ " to " ++ backup ++ "." renameFile cabalFile backup notice verbosity $ "Writing merged config to " ++ cabalFile ++ "." - writeConfigFile cabalFile commentConf + writeConfigFile + cabalFile + commentConf (newConfig `mappend` userConfig `mappend` extraConfig) diff --git a/cabal-install/src/Distribution/Client/Configure.hs b/cabal-install/src/Distribution/Client/Configure.hs index 2cbe16096a4..d0abdac3430 100644 --- a/cabal-install/src/Distribution/Client/Configure.hs +++ b/cabal-install/src/Distribution/Client/Configure.hs @@ -1,5 +1,9 @@ {-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.Configure -- Copyright : (c) David Himmelstrup 2005, @@ -10,78 +14,122 @@ -- Portability : portable -- -- High level interface to configuring a package. ------------------------------------------------------------------------------ -module Distribution.Client.Configure ( - configure, - configureSetupScript, - chooseCabalVersion, - checkConfigExFlags, +module Distribution.Client.Configure + ( configure + , configureSetupScript + , chooseCabalVersion + , checkConfigExFlags + -- * Saved configure flags - readConfigFlagsFrom, readConfigFlags, - cabalConfigFlagsFile, - writeConfigFlagsTo, writeConfigFlags, + , readConfigFlagsFrom + , readConfigFlags + , cabalConfigFlagsFile + , writeConfigFlagsTo + , writeConfigFlags ) where -import Prelude () import Distribution.Client.Compat.Prelude import Distribution.Utils.Generic (safeHead) +import Prelude () import Distribution.Client.Dependency -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.SolverInstallPlan (SolverInstallPlan) import Distribution.Client.IndexUtils as IndexUtils - ( getSourcePackages, getInstalledPackages ) + ( getInstalledPackages + , getSourcePackages + ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.JobControl (Lock) import Distribution.Client.Setup - ( ConfigExFlags(..), RepoContext(..) - , configureCommand, configureExCommand, filterConfigureFlags ) -import Distribution.Client.Types as Source + ( ConfigExFlags (..) + , RepoContext (..) + , configureCommand + , configureExCommand + , filterConfigureFlags + ) import Distribution.Client.SetupWrapper - ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) + ( SetupScriptOptions (..) + , defaultSetupScriptOptions + , setupWrapper + ) +import Distribution.Client.SolverInstallPlan (SolverInstallPlan) import Distribution.Client.Targets - ( userToPackageConstraint, userConstraintPackageName ) -import Distribution.Client.JobControl (Lock) + ( userConstraintPackageName + , userToPackageConstraint + ) +import Distribution.Client.Types as Source import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackageIndex - ( PackageIndex, elemByPackageName ) -import Distribution.Solver.Types.PkgConfigDb - (PkgConfigDb, readPkgConfigDb) -import Distribution.Solver.Types.SourcePackage - +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageIndex + ( PackageIndex + , elemByPackageName + ) +import Distribution.Solver.Types.PkgConfigDb + ( PkgConfigDb + , readPkgConfigDb + ) +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.SourcePackage + +import Distribution.Client.SavedFlags (readCommandFlags, writeCommandFlags) +import Distribution.Package + ( Package (..) + , PackageId + , packageName + ) +import qualified Distribution.PackageDescription as PkgDesc +import Distribution.PackageDescription.Configuration + ( finalizePD + ) import Distribution.Simple.Compiler - ( Compiler, CompilerInfo, compilerInfo, PackageDB(..), PackageDBStack ) -import Distribution.Simple.Program (ProgramDb) -import Distribution.Client.SavedFlags ( readCommandFlags, writeCommandFlags ) -import Distribution.Simple.Setup - ( ConfigFlags(..) - , fromFlag, toFlag, flagToMaybe, fromFlagOrDefault ) + ( Compiler + , CompilerInfo + , PackageDB (..) + , PackageDBStack + , compilerInfo + ) import Distribution.Simple.PackageDescription - ( readGenericPackageDescription ) + ( readGenericPackageDescription + ) import Distribution.Simple.PackageIndex as PackageIndex - ( InstalledPackageIndex, lookupPackageName ) -import Distribution.Package - ( Package(..), packageName, PackageId ) + ( InstalledPackageIndex + , lookupPackageName + ) +import Distribution.Simple.Program (ProgramDb) +import Distribution.Simple.Setup + ( ConfigFlags (..) + , flagToMaybe + , fromFlag + , fromFlagOrDefault + , toFlag + ) +import Distribution.Simple.Utils as Utils + ( debug + , defaultPackageDesc + , die' + , notice + , warn + ) +import Distribution.System + ( Platform + ) import Distribution.Types.GivenComponent - ( GivenComponent(..) ) + ( GivenComponent (..) + ) import Distribution.Types.PackageVersionConstraint - ( PackageVersionConstraint(..), thisPackageVersionConstraint ) -import qualified Distribution.PackageDescription as PkgDesc -import Distribution.PackageDescription.Configuration - ( finalizePD ) + ( PackageVersionConstraint (..) + , thisPackageVersionConstraint + ) import Distribution.Version - ( Version, anyVersion, thisVersion - , VersionRange ) -import Distribution.Simple.Utils as Utils - ( warn, notice, debug, die' - , defaultPackageDesc ) -import Distribution.System - ( Platform ) + ( Version + , VersionRange + , anyVersion + , thisVersion + ) -import System.FilePath ( () ) +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 @@ -92,215 +140,286 @@ chooseCabalVersion _configExFlags maybeVersion = maybe anyVersion thisVersion maybeVersion -- | Configure the package found in the local directory -configure :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> Platform - -> ProgramDb - -> ConfigFlags - -> ConfigExFlags - -> [String] - -> IO () -configure verbosity packageDBs repoCtxt comp platform progdb - configFlags configExFlags extraArgs = do - - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb - sourcePkgDb <- getSourcePackages verbosity repoCtxt - pkgConfigDb <- readPkgConfigDb verbosity progdb - - checkConfigExFlags verbosity installedPkgIndex - (packageIndex sourcePkgDb) configExFlags - - progress <- planLocalPackage verbosity comp platform configFlags configExFlags - installedPkgIndex sourcePkgDb pkgConfigDb - - notice verbosity "Resolving dependencies..." - maybePlan <- foldProgress logMsg (return . Left) (return . Right) - progress - case maybePlan of - Left message -> do - warn verbosity $ - "solver failed to find a solution:\n" - ++ message - ++ "\nTrying configure anyway." - setupWrapper verbosity (setupScriptOptions installedPkgIndex Nothing) - Nothing configureCommand (const configFlags) (const extraArgs) - - Right installPlan0 -> - let installPlan = InstallPlan.configureInstallPlan configFlags installPlan0 - in case fst (InstallPlan.ready installPlan) of - [pkg@(ReadyPackage - (ConfiguredPackage _ (SourcePackage _ _ (LocalUnpackedPackage _) _) - _ _ _))] -> do - configurePackage verbosity - platform (compilerInfo comp) - (setupScriptOptions installedPkgIndex (Just pkg)) - configFlags pkg extraArgs - - _ -> die' verbosity $ "internal error: configure install plan should have exactly " - ++ "one local ready package." - - where - setupScriptOptions :: InstalledPackageIndex - -> Maybe ReadyPackage - -> SetupScriptOptions - setupScriptOptions = - configureSetupScript - packageDBs +configure + :: Verbosity + -> PackageDBStack + -> RepoContext + -> Compiler + -> Platform + -> ProgramDb + -> ConfigFlags + -> ConfigExFlags + -> [String] + -> IO () +configure + verbosity + packageDBs + repoCtxt + comp + platform + progdb + configFlags + configExFlags + extraArgs = do + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb + sourcePkgDb <- getSourcePackages verbosity repoCtxt + pkgConfigDb <- readPkgConfigDb verbosity progdb + + checkConfigExFlags + verbosity + installedPkgIndex + (packageIndex sourcePkgDb) + configExFlags + + progress <- + planLocalPackage + verbosity comp platform - progdb - (fromFlagOrDefault - (useDistPref defaultSetupScriptOptions) - (configDistPref configFlags)) - (chooseCabalVersion - configExFlags - (flagToMaybe (configCabalVersion configExFlags))) - Nothing - False - - logMsg message rest = debug verbosity message >> rest - -configureSetupScript :: PackageDBStack - -> Compiler - -> Platform - -> ProgramDb - -> FilePath - -> VersionRange - -> Maybe Lock - -> Bool - -> InstalledPackageIndex - -> Maybe ReadyPackage - -> SetupScriptOptions -configureSetupScript packageDBs - comp - platform - progdb - distPref - cabalVersion - lock - forceExternal - index - mpkg - = SetupScriptOptions { - useCabalVersion = cabalVersion - , useCabalSpecVersion = Nothing - , useCompiler = Just comp - , usePlatform = Just platform - , usePackageDB = packageDBs' - , usePackageIndex = index' - , useProgramDb = progdb - , useDistPref = distPref - , useLoggingHandle = Nothing - , useWorkingDir = Nothing - , useExtraPathEnv = [] - , useExtraEnvOverrides = [] - , setupCacheLock = lock - , useWin32CleanHack = False - , forceExternalSetupMethod = forceExternal - -- If we have explicit setup dependencies, list them; otherwise, we give - -- the empty list of dependencies; ideally, we would fix the version of - -- Cabal here, so that we no longer need the special case for that in - -- `compileSetupExecutable` in `externalSetupMethod`, but we don't yet - -- know the version of Cabal at this point, but only find this there. - -- Therefore, for now, we just leave this blank. - , useDependencies = fromMaybe [] explicitSetupDeps - , useDependenciesExclusive = not defaultSetupDeps && isJust explicitSetupDeps - , useVersionMacros = not defaultSetupDeps && isJust explicitSetupDeps - , isInteractive = False - } - where - -- When we are compiling a legacy setup script without an explicit - -- setup stanza, we typically want to allow the UserPackageDB for - -- 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 - index' :: Maybe InstalledPackageIndex - (packageDBs', index') = - case packageDBs of - (GlobalPackageDB:dbs) | UserPackageDB `notElem` dbs - , Nothing <- explicitSetupDeps - -> (GlobalPackageDB:UserPackageDB:dbs, Nothing) - -- but if the user is using an odd db stack, don't touch it - _otherwise -> (packageDBs, Just index) - - maybeSetupBuildInfo :: Maybe PkgDesc.SetupBuildInfo - maybeSetupBuildInfo = do - ReadyPackage cpkg <- mpkg - let gpkg = srcpkgDescription (confPkgSource cpkg) - PkgDesc.setupBuildInfo (PkgDesc.packageDescription gpkg) - - -- Was a default 'custom-setup' stanza added by 'cabal-install' itself? If - -- so, 'setup-depends' must not be exclusive. See #3199. - defaultSetupDeps :: Bool - defaultSetupDeps = maybe False PkgDesc.defaultSetupDepends - maybeSetupBuildInfo - - explicitSetupDeps :: Maybe [(InstalledPackageId, PackageId)] - explicitSetupDeps = do - -- Check if there is an explicit setup stanza. - _buildInfo <- maybeSetupBuildInfo - -- Return the setup dependencies computed by the solver - ReadyPackage cpkg <- mpkg - return [ ( cid, srcid ) - | ConfiguredId srcid - (Just (PkgDesc.CLibName PkgDesc.LMainLibName)) cid - <- CD.setupDeps (confPkgDeps cpkg) - ] + configFlags + configExFlags + installedPkgIndex + sourcePkgDb + pkgConfigDb + + notice verbosity "Resolving dependencies..." + maybePlan <- + foldProgress + logMsg + (return . Left) + (return . Right) + progress + case maybePlan of + Left message -> do + warn verbosity $ + "solver failed to find a solution:\n" + ++ message + ++ "\nTrying configure anyway." + setupWrapper + verbosity + (setupScriptOptions installedPkgIndex Nothing) + Nothing + configureCommand + (const configFlags) + (const extraArgs) + Right installPlan0 -> + let installPlan = InstallPlan.configureInstallPlan configFlags installPlan0 + in case fst (InstallPlan.ready installPlan) of + [ pkg@( ReadyPackage + ( ConfiguredPackage + _ + (SourcePackage _ _ (LocalUnpackedPackage _) _) + _ + _ + _ + ) + ) + ] -> do + configurePackage + verbosity + platform + (compilerInfo comp) + (setupScriptOptions installedPkgIndex (Just pkg)) + configFlags + pkg + extraArgs + _ -> + die' verbosity $ + "internal error: configure install plan should have exactly " + ++ "one local ready package." + where + setupScriptOptions + :: InstalledPackageIndex + -> Maybe ReadyPackage + -> SetupScriptOptions + setupScriptOptions = + configureSetupScript + packageDBs + comp + platform + progdb + ( fromFlagOrDefault + (useDistPref defaultSetupScriptOptions) + (configDistPref configFlags) + ) + ( chooseCabalVersion + configExFlags + (flagToMaybe (configCabalVersion configExFlags)) + ) + Nothing + False + + logMsg message rest = debug verbosity message >> rest + +configureSetupScript + :: PackageDBStack + -> Compiler + -> Platform + -> ProgramDb + -> FilePath + -> VersionRange + -> Maybe Lock + -> Bool + -> InstalledPackageIndex + -> Maybe ReadyPackage + -> SetupScriptOptions +configureSetupScript + packageDBs + comp + platform + progdb + distPref + cabalVersion + lock + forceExternal + index + mpkg = + SetupScriptOptions + { useCabalVersion = cabalVersion + , useCabalSpecVersion = Nothing + , useCompiler = Just comp + , usePlatform = Just platform + , usePackageDB = packageDBs' + , usePackageIndex = index' + , useProgramDb = progdb + , useDistPref = distPref + , useLoggingHandle = Nothing + , useWorkingDir = Nothing + , useExtraPathEnv = [] + , useExtraEnvOverrides = [] + , setupCacheLock = lock + , useWin32CleanHack = False + , forceExternalSetupMethod = forceExternal + , -- If we have explicit setup dependencies, list them; otherwise, we give + -- the empty list of dependencies; ideally, we would fix the version of + -- Cabal here, so that we no longer need the special case for that in + -- `compileSetupExecutable` in `externalSetupMethod`, but we don't yet + -- know the version of Cabal at this point, but only find this there. + -- Therefore, for now, we just leave this blank. + useDependencies = fromMaybe [] explicitSetupDeps + , useDependenciesExclusive = not defaultSetupDeps && isJust explicitSetupDeps + , useVersionMacros = not defaultSetupDeps && isJust explicitSetupDeps + , isInteractive = False + } + where + -- When we are compiling a legacy setup script without an explicit + -- setup stanza, we typically want to allow the UserPackageDB for + -- 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 + index' :: Maybe InstalledPackageIndex + (packageDBs', index') = + case packageDBs of + (GlobalPackageDB : dbs) + | UserPackageDB `notElem` dbs + , Nothing <- explicitSetupDeps -> + (GlobalPackageDB : UserPackageDB : dbs, Nothing) + -- but if the user is using an odd db stack, don't touch it + _otherwise -> (packageDBs, Just index) + + maybeSetupBuildInfo :: Maybe PkgDesc.SetupBuildInfo + maybeSetupBuildInfo = do + ReadyPackage cpkg <- mpkg + let gpkg = srcpkgDescription (confPkgSource cpkg) + PkgDesc.setupBuildInfo (PkgDesc.packageDescription gpkg) + + -- Was a default 'custom-setup' stanza added by 'cabal-install' itself? If + -- so, 'setup-depends' must not be exclusive. See #3199. + defaultSetupDeps :: Bool + defaultSetupDeps = + maybe + False + PkgDesc.defaultSetupDepends + maybeSetupBuildInfo + + explicitSetupDeps :: Maybe [(InstalledPackageId, PackageId)] + explicitSetupDeps = do + -- Check if there is an explicit setup stanza. + _buildInfo <- maybeSetupBuildInfo + -- Return the setup dependencies computed by the solver + ReadyPackage cpkg <- mpkg + return + [ (cid, srcid) + | ConfiguredId + srcid + (Just (PkgDesc.CLibName PkgDesc.LMainLibName)) + cid <- + CD.setupDeps (confPkgDeps cpkg) + ] -- | Warn if any constraints or preferences name packages that are not in the -- source package index or installed package index. -checkConfigExFlags :: Package pkg - => Verbosity - -> InstalledPackageIndex - -> PackageIndex pkg - -> ConfigExFlags - -> IO () +checkConfigExFlags + :: Package pkg + => Verbosity + -> InstalledPackageIndex + -> PackageIndex pkg + -> ConfigExFlags + -> IO () checkConfigExFlags verbosity installedPkgIndex sourcePkgIndex flags = do for_ (safeHead unknownConstraints) $ \h -> - warn verbosity $ "Constraint refers to an unknown package: " - ++ showConstraint h + warn verbosity $ + "Constraint refers to an unknown package: " + ++ showConstraint h for_ (safeHead unknownPreferences) $ \h -> - warn verbosity $ "Preference refers to an unknown package: " - ++ prettyShow h + warn verbosity $ + "Preference refers to an unknown package: " + ++ prettyShow h where - unknownConstraints = filter (unknown . userConstraintPackageName . fst) $ - configExConstraints flags - unknownPreferences = filter (unknown . \(PackageVersionConstraint name _) -> name) $ - configPreferences flags - unknown pkg = null (PackageIndex.lookupPackageName installedPkgIndex pkg) - && not (elemByPackageName sourcePkgIndex pkg) + unknownConstraints = + filter (unknown . userConstraintPackageName . fst) $ + configExConstraints flags + unknownPreferences = + filter (unknown . \(PackageVersionConstraint name _) -> name) $ + configPreferences flags + unknown pkg = + null (PackageIndex.lookupPackageName installedPkgIndex pkg) + && not (elemByPackageName sourcePkgIndex pkg) showConstraint (uc, src) = - prettyShow uc ++ " (" ++ showConstraintSource src ++ ")" + prettyShow uc ++ " (" ++ showConstraintSource src ++ ")" -- | Make an 'InstallPlan' for the unpacked package in the current directory, -- and all its dependencies. --- -planLocalPackage :: Verbosity -> Compiler - -> Platform - -> ConfigFlags -> ConfigExFlags - -> InstalledPackageIndex - -> SourcePackageDb - -> PkgConfigDb - -> IO (Progress String String SolverInstallPlan) -planLocalPackage verbosity comp platform configFlags configExFlags - installedPkgIndex (SourcePackageDb _ packagePrefs) pkgConfigDb = do - pkg <- readGenericPackageDescription verbosity =<< - case flagToMaybe (configCabalFilePath configFlags) of - Nothing -> defaultPackageDesc verbosity - Just fp -> return fp - solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags) - (compilerInfo comp) - - let -- We create a local package and ask to resolve a dependency on it - localPkg = SourcePackage { - srcpkgPackageId = packageId pkg, - srcpkgDescription = pkg, - srcpkgSource = LocalUnpackedPackage ".", - srcpkgDescrOverride = Nothing - } +planLocalPackage + :: Verbosity + -> Compiler + -> Platform + -> ConfigFlags + -> ConfigExFlags + -> InstalledPackageIndex + -> SourcePackageDb + -> PkgConfigDb + -> IO (Progress String String SolverInstallPlan) +planLocalPackage + verbosity + comp + platform + configFlags + configExFlags + installedPkgIndex + (SourcePackageDb _ packagePrefs) + pkgConfigDb = do + pkg <- + readGenericPackageDescription verbosity + =<< case flagToMaybe (configCabalFilePath configFlags) of + Nothing -> defaultPackageDesc verbosity + Just fp -> return fp + solver <- + chooseSolver + verbosity + (fromFlag $ configSolver configExFlags) + (compilerInfo comp) + + let + -- We create a local package and ask to resolve a dependency on it + localPkg = + SourcePackage + { srcpkgPackageId = packageId pkg + , srcpkgDescription = pkg + , srcpkgSource = LocalUnpackedPackage "." + , srcpkgDescrOverride = Nothing + } testsEnabled :: Bool testsEnabled = fromFlagOrDefault False $ configTests configFlags @@ -310,49 +429,46 @@ planLocalPackage verbosity comp platform configFlags configExFlags resolverParams :: DepResolverParams resolverParams = - removeLowerBounds + removeLowerBounds (fromMaybe (AllowOlder mempty) $ configAllowOlder configExFlags) - . removeUpperBounds - (fromMaybe (AllowNewer mempty) $ configAllowNewer configExFlags) - - . addPreferences + . removeUpperBounds + (fromMaybe (AllowNewer mempty) $ configAllowNewer configExFlags) + . addPreferences -- preferences from the config file or command line [ PackageVersionPreference name ver - | PackageVersionConstraint name ver <- configPreferences configExFlags ] - - . addConstraints + | PackageVersionConstraint name ver <- configPreferences configExFlags + ] + . addConstraints -- version constraints from the config file or command line -- TODO: should warn or error on constraints that are not on direct -- deps or flag constraints not on the package in question. [ LabeledPackageConstraint (userToPackageConstraint uc) src - | (uc, src) <- configExConstraints configExFlags ] - - . addConstraints + | (uc, src) <- configExConstraints configExFlags + ] + . addConstraints -- package flags from the config file or command line - [ let pc = PackageConstraint - (scopeToplevel $ packageName pkg) - (PackagePropertyFlags $ configConfigurationsFlags configFlags) - in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget + [ let pc = + PackageConstraint + (scopeToplevel $ packageName pkg) + (PackagePropertyFlags $ configConfigurationsFlags configFlags) + in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget ] - - . addConstraints + . addConstraints -- '--enable-tests' and '--enable-benchmarks' constraints from -- the config file or command line - [ let pc = PackageConstraint (scopeToplevel $ packageName pkg) . - PackagePropertyStanzas $ - [ TestStanzas | testsEnabled ] ++ - [ BenchStanzas | benchmarksEnabled ] - in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget + [ let pc = + PackageConstraint (scopeToplevel $ packageName pkg) + . PackagePropertyStanzas + $ [TestStanzas | testsEnabled] + ++ [BenchStanzas | benchmarksEnabled] + in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget ] - - -- Don't solve for executables, since we use an empty source - -- package database and executables never show up in the - -- installed package index - . setSolveExecutables (SolveExecutables False) - - . setSolverVerbosity verbosity - - $ standardInstallPolicy + -- Don't solve for executables, since we use an empty source + -- package database and executables never show up in the + -- installed package index + . setSolveExecutables (SolveExecutables False) + . setSolverVerbosity verbosity + $ standardInstallPolicy installedPkgIndex -- NB: We pass in an *empty* source package database, -- because cabal configure assumes that all dependencies @@ -360,8 +476,7 @@ planLocalPackage verbosity comp platform configFlags configExFlags (SourcePackageDb mempty packagePrefs) [SpecificSourcePackage localPkg] - return (resolveDependencies platform (compilerInfo comp) pkgConfigDb solver resolverParams) - + return (resolveDependencies platform (compilerInfo comp) pkgConfigDb solver resolverParams) -- | Call an installer for an 'SourcePackage' but override the configure -- flags with the ones given by the 'ReadyPackage'. In particular the @@ -371,66 +486,94 @@ planLocalPackage verbosity comp platform configFlags configExFlags -- -- NB: when updating this function, don't forget to also update -- 'installReadyPackage' in D.C.Install. -configurePackage :: Verbosity - -> Platform -> CompilerInfo - -> SetupScriptOptions - -> ConfigFlags - -> ReadyPackage - -> [String] - -> IO () -configurePackage verbosity platform comp scriptOptions configFlags - (ReadyPackage (ConfiguredPackage ipid spkg flags stanzas deps)) - extraArgs = - - setupWrapper verbosity - scriptOptions (Just pkg) configureCommand configureFlags (const extraArgs) - - where - gpkg :: PkgDesc.GenericPackageDescription - gpkg = srcpkgDescription spkg - configureFlags :: Version -> ConfigFlags - configureFlags = filterConfigureFlags configFlags { - configIPID = if isJust (flagToMaybe (configIPID configFlags)) - -- Make sure cabal configure --ipid works. - then configIPID configFlags - else toFlag (prettyShow ipid), - configConfigurationsFlags = flags, - -- We generate the legacy constraints as well as the new style precise - -- deps. In the end only one set gets passed to Setup.hs configure, - -- depending on the Cabal version we are talking to. - configConstraints = [ thisPackageVersionConstraint srcid - | ConfiguredId srcid (Just (PkgDesc.CLibName PkgDesc.LMainLibName)) _uid - <- CD.nonSetupDeps deps ], - configDependencies = [ GivenComponent (packageName srcid) cname uid - | ConfiguredId srcid (Just (PkgDesc.CLibName cname)) uid - <- CD.nonSetupDeps deps ], - -- 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.) - configBenchmarks = toFlag (BenchStanzas `optStanzaSetMember` stanzas) - `mappend` configBenchmarks configFlags, - configTests = toFlag (TestStanzas `optStanzaSetMember` stanzas) - `mappend` configTests configFlags - } - - pkg :: PkgDesc.PackageDescription - pkg = case finalizePD flags (enableStanzas stanzas) - (const True) - platform comp [] gpkg of - Left _ -> error "finalizePD ReadyPackage failed" - Right (desc, _) -> desc +configurePackage + :: Verbosity + -> Platform + -> CompilerInfo + -> SetupScriptOptions + -> ConfigFlags + -> ReadyPackage + -> [String] + -> IO () +configurePackage + verbosity + platform + comp + scriptOptions + configFlags + (ReadyPackage (ConfiguredPackage ipid spkg flags stanzas deps)) + extraArgs = + setupWrapper + verbosity + scriptOptions + (Just pkg) + configureCommand + configureFlags + (const extraArgs) + where + gpkg :: PkgDesc.GenericPackageDescription + gpkg = srcpkgDescription spkg + configureFlags :: Version -> ConfigFlags + configureFlags = + filterConfigureFlags + configFlags + { configIPID = + if isJust (flagToMaybe (configIPID configFlags)) + then -- Make sure cabal configure --ipid works. + configIPID configFlags + else toFlag (prettyShow ipid) + , configConfigurationsFlags = flags + , -- We generate the legacy constraints as well as the new style precise + -- deps. In the end only one set gets passed to Setup.hs configure, + -- depending on the Cabal version we are talking to. + configConstraints = + [ thisPackageVersionConstraint srcid + | ConfiguredId srcid (Just (PkgDesc.CLibName PkgDesc.LMainLibName)) _uid <- + CD.nonSetupDeps deps + ] + , configDependencies = + [ GivenComponent (packageName srcid) cname uid + | ConfiguredId srcid (Just (PkgDesc.CLibName cname)) uid <- + CD.nonSetupDeps deps + ] + , -- 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.) + configBenchmarks = + toFlag (BenchStanzas `optStanzaSetMember` stanzas) + `mappend` configBenchmarks configFlags + , configTests = + toFlag (TestStanzas `optStanzaSetMember` stanzas) + `mappend` configTests configFlags + } + + pkg :: PkgDesc.PackageDescription + pkg = case finalizePD + flags + (enableStanzas stanzas) + (const True) + platform + comp + [] + gpkg of + Left _ -> error "finalizePD ReadyPackage failed" + Right (desc, _) -> desc -- ----------------------------------------------------------------------------- + -- * Saved configure environments and flags + -- ----------------------------------------------------------------------------- -- | Read saved configure flags and restore the saved environment from the -- specified files. -readConfigFlagsFrom :: FilePath -- ^ path to saved flags file - -> IO (ConfigFlags, ConfigExFlags) +readConfigFlagsFrom + :: FilePath + -- ^ path to saved flags file + -> IO (ConfigFlags, ConfigExFlags) readConfigFlagsFrom flags = do readCommandFlags flags configureExCommand @@ -441,21 +584,29 @@ cabalConfigFlagsFile dist = dist "cabal-config-flags" -- | Read saved configure flags and restore the saved environment from the -- usual location. -readConfigFlags :: FilePath -- ^ @--build-dir@ - -> IO (ConfigFlags, ConfigExFlags) +readConfigFlags + :: FilePath + -- ^ @--build-dir@ + -> IO (ConfigFlags, ConfigExFlags) readConfigFlags dist = readConfigFlagsFrom (cabalConfigFlagsFile dist) -- | Save the configure flags and environment to the specified files. -writeConfigFlagsTo :: FilePath -- ^ path to saved flags file - -> Verbosity -> (ConfigFlags, ConfigExFlags) - -> IO () +writeConfigFlagsTo + :: FilePath + -- ^ path to saved flags file + -> Verbosity + -> (ConfigFlags, ConfigExFlags) + -> IO () writeConfigFlagsTo file verb flags = do writeCommandFlags verb file configureExCommand flags -- | Save the build flags to the usual location. -writeConfigFlags :: Verbosity - -> FilePath -- ^ @--build-dir@ - -> (ConfigFlags, ConfigExFlags) -> IO () +writeConfigFlags + :: Verbosity + -> FilePath + -- ^ @--build-dir@ + -> (ConfigFlags, ConfigExFlags) + -> IO () writeConfigFlags verb dist = writeConfigFlagsTo (cabalConfigFlagsFile dist) verb diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index 3c3e8614241..5bc5ec51b86 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -1,4 +1,7 @@ ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.Dependency -- Copyright : (c) David Himmelstrup 2005, @@ -11,384 +14,432 @@ -- Portability : portable -- -- Top level interface to dependency resolution. ------------------------------------------------------------------------------ -module Distribution.Client.Dependency ( - -- * The main package dependency resolver - DepResolverParams, - chooseSolver, - resolveDependencies, - Progress(..), - foldProgress, +module Distribution.Client.Dependency + ( -- * The main package dependency resolver + DepResolverParams + , chooseSolver + , resolveDependencies + , Progress (..) + , foldProgress -- * Alternate, simple resolver that does not do dependencies recursively - resolveWithoutDependencies, + , resolveWithoutDependencies -- * Constructing resolver policies - PackageProperty(..), - PackageConstraint(..), - scopeToplevel, - PackagesPreferenceDefault(..), - PackagePreference(..), + , PackageProperty (..) + , PackageConstraint (..) + , scopeToplevel + , PackagesPreferenceDefault (..) + , PackagePreference (..) -- ** Standard policy - basicInstallPolicy, - standardInstallPolicy, - PackageSpecifier(..), + , basicInstallPolicy + , standardInstallPolicy + , PackageSpecifier (..) -- ** Extra policy options - upgradeDependencies, - reinstallTargets, + , upgradeDependencies + , reinstallTargets -- ** Policy utils - addConstraints, - addPreferences, - setPreferenceDefault, - setReorderGoals, - setCountConflicts, - setFineGrainedConflicts, - setMinimizeConflictSet, - setIndependentGoals, - setAvoidReinstalls, - setShadowPkgs, - setStrongFlags, - setAllowBootLibInstalls, - setOnlyConstrained, - setMaxBackjumps, - setEnableBackjumping, - setSolveExecutables, - setGoalOrder, - setSolverVerbosity, - removeLowerBounds, - removeUpperBounds, - addDefaultSetupDependencies, - addSetupCabalMinVersionConstraint, - addSetupCabalMaxVersionConstraint, + , addConstraints + , addPreferences + , setPreferenceDefault + , setReorderGoals + , setCountConflicts + , setFineGrainedConflicts + , setMinimizeConflictSet + , setIndependentGoals + , setAvoidReinstalls + , setShadowPkgs + , setStrongFlags + , setAllowBootLibInstalls + , setOnlyConstrained + , setMaxBackjumps + , setEnableBackjumping + , setSolveExecutables + , setGoalOrder + , setSolverVerbosity + , removeLowerBounds + , removeUpperBounds + , addDefaultSetupDependencies + , addSetupCabalMinVersionConstraint + , addSetupCabalMaxVersionConstraint ) where import Distribution.Client.Compat.Prelude import qualified Prelude as Unsafe (head) -import Distribution.Solver.Modular - ( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..) ) -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex +import Distribution.Client.Dependency.Types + ( PackagesPreferenceDefault (..) + , PreSolver (..) + , Solver (..) + ) import Distribution.Client.SolverInstallPlan (SolverInstallPlan) import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.Types - ( SourcePackageDb(SourcePackageDb) - , PackageSpecifier(..), pkgSpecifierTarget, pkgSpecifierConstraints - , UnresolvedPkgLoc, UnresolvedSourcePackage - , AllowNewer(..), AllowOlder(..), RelaxDeps(..), RelaxedDep(..) - , RelaxDepScope(..), RelaxDepMod(..), RelaxDepSubject(..), isRelaxDeps - ) -import Distribution.Client.Dependency.Types - ( PreSolver(..), Solver(..) - , PackagesPreferenceDefault(..) ) + ( AllowNewer (..) + , AllowOlder (..) + , PackageSpecifier (..) + , RelaxDepMod (..) + , RelaxDepScope (..) + , RelaxDepSubject (..) + , RelaxDeps (..) + , RelaxedDep (..) + , SourcePackageDb (SourcePackageDb) + , UnresolvedPkgLoc + , UnresolvedSourcePackage + , isRelaxDeps + , pkgSpecifierConstraints + , pkgSpecifierTarget + ) +import Distribution.Client.Utils + ( MergeResult (..) + , duplicatesBy + , mergeBy + ) +import qualified Distribution.Compat.Graph as Graph +import Distribution.Compiler + ( CompilerInfo (..) + ) import Distribution.Package - ( PackageName, mkPackageName, PackageIdentifier(PackageIdentifier), PackageId - , Package(..), packageName, packageVersion ) -import Distribution.Types.Dependency + ( Package (..) + , PackageId + , PackageIdentifier (PackageIdentifier) + , PackageName + , mkPackageName + , packageName + , packageVersion + ) import qualified Distribution.PackageDescription as PD -import qualified Distribution.PackageDescription.Configuration as PD import Distribution.PackageDescription.Configuration - ( finalizePD ) -import Distribution.Compiler - ( CompilerInfo(..) ) -import Distribution.System - ( Platform ) -import Distribution.Client.Utils - ( duplicatesBy, mergeBy, MergeResult(..) ) + ( finalizePD + ) +import qualified Distribution.PackageDescription.Configuration as PD +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import Distribution.Simple.Setup - ( asBool ) + ( asBool + ) +import Distribution.Solver.Modular + ( PruneAfterFirstSuccess (..) + , SolverConfig (..) + , modularResolver + ) +import Distribution.System + ( Platform + ) +import Distribution.Types.Dependency import Distribution.Verbosity - ( normal ) + ( normal + ) import Distribution.Version -import qualified Distribution.Compat.Graph as Graph -import Distribution.Solver.Types.ComponentDeps (ComponentDeps) +import Distribution.Solver.Types.ComponentDeps (ComponentDeps) import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.DependencyResolver -import Distribution.Solver.Types.InstalledPreference as Preference -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackageConstraint -import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.PackagePreferences +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.DependencyResolver +import Distribution.Solver.Types.InstalledPreference as Preference +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageConstraint import qualified Distribution.Solver.Types.PackageIndex as PackageIndex -import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb) -import Distribution.Solver.Types.Progress -import Distribution.Solver.Types.ResolverPackage -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.SolverId -import Distribution.Solver.Types.SolverPackage -import Distribution.Solver.Types.SourcePackage -import Distribution.Solver.Types.Variable +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.PackagePreferences +import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb) +import Distribution.Solver.Types.Progress +import Distribution.Solver.Types.ResolverPackage +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Variable +import Control.Exception + ( assert + ) import Data.List - ( maximumBy ) + ( maximumBy + ) import qualified Data.Map as Map import qualified Data.Set as Set -import Control.Exception - ( assert ) - -- ------------------------------------------------------------ + -- * High level planner policy + -- ------------------------------------------------------------ -- | The set of parameters to the dependency resolver. These parameters are -- relatively low level but many kinds of high level policies can be -- implemented in terms of adjustments to the parameters. --- -data DepResolverParams = DepResolverParams { - depResolverTargets :: Set PackageName, - depResolverConstraints :: [LabeledPackageConstraint], - depResolverPreferences :: [PackagePreference], - depResolverPreferenceDefault :: PackagesPreferenceDefault, - depResolverInstalledPkgIndex :: InstalledPackageIndex, - depResolverSourcePkgIndex :: PackageIndex.PackageIndex UnresolvedSourcePackage, - depResolverReorderGoals :: ReorderGoals, - depResolverCountConflicts :: CountConflicts, - depResolverFineGrainedConflicts :: FineGrainedConflicts, - depResolverMinimizeConflictSet :: MinimizeConflictSet, - depResolverIndependentGoals :: IndependentGoals, - depResolverAvoidReinstalls :: AvoidReinstalls, - depResolverShadowPkgs :: ShadowPkgs, - depResolverStrongFlags :: StrongFlags, - - -- | Whether to allow base and its dependencies to be installed. - depResolverAllowBootLibInstalls :: AllowBootLibInstalls, - - -- | Whether to only allow explicitly constrained packages plus - -- goals or to allow any package. - depResolverOnlyConstrained :: OnlyConstrained, - - depResolverMaxBackjumps :: Maybe Int, - depResolverEnableBackjumping :: EnableBackjumping, - -- | Whether or not to solve for dependencies on executables. - -- This should be true, except in the legacy code path where - -- we can't tell if an executable has been installed or not, - -- so we shouldn't solve for them. See #3875. - depResolverSolveExecutables :: SolveExecutables, - - -- | Function to override the solver's goal-ordering heuristics. - depResolverGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering), - depResolverVerbosity :: Verbosity - } +data DepResolverParams = DepResolverParams + { depResolverTargets :: Set PackageName + , depResolverConstraints :: [LabeledPackageConstraint] + , depResolverPreferences :: [PackagePreference] + , depResolverPreferenceDefault :: PackagesPreferenceDefault + , depResolverInstalledPkgIndex :: InstalledPackageIndex + , depResolverSourcePkgIndex :: PackageIndex.PackageIndex UnresolvedSourcePackage + , depResolverReorderGoals :: ReorderGoals + , depResolverCountConflicts :: CountConflicts + , depResolverFineGrainedConflicts :: FineGrainedConflicts + , depResolverMinimizeConflictSet :: MinimizeConflictSet + , depResolverIndependentGoals :: IndependentGoals + , depResolverAvoidReinstalls :: AvoidReinstalls + , depResolverShadowPkgs :: ShadowPkgs + , depResolverStrongFlags :: StrongFlags + , depResolverAllowBootLibInstalls :: AllowBootLibInstalls + -- ^ Whether to allow base and its dependencies to be installed. + , depResolverOnlyConstrained :: OnlyConstrained + -- ^ Whether to only allow explicitly constrained packages plus + -- goals or to allow any package. + , depResolverMaxBackjumps :: Maybe Int + , depResolverEnableBackjumping :: EnableBackjumping + , depResolverSolveExecutables :: SolveExecutables + -- ^ Whether or not to solve for dependencies on executables. + -- This should be true, except in the legacy code path where + -- we can't tell if an executable has been installed or not, + -- so we shouldn't solve for them. See #3875. + , depResolverGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering) + -- ^ Function to override the solver's goal-ordering heuristics. + , depResolverVerbosity :: Verbosity + } showDepResolverParams :: DepResolverParams -> String showDepResolverParams p = - "targets: " ++ intercalate ", " (map prettyShow $ Set.toList (depResolverTargets p)) - ++ "\nconstraints: " - ++ concatMap (("\n " ++) . showLabeledConstraint) - (depResolverConstraints p) - ++ "\npreferences: " - ++ concatMap (("\n " ++) . showPackagePreference) - (depResolverPreferences p) - ++ "\nstrategy: " ++ show (depResolverPreferenceDefault p) - ++ "\nreorder goals: " ++ show (asBool (depResolverReorderGoals p)) - ++ "\ncount conflicts: " ++ show (asBool (depResolverCountConflicts p)) - ++ "\nfine grained conflicts: " ++ show (asBool (depResolverFineGrainedConflicts p)) - ++ "\nminimize conflict set: " ++ show (asBool (depResolverMinimizeConflictSet p)) - ++ "\nindependent goals: " ++ show (asBool (depResolverIndependentGoals p)) - ++ "\navoid reinstalls: " ++ show (asBool (depResolverAvoidReinstalls p)) - ++ "\nshadow packages: " ++ show (asBool (depResolverShadowPkgs p)) - ++ "\nstrong flags: " ++ show (asBool (depResolverStrongFlags p)) - ++ "\nallow boot library installs: " ++ show (asBool (depResolverAllowBootLibInstalls p)) - ++ "\nonly constrained packages: " ++ show (depResolverOnlyConstrained p) - ++ "\nmax backjumps: " ++ maybe "infinite" show - (depResolverMaxBackjumps p) + "targets: " + ++ intercalate ", " (map prettyShow $ Set.toList (depResolverTargets p)) + ++ "\nconstraints: " + ++ concatMap + (("\n " ++) . showLabeledConstraint) + (depResolverConstraints p) + ++ "\npreferences: " + ++ concatMap + (("\n " ++) . showPackagePreference) + (depResolverPreferences p) + ++ "\nstrategy: " + ++ show (depResolverPreferenceDefault p) + ++ "\nreorder goals: " + ++ show (asBool (depResolverReorderGoals p)) + ++ "\ncount conflicts: " + ++ show (asBool (depResolverCountConflicts p)) + ++ "\nfine grained conflicts: " + ++ show (asBool (depResolverFineGrainedConflicts p)) + ++ "\nminimize conflict set: " + ++ show (asBool (depResolverMinimizeConflictSet p)) + ++ "\nindependent goals: " + ++ show (asBool (depResolverIndependentGoals p)) + ++ "\navoid reinstalls: " + ++ show (asBool (depResolverAvoidReinstalls p)) + ++ "\nshadow packages: " + ++ show (asBool (depResolverShadowPkgs p)) + ++ "\nstrong flags: " + ++ show (asBool (depResolverStrongFlags p)) + ++ "\nallow boot library installs: " + ++ show (asBool (depResolverAllowBootLibInstalls p)) + ++ "\nonly constrained packages: " + ++ show (depResolverOnlyConstrained p) + ++ "\nmax backjumps: " + ++ maybe + "infinite" + show + (depResolverMaxBackjumps p) where showLabeledConstraint :: LabeledPackageConstraint -> String showLabeledConstraint (LabeledPackageConstraint pc src) = - showPackageConstraint pc ++ " (" ++ showConstraintSource src ++ ")" + showPackageConstraint pc ++ " (" ++ showConstraintSource src ++ ")" -- | A package selection preference for a particular package. -- -- Preferences are soft constraints that the dependency resolver should try to -- respect where possible. It is not specified if preferences on some packages -- are more important than others. --- -data PackagePreference = - - -- | A suggested constraint on the version number. - PackageVersionPreference PackageName VersionRange - - -- | If we prefer versions of packages that are already installed. - | PackageInstalledPreference PackageName InstalledPreference - - -- | If we would prefer to enable these optional stanzas - -- (i.e. test suites and/or benchmarks) - | PackageStanzasPreference PackageName [OptionalStanza] - +data PackagePreference + = -- | A suggested constraint on the version number. + PackageVersionPreference PackageName VersionRange + | -- | If we prefer versions of packages that are already installed. + PackageInstalledPreference PackageName InstalledPreference + | -- | If we would prefer to enable these optional stanzas + -- (i.e. test suites and/or benchmarks) + PackageStanzasPreference PackageName [OptionalStanza] -- | Provide a textual representation of a package preference -- for debugging purposes. --- showPackagePreference :: PackagePreference -> String -showPackagePreference (PackageVersionPreference pn vr) = +showPackagePreference (PackageVersionPreference pn vr) = prettyShow pn ++ " " ++ prettyShow (simplifyVersionRange vr) showPackagePreference (PackageInstalledPreference pn ip) = prettyShow pn ++ " " ++ show ip showPackagePreference (PackageStanzasPreference pn st) = prettyShow pn ++ " " ++ show st -basicDepResolverParams :: InstalledPackageIndex - -> PackageIndex.PackageIndex UnresolvedSourcePackage - -> DepResolverParams +basicDepResolverParams + :: InstalledPackageIndex + -> PackageIndex.PackageIndex UnresolvedSourcePackage + -> DepResolverParams basicDepResolverParams installedPkgIndex sourcePkgIndex = - DepResolverParams { - depResolverTargets = Set.empty, - depResolverConstraints = [], - depResolverPreferences = [], - depResolverPreferenceDefault = PreferLatestForSelected, - depResolverInstalledPkgIndex = installedPkgIndex, - depResolverSourcePkgIndex = sourcePkgIndex, - depResolverReorderGoals = ReorderGoals False, - depResolverCountConflicts = CountConflicts True, - depResolverFineGrainedConflicts = FineGrainedConflicts True, - depResolverMinimizeConflictSet = MinimizeConflictSet False, - depResolverIndependentGoals = IndependentGoals False, - depResolverAvoidReinstalls = AvoidReinstalls False, - depResolverShadowPkgs = ShadowPkgs False, - depResolverStrongFlags = StrongFlags False, - depResolverAllowBootLibInstalls = AllowBootLibInstalls False, - depResolverOnlyConstrained = OnlyConstrainedNone, - depResolverMaxBackjumps = Nothing, - depResolverEnableBackjumping = EnableBackjumping True, - depResolverSolveExecutables = SolveExecutables True, - depResolverGoalOrder = Nothing, - depResolverVerbosity = normal - } - -addTargets :: [PackageName] - -> DepResolverParams -> DepResolverParams + DepResolverParams + { depResolverTargets = Set.empty + , depResolverConstraints = [] + , depResolverPreferences = [] + , depResolverPreferenceDefault = PreferLatestForSelected + , depResolverInstalledPkgIndex = installedPkgIndex + , depResolverSourcePkgIndex = sourcePkgIndex + , depResolverReorderGoals = ReorderGoals False + , depResolverCountConflicts = CountConflicts True + , depResolverFineGrainedConflicts = FineGrainedConflicts True + , depResolverMinimizeConflictSet = MinimizeConflictSet False + , depResolverIndependentGoals = IndependentGoals False + , depResolverAvoidReinstalls = AvoidReinstalls False + , depResolverShadowPkgs = ShadowPkgs False + , depResolverStrongFlags = StrongFlags False + , depResolverAllowBootLibInstalls = AllowBootLibInstalls False + , depResolverOnlyConstrained = OnlyConstrainedNone + , depResolverMaxBackjumps = Nothing + , depResolverEnableBackjumping = EnableBackjumping True + , depResolverSolveExecutables = SolveExecutables True + , depResolverGoalOrder = Nothing + , depResolverVerbosity = normal + } + +addTargets + :: [PackageName] + -> DepResolverParams + -> DepResolverParams addTargets extraTargets params = - params { - depResolverTargets = Set.fromList extraTargets `Set.union` depResolverTargets params + params + { depResolverTargets = Set.fromList extraTargets `Set.union` depResolverTargets params } -addConstraints :: [LabeledPackageConstraint] - -> DepResolverParams -> DepResolverParams +addConstraints + :: [LabeledPackageConstraint] + -> DepResolverParams + -> DepResolverParams addConstraints extraConstraints params = - params { - depResolverConstraints = extraConstraints - ++ depResolverConstraints params + params + { depResolverConstraints = + extraConstraints + ++ depResolverConstraints params } -addPreferences :: [PackagePreference] - -> DepResolverParams -> DepResolverParams +addPreferences + :: [PackagePreference] + -> DepResolverParams + -> DepResolverParams addPreferences extraPreferences params = - params { - depResolverPreferences = extraPreferences - ++ depResolverPreferences params + params + { depResolverPreferences = + extraPreferences + ++ depResolverPreferences params } -setPreferenceDefault :: PackagesPreferenceDefault - -> DepResolverParams -> DepResolverParams +setPreferenceDefault + :: PackagesPreferenceDefault + -> DepResolverParams + -> DepResolverParams setPreferenceDefault preferenceDefault params = - params { - depResolverPreferenceDefault = preferenceDefault + params + { depResolverPreferenceDefault = preferenceDefault } setReorderGoals :: ReorderGoals -> DepResolverParams -> DepResolverParams setReorderGoals reorder params = - params { - depResolverReorderGoals = reorder + params + { depResolverReorderGoals = reorder } setCountConflicts :: CountConflicts -> DepResolverParams -> DepResolverParams setCountConflicts count params = - params { - depResolverCountConflicts = count + params + { depResolverCountConflicts = count } setFineGrainedConflicts :: FineGrainedConflicts -> DepResolverParams -> DepResolverParams setFineGrainedConflicts fineGrained params = - params { - depResolverFineGrainedConflicts = fineGrained + params + { depResolverFineGrainedConflicts = fineGrained } setMinimizeConflictSet :: MinimizeConflictSet -> DepResolverParams -> DepResolverParams setMinimizeConflictSet minimize params = - params { - depResolverMinimizeConflictSet = minimize + params + { depResolverMinimizeConflictSet = minimize } setIndependentGoals :: IndependentGoals -> DepResolverParams -> DepResolverParams setIndependentGoals indep params = - params { - depResolverIndependentGoals = indep + params + { depResolverIndependentGoals = indep } setAvoidReinstalls :: AvoidReinstalls -> DepResolverParams -> DepResolverParams setAvoidReinstalls avoid params = - params { - depResolverAvoidReinstalls = avoid + params + { depResolverAvoidReinstalls = avoid } setShadowPkgs :: ShadowPkgs -> DepResolverParams -> DepResolverParams setShadowPkgs shadow params = - params { - depResolverShadowPkgs = shadow + params + { depResolverShadowPkgs = shadow } setStrongFlags :: StrongFlags -> DepResolverParams -> DepResolverParams setStrongFlags sf params = - params { - depResolverStrongFlags = sf + params + { depResolverStrongFlags = sf } setAllowBootLibInstalls :: AllowBootLibInstalls -> DepResolverParams -> DepResolverParams setAllowBootLibInstalls i params = - params { - depResolverAllowBootLibInstalls = i + params + { depResolverAllowBootLibInstalls = i } setOnlyConstrained :: OnlyConstrained -> DepResolverParams -> DepResolverParams setOnlyConstrained i params = - params { - depResolverOnlyConstrained = i - } + params + { depResolverOnlyConstrained = i + } setMaxBackjumps :: Maybe Int -> DepResolverParams -> DepResolverParams setMaxBackjumps n params = - params { - depResolverMaxBackjumps = n + params + { depResolverMaxBackjumps = n } setEnableBackjumping :: EnableBackjumping -> DepResolverParams -> DepResolverParams setEnableBackjumping b params = - params { - depResolverEnableBackjumping = b + params + { depResolverEnableBackjumping = b } setSolveExecutables :: SolveExecutables -> DepResolverParams -> DepResolverParams setSolveExecutables b params = - params { - depResolverSolveExecutables = b + params + { depResolverSolveExecutables = b } -setGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering) - -> DepResolverParams - -> DepResolverParams +setGoalOrder + :: Maybe (Variable QPN -> Variable QPN -> Ordering) + -> DepResolverParams + -> DepResolverParams setGoalOrder order params = - params { - depResolverGoalOrder = order + params + { depResolverGoalOrder = order } setSolverVerbosity :: Verbosity -> DepResolverParams -> DepResolverParams setSolverVerbosity verbosity params = - params { - depResolverVerbosity = verbosity + params + { depResolverVerbosity = verbosity } -- | Some packages are specific to a given compiler version and should never be -- upgraded. dontUpgradeNonUpgradeablePackages :: DepResolverParams -> DepResolverParams dontUpgradeNonUpgradeablePackages params = - addConstraints extraConstraints params + addConstraints extraConstraints params where extraConstraints = [ LabeledPackageConstraint @@ -396,11 +447,14 @@ dontUpgradeNonUpgradeablePackages params = ConstraintSourceNonUpgradeablePackage | Set.notMember (mkPackageName "base") (depResolverTargets params) , pkgname <- nonUpgradeablePackages - , isInstalled pkgname ] + , isInstalled pkgname + ] - isInstalled = not . null - . InstalledPackageIndex.lookupPackageName - (depResolverInstalledPkgIndex params) + isInstalled = + not + . null + . InstalledPackageIndex.lookupPackageName + (depResolverInstalledPkgIndex params) -- NOTE: the lists of non-upgradable and non-installable packages used to be -- respectively in this module and in `Distribution.Solver.Modular.Solver`. @@ -420,44 +474,53 @@ nonUpgradeablePackages = , mkPackageName "template-haskell" ] -addSourcePackages :: [UnresolvedSourcePackage] - -> DepResolverParams -> DepResolverParams +addSourcePackages + :: [UnresolvedSourcePackage] + -> DepResolverParams + -> DepResolverParams addSourcePackages pkgs params = - params { - depResolverSourcePkgIndex = - foldl (flip PackageIndex.insert) - (depResolverSourcePkgIndex params) pkgs + params + { depResolverSourcePkgIndex = + foldl + (flip PackageIndex.insert) + (depResolverSourcePkgIndex params) + pkgs } -hideInstalledPackagesSpecificBySourcePackageId :: [PackageId] - -> DepResolverParams - -> DepResolverParams +hideInstalledPackagesSpecificBySourcePackageId + :: [PackageId] + -> DepResolverParams + -> DepResolverParams hideInstalledPackagesSpecificBySourcePackageId pkgids params = - --TODO: this should work using exclude constraints instead - params { - depResolverInstalledPkgIndex = - foldl' (flip InstalledPackageIndex.deleteSourcePackageId) - (depResolverInstalledPkgIndex params) pkgids + -- TODO: this should work using exclude constraints instead + params + { depResolverInstalledPkgIndex = + foldl' + (flip InstalledPackageIndex.deleteSourcePackageId) + (depResolverInstalledPkgIndex params) + pkgids } -hideInstalledPackagesAllVersions :: [PackageName] - -> DepResolverParams -> DepResolverParams +hideInstalledPackagesAllVersions + :: [PackageName] + -> DepResolverParams + -> DepResolverParams hideInstalledPackagesAllVersions pkgnames params = - --TODO: this should work using exclude constraints instead - params { - depResolverInstalledPkgIndex = - foldl' (flip InstalledPackageIndex.deletePackageName) - (depResolverInstalledPkgIndex params) pkgnames + -- TODO: this should work using exclude constraints instead + params + { depResolverInstalledPkgIndex = + foldl' + (flip InstalledPackageIndex.deletePackageName) + (depResolverInstalledPkgIndex params) + pkgnames } - -- | Remove upper bounds in dependencies using the policy specified by the -- 'AllowNewer' argument (all/some/none). -- -- Note: It's important to apply 'removeUpperBounds' after -- 'addSourcePackages'. Otherwise, the packages inserted by -- 'addSourcePackages' won't have upper bounds in dependencies relaxed. --- removeUpperBounds :: AllowNewer -> DepResolverParams -> DepResolverParams removeUpperBounds (AllowNewer relDeps) = removeBounds RelaxUpper relDeps @@ -470,63 +533,65 @@ data RelaxKind = RelaxLower | RelaxUpper -- | Common internal implementation of 'removeLowerBounds'/'removeUpperBounds' removeBounds :: RelaxKind -> RelaxDeps -> DepResolverParams -> DepResolverParams removeBounds _ rd params | not (isRelaxDeps rd) = params -- no-op optimisation -removeBounds relKind relDeps params = - params { - depResolverSourcePkgIndex = sourcePkgIndex' +removeBounds relKind relDeps params = + params + { depResolverSourcePkgIndex = sourcePkgIndex' } where sourcePkgIndex' :: PackageIndex.PackageIndex UnresolvedSourcePackage sourcePkgIndex' = relaxDeps <$> depResolverSourcePkgIndex params relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage - relaxDeps srcPkg = srcPkg - { srcpkgDescription = relaxPackageDeps relKind relDeps (srcpkgDescription srcPkg) - } + relaxDeps srcPkg = + srcPkg + { srcpkgDescription = relaxPackageDeps relKind relDeps (srcpkgDescription srcPkg) + } -- | Relax the dependencies of this package if needed. -- -- Helper function used by 'removeBounds' -relaxPackageDeps :: RelaxKind - -> RelaxDeps - -> PD.GenericPackageDescription -> PD.GenericPackageDescription +relaxPackageDeps + :: RelaxKind + -> RelaxDeps + -> PD.GenericPackageDescription + -> PD.GenericPackageDescription relaxPackageDeps _ rd gpd | not (isRelaxDeps rd) = gpd -- subsumed by no-op case in 'removeBounds' -relaxPackageDeps relKind RelaxDepsAll gpd = PD.transformAllBuildDepends relaxAll gpd +relaxPackageDeps relKind RelaxDepsAll gpd = PD.transformAllBuildDepends relaxAll gpd where relaxAll :: Dependency -> Dependency relaxAll (Dependency pkgName verRange cs) = - Dependency pkgName (removeBound relKind RelaxDepModNone verRange) cs - + Dependency pkgName (removeBound relKind RelaxDepModNone verRange) cs relaxPackageDeps relKind (RelaxDepsSome depsToRelax0) gpd = PD.transformAllBuildDepends relaxSome gpd where - thisPkgName = packageName gpd - thisPkgId = packageId gpd - depsToRelax = Map.fromList $ mapMaybe f depsToRelax0 + thisPkgName = packageName gpd + thisPkgId = packageId gpd + depsToRelax = Map.fromList $ mapMaybe f depsToRelax0 - f :: RelaxedDep -> Maybe (RelaxDepSubject,RelaxDepMod) + f :: RelaxedDep -> Maybe (RelaxDepSubject, RelaxDepMod) f (RelaxedDep scope rdm p) = case scope of - RelaxDepScopeAll -> Just (p,rdm) + RelaxDepScopeAll -> Just (p, rdm) RelaxDepScopePackage p0 - | p0 == thisPkgName -> Just (p,rdm) - | otherwise -> Nothing + | p0 == thisPkgName -> Just (p, rdm) + | otherwise -> Nothing RelaxDepScopePackageId p0 - | p0 == thisPkgId -> Just (p,rdm) - | otherwise -> Nothing + | p0 == thisPkgId -> Just (p, rdm) + | otherwise -> Nothing relaxSome :: Dependency -> Dependency relaxSome d@(Dependency depName verRange cs) - | Just relMod <- Map.lookup RelaxDepSubjectAll depsToRelax = - -- a '*'-subject acts absorbing, for consistency with - -- the 'Semigroup RelaxDeps' instance - Dependency depName (removeBound relKind relMod verRange) cs - | Just relMod <- Map.lookup (RelaxDepSubjectPkg depName) depsToRelax = - Dependency depName (removeBound relKind relMod verRange) cs - | otherwise = d -- no-op + | Just relMod <- Map.lookup RelaxDepSubjectAll depsToRelax = + -- a '*'-subject acts absorbing, for consistency with + -- the 'Semigroup RelaxDeps' instance + Dependency depName (removeBound relKind relMod verRange) cs + | Just relMod <- Map.lookup (RelaxDepSubjectPkg depName) depsToRelax = + Dependency depName (removeBound relKind relMod verRange) cs + | otherwise = d -- no-op -- | Internal helper for 'relaxPackageDeps' removeBound :: RelaxKind -> RelaxDepMod -> VersionRange -> VersionRange -removeBound RelaxLower RelaxDepModNone = removeLowerBound -removeBound RelaxUpper RelaxDepModNone = removeUpperBound +removeBound RelaxLower RelaxDepModNone = removeLowerBound +removeBound RelaxUpper RelaxDepModNone = removeUpperBound removeBound RelaxLower RelaxDepModCaret = transformCaretLower removeBound RelaxUpper RelaxDepModCaret = transformCaretUpper @@ -535,158 +600,167 @@ removeBound RelaxUpper RelaxDepModCaret = transformCaretUpper -- Note: It's important to apply 'addDefaultSetupDepends' after -- 'addSourcePackages'. Otherwise, the packages inserted by -- 'addSourcePackages' won't have upper bounds in dependencies relaxed. --- -addDefaultSetupDependencies :: (UnresolvedSourcePackage -> Maybe [Dependency]) - -> DepResolverParams -> DepResolverParams +addDefaultSetupDependencies + :: (UnresolvedSourcePackage -> Maybe [Dependency]) + -> DepResolverParams + -> DepResolverParams addDefaultSetupDependencies defaultSetupDeps params = - params { - depResolverSourcePkgIndex = + params + { depResolverSourcePkgIndex = fmap applyDefaultSetupDeps (depResolverSourcePkgIndex params) } where applyDefaultSetupDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage applyDefaultSetupDeps srcpkg = - srcpkg { - srcpkgDescription = gpkgdesc { - PD.packageDescription = pkgdesc { - PD.setupBuildInfo = - case PD.setupBuildInfo pkgdesc of - Just sbi -> Just sbi - Nothing -> case defaultSetupDeps srcpkg of - Nothing -> Nothing - Just deps | isCustom -> Just PD.SetupBuildInfo { - PD.defaultSetupDepends = True, - PD.setupDepends = deps - } + srcpkg + { srcpkgDescription = + gpkgdesc + { PD.packageDescription = + pkgdesc + { PD.setupBuildInfo = + case PD.setupBuildInfo pkgdesc of + Just sbi -> Just sbi + Nothing -> case defaultSetupDeps srcpkg of + Nothing -> Nothing + Just deps + | isCustom -> + Just + PD.SetupBuildInfo + { PD.defaultSetupDepends = True + , PD.setupDepends = deps + } | otherwise -> Nothing - } - } + } + } } where isCustom = PD.buildType pkgdesc == PD.Custom gpkgdesc = srcpkgDescription srcpkg - pkgdesc = PD.packageDescription gpkgdesc + pkgdesc = PD.packageDescription gpkgdesc -- | If a package has a custom setup then we need to add a setup-depends -- on Cabal. --- -addSetupCabalMinVersionConstraint :: Version - -> DepResolverParams -> DepResolverParams +addSetupCabalMinVersionConstraint + :: Version + -> DepResolverParams + -> DepResolverParams addSetupCabalMinVersionConstraint minVersion = - addConstraints - [ LabeledPackageConstraint - (PackageConstraint (ScopeAnySetupQualifier cabalPkgname) - (PackagePropertyVersion $ orLaterVersion minVersion)) - ConstraintSetupCabalMinVersion - ] + addConstraints + [ LabeledPackageConstraint + ( PackageConstraint + (ScopeAnySetupQualifier cabalPkgname) + (PackagePropertyVersion $ orLaterVersion minVersion) + ) + ConstraintSetupCabalMinVersion + ] where cabalPkgname = mkPackageName "Cabal" -- | Variant of 'addSetupCabalMinVersionConstraint' which sets an -- upper bound on @setup.Cabal@ labeled with 'ConstraintSetupCabalMaxVersion'. --- -addSetupCabalMaxVersionConstraint :: Version - -> DepResolverParams -> DepResolverParams +addSetupCabalMaxVersionConstraint + :: Version + -> DepResolverParams + -> DepResolverParams addSetupCabalMaxVersionConstraint maxVersion = - addConstraints - [ LabeledPackageConstraint - (PackageConstraint (ScopeAnySetupQualifier cabalPkgname) - (PackagePropertyVersion $ earlierVersion maxVersion)) - ConstraintSetupCabalMaxVersion - ] + addConstraints + [ LabeledPackageConstraint + ( PackageConstraint + (ScopeAnySetupQualifier cabalPkgname) + (PackagePropertyVersion $ earlierVersion maxVersion) + ) + ConstraintSetupCabalMaxVersion + ] where cabalPkgname = mkPackageName "Cabal" - upgradeDependencies :: DepResolverParams -> DepResolverParams upgradeDependencies = setPreferenceDefault PreferAllLatest - reinstallTargets :: DepResolverParams -> DepResolverParams reinstallTargets params = - hideInstalledPackagesAllVersions (Set.toList $ depResolverTargets params) params - + hideInstalledPackagesAllVersions (Set.toList $ depResolverTargets params) params -- | A basic solver policy on which all others are built. --- -basicInstallPolicy :: InstalledPackageIndex - -> SourcePackageDb - -> [PackageSpecifier UnresolvedSourcePackage] - -> DepResolverParams basicInstallPolicy - installedPkgIndex (SourcePackageDb sourcePkgIndex sourcePkgPrefs) - pkgSpecifiers - - = addPreferences + :: InstalledPackageIndex + -> SourcePackageDb + -> [PackageSpecifier UnresolvedSourcePackage] + -> DepResolverParams +basicInstallPolicy + installedPkgIndex + (SourcePackageDb sourcePkgIndex sourcePkgPrefs) + pkgSpecifiers = + addPreferences [ PackageVersionPreference name ver - | (name, ver) <- Map.toList sourcePkgPrefs ] - - . addConstraints - (concatMap pkgSpecifierConstraints pkgSpecifiers) - - . addTargets - (map pkgSpecifierTarget pkgSpecifiers) - - . hideInstalledPackagesSpecificBySourcePackageId - [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ] - - . addSourcePackages - [ pkg | SpecificSourcePackage pkg <- pkgSpecifiers ] - - $ basicDepResolverParams - installedPkgIndex sourcePkgIndex - + | (name, ver) <- Map.toList sourcePkgPrefs + ] + . addConstraints + (concatMap pkgSpecifierConstraints pkgSpecifiers) + . addTargets + (map pkgSpecifierTarget pkgSpecifiers) + . hideInstalledPackagesSpecificBySourcePackageId + [packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers] + . addSourcePackages + [pkg | SpecificSourcePackage pkg <- pkgSpecifiers] + $ basicDepResolverParams + installedPkgIndex + sourcePkgIndex -- | The policy used by all the standard commands, install, fetch, freeze etc -- (but not the v2-build and related commands). -- -- It extends the 'basicInstallPolicy' with a policy on setup deps. --- -standardInstallPolicy :: InstalledPackageIndex - -> SourcePackageDb - -> [PackageSpecifier UnresolvedSourcePackage] - -> DepResolverParams -standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers - - = addDefaultSetupDependencies mkDefaultSetupDeps - - $ basicInstallPolicy - installedPkgIndex sourcePkgDb pkgSpecifiers - - where - -- Force Cabal >= 1.24 dep when the package is affected by #3199. - mkDefaultSetupDeps :: UnresolvedSourcePackage -> Maybe [Dependency] - mkDefaultSetupDeps srcpkg | affected = - Just [Dependency (mkPackageName "Cabal") (orLaterVersion $ mkVersion [1,24]) mainLibSet] - | otherwise = Nothing - where - gpkgdesc = srcpkgDescription srcpkg - pkgdesc = PD.packageDescription gpkgdesc - bt = PD.buildType pkgdesc - affected = bt == PD.Custom && 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 - -- positives are possible. - hasBuildableFalse :: PD.GenericPackageDescription -> Bool - hasBuildableFalse gpkg = - not (all alwaysTrue (zipWith PD.cOr buildableConditions noDepConditions)) - where - buildableConditions = PD.extractConditions PD.buildable gpkg - noDepConditions = PD.extractConditions - (null . PD.targetBuildDepends) gpkg - alwaysTrue (PD.Lit True) = True - alwaysTrue _ = False +standardInstallPolicy + :: InstalledPackageIndex + -> SourcePackageDb + -> [PackageSpecifier UnresolvedSourcePackage] + -> DepResolverParams +standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers = + addDefaultSetupDependencies mkDefaultSetupDeps $ + basicInstallPolicy + installedPkgIndex + sourcePkgDb + pkgSpecifiers + where + -- Force Cabal >= 1.24 dep when the package is affected by #3199. + mkDefaultSetupDeps :: UnresolvedSourcePackage -> Maybe [Dependency] + mkDefaultSetupDeps srcpkg + | affected = + Just [Dependency (mkPackageName "Cabal") (orLaterVersion $ mkVersion [1, 24]) mainLibSet] + | otherwise = Nothing + where + gpkgdesc = srcpkgDescription srcpkg + pkgdesc = PD.packageDescription gpkgdesc + bt = PD.buildType pkgdesc + affected = bt == PD.Custom && 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 + -- positives are possible. + hasBuildableFalse :: PD.GenericPackageDescription -> Bool + hasBuildableFalse gpkg = + not (all alwaysTrue (zipWith PD.cOr buildableConditions noDepConditions)) + where + buildableConditions = PD.extractConditions PD.buildable gpkg + noDepConditions = + PD.extractConditions + (null . PD.targetBuildDepends) + gpkg + alwaysTrue (PD.Lit True) = True + alwaysTrue _ = False -- ------------------------------------------------------------ + -- * Interface to the standard resolver + -- ------------------------------------------------------------ chooseSolver :: Verbosity -> PreSolver -> CompilerInfo -> IO Solver chooseSolver _verbosity preSolver _cinfo = - case preSolver of - AlwaysModular -> do - return Modular + case preSolver of + AlwaysModular -> do + return Modular runSolver :: Solver -> SolverConfig -> DependencyResolver UnresolvedPkgLoc runSolver Modular = modularResolver @@ -696,279 +770,335 @@ runSolver Modular = modularResolver -- Since this is potentially an expensive operation, the result is wrapped in a -- a 'Progress' structure that can be unfolded to provide progress information, -- logging messages and the final result or an error. --- -resolveDependencies :: Platform - -> CompilerInfo - -> PkgConfigDb - -> Solver - -> DepResolverParams - -> Progress String String SolverInstallPlan - - --TODO: is this needed here? see dontUpgradeNonUpgradeablePackages +resolveDependencies + :: Platform + -> CompilerInfo + -> PkgConfigDb + -> Solver + -> DepResolverParams + -> Progress String String SolverInstallPlan +-- TODO: is this needed here? see dontUpgradeNonUpgradeablePackages resolveDependencies platform comp _pkgConfigDB _solver params - | Set.null (depResolverTargets params) - = return (validateSolverResult platform comp indGoals []) + | Set.null (depResolverTargets params) = + return (validateSolverResult platform comp indGoals []) where indGoals = depResolverIndependentGoals params - resolveDependencies platform comp pkgConfigDB solver params = - - Step (showDepResolverParams finalparams) - $ fmap (validateSolverResult platform comp indGoals) - $ runSolver solver (SolverConfig reordGoals cntConflicts fineGrained minimize - indGoals noReinstalls - shadowing strFlags allowBootLibs - -- See comment of nonUpgradeablePackages about - -- non-installable and non-upgradable packages. - nonUpgradeablePackages - onlyConstrained_ maxBkjumps enableBj - solveExes order verbosity (PruneAfterFirstSuccess False)) - platform comp installedPkgIndex sourcePkgIndex - pkgConfigDB preferences constraints targets + Step (showDepResolverParams finalparams) $ + fmap (validateSolverResult platform comp indGoals) $ + runSolver + solver + ( SolverConfig + reordGoals + cntConflicts + fineGrained + minimize + indGoals + noReinstalls + shadowing + strFlags + allowBootLibs + -- See comment of nonUpgradeablePackages about + -- non-installable and non-upgradable packages. + nonUpgradeablePackages + onlyConstrained_ + maxBkjumps + enableBj + solveExes + order + verbosity + (PruneAfterFirstSuccess False) + ) + platform + comp + installedPkgIndex + sourcePkgIndex + pkgConfigDB + preferences + constraints + targets where - - finalparams@(DepResolverParams - targets constraints - prefs defpref - installedPkgIndex - sourcePkgIndex - reordGoals - cntConflicts - fineGrained - minimize - indGoals - noReinstalls - shadowing - strFlags - allowBootLibs - onlyConstrained_ - maxBkjumps - enableBj - solveExes - order - verbosity) = + finalparams@( DepResolverParams + targets + constraints + prefs + defpref + installedPkgIndex + sourcePkgIndex + reordGoals + cntConflicts + fineGrained + minimize + indGoals + noReinstalls + shadowing + strFlags + allowBootLibs + onlyConstrained_ + maxBkjumps + enableBj + solveExes + order + verbosity + ) = if asBool (depResolverAllowBootLibInstalls params) - then params - else dontUpgradeNonUpgradeablePackages params + then params + else dontUpgradeNonUpgradeablePackages params preferences :: PackageName -> PackagePreferences preferences = interpretPackagesPreference targets defpref prefs - -- | Give an interpretation to the global 'PackagesPreference' as -- specific per-package 'PackageVersionPreference'. --- -interpretPackagesPreference :: Set PackageName - -> PackagesPreferenceDefault - -> [PackagePreference] - -> (PackageName -> PackagePreferences) +interpretPackagesPreference + :: Set PackageName + -> PackagesPreferenceDefault + -> [PackagePreference] + -> (PackageName -> PackagePreferences) interpretPackagesPreference selected defaultPref prefs = - \pkgname -> PackagePreferences (versionPref pkgname) - (installPref pkgname) - (stanzasPref pkgname) + \pkgname -> + PackagePreferences + (versionPref pkgname) + (installPref pkgname) + (stanzasPref pkgname) where versionPref :: PackageName -> [VersionRange] versionPref pkgname = fromMaybe [anyVersion] (Map.lookup pkgname versionPrefs) - versionPrefs = Map.fromListWith (++) - [(pkgname, [pref]) - | PackageVersionPreference pkgname pref <- prefs] + versionPrefs = + Map.fromListWith + (++) + [ (pkgname, [pref]) + | PackageVersionPreference pkgname pref <- prefs + ] installPref :: PackageName -> InstalledPreference installPref pkgname = fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs) - installPrefs = Map.fromList - [ (pkgname, pref) - | PackageInstalledPreference pkgname pref <- prefs ] + installPrefs = + Map.fromList + [ (pkgname, pref) + | PackageInstalledPreference pkgname pref <- prefs + ] installPrefDefault = case defaultPref of - PreferAllLatest -> const Preference.PreferLatest - PreferAllOldest -> const Preference.PreferOldest - PreferAllInstalled -> const Preference.PreferInstalled + PreferAllLatest -> const Preference.PreferLatest + PreferAllOldest -> const Preference.PreferOldest + PreferAllInstalled -> const Preference.PreferInstalled PreferLatestForSelected -> \pkgname -> -- When you say cabal install foo, what you really mean is, prefer the -- latest version of foo, but the installed version of everything else - if pkgname `Set.member` selected then Preference.PreferLatest - else Preference.PreferInstalled + if pkgname `Set.member` selected + then Preference.PreferLatest + else Preference.PreferInstalled stanzasPref :: PackageName -> [OptionalStanza] stanzasPref pkgname = fromMaybe [] (Map.lookup pkgname stanzasPrefs) - stanzasPrefs = Map.fromListWith (\a b -> nub (a ++ b)) - [ (pkgname, pref) - | PackageStanzasPreference pkgname pref <- prefs ] - + stanzasPrefs = + Map.fromListWith + (\a b -> nub (a ++ b)) + [ (pkgname, pref) + | PackageStanzasPreference pkgname pref <- prefs + ] -- ------------------------------------------------------------ + -- * Checking the result of the solver + -- ------------------------------------------------------------ -- | Make an install plan from the output of the dep resolver. -- It checks that the plan is valid, or it's an error in the dep resolver. --- -validateSolverResult :: Platform - -> CompilerInfo - -> IndependentGoals - -> [ResolverPackage UnresolvedPkgLoc] - -> SolverInstallPlan +validateSolverResult + :: Platform + -> CompilerInfo + -> IndependentGoals + -> [ResolverPackage UnresolvedPkgLoc] + -> SolverInstallPlan validateSolverResult platform comp indepGoals pkgs = - case planPackagesProblems platform comp pkgs of - [] -> case SolverInstallPlan.new indepGoals graph of - Right plan -> plan - Left problems -> error (formatPlanProblems problems) - problems -> error (formatPkgProblems problems) - + case planPackagesProblems platform comp pkgs of + [] -> case SolverInstallPlan.new indepGoals graph of + Right plan -> plan + Left problems -> error (formatPlanProblems problems) + problems -> error (formatPkgProblems problems) where graph :: Graph.Graph (ResolverPackage UnresolvedPkgLoc) graph = Graph.fromDistinctList pkgs formatPkgProblems :: [PlanPackageProblem] -> String - formatPkgProblems = formatProblemMessage . map showPlanPackageProblem + formatPkgProblems = formatProblemMessage . map showPlanPackageProblem formatPlanProblems :: [SolverInstallPlan.SolverPlanProblem] -> String formatPlanProblems = formatProblemMessage . map SolverInstallPlan.showPlanProblem formatProblemMessage problems = unlines $ "internal error: could not construct a valid install plan." - : "The proposed (invalid) plan contained the following problems:" - : problems - ++ "Proposed plan:" - : [SolverInstallPlan.showPlanIndex pkgs] - + : "The proposed (invalid) plan contained the following problems:" + : problems + ++ "Proposed plan:" + : [SolverInstallPlan.showPlanIndex pkgs] -data PlanPackageProblem = - InvalidConfiguredPackage (SolverPackage UnresolvedPkgLoc) - [PackageProblem] - | DuplicatePackageSolverId SolverId [ResolverPackage UnresolvedPkgLoc] +data PlanPackageProblem + = InvalidConfiguredPackage + (SolverPackage UnresolvedPkgLoc) + [PackageProblem] + | DuplicatePackageSolverId SolverId [ResolverPackage UnresolvedPkgLoc] showPlanPackageProblem :: PlanPackageProblem -> String showPlanPackageProblem (InvalidConfiguredPackage pkg packageProblems) = - "Package " ++ prettyShow (packageId pkg) - ++ " has an invalid configuration, in particular:\n" - ++ unlines [ " " ++ showPackageProblem problem - | problem <- packageProblems ] + "Package " + ++ prettyShow (packageId pkg) + ++ " has an invalid configuration, in particular:\n" + ++ unlines + [ " " ++ showPackageProblem problem + | problem <- packageProblems + ] showPlanPackageProblem (DuplicatePackageSolverId pid dups) = - "Package " ++ prettyShow (packageId pid) ++ " has " - ++ show (length dups) ++ " duplicate instances." - -planPackagesProblems :: Platform -> CompilerInfo - -> [ResolverPackage UnresolvedPkgLoc] - -> [PlanPackageProblem] + "Package " + ++ prettyShow (packageId pid) + ++ " has " + ++ show (length dups) + ++ " duplicate instances." + +planPackagesProblems + :: Platform + -> CompilerInfo + -> [ResolverPackage UnresolvedPkgLoc] + -> [PlanPackageProblem] planPackagesProblems platform cinfo pkgs = - [ InvalidConfiguredPackage pkg packageProblems - | Configured pkg <- pkgs - , let packageProblems = configuredPackageProblems platform cinfo pkg - , not (null packageProblems) ] - ++ [ DuplicatePackageSolverId (Graph.nodeKey (Unsafe.head dups)) dups - | dups <- duplicatesBy (comparing Graph.nodeKey) pkgs ] - -data PackageProblem = DuplicateFlag PD.FlagName - | MissingFlag PD.FlagName - | ExtraFlag PD.FlagName - | DuplicateDeps [PackageId] - | MissingDep Dependency - | ExtraDep PackageId - | InvalidDep Dependency PackageId + [ InvalidConfiguredPackage pkg packageProblems + | Configured pkg <- pkgs + , let packageProblems = configuredPackageProblems platform cinfo pkg + , not (null packageProblems) + ] + ++ [ DuplicatePackageSolverId (Graph.nodeKey (Unsafe.head dups)) dups + | dups <- duplicatesBy (comparing Graph.nodeKey) pkgs + ] + +data PackageProblem + = DuplicateFlag PD.FlagName + | MissingFlag PD.FlagName + | ExtraFlag PD.FlagName + | DuplicateDeps [PackageId] + | MissingDep Dependency + | ExtraDep PackageId + | InvalidDep Dependency PackageId showPackageProblem :: PackageProblem -> String showPackageProblem (DuplicateFlag flag) = "duplicate flag in the flag assignment: " ++ PD.unFlagName flag - showPackageProblem (MissingFlag flag) = "missing an assignment for the flag: " ++ PD.unFlagName flag - showPackageProblem (ExtraFlag flag) = "extra flag given that is not used by the package: " ++ PD.unFlagName flag - showPackageProblem (DuplicateDeps pkgids) = - "duplicate packages specified as selected dependencies: " - ++ intercalate ", " (map prettyShow pkgids) - + "duplicate packages specified as selected dependencies: " + ++ intercalate ", " (map prettyShow pkgids) showPackageProblem (MissingDep dep) = - "the package has a dependency " ++ prettyShow dep - ++ " but no package has been selected to satisfy it." - + "the package has a dependency " + ++ prettyShow dep + ++ " but no package has been selected to satisfy it." showPackageProblem (ExtraDep pkgid) = - "the package configuration specifies " ++ prettyShow pkgid - ++ " but (with the given flag assignment) the package does not actually" - ++ " depend on any version of that package." - + "the package configuration specifies " + ++ prettyShow pkgid + ++ " but (with the given flag assignment) the package does not actually" + ++ " depend on any version of that package." showPackageProblem (InvalidDep dep pkgid) = - "the package depends on " ++ prettyShow dep - ++ " but the configuration specifies " ++ prettyShow pkgid - ++ " which does not satisfy the dependency." + "the package depends on " + ++ prettyShow dep + ++ " but the configuration specifies " + ++ prettyShow pkgid + ++ " which does not satisfy the dependency." -- | A 'ConfiguredPackage' is valid if the flag assignment is total and if -- in the configuration given by the flag assignment, all the package -- dependencies are satisfied by the specified packages. --- -configuredPackageProblems :: Platform -> CompilerInfo - -> SolverPackage UnresolvedPkgLoc -> [PackageProblem] -configuredPackageProblems platform cinfo - (SolverPackage pkg specifiedFlags stanzas specifiedDeps0 _specifiedExeDeps') = - [ DuplicateFlag flag - | flag <- PD.findDuplicateFlagAssignments specifiedFlags ] - ++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ] - ++ [ ExtraFlag flag | OnlyInRight flag <- mergedFlags ] - ++ [ DuplicateDeps pkgs - | pkgs <- CD.nonSetupDeps (fmap (duplicatesBy (comparing packageName)) - specifiedDeps1) ] - ++ [ MissingDep dep | OnlyInLeft dep <- mergedDeps ] - ++ [ ExtraDep pkgid | OnlyInRight pkgid <- mergedDeps ] - ++ [ InvalidDep dep pkgid | InBoth dep pkgid <- mergedDeps - , not (packageSatisfiesDependency pkgid dep) ] - -- TODO: sanity tests on executable deps - where - thisPkgName :: PackageName - thisPkgName = packageName (srcpkgDescription pkg) - - specifiedDeps1 :: ComponentDeps [PackageId] - specifiedDeps1 = fmap (map solverSrcId) specifiedDeps0 - - specifiedDeps :: [PackageId] - specifiedDeps = CD.flatDeps specifiedDeps1 - - mergedFlags :: [MergeResult PD.FlagName PD.FlagName] - mergedFlags = mergeBy compare - (sort $ map PD.flagName (PD.genPackageFlags (srcpkgDescription pkg))) - (sort $ map fst (PD.unFlagAssignment specifiedFlags)) -- TODO - - packageSatisfiesDependency :: PackageIdentifier -> Dependency -> Bool - packageSatisfiesDependency - (PackageIdentifier name version) - (Dependency name' versionRange _) = assert (name == name') $ - version `withinRange` versionRange - - dependencyName (Dependency name _ _) = name - - mergedDeps :: [MergeResult Dependency PackageId] - mergedDeps = mergeDeps requiredDeps specifiedDeps - - mergeDeps :: [Dependency] -> [PackageId] - -> [MergeResult Dependency PackageId] - mergeDeps required specified = - let sortNubOn f = nubBy ((==) `on` f) . sortBy (compare `on` f) in - mergeBy - (\dep pkgid -> dependencyName dep `compare` packageName pkgid) - (sortNubOn dependencyName required) - (sortNubOn packageName specified) - - compSpec = enableStanzas stanzas - -- TODO: It would be nicer to use ComponentDeps here so we can be more - -- precise in our checks. In fact, this no longer relies on buildDepends and - -- thus should be easier to fix. As long as we _do_ use a flat list here, we - -- have to allow for duplicates when we fold specifiedDeps; once we have - -- proper ComponentDeps here we should get rid of the `nubOn` in - -- `mergeDeps`. - requiredDeps :: [Dependency] - requiredDeps = - --TODO: use something lower level than finalizePD - case finalizePD specifiedFlags - compSpec - (const True) - platform cinfo - [] - (srcpkgDescription pkg) of - Right (resolvedPkg, _) -> +configuredPackageProblems + :: Platform + -> CompilerInfo + -> SolverPackage UnresolvedPkgLoc + -> [PackageProblem] +configuredPackageProblems + platform + cinfo + (SolverPackage pkg specifiedFlags stanzas specifiedDeps0 _specifiedExeDeps') = + [ DuplicateFlag flag + | flag <- PD.findDuplicateFlagAssignments specifiedFlags + ] + ++ [MissingFlag flag | OnlyInLeft flag <- mergedFlags] + ++ [ExtraFlag flag | OnlyInRight flag <- mergedFlags] + ++ [ DuplicateDeps pkgs + | pkgs <- + CD.nonSetupDeps + ( fmap + (duplicatesBy (comparing packageName)) + specifiedDeps1 + ) + ] + ++ [MissingDep dep | OnlyInLeft dep <- mergedDeps] + ++ [ExtraDep pkgid | OnlyInRight pkgid <- mergedDeps] + ++ [ InvalidDep dep pkgid | InBoth dep pkgid <- mergedDeps, not (packageSatisfiesDependency pkgid dep) + ] + where + -- TODO: sanity tests on executable deps + + thisPkgName :: PackageName + thisPkgName = packageName (srcpkgDescription pkg) + + specifiedDeps1 :: ComponentDeps [PackageId] + specifiedDeps1 = fmap (map solverSrcId) specifiedDeps0 + + specifiedDeps :: [PackageId] + specifiedDeps = CD.flatDeps specifiedDeps1 + + mergedFlags :: [MergeResult PD.FlagName PD.FlagName] + mergedFlags = + mergeBy + compare + (sort $ map PD.flagName (PD.genPackageFlags (srcpkgDescription pkg))) + (sort $ map fst (PD.unFlagAssignment specifiedFlags)) -- TODO + packageSatisfiesDependency :: PackageIdentifier -> Dependency -> Bool + packageSatisfiesDependency + (PackageIdentifier name version) + (Dependency name' versionRange _) = + assert (name == name') $ + version `withinRange` versionRange + + dependencyName (Dependency name _ _) = name + + mergedDeps :: [MergeResult Dependency PackageId] + mergedDeps = mergeDeps requiredDeps specifiedDeps + + mergeDeps + :: [Dependency] + -> [PackageId] + -> [MergeResult Dependency PackageId] + mergeDeps required specified = + let sortNubOn f = nubBy ((==) `on` f) . sortBy (compare `on` f) + in mergeBy + (\dep pkgid -> dependencyName dep `compare` packageName pkgid) + (sortNubOn dependencyName required) + (sortNubOn packageName specified) + + compSpec = enableStanzas stanzas + -- TODO: It would be nicer to use ComponentDeps here so we can be more + -- precise in our checks. In fact, this no longer relies on buildDepends and + -- thus should be easier to fix. As long as we _do_ use a flat list here, we + -- have to allow for duplicates when we fold specifiedDeps; once we have + -- proper ComponentDeps here we should get rid of the `nubOn` in + -- `mergeDeps`. + requiredDeps :: [Dependency] + requiredDeps = + -- TODO: use something lower level than finalizePD + case finalizePD + specifiedFlags + compSpec + (const True) + platform + cinfo + [] + (srcpkgDescription pkg) of + Right (resolvedPkg, _) -> -- we filter self/internal dependencies. They are still there. -- This is INCORRECT. -- @@ -976,15 +1106,17 @@ configuredPackageProblems platform cinfo -- but no finalizePDs picks components we are not building, eg. exes. -- See #3775 -- - filter ((/= thisPkgName) . dependencyName) - (PD.enabledBuildDepends resolvedPkg compSpec) - ++ maybe [] PD.setupDepends (PD.setupBuildInfo resolvedPkg) - Left _ -> - error "configuredPackageInvalidDeps internal error" - + filter + ((/= thisPkgName) . dependencyName) + (PD.enabledBuildDepends resolvedPkg compSpec) + ++ maybe [] PD.setupDepends (PD.setupBuildInfo resolvedPkg) + Left _ -> + error "configuredPackageInvalidDeps internal error" -- ------------------------------------------------------------ + -- * Simple resolver that ignores dependencies + -- ------------------------------------------------------------ -- | A simplistic method of resolving a list of target package names to @@ -1000,80 +1132,105 @@ configuredPackageProblems platform cinfo -- -- Note: if no installed package index is available, it is OK to pass 'mempty'. -- It simply means preferences for installed packages will be ignored. --- -resolveWithoutDependencies :: DepResolverParams - -> Either [ResolveNoDepsError] [UnresolvedSourcePackage] -resolveWithoutDependencies (DepResolverParams targets constraints - prefs defpref installedPkgIndex sourcePkgIndex - _reorderGoals _countConflicts _fineGrained - _minimizeConflictSet _indGoals _avoidReinstalls - _shadowing _strFlags _maxBjumps _enableBj _solveExes - _allowBootLibInstalls _onlyConstrained _order _verbosity) = +resolveWithoutDependencies + :: DepResolverParams + -> Either [ResolveNoDepsError] [UnresolvedSourcePackage] +resolveWithoutDependencies + ( DepResolverParams + targets + constraints + prefs + defpref + installedPkgIndex + sourcePkgIndex + _reorderGoals + _countConflicts + _fineGrained + _minimizeConflictSet + _indGoals + _avoidReinstalls + _shadowing + _strFlags + _maxBjumps + _enableBj + _solveExes + _allowBootLibInstalls + _onlyConstrained + _order + _verbosity + ) = collectEithers $ map selectPackage (Set.toList targets) - where - selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage - selectPackage pkgname - | null choices = Left $! ResolveUnsatisfiable pkgname requiredVersions - | otherwise = Right $! maximumBy bestByPrefs choices - - where - -- Constraints - requiredVersions :: VersionRange - requiredVersions = packageConstraints pkgname - choices :: [UnresolvedSourcePackage] - choices = PackageIndex.lookupDependency sourcePkgIndex - pkgname - requiredVersions - - -- Preferences - PackagePreferences preferredVersions preferInstalled _ - = packagePreferences pkgname - - bestByPrefs :: UnresolvedSourcePackage -> UnresolvedSourcePackage -> Ordering - bestByPrefs = comparing $ \pkg -> - (installPref pkg, versionPref pkg, packageVersion pkg) - installPref :: UnresolvedSourcePackage -> Bool - installPref = case preferInstalled of - Preference.PreferLatest -> const False - Preference.PreferOldest -> const False - Preference.PreferInstalled -> not . null - . InstalledPackageIndex.lookupSourcePackageId - installedPkgIndex - . packageId - versionPref :: Package a => a -> Int - versionPref pkg = length . filter (packageVersion pkg `withinRange`) $ - preferredVersions - - packageConstraints :: PackageName -> VersionRange - packageConstraints pkgname = - Map.findWithDefault anyVersion pkgname packageVersionConstraintMap - packageVersionConstraintMap :: Map PackageName VersionRange - packageVersionConstraintMap = - let pcs = map unlabelPackageConstraint constraints - in Map.fromList [ (scopeToPackageName scope, range) - | PackageConstraint - scope (PackagePropertyVersion range) <- pcs ] - - packagePreferences :: PackageName -> PackagePreferences - packagePreferences = interpretPackagesPreference targets defpref prefs - + where + selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage + selectPackage pkgname + | null choices = Left $! ResolveUnsatisfiable pkgname requiredVersions + | otherwise = Right $! maximumBy bestByPrefs choices + where + -- Constraints + requiredVersions :: VersionRange + requiredVersions = packageConstraints pkgname + choices :: [UnresolvedSourcePackage] + choices = + PackageIndex.lookupDependency + sourcePkgIndex + pkgname + requiredVersions + + -- Preferences + PackagePreferences preferredVersions preferInstalled _ = + packagePreferences pkgname + + bestByPrefs :: UnresolvedSourcePackage -> UnresolvedSourcePackage -> Ordering + bestByPrefs = comparing $ \pkg -> + (installPref pkg, versionPref pkg, packageVersion pkg) + installPref :: UnresolvedSourcePackage -> Bool + installPref = case preferInstalled of + Preference.PreferLatest -> const False + Preference.PreferOldest -> const False + Preference.PreferInstalled -> + not + . null + . InstalledPackageIndex.lookupSourcePackageId + installedPkgIndex + . packageId + versionPref :: Package a => a -> Int + versionPref pkg = + length . filter (packageVersion pkg `withinRange`) $ + preferredVersions + + packageConstraints :: PackageName -> VersionRange + packageConstraints pkgname = + Map.findWithDefault anyVersion pkgname packageVersionConstraintMap + packageVersionConstraintMap :: Map PackageName VersionRange + packageVersionConstraintMap = + let pcs = map unlabelPackageConstraint constraints + in Map.fromList + [ (scopeToPackageName scope, range) + | PackageConstraint + scope + (PackagePropertyVersion range) <- + pcs + ] + + packagePreferences :: PackageName -> PackagePreferences + packagePreferences = interpretPackagesPreference targets defpref prefs collectEithers :: [Either a b] -> Either [a] [b] collectEithers = collect . partitionEithers where collect ([], xs) = Right xs - collect (errs,_) = Left errs + collect (errs, _) = Left errs -- | Errors for 'resolveWithoutDependencies'. --- -data ResolveNoDepsError = - - -- | A package name which cannot be resolved to a specific package. - -- Also gives the constraint on the version and whether there was - -- a constraint on the package being installed. - ResolveUnsatisfiable PackageName VersionRange +data ResolveNoDepsError + = -- | A package name which cannot be resolved to a specific package. + -- Also gives the constraint on the version and whether there was + -- a constraint on the package being installed. + ResolveUnsatisfiable PackageName VersionRange instance Show ResolveNoDepsError where show (ResolveUnsatisfiable name ver) = - "There is no available version of " ++ prettyShow name - ++ " that satisfies " ++ prettyShow (simplifyVersionRange ver) + "There is no available version of " + ++ prettyShow name + ++ " that satisfies " + ++ prettyShow (simplifyVersionRange ver) diff --git a/cabal-install/src/Distribution/Client/Dependency/Types.hs b/cabal-install/src/Distribution/Client/Dependency/Types.hs index 8ba96643d8e..78f97662008 100644 --- a/cabal-install/src/Distribution/Client/Dependency/Types.hs +++ b/cabal-install/src/Distribution/Client/Dependency/Types.hs @@ -1,8 +1,9 @@ {-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Dependency.Types ( - PreSolver(..), - Solver(..), - PackagesPreferenceDefault(..), + +module Distribution.Client.Dependency.Types + ( PreSolver (..) + , Solver (..) + , PackagesPreferenceDefault (..) ) where import Distribution.Client.Compat.Prelude @@ -12,7 +13,6 @@ import Text.PrettyPrint (text) import qualified Distribution.Compat.CharParsing as P - -- | All the solvers that can be selected. data PreSolver = AlwaysModular deriving (Eq, Ord, Show, Bounded, Enum, Generic) @@ -28,43 +28,35 @@ instance Structured PreSolver instance Structured Solver instance Pretty PreSolver where - pretty AlwaysModular = text "modular" + pretty AlwaysModular = text "modular" instance Parsec PreSolver where - parsec = do - name <- P.munch1 isAlpha - case map toLower name of - "modular" -> return AlwaysModular - _ -> P.unexpected $ "PreSolver: " ++ name + parsec = do + name <- P.munch1 isAlpha + case map toLower name of + "modular" -> return AlwaysModular + _ -> P.unexpected $ "PreSolver: " ++ name -- | Global policy for all packages to say if we prefer package versions that -- are already installed locally or if we just prefer the latest available. --- -data PackagesPreferenceDefault = - - -- | Always prefer the latest version irrespective of any existing - -- installed version. - -- - -- * This is the standard policy for upgrade. - -- - PreferAllLatest - - -- | Always prefer the oldest version irrespective of any existing - -- installed version or packages explicitly requested. - -- - -- * This is enabled by --prefer-oldest. - -- - | PreferAllOldest - - -- | Always prefer the installed versions over ones that would need to be - -- installed. Secondarily, prefer latest versions (eg the latest installed - -- version or if there are none then the latest source version). - | PreferAllInstalled - - -- | Prefer the latest version for packages that are explicitly requested - -- but prefers the installed version for any other packages. - -- - -- * This is the standard policy for install. - -- - | PreferLatestForSelected - deriving Show +data PackagesPreferenceDefault + = -- | Always prefer the latest version irrespective of any existing + -- installed version. + -- + -- * This is the standard policy for upgrade. + PreferAllLatest + | -- | Always prefer the oldest version irrespective of any existing + -- installed version or packages explicitly requested. + -- + -- * This is enabled by --prefer-oldest. + PreferAllOldest + | -- | Always prefer the installed versions over ones that would need to be + -- installed. Secondarily, prefer latest versions (eg the latest installed + -- version or if there are none then the latest source version). + PreferAllInstalled + | -- | Prefer the latest version for packages that are explicitly requested + -- but prefers the installed version for any other packages. + -- + -- * This is the standard policy for install. + PreferLatestForSelected + deriving (Show) diff --git a/cabal-install/src/Distribution/Client/DistDirLayout.hs b/cabal-install/src/Distribution/Client/DistDirLayout.hs index af59bdaa095..2b4bc54fb3e 100644 --- a/cabal-install/src/Distribution/Client/DistDirLayout.hs +++ b/cabal-install/src/Distribution/Client/DistDirLayout.hs @@ -4,26 +4,25 @@ -- -- The layout of the .\/dist\/ directory where cabal keeps all of its state -- and build artifacts. --- -module Distribution.Client.DistDirLayout ( - -- * 'DistDirLayout' - DistDirLayout(..), - DistDirParams(..), - defaultDistDirLayout, +module Distribution.Client.DistDirLayout + ( -- * 'DistDirLayout' + DistDirLayout (..) + , DistDirParams (..) + , defaultDistDirLayout -- * 'ProjectRoot' - ProjectRoot(..), - defaultProjectFile, + , ProjectRoot (..) + , defaultProjectFile -- * 'StoreDirLayout' - StoreDirLayout(..), - defaultStoreDirLayout, + , StoreDirLayout (..) + , defaultStoreDirLayout -- * 'CabalDirLayout' - CabalDirLayout(..), - mkCabalDirLayout, - defaultCabalDirLayout -) where + , CabalDirLayout (..) + , mkCabalDirLayout + , defaultCabalDirLayout + ) where import Distribution.Client.Compat.Prelude import Prelude () @@ -31,119 +30,102 @@ import Prelude () import System.FilePath import Distribution.Client.Config - ( defaultStoreDir, defaultLogsDir) -import Distribution.Package - ( PackageId, PackageIdentifier, ComponentId, UnitId ) + ( defaultLogsDir + , defaultStoreDir + ) import Distribution.Compiler +import Distribution.Package + ( ComponentId + , PackageId + , PackageIdentifier + , UnitId + ) import Distribution.Simple.Compiler - ( PackageDB(..), PackageDBStack, OptimisationLevel(..) ) + ( OptimisationLevel (..) + , PackageDB (..) + , PackageDBStack + ) +import Distribution.System import Distribution.Types.ComponentName import Distribution.Types.LibraryName -import Distribution.System - -- | Information which can be used to construct the path to -- the build directory of a build. This is LESS fine-grained -- than what goes into the hashed 'InstalledPackageId', -- and for good reason: we don't want this path to change if -- the user, say, adds a dependency to their project. -data DistDirParams = DistDirParams { - distParamUnitId :: UnitId, - distParamPackageId :: PackageId, - distParamComponentId :: ComponentId, - distParamComponentName :: Maybe ComponentName, - distParamCompilerId :: CompilerId, - distParamPlatform :: Platform, - distParamOptimization :: OptimisationLevel - -- TODO (see #3343): - -- Flag assignments - -- Optimization - } - +data DistDirParams = DistDirParams + { distParamUnitId :: UnitId + , distParamPackageId :: PackageId + , distParamComponentId :: ComponentId + , distParamComponentName :: Maybe ComponentName + , distParamCompilerId :: CompilerId + , distParamPlatform :: Platform + , distParamOptimization :: OptimisationLevel + -- TODO (see #3343): + -- Flag assignments + -- Optimization + } -- | The layout of the project state directory. Traditionally this has been -- called the @dist@ directory. --- -data DistDirLayout = DistDirLayout { - - -- | The root directory of the project. Many other files are relative to - -- this location (e.g. the @cabal.project@ file). - -- - distProjectRootDirectory :: FilePath, - - -- | The @cabal.project@ file and related like @cabal.project.freeze@. - -- The parameter is for the extension, like \"freeze\", or \"\" for the - -- main file. - -- - distProjectFile :: String -> FilePath, - - -- | The \"dist\" directory, which is the root of where cabal keeps all - -- its state including the build artifacts from each package we build. - -- - distDirectory :: FilePath, - - -- | The directory under dist where we keep the build artifacts for a - -- package we're building from a local directory. - -- - -- This uses a 'UnitId' not just a 'PackageName' because technically - -- we can have multiple instances of the same package in a solution - -- (e.g. setup deps). - -- - distBuildDirectory :: DistDirParams -> FilePath, - distBuildRootDirectory :: FilePath, - - -- | The directory under dist where we download tarballs and source - -- control repos to. - -- - distDownloadSrcDirectory :: FilePath, - - -- | The directory under dist where we put the unpacked sources of - -- packages, in those cases where it makes sense to keep the build - -- artifacts to reduce rebuild times. - -- - distUnpackedSrcDirectory :: PackageId -> FilePath, - distUnpackedSrcRootDirectory :: FilePath, - - -- | The location for project-wide cache files (e.g. state used in - -- incremental rebuilds). - -- - distProjectCacheFile :: String -> FilePath, - distProjectCacheDirectory :: FilePath, - - -- | The location for package-specific cache files (e.g. state used in - -- incremental rebuilds). - -- - distPackageCacheFile :: DistDirParams -> String -> FilePath, - distPackageCacheDirectory :: DistDirParams -> FilePath, - - -- | The location that sdists are placed by default. - distSdistFile :: PackageId -> FilePath, - distSdistDirectory :: FilePath, - - distTempDirectory :: FilePath, - distBinDirectory :: FilePath, - - distPackageDB :: CompilerId -> PackageDB, - - -- | Is needed when `--haddock-output-dir` flag is used. - distHaddockOutputDir :: Maybe FilePath - } - +data DistDirLayout = DistDirLayout + { distProjectRootDirectory :: FilePath + -- ^ The root directory of the project. Many other files are relative to + -- this location (e.g. the @cabal.project@ file). + , distProjectFile :: String -> FilePath + -- ^ The @cabal.project@ file and related like @cabal.project.freeze@. + -- The parameter is for the extension, like \"freeze\", or \"\" for the + -- main file. + , distDirectory :: FilePath + -- ^ The \"dist\" directory, which is the root of where cabal keeps all + -- its state including the build artifacts from each package we build. + , distBuildDirectory :: DistDirParams -> FilePath + -- ^ The directory under dist where we keep the build artifacts for a + -- package we're building from a local directory. + -- + -- This uses a 'UnitId' not just a 'PackageName' because technically + -- we can have multiple instances of the same package in a solution + -- (e.g. setup deps). + , distBuildRootDirectory :: FilePath + , distDownloadSrcDirectory :: FilePath + -- ^ The directory under dist where we download tarballs and source + -- control repos to. + , distUnpackedSrcDirectory :: PackageId -> FilePath + -- ^ The directory under dist where we put the unpacked sources of + -- packages, in those cases where it makes sense to keep the build + -- artifacts to reduce rebuild times. + , distUnpackedSrcRootDirectory :: FilePath + , distProjectCacheFile :: String -> FilePath + -- ^ The location for project-wide cache files (e.g. state used in + -- incremental rebuilds). + , distProjectCacheDirectory :: FilePath + , distPackageCacheFile :: DistDirParams -> String -> FilePath + -- ^ The location for package-specific cache files (e.g. state used in + -- incremental rebuilds). + , distPackageCacheDirectory :: DistDirParams -> FilePath + , distSdistFile :: PackageId -> FilePath + -- ^ The location that sdists are placed by default. + , distSdistDirectory :: FilePath + , distTempDirectory :: FilePath + , distBinDirectory :: FilePath + , distPackageDB :: CompilerId -> PackageDB + , distHaddockOutputDir :: Maybe FilePath + -- ^ Is needed when `--haddock-output-dir` flag is used. + } -- | The layout of a cabal nix-style store. --- -data StoreDirLayout = StoreDirLayout { - storeDirectory :: CompilerId -> FilePath, - storePackageDirectory :: CompilerId -> UnitId -> FilePath, - storePackageDBPath :: CompilerId -> FilePath, - storePackageDB :: CompilerId -> PackageDB, - storePackageDBStack :: CompilerId -> PackageDBStack, - storeIncomingDirectory :: CompilerId -> FilePath, - storeIncomingLock :: CompilerId -> UnitId -> FilePath - } - - ---TODO: move to another module, e.g. CabalDirLayout? +data StoreDirLayout = StoreDirLayout + { storeDirectory :: CompilerId -> FilePath + , storePackageDirectory :: CompilerId -> UnitId -> FilePath + , storePackageDBPath :: CompilerId -> FilePath + , storePackageDB :: CompilerId -> PackageDB + , storePackageDBStack :: CompilerId -> PackageDBStack + , storeIncomingDirectory :: CompilerId -> FilePath + , storeIncomingLock :: CompilerId -> UnitId -> FilePath + } + +-- TODO: move to another module, e.g. CabalDirLayout? -- or perhaps rename this module to DirLayouts. -- | The layout of the user-wide cabal directory, that is the @~/.cabal@ dir @@ -151,32 +133,26 @@ data StoreDirLayout = StoreDirLayout { -- -- At the moment this is just a partial specification, but the idea is -- eventually to cover it all. --- -data CabalDirLayout = CabalDirLayout { - cabalStoreDirLayout :: StoreDirLayout, - - cabalLogsDirectory :: FilePath - } - +data CabalDirLayout = CabalDirLayout + { cabalStoreDirLayout :: StoreDirLayout + , cabalLogsDirectory :: FilePath + } -- | Information about the root directory of the project. -- -- 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. --- -data ProjectRoot = - -- | An implicit project root. It contains the absolute project - -- root dir. - ProjectRootImplicit FilePath - - -- | An explicit project root. It contains the absolute project - -- root dir and the relative @cabal.project@ file (or explicit override) - | ProjectRootExplicit FilePath FilePath - - -- | An explicit, absolute project root dir and an explicit, absolute - -- @cabal.project@ file. - | ProjectRootExplicitAbsolute FilePath FilePath +data ProjectRoot + = -- | An implicit project root. It contains the absolute project + -- root dir. + ProjectRootImplicit FilePath + | -- | An explicit project root. It contains the absolute project + -- root dir and the relative @cabal.project@ file (or explicit override) + ProjectRootExplicit FilePath FilePath + | -- | An explicit, absolute project root dir and an explicit, absolute + -- @cabal.project@ file. + ProjectRootExplicitAbsolute FilePath FilePath deriving (Eq, Show) defaultProjectFile :: FilePath @@ -185,66 +161,74 @@ defaultProjectFile = "cabal.project" -- | Make the default 'DistDirLayout' based on the project root dir and -- optional overrides for the location of the @dist@ directory, the -- @cabal.project@ file and the documentation directory. --- -defaultDistDirLayout :: ProjectRoot -- ^ the project root - -> Maybe FilePath -- ^ the @dist@ directory or default - -- (absolute or relative to the root) - -> Maybe FilePath -- ^ the documentation directory - -> DistDirLayout +defaultDistDirLayout + :: ProjectRoot + -- ^ the project root + -> Maybe FilePath + -- ^ the @dist@ directory or default + -- (absolute or relative to the root) + -> Maybe FilePath + -- ^ the documentation directory + -> DistDirLayout defaultDistDirLayout projectRoot mdistDirectory haddockOutputDir = - DistDirLayout {..} + DistDirLayout{..} where (projectRootDir, projectFile) = case projectRoot of - ProjectRootImplicit dir -> (dir, dir defaultProjectFile) - ProjectRootExplicit dir file -> (dir, dir file) + ProjectRootImplicit dir -> (dir, dir defaultProjectFile) + ProjectRootExplicit dir file -> (dir, dir file) ProjectRootExplicitAbsolute dir file -> (dir, file) distProjectRootDirectory :: FilePath distProjectRootDirectory = projectRootDir distProjectFile :: String -> FilePath - distProjectFile ext = projectFile <.> ext + distProjectFile ext = projectFile <.> ext distDirectory :: FilePath - distDirectory = distProjectRootDirectory - fromMaybe "dist-newstyle" mdistDirectory - --TODO: switch to just dist at some point, or some other new name + distDirectory = + distProjectRootDirectory + fromMaybe "dist-newstyle" mdistDirectory + -- TODO: switch to just dist at some point, or some other new name distBuildRootDirectory :: FilePath - distBuildRootDirectory = distDirectory "build" + distBuildRootDirectory = distDirectory "build" distBuildDirectory :: DistDirParams -> FilePath distBuildDirectory params = - distBuildRootDirectory - prettyShow (distParamPlatform params) - prettyShow (distParamCompilerId params) - prettyShow (distParamPackageId params) - (case distParamComponentName params of - Nothing -> "" - Just (CLibName LMainLibName) -> "" - Just (CLibName (LSubLibName name)) -> "l" prettyShow name - Just (CFLibName name) -> "f" prettyShow name - Just (CExeName name) -> "x" prettyShow name - Just (CTestName name) -> "t" prettyShow name - Just (CBenchName name) -> "b" prettyShow name) - (case distParamOptimization params of - NoOptimisation -> "noopt" - NormalOptimisation -> "" - MaximumOptimisation -> "opt") - (let uid_str = prettyShow (distParamUnitId params) - in if uid_str == prettyShow (distParamComponentId params) - then "" - else uid_str) + distBuildRootDirectory + prettyShow (distParamPlatform params) + prettyShow (distParamCompilerId params) + prettyShow (distParamPackageId params) + ( case distParamComponentName params of + Nothing -> "" + Just (CLibName LMainLibName) -> "" + Just (CLibName (LSubLibName name)) -> "l" prettyShow name + Just (CFLibName name) -> "f" prettyShow name + Just (CExeName name) -> "x" prettyShow name + Just (CTestName name) -> "t" prettyShow name + Just (CBenchName name) -> "b" prettyShow name + ) + ( case distParamOptimization params of + NoOptimisation -> "noopt" + NormalOptimisation -> "" + MaximumOptimisation -> "opt" + ) + ( let uid_str = prettyShow (distParamUnitId params) + in if uid_str == prettyShow (distParamComponentId params) + then "" + else uid_str + ) distUnpackedSrcRootDirectory :: FilePath - distUnpackedSrcRootDirectory = distDirectory "src" + distUnpackedSrcRootDirectory = distDirectory "src" distUnpackedSrcDirectory :: PackageId -> FilePath - distUnpackedSrcDirectory pkgid = distUnpackedSrcRootDirectory - prettyShow pkgid + distUnpackedSrcDirectory pkgid = + distUnpackedSrcRootDirectory + prettyShow pkgid -- we shouldn't get name clashes so this should be fine: distDownloadSrcDirectory :: FilePath - distDownloadSrcDirectory = distUnpackedSrcRootDirectory + distDownloadSrcDirectory = distUnpackedSrcRootDirectory distProjectCacheDirectory :: FilePath distProjectCacheDirectory = distDirectory "cache" @@ -281,7 +265,7 @@ defaultDistDirLayout projectRoot mdistDirectory haddockOutputDir = defaultStoreDirLayout :: FilePath -> StoreDirLayout defaultStoreDirLayout storeRoot = - StoreDirLayout {..} + StoreDirLayout{..} where storeDirectory :: CompilerId -> FilePath storeDirectory compid = @@ -311,17 +295,19 @@ defaultStoreDirLayout storeRoot = storeIncomingLock compid unitid = storeIncomingDirectory compid prettyShow unitid <.> "lock" - defaultCabalDirLayout :: IO CabalDirLayout defaultCabalDirLayout = - mkCabalDirLayout Nothing Nothing - -mkCabalDirLayout :: Maybe FilePath -- ^ Store directory. Must be absolute - -> Maybe FilePath -- ^ Log directory - -> IO CabalDirLayout + mkCabalDirLayout Nothing Nothing + +mkCabalDirLayout + :: Maybe FilePath + -- ^ Store directory. Must be absolute + -> Maybe FilePath + -- ^ Log directory + -> IO CabalDirLayout mkCabalDirLayout mstoreDir mlogDir = do - cabalStoreDirLayout <- - defaultStoreDirLayout <$> maybe defaultStoreDir pure mstoreDir - cabalLogsDirectory <- - maybe defaultLogsDir pure mlogDir - pure $ CabalDirLayout {..} + cabalStoreDirLayout <- + defaultStoreDirLayout <$> maybe defaultStoreDir pure mstoreDir + cabalLogsDirectory <- + maybe defaultLogsDir pure mlogDir + pure $ CabalDirLayout{..} diff --git a/cabal-install/src/Distribution/Client/Fetch.hs b/cabal-install/src/Distribution/Client/Fetch.hs index 9dcdfb902a9..724c583b661 100644 --- a/cabal-install/src/Distribution/Client/Fetch.hs +++ b/cabal-install/src/Distribution/Client/Fetch.hs @@ -10,223 +10,267 @@ -- -- The cabal fetch command ----------------------------------------------------------------------------- -module Distribution.Client.Fetch ( - fetch, +module Distribution.Client.Fetch + ( fetch ) where import Distribution.Client.Compat.Prelude import Prelude () -import Distribution.Client.Types -import Distribution.Client.Targets -import Distribution.Client.FetchUtils hiding (fetchPackage) import Distribution.Client.Dependency +import Distribution.Client.FetchUtils hiding (fetchPackage) import Distribution.Client.IndexUtils as IndexUtils - ( getSourcePackages, getInstalledPackages ) -import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan + ( getInstalledPackages + , getSourcePackages + ) import Distribution.Client.Setup - ( GlobalFlags(..), FetchFlags(..), RepoContext(..) ) + ( FetchFlags (..) + , GlobalFlags (..) + , RepoContext (..) + ) +import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan +import Distribution.Client.Targets +import Distribution.Client.Types import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb, readPkgConfigDb ) +import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, readPkgConfigDb) import Distribution.Solver.Types.SolverPackage import Distribution.Solver.Types.SourcePackage import Distribution.Package - ( packageId ) + ( packageId + ) import Distribution.Simple.Compiler - ( Compiler, compilerInfo, PackageDBStack ) + ( Compiler + , PackageDBStack + , compilerInfo + ) import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.Simple.Program - ( ProgramDb ) + ( ProgramDb + ) import Distribution.Simple.Setup - ( fromFlag, fromFlagOrDefault ) + ( fromFlag + , fromFlagOrDefault + ) import Distribution.Simple.Utils - ( die', notice, debug ) + ( debug + , die' + , notice + ) import Distribution.System - ( Platform ) + ( Platform + ) -- ------------------------------------------------------------ + -- * The fetch command + -- ------------------------------------------------------------ ---TODO: +-- TODO: + -- * add fetch -o support + -- * support tarball URLs via ad-hoc download cache (or in -o mode?) + -- * suggest using --no-deps, unpack or fetch -o if deps cannot be satisfied + -- * Port various flags from install: + -- * --upgrade-dependencies -- * --constraint and --preference -- * --only-dependencies, but note it conflicts with --no-deps - -- | Fetch a list of packages and their dependencies. --- -fetch :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> Platform - -> ProgramDb - -> GlobalFlags - -> FetchFlags - -> [UserTarget] - -> IO () +fetch + :: Verbosity + -> PackageDBStack + -> RepoContext + -> Compiler + -> Platform + -> ProgramDb + -> GlobalFlags + -> FetchFlags + -> [UserTarget] + -> IO () fetch verbosity _ _ _ _ _ _ _ [] = - notice verbosity "No packages requested. Nothing to do." - -fetch verbosity packageDBs repoCtxt comp platform progdb - _ fetchFlags userTargets = do - + notice verbosity "No packages requested. Nothing to do." +fetch + verbosity + packageDBs + repoCtxt + comp + platform + progdb + _ + fetchFlags + userTargets = do traverse_ (checkTarget verbosity) userTargets installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb - sourcePkgDb <- getSourcePackages verbosity repoCtxt - pkgConfigDb <- readPkgConfigDb verbosity progdb - - pkgSpecifiers <- resolveUserTargets verbosity repoCtxt - (packageIndex sourcePkgDb) - userTargets - - pkgs <- planPackages - verbosity comp platform fetchFlags - installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers + sourcePkgDb <- getSourcePackages verbosity repoCtxt + pkgConfigDb <- readPkgConfigDb verbosity progdb + + pkgSpecifiers <- + resolveUserTargets + verbosity + repoCtxt + (packageIndex sourcePkgDb) + userTargets + + pkgs <- + planPackages + verbosity + comp + platform + fetchFlags + installedPkgIndex + sourcePkgDb + pkgConfigDb + pkgSpecifiers pkgs' <- filterM (fmap not . isFetched . srcpkgSource) pkgs if null pkgs' - --TODO: when we add support for remote tarballs then this message + then -- TODO: when we add support for remote tarballs then this message -- will need to be changed because for remote tarballs we fetch them -- at the earlier phase. - then notice verbosity $ "No packages need to be fetched. " - ++ "All the requested packages are already local " - ++ "or cached locally." - else if dryRun - then notice verbosity $ unlines $ - "The following packages would be fetched:" - : map (prettyShow . packageId) pkgs' - - else traverse_ (fetchPackage verbosity repoCtxt . srcpkgSource) pkgs' - - where - dryRun = fromFlag (fetchDryRun fetchFlags) - -planPackages :: Verbosity - -> Compiler - -> Platform - -> FetchFlags - -> InstalledPackageIndex - -> SourcePackageDb - -> PkgConfigDb - -> [PackageSpecifier UnresolvedSourcePackage] - -> IO [UnresolvedSourcePackage] -planPackages verbosity comp platform fetchFlags - installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers - - | includeDependencies = do - solver <- chooseSolver verbosity - (fromFlag (fetchSolver fetchFlags)) (compilerInfo comp) - notice verbosity "Resolving dependencies..." - installPlan <- foldProgress logMsg (die' verbosity) return $ - resolveDependencies - platform (compilerInfo comp) pkgConfigDb - solver - resolverParams - - -- The packages we want to fetch are those packages the 'InstallPlan' - -- that are in the 'InstallPlan.Configured' state. - return - [ solverPkgSource cpkg - | (SolverInstallPlan.Configured cpkg) - <- SolverInstallPlan.toList installPlan ] - - | otherwise = - either (die' verbosity . unlines . map show) return $ - resolveWithoutDependencies resolverParams - - where - resolverParams :: DepResolverParams - resolverParams = - - setMaxBackjumps (if maxBackjumps < 0 then Nothing - else Just maxBackjumps) - - . setIndependentGoals independentGoals - - . setReorderGoals reorderGoals - - . setCountConflicts countConflicts - - . setFineGrainedConflicts fineGrainedConflicts - - . setMinimizeConflictSet minimizeConflictSet - - . setShadowPkgs shadowPkgs - - . setStrongFlags strongFlags - - . setAllowBootLibInstalls allowBootLibInstalls - - . setOnlyConstrained onlyConstrained - - . setSolverVerbosity verbosity - - . addConstraints - [ let pc = PackageConstraint - (scopeToplevel $ pkgSpecifierTarget pkgSpecifier) - (PackagePropertyStanzas stanzas) - in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget - | pkgSpecifier <- pkgSpecifiers ] - - -- Reinstall the targets given on the command line so that the dep - -- resolver will decide that they need fetching, even if they're - -- already installed. Since we want to get the source packages of - -- things we might have installed (but not have the sources for). - . reinstallTargets - - $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers - - includeDependencies = fromFlag (fetchDeps fetchFlags) - logMsg message rest = debug verbosity message >> rest - - stanzas = [ TestStanzas | testsEnabled ] - ++ [ BenchStanzas | benchmarksEnabled ] - testsEnabled = fromFlagOrDefault False $ fetchTests fetchFlags - benchmarksEnabled = fromFlagOrDefault False $ fetchBenchmarks fetchFlags - - reorderGoals = fromFlag (fetchReorderGoals fetchFlags) - countConflicts = fromFlag (fetchCountConflicts fetchFlags) - fineGrainedConflicts = fromFlag (fetchFineGrainedConflicts fetchFlags) - minimizeConflictSet = fromFlag (fetchMinimizeConflictSet fetchFlags) - independentGoals = fromFlag (fetchIndependentGoals fetchFlags) - shadowPkgs = fromFlag (fetchShadowPkgs fetchFlags) - strongFlags = fromFlag (fetchStrongFlags fetchFlags) - maxBackjumps = fromFlag (fetchMaxBackjumps fetchFlags) - allowBootLibInstalls = fromFlag (fetchAllowBootLibInstalls fetchFlags) - onlyConstrained = fromFlag (fetchOnlyConstrained fetchFlags) + notice verbosity $ + "No packages need to be fetched. " + ++ "All the requested packages are already local " + ++ "or cached locally." + else + if dryRun + then + notice verbosity $ + unlines $ + "The following packages would be fetched:" + : map (prettyShow . packageId) pkgs' + else traverse_ (fetchPackage verbosity repoCtxt . srcpkgSource) pkgs' + where + dryRun = fromFlag (fetchDryRun fetchFlags) + +planPackages + :: Verbosity + -> Compiler + -> Platform + -> FetchFlags + -> InstalledPackageIndex + -> SourcePackageDb + -> PkgConfigDb + -> [PackageSpecifier UnresolvedSourcePackage] + -> IO [UnresolvedSourcePackage] +planPackages + verbosity + comp + platform + fetchFlags + installedPkgIndex + sourcePkgDb + pkgConfigDb + pkgSpecifiers + | includeDependencies = do + solver <- + chooseSolver + verbosity + (fromFlag (fetchSolver fetchFlags)) + (compilerInfo comp) + notice verbosity "Resolving dependencies..." + installPlan <- + foldProgress logMsg (die' verbosity) return $ + resolveDependencies + platform + (compilerInfo comp) + pkgConfigDb + solver + resolverParams + + -- The packages we want to fetch are those packages the 'InstallPlan' + -- that are in the 'InstallPlan.Configured' state. + return + [ solverPkgSource cpkg + | (SolverInstallPlan.Configured cpkg) <- + SolverInstallPlan.toList installPlan + ] + | otherwise = + either (die' verbosity . unlines . map show) return $ + resolveWithoutDependencies resolverParams + where + resolverParams :: DepResolverParams + resolverParams = + setMaxBackjumps + ( if maxBackjumps < 0 + then Nothing + else Just maxBackjumps + ) + . setIndependentGoals independentGoals + . setReorderGoals reorderGoals + . setCountConflicts countConflicts + . setFineGrainedConflicts fineGrainedConflicts + . setMinimizeConflictSet minimizeConflictSet + . setShadowPkgs shadowPkgs + . setStrongFlags strongFlags + . setAllowBootLibInstalls allowBootLibInstalls + . setOnlyConstrained onlyConstrained + . setSolverVerbosity verbosity + . addConstraints + [ let pc = + PackageConstraint + (scopeToplevel $ pkgSpecifierTarget pkgSpecifier) + (PackagePropertyStanzas stanzas) + in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget + | pkgSpecifier <- pkgSpecifiers + ] + -- Reinstall the targets given on the command line so that the dep + -- resolver will decide that they need fetching, even if they're + -- already installed. Since we want to get the source packages of + -- things we might have installed (but not have the sources for). + . reinstallTargets + $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers + + includeDependencies = fromFlag (fetchDeps fetchFlags) + logMsg message rest = debug verbosity message >> rest + + stanzas = + [TestStanzas | testsEnabled] + ++ [BenchStanzas | benchmarksEnabled] + testsEnabled = fromFlagOrDefault False $ fetchTests fetchFlags + benchmarksEnabled = fromFlagOrDefault False $ fetchBenchmarks fetchFlags + + reorderGoals = fromFlag (fetchReorderGoals fetchFlags) + countConflicts = fromFlag (fetchCountConflicts fetchFlags) + fineGrainedConflicts = fromFlag (fetchFineGrainedConflicts fetchFlags) + minimizeConflictSet = fromFlag (fetchMinimizeConflictSet fetchFlags) + independentGoals = fromFlag (fetchIndependentGoals fetchFlags) + shadowPkgs = fromFlag (fetchShadowPkgs fetchFlags) + strongFlags = fromFlag (fetchStrongFlags fetchFlags) + maxBackjumps = fromFlag (fetchMaxBackjumps fetchFlags) + allowBootLibInstalls = fromFlag (fetchAllowBootLibInstalls fetchFlags) + onlyConstrained = fromFlag (fetchOnlyConstrained fetchFlags) checkTarget :: Verbosity -> UserTarget -> IO () checkTarget verbosity target = case target of - UserTargetRemoteTarball _uri - -> die' verbosity $ "The 'fetch' command does not yet support remote tarballs. " - ++ "In the meantime you can use the 'unpack' commands." - _ -> return () + UserTargetRemoteTarball _uri -> + die' verbosity $ + "The 'fetch' command does not yet support remote tarballs. " + ++ "In the meantime you can use the 'unpack' commands." + _ -> return () fetchPackage :: Verbosity -> RepoContext -> PackageLocation a -> IO () fetchPackage verbosity repoCtxt pkgsrc = case pkgsrc of - LocalUnpackedPackage _dir -> return () - LocalTarballPackage _file -> return () - - RemoteTarballPackage _uri _ -> - die' verbosity $ "The 'fetch' command does not yet support remote tarballs. " - ++ "In the meantime you can use the 'unpack' commands." - - RemoteSourceRepoPackage _repo _ -> - die' verbosity $ "The 'fetch' command does not yet support remote " - ++ "source repositories." - - RepoTarballPackage repo pkgid _ -> do - _ <- fetchRepoTarball verbosity repoCtxt repo pkgid - return () + LocalUnpackedPackage _dir -> return () + LocalTarballPackage _file -> return () + RemoteTarballPackage _uri _ -> + die' verbosity $ + "The 'fetch' command does not yet support remote tarballs. " + ++ "In the meantime you can use the 'unpack' commands." + RemoteSourceRepoPackage _repo _ -> + die' verbosity $ + "The 'fetch' command does not yet support remote " + ++ "source repositories." + RepoTarballPackage repo pkgid _ -> do + _ <- fetchRepoTarball verbosity repoCtxt repo pkgid + return () diff --git a/cabal-install/src/Distribution/Client/FetchUtils.hs b/cabal-install/src/Distribution/Client/FetchUtils.hs index 0a493d493f7..2ad9ea2c235 100644 --- a/cabal-install/src/Distribution/Client/FetchUtils.hs +++ b/cabal-install/src/Distribution/Client/FetchUtils.hs @@ -1,4 +1,10 @@ ----------------------------------------------------------------------------- +----------------------------------------------------------------------------- +{-# LANGUAGE RecordWildCards #-} +----------------------------------------------------------------------------- +----------------------------------------------------------------------------- +{-# LANGUAGE ScopedTypeVariables #-} + -- | -- Module : Distribution.Client.FetchUtils -- Copyright : (c) David Himmelstrup 2005 @@ -10,177 +16,201 @@ -- Portability : portable -- -- Functions for fetching packages ------------------------------------------------------------------------------ -{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-} -module Distribution.Client.FetchUtils ( - - -- * fetching packages - fetchPackage, - isFetched, - checkFetched, +module Distribution.Client.FetchUtils + ( -- * fetching packages + fetchPackage + , isFetched + , checkFetched -- ** specifically for repo packages - checkRepoTarballFetched, - fetchRepoTarball, - verifyFetchedTarball, + , checkRepoTarballFetched + , fetchRepoTarball + , verifyFetchedTarball -- ** fetching packages asynchronously - asyncFetchPackages, - waitAsyncFetchPackage, - AsyncFetchMap, + , asyncFetchPackages + , waitAsyncFetchPackage + , AsyncFetchMap -- * fetching other things - downloadIndex, + , downloadIndex ) where import Distribution.Client.Compat.Prelude import Prelude () -import Distribution.Client.Types import Distribution.Client.HttpUtils - ( downloadURI, isOldHackageURI, DownloadResult(..) - , HttpTransport(..), transportCheckHttps, remoteRepoCheckHttps ) + ( DownloadResult (..) + , HttpTransport (..) + , downloadURI + , isOldHackageURI + , remoteRepoCheckHttps + , transportCheckHttps + ) +import Distribution.Client.Types +import Distribution.Client.GlobalFlags + ( RepoContext (..) + ) +import Distribution.Client.Utils + ( ProgressPhase (..) + , progressMessage + ) import Distribution.Package - ( PackageId, packageName, packageVersion ) + ( PackageId + , packageName + , packageVersion + ) import Distribution.Simple.Utils - ( notice, info, debug, warn, die' ) + ( debug + , die' + , info + , notice + , warn + ) import Distribution.Verbosity - ( verboseUnmarkOutput ) -import Distribution.Client.GlobalFlags - ( RepoContext(..) ) -import Distribution.Client.Utils - ( ProgressPhase(..), progressMessage ) + ( verboseUnmarkOutput + ) -import qualified Data.Map as Map -import qualified Control.Exception.Safe as Safe import Control.Concurrent.Async import Control.Concurrent.MVar +import qualified Control.Exception.Safe as Safe +import qualified Data.Map as Map +import Network.URI + ( URI (uriPath) + ) import System.Directory - ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory - , getFileSize ) -import System.IO - ( openTempFile, hClose ) + ( createDirectoryIfMissing + , doesFileExist + , getFileSize + , getTemporaryDirectory + ) import System.FilePath - ( (), (<.>) ) + ( (<.>) + , () + ) import qualified System.FilePath.Posix as FilePath.Posix - ( combine, joinPath ) -import Network.URI - ( URI(uriPath) ) + ( combine + , joinPath + ) +import System.IO + ( hClose + , openTempFile + ) import qualified Hackage.Security.Client as Sec -import qualified Hackage.Security.Util.Path as Sec import qualified Hackage.Security.Util.Checked as Sec +import qualified Hackage.Security.Util.Path as Sec -- ------------------------------------------------------------ + -- * Actually fetch things + -- ------------------------------------------------------------ -- | Returns @True@ if the package has already been fetched -- or does not need fetching. --- isFetched :: UnresolvedPkgLoc -> IO Bool isFetched loc = case loc of - LocalUnpackedPackage _dir -> return True - LocalTarballPackage _file -> return True - RemoteTarballPackage _uri local -> return (isJust local) - RepoTarballPackage repo pkgid _ -> doesFileExist (packageFile repo pkgid) - RemoteSourceRepoPackage _ local -> return (isJust local) - + LocalUnpackedPackage _dir -> return True + LocalTarballPackage _file -> return True + RemoteTarballPackage _uri local -> return (isJust local) + RepoTarballPackage repo pkgid _ -> doesFileExist (packageFile repo pkgid) + RemoteSourceRepoPackage _ local -> return (isJust local) -- | Checks if the package has already been fetched (or does not need -- fetching) and if so returns evidence in the form of a 'PackageLocation' -- with a resolved local file location. --- -checkFetched :: UnresolvedPkgLoc - -> IO (Maybe ResolvedPkgLoc) +checkFetched + :: UnresolvedPkgLoc + -> IO (Maybe ResolvedPkgLoc) checkFetched loc = case loc of - LocalUnpackedPackage dir -> - return (Just $ LocalUnpackedPackage dir) - LocalTarballPackage file -> - return (Just $ LocalTarballPackage file) - RemoteTarballPackage uri (Just file) -> - return (Just $ RemoteTarballPackage uri file) - RepoTarballPackage repo pkgid (Just file) -> - return (Just $ RepoTarballPackage repo pkgid file) - RemoteSourceRepoPackage repo (Just file) -> - return (Just $ RemoteSourceRepoPackage repo file) - - RemoteTarballPackage _uri Nothing -> return Nothing - RemoteSourceRepoPackage _repo Nothing -> return Nothing - RepoTarballPackage repo pkgid Nothing -> - fmap (fmap (RepoTarballPackage repo pkgid)) - (checkRepoTarballFetched repo pkgid) + LocalUnpackedPackage dir -> + return (Just $ LocalUnpackedPackage dir) + LocalTarballPackage file -> + return (Just $ LocalTarballPackage file) + RemoteTarballPackage uri (Just file) -> + return (Just $ RemoteTarballPackage uri file) + RepoTarballPackage repo pkgid (Just file) -> + return (Just $ RepoTarballPackage repo pkgid file) + RemoteSourceRepoPackage repo (Just file) -> + return (Just $ RemoteSourceRepoPackage repo file) + RemoteTarballPackage _uri Nothing -> return Nothing + RemoteSourceRepoPackage _repo Nothing -> return Nothing + RepoTarballPackage repo pkgid Nothing -> + fmap + (fmap (RepoTarballPackage repo pkgid)) + (checkRepoTarballFetched repo pkgid) -- | Like 'checkFetched' but for the specific case of a 'RepoTarballPackage'. --- checkRepoTarballFetched :: Repo -> PackageId -> IO (Maybe FilePath) checkRepoTarballFetched repo pkgid = do - let file = packageFile repo pkgid - exists <- doesFileExist file - if exists - then return (Just file) - else return Nothing + let file = packageFile repo pkgid + exists <- doesFileExist file + if exists + then return (Just file) + else return Nothing verifyFetchedTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO Bool verifyFetchedTarball verbosity repoCtxt repo pkgid = - let file = packageFile repo pkgid - handleError :: IO Bool -> IO Bool - handleError act = do - res <- Safe.try act - case res of - Left e -> warn verbosity ("Error verifying fetched tarball " ++ file ++ ", will redownload: " ++ show (e :: SomeException)) >> pure False - Right b -> pure b + let file = packageFile repo pkgid + handleError :: IO Bool -> IO Bool + handleError act = do + res <- Safe.try act + case res of + Left e -> warn verbosity ("Error verifying fetched tarball " ++ file ++ ", will redownload: " ++ show (e :: SomeException)) >> pure False + Right b -> pure b in handleError $ do exists <- doesFileExist file if not exists then return True -- if the file does not exist, it vacuously passes validation, since it will be downloaded as necessary with what we will then check is a valid hash. else case repo of -- a secure repo has hashes we can compare against to confirm this is the correct file. - RepoSecure{} -> - repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> - Sec.withIndex repoSecure $ \callbacks -> - let warnAndFail s = warn verbosity ("Fetched tarball " ++ file ++ " does not match server, will redownload: " ++ s) >> return False - -- the do block in parens is due to dealing with the checked exceptions mechanism. - in (do fileInfo <- Sec.indexLookupFileInfo callbacks pkgid - sz <- Sec.FileLength . fromInteger <$> getFileSize file - if sz /= Sec.fileInfoLength (Sec.trusted fileInfo) - then warnAndFail "file length mismatch" - else do - res <- Sec.compareTrustedFileInfo (Sec.trusted fileInfo) <$> Sec.computeFileInfo (Sec.Path file :: Sec.Path Sec.Absolute) - if res - then pure True - else warnAndFail "file hash mismatch") - `Sec.catchChecked` (\(e :: Sec.InvalidPackageException) -> warnAndFail (show e)) - `Sec.catchChecked` (\(e :: Sec.VerificationError) -> warnAndFail (show e)) - _ -> pure True + RepoSecure{} -> + repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> + Sec.withIndex repoSecure $ \callbacks -> + let warnAndFail s = warn verbosity ("Fetched tarball " ++ file ++ " does not match server, will redownload: " ++ s) >> return False + in -- the do block in parens is due to dealing with the checked exceptions mechanism. + ( do + fileInfo <- Sec.indexLookupFileInfo callbacks pkgid + sz <- Sec.FileLength . fromInteger <$> getFileSize file + if sz /= Sec.fileInfoLength (Sec.trusted fileInfo) + then warnAndFail "file length mismatch" + else do + res <- Sec.compareTrustedFileInfo (Sec.trusted fileInfo) <$> Sec.computeFileInfo (Sec.Path file :: Sec.Path Sec.Absolute) + if res + then pure True + else warnAndFail "file hash mismatch" + ) + `Sec.catchChecked` (\(e :: Sec.InvalidPackageException) -> warnAndFail (show e)) + `Sec.catchChecked` (\(e :: Sec.VerificationError) -> warnAndFail (show e)) + _ -> pure True -- | Fetch a package if we don't have it already. --- -fetchPackage :: Verbosity - -> RepoContext - -> UnresolvedPkgLoc - -> IO ResolvedPkgLoc +fetchPackage + :: Verbosity + -> RepoContext + -> UnresolvedPkgLoc + -> IO ResolvedPkgLoc fetchPackage verbosity repoCtxt loc = case loc of - LocalUnpackedPackage dir -> - return (LocalUnpackedPackage dir) - LocalTarballPackage file -> - return (LocalTarballPackage file) - RemoteTarballPackage uri (Just file) -> - return (RemoteTarballPackage uri file) - RepoTarballPackage repo pkgid (Just file) -> - return (RepoTarballPackage repo pkgid file) - RemoteSourceRepoPackage repo (Just dir) -> - return (RemoteSourceRepoPackage repo dir) - - RemoteTarballPackage uri Nothing -> do - path <- downloadTarballPackage uri - return (RemoteTarballPackage uri path) - RepoTarballPackage repo pkgid Nothing -> do - local <- fetchRepoTarball verbosity repoCtxt repo pkgid - return (RepoTarballPackage repo pkgid local) - RemoteSourceRepoPackage _repo Nothing -> - die' verbosity "fetchPackage: source repos not supported" + LocalUnpackedPackage dir -> + return (LocalUnpackedPackage dir) + LocalTarballPackage file -> + return (LocalTarballPackage file) + RemoteTarballPackage uri (Just file) -> + return (RemoteTarballPackage uri file) + RepoTarballPackage repo pkgid (Just file) -> + return (RepoTarballPackage repo pkgid file) + RemoteSourceRepoPackage repo (Just dir) -> + return (RemoteSourceRepoPackage repo dir) + RemoteTarballPackage uri Nothing -> do + path <- downloadTarballPackage uri + return (RemoteTarballPackage uri path) + RepoTarballPackage repo pkgid Nothing -> do + local <- fetchRepoTarball verbosity repoCtxt repo pkgid + return (RepoTarballPackage repo pkgid local) + RemoteSourceRepoPackage _repo Nothing -> + die' verbosity "fetchPackage: source repos not supported" where downloadTarballPackage :: URI -> IO FilePath downloadTarballPackage uri = do @@ -193,19 +223,19 @@ fetchPackage verbosity repoCtxt loc = case loc of _ <- downloadURI transport verbosity uri path return path - -- | Fetch a repo package if we don't have it already. --- fetchRepoTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO FilePath fetchRepoTarball verbosity' repoCtxt repo pkgid = do fetched <- doesFileExist (packageFile repo pkgid) if fetched - then do info verbosity $ prettyShow pkgid ++ " has already been downloaded." - return (packageFile repo pkgid) - else do progressMessage verbosity ProgressDownloading (prettyShow pkgid) - res <- downloadRepoPackage - progressMessage verbosity ProgressDownloaded (prettyShow pkgid) - return res + then do + info verbosity $ prettyShow pkgid ++ " has already been downloaded." + return (packageFile repo pkgid) + else do + progressMessage verbosity ProgressDownloading (prettyShow pkgid) + res <- downloadRepoPackage + progressMessage verbosity ProgressDownloaded (prettyShow pkgid) + return res where -- whether we download or not is non-deterministic verbosity = verboseUnmarkOutput verbosity' @@ -213,19 +243,17 @@ fetchRepoTarball verbosity' repoCtxt repo pkgid = do downloadRepoPackage :: IO FilePath downloadRepoPackage = case repo of RepoLocalNoIndex{} -> return (packageFile repo pkgid) - RepoRemote{..} -> do transport <- repoContextGetTransport repoCtxt remoteRepoCheckHttps verbosity transport repoRemote - let uri = packageURI repoRemote pkgid - dir = packageDir repo pkgid - path = packageFile repo pkgid + let uri = packageURI repoRemote pkgid + dir = packageDir repo pkgid + path = packageFile repo pkgid createDirectoryIfMissing True dir _ <- downloadURI transport verbosity uri path return path - RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \rep -> do - let dir = packageDir repo pkgid + let dir = packageDir repo pkgid path = packageFile repo pkgid createDirectoryIfMissing True dir Sec.uncheckClientErrors $ do @@ -236,25 +264,29 @@ fetchRepoTarball verbosity' repoCtxt repo pkgid = do -- | Downloads an index file to [config-dir/packages/serv-id] without -- hackage-security. You probably don't want to call this directly; -- use 'updateRepo' instead. --- downloadIndex :: HttpTransport -> Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult downloadIndex transport verbosity remoteRepo cacheDir = do remoteRepoCheckHttps verbosity transport remoteRepo - let uri = (remoteRepoURI remoteRepo) { - uriPath = uriPath (remoteRepoURI remoteRepo) - `FilePath.Posix.combine` "00-index.tar.gz" - } + let uri = + (remoteRepoURI remoteRepo) + { uriPath = + uriPath (remoteRepoURI remoteRepo) + `FilePath.Posix.combine` "00-index.tar.gz" + } path = cacheDir "00-index" <.> "tar.gz" createDirectoryIfMissing True cacheDir downloadURI transport verbosity uri path - -- ------------------------------------------------------------ + -- * Async fetch wrapper utilities + -- ------------------------------------------------------------ -type AsyncFetchMap = Map UnresolvedPkgLoc - (MVar (Either SomeException ResolvedPkgLoc)) +type AsyncFetchMap = + Map + UnresolvedPkgLoc + (MVar (Either SomeException ResolvedPkgLoc)) -- | Fork off an async action to download the given packages (by location). -- @@ -267,37 +299,40 @@ type AsyncFetchMap = Map UnresolvedPkgLoc -- -- Synchronous exceptions raised by the download actions are delivered -- via 'waitAsyncFetchPackage'. --- -asyncFetchPackages :: Verbosity - -> RepoContext - -> [UnresolvedPkgLoc] - -> (AsyncFetchMap -> IO a) - -> IO a +asyncFetchPackages + :: Verbosity + -> RepoContext + -> [UnresolvedPkgLoc] + -> (AsyncFetchMap -> IO a) + -> IO a asyncFetchPackages verbosity repoCtxt pkglocs body = do - --TODO: [nice to have] use parallel downloads? - - asyncDownloadVars <- sequenceA - [ do v <- newEmptyMVar - return (pkgloc, v) - | pkgloc <- pkglocs - ] - - let fetchPackages :: IO () - fetchPackages = - for_ asyncDownloadVars $ \(pkgloc, var) -> do - -- Suppress marking here, because 'withAsync' means - -- that we get nondeterministic interleaving. - -- It is essential that we don't catch async exceptions here, - -- specifically 'AsyncCancelled' thrown at us from 'concurrently'. - result <- Safe.try $ + -- TODO: [nice to have] use parallel downloads? + + asyncDownloadVars <- + sequenceA + [ do + v <- newEmptyMVar + return (pkgloc, v) + | pkgloc <- pkglocs + ] + + let fetchPackages :: IO () + fetchPackages = + for_ asyncDownloadVars $ \(pkgloc, var) -> do + -- Suppress marking here, because 'withAsync' means + -- that we get nondeterministic interleaving. + -- It is essential that we don't catch async exceptions here, + -- specifically 'AsyncCancelled' thrown at us from 'concurrently'. + result <- + Safe.try $ fetchPackage (verboseUnmarkOutput verbosity) repoCtxt pkgloc - putMVar var result - - (_, res) <- concurrently - fetchPackages - (body $ Map.fromList asyncDownloadVars) - pure res + putMVar var result + (_, res) <- + concurrently + fetchPackages + (body $ Map.fromList asyncDownloadVars) + pure res -- | Expect to find a download in progress in the given 'AsyncFetchMap' -- and wait on it to finish. @@ -309,54 +344,60 @@ asyncFetchPackages verbosity repoCtxt pkglocs body = do -- components and/or qualified goals, and these all go through the -- download phase so we end up using 'waitAsyncFetchPackage' twice on -- the same package. C.f. #4461. -waitAsyncFetchPackage :: Verbosity - -> AsyncFetchMap - -> UnresolvedPkgLoc - -> IO ResolvedPkgLoc +waitAsyncFetchPackage + :: Verbosity + -> AsyncFetchMap + -> UnresolvedPkgLoc + -> IO ResolvedPkgLoc waitAsyncFetchPackage verbosity downloadMap srcloc = - case Map.lookup srcloc downloadMap of - Just hnd -> do - debug verbosity $ "Waiting for download of " ++ show srcloc - either throwIO return =<< readMVar hnd - Nothing -> fail "waitAsyncFetchPackage: package not being downloaded" - + case Map.lookup srcloc downloadMap of + Just hnd -> do + debug verbosity $ "Waiting for download of " ++ show srcloc + either throwIO return =<< readMVar hnd + Nothing -> fail "waitAsyncFetchPackage: package not being downloaded" -- ------------------------------------------------------------ + -- * Path utilities + -- ------------------------------------------------------------ -- | Generate the full path to the locally cached copy of -- the tarball for a given @PackageIdentifier@. --- packageFile :: Repo -> PackageId -> FilePath -packageFile repo pkgid = packageDir repo pkgid - prettyShow pkgid - <.> "tar.gz" +packageFile repo pkgid = + packageDir repo pkgid + prettyShow pkgid + <.> "tar.gz" -- | Generate the full path to the directory where the local cached copy of -- the tarball for a given @PackageIdentifier@ is stored. --- packageDir :: Repo -> PackageId -> FilePath packageDir (RepoLocalNoIndex (LocalRepo _ dir _) _) _pkgid = dir -packageDir repo pkgid = repoLocalDir repo - prettyShow (packageName pkgid) - prettyShow (packageVersion pkgid) +packageDir repo pkgid = + repoLocalDir repo + prettyShow (packageName pkgid) + prettyShow (packageVersion pkgid) -- | Generate the URI of the tarball for a given package. --- packageURI :: RemoteRepo -> PackageId -> URI -packageURI repo pkgid | isOldHackageURI (remoteRepoURI repo) = - (remoteRepoURI repo) { - uriPath = FilePath.Posix.joinPath - [uriPath (remoteRepoURI repo) - ,prettyShow (packageName pkgid) - ,prettyShow (packageVersion pkgid) - ,prettyShow pkgid <.> "tar.gz"] - } +packageURI repo pkgid + | isOldHackageURI (remoteRepoURI repo) = + (remoteRepoURI repo) + { uriPath = + FilePath.Posix.joinPath + [ uriPath (remoteRepoURI repo) + , prettyShow (packageName pkgid) + , prettyShow (packageVersion pkgid) + , prettyShow pkgid <.> "tar.gz" + ] + } packageURI repo pkgid = - (remoteRepoURI repo) { - uriPath = FilePath.Posix.joinPath - [uriPath (remoteRepoURI repo) - ,"package" - ,prettyShow pkgid <.> "tar.gz"] - } + (remoteRepoURI repo) + { uriPath = + FilePath.Posix.joinPath + [ uriPath (remoteRepoURI repo) + , "package" + , prettyShow pkgid <.> "tar.gz" + ] + } diff --git a/cabal-install/src/Distribution/Client/FileMonitor.hs b/cabal-install/src/Distribution/Client/FileMonitor.hs index ab991ea8da5..5edd159496b 100644 --- a/cabal-install/src/Distribution/Client/FileMonitor.hs +++ b/cabal-install/src/Distribution/Client/FileMonitor.hs @@ -1,106 +1,111 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric, DeriveFunctor, GeneralizedNewtypeDeriving, - NamedFieldPuns, BangPatterns, ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | An abstraction to help with re-running actions when files or other -- input values they depend on have changed. --- -module Distribution.Client.FileMonitor ( - - -- * Declaring files to monitor - MonitorFilePath(..), - MonitorKindFile(..), - MonitorKindDir(..), - FilePathGlob(..), - monitorFile, - monitorFileHashed, - monitorNonExistentFile, - monitorFileExistence, - monitorDirectory, - monitorNonExistentDirectory, - monitorDirectoryExistence, - monitorFileOrDirectory, - monitorFileGlob, - monitorFileGlobExistence, - monitorFileSearchPath, - monitorFileHashedSearchPath, - - -- * Creating and checking sets of monitored files - FileMonitor(..), - newFileMonitor, - MonitorChanged(..), - MonitorChangedReason(..), - checkFileMonitorChanged, - updateFileMonitor, - MonitorTimestamp, - beginUpdateFileMonitor, - - -- * Internal - MonitorStateFileSet, - MonitorStateFile, - MonitorStateGlob, +module Distribution.Client.FileMonitor + ( -- * Declaring files to monitor + MonitorFilePath (..) + , MonitorKindFile (..) + , MonitorKindDir (..) + , FilePathGlob (..) + , monitorFile + , monitorFileHashed + , monitorNonExistentFile + , monitorFileExistence + , monitorDirectory + , monitorNonExistentDirectory + , monitorDirectoryExistence + , monitorFileOrDirectory + , monitorFileGlob + , monitorFileGlobExistence + , monitorFileSearchPath + , monitorFileHashedSearchPath + + -- * Creating and checking sets of monitored files + , FileMonitor (..) + , newFileMonitor + , MonitorChanged (..) + , MonitorChangedReason (..) + , checkFileMonitorChanged + , updateFileMonitor + , MonitorTimestamp + , beginUpdateFileMonitor + + -- * Internal + , MonitorStateFileSet + , MonitorStateFile + , MonitorStateGlob ) where -import Prelude () import Distribution.Client.Compat.Prelude import qualified Distribution.Compat.Binary as Binary +import Prelude () -import qualified Data.Map.Strict as Map 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.Monad -import Control.Monad.Trans (MonadIO, liftIO) -import Control.Monad.State (StateT, mapStateT) +import Control.Exception +import Control.Monad +import Control.Monad.Except + ( ExceptT + , runExceptT + , throwError + , withExceptT + ) +import Control.Monad.State (StateT, mapStateT) import qualified Control.Monad.State as State -import Control.Monad.Except (ExceptT, runExceptT, withExceptT, - throwError) -import Control.Exception - -import Distribution.Compat.Time -import Distribution.Client.Glob -import Distribution.Simple.Utils (handleDoesNotExist, writeFileAtomic) -import Distribution.Client.Utils (mergeBy, MergeResult(..)) -import Distribution.Utils.Structured (structuredEncode, Tag (..)) -import System.FilePath -import System.Directory -import System.IO +import Control.Monad.Trans (MonadIO, liftIO) + +import Distribution.Client.Glob +import Distribution.Client.Utils (MergeResult (..), mergeBy) +import Distribution.Compat.Time +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 :: !FilePathGlob - } +data MonitorFilePath + = MonitorFile + { monitorKindFile :: !MonitorKindFile + , monitorKindDir :: !MonitorKindDir + , monitorPath :: !FilePath + } + | MonitorFileGlob + { monitorKindFile :: !MonitorKindFile + , monitorKindDir :: !MonitorKindDir + , monitorPathGlob :: !FilePathGlob + } deriving (Eq, Show, Generic) -data MonitorKindFile = FileExists - | FileModTime - | FileHashed - | FileNotExists +data MonitorKindFile + = FileExists + | FileModTime + | FileHashed + | FileNotExists deriving (Eq, Show, Generic) -data MonitorKindDir = DirExists - | DirModTime - | DirNotExists +data MonitorKindDir + = DirExists + | DirModTime + | DirNotExists deriving (Eq, Show, Generic) instance Binary MonitorFilePath @@ -114,7 +119,6 @@ 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 @@ -122,32 +126,27 @@ monitorFile = MonitorFile FileModTime DirNotExists -- 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 @@ -156,14 +155,12 @@ 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 @@ -171,14 +168,12 @@ monitorFileOrDirectory = MonitorFile FileModTime DirModTime -- 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 :: FilePathGlob -> 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 :: FilePathGlob -> MonitorFilePath monitorFileGlobExistence = MonitorFileGlob FileExists DirExists @@ -187,16 +182,15 @@ monitorFileGlobExistence = MonitorFileGlob FileExists DirExists -- @foundAtPath@. monitorFileSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath] monitorFileSearchPath notFoundAtPaths foundAtPath = - monitorFile foundAtPath - : map monitorNonExistentFile notFoundAtPaths + 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 - + monitorFileHashed foundAtPath + : map monitorNonExistentFile notFoundAtPaths ------------------------------------------------------------------------------ -- Implementation types, files status @@ -207,13 +201,14 @@ monitorFileHashedSearchPath notFoundAtPaths foundAtPath = -- files to be monitored (index by their path), and a list of -- globs, which monitor may files at once. data MonitorStateFileSet - = MonitorStateFileSet ![MonitorStateFile] - ![MonitorStateGlob] - -- Morally this is not actually a set but a bag (represented by lists). - -- There is no principled reason to use a bag here rather than a set, but - -- there is also no particular gain either. That said, we do preserve the - -- order of the lists just to reduce confusion (and have predictable I/O - -- patterns). + = MonitorStateFileSet + ![MonitorStateFile] + ![MonitorStateGlob] + -- Morally this is not actually a set but a bag (represented by lists). + -- There is no principled reason to use a bag here rather than a set, but + -- there is also no particular gain either. That said, we do preserve the + -- order of the lists just to reduce confusion (and have predictable I/O + -- patterns). deriving (Show, Generic) instance Binary MonitorStateFileSet @@ -230,19 +225,25 @@ type Hash = Int -- file to have changed, either because it had already changed by the time we -- did the snapshot (i.e. too new, changed since start of update process) or it -- no longer exists at all. --- -data MonitorStateFile = MonitorStateFile !MonitorKindFile !MonitorKindDir - !FilePath !MonitorStateFileStatus +data MonitorStateFile + = MonitorStateFile + !MonitorKindFile + !MonitorKindDir + !FilePath + !MonitorStateFileStatus deriving (Show, Generic) data MonitorStateFileStatus - = MonitorStateFileExists - | MonitorStateFileModTime !ModTime -- ^ cached file mtime - | MonitorStateFileHashed !ModTime !Hash -- ^ cached mtime and content hash - | MonitorStateDirExists - | MonitorStateDirModTime !ModTime -- ^ cached dir mtime - | MonitorStateNonExistent - | MonitorStateAlreadyChanged + = MonitorStateFileExists + | -- | cached file mtime + MonitorStateFileModTime !ModTime + | -- | cached mtime and content hash + MonitorStateFileHashed !ModTime !Hash + | MonitorStateDirExists + | -- | cached dir mtime + MonitorStateDirModTime !ModTime + | MonitorStateNonExistent + | MonitorStateAlreadyChanged deriving (Show, Generic) instance Binary MonitorStateFile @@ -252,23 +253,25 @@ instance Structured MonitorStateFileStatus -- | The state necessary to determine whether the files matched by a globbing -- match have changed. --- -data MonitorStateGlob = MonitorStateGlob !MonitorKindFile !MonitorKindDir - !FilePathRoot !MonitorStateGlobRel +data MonitorStateGlob + = MonitorStateGlob + !MonitorKindFile + !MonitorKindDir + !FilePathRoot + !MonitorStateGlobRel deriving (Show, Generic) data MonitorStateGlobRel - = MonitorStateGlobDirs - !Glob !FilePathGlobRel - !ModTime - ![(FilePath, MonitorStateGlobRel)] -- invariant: sorted - - | MonitorStateGlobFiles - !Glob - !ModTime - ![(FilePath, MonitorStateFileStatus)] -- invariant: sorted - - | MonitorStateGlobDirTrailing + = MonitorStateGlobDirs + !Glob + !FilePathGlobRel + !ModTime + ![(FilePath, MonitorStateGlobRel)] -- invariant: sorted + | MonitorStateGlobFiles + !Glob + !ModTime + ![(FilePath, MonitorStateFileStatus)] -- invariant: sorted + | MonitorStateGlobDirTrailing deriving (Show, Generic) instance Binary MonitorStateGlob @@ -280,7 +283,6 @@ instance Structured MonitorStateGlobRel -- | We can build a 'MonitorStateFileSet' from a set of 'MonitorFilePath' by -- inspecting the state of the file system, and we can go in the reverse -- direction by just forgetting the extra info. --- reconstructMonitorFilePaths :: MonitorStateFileSet -> [MonitorFilePath] reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) = map getSinglePath singlePaths ++ map getGlobPath globPaths @@ -291,11 +293,12 @@ reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) = getGlobPath :: MonitorStateGlob -> MonitorFilePath getGlobPath (MonitorStateGlob kindfile kinddir root gstate) = - MonitorFileGlob kindfile kinddir $ FilePathGlob root $ - case gstate of - MonitorStateGlobDirs glob globs _ _ -> GlobDir glob globs - MonitorStateGlobFiles glob _ _ -> GlobFile glob - MonitorStateGlobDirTrailing -> GlobDirTrailing + MonitorFileGlob kindfile kinddir $ + FilePathGlob root $ + case gstate of + MonitorStateGlobDirs glob globs _ _ -> GlobDir glob globs + MonitorStateGlobFiles glob _ _ -> GlobFile glob + MonitorStateGlobDirTrailing -> GlobDirTrailing ------------------------------------------------------------------------------ -- Checking the status of monitored files @@ -327,31 +330,23 @@ reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) = -- The typical occurrence of this pattern is captured by 'rerunIfChanged' -- and the 'Rebuild' monad. More complicated cases may need to use -- 'checkFileMonitorChanged' and 'updateFileMonitor' directly. --- -data FileMonitor a b - = FileMonitor { - - -- | The file where this 'FileMonitor' should store its state. - -- - fileMonitorCacheFile :: FilePath, - - -- | Compares a new cache key with old one to determine if a - -- corresponding cached value is still valid. - -- - -- Typically this is just an equality test, but in some - -- circumstances it can make sense to do things like subset - -- comparisons. - -- - -- The first arg is the new value, the second is the old cached value. - -- - fileMonitorKeyValid :: a -> a -> Bool, - - -- | When this mode is enabled, if 'checkFileMonitorChanged' returns - -- 'MonitoredValueChanged' then we have the guarantee that no files - -- changed, that the value change was the only change. In the default - -- mode no such guarantee is provided which is slightly faster. - -- - fileMonitorCheckIfOnlyValueChanged :: Bool +data FileMonitor a b = FileMonitor + { fileMonitorCacheFile :: FilePath + -- ^ The file where this 'FileMonitor' should store its state. + , fileMonitorKeyValid :: a -> a -> Bool + -- ^ Compares a new cache key with old one to determine if a + -- corresponding cached value is still valid. + -- + -- Typically this is just an equality test, but in some + -- circumstances it can make sense to do things like subset + -- comparisons. + -- + -- The first arg is the new value, the second is the old cached value. + , fileMonitorCheckIfOnlyValueChanged :: Bool + -- ^ When this mode is enabled, if 'checkFileMonitorChanged' returns + -- 'MonitoredValueChanged' then we have the guarantee that no files + -- changed, that the value change was the only change. In the default + -- mode no such guarantee is provided which is slightly faster. } -- | Define a new file monitor. @@ -362,145 +357,141 @@ data FileMonitor a b -- -- The path of the file monitor itself must be unique because it keeps state -- on disk and these would clash. --- -newFileMonitor :: Eq a => FilePath -- ^ The file to cache the state of the - -- file monitor. Must be unique. - -> FileMonitor a b +newFileMonitor + :: Eq a + => FilePath + -- ^ The file to cache the state of the + -- file monitor. Must be unique. + -> FileMonitor a b newFileMonitor path = FileMonitor path (==) False -- | The result of 'checkFileMonitorChanged': either the monitored files or -- value changed (and it tells us which it was) or nothing changed and we get -- the cached result. --- -data MonitorChanged a b = - -- | The monitored files and value did not change. The cached result is - -- @b@. - -- - -- The set of monitored files is also returned. This is useful - -- for composing or nesting 'FileMonitor's. - MonitorUnchanged b [MonitorFilePath] - - -- | The monitor found that something changed. The reason is given. - -- - | MonitorChanged (MonitorChangedReason a) - deriving Show +data MonitorChanged a b + = -- | The monitored files and value did not change. The cached result is + -- @b@. + -- + -- The set of monitored files is also returned. This is useful + -- for composing or nesting 'FileMonitor's. + MonitorUnchanged b [MonitorFilePath] + | -- | The monitor found that something changed. The reason is given. + MonitorChanged (MonitorChangedReason a) + deriving (Show) -- | What kind of change 'checkFileMonitorChanged' detected. --- -data MonitorChangedReason a = - - -- | One of the files changed (existence, file type, mtime or file - -- content, depending on the 'MonitorFilePath' in question) - MonitoredFileChanged FilePath - - -- | The pure input value changed. - -- - -- The previous cached key value is also returned. This is sometimes - -- useful when using a 'fileMonitorKeyValid' function that is not simply - -- '(==)', when invalidation can be partial. In such cases it can make - -- sense to 'updateFileMonitor' with a key value that's a combination of - -- the new and old (e.g. set union). - | MonitoredValueChanged a - - -- | There was no saved monitor state, cached value etc. Ie the file - -- for the 'FileMonitor' does not exist. - | MonitorFirstRun - - -- | There was existing state, but we could not read it. This typically - -- happens when the code has changed compared to an existing 'FileMonitor' - -- cache file and type of the input value or cached value has changed such - -- that we cannot decode the values. This is completely benign as we can - -- treat is just as if there were no cache file and re-run. - | MonitorCorruptCache +data MonitorChangedReason a + = -- | One of the files changed (existence, file type, mtime or file + -- content, depending on the 'MonitorFilePath' in question) + MonitoredFileChanged FilePath + | -- | The pure input value changed. + -- + -- The previous cached key value is also returned. This is sometimes + -- useful when using a 'fileMonitorKeyValid' function that is not simply + -- '(==)', when invalidation can be partial. In such cases it can make + -- sense to 'updateFileMonitor' with a key value that's a combination of + -- the new and old (e.g. set union). + MonitoredValueChanged a + | -- | There was no saved monitor state, cached value etc. Ie the file + -- for the 'FileMonitor' does not exist. + MonitorFirstRun + | -- | There was existing state, but we could not read it. This typically + -- happens when the code has changed compared to an existing 'FileMonitor' + -- cache file and type of the input value or cached value has changed such + -- that we cannot decode the values. This is completely benign as we can + -- treat is just as if there were no cache file and re-run. + MonitorCorruptCache deriving (Eq, Show, Functor) -- | Test if the input value or files monitored by the 'FileMonitor' have -- changed. If not, return the cached value. -- -- See 'FileMonitor' for a full explanation. --- checkFileMonitorChanged - :: forall a b. (Binary a, Structured a, Binary b, Structured b) - => FileMonitor a b -- ^ cache file path - -> FilePath -- ^ root directory - -> a -- ^ guard or key value - -> IO (MonitorChanged a b) -- ^ did the key or any paths change? + :: forall a b + . (Binary a, Structured a, Binary b, Structured b) + => FileMonitor a b + -- ^ cache file path + -> FilePath + -- ^ root directory + -> a + -- ^ guard or key value + -> IO (MonitorChanged a b) + -- ^ did the key or any paths change? checkFileMonitorChanged - monitor@FileMonitor { fileMonitorKeyValid, - fileMonitorCheckIfOnlyValueChanged } - root currentKey = - + monitor@FileMonitor + { fileMonitorKeyValid + , fileMonitorCheckIfOnlyValueChanged + } + root + currentKey = -- Consider it a change if the cache file does not exist, -- or we cannot decode it. Sadly ErrorCall can still happen, despite -- using decodeFileOrFail, e.g. Data.Char.chr errors handleDoesNotExist (MonitorChanged MonitorFirstRun) $ - handleErrorCall (MonitorChanged MonitorCorruptCache) $ - withCacheFile monitor $ - either (\_ -> return (MonitorChanged MonitorCorruptCache)) - checkStatusCache - - where - checkStatusCache :: (MonitorStateFileSet, a, Either String b) -> IO (MonitorChanged a b) - checkStatusCache (cachedFileStatus, cachedKey, cachedResult) = do + handleErrorCall (MonitorChanged MonitorCorruptCache) $ + withCacheFile monitor $ + either + (\_ -> return (MonitorChanged MonitorCorruptCache)) + checkStatusCache + where + checkStatusCache :: (MonitorStateFileSet, a, Either String b) -> IO (MonitorChanged a b) + checkStatusCache (cachedFileStatus, cachedKey, cachedResult) = do change <- checkForChanges case change of Just reason -> return (MonitorChanged reason) - Nothing -> case cachedResult of - Left _ -> pure (MonitorChanged MonitorCorruptCache) - Right cr -> return (MonitorUnchanged cr monitorFiles) - where monitorFiles = reconstructMonitorFilePaths cachedFileStatus - where - -- In fileMonitorCheckIfOnlyValueChanged mode we want to guarantee that - -- if we return MonitoredValueChanged that only the value changed. - -- We do that by checking for file changes first. Otherwise it makes - -- more sense to do the cheaper test first. - checkForChanges :: IO (Maybe (MonitorChangedReason a)) - checkForChanges - | fileMonitorCheckIfOnlyValueChanged - = checkFileChange cachedFileStatus cachedKey cachedResult - `mplusMaybeT` - checkValueChange cachedKey - - | otherwise - = checkValueChange cachedKey - `mplusMaybeT` - checkFileChange cachedFileStatus cachedKey cachedResult - - mplusMaybeT :: Monad m => m (Maybe a1) -> m (Maybe a1) -> m (Maybe a1) - mplusMaybeT ma mb = do - mx <- ma - case mx of - Nothing -> mb - Just x -> return (Just x) - - -- Check if the guard value has changed - checkValueChange :: a -> IO (Maybe (MonitorChangedReason a)) - checkValueChange cachedKey - | not (fileMonitorKeyValid currentKey cachedKey) - = return (Just (MonitoredValueChanged cachedKey)) - | otherwise - = return Nothing - - -- Check if any file has changed - checkFileChange :: MonitorStateFileSet -> a -> Either String b -> IO (Maybe (MonitorChangedReason a)) - checkFileChange cachedFileStatus cachedKey cachedResult = do - res <- probeFileSystem root cachedFileStatus - case res of - -- Some monitored file has changed - Left changedPath -> - return (Just (MonitoredFileChanged (normalise changedPath))) - - -- No monitored file has changed - Right (cachedFileStatus', cacheStatus) -> do - - -- But we might still want to update the cache - whenCacheChanged cacheStatus $ - case cachedResult of - Left _ -> pure () - Right cr -> rewriteCacheFile monitor cachedFileStatus' cachedKey cr - - return Nothing + Nothing -> case cachedResult of + Left _ -> pure (MonitorChanged MonitorCorruptCache) + Right cr -> return (MonitorUnchanged cr monitorFiles) + where + monitorFiles = reconstructMonitorFilePaths cachedFileStatus + where + -- In fileMonitorCheckIfOnlyValueChanged mode we want to guarantee that + -- if we return MonitoredValueChanged that only the value changed. + -- We do that by checking for file changes first. Otherwise it makes + -- more sense to do the cheaper test first. + checkForChanges :: IO (Maybe (MonitorChangedReason a)) + checkForChanges + | fileMonitorCheckIfOnlyValueChanged = + checkFileChange cachedFileStatus cachedKey cachedResult + `mplusMaybeT` checkValueChange cachedKey + | otherwise = + checkValueChange cachedKey + `mplusMaybeT` checkFileChange cachedFileStatus cachedKey cachedResult + + mplusMaybeT :: Monad m => m (Maybe a1) -> m (Maybe a1) -> m (Maybe a1) + mplusMaybeT ma mb = do + mx <- ma + case mx of + Nothing -> mb + Just x -> return (Just x) + + -- Check if the guard value has changed + checkValueChange :: a -> IO (Maybe (MonitorChangedReason a)) + checkValueChange cachedKey + | not (fileMonitorKeyValid currentKey cachedKey) = + return (Just (MonitoredValueChanged cachedKey)) + | otherwise = + return Nothing + + -- Check if any file has changed + checkFileChange :: MonitorStateFileSet -> a -> Either String b -> IO (Maybe (MonitorChangedReason a)) + checkFileChange cachedFileStatus cachedKey cachedResult = do + res <- probeFileSystem root cachedFileStatus + case res of + -- Some monitored file has changed + Left changedPath -> + return (Just (MonitoredFileChanged (normalise changedPath))) + -- No monitored file has changed + Right (cachedFileStatus', cacheStatus) -> do + -- But we might still want to update the cache + whenCacheChanged cacheStatus $ + case cachedResult of + Left _ -> pure () + Right cr -> rewriteCacheFile monitor cachedFileStatus' cachedKey cr + + return Nothing -- | Lazily decode a triple, parsing the first two fields strictly and -- returning a lazy value containing either the last one or an error. @@ -512,45 +503,49 @@ checkFileMonitorChanged -- Distribution.Utils.Structured because it depends on a newer version of -- binary than supported in the Cabal library proper. structuredDecodeTriple - :: forall a b c. (Structured a, Structured b, Structured c, Binary.Binary a, Binary.Binary b, Binary.Binary c) - => BS.ByteString -> Either String (a, b, Either String c) + :: forall a b c + . (Structured a, Structured b, Structured c, Binary.Binary a, Binary.Binary b, Binary.Binary c) + => BS.ByteString + -> Either String (a, b, Either String c) structuredDecodeTriple lbs = let partialDecode = - (`runGetOrFail` lbs) $ do - (_ :: Tag (a,b,c)) <- Binary.get - (a :: a) <- Binary.get - (b :: b) <- Binary.get - pure (a, b) + (`runGetOrFail` lbs) $ do + (_ :: Tag (a, b, c)) <- Binary.get + (a :: a) <- Binary.get + (b :: b) <- Binary.get + pure (a, b) cleanEither (Left (_, pos, msg)) = Left ("Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ msg) - cleanEither (Right (_,_,v)) = Right v - - in case partialDecode of - Left (_, pos, msg) -> Left ("Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ msg) - Right (lbs', _, (x,y)) -> Right (x, y, cleanEither $ runGetOrFail (Binary.get :: Binary.Get c) lbs') + cleanEither (Right (_, _, v)) = Right v + in case partialDecode of + Left (_, pos, msg) -> Left ("Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ msg) + Right (lbs', _, (x, y)) -> Right (x, y, cleanEither $ runGetOrFail (Binary.get :: Binary.Get c) lbs') -- | Helper for reading the cache file. -- -- This determines the type and format of the binary cache file. --- -withCacheFile :: (Binary a, Structured a, Binary b, Structured b) - => FileMonitor a b - -> (Either String (MonitorStateFileSet, a, Either String b) -> IO r) - -> IO r -withCacheFile (FileMonitor {fileMonitorCacheFile}) k = - withBinaryFile fileMonitorCacheFile ReadMode $ \hnd -> do - contents <- structuredDecodeTriple <$> BS.hGetContents hnd - k contents +withCacheFile + :: (Binary a, Structured a, Binary b, Structured b) + => FileMonitor a b + -> (Either String (MonitorStateFileSet, a, Either String b) -> IO r) + -> IO r +withCacheFile (FileMonitor{fileMonitorCacheFile}) k = + withBinaryFile fileMonitorCacheFile ReadMode $ \hnd -> do + contents <- structuredDecodeTriple <$> BS.hGetContents hnd + k contents -- | Helper for writing the cache file. -- -- This determines the type and format of the binary cache file. --- -rewriteCacheFile :: (Binary a, Structured a, Binary b, Structured b) - => FileMonitor a b - -> MonitorStateFileSet -> a -> b -> IO () -rewriteCacheFile FileMonitor {fileMonitorCacheFile} fileset key result = - writeFileAtomic fileMonitorCacheFile $ - structuredEncode (fileset, key, result) +rewriteCacheFile + :: (Binary a, Structured a, Binary b, Structured b) + => FileMonitor a b + -> MonitorStateFileSet + -> a + -> b + -> IO () +rewriteCacheFile FileMonitor{fileMonitorCacheFile} fileset key result = + writeFileAtomic fileMonitorCacheFile $ + structuredEncode (fileset, key, result) -- | Probe the file system to see if any of the monitored files have changed. -- @@ -566,22 +561,24 @@ rewriteCacheFile FileMonitor {fileMonitorCacheFile} fileset key result = -- we want to update the cache despite no changes in our relevant file set. -- Specifically, we should add an mtime for this directory so we can avoid -- re-traversing the directory in future runs. --- -probeFileSystem :: FilePath -> MonitorStateFileSet - -> IO (Either FilePath (MonitorStateFileSet, CacheChanged)) +probeFileSystem + :: FilePath + -> MonitorStateFileSet + -> IO (Either FilePath (MonitorStateFileSet, CacheChanged)) probeFileSystem root (MonitorStateFileSet singlePaths globPaths) = runChangedM $ do sequence_ [ probeMonitorStateFileStatus root file status - | MonitorStateFile _ _ file status <- singlePaths ] + | MonitorStateFile _ _ file status <- singlePaths + ] -- The glob monitors can require state changes globPaths' <- sequence [ probeMonitorStateGlob root globPath - | globPath <- globPaths ] + | globPath <- globPaths + ] return (MonitorStateFileSet singlePaths globPaths') - ----------------------------------------------- -- Monad for checking for file system changes -- @@ -606,181 +603,216 @@ cacheChanged = ChangedM $ State.put CacheChanged mapChangedFile :: (FilePath -> FilePath) -> ChangedM a -> ChangedM a mapChangedFile adjust (ChangedM a) = - ChangedM (mapStateT (withExceptT adjust) a) + ChangedM (mapStateT (withExceptT adjust) a) data CacheChanged = CacheChanged | CacheUnchanged whenCacheChanged :: Monad m => CacheChanged -> m () -> m () whenCacheChanged CacheChanged action = action -whenCacheChanged CacheUnchanged _ = return () +whenCacheChanged CacheUnchanged _ = return () ---------------------- -- | Probe the file system to see if a single monitored file has changed. --- -probeMonitorStateFileStatus :: FilePath -> FilePath - -> MonitorStateFileStatus - -> ChangedM () +probeMonitorStateFileStatus + :: FilePath + -> FilePath + -> MonitorStateFileStatus + -> ChangedM () probeMonitorStateFileStatus root file status = - case status of - MonitorStateFileExists -> - probeFileExistence root file - - MonitorStateFileModTime mtime -> - probeFileModificationTime root file mtime - - MonitorStateFileHashed mtime hash -> - probeFileModificationTimeAndHash root file mtime hash - - MonitorStateDirExists -> - probeDirExistence root file - - MonitorStateDirModTime mtime -> - probeFileModificationTime root file mtime - - MonitorStateNonExistent -> - probeFileNonExistence root file - - MonitorStateAlreadyChanged -> - somethingChanged file - + case status of + MonitorStateFileExists -> + probeFileExistence root file + MonitorStateFileModTime mtime -> + probeFileModificationTime root file mtime + MonitorStateFileHashed mtime hash -> + probeFileModificationTimeAndHash root file mtime hash + MonitorStateDirExists -> + probeDirExistence root file + MonitorStateDirModTime mtime -> + probeFileModificationTime root file mtime + MonitorStateNonExistent -> + probeFileNonExistence root file + MonitorStateAlreadyChanged -> + somethingChanged file -- | Probe the file system to see if a monitored file glob has changed. --- -probeMonitorStateGlob :: FilePath -- ^ root path - -> MonitorStateGlob - -> ChangedM MonitorStateGlob -probeMonitorStateGlob relroot - (MonitorStateGlob kindfile kinddir globroot glob) = do +probeMonitorStateGlob + :: FilePath + -- ^ root path + -> MonitorStateGlob + -> ChangedM MonitorStateGlob +probeMonitorStateGlob + relroot + (MonitorStateGlob kindfile kinddir globroot glob) = do root <- liftIO $ getFilePathRootDirectory globroot relroot case globroot of FilePathRelative -> - MonitorStateGlob kindfile kinddir globroot <$> - probeMonitorStateGlobRel kindfile kinddir root "." glob - + MonitorStateGlob kindfile kinddir globroot + <$> probeMonitorStateGlobRel kindfile kinddir root "." glob -- for absolute cases, make the changed file we report absolute too _ -> mapChangedFile (root ) $ - MonitorStateGlob kindfile kinddir globroot <$> - probeMonitorStateGlobRel kindfile kinddir root "" glob - -probeMonitorStateGlobRel :: MonitorKindFile -> MonitorKindDir - -> FilePath -- ^ root path - -> FilePath -- ^ path of the directory we are - -- looking in relative to @root@ - -> MonitorStateGlobRel - -> ChangedM MonitorStateGlobRel -probeMonitorStateGlobRel kindfile kinddir root dirName - (MonitorStateGlobDirs glob globPath mtime children) = do + MonitorStateGlob kindfile kinddir globroot + <$> probeMonitorStateGlobRel kindfile kinddir root "" glob + +probeMonitorStateGlobRel + :: MonitorKindFile + -> MonitorKindDir + -> FilePath + -- ^ root path + -> FilePath + -- ^ path of the directory we are + -- looking in relative to @root@ + -> MonitorStateGlobRel + -> ChangedM MonitorStateGlobRel +probeMonitorStateGlobRel + kindfile + kinddir + root + dirName + (MonitorStateGlobDirs glob globPath mtime children) = do change <- liftIO $ checkDirectoryModificationTime (root dirName) mtime case change of Nothing -> do - children' <- sequence - [ do fstate' <- probeMonitorStateGlobRel - kindfile kinddir root - (dirName fname) fstate - return (fname, fstate') - | (fname, fstate) <- children ] + children' <- + sequence + [ do + fstate' <- + probeMonitorStateGlobRel + kindfile + kinddir + root + (dirName fname) + fstate + return (fname, fstate') + | (fname, fstate) <- children + ] return $! MonitorStateGlobDirs glob globPath mtime children' - Just mtime' -> do -- directory modification time changed: -- a matching subdir may have been added or deleted - matches <- filterM (\entry -> let subdir = root dirName entry - in liftIO $ doesDirectoryExist subdir) - . filter (matchGlob glob) - =<< liftIO (getDirectoryContents (root dirName)) - - children' <- traverse probeMergeResult $ - mergeBy (\(path1,_) path2 -> compare path1 path2) - children - (sort matches) + matches <- + filterM + ( \entry -> + let subdir = root dirName entry + in liftIO $ doesDirectoryExist subdir + ) + . filter (matchGlob glob) + =<< liftIO (getDirectoryContents (root dirName)) + + children' <- + traverse probeMergeResult $ + mergeBy + (\(path1, _) path2 -> compare path1 path2) + children + (sort matches) return $! MonitorStateGlobDirs glob globPath mtime' children' - -- Note that just because the directory has changed, we don't force - -- a cache rewrite with 'cacheChanged' since that has some cost, and - -- all we're saving is scanning the directory. But we do rebuild the - -- cache with the new mtime', so that if the cache is rewritten for - -- some other reason, we'll take advantage of that. - - where - probeMergeResult :: MergeResult (FilePath, MonitorStateGlobRel) FilePath - -> ChangedM (FilePath, MonitorStateGlobRel) - - -- Only in cached (directory deleted) - probeMergeResult (OnlyInLeft (path, fstate)) = do - case allMatchingFiles (dirName path) fstate of - [] -> return (path, fstate) - -- Strictly speaking we should be returning 'CacheChanged' above - -- as we should prune the now-missing 'MonitorStateGlobRel'. However - -- we currently just leave these now-redundant entries in the - -- cache as they cost no IO and keeping them allows us to avoid - -- rewriting the cache. - (file:_) -> somethingChanged file - - -- Only in current filesystem state (directory added) - probeMergeResult (OnlyInRight path) = do - fstate <- liftIO $ buildMonitorStateGlobRel Nothing Map.empty - kindfile kinddir root (dirName path) globPath - case allMatchingFiles (dirName path) fstate of - (file:_) -> somethingChanged file - -- This is the only case where we use 'cacheChanged' because we can - -- have a whole new dir subtree (of unbounded size and cost), so we - -- need to save the state of that new subtree in the cache. - [] -> cacheChanged >> return (path, fstate) - - -- Found in path - probeMergeResult (InBoth (path, fstate) _) = do - fstate' <- probeMonitorStateGlobRel kindfile kinddir - root (dirName path) fstate - return (path, fstate') - - -- | Does a 'MonitorStateGlob' have any relevant files within it? - allMatchingFiles :: FilePath -> MonitorStateGlobRel -> [FilePath] - allMatchingFiles dir (MonitorStateGlobFiles _ _ entries) = - [ dir fname | (fname, _) <- entries ] - allMatchingFiles dir (MonitorStateGlobDirs _ _ _ entries) = - [ res - | (subdir, fstate) <- entries - , res <- allMatchingFiles (dir subdir) fstate ] - allMatchingFiles dir MonitorStateGlobDirTrailing = - [dir] - -probeMonitorStateGlobRel _ _ root dirName - (MonitorStateGlobFiles glob mtime children) = do + where + -- Note that just because the directory has changed, we don't force + -- a cache rewrite with 'cacheChanged' since that has some cost, and + -- all we're saving is scanning the directory. But we do rebuild the + -- cache with the new mtime', so that if the cache is rewritten for + -- some other reason, we'll take advantage of that. + + probeMergeResult + :: MergeResult (FilePath, MonitorStateGlobRel) FilePath + -> ChangedM (FilePath, MonitorStateGlobRel) + + -- Only in cached (directory deleted) + probeMergeResult (OnlyInLeft (path, fstate)) = do + case allMatchingFiles (dirName path) fstate of + [] -> return (path, fstate) + -- Strictly speaking we should be returning 'CacheChanged' above + -- as we should prune the now-missing 'MonitorStateGlobRel'. However + -- we currently just leave these now-redundant entries in the + -- cache as they cost no IO and keeping them allows us to avoid + -- rewriting the cache. + (file : _) -> somethingChanged file + + -- Only in current filesystem state (directory added) + probeMergeResult (OnlyInRight path) = do + fstate <- + liftIO $ + buildMonitorStateGlobRel + Nothing + Map.empty + kindfile + kinddir + root + (dirName path) + globPath + case allMatchingFiles (dirName path) fstate of + (file : _) -> somethingChanged file + -- This is the only case where we use 'cacheChanged' because we can + -- have a whole new dir subtree (of unbounded size and cost), so we + -- need to save the state of that new subtree in the cache. + [] -> cacheChanged >> return (path, fstate) + + -- Found in path + probeMergeResult (InBoth (path, fstate) _) = do + fstate' <- + probeMonitorStateGlobRel + kindfile + kinddir + root + (dirName path) + fstate + return (path, fstate') + + -- \| Does a 'MonitorStateGlob' have any relevant files within it? + allMatchingFiles :: FilePath -> MonitorStateGlobRel -> [FilePath] + allMatchingFiles dir (MonitorStateGlobFiles _ _ entries) = + [dir fname | (fname, _) <- entries] + allMatchingFiles dir (MonitorStateGlobDirs _ _ _ entries) = + [ res + | (subdir, fstate) <- entries + , res <- allMatchingFiles (dir subdir) fstate + ] + allMatchingFiles dir MonitorStateGlobDirTrailing = + [dir] +probeMonitorStateGlobRel + _ + _ + root + dirName + (MonitorStateGlobFiles glob mtime children) = do change <- liftIO $ checkDirectoryModificationTime (root dirName) mtime mtime' <- case change of - Nothing -> return mtime + Nothing -> return mtime Just mtime' -> do -- directory modification time changed: -- a matching file may have been added or deleted - matches <- return . filter (matchGlob glob) - =<< liftIO (getDirectoryContents (root dirName)) + matches <- + return . filter (matchGlob glob) + =<< liftIO (getDirectoryContents (root dirName)) traverse_ probeMergeResult $ - mergeBy (\(path1,_) path2 -> compare path1 path2) - children - (sort matches) + mergeBy + (\(path1, _) path2 -> compare path1 path2) + children + (sort matches) return mtime' -- Check that none of the children have changed for_ children $ \(file, status) -> probeMonitorStateFileStatus root (dirName file) status - return (MonitorStateGlobFiles glob mtime' children) - -- Again, we don't force a cache rewrite with 'cacheChanged', but we do use - -- the new mtime' if any. - where - probeMergeResult :: MergeResult (FilePath, MonitorStateFileStatus) FilePath - -> ChangedM () - probeMergeResult mr = case mr of - InBoth _ _ -> return () - -- this is just to be able to accurately report which file changed: - OnlyInLeft (path, _) -> somethingChanged (dirName path) - OnlyInRight path -> somethingChanged (dirName path) - + where + -- Again, we don't force a cache rewrite with 'cacheChanged', but we do use + -- the new mtime' if any. + + probeMergeResult + :: MergeResult (FilePath, MonitorStateFileStatus) FilePath + -> ChangedM () + probeMergeResult mr = case mr of + InBoth _ _ -> return () + -- this is just to be able to accurately report which file changed: + OnlyInLeft (path, _) -> somethingChanged (dirName path) + OnlyInRight path -> somethingChanged (dirName path) probeMonitorStateGlobRel _ _ _ _ MonitorStateGlobDirTrailing = - return MonitorStateGlobDirTrailing + return MonitorStateGlobDirTrailing ------------------------------------------------------------------------------ @@ -809,31 +841,39 @@ probeMonitorStateGlobRel _ _ _ _ MonitorStateGlobDirTrailing = -- 'beginUpdateFileMonitor' to get a timestamp and pass that. Alternatively, -- if you take the snapshot in advance of the action, or you're not monitoring -- any files then you can use @Nothing@ for the timestamp parameter. --- updateFileMonitor :: (Binary a, Structured a, Binary b, Structured b) - => FileMonitor a b -- ^ cache file path - -> FilePath -- ^ root directory - -> Maybe MonitorTimestamp -- ^ timestamp when the update action started - -> [MonitorFilePath] -- ^ files of interest relative to root - -> a -- ^ the current key value - -> b -- ^ the current result value + => FileMonitor a b + -- ^ cache file path + -> FilePath + -- ^ root directory + -> Maybe MonitorTimestamp + -- ^ timestamp when the update action started + -> [MonitorFilePath] + -- ^ files of interest relative to root + -> a + -- ^ the current key value + -> b + -- ^ the current result value -> IO () -updateFileMonitor monitor root startTime monitorFiles - cachedKey cachedResult = do +updateFileMonitor + monitor + root + startTime + monitorFiles + cachedKey + cachedResult = do hashcache <- readCacheFileHashes monitor msfs <- buildMonitorStateFileSet startTime hashcache root monitorFiles rewriteCacheFile monitor msfs cachedKey cachedResult -- | A timestamp to help with the problem of file changes during actions. -- See 'updateFileMonitor' for details. --- newtype MonitorTimestamp = MonitorTimestamp ModTime -- | Record a timestamp at the beginning of an action, and when the action -- completes call 'updateFileMonitor' passing it the timestamp. -- See 'updateFileMonitor' for details. --- beginUpdateFileMonitor :: IO MonitorTimestamp beginUpdateFileMonitor = MonitorTimestamp <$> getCurTime @@ -841,92 +881,110 @@ beginUpdateFileMonitor = MonitorTimestamp <$> getCurTime -- specification of the set of files we need to monitor, inspect the state -- of the file system now and collect the information we'll need later to -- determine if anything has changed. --- -buildMonitorStateFileSet :: Maybe MonitorTimestamp -- ^ optional: timestamp - -- of the start of the action - -> FileHashCache -- ^ existing file hashes - -> FilePath -- ^ root directory - -> [MonitorFilePath] -- ^ patterns of interest - -- relative to root - -> IO MonitorStateFileSet +buildMonitorStateFileSet + :: Maybe MonitorTimestamp + -- ^ optional: timestamp + -- of the start of the action + -> FileHashCache + -- ^ existing file hashes + -> FilePath + -- ^ root directory + -> [MonitorFilePath] + -- ^ patterns of interest + -- relative to root + -> IO MonitorStateFileSet buildMonitorStateFileSet mstartTime hashcache root = - go [] [] + go [] [] where - go :: [MonitorStateFile] -> [MonitorStateGlob] - -> [MonitorFilePath] -> IO MonitorStateFileSet + go + :: [MonitorStateFile] + -> [MonitorStateGlob] + -> [MonitorFilePath] + -> IO MonitorStateFileSet go !singlePaths !globPaths [] = return (MonitorStateFileSet (reverse singlePaths) (reverse globPaths)) - - go !singlePaths !globPaths - (MonitorFile kindfile kinddir path : monitors) = do - monitorState <- MonitorStateFile kindfile kinddir path - <$> buildMonitorStateFile mstartTime hashcache - kindfile kinddir root path - go (monitorState : singlePaths) globPaths monitors - - go !singlePaths !globPaths - (MonitorFileGlob kindfile kinddir globPath : monitors) = do - monitorState <- buildMonitorStateGlob mstartTime hashcache - kindfile kinddir root globPath - go singlePaths (monitorState : globPaths) monitors - - -buildMonitorStateFile :: Maybe MonitorTimestamp -- ^ start time of update - -> FileHashCache -- ^ existing file hashes - -> MonitorKindFile -> MonitorKindDir - -> FilePath -- ^ the root directory - -> FilePath - -> IO MonitorStateFileStatus + go + !singlePaths + !globPaths + (MonitorFile kindfile kinddir path : monitors) = do + monitorState <- + MonitorStateFile kindfile kinddir path + <$> buildMonitorStateFile + mstartTime + hashcache + kindfile + kinddir + root + path + go (monitorState : singlePaths) globPaths monitors + go + !singlePaths + !globPaths + (MonitorFileGlob kindfile kinddir globPath : monitors) = do + monitorState <- + buildMonitorStateGlob + mstartTime + hashcache + kindfile + kinddir + root + globPath + go singlePaths (monitorState : globPaths) monitors + +buildMonitorStateFile + :: Maybe MonitorTimestamp + -- ^ start time of update + -> FileHashCache + -- ^ existing file hashes + -> MonitorKindFile + -> MonitorKindDir + -> FilePath + -- ^ the root directory + -> FilePath + -> IO MonitorStateFileStatus buildMonitorStateFile mstartTime hashcache kindfile kinddir root path = do - let abspath = root path - isFile <- doesFileExist abspath - isDir <- doesDirectoryExist abspath - case (isFile, kindfile, isDir, kinddir) of - (_, FileNotExists, _, DirNotExists) -> - -- we don't need to care if it exists now, since we check at probe time - return MonitorStateNonExistent - - (False, _, False, _) -> - return MonitorStateAlreadyChanged - - (True, FileExists, _, _) -> - return MonitorStateFileExists - - (True, FileModTime, _, _) -> - handleIOException MonitorStateAlreadyChanged $ do - mtime <- getModTime abspath - if changedDuringUpdate mstartTime mtime - then return MonitorStateAlreadyChanged - else return (MonitorStateFileModTime mtime) - - (True, FileHashed, _, _) -> - handleIOException MonitorStateAlreadyChanged $ do - mtime <- getModTime abspath - if changedDuringUpdate mstartTime mtime - then return MonitorStateAlreadyChanged - else do hash <- getFileHash hashcache abspath abspath mtime - return (MonitorStateFileHashed mtime hash) - - (_, _, True, DirExists) -> - return MonitorStateDirExists - - (_, _, True, DirModTime) -> - handleIOException MonitorStateAlreadyChanged $ do - mtime <- getModTime abspath - if changedDuringUpdate mstartTime mtime - then return MonitorStateAlreadyChanged - else return (MonitorStateDirModTime mtime) - - (False, _, True, DirNotExists) -> return MonitorStateAlreadyChanged - (True, FileNotExists, False, _) -> return MonitorStateAlreadyChanged + let abspath = root path + isFile <- doesFileExist abspath + isDir <- doesDirectoryExist abspath + case (isFile, kindfile, isDir, kinddir) of + (_, FileNotExists, _, DirNotExists) -> + -- we don't need to care if it exists now, since we check at probe time + return MonitorStateNonExistent + (False, _, False, _) -> + return MonitorStateAlreadyChanged + (True, FileExists, _, _) -> + return MonitorStateFileExists + (True, FileModTime, _, _) -> + handleIOException MonitorStateAlreadyChanged $ do + mtime <- getModTime abspath + if changedDuringUpdate mstartTime mtime + then return MonitorStateAlreadyChanged + else return (MonitorStateFileModTime mtime) + (True, FileHashed, _, _) -> + handleIOException MonitorStateAlreadyChanged $ do + mtime <- getModTime abspath + if changedDuringUpdate mstartTime mtime + then return MonitorStateAlreadyChanged + else do + hash <- getFileHash hashcache abspath abspath mtime + return (MonitorStateFileHashed mtime hash) + (_, _, True, DirExists) -> + return MonitorStateDirExists + (_, _, True, DirModTime) -> + handleIOException MonitorStateAlreadyChanged $ do + mtime <- getModTime abspath + if changedDuringUpdate mstartTime mtime + then return MonitorStateAlreadyChanged + else return (MonitorStateDirModTime mtime) + (False, _, True, DirNotExists) -> return MonitorStateAlreadyChanged + (True, FileNotExists, False, _) -> return MonitorStateAlreadyChanged -- | If we have a timestamp for the beginning of the update, then any file -- mtime later than this means that it changed during the update and we ought -- to consider the file as already changed. --- changedDuringUpdate :: Maybe MonitorTimestamp -> ModTime -> Bool -changedDuringUpdate (Just (MonitorTimestamp startTime)) mtime - = mtime > startTime +changedDuringUpdate (Just (MonitorTimestamp startTime)) mtime = + mtime > startTime changedDuringUpdate _ _ = False -- | Much like 'buildMonitorStateFileSet' but for the somewhat complicated case @@ -935,59 +993,97 @@ changedDuringUpdate _ _ = False -- This gets used both by 'buildMonitorStateFileSet' when we're taking the -- file system snapshot, but also by 'probeGlobStatus' as part of checking -- the monitored (globed) files for changes when we find a whole new subtree. --- -buildMonitorStateGlob :: Maybe MonitorTimestamp -- ^ start time of update - -> FileHashCache -- ^ existing file hashes - -> MonitorKindFile -> MonitorKindDir - -> FilePath -- ^ the root directory - -> FilePathGlob -- ^ the matching glob - -> IO MonitorStateGlob -buildMonitorStateGlob mstartTime hashcache kindfile kinddir relroot - (FilePathGlob globroot globPath) = do +buildMonitorStateGlob + :: Maybe MonitorTimestamp + -- ^ start time of update + -> FileHashCache + -- ^ existing file hashes + -> MonitorKindFile + -> MonitorKindDir + -> FilePath + -- ^ the root directory + -> FilePathGlob + -- ^ the matching glob + -> IO MonitorStateGlob +buildMonitorStateGlob + mstartTime + hashcache + kindfile + kinddir + relroot + (FilePathGlob globroot globPath) = do root <- liftIO $ getFilePathRootDirectory globroot relroot - MonitorStateGlob kindfile kinddir globroot <$> - buildMonitorStateGlobRel - mstartTime hashcache kindfile kinddir root "." globPath - -buildMonitorStateGlobRel :: Maybe MonitorTimestamp -- ^ start time of update - -> FileHashCache -- ^ existing file hashes - -> MonitorKindFile -> MonitorKindDir - -> FilePath -- ^ the root directory - -> FilePath -- ^ directory we are examining - -- relative to the root - -> FilePathGlobRel -- ^ the matching glob - -> IO MonitorStateGlobRel -buildMonitorStateGlobRel mstartTime hashcache kindfile kinddir root - dir globPath = do + MonitorStateGlob kindfile kinddir globroot + <$> buildMonitorStateGlobRel + mstartTime + hashcache + kindfile + kinddir + root + "." + globPath + +buildMonitorStateGlobRel + :: Maybe MonitorTimestamp + -- ^ start time of update + -> FileHashCache + -- ^ existing file hashes + -> MonitorKindFile + -> MonitorKindDir + -> FilePath + -- ^ the root directory + -> FilePath + -- ^ directory we are examining + -- relative to the root + -> FilePathGlobRel + -- ^ the matching glob + -> IO MonitorStateGlobRel +buildMonitorStateGlobRel + mstartTime + hashcache + kindfile + kinddir + root + dir + globPath = do let absdir = root dir dirEntries <- getDirectoryContents absdir - dirMTime <- getModTime absdir + dirMTime <- getModTime absdir case globPath of GlobDir glob globPath' -> do - subdirs <- filterM (\subdir -> doesDirectoryExist (absdir subdir)) - $ filter (matchGlob glob) dirEntries + subdirs <- + filterM (\subdir -> doesDirectoryExist (absdir subdir)) $ + filter (matchGlob glob) dirEntries subdirStates <- for (sort subdirs) $ \subdir -> do - fstate <- buildMonitorStateGlobRel - mstartTime hashcache kindfile kinddir root - (dir subdir) globPath' + fstate <- + buildMonitorStateGlobRel + mstartTime + hashcache + kindfile + kinddir + root + (dir subdir) + globPath' return (subdir, fstate) return $! MonitorStateGlobDirs glob globPath' dirMTime subdirStates - GlobFile glob -> do let files = filter (matchGlob glob) dirEntries filesStates <- for (sort files) $ \file -> do - fstate <- buildMonitorStateFile - mstartTime hashcache kindfile kinddir root - (dir file) + fstate <- + buildMonitorStateFile + mstartTime + hashcache + kindfile + kinddir + root + (dir file) return (file, fstate) return $! MonitorStateGlobFiles glob dirMTime filesStates - GlobDirTrailing -> return MonitorStateGlobDirTrailing - -- | We really want to avoid re-hashing files all the time. We already make -- the assumption that if a file mtime has not changed then we don't need to -- bother checking if the content hash has changed. We can apply the same @@ -995,70 +1091,76 @@ buildMonitorStateGlobRel mstartTime hashcache kindfile kinddir root -- 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) -- | We declare it a cache hit if the mtime of a file is the same as before. --- lookupFileHashCache :: FileHashCache -> FilePath -> ModTime -> Maybe Hash lookupFileHashCache hashcache file mtime = do - (mtime', hash) <- Map.lookup file hashcache - guard (mtime' == mtime) - return hash + (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 hashcache relfile absfile mtime = - case lookupFileHashCache hashcache relfile mtime of - Just hash -> return hash - Nothing -> readFileHash absfile + case lookupFileHashCache hashcache relfile mtime of + Just hash -> return hash + Nothing -> readFileHash absfile -- | Build a 'FileHashCache' from the previous 'MonitorStateFileSet'. While -- in principle we could preserve the structure of the previous state, given -- that the set of files to monitor can change then it's simpler just to throw -- away the structure and use a finite map. --- -readCacheFileHashes :: (Binary a, Structured a, Binary b, Structured b) - => FileMonitor a b -> IO FileHashCache +readCacheFileHashes + :: (Binary a, Structured a, Binary b, Structured b) + => FileMonitor a b + -> IO FileHashCache readCacheFileHashes monitor = - handleDoesNotExist Map.empty $ - handleErrorCall Map.empty $ - withCacheFile monitor $ \res -> - case res of - Left _ -> return Map.empty - Right (msfs, _, _) -> return (mkFileHashCache msfs) + handleDoesNotExist Map.empty $ + handleErrorCall Map.empty $ + withCacheFile monitor $ \res -> + case res of + Left _ -> return Map.empty + Right (msfs, _, _) -> return (mkFileHashCache msfs) where mkFileHashCache :: MonitorStateFileSet -> FileHashCache mkFileHashCache (MonitorStateFileSet singlePaths globPaths) = - collectAllFileHashes singlePaths + collectAllFileHashes singlePaths `Map.union` collectAllGlobHashes globPaths collectAllFileHashes :: [MonitorStateFile] -> Map FilePath (ModTime, Hash) collectAllFileHashes singlePaths = - Map.fromList [ (fpath, (mtime, hash)) - | MonitorStateFile _ _ fpath - (MonitorStateFileHashed mtime hash) <- singlePaths ] + Map.fromList + [ (fpath, (mtime, hash)) + | MonitorStateFile + _ + _ + fpath + (MonitorStateFileHashed mtime hash) <- + singlePaths + ] collectAllGlobHashes :: [MonitorStateGlob] -> Map FilePath (ModTime, Hash) collectAllGlobHashes globPaths = - Map.fromList [ (fpath, (mtime, hash)) - | MonitorStateGlob _ _ _ gstate <- globPaths - , (fpath, (mtime, hash)) <- collectGlobHashes "" gstate ] + Map.fromList + [ (fpath, (mtime, hash)) + | MonitorStateGlob _ _ _ gstate <- globPaths + , (fpath, (mtime, hash)) <- collectGlobHashes "" gstate + ] collectGlobHashes :: FilePath -> MonitorStateGlobRel -> [(FilePath, (ModTime, Hash))] collectGlobHashes dir (MonitorStateGlobDirs _ _ _ entries) = [ res | (subdir, fstate) <- entries - , res <- collectGlobHashes (dir subdir) fstate ] - - collectGlobHashes dir (MonitorStateGlobFiles _ _ entries) = + , res <- collectGlobHashes (dir subdir) fstate + ] + collectGlobHashes dir (MonitorStateGlobFiles _ _ entries) = [ (dir fname, (mtime, hash)) - | (fname, MonitorStateFileHashed mtime hash) <- entries ] - + | (fname, MonitorStateFileHashed mtime hash) <- entries + ] collectGlobHashes _dir MonitorStateGlobDirTrailing = [] - ------------------------------------------------------------------------------ -- Utils -- @@ -1067,45 +1169,53 @@ readCacheFileHashes monitor = -- the same as @mtime@, short-circuiting if it is different. probeFileModificationTime :: FilePath -> FilePath -> ModTime -> ChangedM () probeFileModificationTime root file mtime = do - unchanged <- liftIO $ checkModificationTimeUnchanged root file mtime - unless unchanged (somethingChanged file) + unchanged <- liftIO $ checkModificationTimeUnchanged root file mtime + 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 -- different. -probeFileModificationTimeAndHash :: FilePath -> FilePath -> ModTime -> Hash - -> ChangedM () +probeFileModificationTimeAndHash + :: FilePath + -> FilePath + -> ModTime + -> Hash + -> ChangedM () probeFileModificationTimeAndHash root file mtime hash = do - unchanged <- liftIO $ + unchanged <- + liftIO $ checkFileModificationTimeAndHashUnchanged root file mtime hash - unless unchanged (somethingChanged file) + unless unchanged (somethingChanged file) -- | Within the @root@ directory, check if @file@ still exists as a file. -- If it *does not* exist, short-circuit. probeFileExistence :: FilePath -> FilePath -> ChangedM () probeFileExistence root file = do - existsFile <- liftIO $ doesFileExist (root file) - unless existsFile (somethingChanged file) + existsFile <- liftIO $ doesFileExist (root file) + unless existsFile (somethingChanged file) -- | Within the @root@ directory, check if @dir@ still exists. -- If it *does not* exist, short-circuit. probeDirExistence :: FilePath -> FilePath -> ChangedM () probeDirExistence root dir = do - existsDir <- liftIO $ doesDirectoryExist (root dir) - unless existsDir (somethingChanged dir) + existsDir <- liftIO $ doesDirectoryExist (root dir) + unless existsDir (somethingChanged dir) -- | Within the @root@ directory, check if @file@ still does not exist. -- If it *does* exist, short-circuit. probeFileNonExistence :: FilePath -> FilePath -> ChangedM () probeFileNonExistence root file = do - existsFile <- liftIO $ doesFileExist (root file) - existsDir <- liftIO $ doesDirectoryExist (root file) - when (existsFile || existsDir) (somethingChanged file) + existsFile <- liftIO $ doesFileExist (root file) + existsDir <- liftIO $ doesDirectoryExist (root file) + when (existsFile || existsDir) (somethingChanged file) -- | Returns @True@ if, inside the @root@ directory, @file@ has the same -- 'ModTime' as @mtime@. -checkModificationTimeUnchanged :: FilePath -> FilePath - -> ModTime -> IO Bool +checkModificationTimeUnchanged + :: FilePath + -> FilePath + -> ModTime + -> IO Bool checkModificationTimeUnchanged root file mtime = handleIOException False $ do mtime' <- getModTime (root file) @@ -1113,8 +1223,12 @@ checkModificationTimeUnchanged root file mtime = -- | Returns @True@ if, inside the @root@ directory, @file@ has the -- same 'ModTime' and 'Hash' as @mtime and @chash@. -checkFileModificationTimeAndHashUnchanged :: FilePath -> FilePath - -> ModTime -> Hash -> IO Bool +checkFileModificationTimeAndHashUnchanged + :: FilePath + -> FilePath + -> ModTime + -> Hash + -> IO Bool checkFileModificationTimeAndHashUnchanged root file mtime chash = handleIOException False $ do mtime' <- getModTime (root file) @@ -1127,8 +1241,8 @@ checkFileModificationTimeAndHashUnchanged root file mtime 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 + 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. @@ -1150,22 +1264,19 @@ handleErrorCall e = handle handler where handler (ErrorCall _) = return e #endif - -- | Run an IO computation, returning @e@ if there is any 'IOException'. -- -- This policy is OK in the file monitor code because it just causes the -- monitor to report that something changed, and then code reacting to that -- will normally encounter the same IO exception when it re-runs the action -- that uses the file. --- handleIOException :: a -> IO a -> IO a handleIOException e = - handle (anyIOException e) + handle (anyIOException e) where anyIOException :: a -> IOException -> IO a anyIOException x _ = return x - ------------------------------------------------------------------------------ -- Instances -- diff --git a/cabal-install/src/Distribution/Client/Freeze.hs b/cabal-install/src/Distribution/Client/Freeze.hs index ff9f6fde91a..faee9a2cf5a 100644 --- a/cabal-install/src/Distribution/Client/Freeze.hs +++ b/cabal-install/src/Distribution/Client/Freeze.hs @@ -1,4 +1,7 @@ ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.Freeze -- Copyright : (c) David Himmelstrup 2005 @@ -10,29 +13,39 @@ -- Portability : portable -- -- The cabal freeze command ------------------------------------------------------------------------------ -module Distribution.Client.Freeze ( - freeze, getFreezePkgs +module Distribution.Client.Freeze + ( freeze + , getFreezePkgs ) where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () -import Distribution.Client.Config ( SavedConfig(..) ) -import Distribution.Client.Types -import Distribution.Client.Targets +import Distribution.Client.Config (SavedConfig (..)) import Distribution.Client.Dependency import Distribution.Client.IndexUtils as IndexUtils - ( getSourcePackages, getInstalledPackages ) + ( getInstalledPackages + , getSourcePackages + ) +import Distribution.Client.Sandbox.PackageEnvironment + ( loadUserConfig + , pkgEnvSavedConfig + , showPackageEnvironment + , userPackageEnvironmentFile + ) +import Distribution.Client.Setup + ( ConfigExFlags (..) + , FreezeFlags (..) + , GlobalFlags (..) + , RepoContext (..) + ) import Distribution.Client.SolverInstallPlan - ( SolverInstallPlan, SolverPlanPackage ) + ( SolverInstallPlan + , SolverPlanPackage + ) import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan -import Distribution.Client.Setup - ( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..) - , RepoContext(..) ) -import Distribution.Client.Sandbox.PackageEnvironment - ( loadUserConfig, pkgEnvSavedConfig, showPackageEnvironment, - userPackageEnvironmentFile ) +import Distribution.Client.Targets +import Distribution.Client.Types import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.LabeledPackageConstraint @@ -41,172 +54,231 @@ import Distribution.Solver.Types.PkgConfigDb import Distribution.Solver.Types.SolverId import Distribution.Package - ( Package, packageId, packageName, packageVersion ) + ( Package + , packageId + , packageName + , packageVersion + ) import Distribution.Simple.Compiler - ( Compiler, compilerInfo, PackageDBStack ) + ( Compiler + , PackageDBStack + , compilerInfo + ) import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.Simple.Program - ( ProgramDb ) + ( ProgramDb + ) import Distribution.Simple.Setup - ( fromFlag, fromFlagOrDefault, flagToMaybe ) + ( flagToMaybe + , fromFlag + , fromFlagOrDefault + ) import Distribution.Simple.Utils - ( die', notice, debug, writeFileAtomic, toUTF8LBS) + ( debug + , die' + , notice + , toUTF8LBS + , writeFileAtomic + ) import Distribution.System - ( Platform ) + ( Platform + ) import Distribution.Version - ( thisVersion ) + ( thisVersion + ) -- ------------------------------------------------------------ + -- * The freeze command + -- ------------------------------------------------------------ -- | Freeze all of the dependencies by writing a constraints section -- constraining each dependency to an exact version. --- -freeze :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> Platform - -> ProgramDb - -> GlobalFlags - -> FreezeFlags - -> IO () -freeze verbosity packageDBs repoCtxt comp platform progdb - globalFlags freezeFlags = do - - pkgs <- getFreezePkgs - verbosity packageDBs repoCtxt comp platform progdb - globalFlags freezeFlags +freeze + :: Verbosity + -> PackageDBStack + -> RepoContext + -> Compiler + -> Platform + -> ProgramDb + -> GlobalFlags + -> FreezeFlags + -> IO () +freeze + verbosity + packageDBs + repoCtxt + comp + platform + progdb + globalFlags + freezeFlags = do + pkgs <- + getFreezePkgs + verbosity + packageDBs + repoCtxt + comp + platform + progdb + globalFlags + freezeFlags if null pkgs - then notice verbosity $ "No packages to be frozen. " - ++ "As this package has no dependencies." - else if dryRun - then notice verbosity $ unlines $ - "The following packages would be frozen:" - : formatPkgs pkgs - - else freezePackages verbosity globalFlags pkgs - - where - dryRun = fromFlag (freezeDryRun freezeFlags) + then + notice verbosity $ + "No packages to be frozen. " + ++ "As this package has no dependencies." + else + if dryRun + then + notice verbosity $ + unlines $ + "The following packages would be frozen:" + : formatPkgs pkgs + else freezePackages verbosity globalFlags pkgs + where + dryRun = fromFlag (freezeDryRun freezeFlags) -- | Get the list of packages whose versions would be frozen by the @freeze@ -- command. -getFreezePkgs :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> Platform - -> ProgramDb - -> GlobalFlags - -> FreezeFlags - -> IO [SolverPlanPackage] -getFreezePkgs verbosity packageDBs repoCtxt comp platform progdb - _ freezeFlags = do - +getFreezePkgs + :: Verbosity + -> PackageDBStack + -> RepoContext + -> Compiler + -> Platform + -> ProgramDb + -> GlobalFlags + -> FreezeFlags + -> IO [SolverPlanPackage] +getFreezePkgs + verbosity + packageDBs + repoCtxt + comp + platform + progdb + _ + freezeFlags = do installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb - sourcePkgDb <- getSourcePackages verbosity repoCtxt - pkgConfigDb <- readPkgConfigDb verbosity progdb + sourcePkgDb <- getSourcePackages verbosity repoCtxt + pkgConfigDb <- readPkgConfigDb verbosity progdb - pkgSpecifiers <- resolveUserTargets verbosity repoCtxt - (packageIndex sourcePkgDb) - [UserTargetLocalDir "."] + pkgSpecifiers <- + resolveUserTargets + verbosity + repoCtxt + (packageIndex sourcePkgDb) + [UserTargetLocalDir "."] sanityCheck pkgSpecifiers planPackages - verbosity comp platform freezeFlags - installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers - where - sanityCheck :: [PackageSpecifier UnresolvedSourcePackage] -> IO () - sanityCheck pkgSpecifiers = do - when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $ - die' verbosity $ "internal error: 'resolveUserTargets' returned " - ++ "unexpected named package specifiers!" - when (length pkgSpecifiers /= 1) $ - die' verbosity $ "internal error: 'resolveUserTargets' returned " - ++ "unexpected source package specifiers!" - -planPackages :: Verbosity - -> Compiler - -> Platform - -> FreezeFlags - -> InstalledPackageIndex - -> SourcePackageDb - -> PkgConfigDb - -> [PackageSpecifier UnresolvedSourcePackage] - -> IO [SolverPlanPackage] -planPackages verbosity comp platform freezeFlags - installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = do - - solver <- chooseSolver verbosity - (fromFlag (freezeSolver freezeFlags)) (compilerInfo comp) - notice verbosity "Resolving dependencies..." - - installPlan <- foldProgress logMsg (die' verbosity) return $ - resolveDependencies - platform (compilerInfo comp) pkgConfigDb - solver - resolverParams - - return $ pruneInstallPlan installPlan pkgSpecifiers - - where - resolverParams :: DepResolverParams - resolverParams = - - setMaxBackjumps (if maxBackjumps < 0 then Nothing - else Just maxBackjumps) - - . setIndependentGoals independentGoals - - . setReorderGoals reorderGoals - - . setCountConflicts countConflicts - - . setFineGrainedConflicts fineGrainedConflicts - - . setMinimizeConflictSet minimizeConflictSet - - . setShadowPkgs shadowPkgs - - . setStrongFlags strongFlags - - . setAllowBootLibInstalls allowBootLibInstalls - - . setOnlyConstrained onlyConstrained - - . setSolverVerbosity verbosity - - . addConstraints - [ let pkg = pkgSpecifierTarget pkgSpecifier - pc = PackageConstraint (scopeToplevel pkg) - (PackagePropertyStanzas stanzas) - in LabeledPackageConstraint pc ConstraintSourceFreeze - | pkgSpecifier <- pkgSpecifiers ] - - $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers - - logMsg message rest = debug verbosity message >> rest - - stanzas = [ TestStanzas | testsEnabled ] - ++ [ BenchStanzas | benchmarksEnabled ] - testsEnabled = fromFlagOrDefault False $ freezeTests freezeFlags - benchmarksEnabled = fromFlagOrDefault False $ freezeBenchmarks freezeFlags - - reorderGoals = fromFlag (freezeReorderGoals freezeFlags) - countConflicts = fromFlag (freezeCountConflicts freezeFlags) - fineGrainedConflicts = fromFlag (freezeFineGrainedConflicts freezeFlags) - minimizeConflictSet = fromFlag (freezeMinimizeConflictSet freezeFlags) - independentGoals = fromFlag (freezeIndependentGoals freezeFlags) - shadowPkgs = fromFlag (freezeShadowPkgs freezeFlags) - strongFlags = fromFlag (freezeStrongFlags freezeFlags) - maxBackjumps = fromFlag (freezeMaxBackjumps freezeFlags) - allowBootLibInstalls = fromFlag (freezeAllowBootLibInstalls freezeFlags) - onlyConstrained = fromFlag (freezeOnlyConstrained freezeFlags) - + verbosity + comp + platform + freezeFlags + installedPkgIndex + sourcePkgDb + pkgConfigDb + pkgSpecifiers + where + sanityCheck :: [PackageSpecifier UnresolvedSourcePackage] -> IO () + sanityCheck pkgSpecifiers = do + when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $ + die' verbosity $ + "internal error: 'resolveUserTargets' returned " + ++ "unexpected named package specifiers!" + when (length pkgSpecifiers /= 1) $ + die' verbosity $ + "internal error: 'resolveUserTargets' returned " + ++ "unexpected source package specifiers!" + +planPackages + :: Verbosity + -> Compiler + -> Platform + -> FreezeFlags + -> InstalledPackageIndex + -> SourcePackageDb + -> PkgConfigDb + -> [PackageSpecifier UnresolvedSourcePackage] + -> IO [SolverPlanPackage] +planPackages + verbosity + comp + platform + freezeFlags + installedPkgIndex + sourcePkgDb + pkgConfigDb + pkgSpecifiers = do + solver <- + chooseSolver + verbosity + (fromFlag (freezeSolver freezeFlags)) + (compilerInfo comp) + notice verbosity "Resolving dependencies..." + + installPlan <- + foldProgress logMsg (die' verbosity) return $ + resolveDependencies + platform + (compilerInfo comp) + pkgConfigDb + solver + resolverParams + + return $ pruneInstallPlan installPlan pkgSpecifiers + where + resolverParams :: DepResolverParams + resolverParams = + setMaxBackjumps + ( if maxBackjumps < 0 + then Nothing + else Just maxBackjumps + ) + . setIndependentGoals independentGoals + . setReorderGoals reorderGoals + . setCountConflicts countConflicts + . setFineGrainedConflicts fineGrainedConflicts + . setMinimizeConflictSet minimizeConflictSet + . setShadowPkgs shadowPkgs + . setStrongFlags strongFlags + . setAllowBootLibInstalls allowBootLibInstalls + . setOnlyConstrained onlyConstrained + . setSolverVerbosity verbosity + . addConstraints + [ let pkg = pkgSpecifierTarget pkgSpecifier + pc = + PackageConstraint + (scopeToplevel pkg) + (PackagePropertyStanzas stanzas) + in LabeledPackageConstraint pc ConstraintSourceFreeze + | pkgSpecifier <- pkgSpecifiers + ] + $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers + + logMsg message rest = debug verbosity message >> rest + + stanzas = + [TestStanzas | testsEnabled] + ++ [BenchStanzas | benchmarksEnabled] + testsEnabled = fromFlagOrDefault False $ freezeTests freezeFlags + benchmarksEnabled = fromFlagOrDefault False $ freezeBenchmarks freezeFlags + + reorderGoals = fromFlag (freezeReorderGoals freezeFlags) + countConflicts = fromFlag (freezeCountConflicts freezeFlags) + fineGrainedConflicts = fromFlag (freezeFineGrainedConflicts freezeFlags) + minimizeConflictSet = fromFlag (freezeMinimizeConflictSet freezeFlags) + independentGoals = fromFlag (freezeIndependentGoals freezeFlags) + shadowPkgs = fromFlag (freezeShadowPkgs freezeFlags) + strongFlags = fromFlag (freezeStrongFlags freezeFlags) + maxBackjumps = fromFlag (freezeMaxBackjumps freezeFlags) + allowBootLibInstalls = fromFlag (freezeAllowBootLibInstalls freezeFlags) + onlyConstrained = fromFlag (freezeOnlyConstrained freezeFlags) -- | Remove all unneeded packages from an install plan. -- @@ -220,45 +292,53 @@ planPackages verbosity comp platform freezeFlags -- -- Invariant: @pkgSpecifiers@ must refer to packages which are not -- 'PreExisting' in the 'SolverInstallPlan'. -pruneInstallPlan :: SolverInstallPlan - -> [PackageSpecifier UnresolvedSourcePackage] - -> [SolverPlanPackage] +pruneInstallPlan + :: SolverInstallPlan + -> [PackageSpecifier UnresolvedSourcePackage] + -> [SolverPlanPackage] pruneInstallPlan installPlan pkgSpecifiers = - removeSelf pkgIds $ + removeSelf pkgIds $ SolverInstallPlan.dependencyClosure installPlan pkgIds where - pkgIds = [ PlannedId (packageId pkg) - | SpecificSourcePackage pkg <- pkgSpecifiers ] + pkgIds = + [ PlannedId (packageId pkg) + | SpecificSourcePackage pkg <- pkgSpecifiers + ] removeSelf [thisPkg] = filter (\pp -> packageId pp /= packageId thisPkg) - removeSelf _ = error $ "internal error: 'pruneInstallPlan' given " - ++ "unexpected package specifiers!" - + removeSelf _ = + error $ + "internal error: 'pruneInstallPlan' given " + ++ "unexpected package specifiers!" freezePackages :: Package pkg => Verbosity -> GlobalFlags -> [pkg] -> IO () freezePackages verbosity globalFlags pkgs = do - - pkgEnv <- fmap (createPkgEnv . addFrozenConstraints) $ - loadUserConfig verbosity "" - (flagToMaybe . globalConstraintsFile $ globalFlags) - writeFileAtomic userPackageEnvironmentFile $ showPkgEnv pkgEnv + pkgEnv <- + fmap (createPkgEnv . addFrozenConstraints) $ + loadUserConfig + verbosity + "" + (flagToMaybe . globalConstraintsFile $ globalFlags) + writeFileAtomic userPackageEnvironmentFile $ showPkgEnv pkgEnv where addFrozenConstraints config = - config { - savedConfigureExFlags = (savedConfigureExFlags config) { - configExConstraints = map constraint pkgs - } + config + { savedConfigureExFlags = + (savedConfigureExFlags config) + { configExConstraints = map constraint pkgs + } } constraint pkg = - (pkgIdToConstraint $ packageId pkg - ,ConstraintSourceUserConfig userPackageEnvironmentFile) + ( pkgIdToConstraint $ packageId pkg + , ConstraintSourceUserConfig userPackageEnvironmentFile + ) where pkgIdToConstraint pkgId = - UserConstraint (UserQualified UserQualToplevel (packageName pkgId)) - (PackagePropertyVersion $ thisVersion (packageVersion pkgId)) - createPkgEnv config = mempty { pkgEnvSavedConfig = config } + UserConstraint + (UserQualified UserQualToplevel (packageName pkgId)) + (PackagePropertyVersion $ thisVersion (packageVersion pkgId)) + createPkgEnv config = mempty{pkgEnvSavedConfig = config} showPkgEnv = toUTF8LBS . showPackageEnvironment - formatPkgs :: Package pkg => [pkg] -> [String] formatPkgs = map $ showPkg . packageId where diff --git a/cabal-install/src/Distribution/Client/GZipUtils.hs b/cabal-install/src/Distribution/Client/GZipUtils.hs index 003ba0e99c7..acbea16d2e9 100644 --- a/cabal-install/src/Distribution/Client/GZipUtils.hs +++ b/cabal-install/src/Distribution/Client/GZipUtils.hs @@ -1,7 +1,10 @@ -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.GZipUtils -- Copyright : (c) Dmitry Astapov 2010 @@ -13,16 +16,15 @@ -- -- Provides a convenience functions for working with files that may or may not -- be zipped. ------------------------------------------------------------------------------ -module Distribution.Client.GZipUtils ( - maybeDecompress, +module Distribution.Client.GZipUtils + ( maybeDecompress ) where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () import Codec.Compression.Zlib.Internal -import Data.ByteString.Lazy.Internal as BS (ByteString(Empty, Chunk)) +import Data.ByteString.Lazy.Internal as BS (ByteString (Chunk, Empty)) #ifndef MIN_VERSION_zlib #define MIN_VERSION_zlib(x,y,z) 1 @@ -42,7 +44,6 @@ import qualified Data.ByteString as Strict -- This is to deal with http proxies that lie to us and transparently -- decompress without removing the content-encoding header. See: -- --- maybeDecompress :: ByteString -> ByteString #if MIN_VERSION_zlib(0,6,0) maybeDecompress bytes = runST (go bytes decompressor) diff --git a/cabal-install/src/Distribution/Client/GenBounds.hs b/cabal-install/src/Distribution/Client/GenBounds.hs index d82387cc015..e3584ab8cd4 100644 --- a/cabal-install/src/Distribution/Client/GenBounds.hs +++ b/cabal-install/src/Distribution/Client/GenBounds.hs @@ -1,5 +1,9 @@ {-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.GenBounds -- Copyright : (c) Doug Beardsley 2015 @@ -10,45 +14,75 @@ -- Portability : portable -- -- The cabal gen-bounds command for generating PVP-compliant version bounds. ------------------------------------------------------------------------------ -module Distribution.Client.GenBounds ( - genBounds +module Distribution.Client.GenBounds + ( genBounds ) where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () -import Distribution.Client.Utils - ( hasElem, incVersion ) import Distribution.Client.Freeze - ( getFreezePkgs ) + ( getFreezePkgs + ) import Distribution.Client.Setup - ( GlobalFlags(..), FreezeFlags(..), RepoContext ) + ( FreezeFlags (..) + , GlobalFlags (..) + , RepoContext + ) +import Distribution.Client.Utils + ( hasElem + , incVersion + ) import Distribution.Package - ( Package(..), unPackageName, packageName, packageVersion ) + ( Package (..) + , packageName + , packageVersion + , unPackageName + ) import Distribution.PackageDescription - ( enabledBuildDepends ) + ( enabledBuildDepends + ) import Distribution.PackageDescription.Configuration - ( finalizePD ) -import Distribution.Types.ComponentRequestedSpec - ( defaultComponentRequestedSpec ) -import Distribution.Types.Dependency + ( finalizePD + ) import Distribution.Simple.Compiler - ( Compiler, PackageDBStack, compilerInfo ) + ( Compiler + , PackageDBStack + , compilerInfo + ) import Distribution.Simple.PackageDescription - ( readGenericPackageDescription ) + ( readGenericPackageDescription + ) import Distribution.Simple.Program - ( ProgramDb ) + ( ProgramDb + ) import Distribution.Simple.Utils - ( notice, tryFindPackageDesc ) + ( notice + , tryFindPackageDesc + ) import Distribution.System - ( Platform ) + ( Platform + ) +import Distribution.Types.ComponentRequestedSpec + ( defaultComponentRequestedSpec + ) +import Distribution.Types.Dependency import Distribution.Version - ( Version, alterVersion, VersionInterval (..) - , LowerBound(..), UpperBound(..), VersionRange, asVersionIntervals - , orLaterVersion, earlierVersion, intersectVersionRanges, hasUpperBound) + ( LowerBound (..) + , UpperBound (..) + , Version + , VersionInterval (..) + , VersionRange + , alterVersion + , asVersionIntervals + , earlierVersion + , hasUpperBound + , intersectVersionRanges + , orLaterVersion + ) import System.Directory - ( getCurrentDirectory ) + ( getCurrentDirectory + ) -- | Given a version, return an API-compatible (according to PVP) version range. -- @@ -59,19 +93,21 @@ import System.Directory -- the user could be using a new function introduced in a.b.c which would make -- ">= a.b" incorrect. pvpize :: Version -> VersionRange -pvpize v = orLaterVersion (vn 3) - `intersectVersionRanges` - earlierVersion (incVersion 1 (vn 2)) +pvpize v = + orLaterVersion (vn 3) + `intersectVersionRanges` earlierVersion (incVersion 1 (vn 2)) where vn n = alterVersion (take n) v -- | Show the PVP-mandated version range for this package. The @padTo@ parameter -- specifies the width of the package name column. showBounds :: Package pkg => Int -> pkg -> String -showBounds padTo p = unwords $ - (padAfter padTo $ unPackageName $ packageName p) : - -- TODO: use normaliseVersionRange - map showInterval (asVersionIntervals $ pvpize $ packageVersion p) +showBounds padTo p = + unwords $ + (padAfter padTo $ unPackageName $ packageName p) + : + -- TODO: use normaliseVersionRange + map showInterval (asVersionIntervals $ pvpize $ packageVersion p) where padAfter :: Int -> String -> String padAfter n str = str ++ replicate (n - length str) ' ' @@ -84,45 +120,64 @@ showBounds padTo p = unwords $ -- | Entry point for the @gen-bounds@ command. genBounds - :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> Platform - -> ProgramDb - -> GlobalFlags - -> FreezeFlags - -> IO () + :: Verbosity + -> PackageDBStack + -> RepoContext + -> Compiler + -> Platform + -> ProgramDb + -> GlobalFlags + -> FreezeFlags + -> IO () genBounds verbosity packageDBs repoCtxt comp platform progdb globalFlags freezeFlags = do - let cinfo = compilerInfo comp - - cwd <- getCurrentDirectory - path <- tryFindPackageDesc verbosity cwd - gpd <- readGenericPackageDescription verbosity path - -- NB: We don't enable tests or benchmarks, since often they - -- don't really have useful bounds. - let epd = finalizePD mempty defaultComponentRequestedSpec - (const True) platform cinfo [] gpd - case epd of - Left _ -> putStrLn "finalizePD failed" - Right (pd,_) -> do - let needBounds = map depName $ filter (not . hasUpperBound . depVersion) $ - enabledBuildDepends pd defaultComponentRequestedSpec - - pkgs <- getFreezePkgs - verbosity packageDBs repoCtxt comp platform progdb - globalFlags freezeFlags - - let isNeeded = hasElem needBounds . unPackageName . packageName - let thePkgs = filter isNeeded pkgs - - let padTo = maximum $ map (length . unPackageName . packageName) pkgs - - if null thePkgs then notice verbosity - "Congratulations, all your dependencies have upper bounds!" + let cinfo = compilerInfo comp + + cwd <- getCurrentDirectory + path <- tryFindPackageDesc verbosity cwd + gpd <- readGenericPackageDescription verbosity path + -- NB: We don't enable tests or benchmarks, since often they + -- don't really have useful bounds. + let epd = + finalizePD + mempty + defaultComponentRequestedSpec + (const True) + platform + cinfo + [] + gpd + case epd of + Left _ -> putStrLn "finalizePD failed" + Right (pd, _) -> do + let needBounds = + map depName $ + filter (not . hasUpperBound . depVersion) $ + enabledBuildDepends pd defaultComponentRequestedSpec + + pkgs <- + getFreezePkgs + verbosity + packageDBs + repoCtxt + comp + platform + progdb + globalFlags + freezeFlags + + let isNeeded = hasElem needBounds . unPackageName . packageName + let thePkgs = filter isNeeded pkgs + + let padTo = maximum $ map (length . unPackageName . packageName) pkgs + + if null thePkgs + then + notice + verbosity + "Congratulations, all your dependencies have upper bounds!" else do - notice verbosity boundsNeededMsg - traverse_ (notice verbosity . (++",") . showBounds padTo) thePkgs + notice verbosity boundsNeededMsg + traverse_ (notice verbosity . (++ ",") . showBounds padTo) thePkgs depName :: Dependency -> String depName (Dependency pn _ _) = unPackageName pn @@ -133,18 +188,19 @@ depVersion (Dependency _ vr _) = vr -- | The message printed when some dependencies are found to be lacking proper -- PVP-mandated bounds. boundsNeededMsg :: String -boundsNeededMsg = unlines - [ "" - , "The following packages need bounds and here is a suggested starting point." - , "You can copy and paste this into the build-depends section in your .cabal" - , "file and it should work (with the appropriate removal of commas)." - , "" - , "Note that version bounds are a statement that you've successfully built and" - , "tested your package and expect it to work with any of the specified package" - , "versions (PROVIDED that those packages continue to conform with the PVP)." - , "Therefore, the version bounds generated here are the most conservative" - , "based on the versions that you are currently building with. If you know" - , "your package will work with versions outside the ranges generated here," - , "feel free to widen them." - , "" - ] +boundsNeededMsg = + unlines + [ "" + , "The following packages need bounds and here is a suggested starting point." + , "You can copy and paste this into the build-depends section in your .cabal" + , "file and it should work (with the appropriate removal of commas)." + , "" + , "Note that version bounds are a statement that you've successfully built and" + , "tested your package and expect it to work with any of the specified package" + , "versions (PROVIDED that those packages continue to conform with the PVP)." + , "Therefore, the version bounds generated here are the most conservative" + , "based on the versions that you are currently building with. If you know" + , "your package will work with versions outside the ranges generated here," + , "feel free to widen them." + , "" + ] diff --git a/cabal-install/src/Distribution/Client/Get.hs b/cabal-install/src/Distribution/Client/Get.hs index d5670096991..fa97ddad6cd 100644 --- a/cabal-install/src/Distribution/Client/Get.hs +++ b/cabal-install/src/Distribution/Client/Get.hs @@ -1,4 +1,7 @@ ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.Get -- Copyright : (c) Andrea Vezzosi 2008 @@ -11,69 +14,94 @@ -- Portability : portable -- -- The 'cabal get' command. ------------------------------------------------------------------------------ - -module Distribution.Client.Get ( - get, +module Distribution.Client.Get + ( get -- * Cloning 'SourceRepo's + -- | Mainly exported for testing purposes - clonePackagesFromSourceRepo, - ClonePackageException(..), + , clonePackagesFromSourceRepo + , ClonePackageException (..) ) where -import Prelude () import Distribution.Client.Compat.Prelude hiding (get) +import Distribution.Client.Types.SourceRepo (SourceRepoProxy, SourceRepositoryPackage (..), srpToProxy) import Distribution.Compat.Directory - ( listDirectory ) + ( listDirectory + ) import Distribution.Package - ( PackageId, packageId, packageName ) -import Distribution.Simple.Setup - ( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe ) -import Distribution.Simple.Utils - ( notice, die', info, warn, writeFileAtomic ) + ( PackageId + , packageId + , packageName + ) import qualified Distribution.PackageDescription as PD import Distribution.Simple.Program - ( programName ) + ( programName + ) +import Distribution.Simple.Setup + ( Flag (..) + , flagToMaybe + , fromFlag + , fromFlagOrDefault + ) +import Distribution.Simple.Utils + ( die' + , info + , notice + , warn + , writeFileAtomic + ) import Distribution.Types.SourceRepo (RepoKind (..)) -import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage (..), SourceRepoProxy, srpToProxy) +import Prelude () -import Distribution.Client.Setup - ( GlobalFlags(..), GetFlags(..), RepoContext(..) ) -import Distribution.Client.Types -import Distribution.Client.Targets import Distribution.Client.Dependency -import Distribution.Client.VCS import Distribution.Client.FetchUtils -import qualified Distribution.Client.Tar as Tar (extractTarGzFile) import Distribution.Client.IndexUtils - ( getSourcePackagesAtIndexState, TotalIndexState, ActiveRepos ) -import Distribution.Solver.Types.SourcePackage + ( ActiveRepos + , TotalIndexState + , getSourcePackagesAtIndexState + ) +import Distribution.Client.Setup + ( GetFlags (..) + , GlobalFlags (..) + , RepoContext (..) + ) +import qualified Distribution.Client.Tar as Tar (extractTarGzFile) +import Distribution.Client.Targets +import Distribution.Client.Types +import Distribution.Client.VCS import Distribution.PackageDescription.PrettyPrint - ( writeGenericPackageDescription ) + ( writeGenericPackageDescription + ) +import Distribution.Solver.Types.SourcePackage +import Control.Monad (mapM_) import qualified Data.Map as Map -import Control.Monad ( mapM_ ) import System.Directory - ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist ) + ( createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + ) import System.FilePath - ( (), (<.>), addTrailingPathSeparator ) - + ( addTrailingPathSeparator + , (<.>) + , () + ) -- | Entry point for the 'cabal get' command. -get :: Verbosity - -> RepoContext - -> GlobalFlags - -> GetFlags - -> [UserTarget] - -> IO () +get + :: Verbosity + -> RepoContext + -> GlobalFlags + -> GetFlags + -> [UserTarget] + -> IO () get verbosity _ _ _ [] = - notice verbosity "No packages requested. Nothing to do." - + notice verbosity "No packages requested. Nothing to do." get verbosity repoCtxt _ getFlags userTargets = do let useSourceRepo = case getSourceRepository getFlags of - NoFlag -> False - _ -> True + NoFlag -> False + _ -> True unless useSourceRepo $ traverse_ (checkTarget verbosity) userTargets @@ -86,13 +114,17 @@ get verbosity repoCtxt _ getFlags userTargets = do (sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState activeRepos - pkgSpecifiers <- resolveUserTargets verbosity repoCtxt - (packageIndex sourcePkgDb) - userTargets + pkgSpecifiers <- + resolveUserTargets + verbosity + repoCtxt + (packageIndex sourcePkgDb) + userTargets - pkgs <- either (die' verbosity . unlines . map show) return $ - resolveWithoutDependencies - (resolverParams sourcePkgDb pkgSpecifiers) + pkgs <- + either (die' verbosity . unlines . map show) return $ + resolveWithoutDependencies + (resolverParams sourcePkgDb pkgSpecifiers) unless (null prefix) $ createDirectoryIfMissing True prefix @@ -108,12 +140,11 @@ get verbosity repoCtxt _ getFlags userTargets = do if useSourceRepo then clone pkgs else unpack pkgs - where resolverParams :: SourcePackageDb -> [PackageSpecifier UnresolvedSourcePackage] -> DepResolverParams resolverParams sourcePkgDb pkgSpecifiers = - --TODO: add command-line constraint and preference args for unpack - standardInstallPolicy mempty sourcePkgDb pkgSpecifiers + -- TODO: add command-line constraint and preference args for unpack + standardInstallPolicy mempty sourcePkgDb pkgSpecifiers onlyPkgDescr = fromFlagOrDefault False (getOnlyPkgDescr getFlags) @@ -121,37 +152,37 @@ get verbosity repoCtxt _ getFlags userTargets = do prefix = fromFlagOrDefault "" (getDestDir getFlags) clone :: [UnresolvedSourcePackage] -> IO () - clone = clonePackagesFromSourceRepo verbosity prefix kind - . map (\pkg -> (packageId pkg, packageSourceRepos pkg)) + clone = + clonePackagesFromSourceRepo verbosity prefix kind + . map (\pkg -> (packageId pkg, packageSourceRepos pkg)) where kind :: Maybe RepoKind kind = fromFlag . getSourceRepository $ getFlags packageSourceRepos :: SourcePackage loc -> [PD.SourceRepo] - packageSourceRepos = PD.sourceRepos - . PD.packageDescription - . srcpkgDescription + packageSourceRepos = + PD.sourceRepos + . PD.packageDescription + . srcpkgDescription unpack :: [UnresolvedSourcePackage] -> IO () unpack pkgs = do for_ pkgs $ \pkg -> do location <- fetchPackage verbosity repoCtxt (srcpkgSource pkg) let pkgid = packageId pkg - descOverride | usePristine = Nothing - | otherwise = srcpkgDescrOverride pkg + descOverride + | usePristine = Nothing + | otherwise = srcpkgDescrOverride pkg case location of LocalTarballPackage tarballPath -> unpackPackage verbosity prefix pkgid descOverride tarballPath - RemoteTarballPackage _tarballURL tarballPath -> unpackPackage verbosity prefix pkgid descOverride tarballPath - RepoTarballPackage _repo _pkgid tarballPath -> unpackPackage verbosity prefix pkgid descOverride tarballPath - RemoteSourceRepoPackage _repo _ -> - die' verbosity $ "The 'get' command does no yet support targets " - ++ "that are remote source repositories." - + die' verbosity $ + "The 'get' command does no yet support targets " + ++ "that are remote source repositories." LocalUnpackedPackage _ -> error "Distribution.Client.Get.unpack: the impossible happened." where @@ -160,178 +191,218 @@ get verbosity repoCtxt _ getFlags userTargets = do checkTarget :: Verbosity -> UserTarget -> IO () checkTarget verbosity target = case target of - UserTargetLocalDir dir -> die' verbosity (notTarball dir) - UserTargetLocalCabalFile file -> die' verbosity (notTarball file) - _ -> return () + UserTargetLocalDir dir -> die' verbosity (notTarball dir) + UserTargetLocalCabalFile file -> die' verbosity (notTarball file) + _ -> return () where notTarball t = - "The 'get' command is for tarball packages. " - ++ "The target '" ++ t ++ "' is not a tarball." + "The 'get' command is for tarball packages. " + ++ "The target '" + ++ t + ++ "' is not a tarball." -- ------------------------------------------------------------ + -- * Unpacking the source tarball + -- ------------------------------------------------------------ -unpackPackage :: Verbosity -> FilePath -> PackageId - -> PackageDescriptionOverride - -> FilePath -> IO () +unpackPackage + :: Verbosity + -> FilePath + -> PackageId + -> PackageDescriptionOverride + -> FilePath + -> IO () unpackPackage verbosity prefix pkgid descOverride pkgPath = do - let pkgdirname = prettyShow pkgid - pkgdir = prefix pkgdirname - pkgdir' = addTrailingPathSeparator pkgdir - emptyDirectory directory = null <$> listDirectory directory - existsDir <- doesDirectoryExist pkgdir - when existsDir $ do - isEmpty <- emptyDirectory pkgdir - unless isEmpty $ - die' verbosity $ + let pkgdirname = prettyShow pkgid + pkgdir = prefix pkgdirname + pkgdir' = addTrailingPathSeparator pkgdir + emptyDirectory directory = null <$> listDirectory directory + existsDir <- doesDirectoryExist pkgdir + when existsDir $ do + isEmpty <- emptyDirectory pkgdir + unless isEmpty $ + die' verbosity $ "The directory \"" ++ pkgdir' ++ "\" already exists and is not empty, not unpacking." - existsFile <- doesFileExist pkgdir - when existsFile $ die' verbosity $ - "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking." - notice verbosity $ "Unpacking to " ++ pkgdir' - Tar.extractTarGzFile prefix pkgdirname pkgPath - - case descOverride of - Nothing -> return () - Just pkgtxt -> do - let descFilePath = pkgdir prettyShow (packageName pkgid) <.> "cabal" - info verbosity $ - "Updating " ++ descFilePath - ++ " with the latest revision from the index." - writeFileAtomic descFilePath pkgtxt - + existsFile <- doesFileExist pkgdir + when existsFile $ + die' verbosity $ + "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking." + notice verbosity $ "Unpacking to " ++ pkgdir' + Tar.extractTarGzFile prefix pkgdirname pkgPath + + case descOverride of + Nothing -> return () + Just pkgtxt -> do + let descFilePath = pkgdir prettyShow (packageName pkgid) <.> "cabal" + info verbosity $ + "Updating " + ++ descFilePath + ++ " with the latest revision from the index." + writeFileAtomic descFilePath pkgtxt -- | Write a @pkgId.cabal@ file with the package description to the destination -- directory, unless one already exists. unpackOnlyPkgDescr :: Verbosity -> FilePath -> UnresolvedSourcePackage -> IO () unpackOnlyPkgDescr verbosity dstDir pkg = do - let pkgFile = dstDir prettyShow (packageId pkg) <.> "cabal" - existsFile <- doesFileExist pkgFile - when existsFile $ die' verbosity $ + let pkgFile = dstDir prettyShow (packageId pkg) <.> "cabal" + existsFile <- doesFileExist pkgFile + when existsFile $ + die' verbosity $ "The file \"" ++ pkgFile ++ "\" already exists, not overwriting." - existsDir <- doesDirectoryExist (addTrailingPathSeparator pkgFile) - when existsDir $ die' verbosity $ + existsDir <- doesDirectoryExist (addTrailingPathSeparator pkgFile) + when existsDir $ + die' verbosity $ "A directory \"" ++ pkgFile ++ "\" is in the way, not unpacking." - notice verbosity $ "Writing package description to " ++ pkgFile - case srcpkgDescrOverride pkg of - Just pkgTxt -> writeFileAtomic pkgFile pkgTxt - Nothing -> - writeGenericPackageDescription pkgFile (srcpkgDescription pkg) + notice verbosity $ "Writing package description to " ++ pkgFile + case srcpkgDescrOverride pkg of + Just pkgTxt -> writeFileAtomic pkgFile pkgTxt + Nothing -> + writeGenericPackageDescription pkgFile (srcpkgDescription pkg) -- ------------------------------------------------------------ + -- * Cloning packages from their declared source repositories --- ------------------------------------------------------------ +-- ------------------------------------------------------------ -data ClonePackageException = - ClonePackageNoSourceRepos PackageId - | ClonePackageNoSourceReposOfKind PackageId (Maybe RepoKind) - | ClonePackageNoRepoType PackageId PD.SourceRepo - | ClonePackageUnsupportedRepoType PackageId SourceRepoProxy RepoType - | ClonePackageNoRepoLocation PackageId PD.SourceRepo - | ClonePackageDestinationExists PackageId FilePath Bool - | ClonePackageFailedWithExitCode PackageId SourceRepoProxy String ExitCode +data ClonePackageException + = ClonePackageNoSourceRepos PackageId + | ClonePackageNoSourceReposOfKind PackageId (Maybe RepoKind) + | ClonePackageNoRepoType PackageId PD.SourceRepo + | ClonePackageUnsupportedRepoType PackageId SourceRepoProxy RepoType + | ClonePackageNoRepoLocation PackageId PD.SourceRepo + | ClonePackageDestinationExists PackageId FilePath Bool + | ClonePackageFailedWithExitCode PackageId SourceRepoProxy String ExitCode deriving (Show, Eq) instance Exception ClonePackageException where displayException (ClonePackageNoSourceRepos pkgid) = - "Cannot fetch a source repository for package " ++ prettyShow pkgid - ++ ". The package does not specify any source repositories." - + "Cannot fetch a source repository for package " + ++ prettyShow pkgid + ++ ". The package does not specify any source repositories." displayException (ClonePackageNoSourceReposOfKind pkgid repoKind) = - "Cannot fetch a source repository for package " ++ prettyShow pkgid - ++ ". The package does not specify a source repository of the requested " - ++ "kind" ++ maybe "." (\k -> " (kind " ++ prettyShow k ++ ").") repoKind - + "Cannot fetch a source repository for package " + ++ prettyShow pkgid + ++ ". The package does not specify a source repository of the requested " + ++ "kind" + ++ maybe "." (\k -> " (kind " ++ prettyShow k ++ ").") repoKind displayException (ClonePackageNoRepoType pkgid _repo) = - "Cannot fetch the source repository for package " ++ prettyShow pkgid - ++ ". The package's description specifies a source repository but does " - ++ "not specify the repository 'type' field (e.g. git, darcs or hg)." - + "Cannot fetch the source repository for package " + ++ prettyShow pkgid + ++ ". The package's description specifies a source repository but does " + ++ "not specify the repository 'type' field (e.g. git, darcs or hg)." displayException (ClonePackageUnsupportedRepoType pkgid _ repoType) = - "Cannot fetch the source repository for package " ++ prettyShow pkgid - ++ ". The repository type '" ++ prettyShow repoType - ++ "' is not yet supported." - + "Cannot fetch the source repository for package " + ++ prettyShow pkgid + ++ ". The repository type '" + ++ prettyShow repoType + ++ "' is not yet supported." displayException (ClonePackageNoRepoLocation pkgid _repo) = - "Cannot fetch the source repository for package " ++ prettyShow pkgid - ++ ". The package's description specifies a source repository but does " - ++ "not specify the repository 'location' field (i.e. the URL)." - + "Cannot fetch the source repository for package " + ++ prettyShow pkgid + ++ ". The package's description specifies a source repository but does " + ++ "not specify the repository 'location' field (i.e. the URL)." displayException (ClonePackageDestinationExists pkgid dest isdir) = - "Not fetching the source repository for package " ++ prettyShow pkgid ++ ". " - ++ if isdir then "The destination directory " ++ dest ++ " already exists." - else "A file " ++ dest ++ " is in the way." - - displayException (ClonePackageFailedWithExitCode - pkgid repo vcsprogname exitcode) = - "Failed to fetch the source repository for package " ++ prettyShow pkgid - ++ ", repository location " ++ srpLocation repo ++ " (" - ++ vcsprogname ++ " failed with " ++ show exitcode ++ ")." - + "Not fetching the source repository for package " + ++ prettyShow pkgid + ++ ". " + ++ if isdir + then "The destination directory " ++ dest ++ " already exists." + else "A file " ++ dest ++ " is in the way." + displayException + ( ClonePackageFailedWithExitCode + pkgid + repo + vcsprogname + exitcode + ) = + "Failed to fetch the source repository for package " + ++ prettyShow pkgid + ++ ", repository location " + ++ srpLocation repo + ++ " (" + ++ vcsprogname + ++ " failed with " + ++ show exitcode + ++ ")." -- | Given a bunch of package ids and their corresponding available -- 'SourceRepo's, pick a single 'SourceRepo' for each one and clone into -- new subdirs of the given directory. --- -clonePackagesFromSourceRepo :: Verbosity - -> FilePath -- ^ destination dir prefix - -> Maybe RepoKind -- ^ preferred 'RepoKind' - -> [(PackageId, [PD.SourceRepo])] - -- ^ the packages and their - -- available 'SourceRepo's - -> IO () -clonePackagesFromSourceRepo verbosity destDirPrefix - preferredRepoKind pkgrepos = do - +clonePackagesFromSourceRepo + :: Verbosity + -> FilePath + -- ^ destination dir prefix + -> Maybe RepoKind + -- ^ preferred 'RepoKind' + -> [(PackageId, [PD.SourceRepo])] + -- ^ the packages and their + -- available 'SourceRepo's + -> IO () +clonePackagesFromSourceRepo + verbosity + destDirPrefix + preferredRepoKind + pkgrepos = do -- Do a bunch of checks and collect the required info pkgrepos' <- traverse preCloneChecks pkgrepos -- Configure the VCS drivers for all the repository types we may need - vcss <- configureVCSs verbosity $ - Map.fromList [ (vcsRepoType vcs, vcs) - | (_, _, vcs, _) <- pkgrepos' ] + vcss <- + configureVCSs verbosity $ + Map.fromList + [ (vcsRepoType vcs, vcs) + | (_, _, vcs, _) <- pkgrepos' + ] -- Now execute all the required commands for each repo sequence_ [ cloneSourceRepo verbosity vcs' repo destDir - `catch` \exitcode -> - throwIO (ClonePackageFailedWithExitCode - pkgid (srpToProxy repo) (programName (vcsProgram vcs)) exitcode) + `catch` \exitcode -> + throwIO + ( ClonePackageFailedWithExitCode + pkgid + (srpToProxy repo) + (programName (vcsProgram vcs)) + exitcode + ) | (pkgid, repo, vcs, destDir) <- pkgrepos' , let vcs' = Map.findWithDefault (error $ "Cannot configure " ++ prettyShow (vcsRepoType vcs)) (vcsRepoType vcs) vcss ] - - where - preCloneChecks :: (PackageId, [PD.SourceRepo]) - -> IO (PackageId, SourceRepositoryPackage Maybe, VCS Program, FilePath) - preCloneChecks (pkgid, repos) = do - repo <- case selectPackageSourceRepo preferredRepoKind repos of - Just repo -> return repo - Nothing | null repos -> throwIO (ClonePackageNoSourceRepos pkgid) - Nothing -> throwIO (ClonePackageNoSourceReposOfKind - pkgid preferredRepoKind) - - (repo', vcs) <- case validatePDSourceRepo repo of - Right (repo', _, _, vcs) -> return (repo', vcs) - Left SourceRepoRepoTypeUnspecified -> - throwIO (ClonePackageNoRepoType pkgid repo) - - Left (SourceRepoRepoTypeUnsupported repo' repoType) -> - throwIO (ClonePackageUnsupportedRepoType pkgid repo' repoType) - - Left SourceRepoLocationUnspecified -> - throwIO (ClonePackageNoRepoLocation pkgid repo) - - let destDir :: FilePath - destDir = destDirPrefix prettyShow (packageName pkgid) - destDirExists <- doesDirectoryExist destDir - destFileExists <- doesFileExist destDir - when (destDirExists || destFileExists) $ - throwIO (ClonePackageDestinationExists pkgid destDir destDirExists) - - return (pkgid, repo', vcs, destDir) + where + preCloneChecks + :: (PackageId, [PD.SourceRepo]) + -> IO (PackageId, SourceRepositoryPackage Maybe, VCS Program, FilePath) + preCloneChecks (pkgid, repos) = do + repo <- case selectPackageSourceRepo preferredRepoKind repos of + Just repo -> return repo + Nothing | null repos -> throwIO (ClonePackageNoSourceRepos pkgid) + Nothing -> + throwIO + ( ClonePackageNoSourceReposOfKind + pkgid + preferredRepoKind + ) + + (repo', vcs) <- case validatePDSourceRepo repo of + Right (repo', _, _, vcs) -> return (repo', vcs) + Left SourceRepoRepoTypeUnspecified -> + throwIO (ClonePackageNoRepoType pkgid repo) + Left (SourceRepoRepoTypeUnsupported repo' repoType) -> + throwIO (ClonePackageUnsupportedRepoType pkgid repo' repoType) + Left SourceRepoLocationUnspecified -> + throwIO (ClonePackageNoRepoLocation pkgid repo) + + let destDir :: FilePath + destDir = destDirPrefix prettyShow (packageName pkgid) + destDirExists <- doesDirectoryExist destDir + destFileExists <- doesFileExist destDir + when (destDirExists || destFileExists) $ + throwIO (ClonePackageDestinationExists pkgid destDir destDirExists) + + return (pkgid, repo', vcs, destDir) ------------------------------------------------------------------------------- -- Selecting @@ -342,26 +413,26 @@ clonePackagesFromSourceRepo verbosity destDirPrefix -- Note that this does /not/ depend on what 'VCS' drivers we are able to -- successfully configure. It is based only on the 'SourceRepo's declared -- in the package, and optionally on a preferred 'RepoKind'. --- -selectPackageSourceRepo :: Maybe RepoKind - -> [PD.SourceRepo] - -> Maybe PD.SourceRepo +selectPackageSourceRepo + :: Maybe RepoKind + -> [PD.SourceRepo] + -> Maybe PD.SourceRepo selectPackageSourceRepo preferredRepoKind = - listToMaybe + listToMaybe -- Sort repositories by kind, from This to Head to Unknown. Repositories -- with equivalent kinds are selected based on the order they appear in -- the Cabal description file. - . sortBy (comparing thisFirst) + . sortBy (comparing thisFirst) -- If the user has specified the repo kind, filter out the repositories -- they're not interested in. - . filter (\repo -> maybe True (PD.repoKind repo ==) preferredRepoKind) + . filter (\repo -> maybe True (PD.repoKind repo ==) preferredRepoKind) where thisFirst :: PD.SourceRepo -> Int thisFirst r = case PD.repoKind r of - RepoThis -> 0 - RepoHead -> case PD.repoTag r of - -- If the type is 'head' but the author specified a tag, they - -- probably meant to create a 'this' repository but screwed up. - Just _ -> 0 - Nothing -> 1 - RepoKindUnknown _ -> 2 + RepoThis -> 0 + RepoHead -> case PD.repoTag r of + -- If the type is 'head' but the author specified a tag, they + -- probably meant to create a 'this' repository but screwed up. + Just _ -> 0 + Nothing -> 1 + RepoKindUnknown _ -> 2 diff --git a/cabal-install/src/Distribution/Client/Glob.hs b/cabal-install/src/Distribution/Client/Glob.hs index 5d3d501fbdb..66baadf7a5d 100644 --- a/cabal-install/src/Distribution/Client/Glob.hs +++ b/cabal-install/src/Distribution/Client/Glob.hs @@ -1,55 +1,56 @@ {-# LANGUAGE DeriveGeneric #-} ---TODO: [code cleanup] plausibly much of this module should be merged with +-- TODO: [code cleanup] plausibly much of this module should be merged with -- similar functionality in Cabal. module Distribution.Client.Glob - ( FilePathGlob(..) - , FilePathRoot(..) - , FilePathGlobRel(..) - , Glob - , GlobPiece(..) - , matchFileGlob - , matchFileGlobRel - , matchGlob - , isTrivialFilePathGlob - , getFilePathRootDirectory - ) where + ( FilePathGlob (..) + , FilePathRoot (..) + , FilePathGlobRel (..) + , Glob + , GlobPiece (..) + , matchFileGlob + , matchFileGlobRel + , matchGlob + , isTrivialFilePathGlob + , getFilePathRootDirectory + ) where import Distribution.Client.Compat.Prelude import Prelude () -import Data.List (stripPrefix) +import Data.List (stripPrefix) import System.Directory import System.FilePath import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - +import qualified Text.PrettyPrint as Disp -- | A file path specified by globbing --- data FilePathGlob = FilePathGlob FilePathRoot FilePathGlobRel deriving (Eq, Show, Generic) data FilePathGlobRel - = GlobDir !Glob !FilePathGlobRel - | GlobFile !Glob - | GlobDirTrailing -- ^ trailing dir, a glob ending in @/@ + = GlobDir !Glob !FilePathGlobRel + | GlobFile !Glob + | -- | trailing dir, a glob ending in @/@ + GlobDirTrailing deriving (Eq, Show, Generic) -- | A single directory or file component of a globbed path type Glob = [GlobPiece] -- | A piece of a globbing pattern -data GlobPiece = WildCard - | Literal String - | Union [Glob] +data GlobPiece + = WildCard + | Literal String + | Union [Glob] deriving (Eq, Show, Generic) data FilePathRoot - = FilePathRelative - | FilePathRoot FilePath -- ^ e.g. @"/"@, @"c:\"@ or result of 'takeDrive' - | FilePathHomeDir + = FilePathRelative + | -- | e.g. @"/"@, @"c:\"@ or result of 'takeDrive' + FilePathRoot FilePath + | FilePathHomeDir deriving (Eq, Show, Generic) instance Binary FilePathGlob @@ -68,32 +69,34 @@ instance Structured GlobPiece -- If it is trivial in this sense then the result is the equivalent constant -- 'FilePath'. On the other hand if it is not trivial (so could in principle -- match more than one file) then the result is @Nothing@. --- isTrivialFilePathGlob :: FilePathGlob -> Maybe FilePath isTrivialFilePathGlob (FilePathGlob root pathglob) = - case root of - FilePathRelative -> go [] pathglob - FilePathRoot root' -> go [root'] pathglob - FilePathHomeDir -> Nothing + case root of + FilePathRelative -> go [] pathglob + FilePathRoot root' -> go [root'] pathglob + FilePathHomeDir -> Nothing where - go paths (GlobDir [Literal path] globs) = go (path:paths) globs - go paths (GlobFile [Literal path]) = Just (joinPath (reverse (path:paths))) - go paths GlobDirTrailing = Just (addTrailingPathSeparator - (joinPath (reverse paths))) + go paths (GlobDir [Literal path] globs) = go (path : paths) globs + go paths (GlobFile [Literal path]) = Just (joinPath (reverse (path : paths))) + go paths GlobDirTrailing = + Just + ( addTrailingPathSeparator + (joinPath (reverse paths)) + ) go _ _ = Nothing -- | Get the 'FilePath' corresponding to a 'FilePathRoot'. -- -- The 'FilePath' argument is required to supply the path for the -- 'FilePathRelative' case. --- -getFilePathRootDirectory :: FilePathRoot - -> FilePath -- ^ root for relative paths - -> IO FilePath -getFilePathRootDirectory FilePathRelative root = return root -getFilePathRootDirectory (FilePathRoot root) _ = return root -getFilePathRootDirectory FilePathHomeDir _ = getHomeDirectory - +getFilePathRootDirectory + :: FilePathRoot + -> FilePath + -- ^ root for relative paths + -> IO FilePath +getFilePathRootDirectory FilePathRelative root = return root +getFilePathRootDirectory (FilePathRoot root) _ = return root +getFilePathRootDirectory FilePathHomeDir _ = getHomeDirectory ------------------------------------------------------------------------------ -- Matching @@ -102,18 +105,16 @@ getFilePathRootDirectory FilePathHomeDir _ = getHomeDirectory -- | Match a 'FilePathGlob' against the file system, starting from a given -- root directory for relative paths. The results of relative globs are -- relative to the given root. Matches for absolute globs are absolute. --- matchFileGlob :: FilePath -> FilePathGlob -> IO [FilePath] matchFileGlob relroot (FilePathGlob globroot glob) = do - root <- getFilePathRootDirectory globroot relroot - matches <- matchFileGlobRel root glob - case globroot of - FilePathRelative -> return matches - _ -> return (map (root ) matches) + root <- getFilePathRootDirectory globroot relroot + matches <- matchFileGlobRel root glob + case globroot of + FilePathRelative -> return matches + _ -> return (map (root ) matches) -- | Match a 'FilePathGlobRel' against the file system, starting from a -- given root directory. The results are all relative to the given root. --- matchFileGlobRel :: FilePath -> FilePathGlobRel -> IO [FilePath] matchFileGlobRel root glob0 = go glob0 "" where @@ -121,19 +122,19 @@ matchFileGlobRel root glob0 = go glob0 "" entries <- getDirectoryContents (root dir) let files = filter (matchGlob glob) entries return (map (dir ) files) - go (GlobDir glob globPath) dir = do entries <- getDirectoryContents (root dir) - subdirs <- filterM (\subdir -> doesDirectoryExist - (root dir subdir)) - $ filter (matchGlob glob) entries + subdirs <- + filterM + ( \subdir -> + doesDirectoryExist + (root dir subdir) + ) + $ filter (matchGlob glob) entries concat <$> traverse (\subdir -> go globPath (dir subdir)) subdirs - go GlobDirTrailing dir = return [dir] - -- | Match a globbing pattern against a file path component --- matchGlob :: Glob -> String -> Bool matchGlob = goStart where @@ -143,22 +144,23 @@ matchGlob = goStart go, goStart :: [GlobPiece] -> String -> Bool - goStart (WildCard:_) ('.':_) = False - goStart (Union globs:rest) cs = any (\glob -> goStart (glob ++ rest) cs) - globs - goStart rest cs = go rest cs - - go [] "" = True - go (Literal lit:rest) cs - | Just cs' <- stripPrefix lit cs - = go rest cs' - | otherwise = False - go [WildCard] "" = True - go (WildCard:rest) (c:cs) = go rest (c:cs) || go (WildCard:rest) cs - go (Union globs:rest) cs = any (\glob -> go (glob ++ rest) cs) globs - go [] (_:_) = False - go (_:_) "" = False - + goStart (WildCard : _) ('.' : _) = False + goStart (Union globs : rest) cs = + any + (\glob -> goStart (glob ++ rest) cs) + globs + goStart rest cs = go rest cs + + go [] "" = True + go (Literal lit : rest) cs + | Just cs' <- stripPrefix lit cs = + go rest cs' + | otherwise = False + go [WildCard] "" = True + go (WildCard : rest) (c : cs) = go rest (c : cs) || go (WildCard : rest) cs + go (Union globs : rest) cs = any (\glob -> go (glob ++ rest) cs) globs + go [] (_ : _) = False + go (_ : _) "" = False ------------------------------------------------------------------------------ -- Parsing & printing @@ -168,77 +170,89 @@ instance Pretty FilePathGlob where pretty (FilePathGlob root pathglob) = pretty root Disp.<> pretty pathglob instance Parsec FilePathGlob where - parsec = do - root <- parsec - case root of - FilePathRelative -> FilePathGlob root <$> parsec - _ -> FilePathGlob root <$> parsec <|> pure (FilePathGlob root GlobDirTrailing) + parsec = do + root <- parsec + case root of + FilePathRelative -> FilePathGlob root <$> parsec + _ -> FilePathGlob root <$> parsec <|> pure (FilePathGlob root GlobDirTrailing) instance Pretty FilePathRoot where - pretty FilePathRelative = Disp.empty - pretty (FilePathRoot root) = Disp.text root - pretty FilePathHomeDir = Disp.char '~' Disp.<> Disp.char '/' + 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 : ":\\")) + 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 : ":\\")) instance Pretty FilePathGlobRel where - pretty (GlobDir glob pathglob) = dispGlob glob - Disp.<> Disp.char '/' - Disp.<> pretty pathglob - pretty (GlobFile glob) = dispGlob glob - pretty GlobDirTrailing = Disp.empty + pretty (GlobDir glob pathglob) = + dispGlob glob + Disp.<> Disp.char '/' + Disp.<> pretty pathglob + pretty (GlobFile glob) = dispGlob glob + pretty GlobDirTrailing = Disp.empty instance Parsec FilePathGlobRel where - parsec = parsecPath where - parsecPath :: CabalParsing m => m FilePathGlobRel - parsecPath = do - glob <- parsecGlob - dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob) - - dirSep :: CabalParsing m => m () - dirSep = () <$ P.char '/' <|> P.try (do - _ <- P.char '\\' - -- check this isn't an escape code - P.notFollowedBy (P.satisfy isGlobEscapedChar)) + parsec = parsecPath + where + parsecPath :: CabalParsing m => m FilePathGlobRel + parsecPath = do + glob <- parsecGlob + dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob) + + dirSep :: CabalParsing m => m () + dirSep = + () <$ P.char '/' + <|> P.try + ( do + _ <- P.char '\\' + -- check this isn't an escape code + P.notFollowedBy (P.satisfy isGlobEscapedChar) + ) dispGlob :: Glob -> Disp.Doc dispGlob = Disp.hcat . map dispPiece where - dispPiece WildCard = Disp.char '*' + dispPiece WildCard = Disp.char '*' dispPiece (Literal str) = Disp.text (escape str) - dispPiece (Union globs) = Disp.braces - (Disp.hcat (Disp.punctuate - (Disp.char ',') - (map dispGlob globs))) - escape [] = [] - escape (c:cs) + dispPiece (Union globs) = + Disp.braces + ( Disp.hcat + ( Disp.punctuate + (Disp.char ',') + (map dispGlob globs) + ) + ) + escape [] = [] + escape (c : cs) | isGlobEscapedChar c = '\\' : c : escape cs - | otherwise = c : escape cs + | otherwise = c : escape cs parsecGlob :: CabalParsing m => m Glob -parsecGlob = some parsecPiece where - parsecPiece = P.choice [ literal, wildcard, union ] +parsecGlob = some parsecPiece + where + parsecPiece = P.choice [literal, wildcard, union] wildcard = WildCard <$ P.char '*' - union = Union . toList <$> P.between (P.char '{') (P.char '}') (P.sepByNonEmpty parsecGlob (P.char ',')) - literal = Literal <$> some litchar + union = Union . toList <$> P.between (P.char '{') (P.char '}') (P.sepByNonEmpty parsecGlob (P.char ',')) + literal = Literal <$> some litchar litchar = normal <|> escape - normal = P.satisfy (\c -> not (isGlobEscapedChar c) && c /= '/' && c /= '\\') - escape = P.try $ P.char '\\' >> P.satisfy isGlobEscapedChar + normal = P.satisfy (\c -> not (isGlobEscapedChar c) && c /= '/' && c /= '\\') + escape = P.try $ P.char '\\' >> P.satisfy isGlobEscapedChar isGlobEscapedChar :: Char -> Bool -isGlobEscapedChar '*' = True -isGlobEscapedChar '{' = True -isGlobEscapedChar '}' = True -isGlobEscapedChar ',' = True -isGlobEscapedChar _ = False +isGlobEscapedChar '*' = True +isGlobEscapedChar '{' = True +isGlobEscapedChar '}' = True +isGlobEscapedChar ',' = True +isGlobEscapedChar _ = False diff --git a/cabal-install/src/Distribution/Client/GlobalFlags.hs b/cabal-install/src/Distribution/Client/GlobalFlags.hs index d21b071479a..6b41a79b5ef 100644 --- a/cabal-install/src/Distribution/Client/GlobalFlags.hs +++ b/cabal-install/src/Distribution/Client/GlobalFlags.hs @@ -2,132 +2,161 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Client.GlobalFlags ( - GlobalFlags(..) +module Distribution.Client.GlobalFlags + ( GlobalFlags (..) , defaultGlobalFlags - , RepoContext(..) + , RepoContext (..) , withRepoContext , withRepoContext' ) where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () +import Distribution.Client.HttpUtils + ( HttpTransport + , configureTransport + ) import Distribution.Client.Types - ( Repo(..), unRepoName, RemoteRepo(..), LocalRepo (..), localRepoCacheKey ) + ( LocalRepo (..) + , RemoteRepo (..) + , Repo (..) + , localRepoCacheKey + , unRepoName + ) import Distribution.Simple.Setup - ( Flag(..), fromFlag, flagToMaybe ) -import Distribution.Utils.NubList - ( NubList, fromNubList ) -import Distribution.Client.HttpUtils - ( HttpTransport, configureTransport ) + ( Flag (..) + , flagToMaybe + , fromFlag + ) import Distribution.Simple.Utils - ( info, warn ) + ( info + , warn + ) +import Distribution.Utils.NubList + ( NubList + , fromNubList + ) import Distribution.Client.IndexUtils.ActiveRepos - ( ActiveRepos ) + ( ActiveRepos + ) import Control.Concurrent - ( MVar, newMVar, modifyMVar ) -import System.FilePath - ( () ) -import Network.URI - ( URI, uriScheme, uriPath ) + ( MVar + , modifyMVar + , newMVar + ) import qualified Data.Map as Map - -import qualified Hackage.Security.Client as Sec -import qualified Hackage.Security.Util.Path as Sec -import qualified Hackage.Security.Util.Pretty as Sec -import qualified Hackage.Security.Client.Repository.Cache as Sec -import qualified Hackage.Security.Client.Repository.Local as Sec.Local -import qualified Hackage.Security.Client.Repository.Remote as Sec.Remote -import qualified Distribution.Client.Security.HTTP as Sec.HTTP -import qualified Distribution.Client.Security.DNS as Sec.DNS +import Network.URI + ( URI + , uriPath + , uriScheme + ) +import System.FilePath + ( () + ) + +import qualified Distribution.Client.Security.DNS as Sec.DNS +import qualified Distribution.Client.Security.HTTP as Sec.HTTP +import qualified Hackage.Security.Client as Sec +import qualified Hackage.Security.Client.Repository.Cache as Sec +import qualified Hackage.Security.Client.Repository.Local as Sec.Local +import qualified Hackage.Security.Client.Repository.Remote as Sec.Remote +import qualified Hackage.Security.Util.Path as Sec +import qualified Hackage.Security.Util.Pretty as Sec import qualified System.FilePath.Posix as FilePath.Posix -- ------------------------------------------------------------ + -- * Global flags + -- ------------------------------------------------------------ -- | Flags that apply at the top level, not to any sub-command. - data GlobalFlags = GlobalFlags - { globalVersion :: Flag Bool - , globalNumericVersion :: Flag Bool - , globalConfigFile :: Flag FilePath - , globalConstraintsFile :: Flag FilePath - , globalRemoteRepos :: NubList RemoteRepo -- ^ Available Hackage servers. - , globalCacheDir :: Flag FilePath - , globalLocalNoIndexRepos :: NubList LocalRepo - , globalActiveRepos :: Flag ActiveRepos - , globalLogsDir :: Flag FilePath - , globalIgnoreExpiry :: Flag Bool -- ^ Ignore security expiry dates - , globalHttpTransport :: Flag String - , globalNix :: Flag Bool -- ^ Integrate with Nix - , globalStoreDir :: Flag FilePath - , globalProgPathExtra :: NubList FilePath -- ^ Extra program path used for packagedb lookups in a global context (i.e. for http transports) - } deriving (Show, Generic) + { globalVersion :: Flag Bool + , globalNumericVersion :: Flag Bool + , globalConfigFile :: Flag FilePath + , globalConstraintsFile :: Flag FilePath + , globalRemoteRepos :: NubList RemoteRepo + -- ^ Available Hackage servers. + , globalCacheDir :: Flag FilePath + , globalLocalNoIndexRepos :: NubList LocalRepo + , globalActiveRepos :: Flag ActiveRepos + , globalLogsDir :: Flag FilePath + , globalIgnoreExpiry :: Flag Bool + -- ^ Ignore security expiry dates + , globalHttpTransport :: Flag String + , globalNix :: Flag Bool + -- ^ Integrate with Nix + , globalStoreDir :: Flag FilePath + , globalProgPathExtra :: NubList FilePath + -- ^ Extra program path used for packagedb lookups in a global context (i.e. for http transports) + } + deriving (Show, Generic) defaultGlobalFlags :: GlobalFlags -defaultGlobalFlags = GlobalFlags - { globalVersion = Flag False - , globalNumericVersion = Flag False - , globalConfigFile = mempty - , globalConstraintsFile = mempty - , globalRemoteRepos = mempty - , globalCacheDir = mempty +defaultGlobalFlags = + GlobalFlags + { globalVersion = Flag False + , globalNumericVersion = Flag False + , globalConfigFile = mempty + , globalConstraintsFile = mempty + , globalRemoteRepos = mempty + , globalCacheDir = mempty , globalLocalNoIndexRepos = mempty - , globalActiveRepos = mempty - , globalLogsDir = mempty - , globalIgnoreExpiry = Flag False - , globalHttpTransport = mempty - , globalNix = Flag False - , globalStoreDir = mempty - , globalProgPathExtra = mempty + , globalActiveRepos = mempty + , globalLogsDir = mempty + , globalIgnoreExpiry = Flag False + , globalHttpTransport = mempty + , globalNix = Flag False + , globalStoreDir = mempty + , globalProgPathExtra = mempty } instance Monoid GlobalFlags where - mempty = gmempty - mappend = (<>) + mempty = gmempty + mappend = (<>) instance Semigroup GlobalFlags where - (<>) = gmappend + (<>) = gmappend -- ------------------------------------------------------------ + -- * Repo context + -- ------------------------------------------------------------ -- | Access to repositories -data RepoContext = RepoContext { - -- | All user-specified repositories - repoContextRepos :: [Repo] - - -- | Get the HTTP transport - -- - -- The transport will be initialized on the first call to this function. - -- - -- NOTE: It is important that we don't eagerly initialize the transport. - -- Initializing the transport is not free, and especially in contexts where - -- we don't know a priori whether or not we need the transport (for instance - -- when using cabal in "nix mode") incurring the overhead of transport - -- initialization on _every_ invocation (eg @cabal build@) is undesirable. +data RepoContext = RepoContext + { repoContextRepos :: [Repo] + -- ^ All user-specified repositories , repoContextGetTransport :: IO HttpTransport - - -- | Get the (initialized) secure repo - -- - -- (the 'Repo' type itself is stateless and must remain so, because it - -- must be serializable) - , repoContextWithSecureRepo :: forall a. - Repo - -> (forall down. Sec.Repository down -> IO a) - -> IO a - - -- | Should we ignore expiry times (when checking security)? + -- ^ Get the HTTP transport + -- + -- The transport will be initialized on the first call to this function. + -- + -- NOTE: It is important that we don't eagerly initialize the transport. + -- Initializing the transport is not free, and especially in contexts where + -- we don't know a priori whether or not we need the transport (for instance + -- when using cabal in "nix mode") incurring the overhead of transport + -- initialization on _every_ invocation (eg @cabal build@) is undesirable. + , repoContextWithSecureRepo + :: forall a + . Repo + -> (forall down. Sec.Repository down -> IO a) + -> IO a + -- ^ Get the (initialized) secure repo + -- + -- (the 'Repo' type itself is stateless and must remain so, because it + -- must be serializable) , repoContextIgnoreExpiry :: Bool + -- ^ Should we ignore expiry times (when checking security)? } -- | Wrapper around 'Repository', hiding the type argument @@ -135,88 +164,107 @@ data SecureRepo = forall down. SecureRepo (Sec.Repository down) withRepoContext :: Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a withRepoContext verbosity globalFlags = - withRepoContext' - verbosity - (fromNubList (globalRemoteRepos globalFlags)) - (fromNubList (globalLocalNoIndexRepos globalFlags)) - (fromFlag (globalCacheDir globalFlags)) - (flagToMaybe (globalHttpTransport globalFlags)) - (flagToMaybe (globalIgnoreExpiry globalFlags)) - (fromNubList (globalProgPathExtra globalFlags)) - -withRepoContext' :: Verbosity -> [RemoteRepo] -> [LocalRepo] - -> FilePath -> Maybe String -> Maybe Bool - -> [FilePath] - -> (RepoContext -> IO a) - -> IO a -withRepoContext' verbosity remoteRepos localNoIndexRepos - sharedCacheDir httpTransport ignoreExpiry extraPaths = \callback -> do + withRepoContext' + verbosity + (fromNubList (globalRemoteRepos globalFlags)) + (fromNubList (globalLocalNoIndexRepos globalFlags)) + (fromFlag (globalCacheDir globalFlags)) + (flagToMaybe (globalHttpTransport globalFlags)) + (flagToMaybe (globalIgnoreExpiry globalFlags)) + (fromNubList (globalProgPathExtra globalFlags)) + +withRepoContext' + :: Verbosity + -> [RemoteRepo] + -> [LocalRepo] + -> FilePath + -> Maybe String + -> Maybe Bool + -> [FilePath] + -> (RepoContext -> IO a) + -> IO a +withRepoContext' + verbosity + remoteRepos + localNoIndexRepos + sharedCacheDir + httpTransport + ignoreExpiry + extraPaths = \callback -> do for_ localNoIndexRepos $ \local -> - unless (FilePath.Posix.isAbsolute (localRepoPath local)) $ - warn verbosity $ "file+noindex " ++ unRepoName (localRepoName local) ++ " repository path is not absolute; this is fragile, and not recommended" + unless (FilePath.Posix.isAbsolute (localRepoPath local)) $ + warn verbosity $ + "file+noindex " ++ unRepoName (localRepoName local) ++ " repository path is not absolute; this is fragile, and not recommended" transportRef <- newMVar Nothing - let httpLib = Sec.HTTP.transportAdapter - verbosity - (getTransport transportRef) + let httpLib = + Sec.HTTP.transportAdapter + verbosity + (getTransport transportRef) initSecureRepos verbosity httpLib secureRemoteRepos $ \secureRepos' -> - callback RepoContext { - repoContextRepos = allRemoteRepos - ++ allLocalNoIndexRepos - , repoContextGetTransport = getTransport transportRef - , repoContextWithSecureRepo = withSecureRepo secureRepos' - , repoContextIgnoreExpiry = fromMaybe False ignoreExpiry - } - where - secureRemoteRepos = - [ (remote, cacheDir) | RepoSecure remote cacheDir <- allRemoteRepos ] - - allRemoteRepos :: [Repo] - allRemoteRepos = - [ (if isSecure then RepoSecure else RepoRemote) remote cacheDir - | remote <- remoteRepos - , let cacheDir = sharedCacheDir unRepoName (remoteRepoName remote) - isSecure = remoteRepoSecure remote == Just True - ] - - allLocalNoIndexRepos :: [Repo] - allLocalNoIndexRepos = - [ RepoLocalNoIndex local cacheDir - | local <- localNoIndexRepos - , let cacheDir | localRepoSharedCache local = sharedCacheDir localRepoCacheKey local - | otherwise = localRepoPath local - ] - - getTransport :: MVar (Maybe HttpTransport) -> IO HttpTransport - getTransport transportRef = - modifyMVar transportRef $ \mTransport -> do - transport <- case mTransport of - Just tr -> return tr - Nothing -> configureTransport verbosity extraPaths httpTransport - return (Just transport, transport) - - withSecureRepo :: Map Repo SecureRepo - -> Repo - -> (forall down. Sec.Repository down -> IO a) - -> IO a - withSecureRepo secureRepos repo callback = - case Map.lookup repo secureRepos of - Just (SecureRepo secureRepo) -> callback secureRepo - Nothing -> throwIO $ userError "repoContextWithSecureRepo: unknown repo" + callback + RepoContext + { repoContextRepos = + allRemoteRepos + ++ allLocalNoIndexRepos + , repoContextGetTransport = getTransport transportRef + , repoContextWithSecureRepo = withSecureRepo secureRepos' + , repoContextIgnoreExpiry = fromMaybe False ignoreExpiry + } + where + secureRemoteRepos = + [(remote, cacheDir) | RepoSecure remote cacheDir <- allRemoteRepos] + + allRemoteRepos :: [Repo] + allRemoteRepos = + [ (if isSecure then RepoSecure else RepoRemote) remote cacheDir + | remote <- remoteRepos + , let cacheDir = sharedCacheDir unRepoName (remoteRepoName remote) + isSecure = remoteRepoSecure remote == Just True + ] + + allLocalNoIndexRepos :: [Repo] + allLocalNoIndexRepos = + [ RepoLocalNoIndex local cacheDir + | local <- localNoIndexRepos + , let cacheDir + | localRepoSharedCache local = sharedCacheDir localRepoCacheKey local + | otherwise = localRepoPath local + ] + + getTransport :: MVar (Maybe HttpTransport) -> IO HttpTransport + getTransport transportRef = + modifyMVar transportRef $ \mTransport -> do + transport <- case mTransport of + Just tr -> return tr + Nothing -> configureTransport verbosity extraPaths httpTransport + return (Just transport, transport) + + withSecureRepo + :: Map Repo SecureRepo + -> Repo + -> (forall down. Sec.Repository down -> IO a) + -> IO a + withSecureRepo secureRepos repo callback = + case Map.lookup repo secureRepos of + Just (SecureRepo secureRepo) -> callback secureRepo + Nothing -> throwIO $ userError "repoContextWithSecureRepo: unknown repo" -- | Initialize the provided secure repositories -- -- Assumed invariant: `remoteRepoSecure` should be set for all these repos. -initSecureRepos :: forall a. Verbosity - -> Sec.HTTP.HttpLib - -> [(RemoteRepo, FilePath)] - -> (Map Repo SecureRepo -> IO a) - -> IO a +initSecureRepos + :: forall a + . Verbosity + -> Sec.HTTP.HttpLib + -> [(RemoteRepo, FilePath)] + -> (Map Repo SecureRepo -> IO a) + -> IO a initSecureRepos verbosity httpLib repos callback = go Map.empty repos where go :: Map Repo SecureRepo -> [(RemoteRepo, FilePath)] -> IO a go !acc [] = callback acc - go !acc ((r,cacheDir):rs) = do + go !acc ((r, cacheDir) : rs) = do cachePath <- Sec.makeAbsolute $ Sec.fromFilePath cacheDir initSecureRepo verbosity httpLib r cachePath $ \r' -> go (Map.insert (RepoSecure r cacheDir) r' acc) rs @@ -227,61 +275,74 @@ initSecureRepos verbosity httpLib repos callback = go Map.empty repos -- from @cabal-install@'s; these are secure repositories, but live in the local -- file system. We use the convention that these repositories are identified by -- URLs of the form @file:/path/to/local/repo@. -initSecureRepo :: Verbosity - -> Sec.HTTP.HttpLib - -> RemoteRepo -- ^ Secure repo ('remoteRepoSecure' assumed) - -> Sec.Path Sec.Absolute -- ^ Cache dir - -> (SecureRepo -> IO a) -- ^ Callback - -> IO a +initSecureRepo + :: Verbosity + -> Sec.HTTP.HttpLib + -> RemoteRepo + -- ^ Secure repo ('remoteRepoSecure' assumed) + -> Sec.Path Sec.Absolute + -- ^ Cache dir + -> (SecureRepo -> IO a) + -- ^ Callback + -> IO a initSecureRepo verbosity httpLib RemoteRepo{..} cachePath = \callback -> do - requiresBootstrap <- withRepo [] Sec.requiresBootstrap - - mirrors <- if requiresBootstrap - then do - info verbosity $ "Trying to locate mirrors via DNS for " ++ - "initial bootstrap of secure " ++ - "repository '" ++ show remoteRepoURI ++ - "' ..." - - Sec.DNS.queryBootstrapMirrors verbosity remoteRepoURI - else pure [] - - withRepo mirrors $ \r -> do - when requiresBootstrap $ Sec.uncheckClientErrors $ - Sec.bootstrap r - (map Sec.KeyId remoteRepoRootKeys) + requiresBootstrap <- withRepo [] Sec.requiresBootstrap + + mirrors <- + if requiresBootstrap + then do + info verbosity $ + "Trying to locate mirrors via DNS for " + ++ "initial bootstrap of secure " + ++ "repository '" + ++ show remoteRepoURI + ++ "' ..." + + Sec.DNS.queryBootstrapMirrors verbosity remoteRepoURI + else pure [] + + withRepo mirrors $ \r -> do + when requiresBootstrap $ + Sec.uncheckClientErrors $ + Sec.bootstrap + r + (map Sec.KeyId remoteRepoRootKeys) (Sec.KeyThreshold (fromIntegral remoteRepoKeyThreshold)) - callback $ SecureRepo r + callback $ SecureRepo r where -- Initialize local or remote repo depending on the URI withRepo :: [URI] -> (forall down. Sec.Repository down -> IO a) -> IO a withRepo _ callback | uriScheme remoteRepoURI == "file:" = do dir <- Sec.makeAbsolute $ Sec.fromFilePath (uriPath remoteRepoURI) - Sec.Local.withRepository dir - cache - Sec.hackageRepoLayout - Sec.hackageIndexLayout - logTUF - callback + Sec.Local.withRepository + dir + cache + Sec.hackageRepoLayout + Sec.hackageIndexLayout + logTUF + callback withRepo mirrors callback = - Sec.Remote.withRepository httpLib - (remoteRepoURI:mirrors) - Sec.Remote.defaultRepoOpts - cache - Sec.hackageRepoLayout - Sec.hackageIndexLayout - logTUF - callback + Sec.Remote.withRepository + httpLib + (remoteRepoURI : mirrors) + Sec.Remote.defaultRepoOpts + cache + Sec.hackageRepoLayout + Sec.hackageIndexLayout + logTUF + callback cache :: Sec.Cache - cache = Sec.Cache { - cacheRoot = cachePath - , cacheLayout = Sec.cabalCacheLayout { - Sec.cacheLayoutIndexTar = cacheFn "01-index.tar" - , Sec.cacheLayoutIndexIdx = cacheFn "01-index.tar.idx" - , Sec.cacheLayoutIndexTarGz = cacheFn "01-index.tar.gz" - } - } + cache = + Sec.Cache + { cacheRoot = cachePath + , cacheLayout = + Sec.cabalCacheLayout + { Sec.cacheLayoutIndexTar = cacheFn "01-index.tar" + , Sec.cacheLayoutIndexIdx = cacheFn "01-index.tar.idx" + , Sec.cacheLayoutIndexTarGz = cacheFn "01-index.tar.gz" + } + } cacheFn :: FilePath -> Sec.CachePath cacheFn = Sec.rootPath . Sec.fragment diff --git a/cabal-install/src/Distribution/Client/Haddock.hs b/cabal-install/src/Distribution/Client/Haddock.hs index 862a1e6f85a..058b24f6537 100644 --- a/cabal-install/src/Distribution/Client/Haddock.hs +++ b/cabal-install/src/Distribution/Client/Haddock.hs @@ -1,4 +1,7 @@ ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.Haddock -- Copyright : (c) Andrea Vezzosi 2009 @@ -8,64 +11,80 @@ -- Portability : portable -- -- Interfacing with Haddock --- ------------------------------------------------------------------------------ module Distribution.Client.Haddock - ( - regenerateHaddockIndex - ) - where + ( regenerateHaddockIndex + ) +where import Distribution.Client.Compat.Prelude import Prelude () import Data.List (maximumBy) -import System.Directory (createDirectoryIfMissing, renameFile) -import System.FilePath ((), splitFileName) +import Distribution.InstalledPackageInfo as InstalledPackageInfo + ( InstalledPackageInfo (exposed) + ) import Distribution.Package - ( packageVersion ) + ( packageVersion + ) import Distribution.Simple.Haddock (haddockPackagePaths) -import Distribution.Simple.Program (haddockProgram, ProgramDb - , runProgram, requireProgramVersion) -import Distribution.Version (mkVersion, orLaterVersion) import Distribution.Simple.PackageIndex - ( InstalledPackageIndex, allPackagesByName ) + ( InstalledPackageIndex + , allPackagesByName + ) +import Distribution.Simple.Program + ( ProgramDb + , haddockProgram + , requireProgramVersion + , runProgram + ) import Distribution.Simple.Utils - ( debug, installDirectoryContents, withTempDirectory ) -import Distribution.InstalledPackageInfo as InstalledPackageInfo - ( InstalledPackageInfo(exposed) ) + ( debug + , installDirectoryContents + , withTempDirectory + ) +import Distribution.Version (mkVersion, orLaterVersion) +import System.Directory (createDirectoryIfMissing, renameFile) +import System.FilePath (splitFileName, ()) -regenerateHaddockIndex :: Verbosity - -> InstalledPackageIndex -> ProgramDb - -> FilePath - -> IO () +regenerateHaddockIndex + :: Verbosity + -> InstalledPackageIndex + -> ProgramDb + -> FilePath + -> IO () regenerateHaddockIndex verbosity pkgs progdb index = do - (paths, warns) <- haddockPackagePaths pkgs' Nothing - let paths' = [ (interface, html) | (interface, Just html, _, _) <- paths] - for_ warns (debug verbosity) - - (confHaddock, _, _) <- - requireProgramVersion verbosity haddockProgram - (orLaterVersion (mkVersion [0,6])) progdb - - createDirectoryIfMissing True destDir + (paths, warns) <- haddockPackagePaths pkgs' Nothing + let paths' = [(interface, html) | (interface, Just html, _, _) <- paths] + for_ warns (debug verbosity) - withTempDirectory verbosity destDir "tmphaddock" $ \tempDir -> do + (confHaddock, _, _) <- + requireProgramVersion + verbosity + haddockProgram + (orLaterVersion (mkVersion [0, 6])) + progdb - let flags = [ "--gen-contents" - , "--gen-index" - , "--odir=" ++ tempDir - , "--title=Haskell modules on this system" ] - ++ [ "--read-interface=" ++ html ++ "," ++ interface - | (interface, html) <- paths' ] - runProgram verbosity confHaddock flags - renameFile (tempDir "index.html") (tempDir destFile) - installDirectoryContents verbosity tempDir destDir + createDirectoryIfMissing True destDir + withTempDirectory verbosity destDir "tmphaddock" $ \tempDir -> do + let flags = + [ "--gen-contents" + , "--gen-index" + , "--odir=" ++ tempDir + , "--title=Haskell modules on this system" + ] + ++ [ "--read-interface=" ++ html ++ "," ++ interface + | (interface, html) <- paths' + ] + runProgram verbosity confHaddock flags + renameFile (tempDir "index.html") (tempDir destFile) + installDirectoryContents verbosity tempDir destDir where - (destDir,destFile) = splitFileName index + (destDir, destFile) = splitFileName index pkgs' :: [InstalledPackageInfo] - pkgs' = [ maximumBy (comparing packageVersion) pkgvers' - | (_pname, pkgvers) <- allPackagesByName pkgs - , let pkgvers' = filter exposed pkgvers - , not (null pkgvers') ] + pkgs' = + [ maximumBy (comparing packageVersion) pkgvers' + | (_pname, pkgvers) <- allPackagesByName pkgs + , let pkgvers' = filter exposed pkgvers + , not (null pkgvers') + ] diff --git a/cabal-install/src/Distribution/Client/HashValue.hs b/cabal-install/src/Distribution/Client/HashValue.hs index 67117b231cc..e19956b7ed3 100644 --- a/cabal-install/src/Distribution/Client/HashValue.hs +++ b/cabal-install/src/Distribution/Client/HashValue.hs @@ -1,26 +1,27 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.HashValue ( - HashValue, - hashValue, - truncateHash, - showHashValue, - readFileHashValue, - hashFromTUF, - ) where +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Client.HashValue + ( HashValue + , hashValue + , truncateHash + , showHashValue + , readFileHashValue + , hashFromTUF + ) where import Distribution.Client.Compat.Prelude import Prelude () import qualified Hackage.Security.Client as Sec -import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Char8 as BS +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS -import System.IO (IOMode (..), withBinaryFile) +import System.IO (IOMode (..), withBinaryFile) ----------------------------------------------- -- The specific choice of hash implementation @@ -48,7 +49,6 @@ instance Binary HashValue instance Structured HashValue -- | Hash some data. Currently uses SHA256. --- hashValue :: LBS.ByteString -> HashValue hashValue = HashValue . SHA256.hashlazy @@ -56,22 +56,21 @@ showHashValue :: HashValue -> String showHashValue (HashValue digest) = BS.unpack (Base16.encode digest) -- | Hash the content of a file. Uses SHA256. --- readFileHashValue :: FilePath -> IO HashValue readFileHashValue tarball = - withBinaryFile tarball ReadMode $ \hnd -> - evaluate . hashValue =<< LBS.hGetContents hnd + withBinaryFile tarball ReadMode $ \hnd -> + evaluate . hashValue =<< LBS.hGetContents hnd -- | Convert a hash from TUF metadata into a 'PackageSourceHash'. -- -- Note that TUF hashes don't necessarily have to be SHA256, since it can -- support new algorithms in future. --- +{- FOURMOLU_DISABLE -} hashFromTUF :: Sec.Hash -> HashValue hashFromTUF (Sec.Hash hashstr) = - --TODO: [code cleanup] either we should get TUF to use raw bytestrings or - -- perhaps we should also just use a base16 string as the internal rep. - case Base16.decode (BS.pack hashstr) of + -- TODO: [code cleanup] either we should get TUF to use raw bytestrings or + -- perhaps we should also just use a base16 string as the internal rep. + case Base16.decode (BS.pack hashstr) of #if MIN_VERSION_base16_bytestring(1,0,0) Right hash -> HashValue hash Left _ -> error "hashFromTUF: cannot decode base16" @@ -80,11 +79,11 @@ hashFromTUF (Sec.Hash hashstr) = -> HashValue hash _ -> error "hashFromTUF: cannot decode base16 hash" #endif +{- FOURMOLU_ENABLE -} -- | Truncate a 32 byte SHA256 hash to -- -- For example 20 bytes render as 40 hex chars, which we use for unit-ids. -- Or even 4 bytes for 'hashedInstalledPackageIdShort' --- truncateHash :: Int -> HashValue -> HashValue truncateHash n (HashValue h) = HashValue (BS.take n h) diff --git a/cabal-install/src/Distribution/Client/HttpUtils.hs b/cabal-install/src/Distribution/Client/HttpUtils.hs index 54c88d97ea5..3d27882097b 100644 --- a/cabal-install/src/Distribution/Client/HttpUtils.hs +++ b/cabal-install/src/Distribution/Client/HttpUtils.hs @@ -1,150 +1,206 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- --- | Separate module for HTTP actions, using a proxy server if one exists. + ----------------------------------------------------------------------------- -module Distribution.Client.HttpUtils ( - DownloadResult(..), - configureTransport, - HttpTransport(..), - HttpCode, - downloadURI, - transportCheckHttps, - remoteRepoCheckHttps, - remoteRepoTryUpgradeToHttps, - isOldHackageURI + +-- | Separate module for HTTP actions, using a proxy server if one exists. +module Distribution.Client.HttpUtils + ( DownloadResult (..) + , configureTransport + , HttpTransport (..) + , HttpCode + , downloadURI + , transportCheckHttps + , remoteRepoCheckHttps + , remoteRepoTryUpgradeToHttps + , isOldHackageURI ) where -import Prelude () import Distribution.Client.Compat.Prelude hiding (Proxy (..)) import Distribution.Utils.Generic +import Prelude () -import Network.HTTP - ( Request (..), Response (..), RequestMethod (..) - , Header(..), HeaderName(..), lookupHeader ) -import Network.HTTP.Proxy ( Proxy(..), fetchProxy) -import Network.URI - ( URI (..), URIAuth (..), uriToString ) -import Network.Browser - ( browse, setOutHandler, setErrHandler, setProxy - , setAuthorityGen, request, setAllowBasicAuth, setUserAgent ) import qualified Control.Exception as Exception -import Distribution.Simple.Utils - ( die', info, warn, debug, notice - , copyFileVerbose, withTempFile, IOData (..) ) -import Distribution.Utils.String (trim) +import Distribution.Client.Types + ( RemoteRepo (..) + , unRepoName + ) import Distribution.Client.Utils - ( withTempFileName ) + ( withTempFileName + ) import Distribution.Client.Version - ( cabalInstallVersion ) -import Distribution.Client.Types - ( unRepoName, RemoteRepo(..) ) -import Distribution.System - ( buildOS, buildArch ) -import qualified System.FilePath.Posix as FilePath.Posix - ( splitDirectories ) -import System.FilePath - ( (<.>), takeFileName, takeDirectory ) -import System.Directory - ( doesFileExist, renameFile, canonicalizePath ) -import System.IO - ( withFile, IOMode(ReadMode), hGetContents, hClose ) -import System.IO.Error - ( isDoesNotExistError ) + ( cabalInstallVersion + ) import Distribution.Simple.Program - ( Program, simpleProgram, ConfiguredProgram, programPath - , ProgramInvocation(..), programInvocation - , ProgramSearchPathEntry(..) - , getProgramInvocationOutput ) + ( ConfiguredProgram + , Program + , ProgramInvocation (..) + , ProgramSearchPathEntry (..) + , getProgramInvocationOutput + , programInvocation + , programPath + , simpleProgram + ) import Distribution.Simple.Program.Db - ( ProgramDb, emptyProgramDb, addKnownPrograms - , configureAllKnownPrograms - , requireProgram, lookupProgram - , modifyProgramSearchPath ) + ( ProgramDb + , addKnownPrograms + , configureAllKnownPrograms + , emptyProgramDb + , lookupProgram + , modifyProgramSearchPath + , requireProgram + ) import Distribution.Simple.Program.Run - ( getProgramInvocationOutputAndErrors ) + ( getProgramInvocationOutputAndErrors + ) +import Distribution.Simple.Utils + ( IOData (..) + , copyFileVerbose + , debug + , die' + , info + , notice + , warn + , withTempFile + ) +import Distribution.System + ( buildArch + , buildOS + ) +import Distribution.Utils.String (trim) +import Network.Browser + ( browse + , request + , setAllowBasicAuth + , setAuthorityGen + , setErrHandler + , setOutHandler + , setProxy + , setUserAgent + ) +import Network.HTTP + ( Header (..) + , HeaderName (..) + , Request (..) + , RequestMethod (..) + , Response (..) + , lookupHeader + ) +import Network.HTTP.Proxy (Proxy (..), fetchProxy) +import Network.URI + ( URI (..) + , URIAuth (..) + , uriToString + ) import Numeric (showHex) +import System.Directory + ( canonicalizePath + , doesFileExist + , renameFile + ) +import System.FilePath + ( takeDirectory + , takeFileName + , (<.>) + ) +import qualified System.FilePath.Posix as FilePath.Posix + ( splitDirectories + ) +import System.IO + ( IOMode (ReadMode) + , hClose + , hGetContents + , withFile + ) +import System.IO.Error + ( isDoesNotExistError + ) import System.Random (randomRIO) -import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Data.ByteString.Base16 as Base16 -import qualified Distribution.Compat.CharParsing as P -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as LBS +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as LBS8 +import qualified Distribution.Compat.CharParsing as P ------------------------------------------------------------------------------ -- Downloading a URI, given an HttpTransport -- -data DownloadResult = FileAlreadyInCache - | FileDownloaded FilePath +data DownloadResult + = FileAlreadyInCache + | FileDownloaded FilePath deriving (Eq) data DownloadCheck - = Downloaded -- ^ already downloaded and sha256 matches - | CheckETag String -- ^ already downloaded and we have etag - | NeedsDownload (Maybe BS.ByteString) -- ^ needs download with optional hash check - deriving Eq - -downloadURI :: HttpTransport - -> Verbosity - -> URI -- ^ What to download - -> FilePath -- ^ Where to put it - -> IO DownloadResult + = -- | already downloaded and sha256 matches + Downloaded + | -- | already downloaded and we have etag + CheckETag String + | -- | needs download with optional hash check + NeedsDownload (Maybe BS.ByteString) + deriving (Eq) + +downloadURI + :: HttpTransport + -> Verbosity + -> URI + -- ^ What to download + -> FilePath + -- ^ Where to put it + -> IO DownloadResult downloadURI _transport verbosity uri path | uriScheme uri == "file:" = do copyFileVerbose verbosity (uriPath uri) path return (FileDownloaded path) - -- Can we store the hash of the file so we can safely return path when the - -- hash matches to avoid unnecessary computation? +-- Can we store the hash of the file so we can safely return path when the +-- hash matches to avoid unnecessary computation? downloadURI transport verbosity uri path = do + targetExists <- doesFileExist path - targetExists <- doesFileExist path - - downloadCheck <- - -- if we have uriFrag, then we expect there to be #sha256=... - if not (null uriFrag) + downloadCheck <- + -- if we have uriFrag, then we expect there to be #sha256=... + if not (null uriFrag) then case sha256parsed of -- we know the hash, and target exists Right expected | targetExists -> do contents <- LBS.readFile path let actual = SHA256.hashlazy contents if expected == actual - then return Downloaded - else return (NeedsDownload (Just expected)) + then return Downloaded + else return (NeedsDownload (Just expected)) -- we known the hash, target doesn't exist Right expected -> return (NeedsDownload (Just expected)) - -- we failed to parse uriFragment - Left err -> die' verbosity $ - "Cannot parse URI fragment " ++ uriFrag ++ " " ++ err - - -- if there are no uri fragment, use ETag - else do + Left err -> + die' verbosity $ + "Cannot parse URI fragment " ++ uriFrag ++ " " ++ err + else -- if there are no uri fragment, use ETag + do etagPathExists <- doesFileExist etagPath -- In rare cases the target file doesn't exist, but the etag does. if targetExists && etagPathExists - then return (CheckETag etagPath) - else return (NeedsDownload Nothing) - - -- Only use the external http transports if we actually have to - -- (or have been told to do so) - let transport' - | uriScheme uri == "http:" - , not (transportManuallySelected transport) - = plainHttpTransport - - | otherwise - = transport - - case downloadCheck of - Downloaded -> return FileAlreadyInCache - CheckETag etag -> makeDownload transport' Nothing (Just etag) - NeedsDownload hash -> makeDownload transport' hash Nothing - + then return (CheckETag etagPath) + else return (NeedsDownload Nothing) + + -- Only use the external http transports if we actually have to + -- (or have been told to do so) + let transport' + | uriScheme uri == "http:" + , not (transportManuallySelected transport) = + plainHttpTransport + | otherwise = + transport + + case downloadCheck of + Downloaded -> return FileAlreadyInCache + CheckETag etag -> makeDownload transport' Nothing (Just etag) + NeedsDownload hash -> makeDownload transport' hash Nothing where makeDownload :: HttpTransport -> Maybe BS8.ByteString -> Maybe String -> IO DownloadResult makeDownload transport' sha256 etag = withTempFileName (takeDirectory path) (takeFileName path) $ \tmpFile -> do @@ -158,25 +214,32 @@ downloadURI transport verbosity uri path = do contents <- LBS.readFile tmpFile let actual = SHA256.hashlazy contents unless (actual == expected) $ - die' verbosity $ unwords - [ "Failed to download", show uri - , ": SHA256 don't match; expected:", BS8.unpack (Base16.encode expected) - , "actual:", BS8.unpack (Base16.encode actual) - ] - + die' verbosity $ + unwords + [ "Failed to download" + , show uri + , ": SHA256 don't match; expected:" + , BS8.unpack (Base16.encode expected) + , "actual:" + , BS8.unpack (Base16.encode actual) + ] (200, Just newEtag) -> writeFile etagPath newEtag _ -> return () case fst result of 200 -> do - info verbosity ("Downloaded to " ++ path) - renameFile tmpFile path - return (FileDownloaded path) + info verbosity ("Downloaded to " ++ path) + renameFile tmpFile path + return (FileDownloaded path) 304 -> do - notice verbosity "Skipping download: local and remote files match." - return FileAlreadyInCache - errCode -> die' verbosity $ "failed to download " ++ show uri - ++ " : HTTP code " ++ show errCode + notice verbosity "Skipping download: local and remote files match." + return FileAlreadyInCache + errCode -> + die' verbosity $ + "failed to download " + ++ show uri + ++ " : HTTP code " + ++ show errCode etagPath = path <.> "etag" uriFrag = uriFragment uri @@ -185,13 +248,13 @@ downloadURI transport verbosity uri path = do sha256parsed = explicitEitherParsec fragmentParser uriFrag fragmentParser = do - _ <- P.string "#sha256=" - str <- some P.hexDigit - let bs = Base16.decode (BS8.pack str) + _ <- P.string "#sha256=" + str <- some P.hexDigit + let bs = Base16.decode (BS8.pack str) #if MIN_VERSION_base16_bytestring(1,0,0) - either fail return bs + either fail return bs #else - return (fst bs) + return (fst bs) #endif ------------------------------------------------------------------------------ @@ -201,177 +264,218 @@ downloadURI transport verbosity uri path = do remoteRepoCheckHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO () remoteRepoCheckHttps verbosity transport repo | uriScheme (remoteRepoURI repo) == "https:" - , not (transportSupportsHttps transport) - = die' verbosity $ "The remote repository '" ++ unRepoName (remoteRepoName repo) - ++ "' specifies a URL that " ++ requiresHttpsErrorMessage + , not (transportSupportsHttps transport) = + die' verbosity $ + "The remote repository '" + ++ unRepoName (remoteRepoName repo) + ++ "' specifies a URL that " + ++ requiresHttpsErrorMessage | otherwise = return () transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO () transportCheckHttps verbosity transport uri | uriScheme uri == "https:" - , not (transportSupportsHttps transport) - = die' verbosity $ "The URL " ++ show uri - ++ " " ++ requiresHttpsErrorMessage + , not (transportSupportsHttps transport) = + die' verbosity $ + "The URL " + ++ show uri + ++ " " + ++ requiresHttpsErrorMessage | otherwise = return () requiresHttpsErrorMessage :: String requiresHttpsErrorMessage = - "requires HTTPS however the built-in HTTP implementation " - ++ "does not support HTTPS. The transport implementations with HTTPS " - ++ "support are " ++ intercalate ", " - [ name | (name, _, True, _ ) <- supportedTransports ] - ++ ". One of these will be selected automatically if the corresponding " - ++ "external program is available, or one can be selected specifically " - ++ "with the global flag --http-transport=" + "requires HTTPS however the built-in HTTP implementation " + ++ "does not support HTTPS. The transport implementations with HTTPS " + ++ "support are " + ++ intercalate + ", " + [name | (name, _, True, _) <- supportedTransports] + ++ ". One of these will be selected automatically if the corresponding " + ++ "external program is available, or one can be selected specifically " + ++ "with the global flag --http-transport=" remoteRepoTryUpgradeToHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO RemoteRepo remoteRepoTryUpgradeToHttps verbosity transport repo | remoteRepoShouldTryHttps repo , uriScheme (remoteRepoURI repo) == "http:" , not (transportSupportsHttps transport) - , not (transportManuallySelected transport) - = die' verbosity $ "The builtin HTTP implementation does not support HTTPS, but using " - ++ "HTTPS for authenticated uploads is recommended. " - ++ "The transport implementations with HTTPS support are " - ++ intercalate ", " [ name | (name, _, True, _ ) <- supportedTransports ] - ++ "but they require the corresponding external program to be " - ++ "available. You can either make one available or use plain HTTP by " - ++ "using the global flag --http-transport=plain-http (or putting the " - ++ "equivalent in the config file). With plain HTTP, your password " - ++ "is sent using HTTP digest authentication so it cannot be easily " - ++ "intercepted, but it is not as secure as using HTTPS." - + , not (transportManuallySelected transport) = + die' verbosity $ + "The builtin HTTP implementation does not support HTTPS, but using " + ++ "HTTPS for authenticated uploads is recommended. " + ++ "The transport implementations with HTTPS support are " + ++ intercalate ", " [name | (name, _, True, _) <- supportedTransports] + ++ "but they require the corresponding external program to be " + ++ "available. You can either make one available or use plain HTTP by " + ++ "using the global flag --http-transport=plain-http (or putting the " + ++ "equivalent in the config file). With plain HTTP, your password " + ++ "is sent using HTTP digest authentication so it cannot be easily " + ++ "intercepted, but it is not as secure as using HTTPS." | remoteRepoShouldTryHttps repo , uriScheme (remoteRepoURI repo) == "http:" - , transportSupportsHttps transport - = return repo { - remoteRepoURI = (remoteRepoURI repo) { uriScheme = "https:" } - } - - | otherwise - = return repo + , transportSupportsHttps transport = + return + repo + { remoteRepoURI = (remoteRepoURI repo){uriScheme = "https:"} + } + | otherwise = + return repo -- | Utility function for legacy support. isOldHackageURI :: URI -> Bool -isOldHackageURI uri - = case uriAuthority uri of - Just (URIAuth {uriRegName = "hackage.haskell.org"}) -> - FilePath.Posix.splitDirectories (uriPath uri) - == ["/","packages","archive"] - _ -> False - +isOldHackageURI uri = + case uriAuthority uri of + Just (URIAuth{uriRegName = "hackage.haskell.org"}) -> + FilePath.Posix.splitDirectories (uriPath uri) + == ["/", "packages", "archive"] + _ -> False ------------------------------------------------------------------------------ -- Setting up a HttpTransport -- -data HttpTransport = HttpTransport { - -- | GET a URI, with an optional ETag (to do a conditional fetch), - -- write the resource to the given file and return the HTTP status code, - -- and optional ETag. - getHttp :: Verbosity -> URI -> Maybe ETag -> FilePath -> [Header] - -> IO (HttpCode, Maybe ETag), - - -- | POST a resource to a URI, with optional auth (username, password) - -- and return the HTTP status code and any redirect URL. - postHttp :: Verbosity -> URI -> String -> Maybe Auth - -> IO (HttpCode, String), - - -- | POST a file resource to a URI using multipart\/form-data encoding, - -- with optional auth (username, password) and return the HTTP status - -- code and any error string. - postHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth - -> IO (HttpCode, String), - - -- | PUT a file resource to a URI, with optional auth - -- (username, password), extra headers and return the HTTP status code - -- and any error string. - putHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth -> [Header] - -> IO (HttpCode, String), - - -- | Whether this transport supports https or just http. - transportSupportsHttps :: Bool, - - -- | Whether this transport implementation was specifically chosen by - -- the user via configuration, or whether it was automatically selected. - -- Strictly speaking this is not a property of the transport itself but - -- about how it was chosen. Nevertheless it's convenient to keep here. - transportManuallySelected :: Bool - } - --TODO: why does postHttp return a redirect, but postHttpFile return errors? +data HttpTransport = HttpTransport + { getHttp + :: Verbosity + -> URI + -> Maybe ETag + -> FilePath + -> [Header] + -> IO (HttpCode, Maybe ETag) + -- ^ GET a URI, with an optional ETag (to do a conditional fetch), + -- write the resource to the given file and return the HTTP status code, + -- and optional ETag. + , postHttp + :: Verbosity + -> URI + -> String + -> Maybe Auth + -> IO (HttpCode, String) + -- ^ POST a resource to a URI, with optional auth (username, password) + -- and return the HTTP status code and any redirect URL. + , postHttpFile + :: Verbosity + -> URI + -> FilePath + -> Maybe Auth + -> IO (HttpCode, String) + -- ^ POST a file resource to a URI using multipart\/form-data encoding, + -- with optional auth (username, password) and return the HTTP status + -- code and any error string. + , putHttpFile + :: Verbosity + -> URI + -> FilePath + -> Maybe Auth + -> [Header] + -> IO (HttpCode, String) + -- ^ PUT a file resource to a URI, with optional auth + -- (username, password), extra headers and return the HTTP status code + -- and any error string. + , transportSupportsHttps :: Bool + -- ^ Whether this transport supports https or just http. + , transportManuallySelected :: Bool + -- ^ Whether this transport implementation was specifically chosen by + -- the user via configuration, or whether it was automatically selected. + -- Strictly speaking this is not a property of the transport itself but + -- about how it was chosen. Nevertheless it's convenient to keep here. + } + +-- TODO: why does postHttp return a redirect, but postHttpFile return errors? type HttpCode = Int -type ETag = String -type Auth = (String, String) - -noPostYet :: Verbosity -> URI -> String -> Maybe (String, String) - -> IO (Int, String) +type ETag = String +type Auth = (String, String) + +noPostYet + :: Verbosity + -> URI + -> String + -> Maybe (String, String) + -> IO (Int, String) noPostYet verbosity _ _ _ = die' verbosity "Posting (for report upload) is not implemented yet" -supportedTransports :: [(String, Maybe Program, Bool, - ProgramDb -> Maybe HttpTransport)] +supportedTransports + :: [ ( String + , Maybe Program + , Bool + , ProgramDb -> Maybe HttpTransport + ) + ] supportedTransports = - [ let prog = simpleProgram "curl" in - ( "curl", Just prog, True - , \db -> curlTransport <$> lookupProgram prog db ) - - , let prog = simpleProgram "wget" in - ( "wget", Just prog, True - , \db -> wgetTransport <$> lookupProgram prog db ) - - , let prog = simpleProgram "powershell" in - ( "powershell", Just prog, True - , \db -> powershellTransport <$> lookupProgram prog db ) - - , ( "plain-http", Nothing, False - , \_ -> Just plainHttpTransport ) - ] + [ let prog = simpleProgram "curl" + in ( "curl" + , Just prog + , True + , \db -> curlTransport <$> lookupProgram prog db + ) + , let prog = simpleProgram "wget" + in ( "wget" + , Just prog + , True + , \db -> wgetTransport <$> lookupProgram prog db + ) + , let prog = simpleProgram "powershell" + in ( "powershell" + , Just prog + , True + , \db -> powershellTransport <$> lookupProgram prog db + ) + , + ( "plain-http" + , Nothing + , False + , \_ -> Just plainHttpTransport + ) + ] configureTransport :: Verbosity -> [FilePath] -> Maybe String -> IO HttpTransport - configureTransport verbosity extraPath (Just name) = - -- the user specifically selected a transport by name so we'll try and - -- configure that one - - case find (\(name',_,_,_) -> name' == name) supportedTransports of - Just (_, mprog, _tls, mkTrans) -> do - - let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb - progdb <- case mprog of - Nothing -> return emptyProgramDb - Just prog -> snd <$> requireProgram verbosity prog baseProgDb - -- ^^ if it fails, it'll fail here - - let transport = fromMaybe (error "configureTransport: failed to make transport") $ mkTrans progdb - return transport { transportManuallySelected = True } - - Nothing -> die' verbosity $ "Unknown HTTP transport specified: " ++ name - ++ ". The supported transports are " - ++ intercalate ", " - [ name' | (name', _, _, _ ) <- supportedTransports ] - + -- the user specifically selected a transport by name so we'll try and + -- configure that one + + case find (\(name', _, _, _) -> name' == name) supportedTransports of + Just (_, mprog, _tls, mkTrans) -> do + let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb + progdb <- case mprog of + Nothing -> return emptyProgramDb + Just prog -> snd <$> requireProgram verbosity prog baseProgDb + -- ^^ if it fails, it'll fail here + + let transport = fromMaybe (error "configureTransport: failed to make transport") $ mkTrans progdb + return transport{transportManuallySelected = True} + Nothing -> + die' verbosity $ + "Unknown HTTP transport specified: " + ++ name + ++ ". The supported transports are " + ++ intercalate + ", " + [name' | (name', _, _, _) <- supportedTransports] configureTransport verbosity extraPath Nothing = do - -- the user hasn't selected a transport, so we'll pick the first one we - -- can configure successfully, provided that it supports tls - - -- for all the transports except plain-http we need to try and find - -- their external executable - let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb - progdb <- configureAllKnownPrograms verbosity $ - addKnownPrograms - [ prog | (_, Just prog, _, _) <- supportedTransports ] - baseProgDb - - let availableTransports = - [ (name, transport) - | (name, _, _, mkTrans) <- supportedTransports - , transport <- maybeToList (mkTrans progdb) ] - let (name, transport) = - fromMaybe ("plain-http", plainHttpTransport) (safeHead availableTransports) - debug verbosity $ "Selected http transport implementation: " ++ name - - return transport { transportManuallySelected = False } - + -- the user hasn't selected a transport, so we'll pick the first one we + -- can configure successfully, provided that it supports tls + + -- for all the transports except plain-http we need to try and find + -- their external executable + let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb + progdb <- + configureAllKnownPrograms verbosity $ + addKnownPrograms + [prog | (_, Just prog, _, _) <- supportedTransports] + baseProgDb + + let availableTransports = + [ (name, transport) + | (name, _, _, mkTrans) <- supportedTransports + , transport <- maybeToList (mkTrans progdb) + ] + let (name, transport) = + fromMaybe ("plain-http", plainHttpTransport) (safeHead availableTransports) + debug verbosity $ "Selected http transport implementation: " ++ name + + return transport{transportManuallySelected = False} ------------------------------------------------------------------------------ -- The HttpTransports based on external programs @@ -379,28 +483,43 @@ configureTransport verbosity extraPath Nothing = do curlTransport :: ConfiguredProgram -> HttpTransport curlTransport prog = - HttpTransport gethttp posthttp posthttpfile puthttpfile True False + HttpTransport gethttp posthttp posthttpfile puthttpfile True False where gethttp verbosity uri etag destPath reqHeaders = do - withTempFile (takeDirectory destPath) - "curl-headers.txt" $ \tmpFile tmpHandle -> do + withTempFile + (takeDirectory destPath) + "curl-headers.txt" + $ \tmpFile tmpHandle -> do hClose tmpHandle - let args = [ show uri - , "--output", destPath - , "--location" - , "--write-out", "%{http_code}" - , "--user-agent", userAgent - , "--silent", "--show-error" - , "--dump-header", tmpFile ] - ++ concat - [ ["--header", "If-None-Match: " ++ t] - | t <- maybeToList etag ] - ++ concat - [ ["--header", show name ++ ": " ++ value] - | Header name value <- reqHeaders ] - - resp <- getProgramInvocationOutput verbosity $ addAuthConfig Nothing uri - (programInvocation prog args) + let args = + [ show uri + , "--output" + , destPath + , "--location" + , "--write-out" + , "%{http_code}" + , "--user-agent" + , userAgent + , "--silent" + , "--show-error" + , "--dump-header" + , tmpFile + ] + ++ concat + [ ["--header", "If-None-Match: " ++ t] + | t <- maybeToList etag + ] + ++ concat + [ ["--header", show name ++ ": " ++ value] + | Header name value <- reqHeaders + ] + + resp <- + getProgramInvocationOutput verbosity $ + addAuthConfig + Nothing + uri + (programInvocation prog args) withFile tmpFile ReadMode $ \hnd -> do headers <- hGetContents hnd @@ -413,53 +532,78 @@ curlTransport prog = -- attempt to derive a u/p pair from the uri authority if one exists -- all `uriUserInfo` values have '@' as a suffix. drop it. let uriDerivedAuth = case uriAuthority uri of - (Just (URIAuth u _ _)) | not (null u) -> Just $ filter (/= '@') u - _ -> Nothing + (Just (URIAuth u _ _)) | not (null u) -> Just $ filter (/= '@') u + _ -> Nothing -- prefer passed in auth to auth derived from uri. If neither exist, then no auth let mbAuthString = case (explicitAuth, uriDerivedAuth) of - (Just (uname, passwd), _) -> Just (uname ++ ":" ++ passwd) - (Nothing, Just a) -> Just a - (Nothing, Nothing) -> Nothing + (Just (uname, passwd), _) -> Just (uname ++ ":" ++ passwd) + (Nothing, Just a) -> Just a + (Nothing, Nothing) -> Nothing case mbAuthString of - Just up -> progInvocation - { progInvokeInput = Just . IODataText . unlines $ - [ "--digest" - , "--user " ++ up - ] - , progInvokeArgs = ["--config", "-"] ++ progInvokeArgs progInvocation - } + Just up -> + progInvocation + { progInvokeInput = + Just . IODataText . unlines $ + [ "--digest" + , "--user " ++ up + ] + , progInvokeArgs = ["--config", "-"] ++ progInvokeArgs progInvocation + } Nothing -> progInvocation posthttpfile verbosity uri path auth = do - let args = [ show uri - , "--form", "package=@"++path - , "--write-out", "\n%{http_code}" - , "--user-agent", userAgent - , "--silent", "--show-error" - , "--header", "Accept: text/plain" - , "--location" - ] - resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth uri - (programInvocation prog args) - (code, err, _etag) <- parseResponse verbosity uri resp "" - return (code, err) + let args = + [ show uri + , "--form" + , "package=@" ++ path + , "--write-out" + , "\n%{http_code}" + , "--user-agent" + , userAgent + , "--silent" + , "--show-error" + , "--header" + , "Accept: text/plain" + , "--location" + ] + resp <- + getProgramInvocationOutput verbosity $ + addAuthConfig + auth + uri + (programInvocation prog args) + (code, err, _etag) <- parseResponse verbosity uri resp "" + return (code, err) puthttpfile verbosity uri path auth headers = do - let args = [ show uri - , "--request", "PUT", "--data-binary", "@"++path - , "--write-out", "\n%{http_code}" - , "--user-agent", userAgent - , "--silent", "--show-error" - , "--location" - , "--header", "Accept: text/plain" - ] - ++ concat - [ ["--header", show name ++ ": " ++ value] - | Header name value <- headers ] - resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth uri - (programInvocation prog args) - (code, err, _etag) <- parseResponse verbosity uri resp "" - return (code, err) + let args = + [ show uri + , "--request" + , "PUT" + , "--data-binary" + , "@" ++ path + , "--write-out" + , "\n%{http_code}" + , "--user-agent" + , userAgent + , "--silent" + , "--show-error" + , "--location" + , "--header" + , "Accept: text/plain" + ] + ++ concat + [ ["--header", show name ++ ": " ++ value] + | Header name value <- headers + ] + resp <- + getProgramInvocationOutput verbosity $ + addAuthConfig + auth + uri + (programInvocation prog args) + (code, err, _etag) <- parseResponse verbosity uri resp "" + return (code, err) -- on success these curl invocations produces an output like "200" -- and on failure it has the server error response first @@ -467,58 +611,65 @@ curlTransport prog = parseResponse verbosity uri resp headers = let codeerr = case reverse (lines resp) of - (codeLine:rerrLines) -> + (codeLine : rerrLines) -> case readMaybe (trim codeLine) of - Just i -> let errstr = mkErrstr rerrLines - in Just (i, errstr) + Just i -> + let errstr = mkErrstr rerrLines + in Just (i, errstr) Nothing -> Nothing - [] -> Nothing + [] -> Nothing mkErrstr = unlines . reverse . dropWhile (all isSpace) mb_etag :: Maybe ETag - mb_etag = listToMaybe $ reverse - [ etag - | ["ETag:", etag] <- map words (lines headers) ] - + mb_etag = + listToMaybe $ + reverse + [ etag + | ["ETag:", etag] <- map words (lines headers) + ] in case codeerr of Just (i, err) -> return (i, err, mb_etag) - _ -> statusParseFail verbosity uri resp - + _ -> statusParseFail verbosity uri resp wgetTransport :: ConfiguredProgram -> HttpTransport wgetTransport prog = HttpTransport gethttp posthttp posthttpfile puthttpfile True False where - gethttp verbosity uri etag destPath reqHeaders = do - resp <- runWGet verbosity uri args - - -- wget doesn't support range requests. - -- so, we not only ignore range request headers, - -- but we also display a warning message when we see them. - let hasRangeHeader = any isRangeHeader reqHeaders - warningMsg = "the 'wget' transport currently doesn't support" - ++ " range requests, which wastes network bandwidth." - ++ " To fix this, set 'http-transport' to 'curl' or" - ++ " 'plain-http' in '~/.config/cabal/config'." - ++ " Note that the 'plain-http' transport doesn't" - ++ " support HTTPS.\n" - - when (hasRangeHeader) $ warn verbosity warningMsg - (code, etag') <- parseOutput verbosity uri resp - return (code, etag') + gethttp verbosity uri etag destPath reqHeaders = do + resp <- runWGet verbosity uri args + + -- wget doesn't support range requests. + -- so, we not only ignore range request headers, + -- but we also display a warning message when we see them. + let hasRangeHeader = any isRangeHeader reqHeaders + warningMsg = + "the 'wget' transport currently doesn't support" + ++ " range requests, which wastes network bandwidth." + ++ " To fix this, set 'http-transport' to 'curl' or" + ++ " 'plain-http' in '~/.config/cabal/config'." + ++ " Note that the 'plain-http' transport doesn't" + ++ " support HTTPS.\n" + + when (hasRangeHeader) $ warn verbosity warningMsg + (code, etag') <- parseOutput verbosity uri resp + return (code, etag') where - args = [ "--output-document=" ++ destPath - , "--user-agent=" ++ userAgent - , "--tries=5" - , "--timeout=15" - , "--server-response" ] + args = + [ "--output-document=" ++ destPath + , "--user-agent=" ++ userAgent + , "--tries=5" + , "--timeout=15" + , "--server-response" + ] ++ concat - [ ["--header", "If-None-Match: " ++ t] - | t <- maybeToList etag ] + [ ["--header", "If-None-Match: " ++ t] + | t <- maybeToList etag + ] ++ [ "--header=" ++ show name ++ ": " ++ value | hdr@(Header name value) <- reqHeaders - , (not (isRangeHeader hdr)) ] + , (not (isRangeHeader hdr)) + ] -- wget doesn't support range requests. -- so, we ignore range request headers, lest we get errors. @@ -528,171 +679,207 @@ wgetTransport prog = posthttp = noPostYet - posthttpfile verbosity uri path auth = - withTempFile (takeDirectory path) - (takeFileName path) $ \tmpFile tmpHandle -> - withTempFile (takeDirectory path) "response" $ + posthttpfile verbosity uri path auth = + withTempFile + (takeDirectory path) + (takeFileName path) + $ \tmpFile tmpHandle -> + withTempFile (takeDirectory path) "response" $ + \responseFile responseHandle -> do + hClose responseHandle + (body, boundary) <- generateMultipartBody path + LBS.hPut tmpHandle body + hClose tmpHandle + let args = + [ "--post-file=" ++ tmpFile + , "--user-agent=" ++ userAgent + , "--server-response" + , "--output-document=" ++ responseFile + , "--header=Accept: text/plain" + , "--header=Content-type: multipart/form-data; " + ++ "boundary=" + ++ boundary + ] + out <- runWGet verbosity (addUriAuth auth uri) args + (code, _etag) <- parseOutput verbosity uri out + withFile responseFile ReadMode $ \hnd -> do + resp <- hGetContents hnd + evaluate $ force (code, resp) + + puthttpfile verbosity uri path auth headers = + withTempFile (takeDirectory path) "response" $ \responseFile responseHandle -> do hClose responseHandle - (body, boundary) <- generateMultipartBody path - LBS.hPut tmpHandle body - hClose tmpHandle - let args = [ "--post-file=" ++ tmpFile - , "--user-agent=" ++ userAgent - , "--server-response" - , "--output-document=" ++ responseFile - , "--header=Accept: text/plain" - , "--header=Content-type: multipart/form-data; " ++ - "boundary=" ++ boundary ] + let args = + [ "--method=PUT" + , "--body-file=" ++ path + , "--user-agent=" ++ userAgent + , "--server-response" + , "--output-document=" ++ responseFile + , "--header=Accept: text/plain" + ] + ++ [ "--header=" ++ show name ++ ": " ++ value + | Header name value <- headers + ] + out <- runWGet verbosity (addUriAuth auth uri) args (code, _etag) <- parseOutput verbosity uri out withFile responseFile ReadMode $ \hnd -> do resp <- hGetContents hnd evaluate $ force (code, resp) - puthttpfile verbosity uri path auth headers = - withTempFile (takeDirectory path) "response" $ - \responseFile responseHandle -> do - hClose responseHandle - let args = [ "--method=PUT", "--body-file="++path - , "--user-agent=" ++ userAgent - , "--server-response" - , "--output-document=" ++ responseFile - , "--header=Accept: text/plain" ] - ++ [ "--header=" ++ show name ++ ": " ++ value - | Header name value <- headers ] - - out <- runWGet verbosity (addUriAuth auth uri) args - (code, _etag) <- parseOutput verbosity uri out - withFile responseFile ReadMode $ \hnd -> do - resp <- hGetContents hnd - evaluate $ force (code, resp) - addUriAuth Nothing uri = uri - addUriAuth (Just (user, pass)) uri = uri - { uriAuthority = Just a { uriUserInfo = user ++ ":" ++ pass ++ "@" } - } - where - a = fromMaybe (URIAuth "" "" "") (uriAuthority uri) + addUriAuth (Just (user, pass)) uri = + uri + { uriAuthority = Just a{uriUserInfo = user ++ ":" ++ pass ++ "@"} + } + where + a = fromMaybe (URIAuth "" "" "") (uriAuthority uri) runWGet verbosity uri args = do - -- We pass the URI via STDIN because it contains the users' credentials - -- and sensitive data should not be passed via command line arguments. - let - invocation = (programInvocation prog ("--input-file=-" : args)) + -- We pass the URI via STDIN because it contains the users' credentials + -- and sensitive data should not be passed via command line arguments. + let + invocation = + (programInvocation prog ("--input-file=-" : args)) { progInvokeInput = Just $ IODataText $ uriToString id uri "" } - -- wget returns its output on stderr rather than stdout - (_, resp, exitCode) <- getProgramInvocationOutputAndErrors verbosity - invocation - -- wget returns exit code 8 for server "errors" like "304 not modified" - if exitCode == ExitSuccess || exitCode == ExitFailure 8 - then return resp - else die' verbosity $ "'" ++ programPath prog - ++ "' exited with an error:\n" ++ resp + -- wget returns its output on stderr rather than stdout + (_, resp, exitCode) <- + getProgramInvocationOutputAndErrors + verbosity + invocation + -- wget returns exit code 8 for server "errors" like "304 not modified" + if exitCode == ExitSuccess || exitCode == ExitFailure 8 + then return resp + else + die' verbosity $ + "'" + ++ programPath prog + ++ "' exited with an error:\n" + ++ resp -- With the --server-response flag, wget produces output with the full -- http server response with all headers, we want to find a line like -- "HTTP/1.1 200 OK", but only the last one, since we can have multiple -- requests due to redirects. parseOutput verbosity uri resp = - let parsedCode = listToMaybe - [ code - | (protocol:codestr:_err) <- map words (reverse (lines resp)) - , "HTTP/" `isPrefixOf` protocol - , code <- maybeToList (readMaybe codestr) ] + let parsedCode = + listToMaybe + [ code + | (protocol : codestr : _err) <- map words (reverse (lines resp)) + , "HTTP/" `isPrefixOf` protocol + , code <- maybeToList (readMaybe codestr) + ] mb_etag :: Maybe ETag - mb_etag = listToMaybe - [ etag - | ["ETag:", etag] <- map words (reverse (lines resp)) ] + mb_etag = + listToMaybe + [ etag + | ["ETag:", etag] <- map words (reverse (lines resp)) + ] in case parsedCode of Just i -> return (i, mb_etag) - _ -> statusParseFail verbosity uri resp - + _ -> statusParseFail verbosity uri resp powershellTransport :: ConfiguredProgram -> HttpTransport powershellTransport prog = - HttpTransport gethttp posthttp posthttpfile puthttpfile True False + HttpTransport gethttp posthttp posthttpfile puthttpfile True False where gethttp verbosity uri etag destPath reqHeaders = do - resp <- runPowershellScript verbosity $ - webclientScript - (escape (show uri)) - (("$targetStream = New-Object -TypeName System.IO.FileStream -ArgumentList " ++ (escape destPath) ++ ", Create") - :(setupHeaders ((useragentHeader : etagHeader) ++ reqHeaders))) - [ "$response = $request.GetResponse()" - , "$responseStream = $response.GetResponseStream()" - , "$buffer = new-object byte[] 10KB" - , "$count = $responseStream.Read($buffer, 0, $buffer.length)" - , "while ($count -gt 0)" - , "{" - , " $targetStream.Write($buffer, 0, $count)" - , " $count = $responseStream.Read($buffer, 0, $buffer.length)" - , "}" - , "Write-Host ($response.StatusCode -as [int]);" - , "Write-Host $response.GetResponseHeader(\"ETag\").Trim('\"')" - ] - [ "$targetStream.Flush()" - , "$targetStream.Close()" - , "$targetStream.Dispose()" - , "$responseStream.Dispose()" - ] + resp <- + runPowershellScript verbosity $ + webclientScript + (escape (show uri)) + ( ("$targetStream = New-Object -TypeName System.IO.FileStream -ArgumentList " ++ (escape destPath) ++ ", Create") + : (setupHeaders ((useragentHeader : etagHeader) ++ reqHeaders)) + ) + [ "$response = $request.GetResponse()" + , "$responseStream = $response.GetResponseStream()" + , "$buffer = new-object byte[] 10KB" + , "$count = $responseStream.Read($buffer, 0, $buffer.length)" + , "while ($count -gt 0)" + , "{" + , " $targetStream.Write($buffer, 0, $count)" + , " $count = $responseStream.Read($buffer, 0, $buffer.length)" + , "}" + , "Write-Host ($response.StatusCode -as [int]);" + , "Write-Host $response.GetResponseHeader(\"ETag\").Trim('\"')" + ] + [ "$targetStream.Flush()" + , "$targetStream.Close()" + , "$targetStream.Dispose()" + , "$responseStream.Dispose()" + ] parseResponse resp where parseResponse :: String -> IO (HttpCode, Maybe ETag) parseResponse x = case lines $ trim x of - (code:etagv:_) -> fmap (\c -> (c, Just etagv)) $ parseCode code x - (code: _) -> fmap (\c -> (c, Nothing )) $ parseCode code x - _ -> statusParseFail verbosity uri x + (code : etagv : _) -> fmap (\c -> (c, Just etagv)) $ parseCode code x + (code : _) -> fmap (\c -> (c, Nothing)) $ parseCode code x + _ -> statusParseFail verbosity uri x parseCode :: String -> String -> IO HttpCode parseCode code x = case readMaybe code of - Just i -> return i + Just i -> return i Nothing -> statusParseFail verbosity uri x - etagHeader = [ Header HdrIfNoneMatch t | t <- maybeToList etag ] + etagHeader = [Header HdrIfNoneMatch t | t <- maybeToList etag] posthttp = noPostYet posthttpfile verbosity uri path auth = - withTempFile (takeDirectory path) - (takeFileName path) $ \tmpFile tmpHandle -> do - (body, boundary) <- generateMultipartBody path - LBS.hPut tmpHandle body - hClose tmpHandle - fullPath <- canonicalizePath tmpFile - - let contentHeader = Header HdrContentType - ("multipart/form-data; boundary=" ++ boundary) - resp <- runPowershellScript verbosity $ webclientScript - (escape (show uri)) - (setupHeaders (contentHeader : extraHeaders) ++ setupAuth auth) - (uploadFileAction "POST" uri fullPath) - uploadFileCleanup - parseUploadResponse verbosity uri resp + withTempFile + (takeDirectory path) + (takeFileName path) + $ \tmpFile tmpHandle -> do + (body, boundary) <- generateMultipartBody path + LBS.hPut tmpHandle body + hClose tmpHandle + fullPath <- canonicalizePath tmpFile + + let contentHeader = + Header + HdrContentType + ("multipart/form-data; boundary=" ++ boundary) + resp <- + runPowershellScript verbosity $ + webclientScript + (escape (show uri)) + (setupHeaders (contentHeader : extraHeaders) ++ setupAuth auth) + (uploadFileAction "POST" uri fullPath) + uploadFileCleanup + parseUploadResponse verbosity uri resp puthttpfile verbosity uri path auth headers = do fullPath <- canonicalizePath path - resp <- runPowershellScript verbosity $ webclientScript - (escape (show uri)) - (setupHeaders (extraHeaders ++ headers) ++ setupAuth auth) - (uploadFileAction "PUT" uri fullPath) - uploadFileCleanup + resp <- + runPowershellScript verbosity $ + webclientScript + (escape (show uri)) + (setupHeaders (extraHeaders ++ headers) ++ setupAuth auth) + (uploadFileAction "PUT" uri fullPath) + uploadFileCleanup parseUploadResponse verbosity uri resp runPowershellScript verbosity script = do let args = - [ "-InputFormat", "None" - -- the default execution policy doesn't allow running - -- unsigned scripts, so we need to tell powershell to bypass it - , "-ExecutionPolicy", "bypass" - , "-NoProfile", "-NonInteractive" - , "-Command", "-" + [ "-InputFormat" + , "None" + , -- the default execution policy doesn't allow running + -- unsigned scripts, so we need to tell powershell to bypass it + "-ExecutionPolicy" + , "bypass" + , "-NoProfile" + , "-NonInteractive" + , "-Command" + , "-" ] debug verbosity script - getProgramInvocationOutput verbosity (programInvocation prog args) - { progInvokeInput = Just $ IODataText $ script ++ "\nExit(0);" - } + getProgramInvocationOutput + verbosity + (programInvocation prog args) + { progInvokeInput = Just $ IODataText $ script ++ "\nExit(0);" + } escape = show @@ -704,33 +891,37 @@ powershellTransport prog = | Header name value <- headers ] where - addHeader header value - = case header of - HdrAccept -> "Accept = " ++ escape value - HdrUserAgent -> "UserAgent = " ++ escape value - HdrConnection -> "Connection = " ++ escape value - HdrContentLength -> "ContentLength = " ++ escape value - HdrContentType -> "ContentType = " ++ escape value - HdrDate -> "Date = " ++ escape value - HdrExpect -> "Expect = " ++ escape value - HdrHost -> "Host = " ++ escape value - HdrIfModifiedSince -> "IfModifiedSince = " ++ escape value - HdrReferer -> "Referer = " ++ escape value - HdrTransferEncoding -> "TransferEncoding = " ++ escape value - HdrRange -> let (start, end) = - if "bytes=" `isPrefixOf` value - then case break (== '-') value' of - (start', '-':end') -> (start', end') - _ -> error $ "Could not decode range: " ++ value - else error $ "Could not decode range: " ++ value - value' = drop 6 value - in "AddRange(\"bytes\", " ++ escape start ++ ", " ++ escape end ++ ");" - name -> "Headers.Add(" ++ escape (show name) ++ "," ++ escape value ++ ");" + addHeader header value = + case header of + HdrAccept -> "Accept = " ++ escape value + HdrUserAgent -> "UserAgent = " ++ escape value + HdrConnection -> "Connection = " ++ escape value + HdrContentLength -> "ContentLength = " ++ escape value + HdrContentType -> "ContentType = " ++ escape value + HdrDate -> "Date = " ++ escape value + HdrExpect -> "Expect = " ++ escape value + HdrHost -> "Host = " ++ escape value + HdrIfModifiedSince -> "IfModifiedSince = " ++ escape value + HdrReferer -> "Referer = " ++ escape value + HdrTransferEncoding -> "TransferEncoding = " ++ escape value + HdrRange -> + let (start, end) = + if "bytes=" `isPrefixOf` value + then case break (== '-') value' of + (start', '-' : end') -> (start', end') + _ -> error $ "Could not decode range: " ++ value + else error $ "Could not decode range: " ++ value + value' = drop 6 value + in "AddRange(\"bytes\", " ++ escape start ++ ", " ++ escape end ++ ");" + name -> "Headers.Add(" ++ escape (show name) ++ "," ++ escape value ++ ");" setupAuth auth = [ "$request.Credentials = new-object System.Net.NetworkCredential(" - ++ escape uname ++ "," ++ escape passwd ++ ",\"\");" - | (uname,passwd) <- maybeToList auth + ++ escape uname + ++ "," + ++ escape passwd + ++ ",\"\");" + | (uname, passwd) <- maybeToList auth ] uploadFileAction method _uri fullPath = @@ -766,32 +957,32 @@ powershellTransport prog = | Just code <- readMaybe codeStr -> return (code, unlines message) _ -> statusParseFail verbosity uri resp - webclientScript uri setup action cleanup = unlines - [ "[Net.ServicePointManager]::SecurityProtocol = \"tls12, tls11, tls\"" - , "$uri = New-Object \"System.Uri\" " ++ uri - , "$request = [System.Net.HttpWebRequest]::Create($uri)" - , unlines setup - , "Try {" - , unlines (map (" " ++) action) - , "} Catch [System.Net.WebException] {" - , " $exception = $_.Exception;" - , " If ($exception.Status -eq " - ++ "[System.Net.WebExceptionStatus]::ProtocolError) {" - , " $response = $exception.Response -as [System.Net.HttpWebResponse];" - , " $reader = new-object " - ++ "System.IO.StreamReader($response.GetResponseStream());" - , " Write-Host ($response.StatusCode -as [int]);" - , " Write-Host $reader.ReadToEnd();" - , " } Else {" - , " Write-Host $exception.Message;" - , " }" - , "} Catch {" - , " Write-Host $_.Exception.Message;" - , "} finally {" - , unlines (map (" " ++) cleanup) - , "}" - ] - + webclientScript uri setup action cleanup = + unlines + [ "[Net.ServicePointManager]::SecurityProtocol = \"tls12, tls11, tls\"" + , "$uri = New-Object \"System.Uri\" " ++ uri + , "$request = [System.Net.HttpWebRequest]::Create($uri)" + , unlines setup + , "Try {" + , unlines (map (" " ++) action) + , "} Catch [System.Net.WebException] {" + , " $exception = $_.Exception;" + , " If ($exception.Status -eq " + ++ "[System.Net.WebExceptionStatus]::ProtocolError) {" + , " $response = $exception.Response -as [System.Net.HttpWebResponse];" + , " $reader = new-object " + ++ "System.IO.StreamReader($response.GetResponseStream());" + , " Write-Host ($response.StatusCode -as [int]);" + , " Write-Host $reader.ReadToEnd();" + , " } Else {" + , " Write-Host $exception.Message;" + , " }" + , "} Catch {" + , " Write-Host $_.Exception.Message;" + , "} finally {" + , unlines (map (" " ++) cleanup) + , "}" + ] ------------------------------------------------------------------------------ -- The builtin plain HttpTransport @@ -799,76 +990,88 @@ powershellTransport prog = plainHttpTransport :: HttpTransport plainHttpTransport = - HttpTransport gethttp posthttp posthttpfile puthttpfile False False + HttpTransport gethttp posthttp posthttpfile puthttpfile False False where gethttp verbosity uri etag destPath reqHeaders = do - let req = Request{ - rqURI = uri, - rqMethod = GET, - rqHeaders = [ Header HdrIfNoneMatch t - | t <- maybeToList etag ] - ++ reqHeaders, - rqBody = LBS.empty - } + let req = + Request + { rqURI = uri + , rqMethod = GET + , rqHeaders = + [ Header HdrIfNoneMatch t + | t <- maybeToList etag + ] + ++ reqHeaders + , rqBody = LBS.empty + } (_, resp) <- cabalBrowse verbosity Nothing (request req) - let code = convertRspCode (rspCode resp) + let code = convertRspCode (rspCode resp) etag' = lookupHeader HdrETag (rspHeaders resp) -- 206 Partial Content is a normal response to a range request; see #3385. - when (code==200 || code==206) $ - writeFileAtomic destPath $ rspBody resp + when (code == 200 || code == 206) $ + writeFileAtomic destPath $ + rspBody resp return (code, etag') posthttp = noPostYet posthttpfile verbosity uri path auth = do (body, boundary) <- generateMultipartBody path - let headers = [ Header HdrContentType - ("multipart/form-data; boundary="++boundary) - , Header HdrContentLength (show (LBS8.length body)) - , Header HdrAccept ("text/plain") - ] - req = Request { - rqURI = uri, - rqMethod = POST, - rqHeaders = headers, - rqBody = body - } + let headers = + [ Header + HdrContentType + ("multipart/form-data; boundary=" ++ boundary) + , Header HdrContentLength (show (LBS8.length body)) + , Header HdrAccept ("text/plain") + ] + req = + Request + { rqURI = uri + , rqMethod = POST + , rqHeaders = headers + , rqBody = body + } (_, resp) <- cabalBrowse verbosity auth (request req) return (convertRspCode (rspCode resp), rspErrorString resp) puthttpfile verbosity uri path auth headers = do body <- LBS8.readFile path - let req = Request { - rqURI = uri, - rqMethod = PUT, - rqHeaders = Header HdrContentLength (show (LBS8.length body)) - : Header HdrAccept "text/plain" - : headers, - rqBody = body - } + let req = + Request + { rqURI = uri + , rqMethod = PUT + , rqHeaders = + Header HdrContentLength (show (LBS8.length body)) + : Header HdrAccept "text/plain" + : headers + , rqBody = body + } (_, resp) <- cabalBrowse verbosity auth (request req) return (convertRspCode (rspCode resp), rspErrorString resp) - convertRspCode (a,b,c) = a*100 + b*10 + c + convertRspCode (a, b, c) = a * 100 + b * 10 + c rspErrorString resp = case lookupHeader HdrContentType (rspHeaders resp) of Just contenttype - | takeWhile (/= ';') contenttype == "text/plain" - -> LBS8.unpack (rspBody resp) + | takeWhile (/= ';') contenttype == "text/plain" -> + LBS8.unpack (rspBody resp) _ -> rspReason resp cabalBrowse verbosity auth act = do p <- fixupEmptyProxy <$> fetchProxy True Exception.handleJust (guard . isDoesNotExistError) - (const . die' verbosity $ "Couldn't establish HTTP connection. " - ++ "Possible cause: HTTP proxy server is down.") $ - browse $ do + ( const . die' verbosity $ + "Couldn't establish HTTP connection. " + ++ "Possible cause: HTTP proxy server is down." + ) + $ browse + $ do setProxy p - setErrHandler (warn verbosity . ("http error: "++)) + setErrHandler (warn verbosity . ("http error: " ++)) setOutHandler (debug verbosity) - setUserAgent userAgent + setUserAgent userAgent setAllowBasicAuth False setAuthorityGen (\_ _ -> return auth) act @@ -876,20 +1079,30 @@ plainHttpTransport = fixupEmptyProxy (Proxy uri _) | null uri = NoProxy fixupEmptyProxy p = p - ------------------------------------------------------------------------------ -- Common stuff used by multiple transport impls -- userAgent :: String -userAgent = concat [ "cabal-install/", prettyShow cabalInstallVersion - , " (", prettyShow buildOS, "; ", prettyShow buildArch, ")" - ] +userAgent = + concat + [ "cabal-install/" + , prettyShow cabalInstallVersion + , " (" + , prettyShow buildOS + , "; " + , prettyShow buildArch + , ")" + ] statusParseFail :: Verbosity -> URI -> String -> IO a statusParseFail verbosity uri r = - die' verbosity $ "Failed to download " ++ show uri ++ " : " - ++ "No Status Code could be parsed from response: " ++ r + die' verbosity $ + "Failed to download " + ++ show uri + ++ " : " + ++ "No Status Code could be parsed from response: " + ++ r ------------------------------------------------------------------------------ -- Multipart stuff partially taken from cgi package. @@ -897,30 +1110,39 @@ statusParseFail verbosity uri r = generateMultipartBody :: FilePath -> IO (LBS.ByteString, String) generateMultipartBody path = do - content <- LBS.readFile path - boundary <- genBoundary - let !body = formatBody content (LBS8.pack boundary) - return (body, boundary) + content <- LBS.readFile path + boundary <- genBoundary + let !body = formatBody content (LBS8.pack boundary) + return (body, boundary) where formatBody content boundary = - LBS8.concat $ - [ crlf, dd, boundary, crlf ] - ++ [ LBS8.pack (show header) | header <- headers ] - ++ [ crlf - , content - , crlf, dd, boundary, dd, crlf ] + LBS8.concat $ + [crlf, dd, boundary, crlf] + ++ [LBS8.pack (show header) | header <- headers] + ++ [ crlf + , content + , crlf + , dd + , boundary + , dd + , crlf + ] headers = - [ Header (HdrCustom "Content-disposition") - ("form-data; name=package; " ++ - "filename=\"" ++ takeFileName path ++ "\"") + [ Header + (HdrCustom "Content-disposition") + ( "form-data; name=package; " + ++ "filename=\"" + ++ takeFileName path + ++ "\"" + ) , Header HdrContentType "application/x-gzip" ] crlf = LBS8.pack "\r\n" - dd = LBS8.pack "--" + dd = LBS8.pack "--" genBoundary :: IO String genBoundary = do - i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer - return $ showHex i "" + i <- randomRIO (0x10000000000000, 0xFFFFFFFFFFFFFF) :: IO Integer + return $ showHex i "" diff --git a/cabal-install/src/Distribution/Client/IndexUtils.hs b/cabal-install/src/Distribution/Client/IndexUtils.hs index 40d82380321..367a5e6fc5c 100644 --- a/cabal-install/src/Distribution/Client/IndexUtils.hs +++ b/cabal-install/src/Distribution/Client/IndexUtils.hs @@ -1,13 +1,16 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.IndexUtils -- Copyright : (c) Duncan Coutts 2008 @@ -18,118 +21,156 @@ -- Portability : portable -- -- Extra utils related to the package indexes. ------------------------------------------------------------------------------ -module Distribution.Client.IndexUtils ( - getIndexFileAge, - getInstalledPackages, - indexBaseName, - Configure.getInstalledPackagesMonitorFiles, - getSourcePackages, - getSourcePackagesMonitorFiles, - - TotalIndexState, - getSourcePackagesAtIndexState, - ActiveRepos, - filterSkippedActiveRepos, - - Index(..), - RepoIndexState (..), - PackageEntry(..), - parsePackageIndex, - updateRepoIndexCache, - updatePackageIndexCacheFile, - writeIndexTimestamp, - currentIndexTimestamp, - - BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType, - -- * preferred-versions utilities - preferredVersions, isPreferredVersions, parsePreferredVersionsWarnings, - PreferredVersionsParseError(..) +module Distribution.Client.IndexUtils + ( getIndexFileAge + , getInstalledPackages + , indexBaseName + , Configure.getInstalledPackagesMonitorFiles + , getSourcePackages + , getSourcePackagesMonitorFiles + , TotalIndexState + , getSourcePackagesAtIndexState + , ActiveRepos + , filterSkippedActiveRepos + , Index (..) + , RepoIndexState (..) + , PackageEntry (..) + , parsePackageIndex + , updateRepoIndexCache + , updatePackageIndexCacheFile + , writeIndexTimestamp + , currentIndexTimestamp + , BuildTreeRefType (..) + , refTypeFromTypeCode + , typeCodeFromRefType + + -- * preferred-versions utilities + , preferredVersions + , isPreferredVersions + , parsePreferredVersionsWarnings + , PreferredVersionsParseError (..) ) where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () -import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar import qualified Codec.Archive.Tar.Index as Tar -import qualified Distribution.Client.Tar as Tar import Distribution.Client.IndexUtils.ActiveRepos import Distribution.Client.IndexUtils.IndexState import Distribution.Client.IndexUtils.Timestamp +import qualified Distribution.Client.Tar as Tar import Distribution.Client.Types -import Distribution.Verbosity import Distribution.Parsec (simpleParsecBS) +import Distribution.Verbosity +import Distribution.Client.Setup + ( RepoContext (..) + ) import Distribution.Package - ( PackageId, PackageIdentifier(..), mkPackageName - , Package(..), packageVersion, packageName ) -import Distribution.Types.Dependency -import Distribution.Simple.PackageIndex (InstalledPackageIndex) + ( Package (..) + , PackageId + , PackageIdentifier (..) + , mkPackageName + , packageName + , packageVersion + ) import Distribution.PackageDescription - ( GenericPackageDescription(..) - , PackageDescription(..), emptyPackageDescription ) + ( GenericPackageDescription (..) + , PackageDescription (..) + , emptyPackageDescription + ) import Distribution.Simple.Compiler - ( Compiler, PackageDBStack ) -import Distribution.Simple.Program - ( ProgramDb ) + ( Compiler + , PackageDBStack + ) import qualified Distribution.Simple.Configure as Configure - ( getInstalledPackages, getInstalledPackagesMonitorFiles ) + ( getInstalledPackages + , getInstalledPackagesMonitorFiles + ) +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import Distribution.Simple.Program + ( ProgramDb + ) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose + , die' + , fromUTF8LBS + , info + , warn + ) +import Distribution.Types.Dependency import Distribution.Types.PackageName (PackageName) import Distribution.Version - ( Version, VersionRange, mkVersion, intersectVersionRanges ) -import Distribution.Simple.Utils - ( die', warn, info, createDirectoryIfMissingVerbose, fromUTF8LBS ) -import Distribution.Client.Setup - ( RepoContext(..) ) + ( Version + , VersionRange + , intersectVersionRanges + , mkVersion + ) import Distribution.PackageDescription.Parsec - ( parseGenericPackageDescription, parseGenericPackageDescriptionMaybe ) + ( parseGenericPackageDescription + , parseGenericPackageDescriptionMaybe + ) import qualified Distribution.PackageDescription.Parsec as PackageDesc.Parse import qualified Distribution.Simple.PackageDescription as PackageDesc.Parse -import Distribution.Solver.Types.PackageIndex (PackageIndex) +import Distribution.Solver.Types.PackageIndex (PackageIndex) import qualified Distribution.Solver.Types.PackageIndex as PackageIndex -import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.SourcePackage -import Data.Either - ( rights ) -import qualified Data.Map as Map -import qualified Data.Set as Set import Control.Exception -import Data.List (stripPrefix) -import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Char8 as BSS import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as BS +import Data.Either + ( rights + ) +import Data.List (stripPrefix) +import qualified Data.Map as Map +import qualified Data.Set as Set import Distribution.Client.GZipUtils (maybeDecompress) -import Distribution.Client.Utils ( byteStringToFilePath - , tryFindAddSourcePackageDesc ) -import Distribution.Utils.Structured (Structured (..), nominalStructure, structuredEncodeFile, structuredDecodeFileOrFail) +import Distribution.Client.Utils + ( byteStringToFilePath + , tryFindAddSourcePackageDesc + ) +import Distribution.Compat.Directory (listDirectory) import Distribution.Compat.Time (getFileAge, getModTime) -import System.Directory (doesFileExist, doesDirectoryExist) +import Distribution.Utils.Generic (fstOf3) +import Distribution.Utils.Structured (Structured (..), nominalStructure, structuredDecodeFileOrFail, structuredEncodeFile) +import System.Directory (doesDirectoryExist, doesFileExist) import System.FilePath - ( (), (<.>), takeFileName, takeExtension, replaceExtension, splitDirectories, normalise, takeDirectory ) + ( normalise + , replaceExtension + , splitDirectories + , takeDirectory + , takeExtension + , takeFileName + , (<.>) + , () + ) import qualified System.FilePath.Posix as FilePath.Posix import System.IO -import System.IO.Unsafe (unsafeInterleaveIO) import System.IO.Error (isDoesNotExistError) -import Distribution.Compat.Directory (listDirectory) -import Distribution.Utils.Generic (fstOf3) +import System.IO.Unsafe (unsafeInterleaveIO) import qualified Codec.Compression.GZip as GZip -import qualified Hackage.Security.Client as Sec +import qualified Hackage.Security.Client as Sec import qualified Hackage.Security.Util.Some as Sec -- | Reduced-verbosity version of 'Configure.getInstalledPackages' -getInstalledPackages :: Verbosity -> Compiler - -> PackageDBStack -> ProgramDb - -> IO InstalledPackageIndex +getInstalledPackages + :: Verbosity + -> Compiler + -> PackageDBStack + -> ProgramDb + -> IO InstalledPackageIndex getInstalledPackages verbosity comp packageDbs progdb = - Configure.getInstalledPackages verbosity' comp packageDbs progdb + Configure.getInstalledPackages verbosity' comp packageDbs progdb where - verbosity' = lessVerbose verbosity - + verbosity' = lessVerbose verbosity -- | Get filename base (i.e. without file extension) for index-related files -- @@ -143,9 +184,9 @@ indexBaseName :: Repo -> FilePath indexBaseName repo = repoLocalDir repo fn where fn = case repo of - RepoSecure {} -> "01-index" - RepoRemote {} -> "00-index" - RepoLocalNoIndex {} -> "noindex" + RepoSecure{} -> "01-index" + RepoRemote{} -> "00-index" + RepoLocalNoIndex{} -> "noindex" ------------------------------------------------------------------------ -- Reading the source package index @@ -158,20 +199,18 @@ indexBaseName repo = repoLocalDir repo fn -- filtered 'Cache' 'after applying 'filterCache' according to a -- requested 'IndexState'. data IndexStateInfo = IndexStateInfo - { isiMaxTime :: !Timestamp - -- ^ 'Timestamp' of maximum/latest 'Timestamp' in the current - -- filtered view of the cache. - -- - -- The following property holds - -- - -- > filterCache (IndexState (isiMaxTime isi)) cache == (cache, isi) - -- - - , isiHeadTime :: !Timestamp - -- ^ 'Timestamp' equivalent to 'IndexStateHead', i.e. the latest - -- known 'Timestamp'; 'isiHeadTime' is always greater or equal to - -- 'isiMaxTime'. - } + { isiMaxTime :: !Timestamp + -- ^ 'Timestamp' of maximum/latest 'Timestamp' in the current + -- filtered view of the cache. + -- + -- The following property holds + -- + -- > filterCache (IndexState (isiMaxTime isi)) cache == (cache, isi) + , isiHeadTime :: !Timestamp + -- ^ 'Timestamp' equivalent to 'IndexStateHead', i.e. the latest + -- known 'Timestamp'; 'isiHeadTime' is always greater or equal to + -- 'isiMaxTime'. + } emptyStateInfo :: IndexStateInfo emptyStateInfo = IndexStateInfo nullTimestamp nullTimestamp @@ -184,13 +223,13 @@ emptyStateInfo = IndexStateInfo nullTimestamp nullTimestamp filterCache :: RepoIndexState -> Cache -> (Cache, IndexStateInfo) filterCache IndexStateHead cache = (cache, IndexStateInfo{..}) where - isiMaxTime = cacheHeadTs cache + isiMaxTime = cacheHeadTs cache isiHeadTime = cacheHeadTs cache filterCache (IndexStateTime ts0) cache0 = (cache, IndexStateInfo{..}) where - cache = Cache { cacheEntries = ents, cacheHeadTs = isiMaxTime } + cache = Cache{cacheEntries = ents, cacheHeadTs = isiMaxTime} isiHeadTime = cacheHeadTs cache0 - isiMaxTime = maximumTimestamp (map cacheEntryTimestamp ents) + isiMaxTime = maximumTimestamp (map cacheEntryTimestamp ents) ents = filter ((<= ts0) . cacheEntryTimestamp) (cacheEntries cache0) -- | Read a repository index from disk, from the local files specified by @@ -202,7 +241,7 @@ filterCache (IndexStateTime ts0) cache0 = (cache, IndexStateInfo{..}) -- This is a higher level wrapper used internally in cabal-install. getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb getSourcePackages verbosity repoCtxt = - fstOf3 <$> getSourcePackagesAtIndexState verbosity repoCtxt Nothing Nothing + fstOf3 <$> getSourcePackagesAtIndexState verbosity repoCtxt Nothing Nothing -- | Variant of 'getSourcePackages' which allows getting the source -- packages at a particular 'IndexState'. @@ -212,118 +251,146 @@ getSourcePackages verbosity repoCtxt = -- -- Returns also the total index where repositories' -- RepoIndexState's are not HEAD. This is used in v2-freeze. --- getSourcePackagesAtIndexState - :: Verbosity - -> RepoContext - -> Maybe TotalIndexState - -> Maybe ActiveRepos - -> IO (SourcePackageDb, TotalIndexState, ActiveRepos) + :: Verbosity + -> RepoContext + -> Maybe TotalIndexState + -> Maybe ActiveRepos + -> IO (SourcePackageDb, TotalIndexState, ActiveRepos) getSourcePackagesAtIndexState verbosity repoCtxt _ _ | null (repoContextRepos repoCtxt) = do -- In the test suite, we routinely don't have any remote package -- servers, so don't bleat about it warn (verboseUnmarkOutput verbosity) $ - "No remote package servers have been specified. Usually " ++ - "you would have one specified in the config file." - return (SourcePackageDb { - packageIndex = mempty, - packagePreferences = mempty - }, headTotalIndexState, ActiveRepos []) + "No remote package servers have been specified. Usually " + ++ "you would have one specified in the config file." + return + ( SourcePackageDb + { packageIndex = mempty + , packagePreferences = mempty + } + , headTotalIndexState + , ActiveRepos [] + ) getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do - let describeState IndexStateHead = "most recent state" + let describeState IndexStateHead = "most recent state" describeState (IndexStateTime time) = "historical state as of " ++ prettyShow time pkgss <- for (repoContextRepos repoCtxt) $ \r -> do - let rname :: RepoName - rname = repoName r - - info verbosity ("Reading available packages of " ++ unRepoName rname ++ "...") - - idxState <- case mb_idxState of - Just totalIdxState -> do - let idxState = lookupIndexState rname totalIdxState - info verbosity $ "Using " ++ describeState idxState ++ - " as explicitly requested (via command line / project configuration)" - return idxState - Nothing -> do - mb_idxState' <- readIndexTimestamp verbosity (RepoIndex repoCtxt r) - case mb_idxState' of - Nothing -> do - info verbosity "Using most recent state (could not read timestamp file)" - return IndexStateHead - Just idxState -> do - info verbosity $ "Using " ++ describeState idxState ++ - " specified from most recent cabal update" - return idxState - - unless (idxState == IndexStateHead) $ - case r of - RepoLocalNoIndex {} -> warn verbosity "index-state ignored for file+noindex repositories" - RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ unRepoName rname ++ "')") - RepoSecure {} -> pure () - - let idxState' = case r of - RepoSecure {} -> idxState - _ -> IndexStateHead - - (pis,deps,isi) <- readRepoIndex verbosity repoCtxt r idxState' - - case idxState' of - IndexStateHead -> do - info verbosity ("index-state("++ unRepoName rname ++") = " ++ prettyShow (isiHeadTime isi)) - return () - IndexStateTime ts0 -> do - when (isiMaxTime isi /= ts0) $ - if ts0 > isiMaxTime isi - then warn verbosity $ - "Requested index-state " ++ prettyShow ts0 - ++ " is newer than '" ++ unRepoName rname ++ "'!" - ++ " Falling back to older state (" - ++ prettyShow (isiMaxTime isi) ++ ")." - else info verbosity $ - "Requested index-state " ++ prettyShow ts0 - ++ " does not exist in '"++ unRepoName rname ++"'!" - ++ " Falling back to older state (" - ++ prettyShow (isiMaxTime isi) ++ ")." - info verbosity ("index-state("++ unRepoName rname ++") = " ++ - prettyShow (isiMaxTime isi) ++ " (HEAD = " ++ - prettyShow (isiHeadTime isi) ++ ")") - - pure RepoData - { rdRepoName = rname - , rdTimeStamp = isiMaxTime isi - , rdIndex = pis - , rdPreferences = deps - } + let rname :: RepoName + rname = repoName r + + info verbosity ("Reading available packages of " ++ unRepoName rname ++ "...") + + idxState <- case mb_idxState of + Just totalIdxState -> do + let idxState = lookupIndexState rname totalIdxState + info verbosity $ + "Using " + ++ describeState idxState + ++ " as explicitly requested (via command line / project configuration)" + return idxState + Nothing -> do + mb_idxState' <- readIndexTimestamp verbosity (RepoIndex repoCtxt r) + case mb_idxState' of + Nothing -> do + info verbosity "Using most recent state (could not read timestamp file)" + return IndexStateHead + Just idxState -> do + info verbosity $ + "Using " + ++ describeState idxState + ++ " specified from most recent cabal update" + return idxState + + unless (idxState == IndexStateHead) $ + case r of + RepoLocalNoIndex{} -> warn verbosity "index-state ignored for file+noindex repositories" + RepoRemote{} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ unRepoName rname ++ "')") + RepoSecure{} -> pure () + + let idxState' = case r of + RepoSecure{} -> idxState + _ -> IndexStateHead + + (pis, deps, isi) <- readRepoIndex verbosity repoCtxt r idxState' + + case idxState' of + IndexStateHead -> do + info verbosity ("index-state(" ++ unRepoName rname ++ ") = " ++ prettyShow (isiHeadTime isi)) + return () + IndexStateTime ts0 -> do + when (isiMaxTime isi /= ts0) $ + if ts0 > isiMaxTime isi + then + warn verbosity $ + "Requested index-state " + ++ prettyShow ts0 + ++ " is newer than '" + ++ unRepoName rname + ++ "'!" + ++ " Falling back to older state (" + ++ prettyShow (isiMaxTime isi) + ++ ")." + else + info verbosity $ + "Requested index-state " + ++ prettyShow ts0 + ++ " does not exist in '" + ++ unRepoName rname + ++ "'!" + ++ " Falling back to older state (" + ++ prettyShow (isiMaxTime isi) + ++ ")." + info + verbosity + ( "index-state(" + ++ unRepoName rname + ++ ") = " + ++ prettyShow (isiMaxTime isi) + ++ " (HEAD = " + ++ prettyShow (isiHeadTime isi) + ++ ")" + ) + + pure + RepoData + { rdRepoName = rname + , rdTimeStamp = isiMaxTime isi + , rdIndex = pis + , rdPreferences = deps + } let activeRepos :: ActiveRepos activeRepos = fromMaybe defaultActiveRepos mb_activeRepos pkgss' <- case organizeByRepos activeRepos rdRepoName pkgss of - Right x -> return x + Right x -> return x Left err -> warn verbosity err >> return (map (\x -> (x, CombineStrategyMerge)) pkgss) let activeRepos' :: ActiveRepos - activeRepos' = ActiveRepos + activeRepos' = + ActiveRepos [ ActiveRepo (rdRepoName rd) strategy | (rd, strategy) <- pkgss' ] let totalIndexState :: TotalIndexState - totalIndexState = makeTotalIndexState IndexStateHead $ Map.fromList - [ (n, IndexStateTime ts) - | (RepoData n ts _idx _prefs, _strategy) <- pkgss' - -- e.g. file+noindex have nullTimestamp as their timestamp - , ts /= nullTimestamp - ] + totalIndexState = + makeTotalIndexState IndexStateHead $ + Map.fromList + [ (n, IndexStateTime ts) + | (RepoData n ts _idx _prefs, _strategy) <- pkgss' + , -- e.g. file+noindex have nullTimestamp as their timestamp + ts /= nullTimestamp + ] let addIndex - :: PackageIndex UnresolvedSourcePackage - -> (RepoData, CombineStrategy) - -> PackageIndex UnresolvedSourcePackage - addIndex acc (RepoData _ _ _ _, CombineStrategySkip) = acc - addIndex acc (RepoData _ _ idx _, CombineStrategyMerge) = PackageIndex.merge acc idx + :: PackageIndex UnresolvedSourcePackage + -> (RepoData, CombineStrategy) + -> PackageIndex UnresolvedSourcePackage + addIndex acc (RepoData _ _ _ _, CombineStrategySkip) = acc + addIndex acc (RepoData _ _ idx _, CombineStrategyMerge) = PackageIndex.merge acc idx addIndex acc (RepoData _ _ idx _, CombineStrategyOverride) = PackageIndex.override acc idx let pkgs :: PackageIndex UnresolvedSourcePackage @@ -331,7 +398,9 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do -- Note: preferences combined without using CombineStrategy let prefs :: Map PackageName VersionRange - prefs = Map.fromListWith intersectVersionRanges + prefs = + Map.fromListWith + intersectVersionRanges [ (name, range) | (RepoData _n _ts _idx prefs', _strategy) <- pkgss' , Dependency name range _ <- prefs' @@ -340,18 +409,22 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do _ <- evaluate pkgs _ <- evaluate prefs _ <- evaluate totalIndexState - return (SourcePackageDb { - packageIndex = pkgs, - packagePreferences = prefs - }, totalIndexState, activeRepos') + return + ( SourcePackageDb + { packageIndex = pkgs + , packagePreferences = prefs + } + , totalIndexState + , activeRepos' + ) -- auxiliary data used in getSourcePackagesAtIndexState data RepoData = RepoData - { rdRepoName :: RepoName - , rdTimeStamp :: Timestamp - , rdIndex :: PackageIndex UnresolvedSourcePackage - , rdPreferences :: [Dependency] - } + { rdRepoName :: RepoName + , rdTimeStamp :: Timestamp + , rdIndex :: PackageIndex UnresolvedSourcePackage + , rdPreferences :: [Dependency] + } -- | Read a repository index from disk, from the local file specified by -- the 'Repo'. @@ -359,60 +432,71 @@ data RepoData = RepoData -- All the 'SourcePackage's are marked as having come from the given 'Repo'. -- -- This is a higher level wrapper used internally in cabal-install. --- -readRepoIndex :: Verbosity -> RepoContext -> Repo -> RepoIndexState - -> IO (PackageIndex UnresolvedSourcePackage, [Dependency], IndexStateInfo) +readRepoIndex + :: Verbosity + -> RepoContext + -> Repo + -> RepoIndexState + -> IO (PackageIndex UnresolvedSourcePackage, [Dependency], IndexStateInfo) readRepoIndex verbosity repoCtxt repo idxState = handleNotFound $ do when (isRepoRemote repo) $ warnIfIndexIsOld =<< getIndexFileAge repo -- note that if this step fails due to a bad repo cache, the the procedure can still succeed by reading from the existing cache, which is updated regardless. - updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) `catchIO` - (\e -> warn verbosity $ "unable to update the repo index cache -- " ++ displayException e) - readPackageIndexCacheFile verbosity mkAvailablePackage - (RepoIndex repoCtxt repo) - idxState - + updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) + `catchIO` (\e -> warn verbosity $ "unable to update the repo index cache -- " ++ displayException e) + readPackageIndexCacheFile + verbosity + mkAvailablePackage + (RepoIndex repoCtxt repo) + idxState where - mkAvailablePackage pkgEntry = SourcePackage - { srcpkgPackageId = pkgid - , srcpkgDescription = pkgdesc - , srcpkgSource = case pkgEntry of - NormalPackage _ _ _ _ -> RepoTarballPackage repo pkgid Nothing - BuildTreeRef _ _ _ path _ -> LocalUnpackedPackage path - , srcpkgDescrOverride = case pkgEntry of - NormalPackage _ _ pkgtxt _ -> Just pkgtxt - _ -> Nothing - } + mkAvailablePackage pkgEntry = + SourcePackage + { srcpkgPackageId = pkgid + , srcpkgDescription = pkgdesc + , srcpkgSource = case pkgEntry of + NormalPackage _ _ _ _ -> RepoTarballPackage repo pkgid Nothing + BuildTreeRef _ _ _ path _ -> LocalUnpackedPackage path + , srcpkgDescrOverride = case pkgEntry of + NormalPackage _ _ pkgtxt _ -> Just pkgtxt + _ -> Nothing + } where pkgdesc = packageDesc pkgEntry pkgid = packageId pkgEntry - handleNotFound action = catchIO action $ \e -> if isDoesNotExistError e - then do - case repo of - RepoRemote{..} -> warn verbosity $ errMissingPackageList repoRemote - RepoSecure{..} -> warn verbosity $ errMissingPackageList repoRemote - RepoLocalNoIndex local _ -> warn verbosity $ - "Error during construction of local+noindex " - ++ unRepoName (localRepoName local) ++ " repository index: " - ++ show e - return (mempty,mempty,emptyStateInfo) - else ioError e - - isOldThreshold = 15 --days + handleNotFound action = catchIO action $ \e -> + if isDoesNotExistError e + then do + case repo of + RepoRemote{..} -> warn verbosity $ errMissingPackageList repoRemote + RepoSecure{..} -> warn verbosity $ errMissingPackageList repoRemote + RepoLocalNoIndex local _ -> + warn verbosity $ + "Error during construction of local+noindex " + ++ unRepoName (localRepoName local) + ++ " repository index: " + ++ show e + return (mempty, mempty, emptyStateInfo) + else ioError e + + isOldThreshold = 15 -- days warnIfIndexIsOld dt = do when (dt >= isOldThreshold) $ case repo of RepoRemote{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt RepoSecure{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt - RepoLocalNoIndex {} -> return () + RepoLocalNoIndex{} -> return () errMissingPackageList repoRemote = - "The package list for '" ++ unRepoName (remoteRepoName repoRemote) - ++ "' does not exist. Run 'cabal update' to download it." + "The package list for '" + ++ unRepoName (remoteRepoName repoRemote) + ++ "' does not exist. Run 'cabal update' to download it." errOutdatedPackageList repoRemote dt = - "The package list for '" ++ unRepoName (remoteRepoName repoRemote) - ++ "' is " ++ shows (floor dt :: Int) " days old.\nRun " - ++ "'cabal update' to get the latest list of available packages." + "The package list for '" + ++ unRepoName (remoteRepoName repoRemote) + ++ "' is " + ++ shows (floor dt :: Int) " days old.\nRun " + ++ "'cabal update' to get the latest list of available packages." -- | Return the age of the index file in days (as a Double). getIndexFileAge :: Repo -> IO Double @@ -420,34 +504,36 @@ getIndexFileAge repo = getFileAge $ indexBaseName repo <.> "tar" -- | A set of files (or directories) that can be monitored to detect when -- there might have been a change in the source packages. --- getSourcePackagesMonitorFiles :: [Repo] -> [FilePath] getSourcePackagesMonitorFiles repos = - concat [ [ indexBaseName repo <.> "cache" - , indexBaseName repo <.> "timestamp" ] - | repo <- repos ] + concat + [ [ indexBaseName repo <.> "cache" + , indexBaseName repo <.> "timestamp" + ] + | repo <- repos + ] -- | It is not necessary to call this, as the cache will be updated when the -- index is read normally. However you can do the work earlier if you like. --- updateRepoIndexCache :: Verbosity -> Index -> IO () updateRepoIndexCache verbosity index = - whenCacheOutOfDate index $ updatePackageIndexCacheFile verbosity index + whenCacheOutOfDate index $ updatePackageIndexCacheFile verbosity index whenCacheOutOfDate :: Index -> IO () -> IO () whenCacheOutOfDate index action = do exists <- doesFileExist $ cacheFile index if not exists - then action - else if localNoIndex index - then return () -- TODO: don't update cache for local+noindex repositories - else do + then action + else + if localNoIndex index + then return () -- TODO: don't update cache for local+noindex repositories + else do indexTime <- getModTime $ indexFile index cacheTime <- getModTime $ cacheFile index when (indexTime > cacheTime) action localNoIndex :: Index -> Bool -localNoIndex (RepoIndex _ (RepoLocalNoIndex {})) = True +localNoIndex (RepoIndex _ (RepoLocalNoIndex{})) = True localNoIndex _ = False ------------------------------------------------------------------------ @@ -456,40 +542,42 @@ localNoIndex _ = False -- | An index entry is either a normal package, or a local build tree reference. data PackageEntry - = NormalPackage PackageId GenericPackageDescription ByteString BlockNo - | BuildTreeRef BuildTreeRefType - PackageId GenericPackageDescription FilePath BlockNo + = NormalPackage PackageId GenericPackageDescription ByteString BlockNo + | BuildTreeRef + BuildTreeRefType + PackageId + GenericPackageDescription + FilePath + BlockNo -- | A build tree reference is either a link or a snapshot. data BuildTreeRefType = SnapshotRef | LinkRef - deriving (Eq,Show,Generic) + deriving (Eq, Show, Generic) instance Binary BuildTreeRefType instance Structured BuildTreeRefType refTypeFromTypeCode :: Tar.TypeCode -> BuildTreeRefType refTypeFromTypeCode t - | t == Tar.buildTreeRefTypeCode = LinkRef + | t == Tar.buildTreeRefTypeCode = LinkRef | t == Tar.buildTreeSnapshotTypeCode = SnapshotRef - | otherwise = - error "Distribution.Client.IndexUtils.refTypeFromTypeCode: unknown type code" + | otherwise = + error "Distribution.Client.IndexUtils.refTypeFromTypeCode: unknown type code" typeCodeFromRefType :: BuildTreeRefType -> Tar.TypeCode -typeCodeFromRefType LinkRef = Tar.buildTreeRefTypeCode +typeCodeFromRefType LinkRef = Tar.buildTreeRefTypeCode typeCodeFromRefType SnapshotRef = Tar.buildTreeSnapshotTypeCode instance Package PackageEntry where - packageId (NormalPackage pkgid _ _ _) = pkgid + packageId (NormalPackage pkgid _ _ _) = pkgid packageId (BuildTreeRef _ pkgid _ _ _) = pkgid packageDesc :: PackageEntry -> GenericPackageDescription -packageDesc (NormalPackage _ descr _ _) = descr +packageDesc (NormalPackage _ descr _ _) = descr packageDesc (BuildTreeRef _ _ descr _ _) = descr -- | Parse an uncompressed \"00-index.tar\" repository index file represented -- as a 'ByteString'. --- - data PackageOrDep = Pkg PackageEntry | Dep Dependency -- | Read @00-index.tar.gz@ and extract @.cabal@ and @preferred-versions@ files @@ -522,53 +610,59 @@ parsePackageIndex verbosity = concatMap (uncurry extract) . tarEntriesList . Tar tarEntriesList :: Show e => Tar.Entries e -> [(BlockNo, Tar.Entry)] tarEntriesList = go 0 where - go !_ Tar.Done = [] - go !_ (Tar.Fail e) = error ("tarEntriesList: " ++ show e) + go !_ Tar.Done = [] + go !_ (Tar.Fail e) = error ("tarEntriesList: " ++ show e) go !n (Tar.Next e es') = (n, e) : go (Tar.nextEntryOffset e n) es' extractPkg :: Verbosity -> Tar.Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry)) extractPkg verbosity entry blockNo = case Tar.entryContent entry of Tar.NormalFile content _ - | takeExtension fileName == ".cabal" - -> case splitDirectories (normalise fileName) of - [pkgname,vers,_] -> case simpleParsec vers of - Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo) - where - pkgid = PackageIdentifier (mkPackageName pkgname) ver - parsed = parseGenericPackageDescriptionMaybe (BS.toStrict content) - descr = case parsed of - Just d -> d - Nothing -> error $ "Couldn't read cabal file " - ++ show fileName + | takeExtension fileName == ".cabal" -> + case splitDirectories (normalise fileName) of + [pkgname, vers, _] -> case simpleParsec vers of + Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo) + where + pkgid = PackageIdentifier (mkPackageName pkgname) ver + parsed = parseGenericPackageDescriptionMaybe (BS.toStrict content) + descr = case parsed of + Just d -> d + Nothing -> + error $ + "Couldn't read cabal file " + ++ show fileName + _ -> Nothing _ -> Nothing - _ -> Nothing - Tar.OtherEntryType typeCode content _ | Tar.isBuildTreeRefTypeCode typeCode -> - Just $ do - let path = byteStringToFilePath content - dirExists <- doesDirectoryExist path - result <- if not dirExists then return Nothing - else do - cabalFile <- tryFindAddSourcePackageDesc verbosity path "Error reading package index." - descr <- PackageDesc.Parse.readGenericPackageDescription normal cabalFile - return . Just $ BuildTreeRef (refTypeFromTypeCode typeCode) (packageId descr) - descr path blockNo - return result - + Just $ do + let path = byteStringToFilePath content + dirExists <- doesDirectoryExist path + result <- + if not dirExists + then return Nothing + else do + cabalFile <- tryFindAddSourcePackageDesc verbosity path "Error reading package index." + descr <- PackageDesc.Parse.readGenericPackageDescription normal cabalFile + return . Just $ + BuildTreeRef + (refTypeFromTypeCode typeCode) + (packageId descr) + descr + path + blockNo + return result _ -> Nothing - where fileName = Tar.entryPath entry extractPrefs :: Tar.Entry -> Maybe [Dependency] extractPrefs entry = case Tar.entryContent entry of Tar.NormalFile content _ - | isPreferredVersions entrypath - -> Just prefs + | isPreferredVersions entrypath -> + Just prefs where entrypath = Tar.entryPath entry - prefs = parsePreferredVersions content + prefs = parsePreferredVersions content _ -> Nothing ------------------------------------------------------------------------ @@ -601,30 +695,33 @@ parsePreferredVersions = rights . parsePreferredVersionsWarnings -- | Parser error of the `preferred-versions` file. data PreferredVersionsParseError = PreferredVersionsParseError - { preferredVersionsParsecError :: String - -- ^ Parser error to show to a user. - , preferredVersionsOriginalDependency :: String - -- ^ Original input that produced the parser error. - } + { preferredVersionsParsecError :: String + -- ^ Parser error to show to a user. + , preferredVersionsOriginalDependency :: String + -- ^ Original input that produced the parser error. + } deriving (Generic, Read, Show, Eq, Ord, Typeable) -- | Parse `preferred-versions` file, collecting parse errors that can be shown -- in error messages. -parsePreferredVersionsWarnings :: ByteString - -> [Either PreferredVersionsParseError Dependency] +parsePreferredVersionsWarnings + :: ByteString + -> [Either PreferredVersionsParseError Dependency] parsePreferredVersionsWarnings = map parsePreference - . filter (not . isPrefixOf "--") - . lines - . fromUTF8LBS - where - parsePreference :: String -> Either PreferredVersionsParseError Dependency - parsePreference s = case eitherParsec s of - Left err -> Left $ PreferredVersionsParseError - { preferredVersionsParsecError = err - , preferredVersionsOriginalDependency = s - } - Right dep -> Right dep + . filter (not . isPrefixOf "--") + . lines + . fromUTF8LBS + where + parsePreference :: String -> Either PreferredVersionsParseError Dependency + parsePreference s = case eitherParsec s of + Left err -> + Left $ + PreferredVersionsParseError + { preferredVersionsParsecError = err + , preferredVersionsOriginalDependency = s + } + Right dep -> Right dep ------------------------------------------------------------------------ -- Reading and updating the index cache @@ -638,71 +735,75 @@ parsePreferredVersionsWarnings = lazySequence :: [IO a] -> IO [a] lazySequence = unsafeInterleaveIO . go where - go [] = return [] - go (x:xs) = do x' <- x - xs' <- lazySequence xs - return (x' : xs') + go [] = return [] + go (x : xs) = do + x' <- x + xs' <- lazySequence xs + return (x' : xs') -- | A lazy unfolder for lookup operations which return the current -- value and (possibly) the next key -lazyUnfold :: (k -> IO (v, Maybe k)) -> k -> IO [(k,v)] +lazyUnfold :: (k -> IO (v, Maybe k)) -> k -> IO [(k, v)] lazyUnfold step = goLazy . Just where goLazy s = unsafeInterleaveIO (go s) - go Nothing = return [] + go Nothing = return [] go (Just k) = do - (v, mk') <- step k - vs' <- goLazy mk' - return ((k,v):vs') + (v, mk') <- step k + vs' <- goLazy mk' + return ((k, v) : vs') -- | Which index do we mean? -data Index = - -- | The main index for the specified repository +data Index + = -- | The main index for the specified repository RepoIndex RepoContext Repo - - -- | A sandbox-local repository + | -- | A sandbox-local repository -- Argument is the location of the index file - | SandboxIndex FilePath + SandboxIndex FilePath indexFile :: Index -> FilePath indexFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "tar" -indexFile (SandboxIndex index) = index +indexFile (SandboxIndex index) = index cacheFile :: Index -> FilePath cacheFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "cache" -cacheFile (SandboxIndex index) = index `replaceExtension` "cache" +cacheFile (SandboxIndex index) = index `replaceExtension` "cache" timestampFile :: Index -> FilePath timestampFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "timestamp" -timestampFile (SandboxIndex index) = index `replaceExtension` "timestamp" +timestampFile (SandboxIndex index) = index `replaceExtension` "timestamp" -- | Return 'True' if 'Index' uses 01-index format (aka secure repo) is01Index :: Index -> Bool is01Index (RepoIndex _ repo) = case repo of - RepoSecure {} -> True - RepoRemote {} -> False - RepoLocalNoIndex {} -> True -is01Index (SandboxIndex _) = False - + RepoSecure{} -> True + RepoRemote{} -> False + RepoLocalNoIndex{} -> True +is01Index (SandboxIndex _) = False updatePackageIndexCacheFile :: Verbosity -> Index -> IO () updatePackageIndexCacheFile verbosity index = do - info verbosity ("Updating index cache file " ++ cacheFile index ++ " ...") - withIndexEntries verbosity index callback callbackNoIndex + info verbosity ("Updating index cache file " ++ cacheFile index ++ " ...") + withIndexEntries verbosity index callback callbackNoIndex where callback entries = do - let !maxTs = maximumTimestamp (map cacheEntryTimestamp entries) - cache = Cache { cacheHeadTs = maxTs - , cacheEntries = entries - } - writeIndexCache index cache - info verbosity ("Index cache updated to index-state " - ++ prettyShow (cacheHeadTs cache)) + let !maxTs = maximumTimestamp (map cacheEntryTimestamp entries) + cache = + Cache + { cacheHeadTs = maxTs + , cacheEntries = entries + } + writeIndexCache index cache + info + verbosity + ( "Index cache updated to index-state " + ++ prettyShow (cacheHeadTs cache) + ) callbackNoIndex entries = do - writeNoIndexCache verbosity index $ NoIndexCache entries - info verbosity "Index cache updated" + writeNoIndexCache verbosity index $ NoIndexCache entries + info verbosity "Index cache updated" -- | Read the index (for the purpose of building a cache) -- @@ -725,176 +826,188 @@ updatePackageIndexCacheFile verbosity index = do -- cache, rather than reconstruct it from zero on each update. However, this -- would require a change in the cache format. withIndexEntries - :: Verbosity -> Index - -> ([IndexCacheEntry] -> IO a) - -> ([NoIndexCacheEntry] -> IO a) - -> IO a + :: Verbosity + -> Index + -> ([IndexCacheEntry] -> IO a) + -> ([NoIndexCacheEntry] -> IO a) + -> IO a withIndexEntries _ (RepoIndex repoCtxt repo@RepoSecure{}) callback _ = - repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> - Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do - -- Incrementally (lazily) read all the entries in the tar file in order, - -- including all revisions, not just the last revision of each file - indexEntries <- lazyUnfold indexLookupEntry (Sec.directoryFirst indexDirectory) - callback [ cacheEntry - | (dirEntry, indexEntry) <- indexEntries - , cacheEntry <- toCacheEntries dirEntry indexEntry ] + repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> + Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do + -- Incrementally (lazily) read all the entries in the tar file in order, + -- including all revisions, not just the last revision of each file + indexEntries <- lazyUnfold indexLookupEntry (Sec.directoryFirst indexDirectory) + callback + [ cacheEntry + | (dirEntry, indexEntry) <- indexEntries + , cacheEntry <- toCacheEntries dirEntry indexEntry + ] where - toCacheEntries :: Sec.DirectoryEntry -> Sec.Some Sec.IndexEntry - -> [IndexCacheEntry] + toCacheEntries + :: Sec.DirectoryEntry + -> Sec.Some Sec.IndexEntry + -> [IndexCacheEntry] toCacheEntries dirEntry (Sec.Some sie) = - case Sec.indexEntryPathParsed sie of - Nothing -> [] -- skip unrecognized file - Just (Sec.IndexPkgMetadata _pkgId) -> [] -- skip metadata - Just (Sec.IndexPkgCabal pkgId) -> force - [CachePackageId pkgId blockNo timestamp] - Just (Sec.IndexPkgPrefs _pkgName) -> force - [ CachePreference dep blockNo timestamp - | dep <- parsePreferredVersions (Sec.indexEntryContent sie) - ] + case Sec.indexEntryPathParsed sie of + Nothing -> [] -- skip unrecognized file + Just (Sec.IndexPkgMetadata _pkgId) -> [] -- skip metadata + Just (Sec.IndexPkgCabal pkgId) -> + force + [CachePackageId pkgId blockNo timestamp] + Just (Sec.IndexPkgPrefs _pkgName) -> + force + [ CachePreference dep blockNo timestamp + | dep <- parsePreferredVersions (Sec.indexEntryContent sie) + ] where blockNo = Sec.directoryEntryBlockNo dirEntry - timestamp = fromMaybe (error "withIndexEntries: invalid timestamp") $ - epochTimeToTimestamp $ Sec.indexEntryTime sie - + timestamp = + fromMaybe (error "withIndexEntries: invalid timestamp") $ + epochTimeToTimestamp $ + Sec.indexEntryTime sie withIndexEntries verbosity (RepoIndex _repoCtxt (RepoLocalNoIndex (LocalRepo name localDir _) _cacheDir)) _ callback = do - dirContents <- listDirectory localDir - let contentSet = Set.fromList dirContents - - entries <- handle handler $ fmap catMaybes $ for dirContents $ \file -> do - case isTarGz file of - Nothing - | isPreferredVersions file -> do - contents <- BS.readFile (localDir file) - let versionPreferencesParsed = parsePreferredVersionsWarnings contents - let (warnings, versionPreferences) = partitionEithers versionPreferencesParsed - unless (null warnings) $ do - warn verbosity $ - "withIndexEntries: failed to parse some entries of \"preferred-versions\" found at: " - ++ (localDir file) - for_ warnings $ \err -> do - warn verbosity $ "* \"" ++ preferredVersionsOriginalDependency err - warn verbosity $ "Parser Error: " ++ preferredVersionsParsecError err - return $ Just $ NoIndexCachePreference versionPreferences - | otherwise -> do - unless (takeFileName file == "noindex.cache" || ".cabal" `isSuffixOf` file) $ - info verbosity $ "Skipping " ++ file - return Nothing - Just pkgid | cabalPath `Set.member` contentSet -> do - contents <- BSS.readFile (localDir cabalPath) - for (parseGenericPackageDescriptionMaybe contents) $ \gpd -> - return (CacheGPD gpd contents) - where - cabalPath = prettyShow pkgid ++ ".cabal" - Just pkgId -> do - -- check for the right named .cabal file in the compressed tarball - tarGz <- BS.readFile (localDir file) - let tar = GZip.decompress tarGz - entries = Tar.read tar - - case Tar.foldEntries (readCabalEntry pkgId) Nothing (const Nothing) entries of - Just ce -> return (Just ce) - Nothing -> die' verbosity $ "Cannot read .cabal file inside " ++ file - - let (prefs, gpds) = partitionEithers $ map - (\case + dirContents <- listDirectory localDir + let contentSet = Set.fromList dirContents + + entries <- handle handler $ fmap catMaybes $ for dirContents $ \file -> do + case isTarGz file of + Nothing + | isPreferredVersions file -> do + contents <- BS.readFile (localDir file) + let versionPreferencesParsed = parsePreferredVersionsWarnings contents + let (warnings, versionPreferences) = partitionEithers versionPreferencesParsed + unless (null warnings) $ do + warn verbosity $ + "withIndexEntries: failed to parse some entries of \"preferred-versions\" found at: " + ++ (localDir file) + for_ warnings $ \err -> do + warn verbosity $ "* \"" ++ preferredVersionsOriginalDependency err + warn verbosity $ "Parser Error: " ++ preferredVersionsParsecError err + return $ Just $ NoIndexCachePreference versionPreferences + | otherwise -> do + unless (takeFileName file == "noindex.cache" || ".cabal" `isSuffixOf` file) $ + info verbosity $ + "Skipping " ++ file + return Nothing + Just pkgid | cabalPath `Set.member` contentSet -> do + contents <- BSS.readFile (localDir cabalPath) + for (parseGenericPackageDescriptionMaybe contents) $ \gpd -> + return (CacheGPD gpd contents) + where + cabalPath = prettyShow pkgid ++ ".cabal" + Just pkgId -> do + -- check for the right named .cabal file in the compressed tarball + tarGz <- BS.readFile (localDir file) + let tar = GZip.decompress tarGz + entries = Tar.read tar + + case Tar.foldEntries (readCabalEntry pkgId) Nothing (const Nothing) entries of + Just ce -> return (Just ce) + Nothing -> die' verbosity $ "Cannot read .cabal file inside " ++ file + + let (prefs, gpds) = + partitionEithers $ + map + ( \case NoIndexCachePreference deps -> Left deps CacheGPD gpd _ -> Right gpd ) entries - info verbosity $ "Entries in file+noindex repository " ++ unRepoName name - for_ gpds $ \gpd -> - info verbosity $ "- " ++ prettyShow (package $ Distribution.PackageDescription.packageDescription gpd) - unless (null prefs) $ do - info verbosity $ "Preferred versions in file+noindex repository " ++ unRepoName name - for_ (concat prefs) $ \pref -> - info verbosity ("* " ++ prettyShow pref) + info verbosity $ "Entries in file+noindex repository " ++ unRepoName name + for_ gpds $ \gpd -> + info verbosity $ "- " ++ prettyShow (package $ Distribution.PackageDescription.packageDescription gpd) + unless (null prefs) $ do + info verbosity $ "Preferred versions in file+noindex repository " ++ unRepoName name + for_ (concat prefs) $ \pref -> + info verbosity ("* " ++ prettyShow pref) - callback entries + callback entries where handler :: IOException -> IO a handler e = die' verbosity $ "Error while updating index for " ++ unRepoName name ++ " repository " ++ show e isTarGz :: FilePath -> Maybe PackageIdentifier isTarGz fp = do - pfx <- stripSuffix ".tar.gz" fp - simpleParsec pfx + pfx <- stripSuffix ".tar.gz" fp + simpleParsec pfx stripSuffix sfx str = fmap reverse (stripPrefix (reverse sfx) (reverse str)) -- look for /.cabal inside the tarball readCabalEntry :: PackageIdentifier -> Tar.Entry -> Maybe NoIndexCacheEntry -> Maybe NoIndexCacheEntry readCabalEntry pkgId entry Nothing - | filename == Tar.entryPath entry - , Tar.NormalFile contents _ <- Tar.entryContent entry - = let bs = BS.toStrict contents - in fmap (\gpd -> CacheGPD gpd bs) $ parseGenericPackageDescriptionMaybe bs + | filename == Tar.entryPath entry + , Tar.NormalFile contents _ <- Tar.entryContent entry = + let bs = BS.toStrict contents + in fmap (\gpd -> CacheGPD gpd bs) $ parseGenericPackageDescriptionMaybe bs where - filename = prettyShow pkgId FilePath.Posix. prettyShow (packageName pkgId) ++ ".cabal" + filename = prettyShow pkgId FilePath.Posix. prettyShow (packageName pkgId) ++ ".cabal" readCabalEntry _ _ x = x - -withIndexEntries verbosity index callback _ = do -- non-secure repositories - withFile (indexFile index) ReadMode $ \h -> do - bs <- maybeDecompress `fmap` BS.hGetContents h - pkgsOrPrefs <- lazySequence $ parsePackageIndex verbosity bs - callback $ map toCache (catMaybes pkgsOrPrefs) +withIndexEntries verbosity index callback _ = do + -- non-secure repositories + withFile (indexFile index) ReadMode $ \h -> do + bs <- maybeDecompress `fmap` BS.hGetContents h + pkgsOrPrefs <- lazySequence $ parsePackageIndex verbosity bs + callback $ map toCache (catMaybes pkgsOrPrefs) where toCache :: PackageOrDep -> IndexCacheEntry toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo nullTimestamp toCache (Pkg (BuildTreeRef refType _ _ _ blockNo)) = CacheBuildTreeRef refType blockNo toCache (Dep d) = CachePreference d 0 nullTimestamp -readPackageIndexCacheFile :: Package pkg - => Verbosity - -> (PackageEntry -> pkg) - -> Index - -> RepoIndexState - -> IO (PackageIndex pkg, [Dependency], IndexStateInfo) +readPackageIndexCacheFile + :: Package pkg + => Verbosity + -> (PackageEntry -> pkg) + -> Index + -> RepoIndexState + -> IO (PackageIndex pkg, [Dependency], IndexStateInfo) readPackageIndexCacheFile verbosity mkPkg index idxState - | localNoIndex index = do - cache0 <- readNoIndexCache verbosity index - (pkgs, prefs) <- packageNoIndexFromCache verbosity mkPkg cache0 - pure (pkgs, prefs, emptyStateInfo) - - | otherwise = do - cache0 <- readIndexCache verbosity index - indexHnd <- openFile (indexFile index) ReadMode - let (cache,isi) = filterCache idxState cache0 - (pkgs,deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache - pure (pkgs,deps,isi) - -packageIndexFromCache :: Package pkg - => Verbosity - -> (PackageEntry -> pkg) - -> Handle - -> Cache - -> IO (PackageIndex pkg, [Dependency]) + | localNoIndex index = do + cache0 <- readNoIndexCache verbosity index + (pkgs, prefs) <- packageNoIndexFromCache verbosity mkPkg cache0 + pure (pkgs, prefs, emptyStateInfo) + | otherwise = do + cache0 <- readIndexCache verbosity index + indexHnd <- openFile (indexFile index) ReadMode + let (cache, isi) = filterCache idxState cache0 + (pkgs, deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache + pure (pkgs, deps, isi) + +packageIndexFromCache + :: Package pkg + => Verbosity + -> (PackageEntry -> pkg) + -> Handle + -> Cache + -> IO (PackageIndex pkg, [Dependency]) packageIndexFromCache verbosity mkPkg hnd cache = do - (pkgs, prefs) <- packageListFromCache verbosity mkPkg hnd cache - pkgIndex <- evaluate $ PackageIndex.fromList pkgs - return (pkgIndex, prefs) + (pkgs, prefs) <- packageListFromCache verbosity mkPkg hnd cache + pkgIndex <- evaluate $ PackageIndex.fromList pkgs + return (pkgIndex, prefs) packageNoIndexFromCache - :: forall pkg. Package pkg - => Verbosity - -> (PackageEntry -> pkg) - -> NoIndexCache - -> IO (PackageIndex pkg, [Dependency]) + :: forall pkg + . Package pkg + => Verbosity + -> (PackageEntry -> pkg) + -> NoIndexCache + -> IO (PackageIndex pkg, [Dependency]) packageNoIndexFromCache _verbosity mkPkg cache = do - let (pkgs, prefs) = packageListFromNoIndexCache - pkgIndex <- evaluate $ PackageIndex.fromList pkgs - pure (pkgIndex, prefs) + let (pkgs, prefs) = packageListFromNoIndexCache + pkgIndex <- evaluate $ PackageIndex.fromList pkgs + pure (pkgIndex, prefs) where packageListFromNoIndexCache :: ([pkg], [Dependency]) packageListFromNoIndexCache = foldr go mempty (noIndexCacheEntries cache) go :: NoIndexCacheEntry -> ([pkg], [Dependency]) -> ([pkg], [Dependency]) go (CacheGPD gpd bs) (pkgs, prefs) = - let pkgId = package $ Distribution.PackageDescription.packageDescription gpd - in (mkPkg (NormalPackage pkgId gpd (BS.fromStrict bs) 0) : pkgs, prefs) + let pkgId = package $ Distribution.PackageDescription.packageDescription gpd + in (mkPkg (NormalPackage pkgId gpd (BS.fromStrict bs) 0) : pkgs, prefs) go (NoIndexCachePreference deps) (pkgs, prefs) = - (pkgs, deps ++ prefs) - + (pkgs, deps ++ prefs) -- | Read package list -- @@ -905,15 +1018,15 @@ packageNoIndexFromCache _verbosity mkPkg cache = do -- all .cabal edits and preference-updates. The masking happens -- here, i.e. the semantics that later entries in a tar file mask -- earlier ones is resolved in this function. -packageListFromCache :: Verbosity - -> (PackageEntry -> pkg) - -> Handle - -> Cache - -> IO ([pkg], [Dependency]) +packageListFromCache + :: Verbosity + -> (PackageEntry -> pkg) + -> Handle + -> Cache + -> IO ([pkg], [Dependency]) packageListFromCache verbosity mkPkg hnd Cache{..} = accum mempty [] mempty cacheEntries where accum !srcpkgs btrs !prefs [] = return (Map.elems srcpkgs ++ btrs, Map.elems prefs) - accum srcpkgs btrs prefs (CachePackageId pkgid blockno _ : entries) = do -- Given the cache entry, make a package index entry. -- The magic here is that we use lazy IO to read the .cabal file @@ -921,23 +1034,22 @@ packageListFromCache verbosity mkPkg hnd Cache{..} = accum mempty [] mempty cach -- Most of the time we only need the package id. ~(pkg, pkgtxt) <- unsafeInterleaveIO $ do pkgtxt <- getEntryContent blockno - pkg <- readPackageDescription pkgid pkgtxt + pkg <- readPackageDescription pkgid pkgtxt return (pkg, pkgtxt) let srcpkg = mkPkg (NormalPackage pkgid pkg pkgtxt blockno) accum (Map.insert pkgid srcpkg srcpkgs) btrs prefs entries - accum srcpkgs btrs prefs (CacheBuildTreeRef refType blockno : entries) = do -- We have to read the .cabal file eagerly here because we can't cache the -- package id for build tree references - the user might edit the .cabal -- file after the reference was added to the index. path <- liftM byteStringToFilePath . getEntryContent $ blockno - pkg <- do let err = "Error reading package index from cache." - file <- tryFindAddSourcePackageDesc verbosity path err - PackageDesc.Parse.readGenericPackageDescription normal file + pkg <- do + let err = "Error reading package index from cache." + file <- tryFindAddSourcePackageDesc verbosity path err + PackageDesc.Parse.readGenericPackageDescription normal file let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno) - accum srcpkgs (srcpkg:btrs) prefs entries - + accum srcpkgs (srcpkg : btrs) prefs entries accum srcpkgs btrs prefs (CachePreference pref@(Dependency pn _ _) _ _ : entries) = accum srcpkgs btrs (Map.insert pn pref prefs) entries @@ -947,41 +1059,44 @@ packageListFromCache verbosity mkPkg hnd Cache{..} = accum mempty [] mempty cach case Tar.entryContent entry of Tar.NormalFile content _size -> return content Tar.OtherEntryType typecode content _size - | Tar.isBuildTreeRefTypeCode typecode - -> return content + | Tar.isBuildTreeRefTypeCode typecode -> + return content _ -> interror "unexpected tar entry type" readPackageDescription :: PackageIdentifier -> ByteString -> IO GenericPackageDescription readPackageDescription pkgid content = case snd $ PackageDesc.Parse.runParseResult $ parseGenericPackageDescription $ BS.toStrict content of - Right gpd -> return gpd - Left (Just specVer, _) | specVer >= mkVersion [2,2] -> return (dummyPackageDescription specVer) - Left _ -> interror "failed to parse .cabal file" + Right gpd -> return gpd + Left (Just specVer, _) | specVer >= mkVersion [2, 2] -> return (dummyPackageDescription specVer) + Left _ -> interror "failed to parse .cabal file" where dummyPackageDescription :: Version -> GenericPackageDescription - dummyPackageDescription specVer = GenericPackageDescription - { packageDescription = emptyPackageDescription - { package = pkgid - , synopsis = dummySynopsis - } + dummyPackageDescription specVer = + GenericPackageDescription + { packageDescription = + emptyPackageDescription + { package = pkgid + , synopsis = dummySynopsis + } , gpdScannedVersion = Just specVer -- tells index scanner to skip this file. - , genPackageFlags = [] - , condLibrary = Nothing + , genPackageFlags = [] + , condLibrary = Nothing , condSubLibraries = [] - , condForeignLibs = [] - , condExecutables = [] - , condTestSuites = [] - , condBenchmarks = [] + , condForeignLibs = [] + , condExecutables = [] + , condTestSuites = [] + , condBenchmarks = [] } dummySynopsis = "" interror :: String -> IO a - interror msg = die' verbosity $ "internal error when reading package index: " ++ msg - ++ "The package index or index cache is probably " - ++ "corrupt. Running cabal update might fix it." - - + interror msg = + die' verbosity $ + "internal error when reading package index: " + ++ msg + ++ "The package index or index cache is probably " + ++ "corrupt. Running cabal update might fix it." ------------------------------------------------------------------------ -- Index cache data structure -- @@ -993,44 +1108,50 @@ packageListFromCache verbosity mkPkg hnd Cache{..} = accum mempty [] mempty cach -- 'die's if it fails again). readIndexCache :: Verbosity -> Index -> IO Cache readIndexCache verbosity index = do - cacheOrFail <- readIndexCache' index - case cacheOrFail of - Left msg -> do - warn verbosity $ concat - [ "Parsing the index cache failed (", msg, "). " - , "Trying to regenerate the index cache..." - ] - - updatePackageIndexCacheFile verbosity index + cacheOrFail <- readIndexCache' index + case cacheOrFail of + Left msg -> do + warn verbosity $ + concat + [ "Parsing the index cache failed (" + , msg + , "). " + , "Trying to regenerate the index cache..." + ] - either (die' verbosity) (return . hashConsCache) =<< readIndexCache' index + updatePackageIndexCacheFile verbosity index - Right res -> return (hashConsCache res) + either (die' verbosity) (return . hashConsCache) =<< readIndexCache' index + Right res -> return (hashConsCache res) readNoIndexCache :: Verbosity -> Index -> IO NoIndexCache readNoIndexCache verbosity index = do - cacheOrFail <- readNoIndexCache' index - case cacheOrFail of - Left msg -> do - warn verbosity $ concat - [ "Parsing the index cache failed (", msg, "). " - , "Trying to regenerate the index cache..." - ] + cacheOrFail <- readNoIndexCache' index + case cacheOrFail of + Left msg -> do + warn verbosity $ + concat + [ "Parsing the index cache failed (" + , msg + , "). " + , "Trying to regenerate the index cache..." + ] - updatePackageIndexCacheFile verbosity index + updatePackageIndexCacheFile verbosity index - either (die' verbosity) return =<< readNoIndexCache' index + either (die' verbosity) return =<< readNoIndexCache' index - -- we don't hash cons local repository cache, they are hopefully small - Right res -> return res + -- we don't hash cons local repository cache, they are hopefully small + Right res -> return res -- | Read the 'Index' cache from the filesystem without attempting to -- regenerate on parsing failures. readIndexCache' :: Index -> IO (Either String Cache) readIndexCache' index | is01Index index = structuredDecodeFileOrFail (cacheFile index) - | otherwise = liftM (Right .read00IndexCache) $ - BSS.readFile (cacheFile index) + | otherwise = + liftM (Right . read00IndexCache) $ + BSS.readFile (cacheFile index) readNoIndexCache' :: Index -> IO (Either String NoIndexCache) readNoIndexCache' index = structuredDecodeFileOrFail (cacheFile index) @@ -1039,47 +1160,47 @@ readNoIndexCache' index = structuredDecodeFileOrFail (cacheFile index) writeIndexCache :: Index -> Cache -> IO () writeIndexCache index cache | is01Index index = structuredEncodeFile (cacheFile index) cache - | otherwise = writeFile (cacheFile index) (show00IndexCache cache) + | otherwise = writeFile (cacheFile index) (show00IndexCache cache) writeNoIndexCache :: Verbosity -> Index -> NoIndexCache -> IO () writeNoIndexCache verbosity index cache = do - let path = cacheFile index - createDirectoryIfMissingVerbose verbosity True (takeDirectory path) - structuredEncodeFile path cache + let path = cacheFile index + createDirectoryIfMissingVerbose verbosity True (takeDirectory path) + structuredEncodeFile path cache -- | Write the 'IndexState' to the filesystem writeIndexTimestamp :: Index -> RepoIndexState -> IO () -writeIndexTimestamp index st - = writeFile (timestampFile index) (prettyShow st) +writeIndexTimestamp index st = + writeFile (timestampFile index) (prettyShow st) -- | Read out the "current" index timestamp, i.e., what -- timestamp you would use to revert to this version currentIndexTimestamp :: Verbosity -> RepoContext -> Repo -> IO Timestamp currentIndexTimestamp verbosity repoCtxt r = do - mb_is <- readIndexTimestamp verbosity (RepoIndex repoCtxt r) - case mb_is of - Just (IndexStateTime ts) -> return ts - _ -> do - (_,_,isi) <- readRepoIndex verbosity repoCtxt r IndexStateHead - return (isiHeadTime isi) + mb_is <- readIndexTimestamp verbosity (RepoIndex repoCtxt r) + case mb_is of + Just (IndexStateTime ts) -> return ts + _ -> do + (_, _, isi) <- readRepoIndex verbosity repoCtxt r IndexStateHead + return (isiHeadTime isi) -- | Read the 'IndexState' from the filesystem readIndexTimestamp :: Verbosity -> Index -> IO (Maybe RepoIndexState) -readIndexTimestamp verbosity index - = fmap simpleParsec (readFile (timestampFile index)) - `catchIO` \e -> - if isDoesNotExistError e - then return Nothing - else do - warn verbosity $ "Warning: could not read current index timestamp: " ++ displayException e - return Nothing +readIndexTimestamp verbosity index = + fmap simpleParsec (readFile (timestampFile index)) + `catchIO` \e -> + if isDoesNotExistError e + then return Nothing + else do + warn verbosity $ "Warning: could not read current index timestamp: " ++ displayException e + return Nothing -- | Optimise sharing of equal values inside 'Cache' -- -- c.f. https://en.wikipedia.org/wiki/Hash_consing hashConsCache :: Cache -> Cache -hashConsCache cache0 - = cache0 { cacheEntries = go mempty mempty (cacheEntries cache0) } +hashConsCache cache0 = + cache0{cacheEntries = go mempty mempty (cacheEntries cache0)} where -- TODO/NOTE: -- @@ -1092,72 +1213,70 @@ hashConsCache cache0 go _ _ [] = [] -- for now we only optimise only CachePackageIds since those -- represent the vast majority - go !pns !pvs (CachePackageId pid bno ts : rest) - = CachePackageId pid' bno ts : go pns' pvs' rest + go !pns !pvs (CachePackageId pid bno ts : rest) = + CachePackageId pid' bno ts : go pns' pvs' rest where !pid' = PackageIdentifier pn' pv' - (!pn',!pns') = mapIntern pn pns - (!pv',!pvs') = mapIntern pv pvs + (!pn', !pns') = mapIntern pn pns + (!pv', !pvs') = mapIntern pv pvs PackageIdentifier pn pv = pid + go pns pvs (x : xs) = x : go pns pvs xs - go pns pvs (x:xs) = x : go pns pvs xs - - mapIntern :: Ord k => k -> Map.Map k k -> (k,Map.Map k k) - mapIntern k m = maybe (k,Map.insert k k m) (\k' -> (k',m)) (Map.lookup k m) + mapIntern :: Ord k => k -> Map.Map k k -> (k, Map.Map k k) + mapIntern k m = maybe (k, Map.insert k k m) (\k' -> (k', m)) (Map.lookup k m) -- | Cabal caches various information about the Hackage index data Cache = Cache - { cacheHeadTs :: Timestamp - -- ^ maximum/latest 'Timestamp' among 'cacheEntries'; unless the - -- invariant of 'cacheEntries' being in chronological order is - -- violated, this corresponds to the last (seen) 'Timestamp' in - -- 'cacheEntries' - , cacheEntries :: [IndexCacheEntry] - } + { cacheHeadTs :: Timestamp + -- ^ maximum/latest 'Timestamp' among 'cacheEntries'; unless the + -- invariant of 'cacheEntries' being in chronological order is + -- violated, this corresponds to the last (seen) 'Timestamp' in + -- 'cacheEntries' + , cacheEntries :: [IndexCacheEntry] + } deriving (Show, Generic) instance NFData Cache where - rnf = rnf . cacheEntries + rnf = rnf . cacheEntries -- | Cache format for 'file+noindex' repositories newtype NoIndexCache = NoIndexCache - { noIndexCacheEntries :: [NoIndexCacheEntry] - } + { noIndexCacheEntries :: [NoIndexCacheEntry] + } deriving (Show, Generic) instance NFData NoIndexCache where - rnf = rnf . noIndexCacheEntries + rnf = rnf . noIndexCacheEntries -- | Tar files are block structured with 512 byte blocks. Every header and file -- content starts on a block boundary. --- type BlockNo = Word32 -- Tar.TarEntryOffset data IndexCacheEntry - = CachePackageId PackageId !BlockNo !Timestamp - | CachePreference Dependency !BlockNo !Timestamp - | CacheBuildTreeRef !BuildTreeRefType !BlockNo - -- NB: CacheBuildTreeRef is irrelevant for 01-index & v2-build - deriving (Eq,Show,Generic) + = CachePackageId PackageId !BlockNo !Timestamp + | CachePreference Dependency !BlockNo !Timestamp + | CacheBuildTreeRef !BuildTreeRefType !BlockNo + -- NB: CacheBuildTreeRef is irrelevant for 01-index & v2-build + deriving (Eq, Show, Generic) data NoIndexCacheEntry - = CacheGPD GenericPackageDescription !BSS.ByteString - | NoIndexCachePreference [Dependency] - deriving (Eq,Show,Generic) + = CacheGPD GenericPackageDescription !BSS.ByteString + | NoIndexCachePreference [Dependency] + deriving (Eq, Show, Generic) instance NFData IndexCacheEntry where - rnf (CachePackageId pkgid _ _) = rnf pkgid - rnf (CachePreference dep _ _) = rnf dep - rnf (CacheBuildTreeRef _ _) = () + rnf (CachePackageId pkgid _ _) = rnf pkgid + rnf (CachePreference dep _ _) = rnf dep + rnf (CacheBuildTreeRef _ _) = () instance NFData NoIndexCacheEntry where - rnf (CacheGPD gpd bs) = rnf gpd `seq` rnf bs - rnf (NoIndexCachePreference dep) = rnf dep + rnf (CacheGPD gpd bs) = rnf gpd `seq` rnf bs + rnf (NoIndexCachePreference dep) = rnf dep cacheEntryTimestamp :: IndexCacheEntry -> Timestamp -cacheEntryTimestamp (CacheBuildTreeRef _ _) = nullTimestamp +cacheEntryTimestamp (CacheBuildTreeRef _ _) = nullTimestamp cacheEntryTimestamp (CachePreference _ _ ts) = ts -cacheEntryTimestamp (CachePackageId _ _ ts) = ts +cacheEntryTimestamp (CachePackageId _ _ ts) = ts ---------------------------------------------------------------------------- -- new binary 01-index.cache format @@ -1172,28 +1291,28 @@ instance Structured NoIndexCache -- | We need to save only .cabal file contents instance Binary NoIndexCacheEntry where - put (CacheGPD _ bs) = do - put (0 :: Word8) - put bs - put (NoIndexCachePreference dep) = do - put (1 :: Word8) - put dep - - get = do - t :: Word8 <- get - case t of - 0 -> do - bs <- get - case parseGenericPackageDescriptionMaybe bs of - Just gpd -> return (CacheGPD gpd bs) - Nothing -> fail "Failed to parse GPD" - 1 -> do - dep <- get - pure $ NoIndexCachePreference dep - _ -> fail "Failed to parse NoIndexCacheEntry" + put (CacheGPD _ bs) = do + put (0 :: Word8) + put bs + put (NoIndexCachePreference dep) = do + put (1 :: Word8) + put dep + + get = do + t :: Word8 <- get + case t of + 0 -> do + bs <- get + case parseGenericPackageDescriptionMaybe bs of + Just gpd -> return (CacheGPD gpd bs) + Nothing -> fail "Failed to parse GPD" + 1 -> do + dep <- get + pure $ NoIndexCachePreference dep + _ -> fail "Failed to parse NoIndexCacheEntry" instance Structured NoIndexCacheEntry where - structure = nominalStructure + structure = nominalStructure ---------------------------------------------------------------------------- -- legacy 00-index.cache format @@ -1201,64 +1320,69 @@ instance Structured NoIndexCacheEntry where packageKey, blocknoKey, buildTreeRefKey, preferredVersionKey :: String packageKey = "pkg:" blocknoKey = "b#" -buildTreeRefKey = "build-tree-ref:" +buildTreeRefKey = "build-tree-ref:" preferredVersionKey = "pref-ver:" -- legacy 00-index.cache format read00IndexCache :: BSS.ByteString -> Cache -read00IndexCache bs = Cache - { cacheHeadTs = nullTimestamp - , cacheEntries = mapMaybe read00IndexCacheEntry $ BSS.lines bs - } +read00IndexCache bs = + Cache + { cacheHeadTs = nullTimestamp + , cacheEntries = mapMaybe read00IndexCacheEntry $ BSS.lines bs + } read00IndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry read00IndexCacheEntry = \line -> case BSS.words line of [key, pkgnamestr, pkgverstr, sep, blocknostr] | key == BSS.pack packageKey && sep == BSS.pack blocknoKey -> - case (parseName pkgnamestr, parseVer pkgverstr [], - parseBlockNo blocknostr) of - (Just pkgname, Just pkgver, Just blockno) - -> Just (CachePackageId (PackageIdentifier pkgname pkgver) - blockno nullTimestamp) - _ -> Nothing + case ( parseName pkgnamestr + , parseVer pkgverstr [] + , parseBlockNo blocknostr + ) of + (Just pkgname, Just pkgver, Just blockno) -> + Just + ( CachePackageId + (PackageIdentifier pkgname pkgver) + blockno + nullTimestamp + ) + _ -> Nothing [key, typecodestr, blocknostr] | key == BSS.pack buildTreeRefKey -> case (parseRefType typecodestr, parseBlockNo blocknostr) of - (Just refType, Just blockno) - -> Just (CacheBuildTreeRef refType blockno) + (Just refType, Just blockno) -> + Just (CacheBuildTreeRef refType blockno) _ -> Nothing - - (key: remainder) | key == BSS.pack preferredVersionKey -> do + (key : remainder) | key == BSS.pack preferredVersionKey -> do pref <- simpleParsecBS (BSS.unwords remainder) return $ CachePreference pref 0 nullTimestamp - - _ -> Nothing + _ -> Nothing where parseName str - | BSS.all (\c -> isAlphaNum c || c == '-') str - = Just (mkPackageName (BSS.unpack str)) + | BSS.all (\c -> isAlphaNum c || c == '-') str = + Just (mkPackageName (BSS.unpack str)) | otherwise = Nothing parseVer str vs = case BSS.readInt str of - Nothing -> Nothing + Nothing -> Nothing Just (v, str') -> case BSS.uncons str' of - Just ('.', str'') -> parseVer str'' (v:vs) - Just _ -> Nothing - Nothing -> Just (mkVersion (reverse (v:vs))) + Just ('.', str'') -> parseVer str'' (v : vs) + Just _ -> Nothing + Nothing -> Just (mkVersion (reverse (v : vs))) parseBlockNo str = case BSS.readInt str of Just (blockno, remainder) | BSS.null remainder -> Just (fromIntegral blockno) - _ -> Nothing + _ -> Nothing parseRefType str = case BSS.uncons str of Just (typeCode, remainder) - | BSS.null remainder && Tar.isBuildTreeRefTypeCode typeCode - -> Just (refTypeFromTypeCode typeCode) - _ -> Nothing + | BSS.null remainder && Tar.isBuildTreeRefTypeCode typeCode -> + Just (refTypeFromTypeCode typeCode) + _ -> Nothing -- legacy 00-index.cache format show00IndexCache :: Cache -> String @@ -1266,19 +1390,19 @@ show00IndexCache Cache{..} = unlines $ map show00IndexCacheEntry cacheEntries show00IndexCacheEntry :: IndexCacheEntry -> String show00IndexCacheEntry entry = unwords $ case entry of - CachePackageId pkgid b _ -> - [ packageKey - , prettyShow (packageName pkgid) - , prettyShow (packageVersion pkgid) - , blocknoKey - , show b - ] - CacheBuildTreeRef tr b -> - [ buildTreeRefKey - , [typeCodeFromRefType tr] - , show b - ] - CachePreference dep _ _ -> - [ preferredVersionKey - , prettyShow dep - ] + CachePackageId pkgid b _ -> + [ packageKey + , prettyShow (packageName pkgid) + , prettyShow (packageVersion pkgid) + , blocknoKey + , show b + ] + CacheBuildTreeRef tr b -> + [ buildTreeRefKey + , [typeCodeFromRefType tr] + , show b + ] + CachePreference dep _ _ -> + [ preferredVersionKey + , prettyShow dep + ] diff --git a/cabal-install/src/Distribution/Client/IndexUtils/ActiveRepos.hs b/cabal-install/src/Distribution/Client/IndexUtils/ActiveRepos.hs index d257e2ded14..e65000e6b98 100644 --- a/cabal-install/src/Distribution/Client/IndexUtils/ActiveRepos.hs +++ b/cabal-install/src/Distribution/Client/IndexUtils/ActiveRepos.hs @@ -1,14 +1,15 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Client.IndexUtils.ActiveRepos ( - ActiveRepos (..), - defaultActiveRepos, - filterSkippedActiveRepos, - ActiveRepoEntry (..), - CombineStrategy (..), - organizeByRepos, -) where + +module Distribution.Client.IndexUtils.ActiveRepos + ( ActiveRepos (..) + , defaultActiveRepos + , filterSkippedActiveRepos + , ActiveRepoEntry (..) + , CombineStrategy (..) + , organizeByRepos + ) where import Distribution.Client.Compat.Prelude import Distribution.Client.Types.RepoName (RepoName (..)) @@ -17,7 +18,7 @@ import Prelude () import Distribution.Parsec (parsecLeadingCommaNonEmpty) import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp +import qualified Text.PrettyPrint as Disp -- $setup -- >>> import Distribution.Parsec @@ -31,31 +32,31 @@ newtype ActiveRepos = ActiveRepos [ActiveRepoEntry] deriving (Eq, Show, Generic) defaultActiveRepos :: ActiveRepos -defaultActiveRepos = ActiveRepos [ ActiveRepoRest CombineStrategyMerge ] +defaultActiveRepos = ActiveRepos [ActiveRepoRest CombineStrategyMerge] -- | Note, this does nothing if 'ActiveRepoRest' is present. filterSkippedActiveRepos :: ActiveRepos -> ActiveRepos filterSkippedActiveRepos repos@(ActiveRepos entries) - | any isActiveRepoRest entries = repos - | otherwise = ActiveRepos (filter notSkipped entries) + | any isActiveRepoRest entries = repos + | otherwise = ActiveRepos (filter notSkipped entries) where isActiveRepoRest (ActiveRepoRest _) = True - isActiveRepoRest _ = False + isActiveRepoRest _ = False notSkipped (ActiveRepo _ CombineStrategySkip) = False - notSkipped _ = True + notSkipped _ = True instance Binary ActiveRepos instance Structured ActiveRepos instance NFData ActiveRepos instance Pretty ActiveRepos where - pretty (ActiveRepos []) - = Disp.text ":none" - pretty (ActiveRepos repos) - = Disp.hsep - $ Disp.punctuate Disp.comma - $ map pretty repos + pretty (ActiveRepos []) = + Disp.text ":none" + pretty (ActiveRepos repos) = + Disp.hsep $ + Disp.punctuate Disp.comma $ + map pretty repos -- | Note: empty string is not valid 'ActiveRepos'. -- @@ -70,16 +71,18 @@ instance Pretty ActiveRepos where -- -- >>> simpleParsec "hackage.haskell.org, :rest, head.hackage:override" :: Maybe ActiveRepos -- Just (ActiveRepos [ActiveRepo (RepoName "hackage.haskell.org") CombineStrategyMerge,ActiveRepoRest CombineStrategyMerge,ActiveRepo (RepoName "head.hackage") CombineStrategyOverride]) --- instance Parsec ActiveRepos where - parsec = ActiveRepos [] <$ P.try (P.string ":none") - <|> do - repos <- parsecLeadingCommaNonEmpty parsec - return (ActiveRepos (toList repos)) + parsec = + ActiveRepos [] <$ P.try (P.string ":none") + <|> do + repos <- parsecLeadingCommaNonEmpty parsec + return (ActiveRepos (toList repos)) data ActiveRepoEntry - = ActiveRepoRest CombineStrategy -- ^ rest repositories, i.e. not explicitly listed as 'ActiveRepo' - | ActiveRepo RepoName CombineStrategy -- ^ explicit repository name + = -- | rest repositories, i.e. not explicitly listed as 'ActiveRepo' + ActiveRepoRest CombineStrategy + | -- | explicit repository name + ActiveRepo RepoName CombineStrategy deriving (Eq, Show, Generic) instance Binary ActiveRepoEntry @@ -87,33 +90,37 @@ instance Structured ActiveRepoEntry instance NFData ActiveRepoEntry instance Pretty ActiveRepoEntry where - pretty (ActiveRepoRest s) = - Disp.text ":rest" <<>> Disp.colon <<>> pretty s - pretty (ActiveRepo r s) = - pretty r <<>> Disp.colon <<>> pretty s + pretty (ActiveRepoRest s) = + Disp.text ":rest" <<>> Disp.colon <<>> pretty s + pretty (ActiveRepo r s) = + pretty r <<>> Disp.colon <<>> pretty s instance Parsec ActiveRepoEntry where - parsec = leadColon <|> leadRepo where - leadColon = do - _ <- P.char ':' - token <- P.munch1 isAlpha - case token of - "rest" -> ActiveRepoRest <$> strategyP - "repo" -> P.char ':' *> leadRepo - _ -> P.unexpected $ "Unknown active repository entry type: " ++ token - - leadRepo = do - r <- parsec - s <- strategyP - return (ActiveRepo r s) - - strategyP = P.option CombineStrategyMerge (P.char ':' *> parsec) + parsec = leadColon <|> leadRepo + where + leadColon = do + _ <- P.char ':' + token <- P.munch1 isAlpha + case token of + "rest" -> ActiveRepoRest <$> strategyP + "repo" -> P.char ':' *> leadRepo + _ -> P.unexpected $ "Unknown active repository entry type: " ++ token + + leadRepo = do + r <- parsec + s <- strategyP + return (ActiveRepo r s) + + strategyP = P.option CombineStrategyMerge (P.char ':' *> parsec) data CombineStrategy - = CombineStrategySkip -- ^ skip this repository - | CombineStrategyMerge -- ^ merge existing versions - | CombineStrategyOverride -- ^ if later repository specifies a package, - -- all package versions are replaced + = -- | skip this repository + CombineStrategySkip + | -- | merge existing versions + CombineStrategyMerge + | -- | if later repository specifies a package, + -- all package versions are replaced + CombineStrategyOverride deriving (Eq, Show, Enum, Bounded, Generic) instance Binary CombineStrategy @@ -121,16 +128,17 @@ instance Structured CombineStrategy instance NFData CombineStrategy instance Pretty CombineStrategy where - pretty CombineStrategySkip = Disp.text "skip" - pretty CombineStrategyMerge = Disp.text "merge" - pretty CombineStrategyOverride = Disp.text "override" + pretty CombineStrategySkip = Disp.text "skip" + pretty CombineStrategyMerge = Disp.text "merge" + pretty CombineStrategyOverride = Disp.text "override" instance Parsec CombineStrategy where - parsec = P.choice - [ CombineStrategySkip <$ P.string "skip" - , CombineStrategyMerge <$ P.string "merge" - , CombineStrategyOverride <$ P.string "override" - ] + parsec = + P.choice + [ CombineStrategySkip <$ P.string "skip" + , CombineStrategyMerge <$ P.string "merge" + , CombineStrategyOverride <$ P.string "override" + ] ------------------------------------------------------------------------------- -- Organisation @@ -153,38 +161,39 @@ instance Parsec CombineStrategy where -- -- Note: currently if 'ActiveRepoRest' is provided more than once, -- rest-repositories will be multiple times in the output. --- organizeByRepos - :: forall a. ActiveRepos - -> (a -> RepoName) - -> [a] - -> Either String [(a, CombineStrategy)] + :: forall a + . ActiveRepos + -> (a -> RepoName) + -> [a] + -> Either String [(a, CombineStrategy)] organizeByRepos (ActiveRepos xs0) sel ys0 = - -- here we use lazyness to do only one traversal - let (rest, result) = case go rest xs0 ys0 of - Right (rest', result') -> (rest', Right result') - Left err -> ([], Left err) - in result + -- here we use lazyness to do only one traversal + let (rest, result) = case go rest xs0 ys0 of + Right (rest', result') -> (rest', Right result') + Left err -> ([], Left err) + in result where go :: [a] -> [ActiveRepoEntry] -> [a] -> Either String ([a], [(a, CombineStrategy)]) - go _rest [] ys = Right (ys, []) - go rest (ActiveRepoRest s : xs) ys = - go rest xs ys <&> \(rest', result) -> - (rest', map (\x -> (x, s)) rest ++ result) - go rest (ActiveRepo r s : xs) ys = do - (z, zs) <- extract r ys - go rest xs zs <&> \(rest', result) -> - (rest', (z, s) : result) + go _rest [] ys = Right (ys, []) + go rest (ActiveRepoRest s : xs) ys = + go rest xs ys <&> \(rest', result) -> + (rest', map (\x -> (x, s)) rest ++ result) + go rest (ActiveRepo r s : xs) ys = do + (z, zs) <- extract r ys + go rest xs zs <&> \(rest', result) -> + (rest', (z, s) : result) extract :: RepoName -> [a] -> Either String (a, [a]) - extract r = loop id where - loop _acc [] = Left $ "no repository provided " ++ prettyShow r - loop acc (x:xs) - | sel x == r = Right (x, acc xs) - | otherwise = loop (acc . (x :)) xs + extract r = loop id + where + loop _acc [] = Left $ "no repository provided " ++ prettyShow r + loop acc (x : xs) + | sel x == r = Right (x, acc xs) + | otherwise = loop (acc . (x :)) xs (<&>) - :: Either err ([s], b) - -> (([s], b) -> ([s], c)) - -> Either err ([s], c) + :: Either err ([s], b) + -> (([s], b) -> ([s], c)) + -> Either err ([s], c) (<&>) = flip fmap diff --git a/cabal-install/src/Distribution/Client/IndexUtils/IndexState.hs b/cabal-install/src/Distribution/Client/IndexUtils/IndexState.hs index cbd01de141e..8acf2b3bdc3 100644 --- a/cabal-install/src/Distribution/Client/IndexUtils/IndexState.hs +++ b/cabal-install/src/Distribution/Client/IndexUtils/IndexState.hs @@ -1,31 +1,32 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.IndexUtils.IndexUtils -- Copyright : (c) 2016 Herbert Valerio Riedel -- License : BSD3 -- -- Package repositories index state. --- -module Distribution.Client.IndexUtils.IndexState ( - RepoIndexState(..), - TotalIndexState, - headTotalIndexState, - makeTotalIndexState, - lookupIndexState, - insertIndexState, -) where +module Distribution.Client.IndexUtils.IndexState + ( RepoIndexState (..) + , TotalIndexState + , headTotalIndexState + , makeTotalIndexState + , lookupIndexState + , insertIndexState + ) where import Distribution.Client.Compat.Prelude import Distribution.Client.IndexUtils.Timestamp (Timestamp) -import Distribution.Client.Types.RepoName (RepoName (..)) +import Distribution.Client.Types.RepoName (RepoName (..)) import Distribution.Parsec (parsecLeadingCommaNonEmpty) -import qualified Data.Map.Strict as Map +import qualified Data.Map.Strict as Map import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp +import qualified Text.PrettyPrint as Disp -- $setup -- >>> import Distribution.Parsec @@ -43,14 +44,17 @@ instance Structured TotalIndexState instance NFData TotalIndexState instance Pretty TotalIndexState where - pretty (TIS IndexStateHead m) - | not (Map.null m) - = Disp.hsep $ Disp.punctuate Disp.comma + pretty (TIS IndexStateHead m) + | not (Map.null m) = + Disp.hsep $ + Disp.punctuate + Disp.comma [ pretty rn Disp.<+> pretty idx | (rn, idx) <- Map.toList m ] - pretty (TIS def m) = foldl' go (pretty def) (Map.toList m) where - go doc (rn, idx) = doc <<>> Disp.comma Disp.<+> pretty rn Disp.<+> pretty idx + pretty (TIS def m) = foldl' go (pretty def) (Map.toList m) + where + go doc (rn, idx) = doc <<>> Disp.comma Disp.<+> pretty rn Disp.<+> pretty idx -- | -- @@ -68,29 +72,29 @@ instance Pretty TotalIndexState where -- -- >>> simpleParsec "hackage.haskell.org 2020-02-04T12:34:56Z" :: Maybe TotalIndexState -- Just (TIS IndexStateHead (fromList [(RepoName "hackage.haskell.org",IndexStateTime (TS 1580819696))])) --- instance Parsec TotalIndexState where - parsec = normalise . foldl' add headTotalIndexState <$> parsecLeadingCommaNonEmpty single0 where - single0 = startsWithRepoName <|> TokTimestamp <$> parsec - startsWithRepoName = do - reponame <- parsec - -- the "HEAD" is technically a valid reponame... - if reponame == RepoName "HEAD" - then return TokHead - else do - P.spaces - TokRepo reponame <$> parsec - - add :: TotalIndexState -> Tok -> TotalIndexState - add _ TokHead = headTotalIndexState - add _ (TokTimestamp ts) = TIS (IndexStateTime ts) Map.empty - add (TIS def m) (TokRepo rn idx) = TIS def (Map.insert rn idx m) + parsec = normalise . foldl' add headTotalIndexState <$> parsecLeadingCommaNonEmpty single0 + where + single0 = startsWithRepoName <|> TokTimestamp <$> parsec + startsWithRepoName = do + reponame <- parsec + -- the "HEAD" is technically a valid reponame... + if reponame == RepoName "HEAD" + then return TokHead + else do + P.spaces + TokRepo reponame <$> parsec + + add :: TotalIndexState -> Tok -> TotalIndexState + add _ TokHead = headTotalIndexState + add _ (TokTimestamp ts) = TIS (IndexStateTime ts) Map.empty + add (TIS def m) (TokRepo rn idx) = TIS def (Map.insert rn idx m) -- used in Parsec TotalIndexState implementation data Tok - = TokRepo RepoName RepoIndexState - | TokTimestamp Timestamp - | TokHead + = TokRepo RepoName RepoIndexState + | TokTimestamp Timestamp + | TokHead -- | Remove non-default values from 'TotalIndexState'. normalise :: TotalIndexState -> TotalIndexState @@ -111,8 +115,8 @@ lookupIndexState rn (TIS def m) = Map.findWithDefault def rn m -- | Insert a 'RepoIndexState' to 'TotalIndexState'. insertIndexState :: RepoName -> RepoIndexState -> TotalIndexState -> TotalIndexState insertIndexState rn idx (TIS def m) - | idx == def = TIS def (Map.delete rn m) - | otherwise = TIS def (Map.insert rn idx m) + | idx == def = TIS def (Map.delete rn m) + | otherwise = TIS def (Map.insert rn idx m) ------------------------------------------------------------------------------- -- Repository index state @@ -120,19 +124,22 @@ insertIndexState rn idx (TIS def m) -- | Specification of the state of a specific repo package index data RepoIndexState - = IndexStateHead -- ^ Use all available entries - | IndexStateTime !Timestamp -- ^ Use all entries that existed at the specified time - deriving (Eq,Generic,Show) + = -- | Use all available entries + IndexStateHead + | -- | Use all entries that existed at the specified time + IndexStateTime !Timestamp + deriving (Eq, Generic, Show) instance Binary RepoIndexState instance Structured RepoIndexState instance NFData RepoIndexState instance Pretty RepoIndexState where - pretty IndexStateHead = Disp.text "HEAD" - pretty (IndexStateTime ts) = pretty ts + pretty IndexStateHead = Disp.text "HEAD" + pretty (IndexStateTime ts) = pretty ts instance Parsec RepoIndexState where - parsec = parseHead <|> parseTime where - parseHead = IndexStateHead <$ P.string "HEAD" - parseTime = IndexStateTime <$> parsec + parsec = parseHead <|> parseTime + where + parseHead = IndexStateHead <$ P.string "HEAD" + parseTime = IndexStateTime <$> parsec diff --git a/cabal-install/src/Distribution/Client/IndexUtils/Timestamp.hs b/cabal-install/src/Distribution/Client/IndexUtils/Timestamp.hs index 48d3017d0e8..3dfe2963437 100644 --- a/cabal-install/src/Distribution/Client/IndexUtils/Timestamp.hs +++ b/cabal-install/src/Distribution/Client/IndexUtils/Timestamp.hs @@ -1,57 +1,57 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.IndexUtils.Timestamp -- Copyright : (c) 2016 Herbert Valerio Riedel -- License : BSD3 -- -- Timestamp type used in package indexes - module Distribution.Client.IndexUtils.Timestamp - ( Timestamp - , nullTimestamp - , epochTimeToTimestamp - , timestampToUTCTime - , utcTimeToTimestamp - , maximumTimestamp - ) where + ( Timestamp + , nullTimestamp + , epochTimeToTimestamp + , timestampToUTCTime + , utcTimeToTimestamp + , maximumTimestamp + ) where import Distribution.Client.Compat.Prelude -- read is needed for Text instance import Prelude (read) -import Data.Time (UTCTime (..), fromGregorianValid, makeTimeOfDayValid, showGregorian, timeOfDayToTime, timeToTimeOfDay) +import Data.Time (UTCTime (..), fromGregorianValid, makeTimeOfDayValid, showGregorian, timeOfDayToTime, timeToTimeOfDay) import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) -import qualified Codec.Archive.Tar.Entry as Tar +import qualified Codec.Archive.Tar.Entry as Tar import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp +import qualified Text.PrettyPrint as Disp -- | UNIX timestamp (expressed in seconds since unix epoch, i.e. 1970). newtype Timestamp = TS Int64 -- Tar.EpochTime - deriving (Eq,Ord,Enum,NFData,Show,Generic) + deriving (Eq, Ord, Enum, NFData, Show, Generic) epochTimeToTimestamp :: Tar.EpochTime -> Maybe Timestamp epochTimeToTimestamp et - | ts == nullTimestamp = Nothing - | otherwise = Just ts + | ts == nullTimestamp = Nothing + | otherwise = Just ts where ts = TS et timestampToUTCTime :: Timestamp -> Maybe UTCTime timestampToUTCTime (TS t) - | t == minBound = Nothing - | otherwise = Just $ posixSecondsToUTCTime (fromIntegral t) + | t == minBound = Nothing + | otherwise = Just $ posixSecondsToUTCTime (fromIntegral t) utcTimeToTimestamp :: UTCTime -> Maybe Timestamp utcTimeToTimestamp utct - | minTime <= t, t <= maxTime = Just (TS (fromIntegral t)) - | otherwise = Nothing + | minTime <= t, t <= maxTime = Just (TS (fromIntegral t)) + | otherwise = Nothing where maxTime = toInteger (maxBound :: Int64) minTime = toInteger (succ minBound :: Int64) @@ -65,13 +65,13 @@ utcTimeToTimestamp utct -- values. maximumTimestamp :: [Timestamp] -> Timestamp maximumTimestamp [] = nullTimestamp -maximumTimestamp xs@(_:_) = maximum xs +maximumTimestamp xs@(_ : _) = maximum xs -- returns 'Nothing' if not representable as 'Timestamp' posixSecondsToTimestamp :: Integer -> Maybe Timestamp posixSecondsToTimestamp pt - | minTs <= pt, pt <= maxTs = Just (TS (fromInteger pt)) - | otherwise = Nothing + | minTs <= pt, pt <= maxTs = Just (TS (fromInteger pt)) + | otherwise = Nothing where maxTs = toInteger (maxBound :: Int64) minTs = toInteger (succ minBound :: Int64) @@ -86,10 +86,10 @@ posixSecondsToTimestamp pt -- to hold. showTimestamp :: Timestamp -> String showTimestamp ts = case timestampToUTCTime ts of - Nothing -> "" - -- Note: we don't use 'formatTime' here to avoid incurring a - -- dependency on 'old-locale' for older `time` libs - Just UTCTime{..} -> showGregorian utctDay ++ ('T':showTOD utctDayTime) ++ "Z" + Nothing -> "" + -- Note: we don't use 'formatTime' here to avoid incurring a + -- dependency on 'old-locale' for older `time` libs + Just UTCTime{..} -> showGregorian utctDay ++ ('T' : showTOD utctDayTime) ++ "Z" where showTOD = show . timeToTimeOfDay @@ -97,63 +97,65 @@ instance Binary Timestamp instance Structured Timestamp instance Pretty Timestamp where - pretty = Disp.text . showTimestamp + pretty = Disp.text . showTimestamp instance Parsec Timestamp where - parsec = parsePosix <|> parseUTC - where - -- | Parses unix timestamps, e.g. @"\@1474626019"@ - parsePosix = do - _ <- P.char '@' - t <- P.integral -- note, no negative timestamps - maybe (fail (show t ++ " is not representable as timestamp")) return $ - posixSecondsToTimestamp t - - -- | Parses ISO8601/RFC3339-style UTC timestamps, - -- e.g. @"2017-12-31T23:59:59Z"@ - -- - -- TODO: support numeric tz offsets; allow to leave off seconds - parseUTC = do - -- Note: we don't use 'Data.Time.Format.parseTime' here since - -- we want more control over the accepted formats. - - ye <- parseYear - _ <- P.char '-' - mo <- parseTwoDigits - _ <- P.char '-' - da <- parseTwoDigits - _ <- P.char 'T' - - utctDay <- maybe (fail (show (ye,mo,da) ++ " is not valid gregorian date")) return $ - fromGregorianValid ye mo da - - ho <- parseTwoDigits - _ <- P.char ':' - mi <- parseTwoDigits - _ <- P.char ':' - se <- parseTwoDigits - _ <- P.char 'Z' - - utctDayTime <- maybe (fail (show (ho,mi,se) ++ " is not valid time of day")) (return . timeOfDayToTime) $ - makeTimeOfDayValid ho mi (realToFrac (se::Int)) - - let utc = UTCTime {..} - - maybe (fail (show utc ++ " is not representable as timestamp")) return $ utcTimeToTimestamp utc - - parseTwoDigits = do - d1 <- P.satisfy isDigit - d2 <- P.satisfy isDigit - return (read [d1,d2]) - - -- A year must have at least 4 digits; e.g. "0097" is fine, - -- while "97" is not c.f. RFC3339 which - -- deprecates 2-digit years - parseYear = do - sign <- P.option ' ' (P.char '-') - ds <- P.munch1 isDigit - when (length ds < 4) $ fail "Year should have at least 4 digits" - return (read (sign:ds)) + parsec = parsePosix <|> parseUTC + where + -- \| Parses unix timestamps, e.g. @"\@1474626019"@ + parsePosix = do + _ <- P.char '@' + t <- P.integral -- note, no negative timestamps + maybe (fail (show t ++ " is not representable as timestamp")) return $ + posixSecondsToTimestamp t + + -- \| Parses ISO8601/RFC3339-style UTC timestamps, + -- e.g. @"2017-12-31T23:59:59Z"@ + -- + -- TODO: support numeric tz offsets; allow to leave off seconds + parseUTC = do + -- Note: we don't use 'Data.Time.Format.parseTime' here since + -- we want more control over the accepted formats. + + ye <- parseYear + _ <- P.char '-' + mo <- parseTwoDigits + _ <- P.char '-' + da <- parseTwoDigits + _ <- P.char 'T' + + utctDay <- + maybe (fail (show (ye, mo, da) ++ " is not valid gregorian date")) return $ + fromGregorianValid ye mo da + + ho <- parseTwoDigits + _ <- P.char ':' + mi <- parseTwoDigits + _ <- P.char ':' + se <- parseTwoDigits + _ <- P.char 'Z' + + utctDayTime <- + maybe (fail (show (ho, mi, se) ++ " is not valid time of day")) (return . timeOfDayToTime) $ + makeTimeOfDayValid ho mi (realToFrac (se :: Int)) + + let utc = UTCTime{..} + + maybe (fail (show utc ++ " is not representable as timestamp")) return $ utcTimeToTimestamp utc + + parseTwoDigits = do + d1 <- P.satisfy isDigit + d2 <- P.satisfy isDigit + return (read [d1, d2]) + + -- A year must have at least 4 digits; e.g. "0097" is fine, + -- while "97" is not c.f. RFC3339 which + -- deprecates 2-digit years + parseYear = do + sign <- P.option ' ' (P.char '-') + ds <- P.munch1 isDigit + when (length ds < 4) $ fail "Year should have at least 4 digits" + return (read (sign : ds)) -- | Special timestamp value to be used when 'timestamp' is -- missing/unknown/invalid diff --git a/cabal-install/src/Distribution/Client/Init.hs b/cabal-install/src/Distribution/Client/Init.hs index b217827f422..1a8be086a3f 100644 --- a/cabal-install/src/Distribution/Client/Init.hs +++ b/cabal-install/src/Distribution/Client/Init.hs @@ -1,4 +1,7 @@ ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.Init -- Copyright : (c) Brent Yorgey 2009 @@ -10,43 +13,36 @@ -- -- Implementation of the 'cabal init' command, which creates an initial .cabal -- file for a project. --- ------------------------------------------------------------------------------ - -module Distribution.Client.Init -( -- * Commands - initCmd -) where +module Distribution.Client.Init (initCmd) where +import Distribution.Client.IndexUtils +import Distribution.Client.Init.FileCreators import qualified Distribution.Client.Init.Interactive.Command as Interactive import qualified Distribution.Client.Init.NonInteractive.Command as NonInteractive import qualified Distribution.Client.Init.Simple as Simple -import Distribution.Verbosity +import Distribution.Client.Init.Types import Distribution.Client.Setup (RepoContext) import Distribution.Simple.Compiler import Distribution.Simple.Program (ProgramDb) -import Distribution.Client.Init.Types import Distribution.Simple.Setup -import Distribution.Client.IndexUtils -import System.IO (hSetBuffering, stdout, BufferMode (NoBuffering)) -import Distribution.Client.Init.FileCreators +import Distribution.Verbosity +import System.IO (BufferMode (NoBuffering), hSetBuffering, stdout) -- | This is the main driver for the init script. --- initCmd - :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> ProgramDb - -> InitFlags - -> IO () + :: Verbosity + -> PackageDBStack + -> RepoContext + -> Compiler + -> ProgramDb + -> InitFlags + -> IO () initCmd v packageDBs repoCtxt comp progdb initFlags = do - installedPkgIndex <- getInstalledPackages v comp packageDBs progdb - sourcePkgDb <- getSourcePackages v repoCtxt - hSetBuffering stdout NoBuffering - settings <- createProject v installedPkgIndex sourcePkgDb initFlags - writeProject settings + installedPkgIndex <- getInstalledPackages v comp packageDBs progdb + sourcePkgDb <- getSourcePackages v repoCtxt + hSetBuffering stdout NoBuffering + settings <- createProject v installedPkgIndex sourcePkgDb initFlags + writeProject settings where -- When no flag is set, default to interactive. -- @@ -60,5 +56,5 @@ initCmd v packageDBs repoCtxt comp progdb initFlags = do | fromFlagOrDefault False (simpleProject initFlags) = Simple.createProject | otherwise = case interactive initFlags of - Flag False -> NonInteractive.createProject comp - _ -> Interactive.createProject + Flag False -> NonInteractive.createProject comp + _ -> Interactive.createProject diff --git a/cabal-install/src/Distribution/Client/Init/Defaults.hs b/cabal-install/src/Distribution/Client/Init/Defaults.hs index 8a695d7de1a..9be998feda7 100644 --- a/cabal-install/src/Distribution/Client/Init/Defaults.hs +++ b/cabal-install/src/Distribution/Client/Init/Defaults.hs @@ -1,4 +1,7 @@ ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.Init.Defaults -- Copyright : (c) Brent Yorgey 2009 @@ -9,54 +12,50 @@ -- Portability : portable -- -- Default values to use in cabal init (if not specified in config/flags). --- ------------------------------------------------------------------------------ module Distribution.Client.Init.Defaults + ( -- * default init values + defaultApplicationDir + , defaultSourceDir + , defaultCabalVersion + , defaultCabalVersions + , defaultPackageType + , defaultLicense + , defaultLicenseIds + , defaultMainIs + , defaultChangelog + , defaultCategories + , defaultInitFlags + , defaultLanguage + , defaultVersion + , defaultTestDir + + -- * MyLib defaults + , myLibModule + , myLibTestFile + , myLibFile + , myLibHs + , myExeHs + , myLibExeHs + , myTestHs + ) where -( -- * default init values - defaultApplicationDir -, defaultSourceDir -, defaultCabalVersion -, defaultCabalVersions -, defaultPackageType -, defaultLicense -, defaultLicenseIds -, defaultMainIs -, defaultChangelog -, defaultCategories -, defaultInitFlags -, defaultLanguage -, defaultVersion -, defaultTestDir - -- * MyLib defaults -, myLibModule -, myLibTestFile -, myLibFile -, myLibHs -, myExeHs -, myLibExeHs -, myTestHs -) where - - -import Distribution.ModuleName (ModuleName) -import qualified Distribution.ModuleName as ModuleName(fromString) import Distribution.CabalSpecVersion (CabalSpecVersion (..)) -import Distribution.Client.Init.Types (PackageType(..), InitFlags(..), HsFilePath, toHsFilePath) +import Distribution.Client.Init.Types (HsFilePath, InitFlags (..), PackageType (..), toHsFilePath) +import Distribution.FieldGrammar.Newtypes +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName (fromString) import qualified Distribution.SPDX.License as SPDX import qualified Distribution.SPDX.LicenseId as SPDX +import Distribution.Simple (Language (..), License (..)) import Distribution.Simple.Flag (toFlag) -import Distribution.Verbosity (normal) import Distribution.Types.Version -import Distribution.FieldGrammar.Newtypes -import Distribution.Simple (Language(..), License(..)) - +import Distribution.Verbosity (normal) -- -------------------------------------------------------------------- -- -- Default flag and init values defaultVersion :: Version -defaultVersion = mkVersion [0,1,0,0] +defaultVersion = mkVersion [0, 1, 0, 0] defaultApplicationDir :: String defaultApplicationDir = "app" @@ -79,7 +78,7 @@ defaultChangelog = "CHANGELOG.md" defaultLicense :: CabalSpecVersion -> SpecLicense defaultLicense csv | csv < CabalSpecV2_2 = SpecLicense $ Right AllRightsReserved - | otherwise = SpecLicense $ Left SPDX.NONE + | otherwise = SpecLicense $ Left SPDX.NONE defaultMainIs :: HsFilePath defaultMainIs = toHsFilePath "Main.hs" @@ -89,57 +88,57 @@ defaultLanguage = Haskell2010 defaultLicenseIds :: [SPDX.LicenseId] defaultLicenseIds = - [ SPDX.BSD_2_Clause - , SPDX.BSD_3_Clause - , SPDX.Apache_2_0 - , SPDX.MIT - , SPDX.MPL_2_0 - , SPDX.ISC - , SPDX.GPL_2_0_only - , SPDX.GPL_3_0_only - , SPDX.LGPL_2_1_only - , SPDX.LGPL_3_0_only - , SPDX.AGPL_3_0_only - , SPDX.GPL_2_0_or_later - , SPDX.GPL_3_0_or_later - , SPDX.LGPL_2_1_or_later - , SPDX.LGPL_3_0_or_later - , SPDX.AGPL_3_0_or_later - ] + [ SPDX.BSD_2_Clause + , SPDX.BSD_3_Clause + , SPDX.Apache_2_0 + , SPDX.MIT + , SPDX.MPL_2_0 + , SPDX.ISC + , SPDX.GPL_2_0_only + , SPDX.GPL_3_0_only + , SPDX.LGPL_2_1_only + , SPDX.LGPL_3_0_only + , SPDX.AGPL_3_0_only + , SPDX.GPL_2_0_or_later + , SPDX.GPL_3_0_or_later + , SPDX.LGPL_2_1_or_later + , SPDX.LGPL_3_0_or_later + , SPDX.AGPL_3_0_or_later + ] defaultCategories :: [String] defaultCategories = - [ "Codec" - , "Concurrency" - , "Control" - , "Data" - , "Database" - , "Development" - , "Distribution" - , "Game" - , "Graphics" - , "Language" - , "Math" - , "Network" - , "Sound" - , "System" - , "Testing" - , "Text" - , "Web" - ] + [ "Codec" + , "Concurrency" + , "Control" + , "Data" + , "Database" + , "Development" + , "Distribution" + , "Game" + , "Graphics" + , "Language" + , "Math" + , "Network" + , "Sound" + , "System" + , "Testing" + , "Text" + , "Web" + ] defaultCabalVersions :: [CabalSpecVersion] defaultCabalVersions = - [ CabalSpecV1_24 - , CabalSpecV2_0 - , CabalSpecV2_2 - , CabalSpecV2_4 - , CabalSpecV3_0 - , CabalSpecV3_4 - ] + [ CabalSpecV1_24 + , CabalSpecV2_0 + , CabalSpecV2_2 + , CabalSpecV2_4 + , CabalSpecV3_0 + , CabalSpecV3_4 + ] defaultInitFlags :: InitFlags -defaultInitFlags = mempty { initVerbosity = toFlag normal } +defaultInitFlags = mempty{initVerbosity = toFlag normal} -- -------------------------------------------------------------------- -- -- MyLib defaults @@ -155,38 +154,40 @@ myLibFile = toHsFilePath "MyLib.hs" -- | Default MyLib.hs file. Used when no Lib.hs exists. myLibHs :: String -myLibHs = unlines - [ "module MyLib (someFunc) where" - , "" - , "someFunc :: IO ()" - , "someFunc = putStrLn \"someFunc\"" - ] +myLibHs = + unlines + [ "module MyLib (someFunc) where" + , "" + , "someFunc :: IO ()" + , "someFunc = putStrLn \"someFunc\"" + ] myExeHs :: [String] myExeHs = - [ "module Main where" - , "" - , "main :: IO ()" - , "main = putStrLn \"Hello, Haskell!\"" - ] + [ "module Main where" + , "" + , "main :: IO ()" + , "main = putStrLn \"Hello, Haskell!\"" + ] myLibExeHs :: [String] myLibExeHs = - [ "module Main where" - , "" - , "import qualified MyLib (someFunc)" - , "" - , "main :: IO ()" - , "main = do" - , " putStrLn \"Hello, Haskell!\"" - , " MyLib.someFunc" - ] - --- | Default MyLibTest.hs file. -myTestHs :: String -myTestHs = unlines - [ "module Main (main) where" + [ "module Main where" + , "" + , "import qualified MyLib (someFunc)" , "" , "main :: IO ()" - , "main = putStrLn \"Test suite not yet implemented.\"" + , "main = do" + , " putStrLn \"Hello, Haskell!\"" + , " MyLib.someFunc" ] + +-- | Default MyLibTest.hs file. +myTestHs :: String +myTestHs = + unlines + [ "module Main (main) where" + , "" + , "main :: IO ()" + , "main = putStrLn \"Test suite not yet implemented.\"" + ] diff --git a/cabal-install/src/Distribution/Client/Init/FileCreators.hs b/cabal-install/src/Distribution/Client/Init/FileCreators.hs index 90846acaac0..18ea0bc71a1 100644 --- a/cabal-install/src/Distribution/Client/Init/FileCreators.hs +++ b/cabal-install/src/Distribution/Client/Init/FileCreators.hs @@ -1,6 +1,10 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.Init.FileCreators -- Copyright : (c) Brent Yorgey 2009 @@ -11,51 +15,59 @@ -- Portability : portable -- -- Functions to create files during 'cabal init'. --- ------------------------------------------------------------------------------ module Distribution.Client.Init.FileCreators -( -- * Commands - writeProject -, writeLicense -, writeChangeLog -, prepareLibTarget -, prepareExeTarget -, prepareTestTarget -) where - -import Prelude hiding (writeFile, readFile) -import Distribution.Client.Compat.Prelude hiding (head, empty, writeFile, readFile) + ( -- * Commands + writeProject + , writeLicense + , writeChangeLog + , prepareLibTarget + , prepareExeTarget + , prepareTestTarget + ) where + +import Distribution.Client.Compat.Prelude hiding (empty, head, readFile, writeFile) +import Prelude hiding (readFile, writeFile) import qualified Data.Set as Set (member) +import Distribution.CabalSpecVersion (showCabalSpecVersion) import Distribution.Client.Init.Defaults +import Distribution.Client.Init.Format import Distribution.Client.Init.Licenses - ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20, isc ) -import Distribution.Client.Init.Types hiding (putStrLn, putStr, message) + ( agplv3 + , apache20 + , bsd2 + , bsd3 + , gplv2 + , gplv3 + , isc + , lgpl21 + , lgpl3 + , mit + , mpl20 + ) +import Distribution.Client.Init.Types hiding (message, putStr, putStrLn) import qualified Distribution.Client.Init.Types as T -import Distribution.Fields.Pretty (PrettyField(..), showFields') +import Distribution.Fields.Pretty (PrettyField (..), showFields') import qualified Distribution.SPDX as SPDX import Distribution.Types.PackageName -import Distribution.Client.Init.Format -import Distribution.CabalSpecVersion (showCabalSpecVersion) -import System.FilePath ((), (<.>)) import Distribution.FieldGrammar.Newtypes import Distribution.License (licenseToSPDX) +import System.FilePath ((<.>), ()) -- -------------------------------------------------------------------- -- -- File generation writeProject :: Interactive m => ProjectSettings -> m () writeProject (ProjectSettings opts pkgDesc libTarget exeTarget testTarget) - | null pkgName = do + | null pkgName = do message opts T.Error "no package name given, so no .cabal file can be generated\n" - | otherwise = do - + | otherwise = do -- clear prompt history a bit" - message opts T.Log - $ "Using cabal specification: " - ++ showCabalSpecVersion (_optCabalSpec opts) + message opts T.Log $ + "Using cabal specification: " + ++ showCabalSpecVersion (_optCabalSpec opts) writeLicense opts pkgDesc writeChangeLog opts pkgDesc @@ -67,8 +79,9 @@ writeProject (ProjectSettings opts pkgDesc libTarget exeTarget testTarget) exeStanza <- prepareExeTarget opts exeTarget testStanza <- prepareTestTarget opts testTarget - (reusedCabal, cabalContents) <- writeCabalFile opts $ - pkgFields ++ [commonStanza, libStanza, exeStanza, testStanza] + (reusedCabal, cabalContents) <- + writeCabalFile opts $ + pkgFields ++ [commonStanza, libStanza, exeStanza, testStanza] when (null $ _pkgSynopsis pkgDesc) $ message opts T.Warning "No synopsis given. You should edit the .cabal file and add one." @@ -85,83 +98,85 @@ writeProject (ProjectSettings opts pkgDesc libTarget exeTarget testTarget) where pkgName = unPackageName $ _optPkgName opts - prepareLibTarget - :: Interactive m - => WriteOpts - -> Maybe LibTarget - -> m (PrettyField FieldAnnotation) + :: Interactive m + => WriteOpts + -> Maybe LibTarget + -> m (PrettyField FieldAnnotation) prepareLibTarget _ Nothing = return PrettyEmpty prepareLibTarget opts (Just libTarget) = do - void $ writeDirectoriesSafe opts $ filter (/= ".") srcDirs - -- avoid writing when conflicting exposed paths may - -- exist. - when (expMods == (myLibModule :| [])) . void $ - writeFileSafe opts libPath myLibHs + void $ writeDirectoriesSafe opts $ filter (/= ".") srcDirs + -- avoid writing when conflicting exposed paths may + -- exist. + when (expMods == (myLibModule :| [])) . void $ + writeFileSafe opts libPath myLibHs - return $ mkLibStanza opts libTarget + return $ mkLibStanza opts libTarget where expMods = _libExposedModules libTarget srcDirs = _libSourceDirs libTarget libPath = case srcDirs of - path:_ -> path _hsFilePath myLibFile + path : _ -> path _hsFilePath myLibFile _ -> _hsFilePath myLibFile prepareExeTarget - :: Interactive m - => WriteOpts - -> Maybe ExeTarget - -> m (PrettyField FieldAnnotation) + :: Interactive m + => WriteOpts + -> Maybe ExeTarget + -> m (PrettyField FieldAnnotation) prepareExeTarget _ Nothing = return PrettyEmpty prepareExeTarget opts (Just exeTarget) = do - void $ writeDirectoriesSafe opts appDirs - void $ writeFileSafe opts mainPath mainHs - return $ mkExeStanza opts exeTarget + void $ writeDirectoriesSafe opts appDirs + void $ writeFileSafe opts mainPath mainHs + return $ mkExeStanza opts exeTarget where exeMainIs = _exeMainIs exeTarget pkgType = _optPkgType opts appDirs = _exeApplicationDirs exeTarget mainFile = _hsFilePath exeMainIs mainPath = case appDirs of - appPath:_ -> appPath mainFile + appPath : _ -> appPath mainFile _ -> mainFile - mainHs = unlines . mkLiterate exeMainIs $ - if pkgType == LibraryAndExecutable - then myLibExeHs - else myExeHs + mainHs = + unlines . mkLiterate exeMainIs $ + if pkgType == LibraryAndExecutable + then myLibExeHs + else myExeHs prepareTestTarget - :: Interactive m - => WriteOpts - -> Maybe TestTarget - -> m (PrettyField FieldAnnotation) + :: Interactive m + => WriteOpts + -> Maybe TestTarget + -> m (PrettyField FieldAnnotation) prepareTestTarget _ Nothing = return PrettyEmpty prepareTestTarget opts (Just testTarget) = do - void $ writeDirectoriesSafe opts testDirs' - void $ writeFileSafe opts testPath myTestHs - return $ mkTestStanza opts testTarget + void $ writeDirectoriesSafe opts testDirs' + void $ writeFileSafe opts testPath myTestHs + return $ mkTestStanza opts testTarget where testDirs' = _testDirs testTarget testMainIs = _hsFilePath $ _testMainIs testTarget testPath = case testDirs' of - p:_ -> p testMainIs + p : _ -> p testMainIs _ -> testMainIs writeCabalFile - :: Interactive m - => WriteOpts - -> [PrettyField FieldAnnotation] - -- ^ .cabal fields - -> m (Bool, String) + :: Interactive m + => WriteOpts + -> [PrettyField FieldAnnotation] + -- ^ .cabal fields + -> m (Bool, String) writeCabalFile opts fields = do - let cabalContents = showFields' + let cabalContents = + showFields' annCommentLines postProcessFieldLines - 4 fields + 4 + fields - reusedCabal <- writeFileSafe opts cabalFileName cabalContents - return (reusedCabal, cabalContents) + reusedCabal <- writeFileSafe opts cabalFileName cabalContents + return (reusedCabal, cabalContents) where cabalFileName = pkgName ++ ".cabal" pkgName = unPackageName $ _optPkgName opts @@ -174,7 +189,6 @@ writeCabalFile opts fields = do -- -- If the license type is unknown no license file will be prepared and -- a warning will be raised. --- writeLicense :: Interactive m => WriteOpts -> PkgDescription -> m () writeLicense writeOpts pkgDesc = do year <- show <$> getCurrentYear @@ -207,34 +221,35 @@ writeLicense writeOpts pkgDesc = do _ -> Nothing -- | Writes the changelog to the current directory. --- writeChangeLog :: Interactive m => WriteOpts -> PkgDescription -> m () writeChangeLog opts pkgDesc | Just docs <- _pkgExtraDocFiles pkgDesc - , defaultChangelog `Set.member` docs = go + , defaultChangelog `Set.member` docs = + go | defaultChangelog `elem` _pkgExtraSrcFiles pkgDesc = go | otherwise = return () - where - changeLog = unlines - [ "# Revision history for " ++ prettyShow (_pkgName pkgDesc) - , "" - , "## " ++ prettyShow (_pkgVersion pkgDesc) ++ " -- YYYY-mm-dd" - , "" - , "* First version. Released on an unsuspecting world." - ] - - go = - void $ writeFileSafe opts defaultChangelog changeLog + where + changeLog = + unlines + [ "# Revision history for " ++ prettyShow (_pkgName pkgDesc) + , "" + , "## " ++ prettyShow (_pkgVersion pkgDesc) ++ " -- YYYY-mm-dd" + , "" + , "* First version. Released on an unsuspecting world." + ] + + go = + void $ writeFileSafe opts defaultChangelog changeLog -- -------------------------------------------------------------------- -- -- Utilities -data WriteAction = Overwrite | Fresh | Existing deriving Eq +data WriteAction = Overwrite | Fresh | Existing deriving (Eq) instance Show WriteAction where show Overwrite = "Overwriting" - show Fresh = "Creating fresh" - show Existing = "Using existing" + show Fresh = "Creating fresh" + show Existing = "Using existing" -- | Possibly generate a message to stdout, taking into account the -- --quiet flag. @@ -245,65 +260,67 @@ message opts = T.message (_optVerbosity opts) -- the overwrite flag is set. writeFileSafe :: Interactive m => WriteOpts -> FilePath -> String -> m Bool writeFileSafe opts fileName content = do - exists <- doesFileExist fileName + exists <- doesFileExist fileName - let action - | exists && doOverwrite = Overwrite - | not exists = Fresh - | otherwise = Existing + let action + | exists && doOverwrite = Overwrite + | not exists = Fresh + | otherwise = Existing - go exists + go exists - message opts T.Log $ show action ++ " file " ++ fileName ++ "..." - return $ action == Existing + message opts T.Log $ show action ++ " file " ++ fileName ++ "..." + return $ action == Existing where doOverwrite = _optOverwrite opts go exists | not exists = do - writeFile fileName content + writeFile fileName content | exists && doOverwrite = do - newName <- findNewPath fileName - message opts T.Log $ concat - [ fileName - , " already exists. Backing up old version in " - , newName - ] - - copyFile fileName newName -- backups the old file - removeExistingFile fileName -- removes the original old file - writeFile fileName content -- writes the new file + newName <- findNewPath fileName + message opts T.Log $ + concat + [ fileName + , " already exists. Backing up old version in " + , newName + ] + + copyFile fileName newName -- backups the old file + removeExistingFile fileName -- removes the original old file + writeFile fileName content -- writes the new file | otherwise = return () writeDirectoriesSafe :: Interactive m => WriteOpts -> [String] -> m Bool writeDirectoriesSafe opts dirs = fmap or $ for dirs $ \dir -> do - exists <- doesDirectoryExist dir + exists <- doesDirectoryExist dir - let action - | exists && doOverwrite = Overwrite - | not exists = Fresh - | otherwise = Existing + let action + | exists && doOverwrite = Overwrite + | not exists = Fresh + | otherwise = Existing - go dir exists + go dir exists - message opts T.Log $ show action ++ " directory ./" ++ dir ++ "..." - return $ action == Existing + message opts T.Log $ show action ++ " directory ./" ++ dir ++ "..." + return $ action == Existing where doOverwrite = _optOverwrite opts go dir exists | not exists = do - createDirectory dir + createDirectory dir | exists && doOverwrite = do - newDir <- findNewPath dir - message opts T.Log $ concat - [ dir - , " already exists. Backing up old version in " - , newDir - ] - - renameDirectory dir newDir -- backups the old directory - createDirectory dir -- creates the new directory + newDir <- findNewPath dir + message opts T.Log $ + concat + [ dir + , " already exists. Backing up old version in " + , newDir + ] + + renameDirectory dir newDir -- backups the old directory + createDirectory dir -- creates the new directory | otherwise = return () findNewPath :: Interactive m => FilePath -> m FilePath diff --git a/cabal-install/src/Distribution/Client/Init/FlagExtractors.hs b/cabal-install/src/Distribution/Client/Init/FlagExtractors.hs index 8ddc6795a7d..9e1ed191f94 100644 --- a/cabal-install/src/Distribution/Client/Init/FlagExtractors.hs +++ b/cabal-install/src/Distribution/Client/Init/FlagExtractors.hs @@ -1,67 +1,66 @@ {-# LANGUAGE LambdaCase #-} -module Distribution.Client.Init.FlagExtractors -( -- * Flag extractors - getPackageDir -, getSimpleProject -, getMinimal -, getCabalVersion -, getCabalVersionNoPrompt -, getPackageName -, getVersion -, getLicense -, getAuthor -, getEmail -, getHomepage -, getSynopsis -, getCategory -, getExtraSrcFiles -, getExtraDocFiles -, getPackageType -, getMainFile -, getInitializeTestSuite -, getTestDirs -, getLanguage -, getNoComments -, getAppDirs -, getSrcDirs -, getExposedModules -, getBuildTools -, getDependencies -, getOtherExts -, getOverwrite -, getOtherModules - -- * Shared prompts -, simpleProjectPrompt -, initializeTestSuitePrompt -, packageTypePrompt -, testMainPrompt -, dependenciesPrompt -) where - +module Distribution.Client.Init.FlagExtractors + ( -- * Flag extractors + getPackageDir + , getSimpleProject + , getMinimal + , getCabalVersion + , getCabalVersionNoPrompt + , getPackageName + , getVersion + , getLicense + , getAuthor + , getEmail + , getHomepage + , getSynopsis + , getCategory + , getExtraSrcFiles + , getExtraDocFiles + , getPackageType + , getMainFile + , getInitializeTestSuite + , getTestDirs + , getLanguage + , getNoComments + , getAppDirs + , getSrcDirs + , getExposedModules + , getBuildTools + , getDependencies + , getOtherExts + , getOverwrite + , getOtherModules + + -- * Shared prompts + , simpleProjectPrompt + , initializeTestSuitePrompt + , packageTypePrompt + , testMainPrompt + , dependenciesPrompt + ) where + +import Distribution.Client.Compat.Prelude hiding (getLine, last, putStr, putStrLn) import Prelude () -import Distribution.Client.Compat.Prelude hiding (putStr, putStrLn, getLine, last) import qualified Data.List.NonEmpty as NEL -import Distribution.CabalSpecVersion (CabalSpecVersion(..)) -import Distribution.Version (Version) -import Distribution.ModuleName (ModuleName) -import Distribution.Types.Dependency (Dependency(..)) -import Distribution.Types.PackageName (PackageName) +import Distribution.CabalSpecVersion (CabalSpecVersion (..)) import Distribution.Client.Init.Defaults -import Distribution.FieldGrammar.Newtypes (SpecLicense) import Distribution.Client.Init.Types -import Distribution.Simple.Setup (Flag(..), fromFlagOrDefault, flagToMaybe) +import Distribution.FieldGrammar.Newtypes (SpecLicense) +import Distribution.ModuleName (ModuleName) import Distribution.Simple.Flag (flagElim) +import Distribution.Simple.Setup (Flag (..), flagToMaybe, fromFlagOrDefault) +import Distribution.Types.Dependency (Dependency (..)) +import Distribution.Types.PackageName (PackageName) +import Distribution.Version (Version) -import Language.Haskell.Extension (Language(..), Extension(..)) -import Distribution.Client.Init.Prompt import qualified Data.Set as Set -import Distribution.Simple.PackageIndex +import Distribution.Client.Init.Prompt import Distribution.Client.Init.Utils - - +import Distribution.Simple.PackageIndex +import Language.Haskell.Extension (Extension (..), Language (..)) -- -------------------------------------------------------------------- -- -- Flag extraction @@ -135,25 +134,28 @@ getExtraSrcFiles = pure . flagElim mempty Set.fromList . extraSrc -- | Try to guess extra source files (don't prompt the user). getExtraDocFiles :: Interactive m => InitFlags -> m (Maybe (Set String)) -getExtraDocFiles = pure - . Just - . flagElim (Set.singleton defaultChangelog) Set.fromList - . extraDoc +getExtraDocFiles = + pure + . Just + . flagElim (Set.singleton defaultChangelog) Set.fromList + . extraDoc -- | Ask whether the project builds a library or executable. getPackageType :: Interactive m => InitFlags -> m PackageType -> m PackageType -getPackageType InitFlags - { initializeTestSuite = Flag True - , packageType = NoFlag - } _ = return TestSuite +getPackageType + InitFlags + { initializeTestSuite = Flag True + , packageType = NoFlag + } + _ = return TestSuite getPackageType flags act = fromFlagOrPrompt (packageType flags) act getMainFile :: Interactive m => InitFlags -> m HsFilePath -> m HsFilePath getMainFile flags act = case mainIs flags of - Flag a - | isHsFilePath a -> return $ toHsFilePath a - | otherwise -> act - NoFlag -> act + Flag a + | isHsFilePath a -> return $ toHsFilePath a + | otherwise -> act + NoFlag -> act getInitializeTestSuite :: Interactive m => InitFlags -> m Bool -> m Bool getInitializeTestSuite flags = fromFlagOrPrompt (initializeTestSuite flags) @@ -179,7 +181,8 @@ getSrcDirs flags = fromFlagOrPrompt (sourceDirs flags) -- | Retrieve the list of exposed modules getExposedModules :: Interactive m => InitFlags -> m (NonEmpty ModuleName) -getExposedModules = return +getExposedModules = + return . fromMaybe (myLibModule NEL.:| []) . join . flagToMaybe @@ -204,46 +207,48 @@ getBuildTools = flagElim (return []) (foldM go []) . buildTools -- | Retrieve the list of dependencies getDependencies - :: Interactive m - => InitFlags - -> m [Dependency] - -> m [Dependency] + :: Interactive m + => InitFlags + -> m [Dependency] + -> m [Dependency] getDependencies flags = fromFlagOrPrompt (dependencies flags) - -- | Retrieve the list of extensions getOtherExts :: Interactive m => InitFlags -> m [Extension] -getOtherExts = return . fromFlagOrDefault [] . otherExts +getOtherExts = return . fromFlagOrDefault [] . otherExts -- | Tell whether to overwrite files on write --- getOverwrite :: Interactive m => InitFlags -> m Bool -getOverwrite = return . fromFlagOrDefault False . overwrite +getOverwrite = return . fromFlagOrDefault False . overwrite -- -------------------------------------------------------------------- -- -- Shared prompts simpleProjectPrompt :: Interactive m => InitFlags -> m Bool -simpleProjectPrompt flags = getSimpleProject flags $ +simpleProjectPrompt flags = + getSimpleProject flags $ promptYesNo "Should I generate a simple project with sensible defaults" (DefaultPrompt True) initializeTestSuitePrompt :: Interactive m => InitFlags -> m Bool -initializeTestSuitePrompt flags = getInitializeTestSuite flags $ +initializeTestSuitePrompt flags = + getInitializeTestSuite flags $ promptYesNo "Should I generate a test suite for the library" (DefaultPrompt True) packageTypePrompt :: Interactive m => InitFlags -> m PackageType packageTypePrompt flags = getPackageType flags $ do - pt <- promptList "What does the package build" + pt <- + promptList + "What does the package build" packageTypes (DefaultPrompt "Executable") Nothing False - return $ fromMaybe Executable (parsePackageType pt) + return $ fromMaybe Executable (parsePackageType pt) where packageTypes = [ "Library" @@ -261,31 +266,34 @@ packageTypePrompt flags = getPackageType flags $ do testMainPrompt :: Interactive m => m HsFilePath testMainPrompt = do - fp <- promptList "What is the main module of the test suite?" + fp <- + promptList + "What is the main module of the test suite?" [defaultMainIs', "Main.lhs"] (DefaultPrompt defaultMainIs') Nothing True - let hs = toHsFilePath fp + let hs = toHsFilePath fp - case _hsFileType hs of - InvalidHsPath -> do - putStrLn $ concat + case _hsFileType hs of + InvalidHsPath -> do + putStrLn $ + concat [ "Main file " , show hs , " is not a valid haskell file. Source files must end in .hs or .lhs." ] - testMainPrompt - _ -> return hs + testMainPrompt + _ -> return hs where defaultMainIs' = show defaultMainIs dependenciesPrompt - :: Interactive m - => InstalledPackageIndex - -> InitFlags - -> m [Dependency] + :: Interactive m + => InstalledPackageIndex + -> InitFlags + -> m [Dependency] dependenciesPrompt pkgIx flags = getDependencies flags (getBaseDep pkgIx flags) -- -------------------------------------------------------------------- -- @@ -293,10 +301,9 @@ dependenciesPrompt pkgIx flags = getDependencies flags (getBaseDep pkgIx flags) -- | If a flag is defined, return its value or else execute -- an interactive action. --- fromFlagOrPrompt - :: Interactive m - => Flag a - -> m a - -> m a + :: Interactive m + => Flag a + -> m a + -> m a fromFlagOrPrompt flag action = flagElim action return flag diff --git a/cabal-install/src/Distribution/Client/Init/Format.hs b/cabal-install/src/Distribution/Client/Init/Format.hs index 48eab2ce1a2..d2ed5a8c873 100644 --- a/cabal-install/src/Distribution/Client/Init/Format.hs +++ b/cabal-install/src/Distribution/Client/Init/Format.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} + -- | -- Module : Distribution.Client.Init.Format -- Copyright : (c) Brent Yorgey 2009 @@ -9,66 +10,68 @@ -- Portability : portable -- -- Pretty printing and field formatting utilities used for file creation. --- module Distribution.Client.Init.Format -( -- * cabal file formatters - listFieldS -, field -, fieldD -, commentedOutWithComments -, withComments -, annNoComments -, postProcessFieldLines - -- * stanza generation -, mkCommonStanza -, mkLibStanza -, mkExeStanza -, mkTestStanza -, mkPkgDescription -) where - + ( -- * cabal file formatters + listFieldS + , field + , fieldD + , commentedOutWithComments + , withComments + , annNoComments + , postProcessFieldLines + + -- * stanza generation + , mkCommonStanza + , mkLibStanza + , mkExeStanza + , mkTestStanza + , mkPkgDescription + ) where -import Distribution.Pretty -import Distribution.Fields +import Distribution.CabalSpecVersion import Distribution.Client.Init.Types +import Distribution.FieldGrammar.Newtypes (SpecLicense (SpecLicense)) +import Distribution.Fields import Distribution.License -import Text.PrettyPrint -import Distribution.Solver.Compat.Prelude hiding (empty) +import Distribution.Package (unPackageName) import Distribution.PackageDescription.FieldGrammar +import Distribution.Pretty +import qualified Distribution.SPDX.License as SPDX import Distribution.Simple.Utils hiding (cabalVersion) +import Distribution.Solver.Compat.Prelude hiding (empty) import Distribution.Utils.Path -import Distribution.Package (unPackageName) -import qualified Distribution.SPDX.License as SPDX -import Distribution.CabalSpecVersion -import Distribution.FieldGrammar.Newtypes (SpecLicense(SpecLicense)) - +import Text.PrettyPrint -- | Construct a 'PrettyField' from a field that can be automatically -- converted to a 'Doc' via 'display'. field - :: Pretty b - => FieldName - -> (a -> b) - -> a - -> [String] - -> Bool - -> WriteOpts - -> PrettyField FieldAnnotation + :: Pretty b + => FieldName + -> (a -> b) + -> a + -> [String] + -> Bool + -> WriteOpts + -> PrettyField FieldAnnotation field fieldName modifier fieldContents = - fieldD fieldName (pretty $ modifier fieldContents) + fieldD fieldName (pretty $ modifier fieldContents) -- | Construct a 'PrettyField' from a 'Doc' Flag. fieldD - :: FieldName -- ^ Name of the field - -> Doc -- ^ Field contents - -> [String] -- ^ Comment to explain the field - -> Bool -- ^ Should the field be included (commented out) even if blank? - -> WriteOpts - -> PrettyField FieldAnnotation + :: FieldName + -- ^ Name of the field + -> Doc + -- ^ Field contents + -> [String] + -- ^ Comment to explain the field + -> Bool + -- ^ Should the field be included (commented out) even if blank? + -> WriteOpts + -> PrettyField FieldAnnotation fieldD fieldName fieldContents fieldComments includeField opts - -- If the "--no-comments" or "--minimal" flag is set, strip comments. - | hasNoComments || isMinimal = contents NoComment - | otherwise = contents $ commentPositionFor fieldName fieldComments + -- If the "--no-comments" or "--minimal" flag is set, strip comments. + | hasNoComments || isMinimal = contents NoComment + | otherwise = contents $ commentPositionFor fieldName fieldComments where commentPositionFor fn | fn == "cabal-version" = CommentAfter @@ -78,32 +81,32 @@ fieldD fieldName fieldContents fieldComments includeField opts hasNoComments = _optNoComments opts contents - -- If there is no content, optionally produce a commented out field. + -- If there is no content, optionally produce a commented out field. | fieldContents == empty = fieldSEmptyContents - | otherwise = fieldSWithContents + | otherwise = fieldSWithContents fieldSEmptyContents cs | not includeField || isMinimal = PrettyEmpty - | otherwise = PrettyField - (commentedOutWithComments cs) - fieldName - empty + | otherwise = + PrettyField + (commentedOutWithComments cs) + fieldName + empty fieldSWithContents cs = PrettyField (withComments cs) fieldName fieldContents - -- | A field annotation instructing the pretty printer to comment out the field -- and any contents, with no comments. commentedOutWithComments :: CommentPosition -> FieldAnnotation commentedOutWithComments (CommentBefore cs) = FieldAnnotation True . CommentBefore $ map commentNoTrailing cs -commentedOutWithComments (CommentAfter cs) = FieldAnnotation True . CommentAfter $ map commentNoTrailing cs +commentedOutWithComments (CommentAfter cs) = FieldAnnotation True . CommentAfter $ map commentNoTrailing cs commentedOutWithComments NoComment = FieldAnnotation True NoComment -- | A field annotation with the specified comment lines. withComments :: CommentPosition -> FieldAnnotation withComments (CommentBefore cs) = FieldAnnotation False . CommentBefore $ map commentNoTrailing cs -withComments (CommentAfter cs) = FieldAnnotation False . CommentAfter $ map commentNoTrailing cs +withComments (CommentAfter cs) = FieldAnnotation False . CommentAfter $ map commentNoTrailing cs withComments NoComment = FieldAnnotation False NoComment -- | A field annotation with no comments. @@ -123,162 +126,231 @@ postProcessFieldLines ann mkCommonStanza :: WriteOpts -> PrettyField FieldAnnotation mkCommonStanza opts = case specHasCommonStanzas $ _optCabalSpec opts of NoCommonStanzas -> PrettyEmpty - _ -> PrettySection - annNoComments - "common" - [text "warnings"] - [field "ghc-options" text "-Wall" [] False opts] + _ -> + PrettySection + annNoComments + "common" + [text "warnings"] + [field "ghc-options" text "-Wall" [] False opts] mkLibStanza :: WriteOpts -> LibTarget -> PrettyField FieldAnnotation mkLibStanza opts (LibTarget srcDirs lang expMods otherMods exts deps tools) = - PrettySection annNoComments (toUTF8BS "library") [] + PrettySection + annNoComments + (toUTF8BS "library") + [] [ case specHasCommonStanzas $ _optCabalSpec opts of NoCommonStanzas -> PrettyEmpty - _ -> field "import" (hsep . map text) ["warnings"] - ["Import common warning flags."] - False - opts - - , field "exposed-modules" formatExposedModules (toList expMods) - ["Modules exported by the library."] - True - opts - - , field "other-modules" formatOtherModules otherMods - ["Modules included in this library but not exported."] - True - opts - - , field "other-extensions" formatOtherExtensions exts - ["LANGUAGE extensions used by modules in this package."] - True - opts - - , field "build-depends" formatDependencyList deps - ["Other library packages from which modules are imported."] - True - opts - - , field "hs-source-dirs" formatHsSourceDirs (unsafeMakeSymbolicPath <$> srcDirs) - ["Directories containing source files."] - True - opts - - , field (buildToolTag opts) formatDependencyList tools - ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."] - False - opts - - , field "default-language" id lang - ["Base language which the package is written in."] - True - opts + _ -> + field + "import" + (hsep . map text) + ["warnings"] + ["Import common warning flags."] + False + opts + , field + "exposed-modules" + formatExposedModules + (toList expMods) + ["Modules exported by the library."] + True + opts + , field + "other-modules" + formatOtherModules + otherMods + ["Modules included in this library but not exported."] + True + opts + , field + "other-extensions" + formatOtherExtensions + exts + ["LANGUAGE extensions used by modules in this package."] + True + opts + , field + "build-depends" + formatDependencyList + deps + ["Other library packages from which modules are imported."] + True + opts + , field + "hs-source-dirs" + formatHsSourceDirs + (unsafeMakeSymbolicPath <$> srcDirs) + ["Directories containing source files."] + True + opts + , field + (buildToolTag opts) + formatDependencyList + tools + ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."] + False + opts + , field + "default-language" + id + lang + ["Base language which the package is written in."] + True + opts ] mkExeStanza :: WriteOpts -> ExeTarget -> PrettyField FieldAnnotation mkExeStanza opts (ExeTarget exeMain appDirs lang otherMods exts deps tools) = - PrettySection annNoComments (toUTF8BS "executable") [exeName] - [ case specHasCommonStanzas $ _optCabalSpec opts of - NoCommonStanzas -> PrettyEmpty - _ -> field "import" (hsep . map text) ["warnings"] + PrettySection + annNoComments + (toUTF8BS "executable") + [exeName] + [ case specHasCommonStanzas $ _optCabalSpec opts of + NoCommonStanzas -> PrettyEmpty + _ -> + field + "import" + (hsep . map text) + ["warnings"] ["Import common warning flags."] False opts - - , field "main-is" unsafeFromHs exeMain - [".hs or .lhs file containing the Main module."] - True + , field + "main-is" + unsafeFromHs + exeMain + [".hs or .lhs file containing the Main module."] + True opts - - , field "other-modules" formatOtherModules otherMods - [ "Modules included in this executable, other than Main." ] + , field + "other-modules" + formatOtherModules + otherMods + ["Modules included in this executable, other than Main."] True opts - - , field "other-extensions" formatOtherExtensions exts + , field + "other-extensions" + formatOtherExtensions + exts ["LANGUAGE extensions used by modules in this package."] True opts - , field "build-depends" formatDependencyList deps + , field + "build-depends" + formatDependencyList + deps ["Other library packages from which modules are imported."] True opts - - , field "hs-source-dirs" formatHsSourceDirs + , field + "hs-source-dirs" + formatHsSourceDirs (unsafeMakeSymbolicPath <$> appDirs) ["Directories containing source files."] True opts - - , field (buildToolTag opts) formatDependencyList tools + , field + (buildToolTag opts) + formatDependencyList + tools ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."] False opts - - , field "default-language" id lang + , field + "default-language" + id + lang ["Base language which the package is written in."] True opts - ] - where - exeName = pretty $ _optPkgName opts + ] + where + exeName = pretty $ _optPkgName opts mkTestStanza :: WriteOpts -> TestTarget -> PrettyField FieldAnnotation mkTestStanza opts (TestTarget testMain dirs lang otherMods exts deps tools) = - PrettySection annNoComments (toUTF8BS "test-suite") [suiteName] - [ case specHasCommonStanzas $ _optCabalSpec opts of - NoCommonStanzas -> PrettyEmpty - _ -> field "import" (hsep . map text) ["warnings"] - ["Import common warning flags."] - False - opts - - , field "default-language" id lang - ["Base language which the package is written in."] - True - opts - , field "other-modules" formatOtherModules otherMods - [ "Modules included in this executable, other than Main." ] - True - opts - - , field "other-extensions" formatOtherExtensions exts - ["LANGUAGE extensions used by modules in this package."] - True - opts - - , field "type" text "exitcode-stdio-1.0" - ["The interface type and version of the test suite."] - True - opts - - , field "hs-source-dirs" formatHsSourceDirs - (unsafeMakeSymbolicPath <$> dirs) - ["Directories containing source files."] - True - opts - - , field "main-is" unsafeFromHs testMain - ["The entrypoint to the test suite."] - True - opts - - , field "build-depends" formatDependencyList deps - ["Test dependencies."] - True - opts - - , field (buildToolTag opts) formatDependencyList tools - ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."] - False - opts - ] - where - suiteName = text $ unPackageName (_optPkgName opts) ++ "-test" + PrettySection + annNoComments + (toUTF8BS "test-suite") + [suiteName] + [ case specHasCommonStanzas $ _optCabalSpec opts of + NoCommonStanzas -> PrettyEmpty + _ -> + field + "import" + (hsep . map text) + ["warnings"] + ["Import common warning flags."] + False + opts + , field + "default-language" + id + lang + ["Base language which the package is written in."] + True + opts + , field + "other-modules" + formatOtherModules + otherMods + ["Modules included in this executable, other than Main."] + True + opts + , field + "other-extensions" + formatOtherExtensions + exts + ["LANGUAGE extensions used by modules in this package."] + True + opts + , field + "type" + text + "exitcode-stdio-1.0" + ["The interface type and version of the test suite."] + True + opts + , field + "hs-source-dirs" + formatHsSourceDirs + (unsafeMakeSymbolicPath <$> dirs) + ["Directories containing source files."] + True + opts + , field + "main-is" + unsafeFromHs + testMain + ["The entrypoint to the test suite."] + True + opts + , field + "build-depends" + formatDependencyList + deps + ["Test dependencies."] + True + opts + , field + (buildToolTag opts) + formatDependencyList + tools + ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."] + False + opts + ] + where + suiteName = text $ unPackageName (_optPkgName opts) ++ "-test" mkPkgDescription :: WriteOpts -> PkgDescription -> [PrettyField FieldAnnotation] mkPkgDescription opts pkgDesc = - [ field "cabal-version" text ((if cabalSpec < CabalSpecV1_12 then ">=" else "") ++ showCabalSpecVersion cabalSpec) + [ field + "cabal-version" + text + ((if cabalSpec < CabalSpecV1_12 then ">=" else "") ++ showCabalSpecVersion cabalSpec) [ "The cabal-version field refers to the version of the .cabal specification," , "and can be different from the cabal-install (the tool) version and the" , "Cabal (the library) version you are using. As such, the Cabal (the library)" @@ -288,9 +360,11 @@ mkPkgDescription opts pkgDesc = ] False opts - - , field "name" pretty (_pkgName pkgDesc) - ["Initial package description '" ++ prettyShow (_optPkgName opts) ++ "' generated by" + , field + "name" + pretty + (_pkgName pkgDesc) + [ "Initial package description '" ++ prettyShow (_optPkgName opts) ++ "' generated by" , "'cabal init'. For further documentation, see:" , " http://haskell.org/cabal/users-guide/" , "" @@ -298,88 +372,120 @@ mkPkgDescription opts pkgDesc = ] True opts - - , field "version" pretty (_pkgVersion pkgDesc) - ["The package version.", - "See the Haskell package versioning policy (PVP) for standards", - "guiding when and how versions should be incremented.", - "https://pvp.haskell.org", - "PVP summary: +-+------- breaking API changes", - " | | +----- non-breaking API additions", - " | | | +--- code changes with no API change"] + , field + "version" + pretty + (_pkgVersion pkgDesc) + [ "The package version." + , "See the Haskell package versioning policy (PVP) for standards" + , "guiding when and how versions should be incremented." + , "https://pvp.haskell.org" + , "PVP summary: +-+------- breaking API changes" + , " | | +----- non-breaking API additions" + , " | | | +--- code changes with no API change" + ] True opts - - , field "synopsis" text (_pkgSynopsis pkgDesc) + , field + "synopsis" + text + (_pkgSynopsis pkgDesc) ["A short (one-line) description of the package."] True opts - - , field "description" text "" + , field + "description" + text + "" ["A longer description of the package."] True opts - - , field "homepage" text (_pkgHomePage pkgDesc) + , field + "homepage" + text + (_pkgHomePage pkgDesc) ["URL for the project homepage or repository."] False opts - - , field "bug-reports" text "" + , field + "bug-reports" + text + "" ["A URL where users can report bugs."] False opts - - , field "license" pretty (_pkgLicense pkgDesc) + , field + "license" + pretty + (_pkgLicense pkgDesc) ["The license under which the package is released."] True opts - - , case _pkgLicense pkgDesc of - SpecLicense (Left SPDX.NONE) -> PrettyEmpty - SpecLicense (Right AllRightsReserved) -> PrettyEmpty - SpecLicense (Right UnspecifiedLicense) -> PrettyEmpty - _ -> field "license-file" text "LICENSE" - ["The file containing the license text."] - False - opts - - , field "author" text (_pkgAuthor pkgDesc) + , case _pkgLicense pkgDesc of + SpecLicense (Left SPDX.NONE) -> PrettyEmpty + SpecLicense (Right AllRightsReserved) -> PrettyEmpty + SpecLicense (Right UnspecifiedLicense) -> PrettyEmpty + _ -> + field + "license-file" + text + "LICENSE" + ["The file containing the license text."] + False + opts + , field + "author" + text + (_pkgAuthor pkgDesc) ["The package author(s)."] True opts - - , field "maintainer" text (_pkgEmail pkgDesc) + , field + "maintainer" + text + (_pkgEmail pkgDesc) ["An email address to which users can send suggestions, bug reports, and patches."] True opts - - , field "copyright" text "" + , field + "copyright" + text + "" ["A copyright notice."] True opts - - , field "category" text (_pkgCategory pkgDesc) + , field + "category" + text + (_pkgCategory pkgDesc) [] False opts - , field "build-type" text "Simple" + , field + "build-type" + text + "Simple" [] False opts - , case _pkgExtraDocFiles pkgDesc of - Nothing -> PrettyEmpty - Just fs -> - field "extra-doc-files" formatExtraSourceFiles (toList fs) + , case _pkgExtraDocFiles pkgDesc of + Nothing -> PrettyEmpty + Just fs -> + field + "extra-doc-files" + formatExtraSourceFiles + (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 (toList $ _pkgExtraSrcFiles pkgDesc) + , field + "extra-source-files" + formatExtraSourceFiles + (toList $ _pkgExtraSrcFiles pkgDesc) ["Extra source files to be distributed with the package, such as examples, or a tutorial module."] True opts - ] + ] where cabalSpec = _pkgCabalVersion pkgDesc @@ -399,4 +505,4 @@ buildToolTag opts commentNoTrailing :: String -> String commentNoTrailing "" = "--" -commentNoTrailing c = "-- " ++ c +commentNoTrailing c = "-- " ++ c diff --git a/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs b/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs index bf27eb30118..2fab0db25cc 100644 --- a/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs +++ b/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs @@ -1,5 +1,10 @@ -{-# LANGUAGE LambdaCase, MultiWayIf #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.Init.Command -- Copyright : (c) Brent Yorgey 2009 @@ -11,71 +16,67 @@ -- -- Implementation of the 'cabal init' command, which creates an initial .cabal -- file for a project. --- ------------------------------------------------------------------------------ module Distribution.Client.Init.Interactive.Command -( -- * Commands - createProject - -- ** Target generation -, genPkgDescription -, genLibTarget -, genExeTarget -, genTestTarget - -- ** Prompts -, cabalVersionPrompt -, packageNamePrompt -, versionPrompt -, licensePrompt -, authorPrompt -, emailPrompt -, homepagePrompt -, synopsisPrompt -, categoryPrompt -, mainFilePrompt -, testDirsPrompt -, languagePrompt -, noCommentsPrompt -, appDirsPrompt -, dependenciesPrompt -, srcDirsPrompt -) where - - + ( -- * Commands + createProject + + -- ** Target generation + , genPkgDescription + , genLibTarget + , genExeTarget + , genTestTarget + + -- ** Prompts + , cabalVersionPrompt + , packageNamePrompt + , versionPrompt + , licensePrompt + , authorPrompt + , emailPrompt + , homepagePrompt + , synopsisPrompt + , categoryPrompt + , mainFilePrompt + , testDirsPrompt + , languagePrompt + , noCommentsPrompt + , appDirsPrompt + , dependenciesPrompt + , srcDirsPrompt + ) where + +import Distribution.Client.Compat.Prelude hiding (getLine, last, putStr, putStrLn) import Prelude () -import Distribution.Client.Compat.Prelude hiding (putStr, putStrLn, getLine, last) -import Distribution.CabalSpecVersion (CabalSpecVersion(..), showCabalSpecVersion) -import Distribution.Version (Version) -import Distribution.Types.PackageName (PackageName, unPackageName) -import qualified Distribution.SPDX as SPDX +import Distribution.CabalSpecVersion (CabalSpecVersion (..), showCabalSpecVersion) import Distribution.Client.Init.Defaults import Distribution.Client.Init.FlagExtractors +import Distribution.Client.Init.NonInteractive.Heuristics (guessAuthorEmail, guessAuthorName) import Distribution.Client.Init.Prompt import Distribution.Client.Init.Types import Distribution.Client.Init.Utils -import Distribution.Client.Init.NonInteractive.Heuristics (guessAuthorName, guessAuthorEmail) -import Distribution.FieldGrammar.Newtypes (SpecLicense(..)) -import Distribution.Simple.Setup (Flag(..), fromFlagOrDefault) +import Distribution.Client.Types (SourcePackageDb (..)) +import Distribution.FieldGrammar.Newtypes (SpecLicense (..)) +import qualified Distribution.SPDX as SPDX import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import Distribution.Client.Types (SourcePackageDb(..)) +import Distribution.Simple.Setup (Flag (..), fromFlagOrDefault) import Distribution.Solver.Types.PackageIndex (elemByPackageName) +import Distribution.Types.PackageName (PackageName, unPackageName) +import Distribution.Version (Version) -import Language.Haskell.Extension (Language(..)) import Distribution.License (knownLicenses) import Distribution.Parsec (simpleParsec') - +import Language.Haskell.Extension (Language (..)) -- | Main driver for interactive prompt code. --- createProject - :: Interactive m - => Verbosity - -> InstalledPackageIndex - -> SourcePackageDb - -> InitFlags - -> m ProjectSettings + :: Interactive m + => Verbosity + -> InstalledPackageIndex + -> SourcePackageDb + -> InitFlags + -> m ProjectSettings createProject v pkgIx srcDb initFlags = do - -- The workflow is as follows: -- -- 1. Get the package type, supplied as either a program input or @@ -101,59 +102,81 @@ createProject v pkgIx srcDb initFlags = do let pkgName = _pkgName pkgDesc cabalSpec = _pkgCabalVersion pkgDesc - mkOpts cs = WriteOpts - doOverwrite isMinimal cs - v pkgDir pkgType pkgName - initFlags' = initFlags { cabalVersion = Flag cabalSpec } + mkOpts cs = + WriteOpts + doOverwrite + isMinimal + cs + v + pkgDir + pkgType + pkgName + initFlags' = initFlags{cabalVersion = Flag cabalSpec} case pkgType of Library -> do libTarget <- genLibTarget initFlags' pkgIx - testTarget <- addLibDepToTest pkgName <$> - genTestTarget initFlags' pkgIx + testTarget <- + addLibDepToTest pkgName + <$> genTestTarget initFlags' pkgIx comments <- noCommentsPrompt initFlags' - return $ ProjectSettings - (mkOpts comments cabalSpec) pkgDesc - (Just libTarget) Nothing testTarget - + return $ + ProjectSettings + (mkOpts comments cabalSpec) + pkgDesc + (Just libTarget) + Nothing + testTarget Executable -> do exeTarget <- genExeTarget initFlags' pkgIx comments <- noCommentsPrompt initFlags' - return $ ProjectSettings - (mkOpts comments cabalSpec) pkgDesc Nothing - (Just exeTarget) Nothing - + return $ + ProjectSettings + (mkOpts comments cabalSpec) + pkgDesc + Nothing + (Just exeTarget) + Nothing LibraryAndExecutable -> do libTarget <- genLibTarget initFlags' pkgIx - exeTarget <- addLibDepToExe pkgName <$> - genExeTarget initFlags' pkgIx + exeTarget <- + addLibDepToExe pkgName + <$> genExeTarget initFlags' pkgIx - testTarget <- addLibDepToTest pkgName <$> - genTestTarget initFlags' pkgIx + testTarget <- + addLibDepToTest pkgName + <$> genTestTarget initFlags' pkgIx comments <- noCommentsPrompt initFlags' - return $ ProjectSettings - (mkOpts comments cabalSpec) pkgDesc (Just libTarget) - (Just exeTarget) testTarget - + return $ + ProjectSettings + (mkOpts comments cabalSpec) + pkgDesc + (Just libTarget) + (Just exeTarget) + testTarget TestSuite -> do -- the line below is necessary because if both package type and test flags -- are *not* passed, the user will be prompted for a package type (which -- includes TestSuite in the list). It prevents that the user end up with a -- TestSuite target with initializeTestSuite set to NoFlag, thus avoiding the prompt. - let initFlags'' = initFlags' { initializeTestSuite = Flag True } + let initFlags'' = initFlags'{initializeTestSuite = Flag True} testTarget <- genTestTarget initFlags'' pkgIx comments <- noCommentsPrompt initFlags'' - return $ ProjectSettings - (mkOpts comments cabalSpec) pkgDesc - Nothing Nothing testTarget + return $ + ProjectSettings + (mkOpts comments cabalSpec) + pkgDesc + Nothing + Nothing + testTarget -- -------------------------------------------------------------------- -- -- Target and pkg description generation @@ -162,15 +185,14 @@ createProject v pkgIx srcDb initFlags = do -- generate a 'PkgDescription' object for creation. If the user specifies -- the generation of a simple package, then a simple target with defaults -- is generated. --- genPkgDescription - :: Interactive m - => InitFlags - -> SourcePackageDb - -> m PkgDescription + :: Interactive m + => InitFlags + -> SourcePackageDb + -> m PkgDescription genPkgDescription flags' srcDb = do csv <- cabalVersionPrompt flags' - let flags = flags' { cabalVersion = Flag csv } + let flags = flags'{cabalVersion = Flag csv} PkgDescription csv <$> packageNamePrompt srcDb flags <*> versionPrompt flags @@ -187,13 +209,13 @@ genPkgDescription flags' srcDb = do -- generate a 'LibTarget' object for creation. If the user specifies -- the generation of a simple package, then a simple target with defaults -- is generated. --- genLibTarget - :: Interactive m - => InitFlags - -> InstalledPackageIndex - -> m LibTarget -genLibTarget flags pkgs = LibTarget + :: Interactive m + => InitFlags + -> InstalledPackageIndex + -> m LibTarget +genLibTarget flags pkgs = + LibTarget <$> srcDirsPrompt flags <*> languagePrompt flags "library" <*> getExposedModules flags @@ -206,13 +228,13 @@ genLibTarget flags pkgs = LibTarget -- generate a 'ExeTarget' object for creation. If the user specifies -- the generation of a simple package, then a simple target with defaults -- is generated. --- genExeTarget - :: Interactive m - => InitFlags - -> InstalledPackageIndex - -> m ExeTarget -genExeTarget flags pkgs = ExeTarget + :: Interactive m + => InitFlags + -> InstalledPackageIndex + -> m ExeTarget +genExeTarget flags pkgs = + ExeTarget <$> mainFilePrompt flags <*> appDirsPrompt flags <*> languagePrompt flags "executable" @@ -229,25 +251,25 @@ genExeTarget flags pkgs = ExeTarget -- Note: this workflow is only enabled if the user answers affirmatively -- when prompted, or if the user passes in the flag to enable -- test suites at command line. --- genTestTarget - :: Interactive m - => InitFlags - -> InstalledPackageIndex - -> m (Maybe TestTarget) + :: Interactive m + => InitFlags + -> InstalledPackageIndex + -> m (Maybe TestTarget) genTestTarget flags pkgs = initializeTestSuitePrompt flags >>= go where go initialized | not initialized = return Nothing - | otherwise = fmap Just $ TestTarget - <$> testMainPrompt - <*> testDirsPrompt flags - <*> languagePrompt flags "test suite" - <*> getOtherModules flags - <*> getOtherExts flags - <*> dependenciesPrompt pkgs flags - <*> getBuildTools flags - + | otherwise = + fmap Just $ + TestTarget + <$> testMainPrompt + <*> testDirsPrompt flags + <*> languagePrompt flags "test suite" + <*> getOtherModules flags + <*> getOtherExts flags + <*> dependenciesPrompt pkgs flags + <*> getBuildTools flags -- -------------------------------------------------------------------- -- -- Prompts @@ -261,13 +283,15 @@ overwritePrompt flags = do cabalVersionPrompt :: Interactive m => InitFlags -> m CabalSpecVersion cabalVersionPrompt flags = getCabalVersion flags $ do - v <- promptList "Please choose version of the Cabal specification to use" + v <- + promptList + "Please choose version of the Cabal specification to use" ppVersions (DefaultPrompt ppDefault) (Just takeVersion) False - -- take just the version numbers for convenience - return $ parseCabalVersion (takeVersion v) + -- take just the version numbers for convenience + return $ parseCabalVersion (takeVersion v) where -- only used when presenting the default in prompt takeVersion = takeWhile (/= ' ') @@ -283,38 +307,39 @@ cabalVersionPrompt flags = getCabalVersion flags $ do parseCabalVersion "3.0" = CabalSpecV3_0 parseCabalVersion "3.4" = CabalSpecV3_4 parseCabalVersion _ = defaultCabalVersion -- 2.4 - displayCabalVersion :: CabalSpecVersion -> String displayCabalVersion v = case v of - CabalSpecV2_0 -> "2.0 (support for Backpack, internal sub-libs, '^>=' operator)" - CabalSpecV2_2 -> "2.2 (+ support for 'common', 'elif', redundant commas, SPDX)" - 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')" + CabalSpecV2_0 -> "2.0 (support for Backpack, internal sub-libs, '^>=' operator)" + CabalSpecV2_2 -> "2.2 (+ support for 'common', 'elif', redundant commas, SPDX)" + 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')" _ -> showCabalSpecVersion v packageNamePrompt :: Interactive m => SourcePackageDb -> InitFlags -> m PackageName packageNamePrompt srcDb flags = getPackageName flags $ do - defName <- case packageDir flags of - Flag b -> filePathToPkgName b - NoFlag -> currentDirPkgName + defName <- case packageDir flags of + Flag b -> filePathToPkgName b + NoFlag -> currentDirPkgName - go $ DefaultPrompt defName + go $ DefaultPrompt defName where - go defName = prompt "Package name" defName >>= \n -> - if isPkgRegistered n - then do - don'tUseName <- promptYesNo (promptOtherNameMsg n) (DefaultPrompt True) - if don'tUseName - then go defName - else return n - else return n + go defName = + prompt "Package name" defName >>= \n -> + if isPkgRegistered n + then do + don'tUseName <- promptYesNo (promptOtherNameMsg n) (DefaultPrompt True) + if don'tUseName + then go defName + else return n + else return n isPkgRegistered = elemByPackageName (packageIndex srcDb) - inUseMsg pn = "The name " - ++ unPackageName pn - ++ " is already in use by another package on Hackage." + inUseMsg pn = + "The name " + ++ unPackageName pn + ++ " is already in use by another package on Hackage." promptOtherNameMsg pn = inUseMsg pn ++ " Do you want to choose a different name (y/n)" @@ -325,34 +350,38 @@ versionPrompt flags = getVersion flags go vv <- promptStr "Package version" (DefaultPrompt $ prettyShow defaultVersion) case simpleParsec vv of Nothing -> do - putStrLn - $ "Version must be a valid PVP format (e.g. 0.1.0.0): " - ++ vv + putStrLn $ + "Version must be a valid PVP format (e.g. 0.1.0.0): " + ++ vv go Just v -> return v licensePrompt :: Interactive m => InitFlags -> m SpecLicense licensePrompt flags = getLicense flags $ do - let csv = fromFlagOrDefault defaultCabalVersion (cabalVersion flags) - l <- promptList "Please choose a license" + let csv = fromFlagOrDefault defaultCabalVersion (cabalVersion flags) + l <- + promptList + "Please choose a license" (licenses csv) (DefaultPrompt "BSD-3-Clause") Nothing True - case simpleParsec' csv l of - Nothing -> do - putStrLn ( "The license must be a valid SPDX expression:" - ++ "\n - On the SPDX License List: https://spdx.org/licenses/" - ++ "\n - NONE, if you do not want to grant any license" - ++ "\n - LicenseRef-( alphanumeric | - | . )+" - ) - licensePrompt flags - Just l' -> return l' + case simpleParsec' csv l of + Nothing -> do + putStrLn + ( "The license must be a valid SPDX expression:" + ++ "\n - On the SPDX License List: https://spdx.org/licenses/" + ++ "\n - NONE, if you do not want to grant any license" + ++ "\n - LicenseRef-( alphanumeric | - | . )+" + ) + licensePrompt flags + Just l' -> return l' where - licenses csv = if csv >= CabalSpecV2_2 - then SPDX.licenseId <$> defaultLicenseIds - else fmap prettyShow knownLicenses + licenses csv = + if csv >= CabalSpecV2_2 + then SPDX.licenseId <$> defaultLicenseIds + else fmap prettyShow knownLicenses authorPrompt :: Interactive m => InitFlags -> m String authorPrompt flags = getAuthor flags $ guessAuthorName >>= promptOrDefault "Author name" @@ -361,17 +390,24 @@ emailPrompt :: Interactive m => InitFlags -> m String emailPrompt flags = getEmail flags $ guessAuthorEmail >>= promptOrDefault "Maintainer email" homepagePrompt :: Interactive m => InitFlags -> m String -homepagePrompt flags = getHomepage flags $ +homepagePrompt flags = + getHomepage flags $ promptStr "Project homepage URL" OptionalPrompt synopsisPrompt :: Interactive m => InitFlags -> m String -synopsisPrompt flags = getSynopsis flags $ +synopsisPrompt flags = + getSynopsis flags $ promptStr "Project synopsis" OptionalPrompt categoryPrompt :: Interactive m => InitFlags -> m String -categoryPrompt flags = getCategory flags $ promptList - "Project category" defaultCategories - (DefaultPrompt "") (Just matchNone) True +categoryPrompt flags = + getCategory flags $ + promptList + "Project category" + defaultCategories + (DefaultPrompt "") + (Just matchNone) + True where matchNone s | null s = "(none)" @@ -382,72 +418,79 @@ mainFilePrompt flags = getMainFile flags go where defaultMainIs' = show defaultMainIs go = do - fp <- promptList "What is the main module of the executable" - [defaultMainIs', "Main.lhs"] - (DefaultPrompt defaultMainIs') - Nothing - True + fp <- + promptList + "What is the main module of the executable" + [defaultMainIs', "Main.lhs"] + (DefaultPrompt defaultMainIs') + Nothing + True let hs = toHsFilePath fp case _hsFileType hs of InvalidHsPath -> do - putStrLn $ concat - [ "Main file " - , show hs - , " is not a valid haskell file. Source files must end in .hs or .lhs." - ] + putStrLn $ + concat + [ "Main file " + , show hs + , " is not a valid haskell file. Source files must end in .hs or .lhs." + ] go - _ -> return hs testDirsPrompt :: Interactive m => InitFlags -> m [String] testDirsPrompt flags = getTestDirs flags $ do - dir <- promptStr "Test directory" (DefaultPrompt defaultTestDir) - return [dir] + dir <- promptStr "Test directory" (DefaultPrompt defaultTestDir) + return [dir] languagePrompt :: Interactive m => InitFlags -> String -> m Language languagePrompt flags pkgType = getLanguage flags $ do - let h2010 = "Haskell2010" - h98 = "Haskell98" - ghc2021 = "GHC2021 (requires at least GHC 9.2)" + let h2010 = "Haskell2010" + h98 = "Haskell98" + ghc2021 = "GHC2021 (requires at least GHC 9.2)" - l <- promptList ("Choose a language for your " ++ pkgType) + l <- + promptList + ("Choose a language for your " ++ pkgType) [h2010, h98, ghc2021] (DefaultPrompt h2010) Nothing True - if - | l == h2010 -> return Haskell2010 - | l == h98 -> return Haskell98 - | l == ghc2021 -> return GHC2021 - | otherwise -> return $ UnknownLanguage l + if + | l == h2010 -> return Haskell2010 + | l == h98 -> return Haskell98 + | l == ghc2021 -> return GHC2021 + | otherwise -> return $ UnknownLanguage l noCommentsPrompt :: Interactive m => InitFlags -> m Bool noCommentsPrompt flags = getNoComments flags $ do - doComments <- promptYesNo + doComments <- + promptYesNo "Add informative comments to each field in the cabal file. (y/n)" (DefaultPrompt True) - -- - -- if --no-comments is flagged, then we choose not to generate comments - -- for fields in the cabal file, but it's a nicer UX to present the - -- affirmative question which must be negated. - -- + -- + -- if --no-comments is flagged, then we choose not to generate comments + -- for fields in the cabal file, but it's a nicer UX to present the + -- affirmative question which must be negated. + -- - return (not doComments) + return (not doComments) -- | Ask for the application root directory. appDirsPrompt :: Interactive m => InitFlags -> m [String] appDirsPrompt flags = getAppDirs flags $ do - dir <- promptList promptMsg + dir <- + promptList + promptMsg [defaultApplicationDir, "exe", "src-exe"] (DefaultPrompt defaultApplicationDir) Nothing True - return [dir] + return [dir] where promptMsg = case mainIs flags of Flag p -> "Application (" ++ p ++ ") directory" @@ -456,13 +499,15 @@ appDirsPrompt flags = getAppDirs flags $ do -- | Ask for the source (library) root directory. srcDirsPrompt :: Interactive m => InitFlags -> m [String] srcDirsPrompt flags = getSrcDirs flags $ do - dir <- promptList "Library source directory" + dir <- + promptList + "Library source directory" [defaultSourceDir, "lib", "src-lib"] (DefaultPrompt defaultSourceDir) Nothing True - return [dir] + return [dir] promptOrDefault :: Interactive m => String -> Maybe String -> m String -promptOrDefault s = maybe (promptStr s MandatoryPrompt) (promptStr s . DefaultPrompt) +promptOrDefault s = maybe (promptStr s MandatoryPrompt) (promptStr s . DefaultPrompt) diff --git a/cabal-install/src/Distribution/Client/Init/Licenses.hs b/cabal-install/src/Distribution/Client/Init/Licenses.hs index e08d3580fe3..ef648e9351f 100644 --- a/cabal-install/src/Distribution/Client/Init/Licenses.hs +++ b/cabal-install/src/Distribution/Client/Init/Licenses.hs @@ -1,13 +1,12 @@ -{-| -Module : Distribution.Client.Init.Licenses - -Description : Factory functions for producing known license types. - -License : BSD-like -Maintainer : cabal-devel@haskell.org -Stability : provisional -Portability : portable --} +-- | +-- Module : Distribution.Client.Init.Licenses +-- +-- Description : Factory functions for producing known license types. +-- +-- License : BSD-like +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable module Distribution.Client.Init.Licenses ( License , bsd2 @@ -28,7 +27,8 @@ import Prelude (String, unlines, (++)) type License = String bsd2 :: String -> String -> License -bsd2 authors year = unlines +bsd2 authors year = + unlines [ "Copyright (c) " ++ year ++ ", " ++ authors , "All rights reserved." , "" @@ -58,7 +58,8 @@ bsd2 authors year = unlines ] bsd3 :: String -> String -> License -bsd3 authors year = unlines +bsd3 authors year = + unlines [ "Copyright (c) " ++ year ++ ", " ++ authors , "" , "All rights reserved." @@ -92,7 +93,8 @@ bsd3 authors year = unlines ] gplv2 :: License -gplv2 = unlines +gplv2 = + unlines [ " GNU GENERAL PUBLIC LICENSE" , " Version 2, June 1991" , "" @@ -435,7 +437,8 @@ gplv2 = unlines ] gplv3 :: License -gplv3 = unlines +gplv3 = + unlines [ " GNU GENERAL PUBLIC LICENSE" , " Version 3, 29 June 2007" , "" @@ -1113,7 +1116,8 @@ gplv3 = unlines ] agplv3 :: License -agplv3 = unlines +agplv3 = + unlines [ " GNU AFFERO GENERAL PUBLIC LICENSE" , " Version 3, 19 November 2007" , "" @@ -1778,7 +1782,8 @@ agplv3 = unlines ] lgpl21 :: License -lgpl21 = unlines +lgpl21 = + unlines [ " GNU LESSER GENERAL PUBLIC LICENSE" , " Version 2.1, February 1999" , "" @@ -2284,7 +2289,8 @@ lgpl21 = unlines ] lgpl3 :: License -lgpl3 = unlines +lgpl3 = + unlines [ " GNU LESSER GENERAL PUBLIC LICENSE" , " Version 3, 29 June 2007" , "" @@ -2453,7 +2459,8 @@ lgpl3 = unlines ] apache20 :: License -apache20 = unlines +apache20 = + unlines [ "" , " Apache License" , " Version 2.0, January 2004" @@ -2659,7 +2666,8 @@ apache20 = unlines ] mit :: String -> String -> License -mit authors year = unlines +mit authors year = + unlines [ "Copyright (c) " ++ year ++ " " ++ authors , "" , "Permission is hereby granted, free of charge, to any person obtaining" @@ -2683,7 +2691,8 @@ mit authors year = unlines ] mpl20 :: License -mpl20 = unlines +mpl20 = + unlines [ "Mozilla Public License Version 2.0" , "==================================" , "" @@ -3060,7 +3069,8 @@ mpl20 = unlines ] isc :: String -> String -> License -isc authors year = unlines +isc authors year = + unlines [ "Copyright (c) " ++ year ++ " " ++ authors , "" , "Permission to use, copy, modify, and/or distribute this software for any purpose" diff --git a/cabal-install/src/Distribution/Client/Init/NonInteractive/Command.hs b/cabal-install/src/Distribution/Client/Init/NonInteractive/Command.hs index bc317247dfe..8c37cad96f2 100644 --- a/cabal-install/src/Distribution/Client/Init/NonInteractive/Command.hs +++ b/cabal-install/src/Distribution/Client/Init/NonInteractive/Command.hs @@ -1,82 +1,81 @@ {-# LANGUAGE LambdaCase #-} + module Distribution.Client.Init.NonInteractive.Command -( genPkgDescription -, genLibTarget -, genExeTarget -, genTestTarget -, createProject -, packageTypeHeuristics -, authorHeuristics -, emailHeuristics -, cabalVersionHeuristics -, packageNameHeuristics -, versionHeuristics -, mainFileHeuristics -, testDirsHeuristics -, initializeTestSuiteHeuristics -, exposedModulesHeuristics -, libOtherModulesHeuristics -, exeOtherModulesHeuristics -, testOtherModulesHeuristics -, buildToolsHeuristics -, dependenciesHeuristics -, otherExtsHeuristics -, licenseHeuristics -, homepageHeuristics -, synopsisHeuristics -, categoryHeuristics -, extraDocFileHeuristics -, appDirsHeuristics -, srcDirsHeuristics -, languageHeuristics -, noCommentsHeuristics -, minimalHeuristics -, overwriteHeuristics -) where + ( genPkgDescription + , genLibTarget + , genExeTarget + , genTestTarget + , createProject + , packageTypeHeuristics + , authorHeuristics + , emailHeuristics + , cabalVersionHeuristics + , packageNameHeuristics + , versionHeuristics + , mainFileHeuristics + , testDirsHeuristics + , initializeTestSuiteHeuristics + , exposedModulesHeuristics + , libOtherModulesHeuristics + , exeOtherModulesHeuristics + , testOtherModulesHeuristics + , buildToolsHeuristics + , dependenciesHeuristics + , otherExtsHeuristics + , licenseHeuristics + , homepageHeuristics + , synopsisHeuristics + , categoryHeuristics + , extraDocFileHeuristics + , appDirsHeuristics + , srcDirsHeuristics + , languageHeuristics + , noCommentsHeuristics + , minimalHeuristics + , overwriteHeuristics + ) where + import Distribution.Client.Init.Types +import Distribution.Client.Compat.Prelude hiding (getLine, head, last, putStr, putStrLn) import Prelude () -import Distribution.Client.Compat.Prelude hiding (putStr, putStrLn, getLine, last, head) -import Data.List (last, head) +import Data.List (head, last) import qualified Data.List.NonEmpty as NEL -import Distribution.CabalSpecVersion (CabalSpecVersion(..)) -import Distribution.Version (Version) -import Distribution.ModuleName (ModuleName, components) -import Distribution.Types.Dependency (Dependency(..)) -import Distribution.Types.PackageName (PackageName, unPackageName) +import Distribution.CabalSpecVersion (CabalSpecVersion (..)) import Distribution.Client.Init.Defaults +import Distribution.Client.Init.FlagExtractors import Distribution.Client.Init.NonInteractive.Heuristics import Distribution.Client.Init.Utils -import Distribution.Client.Init.FlagExtractors -import Distribution.Simple.Setup (Flag(..), fromFlagOrDefault) +import Distribution.Client.Types (SourcePackageDb (..)) +import Distribution.ModuleName (ModuleName, components) import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import Distribution.Client.Types (SourcePackageDb(..)) +import Distribution.Simple.Setup (Flag (..), fromFlagOrDefault) import Distribution.Solver.Types.PackageIndex (elemByPackageName) +import Distribution.Types.Dependency (Dependency (..)) +import Distribution.Types.PackageName (PackageName, unPackageName) import Distribution.Utils.Generic (safeHead) import Distribution.Verbosity +import Distribution.Version (Version) -import Language.Haskell.Extension (Language(..), Extension(..)) +import Language.Haskell.Extension (Extension (..), Language (..)) -import System.FilePath (splitDirectories, ()) -import Distribution.Simple.Compiler import qualified Data.Set as Set import Distribution.FieldGrammar.Newtypes - +import Distribution.Simple.Compiler +import System.FilePath (splitDirectories, ()) -- | Main driver for interactive prompt code. --- createProject - :: Interactive m - => Compiler - -> Verbosity - -> InstalledPackageIndex - -> SourcePackageDb - -> InitFlags - -> m ProjectSettings + :: Interactive m + => Compiler + -> Verbosity + -> InstalledPackageIndex + -> SourcePackageDb + -> InitFlags + -> m ProjectSettings createProject comp v pkgIx srcDb initFlags = do - -- The workflow is as follows: -- -- 1. Get the package type, supplied as either a program input or @@ -108,62 +107,85 @@ createProject comp v pkgIx srcDb initFlags = do let pkgName = _pkgName pkgDesc cabalSpec = _pkgCabalVersion pkgDesc - mkOpts cs = WriteOpts - doOverwrite isMinimal cs - v pkgDir pkgType pkgName + mkOpts cs = + WriteOpts + doOverwrite + isMinimal + cs + v + pkgDir + pkgType + pkgName case pkgType of Library -> do libTarget <- genLibTarget initFlags comp pkgIx cabalSpec - testTarget <- addLibDepToTest pkgName <$> - genTestTarget initFlags comp pkgIx cabalSpec - - return $ ProjectSettings - (mkOpts comments cabalSpec) pkgDesc - (Just libTarget) Nothing testTarget - + testTarget <- + addLibDepToTest pkgName + <$> genTestTarget initFlags comp pkgIx cabalSpec + + return $ + ProjectSettings + (mkOpts comments cabalSpec) + pkgDesc + (Just libTarget) + Nothing + testTarget Executable -> do exeTarget <- genExeTarget initFlags comp pkgIx cabalSpec - return $ ProjectSettings - (mkOpts comments cabalSpec) pkgDesc Nothing - (Just exeTarget) Nothing - + return $ + ProjectSettings + (mkOpts comments cabalSpec) + pkgDesc + Nothing + (Just exeTarget) + Nothing LibraryAndExecutable -> do libTarget <- genLibTarget initFlags comp pkgIx cabalSpec - exeTarget <- addLibDepToExe pkgName <$> - genExeTarget initFlags comp pkgIx cabalSpec - testTarget <- addLibDepToTest pkgName <$> - genTestTarget initFlags comp pkgIx cabalSpec - - return $ ProjectSettings - (mkOpts comments cabalSpec) pkgDesc (Just libTarget) - (Just exeTarget) testTarget - + exeTarget <- + addLibDepToExe pkgName + <$> genExeTarget initFlags comp pkgIx cabalSpec + testTarget <- + addLibDepToTest pkgName + <$> genTestTarget initFlags comp pkgIx cabalSpec + + return $ + ProjectSettings + (mkOpts comments cabalSpec) + pkgDesc + (Just libTarget) + (Just exeTarget) + testTarget TestSuite -> do testTarget <- genTestTarget initFlags comp pkgIx cabalSpec - return $ ProjectSettings - (mkOpts comments cabalSpec) pkgDesc - Nothing Nothing testTarget + return $ + ProjectSettings + (mkOpts comments cabalSpec) + pkgDesc + Nothing + Nothing + testTarget genPkgDescription :: Interactive m => InitFlags -> SourcePackageDb -> m PkgDescription -genPkgDescription flags srcDb = PkgDescription - <$> cabalVersionHeuristics flags - <*> packageNameHeuristics srcDb flags - <*> versionHeuristics flags - <*> licenseHeuristics flags - <*> authorHeuristics flags - <*> emailHeuristics flags - <*> homepageHeuristics flags - <*> synopsisHeuristics flags - <*> categoryHeuristics flags - <*> getExtraSrcFiles flags - <*> extraDocFileHeuristics flags +genPkgDescription flags srcDb = + PkgDescription + <$> cabalVersionHeuristics flags + <*> packageNameHeuristics srcDb flags + <*> versionHeuristics flags + <*> licenseHeuristics flags + <*> authorHeuristics flags + <*> emailHeuristics flags + <*> homepageHeuristics flags + <*> synopsisHeuristics flags + <*> categoryHeuristics flags + <*> getExtraSrcFiles flags + <*> extraDocFileHeuristics flags genLibTarget :: Interactive m @@ -173,7 +195,7 @@ genLibTarget -> CabalSpecVersion -> m LibTarget genLibTarget flags comp pkgs v = do - srcDirs <- srcDirsHeuristics flags + srcDirs <- srcDirsHeuristics flags let srcDir = fromMaybe defaultSourceDir $ safeHead srcDirs LibTarget srcDirs <$> languageHeuristics flags comp @@ -191,7 +213,7 @@ genExeTarget -> CabalSpecVersion -> m ExeTarget genExeTarget flags comp pkgs v = do - appDirs <- appDirsHeuristics flags + appDirs <- appDirsHeuristics flags let appDir = fromMaybe defaultApplicationDir $ safeHead appDirs ExeTarget <$> mainFileHeuristics flags @@ -214,15 +236,17 @@ genTestTarget flags comp pkgs v = do testDirs' <- testDirsHeuristics flags let testDir = fromMaybe defaultTestDir $ safeHead testDirs' if not initialized - then return Nothing - else fmap Just $ TestTarget - <$> testMainHeuristics flags - <*> pure testDirs' - <*> languageHeuristics flags comp - <*> testOtherModulesHeuristics flags - <*> otherExtsHeuristics flags testDir - <*> dependenciesHeuristics flags testDir pkgs - <*> buildToolsHeuristics flags testDir v + then return Nothing + else + fmap Just $ + TestTarget + <$> testMainHeuristics flags + <*> pure testDirs' + <*> languageHeuristics flags comp + <*> testOtherModulesHeuristics flags + <*> otherExtsHeuristics flags testDir + <*> dependenciesHeuristics flags testDir pkgs + <*> buildToolsHeuristics flags testDir v -- -------------------------------------------------------------------- -- -- Get flags from init config @@ -247,21 +271,22 @@ cabalVersionHeuristics flags = getCabalVersion flags guessCabalSpecVersion -- using an existing package name. packageNameHeuristics :: Interactive m => SourcePackageDb -> InitFlags -> m PackageName packageNameHeuristics sourcePkgDb flags = getPackageName flags $ do - defName <- guessPackageName =<< case packageDir flags of + defName <- + guessPackageName =<< case packageDir flags of Flag a -> return a NoFlag -> last . splitDirectories <$> getCurrentDirectory - when (isPkgRegistered defName) - $ putStrLn (inUseMsg defName) - - return defName + when (isPkgRegistered defName) $ + putStrLn (inUseMsg defName) + return defName where isPkgRegistered = elemByPackageName (packageIndex sourcePkgDb) - inUseMsg pn = "The name " - ++ unPackageName pn - ++ " is already in use by another package on Hackage." + inUseMsg pn = + "The name " + ++ unPackageName pn + ++ " is already in use by another package on Hackage." -- | Package version: use 0.1.0.0 as a last resort versionHeuristics :: Interactive m => InitFlags -> m Version @@ -276,14 +301,16 @@ licenseHeuristics flags = getLicense flags $ guessLicense flags -- | The author's name. Prompt, or try to guess from an existing -- git repo. authorHeuristics :: Interactive m => InitFlags -> m String -authorHeuristics flags = guessAuthorName >>= - maybe (getAuthor flags $ return "Unknown") (getAuthor flags . return) +authorHeuristics flags = + guessAuthorName + >>= maybe (getAuthor flags $ return "Unknown") (getAuthor flags . return) -- | The author's email. Prompt, or try to guess from an existing -- git repo. emailHeuristics :: Interactive m => InitFlags -> m String -emailHeuristics flags = guessAuthorEmail >>= - maybe (getEmail flags $ return "Unknown") (getEmail flags . return) +emailHeuristics flags = + guessAuthorEmail + >>= maybe (getEmail flags $ return "Unknown") (getEmail flags . return) -- | Prompt for a homepage URL for the package. homepageHeuristics :: Interactive m => InitFlags -> m String @@ -355,18 +382,17 @@ exposedModulesHeuristics flags = do if exists then do - modules <- filter isHaskell <$> listFilesRecursive srcDir + modules <- filter isHaskell <$> listFilesRecursive srcDir modulesNames <- catMaybes <$> traverse retrieveModuleName modules otherModules' <- libOtherModulesHeuristics flags return $ filter (`notElem` otherModules') modulesNames + else return [] - else - return [] - - return $ if null mods - then myLibModule NEL.:| [] - else NEL.fromList mods + return $ + if null mods + then myLibModule NEL.:| [] + else NEL.fromList mods -- | Retrieve the list of other modules for Libraries, filtering them -- based on the last component of the module name @@ -379,16 +405,18 @@ libOtherModulesHeuristics flags = case otherModules flags of Flag x -> fromMaybe defaultSourceDir $ safeHead x NoFlag -> defaultSourceDir - libDir <- ( srcDir) <$> case packageDir flags of - Flag x -> return x - NoFlag -> getCurrentDirectory + libDir <- + ( srcDir) <$> case packageDir flags of + Flag x -> return x + NoFlag -> getCurrentDirectory exists <- doesDirectoryExist libDir if exists then do otherModules' <- filter isHaskell <$> listFilesRecursive libDir filter ((`elem` otherCandidates) . last . components) - . catMaybes <$> traverse retrieveModuleName otherModules' + . catMaybes + <$> traverse retrieveModuleName otherModules' else return [] -- | Retrieve the list of other modules for Executables, it lists everything @@ -401,15 +429,17 @@ exeOtherModulesHeuristics flags = case otherModules flags of Flag x -> fromMaybe defaultApplicationDir $ safeHead x NoFlag -> defaultApplicationDir - exeDir <- ( appDir) <$> case packageDir flags of - Flag x -> return x - NoFlag -> getCurrentDirectory + exeDir <- + ( appDir) <$> case packageDir flags of + Flag x -> return x + NoFlag -> getCurrentDirectory exists <- doesDirectoryExist exeDir if exists then do - otherModules' <- filter (\f -> not (isMain f) && isHaskell f) - <$> listFilesRecursive exeDir + otherModules' <- + filter (\f -> not (isMain f) && isHaskell f) + <$> listFilesRecursive exeDir catMaybes <$> traverse retrieveModuleName otherModules' else return [] @@ -423,25 +453,27 @@ testOtherModulesHeuristics flags = case otherModules flags of Flag x -> fromMaybe defaultTestDir $ safeHead x NoFlag -> defaultTestDir - testDir' <- ( testDir) <$> case packageDir flags of - Flag x -> return x - NoFlag -> getCurrentDirectory + testDir' <- + ( testDir) <$> case packageDir flags of + Flag x -> return x + NoFlag -> getCurrentDirectory exists <- doesDirectoryExist testDir' if exists then do - otherModules' <- filter (\f -> not (isMain f) && isHaskell f) - <$> listFilesRecursive testDir' + otherModules' <- + filter (\f -> not (isMain f) && isHaskell f) + <$> listFilesRecursive testDir' catMaybes <$> traverse retrieveModuleName otherModules' else return [] -- | Retrieve the list of build tools buildToolsHeuristics - :: Interactive m - => InitFlags - -> FilePath - -> CabalSpecVersion - -> m [Dependency] + :: Interactive m + => InitFlags + -> FilePath + -> CabalSpecVersion + -> m [Dependency] buildToolsHeuristics flags fp v = case buildTools flags of Flag{} -> getBuildTools flags NoFlag -> retrieveBuildTools v fp @@ -455,9 +487,9 @@ dependenciesHeuristics flags fp pkgIx = getDependencies flags $ do Flag x -> x NoFlag -> map moduleName sources - groupedDeps = concatMap (\s -> map (\i -> (moduleName s, i)) (imports s)) sources + groupedDeps = concatMap (\s -> map (\i -> (moduleName s, i)) (imports s)) sources filteredDeps = filter ((`notElem` mods) . snd) groupedDeps - preludeNub = nubBy (\a b -> snd a == snd b) $ (fromString "Prelude", fromString "Prelude") : filteredDeps + preludeNub = nubBy (\a b -> snd a == snd b) $ (fromString "Prelude", fromString "Prelude") : filteredDeps retrieveDependencies (fromFlagOrDefault normal $ initVerbosity flags) flags preludeNub pkgIx @@ -469,9 +501,8 @@ otherExtsHeuristics flags fp = case otherExts flags of exists <- doesDirectoryExist fp if exists then do - sources <- listFilesRecursive fp + sources <- listFilesRecursive fp extensions' <- traverse retrieveModuleExtensions . filter isHaskell $ sources return $ nub . join $ extensions' - else - return [] + else return [] diff --git a/cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs b/cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs index 04c49279871..0fe0129d2c3 100644 --- a/cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs +++ b/cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs @@ -1,5 +1,9 @@ {-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.Init.NonInteractive.Heuristics -- Copyright : (c) Benedikt Huber 2009 @@ -10,8 +14,6 @@ -- Portability : portable -- -- Heuristics for creating initial cabal files. --- ------------------------------------------------------------------------------ module Distribution.Client.Init.NonInteractive.Heuristics ( guessPackageName , guessMainFile @@ -26,25 +28,23 @@ module Distribution.Client.Init.NonInteractive.Heuristics , guessApplicationDirectories ) where -import Distribution.Client.Compat.Prelude hiding (readFile, (<|>), many) +import Distribution.Client.Compat.Prelude hiding (many, readFile, (<|>)) import Distribution.Simple.Setup (fromFlagOrDefault) import qualified Data.List as L +import qualified Data.Set as Set +import Distribution.CabalSpecVersion import Distribution.Client.Init.Defaults import Distribution.Client.Init.FlagExtractors (getCabalVersionNoPrompt) import Distribution.Client.Init.Types import Distribution.Client.Init.Utils -import System.FilePath -import Distribution.CabalSpecVersion -import Language.Haskell.Extension -import Distribution.Version -import Distribution.Types.PackageName (PackageName) -import Distribution.Simple.Compiler -import qualified Data.Set as Set import Distribution.FieldGrammar.Newtypes - - +import Distribution.Simple.Compiler +import Distribution.Types.PackageName (PackageName) +import Distribution.Version +import Language.Haskell.Extension +import System.FilePath -- | Guess the main file, returns a default value if none is found. guessMainFile :: Interactive m => FilePath -> m HsFilePath @@ -52,12 +52,12 @@ guessMainFile pkgDir = do exists <- doesDirectoryExist pkgDir if exists then do - files <- filter isMain <$> listFilesRecursive pkgDir - return $ if null files - then defaultMainIs - else toHsFilePath $ L.head files - else - return defaultMainIs + files <- filter isMain <$> listFilesRecursive pkgDir + return $ + if null files + then defaultMainIs + else toHsFilePath $ L.head files + else return defaultMainIs -- | Juggling characters around to guess the desired cabal version based on -- the system's cabal version. @@ -66,15 +66,16 @@ guessCabalSpecVersion = do (_, verString, _) <- readProcessWithExitCode "cabal" ["--version"] "" case simpleParsec $ takeWhile (not . isSpace) $ dropWhile (not . isDigit) verString of Just v -> pure $ fromMaybe defaultCabalVersion $ case versionNumbers v of - [x,y,_,_] -> cabalSpecFromVersionDigits [x,y] - [x,y,_] -> cabalSpecFromVersionDigits [x,y] + [x, y, _, _] -> cabalSpecFromVersionDigits [x, y] + [x, y, _] -> cabalSpecFromVersionDigits [x, y] _ -> Just defaultCabalVersion Nothing -> pure defaultCabalVersion -- | Guess the language specification based on the GHC version guessLanguage :: Interactive m => Compiler -> m Language -guessLanguage Compiler {compilerId = CompilerId GHC ver} = - return $ if ver < mkVersion [7,0,1] +guessLanguage Compiler{compilerId = CompilerId GHC ver} = + return $ + if ver < mkVersion [7, 0, 1] then Haskell98 else Haskell2010 guessLanguage _ = return defaultLanguage @@ -92,63 +93,68 @@ guessLicense flags = return . defaultLicense $ getCabalVersionNoPrompt flags guessExtraDocFiles :: Interactive m => InitFlags -> m (Maybe (Set FilePath)) guessExtraDocFiles flags = do pkgDir <- fromFlagOrDefault getCurrentDirectory $ return <$> packageDir flags - files <- getDirectoryContents pkgDir + files <- getDirectoryContents pkgDir let extraDocCandidates = ["CHANGES", "CHANGELOG", "README"] extraDocs = [y | x <- extraDocCandidates, y <- files, x == map toUpper (takeBaseName y)] - return $ Just $ if null extraDocs - then Set.singleton defaultChangelog - else Set.fromList extraDocs + return $ + Just $ + if null extraDocs + then Set.singleton defaultChangelog + else Set.fromList extraDocs -- | Try to guess the package type from the files in the package directory, -- looking for unique characteristics from each type, defaults to Executable. guessPackageType :: Interactive m => InitFlags -> m PackageType guessPackageType flags = do if fromFlagOrDefault False (initializeTestSuite flags) - then - return TestSuite + then return TestSuite else do - let lastDir dirs = L.last . splitDirectories $ dirs - srcCandidates = [defaultSourceDir, "src", "source"] + let lastDir dirs = L.last . splitDirectories $ dirs + srcCandidates = [defaultSourceDir, "src", "source"] testCandidates = [defaultTestDir, "test", "tests"] pkgDir <- fromFlagOrDefault getCurrentDirectory $ return <$> packageDir flags - files <- listFilesInside (\x -> return $ lastDir x `notElem` testCandidates) pkgDir - files' <- filter (not . null . map (`elem` testCandidates) . splitDirectories) <$> - listFilesRecursive pkgDir + files <- listFilesInside (\x -> return $ lastDir x `notElem` testCandidates) pkgDir + files' <- + filter (not . null . map (`elem` testCandidates) . splitDirectories) + <$> listFilesRecursive pkgDir - let hasExe = not $ null [f | f <- files, isMain $ takeFileName f] - hasLib = not $ null [f | f <- files, lastDir f `elem` srcCandidates] - hasTest = not $ null [f | f <- files', isMain $ takeFileName f] + let hasExe = not $ null [f | f <- files, isMain $ takeFileName f] + hasLib = not $ null [f | f <- files, lastDir f `elem` srcCandidates] + hasTest = not $ null [f | f <- files', isMain $ takeFileName f] return $ case (hasLib, hasExe, hasTest) of - (True , True , _ ) -> LibraryAndExecutable - (True , False, _ ) -> Library + (True, True, _) -> LibraryAndExecutable + (True, False, _) -> Library (False, False, True) -> TestSuite - _ -> Executable + _ -> Executable -- | Try to guess the application directories from the package directory, -- using a default value as fallback. guessApplicationDirectories :: Interactive m => InitFlags -> m [FilePath] guessApplicationDirectories flags = do - pkgDirs <- fromFlagOrDefault getCurrentDirectory - (return <$> packageDir flags) + pkgDirs <- + fromFlagOrDefault + getCurrentDirectory + (return <$> packageDir flags) pkgDirsContents <- listDirectory pkgDirs - let candidates = [defaultApplicationDir, "app", "src-exe"] in - return $ case [y | x <- candidates, y <- pkgDirsContents, x == y] of - [] -> [defaultApplicationDir] - x -> map ( pkgDirs) . nub $ x + let candidates = [defaultApplicationDir, "app", "src-exe"] + in return $ case [y | x <- candidates, y <- pkgDirsContents, x == y] of + [] -> [defaultApplicationDir] + x -> map ( pkgDirs) . nub $ x -- | Try to guess the source directories, using a default value as fallback. guessSourceDirectories :: Interactive m => InitFlags -> m [FilePath] guessSourceDirectories flags = do pkgDir <- fromFlagOrDefault getCurrentDirectory $ return <$> packageDir flags - doesDirectoryExist (pkgDir "src") >>= return . \case - False -> [defaultSourceDir] - True -> ["src"] + doesDirectoryExist (pkgDir "src") + >>= return . \case + False -> [defaultSourceDir] + True -> ["src"] -- | Guess author and email using git configuration options. guessAuthorName :: Interactive m => m (Maybe String) @@ -164,10 +170,9 @@ guessGitInfo target = do 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) - + ExitSuccess -> return $ Just (trim $ snd' globalInfo) + _ -> return Nothing + else return $ Just (trim $ snd' localInfo) where fst' (x, _, _) = x snd' (_, x, _) = x diff --git a/cabal-install/src/Distribution/Client/Init/Prompt.hs b/cabal-install/src/Distribution/Client/Init/Prompt.hs index 2e7e25e25f7..7464a0d0145 100644 --- a/cabal-install/src/Distribution/Client/Init/Prompt.hs +++ b/cabal-install/src/Distribution/Client/Init/Prompt.hs @@ -1,6 +1,10 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.Init.Prompt -- Copyright : (c) Brent Yorgey 2009 @@ -11,23 +15,19 @@ -- Portability : portable -- -- User prompt utility functions for use by the 'cabal init' command. --- ------------------------------------------------------------------------------ - module Distribution.Client.Init.Prompt -( prompt -, promptYesNo -, promptStr -, promptList -) where + ( prompt + , promptYesNo + , promptStr + , promptList + ) where -import Prelude hiding (break, putStrLn, getLine, putStr) +import Prelude hiding (break, getLine, putStr, putStrLn) import Distribution.Client.Compat.Prelude hiding (break, empty, getLine, putStr, putStrLn) import Distribution.Client.Init.Types import qualified System.IO - -- | Create a prompt with optional default value that returns a -- String. promptStr :: Interactive m => String -> DefaultPrompt String -> m String @@ -35,21 +35,21 @@ promptStr = promptDefault Right id -- | Create a yes/no prompt with optional default value. promptYesNo - :: Interactive m - => String - -- ^ prompt message - -> DefaultPrompt Bool - -- ^ optional default value - -> m Bool + :: Interactive m + => String + -- ^ prompt message + -> DefaultPrompt Bool + -- ^ optional default value + -> m Bool promptYesNo = - promptDefault recogniseYesNo showYesNo + promptDefault recogniseYesNo showYesNo where recogniseYesNo s | (toLower <$> s) == "y" = Right True | (toLower <$> s) == "n" || s == "N" = Right False | otherwise = Left $ "Cannot parse input: " ++ s - showYesNo True = "y" + showYesNo True = "y" showYesNo False = "n" -- | Create a prompt with optional default value that returns a value @@ -68,94 +68,101 @@ mkDefPrompt msg def = msg ++ "?" ++ format def -- | Create a prompt from a list of strings promptList - :: Interactive m - => String - -- ^ prompt - -> [String] - -- ^ choices - -> DefaultPrompt String - -- ^ optional default value - -> Maybe (String -> String) - -- ^ modify the default value to present in-prompt - -- e.g. empty string maps to "(none)", but only in the - -- prompt. - -> Bool - -- ^ whether to allow an 'other' option - -> m String + :: Interactive m + => String + -- ^ prompt + -> [String] + -- ^ choices + -> DefaultPrompt String + -- ^ optional default value + -> Maybe (String -> String) + -- ^ modify the default value to present in-prompt + -- e.g. empty string maps to "(none)", but only in the + -- prompt. + -> Bool + -- ^ whether to allow an 'other' option + -> m String promptList msg choices def modDef hasOther = do putStrLn $ msg ++ ":" -- Output nicely formatted list of options - for_ prettyChoices $ \(i,c) -> do - let star = if DefaultPrompt c == def - then "*" - else " " - - let output = concat $ if i < 10 - then [" ", star, " ", show i, ") ", c] - else [" ", star, show i, ") ", c] + for_ prettyChoices $ \(i, c) -> do + let star = + if DefaultPrompt c == def + then "*" + else " " + + let output = + concat $ + if i < 10 + then [" ", star, " ", show i, ") ", c] + else [" ", star, show i, ") ", c] putStrLn output go - where - prettyChoices = - let cs = if hasOther - then choices ++ ["Other (specify)"] - else choices - in zip [1::Int .. length choices + 1] cs - - numChoices = length choices - - invalidChoice input = do - let msg' = if null input - then "Empty input is not a valid choice." - else concat - [ input - , " is not a valid choice. Please choose a number from 1 to " - , show (length prettyChoices) - , "." - ] + where + prettyChoices = + let cs = + if hasOther + then choices ++ ["Other (specify)"] + else choices + in zip [1 :: Int .. length choices + 1] cs + + numChoices = length choices + + invalidChoice input = do + let msg' = + if null input + then "Empty input is not a valid choice." + else + concat + [ input + , " is not a valid choice. Please choose a number from 1 to " + , show (length prettyChoices) + , "." + ] putStrLn msg' breakOrContinue ("promptList: " ++ input) go - go = do - putStr - $ mkDefPrompt "Your choice" - $ maybe def (<$> def) modDef - - input <- getLine - case def of - DefaultPrompt d | null input -> return d - _ -> case readMaybe input of - Nothing -> invalidChoice input - Just n - | n > 0, n <= numChoices -> return $ choices !! (n-1) - | n == numChoices + 1, hasOther -> - promptStr "Please specify" OptionalPrompt - | otherwise -> invalidChoice (show n) + go = do + putStr $ + mkDefPrompt "Your choice" $ + maybe def (<$> def) modDef + + input <- getLine + case def of + DefaultPrompt d | null input -> return d + _ -> case readMaybe input of + Nothing -> invalidChoice input + Just n + | n > 0, n <= numChoices -> return $ choices !! (n - 1) + | n == numChoices + 1 + , hasOther -> + promptStr "Please specify" OptionalPrompt + | otherwise -> invalidChoice (show n) -- | Create a prompt with an optional default value. promptDefault - :: Interactive m - => (String -> Either String t) - -- ^ parser - -> (t -> String) - -- ^ pretty-printer - -> String - -- ^ prompt message - -> (DefaultPrompt t) - -- ^ optional default value - -> m t + :: Interactive m + => (String -> Either String t) + -- ^ parser + -> (t -> String) + -- ^ pretty-printer + -> String + -- ^ prompt message + -> (DefaultPrompt t) + -- ^ optional default value + -> m t promptDefault parse pprint msg def = do putStr $ mkDefPrompt msg (pprint <$> def) hFlush System.IO.stdout input <- getLine case def of - DefaultPrompt d | null input -> return d - _ -> case parse input of - Right t -> return t + DefaultPrompt d | null input -> return d + _ -> case parse input of + Right t -> return t Left err -> do putStrLn $ "Couldn't parse " ++ input ++ ", please try again!" breakOrContinue @@ -164,8 +171,8 @@ promptDefault parse pprint msg def = do -- | Prompt utility for breaking out of an interactive loop -- in the pure case --- breakOrContinue :: Interactive m => String -> m a -> m a -breakOrContinue msg act = break >>= \case +breakOrContinue msg act = + break >>= \case True -> throwPrompt $ BreakException msg False -> act diff --git a/cabal-install/src/Distribution/Client/Init/Simple.hs b/cabal-install/src/Distribution/Client/Init/Simple.hs index 1b624b373a3..4d413085547 100644 --- a/cabal-install/src/Distribution/Client/Init/Simple.hs +++ b/cabal-install/src/Distribution/Client/Init/Simple.hs @@ -1,90 +1,111 @@ module Distribution.Client.Init.Simple -( -- * Project creation - createProject - -- * Gen targets -, genSimplePkgDesc -, genSimpleLibTarget -, genSimpleExeTarget -, genSimpleTestTarget -) where + ( -- * Project creation + createProject + -- * Gen targets + , genSimplePkgDesc + , genSimpleLibTarget + , genSimpleExeTarget + , genSimpleTestTarget + ) where -import Distribution.Client.Init.Types -import Distribution.Verbosity -import Distribution.Simple.PackageIndex -import Distribution.Client.Types.SourcePackageDb (SourcePackageDb(..)) import qualified Data.List.NonEmpty as NEL -import Distribution.Client.Init.Utils (currentDirPkgName, mkPackageNameDep, fixupDocFiles) +import qualified Data.Set as Set import Distribution.Client.Init.Defaults -import Distribution.Simple.Flag (fromFlagOrDefault, flagElim, Flag (..)) import Distribution.Client.Init.FlagExtractors -import qualified Data.Set as Set +import Distribution.Client.Init.Types +import Distribution.Client.Init.Utils (currentDirPkgName, fixupDocFiles, mkPackageNameDep) +import Distribution.Client.Types.SourcePackageDb (SourcePackageDb (..)) +import Distribution.Simple.Flag (Flag (..), flagElim, fromFlagOrDefault) +import Distribution.Simple.PackageIndex import Distribution.Types.Dependency import Distribution.Types.PackageName (unPackageName) - +import Distribution.Verbosity createProject - :: Interactive m - => Verbosity - -> InstalledPackageIndex - -> SourcePackageDb - -> InitFlags - -> m ProjectSettings + :: Interactive m + => Verbosity + -> InstalledPackageIndex + -> SourcePackageDb + -> InitFlags + -> m ProjectSettings createProject v pkgIx _srcDb initFlags = do - pkgType <- packageTypePrompt initFlags - isMinimal <- getMinimal initFlags - doOverwrite <- getOverwrite initFlags - pkgDir <- getPackageDir initFlags - pkgDesc <- fixupDocFiles v =<< genSimplePkgDesc initFlags - - let pkgName = _pkgName pkgDesc - cabalSpec = _pkgCabalVersion pkgDesc - mkOpts cs = WriteOpts - doOverwrite isMinimal cs - v pkgDir pkgType pkgName - - basedFlags <- addBaseDepToFlags pkgIx initFlags - - case pkgType of - Library -> do - libTarget <- genSimpleLibTarget basedFlags - testTarget <- addLibDepToTest pkgName <$> genSimpleTestTarget basedFlags - return $ ProjectSettings - (mkOpts False cabalSpec) pkgDesc - (Just libTarget) Nothing testTarget - - Executable -> do - exeTarget <- genSimpleExeTarget basedFlags - return $ ProjectSettings - (mkOpts False cabalSpec) pkgDesc - Nothing (Just exeTarget) Nothing - - LibraryAndExecutable -> do - libTarget <- genSimpleLibTarget basedFlags - testTarget <- addLibDepToTest pkgName <$> genSimpleTestTarget basedFlags - exeTarget <- addLibDepToExe pkgName <$> genSimpleExeTarget basedFlags - return $ ProjectSettings - (mkOpts False cabalSpec) pkgDesc - (Just libTarget) (Just exeTarget) testTarget - - TestSuite -> do - testTarget <- genSimpleTestTarget basedFlags - return $ ProjectSettings - (mkOpts False cabalSpec) pkgDesc - Nothing Nothing testTarget + pkgType <- packageTypePrompt initFlags + isMinimal <- getMinimal initFlags + doOverwrite <- getOverwrite initFlags + pkgDir <- getPackageDir initFlags + pkgDesc <- fixupDocFiles v =<< genSimplePkgDesc initFlags + + let pkgName = _pkgName pkgDesc + cabalSpec = _pkgCabalVersion pkgDesc + mkOpts cs = + WriteOpts + doOverwrite + isMinimal + cs + v + pkgDir + pkgType + pkgName + + basedFlags <- addBaseDepToFlags pkgIx initFlags + + case pkgType of + Library -> do + libTarget <- genSimpleLibTarget basedFlags + testTarget <- addLibDepToTest pkgName <$> genSimpleTestTarget basedFlags + return $ + ProjectSettings + (mkOpts False cabalSpec) + pkgDesc + (Just libTarget) + Nothing + testTarget + Executable -> do + exeTarget <- genSimpleExeTarget basedFlags + return $ + ProjectSettings + (mkOpts False cabalSpec) + pkgDesc + Nothing + (Just exeTarget) + Nothing + LibraryAndExecutable -> do + libTarget <- genSimpleLibTarget basedFlags + testTarget <- addLibDepToTest pkgName <$> genSimpleTestTarget basedFlags + exeTarget <- addLibDepToExe pkgName <$> genSimpleExeTarget basedFlags + return $ + ProjectSettings + (mkOpts False cabalSpec) + pkgDesc + (Just libTarget) + (Just exeTarget) + testTarget + TestSuite -> do + testTarget <- genSimpleTestTarget basedFlags + return $ + ProjectSettings + (mkOpts False cabalSpec) + pkgDesc + Nothing + Nothing + testTarget where -- Add package name as dependency of test suite -- addLibDepToTest _ Nothing = Nothing - addLibDepToTest n (Just t) = Just $ t - { _testDependencies = _testDependencies t ++ [mkPackageNameDep n] - } + addLibDepToTest n (Just t) = + Just $ + t + { _testDependencies = _testDependencies t ++ [mkPackageNameDep n] + } -- Add package name as dependency of executable -- - addLibDepToExe n exe = exe - { _exeDependencies = _exeDependencies exe ++ [mkPackageNameDep n] - } + addLibDepToExe n exe = + exe + { _exeDependencies = _exeDependencies exe ++ [mkPackageNameDep n] + } genSimplePkgDesc :: Interactive m => InitFlags -> m PkgDescription genSimplePkgDesc flags = mkPkgDesc <$> currentDirPkgName @@ -94,44 +115,46 @@ genSimplePkgDesc flags = mkPkgDesc <$> currentDirPkgName extractExtraDoc [] = defaultExtraDoc extractExtraDoc fs = Just $ Set.fromList fs - mkPkgDesc pkgName = PkgDescription - (fromFlagOrDefault defaultCabalVersion (cabalVersion flags)) - pkgName - (fromFlagOrDefault defaultVersion (version flags)) - (fromFlagOrDefault (defaultLicense $ getCabalVersionNoPrompt flags) (license flags)) - (fromFlagOrDefault "" (author flags)) - (fromFlagOrDefault "" (email flags)) - (fromFlagOrDefault "" (homepage flags)) - (fromFlagOrDefault "" (synopsis flags)) - (fromFlagOrDefault "" (category flags)) - (flagElim mempty Set.fromList (extraSrc flags)) - (flagElim defaultExtraDoc extractExtraDoc (extraDoc flags)) + mkPkgDesc pkgName = + PkgDescription + (fromFlagOrDefault defaultCabalVersion (cabalVersion flags)) + pkgName + (fromFlagOrDefault defaultVersion (version flags)) + (fromFlagOrDefault (defaultLicense $ getCabalVersionNoPrompt flags) (license flags)) + (fromFlagOrDefault "" (author flags)) + (fromFlagOrDefault "" (email flags)) + (fromFlagOrDefault "" (homepage flags)) + (fromFlagOrDefault "" (synopsis flags)) + (fromFlagOrDefault "" (category flags)) + (flagElim mempty Set.fromList (extraSrc flags)) + (flagElim defaultExtraDoc extractExtraDoc (extraDoc flags)) genSimpleLibTarget :: Interactive m => InitFlags -> m LibTarget genSimpleLibTarget flags = do - buildToolDeps <- getBuildTools flags - return $ LibTarget + buildToolDeps <- getBuildTools flags + return $ + LibTarget { _libSourceDirs = fromFlagOrDefault [defaultSourceDir] $ sourceDirs flags , _libLanguage = fromFlagOrDefault defaultLanguage $ language flags , _libExposedModules = - flagElim (myLibModule NEL.:| []) extractMods $ exposedModules flags + flagElim (myLibModule NEL.:| []) extractMods $ exposedModules flags , _libOtherModules = fromFlagOrDefault [] $ otherModules flags , _libOtherExts = fromFlagOrDefault [] $ otherExts flags , _libDependencies = fromFlagOrDefault [] $ dependencies flags , _libBuildTools = buildToolDeps } - where extractMods [] = myLibModule NEL.:| [] extractMods as = NEL.fromList as genSimpleExeTarget :: Interactive m => InitFlags -> m ExeTarget genSimpleExeTarget flags = do - buildToolDeps <- getBuildTools flags - return $ ExeTarget + buildToolDeps <- getBuildTools flags + return $ + ExeTarget { _exeMainIs = flagElim defaultMainIs toHsFilePath $ mainIs flags - , _exeApplicationDirs = - fromFlagOrDefault [defaultApplicationDir] $ applicationDirs flags + , _exeApplicationDirs = + fromFlagOrDefault [defaultApplicationDir] $ applicationDirs flags , _exeLanguage = fromFlagOrDefault defaultLanguage $ language flags , _exeOtherModules = fromFlagOrDefault [] $ otherModules flags , _exeOtherExts = fromFlagOrDefault [] $ otherExts flags @@ -145,16 +168,18 @@ genSimpleTestTarget flags = go =<< initializeTestSuitePrompt flags go initialized | not initialized = return Nothing | otherwise = do - buildToolDeps <- getBuildTools flags - return $ Just $ TestTarget - { _testMainIs = flagElim defaultMainIs toHsFilePath $ mainIs flags - , _testDirs = fromFlagOrDefault [defaultTestDir] $ testDirs flags - , _testLanguage = fromFlagOrDefault defaultLanguage $ language flags - , _testOtherModules = fromFlagOrDefault [] $ otherModules flags - , _testOtherExts = fromFlagOrDefault [] $ otherExts flags - , _testDependencies = fromFlagOrDefault [] $ dependencies flags - , _testBuildTools = buildToolDeps - } + buildToolDeps <- getBuildTools flags + return $ + Just $ + TestTarget + { _testMainIs = flagElim defaultMainIs toHsFilePath $ mainIs flags + , _testDirs = fromFlagOrDefault [defaultTestDir] $ testDirs flags + , _testLanguage = fromFlagOrDefault defaultLanguage $ language flags + , _testOtherModules = fromFlagOrDefault [] $ otherModules flags + , _testOtherExts = fromFlagOrDefault [] $ otherExts flags + , _testDependencies = fromFlagOrDefault [] $ dependencies flags + , _testBuildTools = buildToolDeps + } -- -------------------------------------------------------------------- -- -- Utils @@ -166,10 +191,11 @@ addBaseDepToFlags pkgIx initFlags = case dependencies initFlags of Flag as | any ((==) "base" . unPackageName . depPkgName) as -> return initFlags | otherwise -> do - based <- dependenciesPrompt pkgIx initFlags - return $ initFlags - { dependencies = Flag $ based ++ as - } + based <- dependenciesPrompt pkgIx initFlags + return $ + initFlags + { dependencies = Flag $ based ++ as + } NoFlag -> do based <- dependenciesPrompt pkgIx initFlags - return initFlags { dependencies = Flag based } + return initFlags{dependencies = Flag based} diff --git a/cabal-install/src/Distribution/Client/Init/Types.hs b/cabal-install/src/Distribution/Client/Init/Types.hs index 36d32a89977..41513d0f048 100644 --- a/cabal-install/src/Distribution/Client/Init/Types.hs +++ b/cabal-install/src/Distribution/Client/Init/Types.hs @@ -1,7 +1,8 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE BangPatterns #-} + -- | -- Module : Distribution.Client.Init.Types -- Copyright : (c) Brent Yorgey, Benedikt Huber 2009 @@ -12,71 +13,75 @@ -- Portability : portable -- -- Some types used by the 'cabal init' command. --- module Distribution.Client.Init.Types -( -- * Data - InitFlags(..) - -- ** Targets and descriptions -, PkgDescription(..) -, LibTarget(..) -, ExeTarget(..) -, TestTarget(..) - -- ** package types -, PackageType(..) - -- ** Main file -, HsFilePath(..) -, HsFileType(..) -, fromHsFilePath -, toHsFilePath -, toLiterateHs -, toStandardHs -, mkLiterate -, isHsFilePath - -- * Typeclasses -, Interactive(..) -, BreakException(..) -, PurePrompt(..) -, evalPrompt -, Severity(..) - -- * Aliases -, IsLiterate -, IsSimple - -- * File creator opts -, WriteOpts(..) -, ProjectSettings(..) - -- * Formatters -, FieldAnnotation(..) - -- * Other conveniences -, DefaultPrompt(..) -) where - + ( -- * Data + InitFlags (..) + + -- ** Targets and descriptions + , PkgDescription (..) + , LibTarget (..) + , ExeTarget (..) + , TestTarget (..) + + -- ** package types + , PackageType (..) + + -- ** Main file + , HsFilePath (..) + , HsFileType (..) + , fromHsFilePath + , toHsFilePath + , toLiterateHs + , toStandardHs + , mkLiterate + , isHsFilePath + + -- * Typeclasses + , Interactive (..) + , BreakException (..) + , PurePrompt (..) + , evalPrompt + , Severity (..) + + -- * Aliases + , IsLiterate + , IsSimple + + -- * File creator opts + , WriteOpts (..) + , ProjectSettings (..) + + -- * Formatters + , FieldAnnotation (..) + + -- * Other conveniences + , DefaultPrompt (..) + ) where -import qualified Distribution.Client.Compat.Prelude as P import Distribution.Client.Compat.Prelude as P hiding (getLine, putStr, putStrLn) +import qualified Distribution.Client.Compat.Prelude as P import Prelude (read) import Control.Monad.Catch import Data.List.NonEmpty (fromList) -import Distribution.Simple.Setup (Flag(..)) -import Distribution.Types.Dependency as P -import Distribution.Verbosity (silent) -import Distribution.Version -import qualified Distribution.Package as P -import Distribution.ModuleName import Distribution.CabalSpecVersion import Distribution.Client.Utils as P import Distribution.Fields.Pretty -import Language.Haskell.Extension ( Language(..), Extension ) +import Distribution.ModuleName +import qualified Distribution.Package as P +import Distribution.Simple.Setup (Flag (..)) +import Distribution.Verbosity (silent) +import Distribution.Version +import Language.Haskell.Extension (Extension, Language (..)) import qualified System.IO -import qualified System.Directory as P -import qualified System.Process as Process import qualified Distribution.Compat.Environment as P -import System.FilePath import Distribution.FieldGrammar.Newtypes (SpecLicense) - +import qualified System.Directory as P +import System.FilePath +import qualified System.Process as Process -- -------------------------------------------------------------------- -- -- Flags @@ -84,42 +89,41 @@ import Distribution.FieldGrammar.Newtypes (SpecLicense) -- | InitFlags is a subset of flags available in the -- @.cabal@ file that represent options that are relevant to the -- init command process. --- -data InitFlags = - InitFlags - { interactive :: Flag Bool - , quiet :: Flag Bool - , packageDir :: Flag FilePath - , noComments :: Flag Bool - , minimal :: Flag Bool - , simpleProject :: Flag Bool - , packageName :: Flag P.PackageName - , version :: Flag Version - , cabalVersion :: Flag CabalSpecVersion - , license :: Flag SpecLicense - , author :: Flag String - , email :: Flag String - , homepage :: Flag String - , synopsis :: Flag String - , category :: Flag String - , extraSrc :: Flag [String] - , extraDoc :: Flag [String] - , packageType :: Flag PackageType - , mainIs :: Flag FilePath - , language :: Flag Language - , exposedModules :: Flag [ModuleName] - , otherModules :: Flag [ModuleName] - , otherExts :: Flag [Extension] - , dependencies :: Flag [P.Dependency] - , applicationDirs :: Flag [String] - , sourceDirs :: Flag [String] - , buildTools :: Flag [String] - , initializeTestSuite :: Flag Bool - , testDirs :: Flag [String] - , initHcPath :: Flag FilePath - , initVerbosity :: Flag Verbosity - , overwrite :: Flag Bool - } deriving (Eq, Show, Generic) +data InitFlags = InitFlags + { interactive :: Flag Bool + , quiet :: Flag Bool + , packageDir :: Flag FilePath + , noComments :: Flag Bool + , minimal :: Flag Bool + , simpleProject :: Flag Bool + , packageName :: Flag P.PackageName + , version :: Flag Version + , cabalVersion :: Flag CabalSpecVersion + , license :: Flag SpecLicense + , author :: Flag String + , email :: Flag String + , homepage :: Flag String + , synopsis :: Flag String + , category :: Flag String + , extraSrc :: Flag [String] + , extraDoc :: Flag [String] + , packageType :: Flag PackageType + , mainIs :: Flag FilePath + , language :: Flag Language + , exposedModules :: Flag [ModuleName] + , otherModules :: Flag [ModuleName] + , otherExts :: Flag [Extension] + , dependencies :: Flag [P.Dependency] + , applicationDirs :: Flag [String] + , sourceDirs :: Flag [String] + , buildTools :: Flag [String] + , initializeTestSuite :: Flag Bool + , testDirs :: Flag [String] + , initHcPath :: Flag FilePath + , initVerbosity :: Flag Verbosity + , overwrite :: Flag Bool + } + deriving (Eq, Show, Generic) instance Monoid InitFlags where mempty = gmempty @@ -134,322 +138,329 @@ instance Semigroup InitFlags where -- | 'PkgDescription' represents the relevant options set by the -- user when building a package description during the init command -- process. --- data PkgDescription = PkgDescription - { _pkgCabalVersion :: CabalSpecVersion - , _pkgName :: P.PackageName - , _pkgVersion :: Version - , _pkgLicense :: SpecLicense - , _pkgAuthor :: String - , _pkgEmail :: String - , _pkgHomePage :: String - , _pkgSynopsis :: String - , _pkgCategory :: String - , _pkgExtraSrcFiles :: Set String - , _pkgExtraDocFiles :: Maybe (Set String) - } deriving (Show, Eq) + { _pkgCabalVersion :: CabalSpecVersion + , _pkgName :: P.PackageName + , _pkgVersion :: Version + , _pkgLicense :: SpecLicense + , _pkgAuthor :: String + , _pkgEmail :: String + , _pkgHomePage :: String + , _pkgSynopsis :: String + , _pkgCategory :: String + , _pkgExtraSrcFiles :: Set String + , _pkgExtraDocFiles :: Maybe (Set String) + } + deriving (Show, Eq) -- | 'LibTarget' represents the relevant options set by the -- user when building a library package during the init command -- process. --- data LibTarget = LibTarget - { _libSourceDirs :: [String] - , _libLanguage :: Language - , _libExposedModules :: NonEmpty ModuleName - , _libOtherModules :: [ModuleName] - , _libOtherExts :: [Extension] - , _libDependencies :: [P.Dependency] - , _libBuildTools :: [P.Dependency] - } deriving (Show, Eq) + { _libSourceDirs :: [String] + , _libLanguage :: Language + , _libExposedModules :: NonEmpty ModuleName + , _libOtherModules :: [ModuleName] + , _libOtherExts :: [Extension] + , _libDependencies :: [P.Dependency] + , _libBuildTools :: [P.Dependency] + } + deriving (Show, Eq) -- | 'ExeTarget' represents the relevant options set by the -- user when building an executable package. --- data ExeTarget = ExeTarget - { _exeMainIs :: HsFilePath - , _exeApplicationDirs :: [String] - , _exeLanguage :: Language - , _exeOtherModules :: [ModuleName] - , _exeOtherExts :: [Extension] - , _exeDependencies :: [P.Dependency] - , _exeBuildTools :: [P.Dependency] - } deriving (Show, Eq) + { _exeMainIs :: HsFilePath + , _exeApplicationDirs :: [String] + , _exeLanguage :: Language + , _exeOtherModules :: [ModuleName] + , _exeOtherExts :: [Extension] + , _exeDependencies :: [P.Dependency] + , _exeBuildTools :: [P.Dependency] + } + deriving (Show, Eq) -- | 'TestTarget' represents the relevant options set by the -- user when building a library package. --- data TestTarget = TestTarget - { _testMainIs :: HsFilePath - , _testDirs :: [String] - , _testLanguage :: Language - , _testOtherModules :: [ModuleName] - , _testOtherExts :: [Extension] - , _testDependencies :: [P.Dependency] - , _testBuildTools :: [P.Dependency] - } deriving (Show, Eq) + { _testMainIs :: HsFilePath + , _testDirs :: [String] + , _testLanguage :: Language + , _testOtherModules :: [ModuleName] + , _testOtherExts :: [Extension] + , _testDependencies :: [P.Dependency] + , _testBuildTools :: [P.Dependency] + } + deriving (Show, Eq) -- -------------------------------------------------------------------- -- -- File creator options data WriteOpts = WriteOpts - { _optOverwrite :: Bool - , _optMinimal :: Bool - , _optNoComments :: Bool - , _optVerbosity :: Verbosity - , _optPkgDir :: FilePath - , _optPkgType :: PackageType - , _optPkgName :: P.PackageName - , _optCabalSpec :: CabalSpecVersion - } deriving (Eq, Show) + { _optOverwrite :: Bool + , _optMinimal :: Bool + , _optNoComments :: Bool + , _optVerbosity :: Verbosity + , _optPkgDir :: FilePath + , _optPkgType :: PackageType + , _optPkgName :: P.PackageName + , _optCabalSpec :: CabalSpecVersion + } + deriving (Eq, Show) data ProjectSettings = ProjectSettings - { _pkgOpts :: WriteOpts - , _pkgDesc :: PkgDescription - , _pkgLibTarget :: Maybe LibTarget - , _pkgExeTarget :: Maybe ExeTarget - , _pkgTestTarget :: Maybe TestTarget - } deriving (Eq, Show) + { _pkgOpts :: WriteOpts + , _pkgDesc :: PkgDescription + , _pkgLibTarget :: Maybe LibTarget + , _pkgExeTarget :: Maybe ExeTarget + , _pkgTestTarget :: Maybe TestTarget + } + deriving (Eq, Show) -- -------------------------------------------------------------------- -- -- Other types -- | Enum to denote whether the user wants to build a library target, -- executable target, library and executable targets, or a standalone test suite. --- data PackageType = Library | Executable | LibraryAndExecutable | TestSuite - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic) data HsFileType - = Literate - | Standard - | InvalidHsPath - deriving (Eq, Show) + = Literate + | Standard + | InvalidHsPath + deriving (Eq, Show) data HsFilePath = HsFilePath - { _hsFilePath :: FilePath - , _hsFileType :: HsFileType - } deriving Eq + { _hsFilePath :: FilePath + , _hsFileType :: HsFileType + } + deriving (Eq) instance Show HsFilePath where - show (HsFilePath fp ty) = case ty of - Literate -> fp - Standard -> fp - InvalidHsPath -> "Invalid haskell source file: " ++ fp + show (HsFilePath fp ty) = case ty of + Literate -> fp + Standard -> fp + InvalidHsPath -> "Invalid haskell source file: " ++ fp fromHsFilePath :: HsFilePath -> Maybe FilePath fromHsFilePath (HsFilePath fp ty) = case ty of - Literate -> Just fp - Standard -> Just fp - InvalidHsPath -> Nothing + Literate -> Just fp + Standard -> Just fp + InvalidHsPath -> Nothing isHsFilePath :: FilePath -> Bool isHsFilePath fp = case _hsFileType $ toHsFilePath fp of - InvalidHsPath -> False - _ -> True + InvalidHsPath -> False + _ -> True toHsFilePath :: FilePath -> HsFilePath toHsFilePath fp - | takeExtension fp == ".lhs" = HsFilePath fp Literate - | takeExtension fp == ".hs" = HsFilePath fp Standard - | otherwise = HsFilePath fp InvalidHsPath + | takeExtension fp == ".lhs" = HsFilePath fp Literate + | takeExtension fp == ".hs" = HsFilePath fp Standard + | otherwise = HsFilePath fp InvalidHsPath toLiterateHs :: HsFilePath -> HsFilePath -toLiterateHs (HsFilePath fp Standard) = HsFilePath +toLiterateHs (HsFilePath fp Standard) = + HsFilePath (dropExtension fp ++ ".lhs") Literate toLiterateHs a = a toStandardHs :: HsFilePath -> HsFilePath -toStandardHs (HsFilePath fp Literate) = HsFilePath +toStandardHs (HsFilePath fp Literate) = + HsFilePath (dropExtension fp ++ ".hs") Standard toStandardHs a = a mkLiterate :: HsFilePath -> [String] -> [String] mkLiterate (HsFilePath _ Literate) hs = - (\line -> if null line then line else "> " ++ line) <$> hs + (\line -> if null line then line else "> " ++ line) <$> hs mkLiterate _ hs = hs -- -------------------------------------------------------------------- -- -- Interactive prompt monad newtype PurePrompt a = PurePrompt - { _runPrompt - :: NonEmpty String - -> Either BreakException (a, NonEmpty String) - } deriving (Functor) + { _runPrompt + :: NonEmpty String + -> Either BreakException (a, NonEmpty String) + } + deriving (Functor) evalPrompt :: PurePrompt a -> NonEmpty String -> a evalPrompt act s = case _runPrompt act s of - Left e -> error $ show e - Right (a,_) -> a + Left e -> error $ show e + Right (a, _) -> a instance Applicative PurePrompt where - pure a = PurePrompt $ \s -> Right (a, s) - PurePrompt ff <*> PurePrompt aa = PurePrompt $ \s -> case ff s of + pure a = PurePrompt $ \s -> Right (a, s) + PurePrompt ff <*> PurePrompt aa = PurePrompt $ \s -> case ff s of + Left e -> Left e + Right (f, s') -> case aa s' of Left e -> Left e - Right (f, s') -> case aa s' of - Left e -> Left e - Right (a, s'') -> Right (f a, s'') + Right (a, s'') -> Right (f a, s'') instance Monad PurePrompt where - return = pure - PurePrompt a >>= k = PurePrompt $ \s -> case a s of - Left e -> Left e - Right (a', s') -> _runPrompt (k a') s' + return = pure + PurePrompt a >>= k = PurePrompt $ \s -> case a s of + Left e -> Left e + Right (a', s') -> _runPrompt (k a') s' class Monad m => Interactive m where - -- input functions - getLine :: m String - readFile :: FilePath -> m String - getCurrentDirectory :: m FilePath - getHomeDirectory :: m FilePath - getDirectoryContents :: FilePath -> m [FilePath] - listDirectory :: FilePath -> m [FilePath] - doesDirectoryExist :: FilePath -> m Bool - doesFileExist :: FilePath -> m Bool - canonicalizePathNoThrow :: FilePath -> m FilePath - readProcessWithExitCode :: FilePath -> [String] -> String -> m (ExitCode, String, String) - getEnvironment :: m [(String, String)] - getCurrentYear :: m Integer - listFilesInside :: (FilePath -> m Bool) -> FilePath -> m [FilePath] - listFilesRecursive :: FilePath -> m [FilePath] - - -- output functions - putStr :: String -> m () - putStrLn :: String -> m () - createDirectory :: FilePath -> m () - removeDirectory :: FilePath -> m () - writeFile :: FilePath -> String -> m () - removeExistingFile :: FilePath -> m () - copyFile :: FilePath -> FilePath -> m () - renameDirectory :: FilePath -> FilePath -> m () - hFlush :: System.IO.Handle -> m () - message :: Verbosity -> Severity -> String -> m () - - -- misc functions - break :: m Bool - throwPrompt :: BreakException -> m a + -- input functions + getLine :: m String + readFile :: FilePath -> m String + getCurrentDirectory :: m FilePath + getHomeDirectory :: m FilePath + getDirectoryContents :: FilePath -> m [FilePath] + listDirectory :: FilePath -> m [FilePath] + doesDirectoryExist :: FilePath -> m Bool + doesFileExist :: FilePath -> m Bool + canonicalizePathNoThrow :: FilePath -> m FilePath + readProcessWithExitCode :: FilePath -> [String] -> String -> m (ExitCode, String, String) + getEnvironment :: m [(String, String)] + getCurrentYear :: m Integer + listFilesInside :: (FilePath -> m Bool) -> FilePath -> m [FilePath] + listFilesRecursive :: FilePath -> m [FilePath] + + -- output functions + putStr :: String -> m () + putStrLn :: String -> m () + createDirectory :: FilePath -> m () + removeDirectory :: FilePath -> m () + writeFile :: FilePath -> String -> m () + removeExistingFile :: FilePath -> m () + copyFile :: FilePath -> FilePath -> m () + renameDirectory :: FilePath -> FilePath -> m () + hFlush :: System.IO.Handle -> m () + message :: Verbosity -> Severity -> String -> m () + + -- misc functions + 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 - - 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 - message q severity msg - | q == silent = pure () - | otherwise = putStrLn $ "[" ++ show severity ++ "] " ++ msg - break = return False - throwPrompt = throwM + 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 + + 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 + message q severity msg + | q == silent = pure () + | otherwise = putStrLn $ "[" ++ show severity ++ "] " ++ msg + break = return False + throwPrompt = throwM instance Interactive PurePrompt where - getLine = pop - readFile !_ = pop - getCurrentDirectory = popAbsolute - getHomeDirectory = popAbsolute - -- expects stack input of form "[\"foo\", \"bar\", \"baz\"]" - getDirectoryContents !_ = popList - listDirectory !_ = popList - doesDirectoryExist !_ = popBool - doesFileExist !_ = popBool - canonicalizePathNoThrow !_ = popAbsolute - readProcessWithExitCode !_ !_ !_ = do - input <- pop - return (ExitSuccess, input, "") - getEnvironment = fmap (map read) popList - getCurrentYear = fmap read pop - listFilesInside pred' !_ = do - input <- map splitDirectories <$> popList - map joinPath <$> filterM (fmap and . traverse pred') input - listFilesRecursive !_ = popList - - putStr !_ = return () - putStrLn !_ = return () - createDirectory !d = checkInvalidPath d () - removeDirectory !d = checkInvalidPath d () - writeFile !f !_ = checkInvalidPath f () - removeExistingFile !f = checkInvalidPath f () - copyFile !f !_ = checkInvalidPath f () - renameDirectory !d !_ = checkInvalidPath d () - hFlush _ = return () - message !_ !severity !msg = case severity of - Error -> PurePrompt $ \_ -> Left $ BreakException - (show severity ++ ": " ++ msg) - _ -> return () - - break = return True - throwPrompt (BreakException e) = PurePrompt $ \s -> Left $ BreakException - ("Error: " ++ e ++ "\nStacktrace: " ++ show s) + getLine = pop + readFile !_ = pop + getCurrentDirectory = popAbsolute + getHomeDirectory = popAbsolute + + -- expects stack input of form "[\"foo\", \"bar\", \"baz\"]" + getDirectoryContents !_ = popList + listDirectory !_ = popList + doesDirectoryExist !_ = popBool + doesFileExist !_ = popBool + canonicalizePathNoThrow !_ = popAbsolute + readProcessWithExitCode !_ !_ !_ = do + input <- pop + return (ExitSuccess, input, "") + getEnvironment = fmap (map read) popList + getCurrentYear = fmap read pop + listFilesInside pred' !_ = do + input <- map splitDirectories <$> popList + map joinPath <$> filterM (fmap and . traverse pred') input + listFilesRecursive !_ = popList + + putStr !_ = return () + putStrLn !_ = return () + createDirectory !d = checkInvalidPath d () + removeDirectory !d = checkInvalidPath d () + writeFile !f !_ = checkInvalidPath f () + removeExistingFile !f = checkInvalidPath f () + copyFile !f !_ = checkInvalidPath f () + renameDirectory !d !_ = checkInvalidPath d () + hFlush _ = return () + message !_ !severity !msg = case severity of + Error -> PurePrompt $ \_ -> + Left $ + BreakException + (show severity ++ ": " ++ msg) + _ -> return () + + break = return True + throwPrompt (BreakException e) = PurePrompt $ \s -> + Left $ + BreakException + ("Error: " ++ e ++ "\nStacktrace: " ++ show s) pop :: PurePrompt String -pop = PurePrompt $ \ (p:|ps) -> Right (p,fromList ps) +pop = PurePrompt $ \(p :| ps) -> Right (p, fromList ps) popAbsolute :: PurePrompt String popAbsolute = do - input <- pop - return $ "/home/test/" ++ input + input <- pop + return $ "/home/test/" ++ input popBool :: PurePrompt Bool -popBool = pop >>= \case +popBool = + pop >>= \case "True" -> pure True "False" -> pure False s -> throwPrompt $ BreakException $ "popBool: " ++ s popList :: PurePrompt [String] -popList = pop >>= \a -> case P.safeRead a of +popList = + pop >>= \a -> case P.safeRead a of Nothing -> throwPrompt $ BreakException ("popList: " ++ show a) Just as -> return as checkInvalidPath :: String -> a -> PurePrompt a checkInvalidPath path act = - -- The check below is done this way so it's easier to append - -- more invalid paths in the future, if necessary - if path `elem` ["."] then - throwPrompt $ BreakException $ "Invalid path: " ++ path - else - return act + -- The check below is done this way so it's easier to append + -- more invalid paths in the future, if necessary + if path `elem` ["."] + then throwPrompt $ BreakException $ "Invalid path: " ++ path + else return act -- | A pure exception thrown exclusively by the pure prompter -- to cancel infinite loops in the prompting process. -- -- For example, in order to break on parse errors, or user-driven -- continuations that do not make sense to test. --- newtype BreakException = BreakException String deriving (Eq, Show) instance Exception BreakException -- | Used to inform the intent of prompted messages. --- data Severity = Log | Info | Warning | Error deriving (Eq, Show) -- | Convenience alias for the literate haskell flag --- type IsLiterate = Bool -- | Convenience alias for generating simple projects --- type IsSimple = Bool -- | Defines whether or not a prompt will have a default value, @@ -466,7 +477,7 @@ data DefaultPrompt t -- | Annotations for cabal file PrettyField. data FieldAnnotation = FieldAnnotation { annCommentedOut :: Bool - -- ^ True iif the field and its contents should be commented out. + -- ^ True iif the field and its contents should be commented out. , annCommentLines :: CommentPosition - -- ^ Comment lines to place before the field or section. + -- ^ Comment lines to place before the field or section. } diff --git a/cabal-install/src/Distribution/Client/Init/Utils.hs b/cabal-install/src/Distribution/Client/Init/Utils.hs index 91d887e4e46..e8cde1184ae 100644 --- a/cabal-install/src/Distribution/Client/Init/Utils.hs +++ b/cabal-install/src/Distribution/Client/Init/Utils.hs @@ -1,65 +1,64 @@ {-# LANGUAGE RecordWildCards #-} module Distribution.Client.Init.Utils -( SourceFileEntry(..) -, retrieveSourceFiles -, retrieveModuleName -, retrieveModuleImports -, retrieveModuleExtensions -, retrieveBuildTools -, retrieveDependencies -, isMain -, isHaskell -, isSourceFile -, trim -, currentDirPkgName -, filePathToPkgName -, mkPackageNameDep -, fixupDocFiles -, mkStringyDep -, getBaseDep -, addLibDepToExe -, addLibDepToTest -) where - - -import qualified Prelude () -import Distribution.Client.Compat.Prelude hiding (putStrLn, empty, readFile, Parsec, many) + ( SourceFileEntry (..) + , retrieveSourceFiles + , retrieveModuleName + , retrieveModuleImports + , retrieveModuleExtensions + , retrieveBuildTools + , retrieveDependencies + , isMain + , isHaskell + , isSourceFile + , trim + , currentDirPkgName + , filePathToPkgName + , mkPackageNameDep + , fixupDocFiles + , mkStringyDep + , getBaseDep + , addLibDepToExe + , addLibDepToTest + ) where + +import Distribution.Client.Compat.Prelude hiding (Parsec, empty, many, putStrLn, readFile) import Distribution.Utils.Generic (isInfixOf, safeLast) +import qualified Prelude () import Control.Monad (forM) import qualified Data.List.NonEmpty as NE import qualified Data.Map as M -import Language.Haskell.Extension (Extension(..)) +import Language.Haskell.Extension (Extension (..)) import System.FilePath -import Distribution.CabalSpecVersion (CabalSpecVersion(..)) -import Distribution.ModuleName (ModuleName) -import Distribution.InstalledPackageInfo (InstalledPackageInfo, exposed) -import qualified Distribution.Package as P -import Distribution.Simple.PackageIndex (InstalledPackageIndex, moduleNameIndex) -import Distribution.Simple.Setup (Flag(..)) -import Distribution.Utils.String (trim) -import Distribution.Version +import Distribution.CabalSpecVersion (CabalSpecVersion (..)) import Distribution.Client.Init.Defaults import Distribution.Client.Init.Types import Distribution.Client.Utils (pvpize) -import Distribution.Types.PackageName -import Distribution.Types.Dependency (Dependency, mkDependency) import qualified Distribution.Compat.NonEmptySet as NES +import Distribution.InstalledPackageInfo (InstalledPackageInfo, exposed) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.Package as P +import Distribution.Simple.PackageIndex (InstalledPackageIndex, moduleNameIndex) +import Distribution.Simple.Setup (Flag (..)) +import Distribution.Types.Dependency (Dependency, mkDependency) import Distribution.Types.LibraryName +import Distribution.Types.PackageName +import Distribution.Utils.String (trim) import Distribution.Verbosity (silent) +import Distribution.Version - --- |Data type of source files found in the working directory +-- | Data type of source files found in the working directory data SourceFileEntry = SourceFileEntry - { relativeSourcePath :: FilePath - , moduleName :: ModuleName - , fileExtension :: String - , imports :: [ModuleName] - , extensions :: [Extension] - } deriving Show + { relativeSourcePath :: FilePath + , moduleName :: ModuleName + , fileExtension :: String + , imports :: [ModuleName] + , extensions :: [Extension] + } + deriving (Show) -- Unfortunately we cannot use the version exported by Distribution.Simple.Program knownSuffixHandlers :: CabalSpecVersion -> String -> String @@ -83,11 +82,12 @@ knownSuffixHandlers v s ".cpphs" -> "cpp:cpp" _ -> "" - -- | Check if a given file has main file characteristics isMain :: String -> Bool -isMain f = (isInfixOf "Main" f || isInfixOf "main" f) - && isSuffixOf ".hs" f || isSuffixOf ".lhs" f +isMain f = + (isInfixOf "Main" f || isInfixOf "main" f) + && isSuffixOf ".hs" f + || isSuffixOf ".lhs" f -- | Check if a given file has a Haskell extension isHaskell :: String -> Bool @@ -105,13 +105,12 @@ retrieveBuildTools v fp = do let tools = [ mkStringyDep (knownSuffixHandlers v f) - | f <- files, isBuildTool v f + | f <- files + , isBuildTool v f ] return tools - - else - return [] + else return [] retrieveSourceFiles :: Interactive m => FilePath -> m [SourceFileEntry] retrieveSourceFiles fp = do @@ -128,76 +127,69 @@ retrieveSourceFiles fp = do case maybeModuleName of Nothing -> return Nothing Just moduleName -> do - - let fileExtension = takeExtension f + let fileExtension = takeExtension f relativeSourcePath <- makeRelative f <$> getCurrentDirectory - imports <- retrieveModuleImports f - extensions <- retrieveModuleExtensions f + imports <- retrieveModuleImports f + extensions <- retrieveModuleExtensions f - return . Just $ SourceFileEntry {..} - else - return Nothing + return . Just $ SourceFileEntry{..} + else return Nothing return . catMaybes $ entries - - else - return [] + else return [] -- | Given a module, retrieve its name retrieveModuleName :: Interactive m => FilePath -> m (Maybe ModuleName) retrieveModuleName m = do - rawModule <- trim . grabModuleName <$> readFile m - - if isInfixOf rawModule (dirToModuleName m) - then - return $ Just $ fromString rawModule - else do - putStrLn - $ "Warning: found module that doesn't match directory structure: " + rawModule <- trim . grabModuleName <$> readFile m + + if isInfixOf rawModule (dirToModuleName m) + then return $ Just $ fromString rawModule + else do + putStrLn $ + "Warning: found module that doesn't match directory structure: " ++ rawModule - return Nothing + return Nothing where dirToModuleName = map (\x -> if x == '/' || x == '\\' then '.' else x) stop c = (c /= '\n') && (c /= ' ') grabModuleName [] = [] - grabModuleName ('-':'-':xs) = grabModuleName $ dropWhile' (/= '\n') xs - grabModuleName ('m':'o':'d':'u':'l':'e':' ':xs) = takeWhile' stop xs - grabModuleName (_:xs) = grabModuleName xs + grabModuleName ('-' : '-' : xs) = grabModuleName $ dropWhile' (/= '\n') xs + grabModuleName ('m' : 'o' : 'd' : 'u' : 'l' : 'e' : ' ' : xs) = takeWhile' stop xs + grabModuleName (_ : xs) = grabModuleName xs -- | Given a module, retrieve all of its imports retrieveModuleImports :: Interactive m => FilePath -> m [ModuleName] retrieveModuleImports m = do map (fromString . trim) . grabModuleImports <$> readFile m - where stop c = (c /= '\n') && (c /= ' ') && (c /= '(') grabModuleImports [] = [] - grabModuleImports ('-':'-':xs) = grabModuleImports $ dropWhile' (/= '\n') xs - grabModuleImports ('i':'m':'p':'o':'r':'t':' ':xs) = case trim xs of -- in case someone uses a weird formatting - ('q':'u':'a':'l':'i':'f':'i':'e':'d':' ':ys) -> takeWhile' stop ys : grabModuleImports (dropWhile' stop ys) - _ -> takeWhile' stop xs : grabModuleImports (dropWhile' stop xs) - grabModuleImports (_:xs) = grabModuleImports xs + grabModuleImports ('-' : '-' : xs) = grabModuleImports $ dropWhile' (/= '\n') xs + grabModuleImports ('i' : 'm' : 'p' : 'o' : 'r' : 't' : ' ' : xs) = case trim xs of -- in case someone uses a weird formatting + ('q' : 'u' : 'a' : 'l' : 'i' : 'f' : 'i' : 'e' : 'd' : ' ' : ys) -> takeWhile' stop ys : grabModuleImports (dropWhile' stop ys) + _ -> takeWhile' stop xs : grabModuleImports (dropWhile' stop xs) + grabModuleImports (_ : xs) = grabModuleImports xs -- | Given a module, retrieve all of its language pragmas retrieveModuleExtensions :: Interactive m => FilePath -> m [Extension] retrieveModuleExtensions m = do catMaybes <$> map (simpleParsec . trim) . grabModuleExtensions <$> readFile m - where stop c = (c /= '\n') && (c /= ' ') && (c /= ',') && (c /= '#') grabModuleExtensions [] = [] - grabModuleExtensions ('-':'-':xs) = grabModuleExtensions $ dropWhile' (/= '\n') xs - grabModuleExtensions ('L':'A':'N':'G':'U':'A':'G':'E':xs) = takeWhile' stop xs : grabModuleExtensions' (dropWhile' stop xs) - grabModuleExtensions (_:xs) = grabModuleExtensions xs + grabModuleExtensions ('-' : '-' : xs) = grabModuleExtensions $ dropWhile' (/= '\n') xs + grabModuleExtensions ('L' : 'A' : 'N' : 'G' : 'U' : 'A' : 'G' : 'E' : xs) = takeWhile' stop xs : grabModuleExtensions' (dropWhile' stop xs) + grabModuleExtensions (_ : xs) = grabModuleExtensions xs grabModuleExtensions' [] = [] - grabModuleExtensions' ('#':xs) = grabModuleExtensions xs - grabModuleExtensions' (',':xs) = takeWhile' stop xs : grabModuleExtensions' (dropWhile' stop xs) - grabModuleExtensions' (_:xs) = grabModuleExtensions xs + grabModuleExtensions' ('#' : xs) = grabModuleExtensions xs + grabModuleExtensions' (',' : xs) = takeWhile' stop xs : grabModuleExtensions' (dropWhile' stop xs) + grabModuleExtensions' (_ : xs) = grabModuleExtensions xs takeWhile' :: (Char -> Bool) -> String -> String takeWhile' p = takeWhile p . trim @@ -208,7 +200,7 @@ dropWhile' p = dropWhile p . trim -- | Check whether a potential source file is located in one of the -- source directories. isSourceFile :: Maybe [FilePath] -> SourceFileEntry -> Bool -isSourceFile Nothing sf = isSourceFile (Just ["."]) sf +isSourceFile Nothing sf = isSourceFile (Just ["."]) sf isSourceFile (Just srcDirs) sf = any (equalFilePath (relativeSourcePath sf)) srcDirs retrieveDependencies :: Interactive m => Verbosity -> InitFlags -> [(ModuleName, ModuleName)] -> InstalledPackageIndex -> m [P.Dependency] @@ -216,11 +208,11 @@ retrieveDependencies v flags mods' pkgIx = do let mods = mods' modMap :: M.Map ModuleName [InstalledPackageInfo] - modMap = M.map (filter exposed) $ moduleNameIndex pkgIx + modMap = M.map (filter exposed) $ moduleNameIndex pkgIx modDeps :: [(ModuleName, ModuleName, Maybe [InstalledPackageInfo])] modDeps = map (\(mn, ds) -> (mn, ds, M.lookup ds modMap)) mods - -- modDeps = map (id &&& flip M.lookup modMap) mods + -- modDeps = map (id &&& flip M.lookup modMap) mods message v Log "Guessing dependencies..." nub . catMaybes <$> traverse (chooseDep v flags) modDeps @@ -236,49 +228,49 @@ chooseDep -> m (Maybe P.Dependency) chooseDep v flags (importer, m, mipi) = case mipi of -- We found some packages: group them by name. - Just ps@(_:_) -> + Just ps@(_ : _) -> case NE.groupBy (\x y -> P.pkgName x == P.pkgName y) $ map P.packageId ps of - -- if there's only one group, i.e. multiple versions of a single package, - -- we make it into a dependency, choosing the latest-ish version. + -- if there's only one group, i.e. multiple versions of a single package, + -- we make it into a dependency, choosing the latest-ish version. -- Given a list of available versions of the same package, pick a dependency. [grp] -> fmap Just $ case grp of - -- If only one version, easy. We change e.g. 0.4.2 into 0.4.* - (pid:|[]) -> - return $ P.Dependency + (pid :| []) -> + return $ + P.Dependency (P.pkgName pid) (pvpize desugar . P.pkgVersion $ pid) - P.mainLibSet --TODO sublibraries + P.mainLibSet -- TODO sublibraries -- Otherwise, choose the latest version and issue a warning. pids -> do message v Warning ("multiple versions of " ++ prettyShow (P.pkgName . NE.head $ pids) ++ " provide " ++ prettyShow m ++ ", choosing the latest.") - return $ P.Dependency + return $ + P.Dependency (P.pkgName . NE.head $ pids) (pvpize desugar . maximum . fmap P.pkgVersion $ pids) - P.mainLibSet --TODO take into account sublibraries + P.mainLibSet -- TODO take into account sublibraries -- if multiple packages are found, we refuse to choose between -- different packages and make the user do it - grps -> do + grps -> do message v Warning ("multiple packages found providing " ++ prettyShow m ++ ": " ++ intercalate ", " (fmap (prettyShow . P.pkgName . NE.head) grps)) message v Warning "You will need to pick one and manually add it to the build-depends field." return Nothing - _ -> do message v Warning ("no package found providing " ++ prettyShow m ++ " in " ++ prettyShow importer ++ ".") return Nothing - where -- desugar if cabal version lower than 2.0 desugar = case cabalVersion flags of - Flag x -> x < CabalSpecV2_0 + Flag x -> x < CabalSpecV2_0 NoFlag -> defaultCabalVersion < CabalSpecV2_0 filePathToPkgName :: Interactive m => FilePath -> m P.PackageName -filePathToPkgName = fmap (mkPackageName . repair . fromMaybe "" . safeLast . splitDirectories) - . canonicalizePathNoThrow +filePathToPkgName = + fmap (mkPackageName . repair . fromMaybe "" . safeLast . splitDirectories) + . canonicalizePathNoThrow where -- Treat each span of non-alphanumeric characters as a hyphen. Each -- hyphenated component of a package name must contain at least one @@ -288,12 +280,14 @@ filePathToPkgName = fmap (mkPackageName . repair . fromMaybe "" . safeLast . spl -- "x12-foo3". repair = repair' ('x' :) id repair' invalid valid x = case dropWhile (not . isAlphaNum) x of - "" -> repairComponent "" - x' -> let (c, r) = first repairComponent $ span isAlphaNum x' - in c ++ repairRest r + "" -> repairComponent "" + x' -> + let (c, r) = first repairComponent $ span isAlphaNum x' + in c ++ repairRest r where - repairComponent c | all isDigit c = invalid c - | otherwise = valid c + repairComponent c + | all isDigit c = invalid c + | otherwise = valid c repairRest = repair' id ('-' :) currentDirPkgName :: Interactive m => m P.PackageName @@ -309,37 +303,46 @@ mkPackageNameDep pkg = mkDependency pkg anyVersion (NES.singleton LMainLibName) fixupDocFiles :: Interactive m => Verbosity -> PkgDescription -> m PkgDescription fixupDocFiles v pkgDesc | _pkgCabalVersion pkgDesc < CabalSpecV1_18 = do - message v Warning $ concat - [ "Cabal spec versions < 1.18 do not support extra-doc-files. " - , "Doc files will be treated as extra-src-files." - ] - - return $ pkgDesc - { _pkgExtraSrcFiles =_pkgExtraSrcFiles pkgDesc - <> fromMaybe mempty (_pkgExtraDocFiles pkgDesc) - , _pkgExtraDocFiles = Nothing - } + message v Warning $ + concat + [ "Cabal spec versions < 1.18 do not support extra-doc-files. " + , "Doc files will be treated as extra-src-files." + ] + + return $ + pkgDesc + { _pkgExtraSrcFiles = + _pkgExtraSrcFiles pkgDesc + <> fromMaybe mempty (_pkgExtraDocFiles pkgDesc) + , _pkgExtraDocFiles = Nothing + } | otherwise = return pkgDesc mkStringyDep :: String -> Dependency mkStringyDep = mkPackageNameDep . mkPackageName - getBaseDep :: Interactive m => InstalledPackageIndex -> InitFlags -> m [Dependency] -getBaseDep pkgIx flags = retrieveDependencies silent flags - [(fromString "Prelude", fromString "Prelude")] pkgIx +getBaseDep pkgIx flags = + retrieveDependencies + silent + flags + [(fromString "Prelude", fromString "Prelude")] + pkgIx -- Add package name as dependency of test suite -- addLibDepToTest :: PackageName -> Maybe TestTarget -> Maybe TestTarget addLibDepToTest _ Nothing = Nothing -addLibDepToTest n (Just t) = Just $ t - { _testDependencies = _testDependencies t ++ [mkPackageNameDep n] - } +addLibDepToTest n (Just t) = + Just $ + t + { _testDependencies = _testDependencies t ++ [mkPackageNameDep n] + } -- Add package name as dependency of executable -- addLibDepToExe :: PackageName -> ExeTarget -> ExeTarget -addLibDepToExe n exe = exe - { _exeDependencies = _exeDependencies exe ++ [mkPackageNameDep n] - } +addLibDepToExe n exe = + exe + { _exeDependencies = _exeDependencies exe ++ [mkPackageNameDep n] + } diff --git a/cabal-install/src/Distribution/Client/Install.hs b/cabal-install/src/Distribution/Client/Install.hs index b0cf35873e9..93ad8e5ae2e 100644 --- a/cabal-install/src/Distribution/Client/Install.hs +++ b/cabal-install/src/Distribution/Client/Install.hs @@ -1,6 +1,9 @@ {-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.Install -- Copyright : (c) 2005 David Himmelstrup @@ -13,166 +16,281 @@ -- Portability : portable -- -- High level interface to package installation. ------------------------------------------------------------------------------ -module Distribution.Client.Install ( - -- * High-level interface - install, +module Distribution.Client.Install + ( -- * High-level interface + install -- * Lower-level interface that allows to manipulate the install plan - makeInstallContext, - makeInstallPlan, - processInstallPlan, - InstallArgs, - InstallContext, + , makeInstallContext + , makeInstallPlan + , processInstallPlan + , InstallArgs + , InstallContext -- * Prune certain packages from the install plan - pruneInstallPlan + , pruneInstallPlan ) where -import Prelude () import Distribution.Client.Compat.Prelude -import Distribution.Utils.Generic(safeLast) +import Distribution.Utils.Generic (safeLast) +import Prelude () +import Control.Exception as Exception + ( Handler (Handler) + , bracket + , catches + , handleJust + ) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map -import Control.Exception as Exception - ( bracket, catches, Handler(Handler), handleJust ) import System.Directory - ( getTemporaryDirectory, doesDirectoryExist, doesFileExist, - createDirectoryIfMissing, removeFile, renameDirectory, - getDirectoryContents ) + ( createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , getDirectoryContents + , getTemporaryDirectory + , removeFile + , renameDirectory + ) import System.FilePath - ( (), (<.>), equalFilePath, takeDirectory ) + ( equalFilePath + , takeDirectory + , (<.>) + , () + ) import System.IO - ( openFile, IOMode(AppendMode), hClose ) + ( IOMode (AppendMode) + , hClose + , openFile + ) import System.IO.Error - ( isDoesNotExistError, ioeGetFileName ) + ( ioeGetFileName + , isDoesNotExistError + ) -import Distribution.Client.Targets +import Distribution.Client.BuildReports.Anonymous (showBuildReport) +import qualified Distribution.Client.BuildReports.Anonymous as BuildReports +import qualified Distribution.Client.BuildReports.Storage as BuildReports + ( fromInstallPlan + , fromPlanningFailure + , storeAnonymous + , storeLocal + ) +import Distribution.Client.BuildReports.Types + ( ReportLevel (..) + ) +import Distribution.Client.Config + ( defaultReportsDir + , defaultUserInstall + ) import Distribution.Client.Configure - ( chooseCabalVersion, configureSetupScript, checkConfigExFlags ) + ( checkConfigExFlags + , chooseCabalVersion + , configureSetupScript + ) import Distribution.Client.Dependency import Distribution.Client.Dependency.Types - ( Solver(..) ) + ( Solver (..) + ) import Distribution.Client.FetchUtils -import Distribution.Client.HttpUtils - ( HttpTransport (..) ) -import Distribution.Solver.Types.PackageFixedDeps import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex) +import Distribution.Client.HttpUtils + ( HttpTransport (..) + ) import Distribution.Client.IndexUtils as IndexUtils - ( getSourcePackagesAtIndexState, getInstalledPackages ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan + ( getInstalledPackages + , getSourcePackagesAtIndexState + ) import Distribution.Client.InstallPlan (InstallPlan) -import Distribution.Client.SolverInstallPlan (SolverInstallPlan) +import qualified Distribution.Client.InstallPlan as InstallPlan +import qualified Distribution.Client.InstallSymlink as InstallSymlink + ( symlinkBinaries + ) +import Distribution.Client.JobControl import Distribution.Client.Setup - ( GlobalFlags(..), RepoContext(..) - , ConfigFlags(..), configureCommand, filterConfigureFlags - , ConfigExFlags(..), InstallFlags(..) - , filterTestFlags ) -import Distribution.Client.Config - ( defaultReportsDir, defaultUserInstall ) + ( ConfigExFlags (..) + , ConfigFlags (..) + , GlobalFlags (..) + , InstallFlags (..) + , RepoContext (..) + , configureCommand + , filterConfigureFlags + , filterTestFlags + ) +import Distribution.Client.SetupWrapper + ( SetupScriptOptions (..) + , defaultSetupScriptOptions + , setupWrapper + ) +import Distribution.Client.SolverInstallPlan (SolverInstallPlan) +import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.Tar (extractTarGzFile) +import Distribution.Client.Targets import Distribution.Client.Types as Source -import Distribution.Client.BuildReports.Types - ( ReportLevel(..) ) -import Distribution.Client.SetupWrapper - ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) -import Distribution.Client.BuildReports.Anonymous (showBuildReport) -import qualified Distribution.Client.BuildReports.Anonymous as BuildReports -import qualified Distribution.Client.BuildReports.Storage as BuildReports - ( storeAnonymous, storeLocal, fromInstallPlan, fromPlanningFailure ) -import qualified Distribution.Client.InstallSymlink as InstallSymlink - ( symlinkBinaries ) import Distribution.Client.Types.OverwritePolicy (OverwritePolicy (..)) import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import qualified Distribution.InstalledPackageInfo as Installed -import Distribution.Client.JobControl +import Distribution.Solver.Types.PackageFixedDeps import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza import qualified Distribution.Solver.Types.PackageIndex as SourcePackageIndex -import Distribution.Solver.Types.PkgConfigDb - ( PkgConfigDb, readPkgConfigDb ) -import Distribution.Solver.Types.SourcePackage as SourcePackage +import Distribution.Solver.Types.PkgConfigDb + ( PkgConfigDb + , readPkgConfigDb + ) +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.SourcePackage as SourcePackage -import Distribution.Utils.NubList +import Distribution.Client.Utils + ( MergeResult (..) + , ProgressPhase (..) + , determineNumJobs + , logDirChange + , mergeBy + , progressMessage + ) +import Distribution.Package + ( HasMungedPackageId (..) + , HasUnitId (..) + , Package (..) + , PackageId + , PackageIdentifier (..) + , UnitId + , packageName + , packageVersion + ) +import Distribution.PackageDescription + ( GenericPackageDescription (..) + , PackageDescription + ) +import qualified Distribution.PackageDescription as PackageDescription +import Distribution.PackageDescription.Configuration + ( finalizePD + ) +import Distribution.Simple.BuildPaths (exeExtension) import Distribution.Simple.Compiler - ( CompilerId(..), Compiler(compilerId), compilerFlavor - , CompilerInfo(..), compilerInfo, PackageDB(..), PackageDBStack ) -import Distribution.Simple.Program (ProgramDb) + ( Compiler (compilerId) + , CompilerId (..) + , CompilerInfo (..) + , PackageDB (..) + , PackageDBStack + , compilerFlavor + , compilerInfo + ) +import Distribution.Simple.Configure (interpretPackageDbFlags) +import Distribution.Simple.InstallDirs as InstallDirs + ( PathTemplate + , fromPathTemplate + , initialPathTemplateEnv + , installDirsTemplateEnv + , substPathTemplate + , toPathTemplate + ) import qualified Distribution.Simple.InstallDirs as InstallDirs -import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.Program (ProgramDb) +import Distribution.Simple.Register (defaultRegisterOptions, registerPackage) import Distribution.Simple.Setup - ( haddockCommand, HaddockFlags(..) - , buildCommand, BuildFlags(..), emptyBuildFlags - , TestFlags, BenchmarkFlags - , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref ) + ( BenchmarkFlags + , BuildFlags (..) + , HaddockFlags (..) + , TestFlags + , buildCommand + , defaultDistPref + , emptyBuildFlags + , flagToMaybe + , fromFlag + , fromFlagOrDefault + , haddockCommand + , toFlag + ) import qualified Distribution.Simple.Setup as Cabal - ( Flag(..) - , copyCommand, CopyFlags(..), emptyCopyFlags - , registerCommand, RegisterFlags(..), emptyRegisterFlags - , testCommand, TestFlags(..) ) + ( CopyFlags (..) + , Flag (..) + , RegisterFlags (..) + , TestFlags (..) + , copyCommand + , emptyCopyFlags + , emptyRegisterFlags + , registerCommand + , testCommand + ) import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, writeFileAtomic ) -import Distribution.Simple.InstallDirs as InstallDirs - ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate - , initialPathTemplateEnv, installDirsTemplateEnv ) -import Distribution.Simple.Configure (interpretPackageDbFlags) -import Distribution.Simple.Register (registerPackage, defaultRegisterOptions) -import Distribution.Package - ( PackageIdentifier(..), PackageId, packageName, packageVersion - , Package(..), HasMungedPackageId(..), HasUnitId(..) - , UnitId ) -import Distribution.Types.GivenComponent - ( GivenComponent(..) ) -import Distribution.Types.PackageVersionConstraint - ( PackageVersionConstraint(..), thisPackageVersionConstraint ) -import Distribution.Types.MungedPackageId -import qualified Distribution.PackageDescription as PackageDescription -import Distribution.PackageDescription - ( PackageDescription, GenericPackageDescription(..) ) -import Distribution.Types.Flag - ( PackageFlag(..), FlagAssignment, mkFlagAssignment - , showFlagAssignment, diffFlagAssignment, nullFlagAssignment ) -import Distribution.PackageDescription.Configuration - ( finalizePD ) -import Distribution.Version - ( Version, VersionRange, foldVersionRange ) + ( createDirectoryIfMissingVerbose + , writeFileAtomic + ) import Distribution.Simple.Utils as Utils - ( notice, info, warn, debug, debugNoWrap, die' - , withTempDirectory ) -import Distribution.Client.Utils - ( determineNumJobs, logDirChange, mergeBy, MergeResult(..) - , ProgressPhase(..), progressMessage ) + ( debug + , debugNoWrap + , die' + , info + , notice + , warn + , withTempDirectory + ) import Distribution.System - ( Platform, OS(Windows), buildOS, buildPlatform ) + ( OS (Windows) + , Platform + , buildOS + , buildPlatform + ) +import Distribution.Types.Flag + ( FlagAssignment + , PackageFlag (..) + , diffFlagAssignment + , mkFlagAssignment + , nullFlagAssignment + , showFlagAssignment + ) +import Distribution.Types.GivenComponent + ( GivenComponent (..) + ) +import Distribution.Types.MungedPackageId +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint (..) + , thisPackageVersionConstraint + ) +import Distribution.Utils.NubList import Distribution.Verbosity as Verbosity - ( modifyVerbosity, normal, verbose ) -import Distribution.Simple.BuildPaths ( exeExtension ) + ( modifyVerbosity + , normal + , verbose + ) +import Distribution.Version + ( Version + , VersionRange + , foldVersionRange + ) import qualified Data.ByteString as BS ---TODO: +-- TODO: + -- * assign flags to packages individually + -- * complain about flags that do not apply to any package given as target -- so flags do not apply to dependencies, only listed, can use flag -- constraints for dependencies + -- * allow flag constraints + -- * allow installed constraints + -- * allow flag and installed preferences + -- * allow persistent configure flags for each package individually -- ------------------------------------------------------------ + -- * Top level user actions + -- ------------------------------------------------------------ -- | Installs the packages needed to satisfy a list of dependencies. --- install :: Verbosity -> PackageDBStack @@ -189,83 +307,134 @@ install -> BenchmarkFlags -> [UserTarget] -> IO () -install verbosity packageDBs repos comp platform progdb - globalFlags configFlags configExFlags installFlags - haddockFlags testFlags benchmarkFlags userTargets0 = do - +install + verbosity + packageDBs + repos + comp + platform + progdb + globalFlags + configFlags + configExFlags + installFlags + haddockFlags + testFlags + benchmarkFlags + userTargets0 = do unless (installRootCmd installFlags == Cabal.NoFlag) $ - warn verbosity $ "--root-cmd is no longer supported, " - ++ "see https://github.com/haskell/cabal/issues/3353" - ++ " (if you didn't type --root-cmd, comment out root-cmd" - ++ " in your ~/.config/cabal/config file)" + warn verbosity $ + "--root-cmd is no longer supported, " + ++ "see https://github.com/haskell/cabal/issues/3353" + ++ " (if you didn't type --root-cmd, comment out root-cmd" + ++ " in your ~/.config/cabal/config file)" let userOrSandbox = fromFlag (configUserInstall configFlags) unless userOrSandbox $ - warn verbosity $ "the --global flag is deprecated -- " - ++ "it is generally considered a bad idea to install packages " - ++ "into the global store" + warn verbosity $ + "the --global flag is deprecated -- " + ++ "it is generally considered a bad idea to install packages " + ++ "into the global store" installContext <- makeInstallContext verbosity args (Just userTargets0) - planResult <- foldProgress logMsg (return . Left) (return . Right) =<< - makeInstallPlan verbosity args installContext + planResult <- + foldProgress logMsg (return . Left) (return . Right) + =<< makeInstallPlan verbosity args installContext case planResult of - Left message -> do - reportPlanningFailure verbosity args installContext message - die'' message - Right installPlan -> - processInstallPlan verbosity args installContext installPlan - where - args :: InstallArgs - args = (packageDBs, repos, comp, platform, progdb, - globalFlags, configFlags, configExFlags, - installFlags, haddockFlags, testFlags, benchmarkFlags) - - die'' = die' verbosity - - logMsg message rest = debugNoWrap verbosity message >> rest + Left message -> do + reportPlanningFailure verbosity args installContext message + die'' message + Right installPlan -> + processInstallPlan verbosity args installContext installPlan + where + args :: InstallArgs + args = + ( packageDBs + , repos + , comp + , platform + , progdb + , globalFlags + , configFlags + , configExFlags + , installFlags + , haddockFlags + , testFlags + , benchmarkFlags + ) + + die'' = die' verbosity + + logMsg message rest = debugNoWrap verbosity message >> rest -- TODO: Make InstallContext a proper data type with documented fields. + -- | Common context for makeInstallPlan and processInstallPlan. -type InstallContext = ( InstalledPackageIndex, SourcePackageDb - , PkgConfigDb - , [UserTarget], [PackageSpecifier UnresolvedSourcePackage] - , HttpTransport ) +type InstallContext = + ( InstalledPackageIndex + , SourcePackageDb + , PkgConfigDb + , [UserTarget] + , [PackageSpecifier UnresolvedSourcePackage] + , HttpTransport + ) -- TODO: Make InstallArgs a proper data type with documented fields or just get -- rid of it completely. + -- | Initial arguments given to 'install' or 'makeInstallContext'. -type InstallArgs = ( PackageDBStack - , RepoContext - , Compiler - , Platform - , ProgramDb - , GlobalFlags - , ConfigFlags - , ConfigExFlags - , InstallFlags - , HaddockFlags - , TestFlags - , BenchmarkFlags ) +type InstallArgs = + ( PackageDBStack + , RepoContext + , Compiler + , Platform + , ProgramDb + , GlobalFlags + , ConfigFlags + , ConfigExFlags + , InstallFlags + , HaddockFlags + , TestFlags + , BenchmarkFlags + ) -- | Make an install context given install arguments. -makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget] - -> IO InstallContext -makeInstallContext verbosity - (packageDBs, repoCtxt, comp, _, progdb, - _, _, configExFlags, installFlags, _, _, _) mUserTargets = do - +makeInstallContext + :: Verbosity + -> InstallArgs + -> Maybe [UserTarget] + -> IO InstallContext +makeInstallContext + verbosity + ( packageDBs + , repoCtxt + , comp + , _ + , progdb + , _ + , _ + , configExFlags + , installFlags + , _ + , _ + , _ + ) + mUserTargets = do let idxState = flagToMaybe (installIndexState installFlags) - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb (sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState Nothing - pkgConfigDb <- readPkgConfigDb verbosity progdb + pkgConfigDb <- readPkgConfigDb verbosity progdb - checkConfigExFlags verbosity installedPkgIndex - (packageIndex sourcePkgDb) configExFlags + checkConfigExFlags + verbosity + installedPkgIndex + (packageIndex sourcePkgDb) + configExFlags transport <- repoContextGetTransport repoCtxt (userTargets, pkgSpecifiers) <- case mUserTargets of - Nothing -> + Nothing -> -- We want to distinguish between the case where the user has given an -- empty list of targets on the command-line and the case where we -- specifically want to have an empty list of targets. @@ -273,514 +442,672 @@ makeInstallContext verbosity Just userTargets0 -> do -- For install, if no target is given it means we use the current -- directory as the single target. - let userTargets | null userTargets0 = [UserTargetLocalDir "."] - | otherwise = userTargets0 - - pkgSpecifiers <- resolveUserTargets verbosity repoCtxt - (packageIndex sourcePkgDb) - userTargets + let userTargets + | null userTargets0 = [UserTargetLocalDir "."] + | otherwise = userTargets0 + + pkgSpecifiers <- + resolveUserTargets + verbosity + repoCtxt + (packageIndex sourcePkgDb) + userTargets return (userTargets, pkgSpecifiers) - return (installedPkgIndex, sourcePkgDb, pkgConfigDb, userTargets - ,pkgSpecifiers, transport) + return + ( installedPkgIndex + , sourcePkgDb + , pkgConfigDb + , userTargets + , pkgSpecifiers + , transport + ) -- | Make an install plan given install context and install arguments. -makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext - -> IO (Progress String String SolverInstallPlan) -makeInstallPlan verbosity - (_, _, comp, platform,_, - _, configFlags, configExFlags, installFlags, - _, _, _) - (installedPkgIndex, sourcePkgDb, pkgConfigDb, - _, pkgSpecifiers, _) = do - - solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags)) - (compilerInfo comp) +makeInstallPlan + :: Verbosity + -> InstallArgs + -> InstallContext + -> IO (Progress String String SolverInstallPlan) +makeInstallPlan + verbosity + ( _ + , _ + , comp + , platform + , _ + , _ + , configFlags + , configExFlags + , installFlags + , _ + , _ + , _ + ) + ( installedPkgIndex + , sourcePkgDb + , pkgConfigDb + , _ + , pkgSpecifiers + , _ + ) = do + solver <- + chooseSolver + verbosity + (fromFlag (configSolver configExFlags)) + (compilerInfo comp) notice verbosity "Resolving dependencies..." - return $ planPackages verbosity comp platform solver - configFlags configExFlags installFlags - installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers + return $ + planPackages + verbosity + comp + platform + solver + configFlags + configExFlags + installFlags + installedPkgIndex + sourcePkgDb + pkgConfigDb + pkgSpecifiers -- | Given an install plan, perform the actual installations. -processInstallPlan :: Verbosity -> InstallArgs -> InstallContext - -> SolverInstallPlan - -> IO () -processInstallPlan verbosity - args@(_,_, _, _, _, _, configFlags, _, installFlags, _, _, _) - (installedPkgIndex, sourcePkgDb, _, - userTargets, pkgSpecifiers, _) installPlan0 = do - - checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb - installFlags pkgSpecifiers +processInstallPlan + :: Verbosity + -> InstallArgs + -> InstallContext + -> SolverInstallPlan + -> IO () +processInstallPlan + verbosity + args@(_, _, _, _, _, _, configFlags, _, installFlags, _, _, _) + ( installedPkgIndex + , sourcePkgDb + , _ + , userTargets + , pkgSpecifiers + , _ + ) + installPlan0 = do + checkPrintPlan + verbosity + installedPkgIndex + installPlan + sourcePkgDb + installFlags + pkgSpecifiers unless (dryRun || nothingToInstall) $ do - buildOutcomes <- performInstallations verbosity - args installedPkgIndex installPlan + buildOutcomes <- + performInstallations + verbosity + args + installedPkgIndex + installPlan postInstallActions verbosity args userTargets installPlan buildOutcomes - where - installPlan = InstallPlan.configureInstallPlan configFlags installPlan0 - dryRun = fromFlag (installDryRun installFlags) - nothingToInstall = null (fst (InstallPlan.ready installPlan)) + where + installPlan = InstallPlan.configureInstallPlan configFlags installPlan0 + dryRun = fromFlag (installDryRun installFlags) + nothingToInstall = null (fst (InstallPlan.ready installPlan)) -- ------------------------------------------------------------ --- * Installation planning --- ------------------------------------------------------------ - -planPackages :: Verbosity - -> Compiler - -> Platform - -> Solver - -> ConfigFlags - -> ConfigExFlags - -> InstallFlags - -> InstalledPackageIndex - -> SourcePackageDb - -> PkgConfigDb - -> [PackageSpecifier UnresolvedSourcePackage] - -> Progress String String SolverInstallPlan -planPackages verbosity comp platform solver - configFlags configExFlags installFlags - installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = - - resolveDependencies - platform (compilerInfo comp) pkgConfigDb - solver - resolverParams - - >>= if onlyDeps then pruneInstallPlan pkgSpecifiers else return - - where - resolverParams = - - setMaxBackjumps (if maxBackjumps < 0 then Nothing - else Just maxBackjumps) - - . setIndependentGoals independentGoals - - . setReorderGoals reorderGoals - - . setCountConflicts countConflicts - - . setFineGrainedConflicts fineGrainedConflicts - - . setMinimizeConflictSet minimizeConflictSet - - . setAvoidReinstalls avoidReinstalls - . setShadowPkgs shadowPkgs - - . setStrongFlags strongFlags - - . setAllowBootLibInstalls allowBootLibInstalls - - . setOnlyConstrained onlyConstrained - - . setSolverVerbosity verbosity - - . setPreferenceDefault (if upgradeDeps then PreferAllLatest - else PreferLatestForSelected) - - . removeLowerBounds allowOlder - . removeUpperBounds allowNewer +-- * Installation planning - . addPreferences - -- preferences from the config file or command line - [ PackageVersionPreference name ver - | PackageVersionConstraint name ver <- configPreferences configExFlags ] +-- ------------------------------------------------------------ - . addConstraints - -- version constraints from the config file or command line +planPackages + :: Verbosity + -> Compiler + -> Platform + -> Solver + -> ConfigFlags + -> ConfigExFlags + -> InstallFlags + -> InstalledPackageIndex + -> SourcePackageDb + -> PkgConfigDb + -> [PackageSpecifier UnresolvedSourcePackage] + -> Progress String String SolverInstallPlan +planPackages + verbosity + comp + platform + solver + configFlags + configExFlags + installFlags + installedPkgIndex + sourcePkgDb + pkgConfigDb + pkgSpecifiers = + resolveDependencies + platform + (compilerInfo comp) + pkgConfigDb + solver + resolverParams + >>= if onlyDeps then pruneInstallPlan pkgSpecifiers else return + where + resolverParams = + setMaxBackjumps + ( if maxBackjumps < 0 + then Nothing + else Just maxBackjumps + ) + . setIndependentGoals independentGoals + . setReorderGoals reorderGoals + . setCountConflicts countConflicts + . setFineGrainedConflicts fineGrainedConflicts + . setMinimizeConflictSet minimizeConflictSet + . setAvoidReinstalls avoidReinstalls + . setShadowPkgs shadowPkgs + . setStrongFlags strongFlags + . setAllowBootLibInstalls allowBootLibInstalls + . setOnlyConstrained onlyConstrained + . setSolverVerbosity verbosity + . setPreferenceDefault + ( if upgradeDeps + then PreferAllLatest + else PreferLatestForSelected + ) + . removeLowerBounds allowOlder + . removeUpperBounds allowNewer + . addPreferences + -- preferences from the config file or command line + [ PackageVersionPreference name ver + | PackageVersionConstraint name ver <- configPreferences configExFlags + ] + . addConstraints + -- version constraints from the config file or command line [ LabeledPackageConstraint (userToPackageConstraint pc) src - | (pc, src) <- configExConstraints configExFlags ] - - . addConstraints - --FIXME: this just applies all flags to all targets which - -- is silly. We should check if the flags are appropriate - [ let pc = PackageConstraint - (scopeToplevel $ pkgSpecifierTarget pkgSpecifier) - (PackagePropertyFlags flags) - in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget - | let flags = configConfigurationsFlags configFlags - , not (nullFlagAssignment flags) - , pkgSpecifier <- pkgSpecifiers ] - - . addConstraints - [ let pc = PackageConstraint - (scopeToplevel $ pkgSpecifierTarget pkgSpecifier) - (PackagePropertyStanzas stanzas) - in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget - | pkgSpecifier <- pkgSpecifiers ] - - . (if reinstall then reinstallTargets else id) - - -- Don't solve for executables, the legacy install codepath - -- doesn't understand how to install them - . setSolveExecutables (SolveExecutables False) - - $ standardInstallPolicy - installedPkgIndex sourcePkgDb pkgSpecifiers - - stanzas = [ TestStanzas | testsEnabled ] - ++ [ BenchStanzas | benchmarksEnabled ] - testsEnabled = fromFlagOrDefault False $ configTests configFlags - benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags - - reinstall = fromFlag (installOverrideReinstall installFlags) || - fromFlag (installReinstall installFlags) - reorderGoals = fromFlag (installReorderGoals installFlags) - countConflicts = fromFlag (installCountConflicts installFlags) - fineGrainedConflicts = fromFlag (installFineGrainedConflicts installFlags) - minimizeConflictSet = fromFlag (installMinimizeConflictSet installFlags) - independentGoals = fromFlag (installIndependentGoals installFlags) - avoidReinstalls = fromFlag (installAvoidReinstalls installFlags) - shadowPkgs = fromFlag (installShadowPkgs installFlags) - strongFlags = fromFlag (installStrongFlags installFlags) - maxBackjumps = fromFlag (installMaxBackjumps installFlags) - allowBootLibInstalls = fromFlag (installAllowBootLibInstalls installFlags) - onlyConstrained = fromFlag (installOnlyConstrained installFlags) - upgradeDeps = fromFlag (installUpgradeDeps installFlags) - onlyDeps = fromFlag (installOnlyDeps installFlags) - - allowOlder = fromMaybe (AllowOlder mempty) - (configAllowOlder configExFlags) - allowNewer = fromMaybe (AllowNewer mempty) - (configAllowNewer configExFlags) + | (pc, src) <- configExConstraints configExFlags + ] + . addConstraints + -- FIXME: this just applies all flags to all targets which + -- is silly. We should check if the flags are appropriate + [ let pc = + PackageConstraint + (scopeToplevel $ pkgSpecifierTarget pkgSpecifier) + (PackagePropertyFlags flags) + in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget + | let flags = configConfigurationsFlags configFlags + , not (nullFlagAssignment flags) + , pkgSpecifier <- pkgSpecifiers + ] + . addConstraints + [ let pc = + PackageConstraint + (scopeToplevel $ pkgSpecifierTarget pkgSpecifier) + (PackagePropertyStanzas stanzas) + in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget + | pkgSpecifier <- pkgSpecifiers + ] + . (if reinstall then reinstallTargets else id) + -- Don't solve for executables, the legacy install codepath + -- doesn't understand how to install them + . setSolveExecutables (SolveExecutables False) + $ standardInstallPolicy + installedPkgIndex + sourcePkgDb + pkgSpecifiers + + stanzas = + [TestStanzas | testsEnabled] + ++ [BenchStanzas | benchmarksEnabled] + testsEnabled = fromFlagOrDefault False $ configTests configFlags + benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags + + reinstall = + fromFlag (installOverrideReinstall installFlags) + || fromFlag (installReinstall installFlags) + reorderGoals = fromFlag (installReorderGoals installFlags) + countConflicts = fromFlag (installCountConflicts installFlags) + fineGrainedConflicts = fromFlag (installFineGrainedConflicts installFlags) + minimizeConflictSet = fromFlag (installMinimizeConflictSet installFlags) + independentGoals = fromFlag (installIndependentGoals installFlags) + avoidReinstalls = fromFlag (installAvoidReinstalls installFlags) + shadowPkgs = fromFlag (installShadowPkgs installFlags) + strongFlags = fromFlag (installStrongFlags installFlags) + maxBackjumps = fromFlag (installMaxBackjumps installFlags) + allowBootLibInstalls = fromFlag (installAllowBootLibInstalls installFlags) + onlyConstrained = fromFlag (installOnlyConstrained installFlags) + upgradeDeps = fromFlag (installUpgradeDeps installFlags) + onlyDeps = fromFlag (installOnlyDeps installFlags) + + allowOlder = + fromMaybe + (AllowOlder mempty) + (configAllowOlder configExFlags) + allowNewer = + fromMaybe + (AllowNewer mempty) + (configAllowNewer configExFlags) -- | Remove the provided targets from the install plan. -pruneInstallPlan :: Package targetpkg - => [PackageSpecifier targetpkg] - -> SolverInstallPlan - -> Progress String String SolverInstallPlan +pruneInstallPlan + :: Package targetpkg + => [PackageSpecifier targetpkg] + -> SolverInstallPlan + -> Progress String String SolverInstallPlan pruneInstallPlan pkgSpecifiers = -- TODO: this is a general feature and should be moved to D.C.Dependency -- Also, the InstallPlan.remove should return info more precise to the -- problem, rather than the very general PlanProblem type. either (Fail . explain) Done - . SolverInstallPlan.remove (\pkg -> packageName pkg `elem` targetnames) + . SolverInstallPlan.remove (\pkg -> packageName pkg `elem` targetnames) where explain :: [SolverInstallPlan.SolverPlanProblem] -> String explain problems = "Cannot select only the dependencies (as requested by the " - ++ "'--only-dependencies' flag), " - ++ (case pkgids of - [pkgid] -> "the package " ++ prettyShow pkgid ++ " is " - _ -> "the packages " - ++ intercalate ", " (map prettyShow pkgids) ++ " are ") - ++ "required by a dependency of one of the other targets." + ++ "'--only-dependencies' flag), " + ++ ( case pkgids of + [pkgid] -> "the package " ++ prettyShow pkgid ++ " is " + _ -> + "the packages " + ++ intercalate ", " (map prettyShow pkgids) + ++ " are " + ) + ++ "required by a dependency of one of the other targets." where pkgids = - nub [ depid - | SolverInstallPlan.PackageMissingDeps _ depids <- problems - , depid <- depids - , packageName depid `elem` targetnames ] + nub + [ depid + | SolverInstallPlan.PackageMissingDeps _ depids <- problems + , depid <- depids + , packageName depid `elem` targetnames + ] - targetnames = map pkgSpecifierTarget pkgSpecifiers + targetnames = map pkgSpecifierTarget pkgSpecifiers -- ------------------------------------------------------------ + -- * Informational messages + -- ------------------------------------------------------------ -- | Perform post-solver checks of the install plan and print it if -- either requested or needed. -checkPrintPlan :: Verbosity - -> InstalledPackageIndex - -> InstallPlan - -> SourcePackageDb - -> InstallFlags - -> [PackageSpecifier UnresolvedSourcePackage] - -> IO () -checkPrintPlan verbosity installed installPlan sourcePkgDb - installFlags pkgSpecifiers = do - - -- User targets that are already installed. - let preExistingTargets = - [ p | let tgts = map pkgSpecifierTarget pkgSpecifiers, - InstallPlan.PreExisting p <- InstallPlan.toList installPlan, - packageName p `elem` tgts ] - - -- If there's nothing to install, we print the already existing - -- target packages as an explanation. - when nothingToInstall $ - notice verbosity $ unlines $ - "All the requested packages are already installed:" - : map (prettyShow . packageId) preExistingTargets - ++ ["Use --reinstall if you want to reinstall anyway."] - - let lPlan = - [ (pkg, status) - | pkg <- InstallPlan.executionOrder installPlan - , let status = packageStatus installed pkg ] - -- Are any packages classified as reinstalls? - let reinstalledPkgs = - [ ipkg - | (_pkg, status) <- lPlan - , ipkg <- extractReinstalls status ] - -- Packages that are already broken. - let oldBrokenPkgs = +checkPrintPlan + :: Verbosity + -> InstalledPackageIndex + -> InstallPlan + -> SourcePackageDb + -> InstallFlags + -> [PackageSpecifier UnresolvedSourcePackage] + -> IO () +checkPrintPlan + verbosity + installed + installPlan + sourcePkgDb + installFlags + pkgSpecifiers = do + -- User targets that are already installed. + let preExistingTargets = + [ p | let tgts = map pkgSpecifierTarget pkgSpecifiers, InstallPlan.PreExisting p <- InstallPlan.toList installPlan, packageName p `elem` tgts + ] + + -- If there's nothing to install, we print the already existing + -- target packages as an explanation. + when nothingToInstall $ + notice verbosity $ + unlines $ + "All the requested packages are already installed:" + : map (prettyShow . packageId) preExistingTargets + ++ ["Use --reinstall if you want to reinstall anyway."] + + let lPlan = + [ (pkg, status) + | pkg <- InstallPlan.executionOrder installPlan + , let status = packageStatus installed pkg + ] + -- Are any packages classified as reinstalls? + let reinstalledPkgs = + [ ipkg + | (_pkg, status) <- lPlan + , ipkg <- extractReinstalls status + ] + -- Packages that are already broken. + let oldBrokenPkgs = map Installed.installedUnitId - . PackageIndex.reverseDependencyClosure installed - . map (Installed.installedUnitId . fst) - . PackageIndex.brokenPackages - $ installed - let excluded = reinstalledPkgs ++ oldBrokenPkgs - -- Packages that are reverse dependencies of replaced packages are very - -- likely to be broken. We exclude packages that are already broken. - let newBrokenPkgs = - filter (\ p -> not (Installed.installedUnitId p `elem` excluded)) - (PackageIndex.reverseDependencyClosure installed reinstalledPkgs) - let containsReinstalls = not (null reinstalledPkgs) - let breaksPkgs = not (null newBrokenPkgs) - - let adaptedVerbosity - | containsReinstalls - , not overrideReinstall = modifyVerbosity (max verbose) verbosity - | otherwise = verbosity - - -- We print the install plan if we are in a dry-run or if we are confronted - -- with a dangerous install plan. - when (dryRun || containsReinstalls && not overrideReinstall) $ - printPlan (dryRun || breaksPkgs && not overrideReinstall) - adaptedVerbosity lPlan sourcePkgDb - - -- If the install plan is dangerous, we print various warning messages. In - -- particular, if we can see that packages are likely to be broken, we even - -- bail out (unless installation has been forced with --force-reinstalls). - when containsReinstalls $ do - if breaksPkgs - then do - (if dryRun || overrideReinstall then warn else die') verbosity $ unlines $ - "The following packages are likely to be broken by the reinstalls:" - : map (prettyShow . mungedId) newBrokenPkgs - ++ if overrideReinstall - then if dryRun then [] else - ["Continuing even though " ++ - "the plan contains dangerous reinstalls."] - else - ["Use --force-reinstalls if you want to install anyway."] - else unless dryRun $ warn verbosity - "Note that reinstalls are always dangerous. Continuing anyway..." - - -- If we are explicitly told to not download anything, check that all packages - -- are already fetched. - let offline = fromFlagOrDefault False (installOfflineMode installFlags) - when offline $ do - let pkgs = [ confPkgSource cpkg - | InstallPlan.Configured cpkg <- InstallPlan.toList installPlan ] - notFetched <- fmap (map packageId) - . filterM (fmap isNothing . checkFetched . srcpkgSource) - $ pkgs - unless (null notFetched) $ - die' verbosity $ "Can't download packages in offline mode. " - ++ "Must download the following packages to proceed:\n" - ++ intercalate ", " (map prettyShow notFetched) - ++ "\nTry using 'cabal fetch'." - - where - nothingToInstall = null (fst (InstallPlan.ready installPlan)) - - dryRun = fromFlag (installDryRun installFlags) - overrideReinstall = fromFlag (installOverrideReinstall installFlags) - -data PackageStatus = NewPackage - | NewVersion [Version] - | Reinstall [UnitId] [PackageChange] + . PackageIndex.reverseDependencyClosure installed + . map (Installed.installedUnitId . fst) + . PackageIndex.brokenPackages + $ installed + let excluded = reinstalledPkgs ++ oldBrokenPkgs + -- Packages that are reverse dependencies of replaced packages are very + -- likely to be broken. We exclude packages that are already broken. + let newBrokenPkgs = + filter + (\p -> not (Installed.installedUnitId p `elem` excluded)) + (PackageIndex.reverseDependencyClosure installed reinstalledPkgs) + let containsReinstalls = not (null reinstalledPkgs) + let breaksPkgs = not (null newBrokenPkgs) + + let adaptedVerbosity + | containsReinstalls + , not overrideReinstall = + modifyVerbosity (max verbose) verbosity + | otherwise = verbosity + + -- We print the install plan if we are in a dry-run or if we are confronted + -- with a dangerous install plan. + when (dryRun || containsReinstalls && not overrideReinstall) $ + printPlan + (dryRun || breaksPkgs && not overrideReinstall) + adaptedVerbosity + lPlan + sourcePkgDb + + -- If the install plan is dangerous, we print various warning messages. In + -- particular, if we can see that packages are likely to be broken, we even + -- bail out (unless installation has been forced with --force-reinstalls). + when containsReinstalls $ do + if breaksPkgs + then do + (if dryRun || overrideReinstall then warn else die') verbosity $ + unlines $ + "The following packages are likely to be broken by the reinstalls:" + : map (prettyShow . mungedId) newBrokenPkgs + ++ if overrideReinstall + then + if dryRun + then [] + else + [ "Continuing even though " + ++ "the plan contains dangerous reinstalls." + ] + else ["Use --force-reinstalls if you want to install anyway."] + else + unless dryRun $ + warn + verbosity + "Note that reinstalls are always dangerous. Continuing anyway..." + + -- If we are explicitly told to not download anything, check that all packages + -- are already fetched. + let offline = fromFlagOrDefault False (installOfflineMode installFlags) + when offline $ do + let pkgs = + [ confPkgSource cpkg + | InstallPlan.Configured cpkg <- InstallPlan.toList installPlan + ] + notFetched <- + fmap (map packageId) + . filterM (fmap isNothing . checkFetched . srcpkgSource) + $ pkgs + unless (null notFetched) $ + die' verbosity $ + "Can't download packages in offline mode. " + ++ "Must download the following packages to proceed:\n" + ++ intercalate ", " (map prettyShow notFetched) + ++ "\nTry using 'cabal fetch'." + where + nothingToInstall = null (fst (InstallPlan.ready installPlan)) + + dryRun = fromFlag (installDryRun installFlags) + overrideReinstall = fromFlag (installOverrideReinstall installFlags) + +data PackageStatus + = NewPackage + | NewVersion [Version] + | Reinstall [UnitId] [PackageChange] type PackageChange = MergeResult MungedPackageId MungedPackageId extractReinstalls :: PackageStatus -> [UnitId] extractReinstalls (Reinstall ipids _) = ipids -extractReinstalls _ = [] +extractReinstalls _ = [] -packageStatus :: InstalledPackageIndex - -> ReadyPackage - -> PackageStatus +packageStatus + :: InstalledPackageIndex + -> ReadyPackage + -> PackageStatus packageStatus installedPkgIndex cpkg = - case PackageIndex.lookupPackageName installedPkgIndex - (packageName cpkg) of + case PackageIndex.lookupPackageName + installedPkgIndex + (packageName cpkg) of [] -> NewPackage - ps -> case filter ((== mungedId cpkg) - . mungedId) (concatMap snd ps) of - [] -> NewVersion (map fst ps) - pkgs@(pkg:_) -> Reinstall (map Installed.installedUnitId pkgs) - (changes pkg cpkg) - + ps -> case filter + ( (== mungedId cpkg) + . mungedId + ) + (concatMap snd ps) of + [] -> NewVersion (map fst ps) + pkgs@(pkg : _) -> + Reinstall + (map Installed.installedUnitId pkgs) + (changes pkg cpkg) where - - changes :: Installed.InstalledPackageInfo - -> ReadyPackage - -> [PackageChange] - changes pkg (ReadyPackage pkg') = filter changed $ - mergeBy (comparing mungedName) - -- deps of installed pkg - (resolveInstalledIds $ Installed.depends pkg) - -- deps of configured pkg - (resolveInstalledIds $ CD.nonSetupDeps (depends pkg')) + changes + :: Installed.InstalledPackageInfo + -> ReadyPackage + -> [PackageChange] + changes pkg (ReadyPackage pkg') = + filter changed $ + mergeBy + (comparing mungedName) + -- deps of installed pkg + (resolveInstalledIds $ Installed.depends pkg) + -- deps of configured pkg + (resolveInstalledIds $ CD.nonSetupDeps (depends pkg')) -- convert to source pkg ids via index resolveInstalledIds :: [UnitId] -> [MungedPackageId] resolveInstalledIds = - nub - . sort - . map mungedId - . mapMaybe (PackageIndex.lookupUnitId installedPkgIndex) - - changed (InBoth pkgid pkgid') = pkgid /= pkgid' - changed _ = True - -printPlan :: Bool -- is dry run - -> Verbosity - -> [(ReadyPackage, PackageStatus)] - -> SourcePackageDb - -> IO () + nub + . sort + . map mungedId + . mapMaybe (PackageIndex.lookupUnitId installedPkgIndex) + + changed (InBoth pkgid pkgid') = pkgid /= pkgid' + changed _ = True + +printPlan + :: Bool -- is dry run + -> Verbosity + -> [(ReadyPackage, PackageStatus)] + -> SourcePackageDb + -> IO () printPlan dryRun verbosity plan sourcePkgDb = case plan of - [] -> return () + [] -> return () pkgs - | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $ - ("In order, the following " ++ wouldWill ++ " be installed:") - : map showPkgAndReason pkgs - | otherwise -> notice verbosity $ unlines $ - ("In order, the following " ++ wouldWill - ++ " be installed (use -v for more details):") - : map showPkg pkgs + | verbosity >= Verbosity.verbose -> + notice verbosity $ + unlines $ + ("In order, the following " ++ wouldWill ++ " be installed:") + : map showPkgAndReason pkgs + | otherwise -> + notice verbosity $ + unlines $ + ( "In order, the following " + ++ wouldWill + ++ " be installed (use -v for more details):" + ) + : map showPkg pkgs where - wouldWill | dryRun = "would" - | otherwise = "will" + wouldWill + | dryRun = "would" + | otherwise = "will" - showPkg (pkg, _) = prettyShow (packageId pkg) ++ - showLatest (pkg) + showPkg (pkg, _) = + prettyShow (packageId pkg) + ++ showLatest (pkg) - showPkgAndReason (ReadyPackage pkg', pr) = unwords + showPkgAndReason (ReadyPackage pkg', pr) = + unwords [ prettyShow (packageId pkg') , showLatest pkg' , showFlagAssignment (nonDefaultFlags pkg') , showStanzas (confPkgStanzas pkg') , showDep pkg' , case pr of - NewPackage -> "(new package)" - NewVersion _ -> "(new version)" - Reinstall _ cs -> "(reinstall)" ++ case cs of - [] -> "" - diff -> "(changes: " ++ intercalate ", " (map change diff) - ++ ")" + NewPackage -> "(new package)" + NewVersion _ -> "(new version)" + Reinstall _ cs -> + "(reinstall)" ++ case cs of + [] -> "" + diff -> + "(changes: " + ++ intercalate ", " (map change diff) + ++ ")" ] showLatest :: Package srcpkg => srcpkg -> String showLatest pkg = case mLatestVersion of - Just latestVersion -> - if packageVersion pkg < latestVersion - then ("(latest: " ++ prettyShow latestVersion ++ ")") - else "" - Nothing -> "" + Just latestVersion -> + if packageVersion pkg < latestVersion + then ("(latest: " ++ prettyShow latestVersion ++ ")") + else "" + Nothing -> "" where mLatestVersion :: Maybe Version - mLatestVersion = fmap packageVersion $ - safeLast $ - SourcePackageIndex.lookupPackageName - (packageIndex sourcePkgDb) - (packageName pkg) + mLatestVersion = + fmap packageVersion $ + safeLast $ + SourcePackageIndex.lookupPackageName + (packageIndex sourcePkgDb) + (packageName pkg) toFlagAssignment :: [PackageFlag] -> FlagAssignment - toFlagAssignment = mkFlagAssignment . map (\ f -> (flagName f, flagDefault f)) + toFlagAssignment = mkFlagAssignment . map (\f -> (flagName f, flagDefault f)) nonDefaultFlags :: ConfiguredPackage loc -> FlagAssignment nonDefaultFlags cpkg = let defaultAssignment = toFlagAssignment - (genPackageFlags (SourcePackage.srcpkgDescription $ - confPkgSource cpkg)) - in confPkgFlags cpkg `diffFlagAssignment` defaultAssignment - - change (OnlyInLeft pkgid) = prettyShow pkgid ++ " removed" - change (InBoth pkgid pkgid') = prettyShow pkgid ++ " -> " - ++ prettyShow (mungedVersion pkgid') - change (OnlyInRight pkgid') = prettyShow pkgid' ++ " added" - - showDep pkg | Just rdeps <- Map.lookup (packageId pkg) revDeps - = " (via: " ++ unwords (map prettyShow rdeps) ++ ")" - | otherwise = "" + ( genPackageFlags + ( SourcePackage.srcpkgDescription $ + confPkgSource cpkg + ) + ) + in confPkgFlags cpkg `diffFlagAssignment` defaultAssignment + + change (OnlyInLeft pkgid) = prettyShow pkgid ++ " removed" + change (InBoth pkgid pkgid') = + prettyShow pkgid + ++ " -> " + ++ prettyShow (mungedVersion pkgid') + change (OnlyInRight pkgid') = prettyShow pkgid' ++ " added" + + showDep pkg + | Just rdeps <- Map.lookup (packageId pkg) revDeps = + " (via: " ++ unwords (map prettyShow rdeps) ++ ")" + | otherwise = "" revDepGraphEdges :: [(PackageId, PackageId)] - revDepGraphEdges = [ (rpid, packageId cpkg) - | (ReadyPackage cpkg, _) <- plan - , ConfiguredId - rpid - (Just - (PackageDescription.CLibName - PackageDescription.LMainLibName)) - _ - <- CD.flatDeps (confPkgDeps cpkg) ] + revDepGraphEdges = + [ (rpid, packageId cpkg) + | (ReadyPackage cpkg, _) <- plan + , ConfiguredId + rpid + ( Just + ( PackageDescription.CLibName + PackageDescription.LMainLibName + ) + ) + _ <- + CD.flatDeps (confPkgDeps cpkg) + ] revDeps :: Map.Map PackageId [PackageId] - revDeps = Map.fromListWith (++) (map (fmap (:[])) revDepGraphEdges) + revDeps = Map.fromListWith (++) (map (fmap (: [])) revDepGraphEdges) -- ------------------------------------------------------------ + -- * Post installation stuff + -- ------------------------------------------------------------ -- | Report a solver failure. This works slightly differently to -- 'postInstallActions', as (by definition) we don't have an install plan. -reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> String - -> IO () -reportPlanningFailure verbosity - (_, _, comp, platform, _ - ,_, configFlags, _, installFlags, _, _, _) +reportPlanningFailure + :: Verbosity + -> InstallArgs + -> InstallContext + -> String + -> IO () +reportPlanningFailure + verbosity + ( _ + , _ + , comp + , platform + , _ + , _ + , configFlags + , _ + , installFlags + , _ + , _ + , _ + ) (_, sourcePkgDb, _, _, pkgSpecifiers, _) message = do + when reportFailure $ do + -- Only create reports for explicitly named packages + let pkgids = + filter + (SourcePackageIndex.elemByPackageId (packageIndex sourcePkgDb)) + $ mapMaybe theSpecifiedPackage pkgSpecifiers + + buildReports = + BuildReports.fromPlanningFailure + platform + (compilerId comp) + pkgids + (configConfigurationsFlags configFlags) + + unless (null buildReports) $ + info verbosity $ + "Solver failure will be reported for " + ++ intercalate "," (map prettyShow pkgids) + + -- Save reports + BuildReports.storeLocal + (compilerInfo comp) + (fromNubList $ installSummaryFile installFlags) + buildReports + platform - when reportFailure $ do - - -- Only create reports for explicitly named packages - let pkgids = filter - (SourcePackageIndex.elemByPackageId (packageIndex sourcePkgDb)) $ - mapMaybe theSpecifiedPackage pkgSpecifiers - - buildReports = BuildReports.fromPlanningFailure platform - (compilerId comp) pkgids - (configConfigurationsFlags configFlags) - - unless (null buildReports) $ - info verbosity $ - "Solver failure will be reported for " - ++ intercalate "," (map prettyShow pkgids) - - -- Save reports - BuildReports.storeLocal (compilerInfo comp) - (fromNubList $ installSummaryFile installFlags) - buildReports platform - - -- Save solver log - case logFile of - Nothing -> return () - Just template -> for_ pkgids $ \pkgid -> - let env = initialPathTemplateEnv pkgid dummyIpid - (compilerInfo comp) platform - path = fromPathTemplate $ substPathTemplate env template - in writeFile path message - - where - reportFailure = fromFlag (installReportPlanningFailure installFlags) - logFile = flagToMaybe (installLogFile installFlags) - - -- A IPID is calculated from the transitive closure of - -- dependencies, but when the solver fails we don't have that. - -- So we fail. - dummyIpid = error "reportPlanningFailure: installed package ID not available" + -- Save solver log + case logFile of + Nothing -> return () + Just template -> for_ pkgids $ \pkgid -> + let env = + initialPathTemplateEnv + pkgid + dummyIpid + (compilerInfo comp) + platform + path = fromPathTemplate $ substPathTemplate env template + in writeFile path message + where + reportFailure = fromFlag (installReportPlanningFailure installFlags) + logFile = flagToMaybe (installLogFile installFlags) + + -- A IPID is calculated from the transitive closure of + -- dependencies, but when the solver fails we don't have that. + -- So we fail. + dummyIpid = error "reportPlanningFailure: installed package ID not available" -- | If a 'PackageSpecifier' refers to a single package, return Just that -- package. theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId theSpecifiedPackage pkgSpec = case pkgSpec of - NamedPackage name [PackagePropertyVersion version] - -> PackageIdentifier name <$> trivialRange version + NamedPackage name [PackagePropertyVersion version] -> + PackageIdentifier name <$> trivialRange version NamedPackage _ _ -> Nothing SpecificSourcePackage pkg -> Just $ packageId pkg where - -- | If a range includes only a single version, return Just that version. + -- \| If a range includes only a single version, return Just that version. trivialRange :: VersionRange -> Maybe Version - trivialRange = foldVersionRange + trivialRange = + foldVersionRange Nothing - Just -- "== v" + Just -- "== v" (\_ -> Nothing) (\_ -> Nothing) (\_ _ -> Nothing) @@ -793,201 +1120,276 @@ theSpecifiedPackage pkgSpec = -- * symlinking binaries -- * updating indexes -- * error reporting --- -postInstallActions :: Verbosity - -> InstallArgs - -> [UserTarget] - -> InstallPlan - -> BuildOutcomes - -> IO () -postInstallActions verbosity - (packageDBs, _, comp, platform, progdb - ,globalFlags, configFlags, _, installFlags, _, _, _) - _ installPlan buildOutcomes = do - - let buildReports = BuildReports.fromInstallPlan platform (compilerId comp) - installPlan buildOutcomes - BuildReports.storeLocal (compilerInfo comp) - (fromNubList $ installSummaryFile installFlags) - buildReports - platform - when (reportingLevel >= AnonymousReports) $ - BuildReports.storeAnonymous buildReports - when (reportingLevel == DetailedReports) $ - storeDetailedBuildReports verbosity logsDir buildReports - - regenerateHaddockIndex verbosity packageDBs comp platform progdb - configFlags installFlags buildOutcomes - - symlinkBinaries verbosity platform comp configFlags installFlags - installPlan buildOutcomes - - printBuildFailures verbosity buildOutcomes - - where - reportingLevel = fromFlag (installBuildReports installFlags) - logsDir = fromFlag (globalLogsDir globalFlags) - -storeDetailedBuildReports :: Verbosity -> FilePath - -> [(BuildReports.BuildReport, Maybe Repo)] -> IO () -storeDetailedBuildReports verbosity logsDir reports = sequence_ - [ do allReportsDir <- defaultReportsDir - let logFileName = prettyShow (BuildReports.package report) <.> "log" - logFile = logsDir logFileName - reportsDir = allReportsDir unRepoName (remoteRepoName remoteRepo) - reportFile = reportsDir logFileName - - handleMissingLogFile $ do - buildLog <- readFile logFile - createDirectoryIfMissing True reportsDir -- FIXME - writeFile reportFile (show (showBuildReport report, buildLog)) - - | (report, Just repo) <- reports - , Just remoteRepo <- [maybeRepoRemote repo] - , isLikelyToHaveLogFile (BuildReports.installOutcome report) ] - +postInstallActions + :: Verbosity + -> InstallArgs + -> [UserTarget] + -> InstallPlan + -> BuildOutcomes + -> IO () +postInstallActions + verbosity + ( packageDBs + , _ + , comp + , platform + , progdb + , globalFlags + , configFlags + , _ + , installFlags + , _ + , _ + , _ + ) + _ + installPlan + buildOutcomes = do + let buildReports = + BuildReports.fromInstallPlan + platform + (compilerId comp) + installPlan + buildOutcomes + BuildReports.storeLocal + (compilerInfo comp) + (fromNubList $ installSummaryFile installFlags) + buildReports + platform + when (reportingLevel >= AnonymousReports) $ + BuildReports.storeAnonymous buildReports + when (reportingLevel == DetailedReports) $ + storeDetailedBuildReports verbosity logsDir buildReports + + regenerateHaddockIndex + verbosity + packageDBs + comp + platform + progdb + configFlags + installFlags + buildOutcomes + + symlinkBinaries + verbosity + platform + comp + configFlags + installFlags + installPlan + buildOutcomes + + printBuildFailures verbosity buildOutcomes + where + reportingLevel = fromFlag (installBuildReports installFlags) + logsDir = fromFlag (globalLogsDir globalFlags) + +storeDetailedBuildReports + :: Verbosity + -> FilePath + -> [(BuildReports.BuildReport, Maybe Repo)] + -> IO () +storeDetailedBuildReports verbosity logsDir reports = + sequence_ + [ do + allReportsDir <- defaultReportsDir + let logFileName = prettyShow (BuildReports.package report) <.> "log" + logFile = logsDir logFileName + reportsDir = allReportsDir unRepoName (remoteRepoName remoteRepo) + reportFile = reportsDir logFileName + + handleMissingLogFile $ do + buildLog <- readFile logFile + createDirectoryIfMissing True reportsDir -- FIXME + writeFile reportFile (show (showBuildReport report, buildLog)) + | (report, Just repo) <- reports + , Just remoteRepo <- [maybeRepoRemote repo] + , isLikelyToHaveLogFile (BuildReports.installOutcome report) + ] where - isLikelyToHaveLogFile BuildReports.ConfigureFailed {} = True - isLikelyToHaveLogFile BuildReports.BuildFailed {} = True - isLikelyToHaveLogFile BuildReports.InstallFailed {} = True - isLikelyToHaveLogFile BuildReports.InstallOk {} = True - isLikelyToHaveLogFile _ = False + isLikelyToHaveLogFile BuildReports.ConfigureFailed{} = True + isLikelyToHaveLogFile BuildReports.BuildFailed{} = True + isLikelyToHaveLogFile BuildReports.InstallFailed{} = True + isLikelyToHaveLogFile BuildReports.InstallOk{} = True + isLikelyToHaveLogFile _ = False handleMissingLogFile = Exception.handleJust missingFile $ \ioe -> - warn verbosity $ "Missing log file for build report: " - ++ fromMaybe "" (ioeGetFileName ioe) + warn verbosity $ + "Missing log file for build report: " + ++ fromMaybe "" (ioeGetFileName ioe) missingFile ioe - | isDoesNotExistError ioe = Just ioe - missingFile _ = Nothing - - -regenerateHaddockIndex :: Verbosity - -> [PackageDB] - -> Compiler - -> Platform - -> ProgramDb - -> ConfigFlags - -> InstallFlags - -> BuildOutcomes - -> IO () -regenerateHaddockIndex verbosity packageDBs comp platform progdb - configFlags installFlags buildOutcomes - | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do - - defaultDirs <- InstallDirs.defaultInstallDirs - (compilerFlavor comp) - (fromFlag (configUserInstall configFlags)) - True - let indexFileTemplate = fromFlag (installHaddockIndex installFlags) - indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate - - notice verbosity $ - "Updating documentation index " ++ indexFile - - --TODO: might be nice if the install plan gave us the new InstalledPackageInfo - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb - Haddock.regenerateHaddockIndex verbosity installedPkgIndex progdb indexFile - - | otherwise = return () - where - haddockIndexFileIsRequested = - fromFlag (installDocumentation installFlags) - && isJust (flagToMaybe (installHaddockIndex installFlags)) - - -- We want to regenerate the index if some new documentation was actually - -- installed. Since the index can be only per-user or per-sandbox (see - -- #1337), we don't do it for global installs or special cases where we're - -- installing into a specific db. - shouldRegenerateHaddockIndex = normalUserInstall && someDocsWereInstalled buildOutcomes - where - someDocsWereInstalled = any installedDocs . Map.elems - installedDocs (Right (BuildResult DocsOk _ _)) = True - installedDocs _ = False - - normalUserInstall = (UserPackageDB `elem` packageDBs) - && all (not . isSpecificPackageDB) packageDBs - isSpecificPackageDB (SpecificPackageDB _) = True - isSpecificPackageDB _ = False - - substHaddockIndexFileName defaultDirs = fromPathTemplate - . substPathTemplate env - where - env = env0 ++ installDirsTemplateEnv absoluteDirs - env0 = InstallDirs.compilerTemplateEnv (compilerInfo comp) - ++ InstallDirs.platformTemplateEnv platform - ++ InstallDirs.abiTemplateEnv (compilerInfo comp) platform - absoluteDirs = InstallDirs.substituteInstallDirTemplates - env0 templateDirs - templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault - defaultDirs (configInstallDirs configFlags) - - -symlinkBinaries :: Verbosity - -> Platform -> Compiler - -> ConfigFlags - -> InstallFlags - -> InstallPlan - -> BuildOutcomes - -> IO () -symlinkBinaries verbosity platform comp configFlags installFlags - plan buildOutcomes = do - failed <- InstallSymlink.symlinkBinaries platform comp - NeverOverwrite - configFlags installFlags - plan buildOutcomes - case failed of - [] -> return () - [(_, exe, path)] -> - warn verbosity $ - "could not create a symlink in " ++ bindir ++ " for " - ++ prettyShow exe ++ " because the file exists there already but is not " - ++ "managed by cabal. You can create a symlink for this executable " - ++ "manually if you wish. The executable file has been installed at " - ++ path - exes -> - warn verbosity $ - "could not create symlinks in " ++ bindir ++ " for " - ++ intercalate ", " [ prettyShow exe | (_, exe, _) <- exes ] - ++ " because the files exist there already and are not " - ++ "managed by cabal. You can create symlinks for these executables " - ++ "manually if you wish. The executable files have been installed at " - ++ intercalate ", " [ path | (_, _, path) <- exes ] - where - bindir = fromFlag (installSymlinkBinDir installFlags) + | isDoesNotExistError ioe = Just ioe + missingFile _ = Nothing +regenerateHaddockIndex + :: Verbosity + -> [PackageDB] + -> Compiler + -> Platform + -> ProgramDb + -> ConfigFlags + -> InstallFlags + -> BuildOutcomes + -> IO () +regenerateHaddockIndex + verbosity + packageDBs + comp + platform + progdb + configFlags + installFlags + buildOutcomes + | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do + defaultDirs <- + InstallDirs.defaultInstallDirs + (compilerFlavor comp) + (fromFlag (configUserInstall configFlags)) + True + let indexFileTemplate = fromFlag (installHaddockIndex installFlags) + indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate + + notice verbosity $ + "Updating documentation index " ++ indexFile + + -- TODO: might be nice if the install plan gave us the new InstalledPackageInfo + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb + Haddock.regenerateHaddockIndex verbosity installedPkgIndex progdb indexFile + | otherwise = return () + where + haddockIndexFileIsRequested = + fromFlag (installDocumentation installFlags) + && isJust (flagToMaybe (installHaddockIndex installFlags)) + + -- We want to regenerate the index if some new documentation was actually + -- installed. Since the index can be only per-user or per-sandbox (see + -- #1337), we don't do it for global installs or special cases where we're + -- installing into a specific db. + shouldRegenerateHaddockIndex = normalUserInstall && someDocsWereInstalled buildOutcomes + where + someDocsWereInstalled = any installedDocs . Map.elems + installedDocs (Right (BuildResult DocsOk _ _)) = True + installedDocs _ = False + + normalUserInstall = + (UserPackageDB `elem` packageDBs) + && all (not . isSpecificPackageDB) packageDBs + isSpecificPackageDB (SpecificPackageDB _) = True + isSpecificPackageDB _ = False + + substHaddockIndexFileName defaultDirs = + fromPathTemplate + . substPathTemplate env + where + env = env0 ++ installDirsTemplateEnv absoluteDirs + env0 = + InstallDirs.compilerTemplateEnv (compilerInfo comp) + ++ InstallDirs.platformTemplateEnv platform + ++ InstallDirs.abiTemplateEnv (compilerInfo comp) platform + absoluteDirs = + InstallDirs.substituteInstallDirTemplates + env0 + templateDirs + templateDirs = + InstallDirs.combineInstallDirs + fromFlagOrDefault + defaultDirs + (configInstallDirs configFlags) + +symlinkBinaries + :: Verbosity + -> Platform + -> Compiler + -> ConfigFlags + -> InstallFlags + -> InstallPlan + -> BuildOutcomes + -> IO () +symlinkBinaries + verbosity + platform + comp + configFlags + installFlags + plan + buildOutcomes = do + failed <- + InstallSymlink.symlinkBinaries + platform + comp + NeverOverwrite + configFlags + installFlags + plan + buildOutcomes + case failed of + [] -> return () + [(_, exe, path)] -> + warn verbosity $ + "could not create a symlink in " + ++ bindir + ++ " for " + ++ prettyShow exe + ++ " because the file exists there already but is not " + ++ "managed by cabal. You can create a symlink for this executable " + ++ "manually if you wish. The executable file has been installed at " + ++ path + exes -> + warn verbosity $ + "could not create symlinks in " + ++ bindir + ++ " for " + ++ intercalate ", " [prettyShow exe | (_, exe, _) <- exes] + ++ " because the files exist there already and are not " + ++ "managed by cabal. You can create symlinks for these executables " + ++ "manually if you wish. The executable files have been installed at " + ++ intercalate ", " [path | (_, _, path) <- exes] + where + bindir = fromFlag (installSymlinkBinDir installFlags) printBuildFailures :: Verbosity -> BuildOutcomes -> IO () printBuildFailures verbosity buildOutcomes = case [ (pkgid, failure) - | (pkgid, Left failure) <- Map.toList buildOutcomes ] of - [] -> return () - failed -> die' verbosity . unlines - $ "Some packages failed to install:" - : [ prettyShow pkgid ++ printFailureReason reason - | (pkgid, reason) <- failed ] + | (pkgid, Left failure) <- Map.toList buildOutcomes + ] of + [] -> return () + failed -> + die' verbosity . unlines $ + "Some packages failed to install:" + : [ prettyShow pkgid ++ printFailureReason reason + | (pkgid, reason) <- failed + ] where printFailureReason reason = case reason of GracefulFailure msg -> msg - DependentFailed pkgid -> " depends on " ++ prettyShow pkgid - ++ " which failed to install." - DownloadFailed e -> " failed while downloading the package." - ++ showException e - UnpackFailed e -> " failed while unpacking the package." - ++ showException e - ConfigureFailed e -> " failed during the configure step." - ++ showException e - BuildFailed e -> " failed during the building phase." - ++ showException e - TestsFailed e -> " failed during the tests phase." - ++ showException e - InstallFailed e -> " failed during the final install step." - ++ showException e - + DependentFailed pkgid -> + " depends on " + ++ prettyShow pkgid + ++ " which failed to install." + DownloadFailed e -> + " failed while downloading the package." + ++ showException e + UnpackFailed e -> + " failed while unpacking the package." + ++ showException e + ConfigureFailed e -> + " failed during the configure step." + ++ showException e + BuildFailed e -> + " failed during the building phase." + ++ showException e + TestsFailed e -> + " failed during the tests phase." + ++ showException e + InstallFailed e -> + " failed during the final install step." + ++ showException e -- This will never happen, but we include it for completeness PlanningFailed -> " failed during the planning phase." - showException e = " The exception was:\n " ++ show e ++ maybeOOM e + showException e = " The exception was:\n " ++ show e ++ maybeOOM e #ifdef mingw32_HOST_OS maybeOOM _ = "" #else @@ -999,140 +1401,193 @@ printBuildFailures verbosity buildOutcomes = #endif -- ------------------------------------------------------------ + -- * Actually do the installations + -- ------------------------------------------------------------ -data InstallMisc = InstallMisc { - libVersion :: Maybe Version +data InstallMisc = InstallMisc + { libVersion :: Maybe Version } -- | If logging is enabled, contains location of the log file and the verbosity -- level for logging. type UseLogFile = Maybe (PackageIdentifier -> UnitId -> FilePath, Verbosity) -performInstallations :: Verbosity - -> InstallArgs - -> InstalledPackageIndex - -> InstallPlan - -> IO BuildOutcomes -performInstallations verbosity - (packageDBs, repoCtxt, comp, platform, progdb, - globalFlags, configFlags, configExFlags, installFlags, - haddockFlags, testFlags, _) - installedPkgIndex installPlan = do - - info verbosity $ "Number of threads used: " ++ (show numJobs) ++ "." - - jobControl <- if parallelInstall then newParallelJobControl numJobs - else newSerialJobControl - fetchLimit <- newJobLimit (min numJobs numFetchJobs) - installLock <- newLock -- serialise installation - cacheLock <- newLock -- serialise access to setup exe cache - - executeInstallPlan verbosity jobControl keepGoing useLogFile - installPlan $ \rpkg -> - installReadyPackage platform cinfo configFlags - rpkg $ \configFlags' src pkg pkgoverride -> - fetchSourcePackage verbosity repoCtxt fetchLimit src $ \src' -> - installLocalPackage verbosity (packageId pkg) src' distPref $ \mpath -> - installUnpackedPackage verbosity installLock numJobs - (setupScriptOptions installedPkgIndex - cacheLock rpkg) - configFlags' - installFlags haddockFlags testFlags - comp progdb - platform pkg rpkg pkgoverride mpath useLogFile +performInstallations + :: Verbosity + -> InstallArgs + -> InstalledPackageIndex + -> InstallPlan + -> IO BuildOutcomes +performInstallations + verbosity + ( packageDBs + , repoCtxt + , comp + , platform + , progdb + , globalFlags + , configFlags + , configExFlags + , installFlags + , haddockFlags + , testFlags + , _ + ) + installedPkgIndex + installPlan = do + info verbosity $ "Number of threads used: " ++ (show numJobs) ++ "." + + jobControl <- + if parallelInstall + then newParallelJobControl numJobs + else newSerialJobControl + fetchLimit <- newJobLimit (min numJobs numFetchJobs) + installLock <- newLock -- serialise installation + cacheLock <- newLock -- serialise access to setup exe cache + executeInstallPlan + verbosity + jobControl + keepGoing + useLogFile + installPlan + $ \rpkg -> + installReadyPackage + platform + cinfo + configFlags + rpkg + $ \configFlags' src pkg pkgoverride -> + fetchSourcePackage verbosity repoCtxt fetchLimit src $ \src' -> + installLocalPackage verbosity (packageId pkg) src' distPref $ \mpath -> + installUnpackedPackage + verbosity + installLock + numJobs + ( setupScriptOptions + installedPkgIndex + cacheLock + rpkg + ) + configFlags' + installFlags + haddockFlags + testFlags + comp + progdb + platform + pkg + rpkg + pkgoverride + mpath + useLogFile + where + cinfo = compilerInfo comp + + numJobs = determineNumJobs (installNumJobs installFlags) + numFetchJobs = 2 + parallelInstall = numJobs >= 2 + keepGoing = fromFlag (installKeepGoing installFlags) + distPref = + fromFlagOrDefault + (useDistPref defaultSetupScriptOptions) + (configDistPref configFlags) + + setupScriptOptions index lock rpkg = + configureSetupScript + packageDBs + comp + platform + progdb + distPref + (chooseCabalVersion configExFlags (libVersion miscOptions)) + (Just lock) + parallelInstall + index + (Just rpkg) + + reportingLevel = fromFlag (installBuildReports installFlags) + logsDir = fromFlag (globalLogsDir globalFlags) + + -- Should the build output be written to a log file instead of stdout? + useLogFile :: UseLogFile + useLogFile = + fmap + ((\f -> (f, loggingVerbosity)) . substLogFileName) + logFileTemplate + where + installLogFile' = flagToMaybe $ installLogFile installFlags + defaultTemplate = + toPathTemplate $ + logsDir "$compiler" "$libname" <.> "log" + + -- If the user has specified --remote-build-reporting=detailed, use the + -- default log file location. If the --build-log option is set, use the + -- provided location. Otherwise don't use logging, unless building in + -- parallel (in which case the default location is used). + logFileTemplate :: Maybe PathTemplate + logFileTemplate + | useDefaultTemplate = Just defaultTemplate + | otherwise = installLogFile' + + -- If the user has specified --remote-build-reporting=detailed or + -- --build-log, use more verbose logging. + loggingVerbosity :: Verbosity + loggingVerbosity + | overrideVerbosity = modifyVerbosity (max verbose) verbosity + | otherwise = verbosity + + useDefaultTemplate :: Bool + useDefaultTemplate + | reportingLevel == DetailedReports = True + | isJust installLogFile' = False + | parallelInstall = True + | otherwise = False + + overrideVerbosity :: Bool + overrideVerbosity + | reportingLevel == DetailedReports = True + | isJust installLogFile' = True + | parallelInstall = False + | otherwise = False + + substLogFileName :: PathTemplate -> PackageIdentifier -> UnitId -> FilePath + substLogFileName template pkg uid = + fromPathTemplate + . substPathTemplate env + $ template + where + env = + initialPathTemplateEnv + (packageId pkg) + uid + (compilerInfo comp) + platform - where - cinfo = compilerInfo comp - - numJobs = determineNumJobs (installNumJobs installFlags) - numFetchJobs = 2 - parallelInstall = numJobs >= 2 - keepGoing = fromFlag (installKeepGoing installFlags) - distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions) - (configDistPref configFlags) - - setupScriptOptions index lock rpkg = - configureSetupScript - packageDBs - comp - platform - progdb - distPref - (chooseCabalVersion configExFlags (libVersion miscOptions)) - (Just lock) - parallelInstall - index - (Just rpkg) - - reportingLevel = fromFlag (installBuildReports installFlags) - logsDir = fromFlag (globalLogsDir globalFlags) - - -- Should the build output be written to a log file instead of stdout? - useLogFile :: UseLogFile - useLogFile = fmap ((\f -> (f, loggingVerbosity)) . substLogFileName) - logFileTemplate - where - installLogFile' = flagToMaybe $ installLogFile installFlags - defaultTemplate = toPathTemplate $ - logsDir "$compiler" "$libname" <.> "log" - - -- If the user has specified --remote-build-reporting=detailed, use the - -- default log file location. If the --build-log option is set, use the - -- provided location. Otherwise don't use logging, unless building in - -- parallel (in which case the default location is used). - logFileTemplate :: Maybe PathTemplate - logFileTemplate - | useDefaultTemplate = Just defaultTemplate - | otherwise = installLogFile' - - -- If the user has specified --remote-build-reporting=detailed or - -- --build-log, use more verbose logging. - loggingVerbosity :: Verbosity - loggingVerbosity | overrideVerbosity = modifyVerbosity (max verbose) verbosity - | otherwise = verbosity - - useDefaultTemplate :: Bool - useDefaultTemplate - | reportingLevel == DetailedReports = True - | isJust installLogFile' = False - | parallelInstall = True - | otherwise = False - - overrideVerbosity :: Bool - overrideVerbosity - | reportingLevel == DetailedReports = True - | isJust installLogFile' = True - | parallelInstall = False - | otherwise = False - - substLogFileName :: PathTemplate -> PackageIdentifier -> UnitId -> FilePath - substLogFileName template pkg uid = fromPathTemplate - . substPathTemplate env - $ template - where env = initialPathTemplateEnv (packageId pkg) uid - (compilerInfo comp) platform - - miscOptions = InstallMisc { - libVersion = flagToMaybe (configCabalVersion configExFlags) - } - - -executeInstallPlan :: Verbosity - -> JobControl IO (UnitId, BuildOutcome) - -> Bool - -> UseLogFile - -> InstallPlan - -> (ReadyPackage -> IO BuildOutcome) - -> IO BuildOutcomes -executeInstallPlan verbosity jobCtl keepGoing useLogFile plan0 installPkg = - InstallPlan.execute - jobCtl keepGoing depsFailure plan0 $ \pkg -> do - buildOutcome <- installPkg pkg - printBuildResult (packageId pkg) (installedUnitId pkg) buildOutcome - return buildOutcome + miscOptions = + InstallMisc + { libVersion = flagToMaybe (configCabalVersion configExFlags) + } +executeInstallPlan + :: Verbosity + -> JobControl IO (UnitId, BuildOutcome) + -> Bool + -> UseLogFile + -> InstallPlan + -> (ReadyPackage -> IO BuildOutcome) + -> IO BuildOutcomes +executeInstallPlan verbosity jobCtl keepGoing useLogFile plan0 installPkg = + InstallPlan.execute + jobCtl + keepGoing + depsFailure + plan0 + $ \pkg -> do + buildOutcome <- installPkg pkg + printBuildResult (packageId pkg) (installedUnitId pkg) buildOutcome + return buildOutcome where depsFailure = DependentFailed . packageId @@ -1140,16 +1595,16 @@ executeInstallPlan verbosity jobCtl keepGoing useLogFile plan0 installPkg = -- otherwise. printBuildResult :: PackageId -> UnitId -> BuildOutcome -> IO () printBuildResult pkgid uid buildOutcome = case buildOutcome of - (Right _) -> progressMessage verbosity ProgressCompleted (prettyShow pkgid) - (Left _) -> do - notice verbosity $ "Failed to install " ++ prettyShow pkgid - when (verbosity >= normal) $ - case useLogFile of - Nothing -> return () - Just (mkLogFileName, _) -> do - let logName = mkLogFileName pkgid uid - putStr $ "Build log ( " ++ logName ++ " ):\n" - printFile logName + (Right _) -> progressMessage verbosity ProgressCompleted (prettyShow pkgid) + (Left _) -> do + notice verbosity $ "Failed to install " ++ prettyShow pkgid + when (verbosity >= normal) $ + case useLogFile of + Nothing -> return () + Just (mkLogFileName, _) -> do + let logName = mkLogFileName pkgid uid + putStr $ "Build log ( " ++ logName ++ " ):\n" + printFile logName printFile :: FilePath -> IO () printFile path = readFile path >>= putStr @@ -1162,47 +1617,75 @@ executeInstallPlan verbosity jobCtl keepGoing useLogFile plan0 installPkg = -- -- NB: when updating this function, don't forget to also update -- 'configurePackage' in D.C.Configure. -installReadyPackage :: Platform -> CompilerInfo - -> ConfigFlags - -> ReadyPackage - -> (ConfigFlags -> UnresolvedPkgLoc - -> PackageDescription - -> PackageDescriptionOverride - -> a) - -> a -installReadyPackage platform cinfo configFlags - (ReadyPackage (ConfiguredPackage ipid - (SourcePackage _ gpkg source pkgoverride) - flags stanzas deps)) - installPkg = - installPkg configFlags { - configIPID = toFlag (prettyShow ipid), - configConfigurationsFlags = flags, - -- We generate the legacy constraints as well as the new style precise deps. - -- In the end only one set gets passed to Setup.hs configure, depending on - -- the Cabal version we are talking to. - configConstraints = [ thisPackageVersionConstraint srcid - | ConfiguredId - srcid - (Just - (PackageDescription.CLibName - PackageDescription.LMainLibName)) - _ipid - <- CD.nonSetupDeps deps ], - configDependencies = [ GivenComponent (packageName srcid) cname dep_ipid - | ConfiguredId srcid (Just (PackageDescription.CLibName cname)) dep_ipid - <- CD.nonSetupDeps deps ], - -- Use '--exact-configuration' if supported. - configExactConfiguration = toFlag True, - configBenchmarks = toFlag False, - configTests = toFlag (TestStanzas `optStanzaSetMember` stanzas) - } source pkg pkgoverride - where - pkg = case finalizePD flags (enableStanzas stanzas) - (const True) - platform cinfo [] gpkg of - Left _ -> error "finalizePD ReadyPackage failed" - Right (desc, _) -> desc +installReadyPackage + :: Platform + -> CompilerInfo + -> ConfigFlags + -> ReadyPackage + -> ( ConfigFlags + -> UnresolvedPkgLoc + -> PackageDescription + -> PackageDescriptionOverride + -> a + ) + -> a +installReadyPackage + platform + cinfo + configFlags + ( ReadyPackage + ( ConfiguredPackage + ipid + (SourcePackage _ gpkg source pkgoverride) + flags + stanzas + deps + ) + ) + installPkg = + installPkg + configFlags + { configIPID = toFlag (prettyShow ipid) + , configConfigurationsFlags = flags + , -- We generate the legacy constraints as well as the new style precise deps. + -- In the end only one set gets passed to Setup.hs configure, depending on + -- the Cabal version we are talking to. + configConstraints = + [ thisPackageVersionConstraint srcid + | ConfiguredId + srcid + ( Just + ( PackageDescription.CLibName + PackageDescription.LMainLibName + ) + ) + _ipid <- + CD.nonSetupDeps deps + ] + , configDependencies = + [ GivenComponent (packageName srcid) cname dep_ipid + | ConfiguredId srcid (Just (PackageDescription.CLibName cname)) dep_ipid <- + CD.nonSetupDeps deps + ] + , -- Use '--exact-configuration' if supported. + configExactConfiguration = toFlag True + , configBenchmarks = toFlag False + , configTests = toFlag (TestStanzas `optStanzaSetMember` stanzas) + } + source + pkg + pkgoverride + where + pkg = case finalizePD + flags + (enableStanzas stanzas) + (const True) + platform + cinfo + [] + gpkg of + Left _ -> error "finalizePD ReadyPackage failed" + Right (desc, _) -> desc fetchSourcePackage :: Verbosity @@ -1215,89 +1698,120 @@ fetchSourcePackage verbosity repoCtxt fetchLimit src installPkg = do fetched <- checkFetched src case fetched of Just src' -> installPkg src' - Nothing -> onFailure DownloadFailed $ do - loc <- withJobLimit fetchLimit $ - fetchPackage verbosity repoCtxt src - installPkg loc - + Nothing -> onFailure DownloadFailed $ do + loc <- + withJobLimit fetchLimit $ + fetchPackage verbosity repoCtxt src + installPkg loc installLocalPackage :: Verbosity - -> PackageIdentifier -> ResolvedPkgLoc -> FilePath + -> PackageIdentifier + -> ResolvedPkgLoc + -> FilePath -> (Maybe FilePath -> IO BuildOutcome) -> IO BuildOutcome installLocalPackage verbosity pkgid location distPref installPkg = - case location of - LocalUnpackedPackage dir -> installPkg (Just dir) - RemoteSourceRepoPackage _repo dir -> installPkg (Just dir) - LocalTarballPackage tarballPath -> - installLocalTarballPackage verbosity - pkgid tarballPath distPref installPkg - + installLocalTarballPackage + verbosity + pkgid + tarballPath + distPref + installPkg RemoteTarballPackage _ tarballPath -> - installLocalTarballPackage verbosity - pkgid tarballPath distPref installPkg - + installLocalTarballPackage + verbosity + pkgid + tarballPath + distPref + installPkg RepoTarballPackage _ _ tarballPath -> - installLocalTarballPackage verbosity - pkgid tarballPath distPref installPkg + installLocalTarballPackage + verbosity + pkgid + tarballPath + distPref + installPkg installLocalTarballPackage :: Verbosity - -> PackageIdentifier -> FilePath -> FilePath + -> PackageIdentifier + -> FilePath + -> FilePath -> (Maybe FilePath -> IO BuildOutcome) -> IO BuildOutcome -installLocalTarballPackage verbosity pkgid - tarballPath distPref installPkg = do - tmp <- getTemporaryDirectory - withTempDirectory verbosity tmp "cabal-tmp" $ \tmpDirPath -> - onFailure UnpackFailed $ do - let relUnpackedPath = prettyShow pkgid - absUnpackedPath = tmpDirPath relUnpackedPath - descFilePath = absUnpackedPath - prettyShow (packageName pkgid) <.> "cabal" - info verbosity $ "Extracting " ++ tarballPath - ++ " to " ++ tmpDirPath ++ "..." - extractTarGzFile tmpDirPath relUnpackedPath tarballPath - exists <- doesFileExist descFilePath - unless exists $ - die' verbosity $ "Package .cabal file not found: " ++ show descFilePath - maybeRenameDistDir absUnpackedPath - installPkg (Just absUnpackedPath) - - where - -- 'cabal sdist' puts pre-generated files in the 'dist' - -- directory. This fails when a nonstandard build directory name - -- is used (as is the case with sandboxes), so we need to rename - -- the 'dist' dir here. - -- - -- TODO: 'cabal get happy && cd sandbox && cabal install ../happy' still - -- 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 - distDirExists <- doesDirectoryExist distDirPath - when (distDirExists - && (not $ distDirPath `equalFilePath` distDirPathNew)) $ do - -- NB: we need to handle the case when 'distDirPathNew' is a - -- subdirectory of 'distDirPath' (e.g. the former is - -- 'dist/dist-sandbox-3688fbc2' and the latter is 'dist'). - debug verbosity $ "Renaming '" ++ distDirPath ++ "' to '" - ++ distDirPathTmp ++ "'." - renameDirectory distDirPath distDirPathTmp - when (distDirPath `isPrefixOf` distDirPathNew) $ - createDirectoryIfMissingVerbose verbosity False distDirPath - debug verbosity $ "Renaming '" ++ distDirPathTmp ++ "' to '" - ++ distDirPathNew ++ "'." - renameDirectory distDirPathTmp distDirPathNew +installLocalTarballPackage + verbosity + pkgid + tarballPath + distPref + installPkg = do + tmp <- getTemporaryDirectory + withTempDirectory verbosity tmp "cabal-tmp" $ \tmpDirPath -> + onFailure UnpackFailed $ do + let relUnpackedPath = prettyShow pkgid + absUnpackedPath = tmpDirPath relUnpackedPath + descFilePath = + absUnpackedPath + prettyShow (packageName pkgid) + <.> "cabal" + info verbosity $ + "Extracting " + ++ tarballPath + ++ " to " + ++ tmpDirPath + ++ "..." + extractTarGzFile tmpDirPath relUnpackedPath tarballPath + exists <- doesFileExist descFilePath + unless exists $ + die' verbosity $ + "Package .cabal file not found: " ++ show descFilePath + maybeRenameDistDir absUnpackedPath + installPkg (Just absUnpackedPath) + where + -- 'cabal sdist' puts pre-generated files in the 'dist' + -- directory. This fails when a nonstandard build directory name + -- is used (as is the case with sandboxes), so we need to rename + -- the 'dist' dir here. + -- + -- TODO: 'cabal get happy && cd sandbox && cabal install ../happy' still + -- 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 + distDirExists <- doesDirectoryExist distDirPath + when + ( distDirExists + && (not $ distDirPath `equalFilePath` distDirPathNew) + ) + $ do + -- NB: we need to handle the case when 'distDirPathNew' is a + -- subdirectory of 'distDirPath' (e.g. the former is + -- 'dist/dist-sandbox-3688fbc2' and the latter is 'dist'). + debug verbosity $ + "Renaming '" + ++ distDirPath + ++ "' to '" + ++ distDirPathTmp + ++ "'." + renameDirectory distDirPath distDirPathTmp + when (distDirPath `isPrefixOf` distDirPathNew) $ + createDirectoryIfMissingVerbose verbosity False distDirPath + debug verbosity $ + "Renaming '" + ++ distDirPathTmp + ++ "' to '" + ++ distDirPathNew + ++ "'." + renameDirectory distDirPathTmp distDirPathNew installUnpackedPackage :: Verbosity @@ -1314,235 +1828,301 @@ installUnpackedPackage -> PackageDescription -> ReadyPackage -> PackageDescriptionOverride - -> Maybe FilePath -- ^ Directory to change to before starting the installation. - -> UseLogFile -- ^ File to log output to (if any) + -> Maybe FilePath + -- ^ Directory to change to before starting the installation. + -> UseLogFile + -- ^ File to log output to (if any) -> IO BuildOutcome -installUnpackedPackage verbosity installLock numJobs - scriptOptions - configFlags installFlags haddockFlags testFlags comp progdb - platform pkg rpkg pkgoverride workingDir useLogFile = do - -- Override the .cabal file if necessary - case pkgoverride of - Nothing -> return () - Just pkgtxt -> do - let descFilePath = fromMaybe "." workingDir - prettyShow (packageName pkgid) <.> "cabal" - info verbosity $ - "Updating " ++ prettyShow (packageName pkgid) <.> "cabal" - ++ " with the latest revision from the index." - writeFileAtomic descFilePath pkgtxt - - -- 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 - -- Filter out flags not supported by the old versions of the Cabal lib. - let configureFlags :: Version -> ConfigFlags - configureFlags = filterConfigureFlags configFlags' { - configVerbosity = toFlag verbosity' - } - - -- Path to the optional log file. - mLogPath <- maybeLogPath - - logDirChange (maybe (const (return ())) appendFile mLogPath) workingDir $ do - -- Configure phase - onFailure ConfigureFailed $ do - noticeProgress ProgressStarting - setup configureCommand configureFlags mLogPath - - -- Build phase - onFailure BuildFailed $ do - noticeProgress ProgressBuilding - setup buildCommand' buildFlags mLogPath - - -- Doc generation phase - docsResult <- if shouldHaddock - then (do setup haddockCommand haddockFlags' mLogPath - return DocsOk) - `catchIO` (\_ -> return DocsFailed) - `catchExit` (\_ -> return DocsFailed) - else return DocsNotTried - - -- Tests phase - onFailure TestsFailed $ do - when (testsEnabled && PackageDescription.hasTests pkg) $ - setup Cabal.testCommand testFlags' mLogPath +installUnpackedPackage + verbosity + installLock + numJobs + scriptOptions + configFlags + installFlags + haddockFlags + testFlags + comp + progdb + platform + pkg + rpkg + pkgoverride + workingDir + useLogFile = do + -- Override the .cabal file if necessary + case pkgoverride of + Nothing -> return () + Just pkgtxt -> do + let descFilePath = + fromMaybe "." workingDir + prettyShow (packageName pkgid) + <.> "cabal" + info verbosity $ + "Updating " + ++ prettyShow (packageName pkgid) <.> "cabal" + ++ " with the latest revision from the index." + writeFileAtomic descFilePath pkgtxt + + -- 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 + -- Filter out flags not supported by the old versions of the Cabal lib. + let configureFlags :: Version -> ConfigFlags + configureFlags = + filterConfigureFlags + configFlags' + { configVerbosity = toFlag verbosity' + } - let testsResult | testsEnabled = TestsOk - | otherwise = TestsNotTried - - -- Install phase - onFailure InstallFailed $ criticalSection installLock $ do - -- Actual installation - withWin32SelfUpgrade verbosity uid configFlags - cinfo platform pkg $ do - setup Cabal.copyCommand copyFlags mLogPath - - -- Capture installed package configuration file, so that - -- it can be incorporated into the final InstallPlan - ipkgs <- genPkgConfs mLogPath - let ipkgs' = case ipkgs of - [ipkg] -> [ipkg { Installed.installedUnitId = uid }] - _ -> ipkgs - let packageDBs = interpretPackageDbFlags - (fromFlag (configUserInstall configFlags)) - (configPackageDBs configFlags) - for_ ipkgs' $ \ipkg' -> - registerPackage verbosity comp progdb - packageDBs ipkg' - defaultRegisterOptions - - return (Right (BuildResult docsResult testsResult (find ((==uid).installedUnitId) ipkgs'))) + -- Path to the optional log file. + mLogPath <- maybeLogPath + + logDirChange (maybe (const (return ())) appendFile mLogPath) workingDir $ do + -- Configure phase + onFailure ConfigureFailed $ do + noticeProgress ProgressStarting + setup configureCommand configureFlags mLogPath + + -- Build phase + onFailure BuildFailed $ do + noticeProgress ProgressBuilding + setup buildCommand' buildFlags mLogPath + + -- Doc generation phase + docsResult <- + if shouldHaddock + then + ( do + setup haddockCommand haddockFlags' mLogPath + return DocsOk + ) + `catchIO` (\_ -> return DocsFailed) + `catchExit` (\_ -> return DocsFailed) + else return DocsNotTried + + -- Tests phase + onFailure TestsFailed $ do + when (testsEnabled && PackageDescription.hasTests pkg) $ + setup Cabal.testCommand testFlags' mLogPath - where - pkgid = packageId pkg - uid = installedUnitId rpkg - cinfo = compilerInfo comp - buildCommand' = buildCommand progdb - dispname = prettyShow pkgid - isParallelBuild = numJobs >= 2 - - 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 - - addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags - addDefaultInstallDirs configFlags' = do - defInstallDirs <- InstallDirs.defaultInstallDirs flavor userInstall False - return $ configFlags' { - configInstallDirs = fmap Cabal.Flag . - InstallDirs.substituteInstallDirTemplates env $ - InstallDirs.combineInstallDirs fromFlagOrDefault - defInstallDirs (configInstallDirs configFlags) + let testsResult + | testsEnabled = TestsOk + | otherwise = TestsNotTried + + -- Install phase + onFailure InstallFailed $ criticalSection installLock $ do + -- Actual installation + withWin32SelfUpgrade + verbosity + uid + configFlags + cinfo + platform + pkg + $ do + setup Cabal.copyCommand copyFlags mLogPath + + -- Capture installed package configuration file, so that + -- it can be incorporated into the final InstallPlan + ipkgs <- genPkgConfs mLogPath + let ipkgs' = case ipkgs of + [ipkg] -> [ipkg{Installed.installedUnitId = uid}] + _ -> ipkgs + let packageDBs = + interpretPackageDbFlags + (fromFlag (configUserInstall configFlags)) + (configPackageDBs configFlags) + for_ ipkgs' $ \ipkg' -> + registerPackage + verbosity + comp + progdb + packageDBs + ipkg' + defaultRegisterOptions + + return (Right (BuildResult docsResult testsResult (find ((== uid) . installedUnitId) ipkgs'))) + where + pkgid = packageId pkg + uid = installedUnitId rpkg + cinfo = compilerInfo comp + buildCommand' = buildCommand progdb + dispname = prettyShow pkgid + isParallelBuild = numJobs >= 2 + + 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 + + addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags + addDefaultInstallDirs configFlags' = do + defInstallDirs <- InstallDirs.defaultInstallDirs flavor userInstall False + return $ + configFlags' + { configInstallDirs = + fmap Cabal.Flag + . InstallDirs.substituteInstallDirTemplates env + $ InstallDirs.combineInstallDirs + fromFlagOrDefault + defInstallDirs + (configInstallDirs configFlags) + } where CompilerId flavor _ = compilerInfoId cinfo - env = initialPathTemplateEnv pkgid uid cinfo platform - userInstall = fromFlagOrDefault defaultUserInstall - (configUserInstall configFlags') - - genPkgConfs :: 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 - -- Sort so that each prefix of the package - -- configurations is well formed - then traverse (readPkgConf pkgConfDest) . sort . filter notHidden + env = initialPathTemplateEnv pkgid uid cinfo platform + userInstall = + fromFlagOrDefault + defaultUserInstall + (configUserInstall configFlags') + + genPkgConfs + :: 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 + + traverse (readPkgConf pkgConfDest) . sort . filter notHidden =<< getDirectoryContents pkgConfDest - else fmap (:[]) $ readPkgConf "." pkgConfDest - else return [] - - readPkgConf :: FilePath -> FilePath - -> IO Installed.InstalledPackageInfo - readPkgConf pkgConfDir pkgConfFile = do - pkgConfText <- BS.readFile (pkgConfDir pkgConfFile) - case Installed.parseInstalledPackageInfo pkgConfText of - Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors - Right (warns, pkgConf) -> do - unless (null warns) $ - warn verbosity $ unlines warns - return pkgConf - - pkgConfParseFailed :: String -> IO a - pkgConfParseFailed perror = - die' verbosity $ "Couldn't parse the output of 'setup register --gen-pkg-config':" + else fmap (: []) $ readPkgConf "." pkgConfDest + else return [] + + readPkgConf + :: FilePath + -> FilePath + -> IO Installed.InstalledPackageInfo + readPkgConf pkgConfDir pkgConfFile = do + pkgConfText <- BS.readFile (pkgConfDir pkgConfFile) + case Installed.parseInstalledPackageInfo pkgConfText of + Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors + Right (warns, pkgConf) -> do + unless (null warns) $ + warn verbosity $ + unlines warns + return pkgConf + + pkgConfParseFailed :: String -> IO a + pkgConfParseFailed perror = + die' verbosity $ + "Couldn't parse the output of 'setup register --gen-pkg-config':" ++ show perror - maybeLogPath :: IO (Maybe FilePath) - maybeLogPath = - case useLogFile of - Nothing -> return Nothing - Just (mkLogFileName, _) -> do - let logFileName = mkLogFileName (packageId pkg) uid - logDir = takeDirectory logFileName - unless (null logDir) $ createDirectoryIfMissing True logDir - logFileExists <- doesFileExist logFileName - when logFileExists $ removeFile logFileName - return (Just logFileName) - - setup cmd flags mLogPath = - Exception.bracket - (traverse (\path -> openFile path AppendMode) mLogPath) - (traverse_ hClose) - (\logFileHandle -> - setupWrapper verbosity - scriptOptions { useLoggingHandle = logFileHandle - , useWorkingDir = workingDir } - (Just pkg) - cmd flags (const [])) - + maybeLogPath :: IO (Maybe FilePath) + maybeLogPath = + case useLogFile of + Nothing -> return Nothing + Just (mkLogFileName, _) -> do + let logFileName = mkLogFileName (packageId pkg) uid + logDir = takeDirectory logFileName + unless (null logDir) $ createDirectoryIfMissing True logDir + logFileExists <- doesFileExist logFileName + when logFileExists $ removeFile logFileName + return (Just logFileName) + + setup cmd flags mLogPath = + Exception.bracket + (traverse (\path -> openFile path AppendMode) mLogPath) + (traverse_ hClose) + ( \logFileHandle -> + setupWrapper + verbosity + scriptOptions + { useLoggingHandle = logFileHandle + , useWorkingDir = workingDir + } + (Just pkg) + cmd + flags + (const []) + ) -- helper onFailure :: (SomeException -> BuildFailure) -> IO BuildOutcome -> IO BuildOutcome onFailure result action = - action `catches` - [ Handler $ \ioe -> handler (ioe :: IOException) - , Handler $ \exit -> handler (exit :: ExitCode) - ] + action + `catches` [ Handler $ \ioe -> handler (ioe :: IOException) + , Handler $ \exit -> handler (exit :: ExitCode) + ] where handler :: Exception e => e -> IO BuildOutcome handler = return . Left . result . toException - -- ------------------------------------------------------------ + -- * Weird windows hacks + -- ------------------------------------------------------------ -withWin32SelfUpgrade :: Verbosity - -> UnitId - -> ConfigFlags - -> CompilerInfo - -> Platform - -> PackageDescription - -> IO a -> IO a +withWin32SelfUpgrade + :: Verbosity + -> UnitId + -> ConfigFlags + -> CompilerInfo + -> Platform + -> PackageDescription + -> IO a + -> IO a withWin32SelfUpgrade _ _ _ _ _ _ action | buildOS /= Windows = action withWin32SelfUpgrade verbosity uid configFlags cinfo platform pkg action = do - - defaultDirs <- InstallDirs.defaultInstallDirs - compFlavor - (fromFlag (configUserInstall configFlags)) - (PackageDescription.hasLibs pkg) - - Win32SelfUpgrade.possibleSelfUpgrade verbosity - (exeInstallPaths defaultDirs) action - + defaultDirs <- + InstallDirs.defaultInstallDirs + compFlavor + (fromFlag (configUserInstall configFlags)) + (PackageDescription.hasLibs pkg) + + Win32SelfUpgrade.possibleSelfUpgrade + verbosity + (exeInstallPaths defaultDirs) + action where pkgid = packageId pkg (CompilerId compFlavor _) = compilerInfoId cinfo @@ -1552,19 +2132,33 @@ withWin32SelfUpgrade verbosity uid configFlags cinfo platform pkg action = do | exe <- PackageDescription.executables pkg , PackageDescription.buildable (PackageDescription.buildInfo exe) , let exeName = prefix ++ prettyShow (PackageDescription.exeName exe) ++ suffix - prefix = substTemplate prefixTemplate - suffix = substTemplate suffixTemplate ] + prefix = substTemplate prefixTemplate + suffix = substTemplate suffixTemplate + ] where fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "") prefixTemplate = fromFlagTemplate (configProgPrefix configFlags) suffixTemplate = fromFlagTemplate (configProgSuffix configFlags) - templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault - defaultDirs (configInstallDirs configFlags) - absoluteDirs = InstallDirs.absoluteInstallDirs - pkgid uid - cinfo InstallDirs.NoCopyDest - platform templateDirs - substTemplate = InstallDirs.fromPathTemplate - . InstallDirs.substPathTemplate env - where env = InstallDirs.initialPathTemplateEnv pkgid uid - cinfo platform + templateDirs = + InstallDirs.combineInstallDirs + fromFlagOrDefault + defaultDirs + (configInstallDirs configFlags) + absoluteDirs = + InstallDirs.absoluteInstallDirs + pkgid + uid + cinfo + InstallDirs.NoCopyDest + platform + templateDirs + substTemplate = + InstallDirs.fromPathTemplate + . InstallDirs.substPathTemplate env + where + env = + InstallDirs.initialPathTemplateEnv + pkgid + uid + cinfo + platform diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs index 9b8fa6cba0c..0d872579e87 100644 --- a/cabal-install/src/Distribution/Client/InstallPlan.hs +++ b/cabal-install/src/Distribution/Client/InstallPlan.hs @@ -1,11 +1,15 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.InstallPlan -- Copyright : (c) Duncan Coutts 2008 @@ -16,96 +20,99 @@ -- Portability : portable -- -- Package installation plan --- ------------------------------------------------------------------------------ -module Distribution.Client.InstallPlan ( - InstallPlan, - GenericInstallPlan, - PlanPackage, - GenericPlanPackage(..), - foldPlanPackage, - IsUnit, - - -- * Operations on 'InstallPlan's - new, - toGraph, - toList, - toMap, - keys, - keysSet, - planIndepGoals, - depends, - - fromSolverInstallPlan, - fromSolverInstallPlanWithProgress, - configureInstallPlan, - remove, - installed, - lookup, - directDeps, - revDirectDeps, - - -- * Traversal - executionOrder, - execute, - BuildOutcomes, - lookupBuildOutcome, - -- ** Traversal helpers - -- $traversal - Processing, - ready, - completed, - failed, - - -- * Display - showPlanGraph, - showInstallPlan, - - -- * Graph-like operations - dependencyClosure, - reverseTopologicalOrder, - reverseDependencyClosure, +module Distribution.Client.InstallPlan + ( InstallPlan + , GenericInstallPlan + , PlanPackage + , GenericPlanPackage (..) + , foldPlanPackage + , IsUnit + + -- * Operations on 'InstallPlan's + , new + , toGraph + , toList + , toMap + , keys + , keysSet + , planIndepGoals + , depends + , fromSolverInstallPlan + , fromSolverInstallPlanWithProgress + , configureInstallPlan + , remove + , installed + , lookup + , directDeps + , revDirectDeps + + -- * Traversal + , executionOrder + , execute + , BuildOutcomes + , lookupBuildOutcome + + -- ** Traversal helpers + -- $traversal + , Processing + , ready + , completed + , failed + + -- * Display + , showPlanGraph + , showInstallPlan + + -- * Graph-like operations + , dependencyClosure + , reverseTopologicalOrder + , reverseDependencyClosure ) where -import Distribution.Client.Compat.Prelude hiding (toList, lookup, tail) -import Prelude (tail) +import Distribution.Client.Compat.Prelude hiding (lookup, tail, toList) import Distribution.Compat.Stack (WithCallStack) +import Prelude (tail) import Distribution.Client.Types hiding (BuildOutcomes) import qualified Distribution.PackageDescription as PD import qualified Distribution.Simple.Configure as Configure import qualified Distribution.Simple.Setup as Cabal +import Distribution.Client.JobControl +import Distribution.Client.SolverInstallPlan (SolverInstallPlan) +import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) + ( InstalledPackageInfo + ) import Distribution.Package - ( Package(..), HasMungedPackageId(..) - , HasUnitId(..), UnitId ) -import Distribution.Solver.Types.SolverPackage -import Distribution.Client.JobControl + ( HasMungedPackageId (..) + , HasUnitId (..) + , Package (..) + , UnitId + ) import Distribution.Pretty (defaultStyle) +import Distribution.Solver.Types.SolverPackage import Text.PrettyPrint -import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan -import Distribution.Client.SolverInstallPlan (SolverInstallPlan) import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.SolverId -import Distribution.Solver.Types.InstSolverPackage +import Distribution.Solver.Types.InstSolverPackage +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.SolverId -import Distribution.Utils.LogProgress -import Distribution.Utils.Structured (Structured (..), Structure(Nominal)) +import Distribution.Utils.LogProgress +import Distribution.Utils.Structured (Structure (Nominal), Structured (..)) -- TODO: Need this when we compute final UnitIds -- import qualified Distribution.Simple.Configure as Configure -import qualified Data.Foldable as Foldable (all, toList) -import qualified Distribution.Compat.Graph as Graph -import Distribution.Compat.Graph (Graph, IsNode(..)) import Control.Exception - ( assert ) + ( assert + ) +import qualified Data.Foldable as Foldable (all, toList) import qualified Data.Map as Map import qualified Data.Set as Set +import Distribution.Compat.Graph (Graph, IsNode (..)) +import qualified Distribution.Compat.Graph as Graph -- When cabal tries to install a number of packages, including all their -- dependencies it has a non-trivial problem to solve. @@ -161,27 +168,28 @@ import qualified Data.Set as Set -- to get this wrong (and, for instance, call graph traversal functions from -- Cabal rather than from cabal-install). Instead, see 'PackageInstalled'. data GenericPlanPackage ipkg srcpkg - = PreExisting ipkg - | Configured srcpkg - | Installed srcpkg + = PreExisting ipkg + | Configured srcpkg + | Installed srcpkg deriving (Eq, Show, Generic) displayGenericPlanPackage :: (IsUnit ipkg, IsUnit srcpkg) => GenericPlanPackage ipkg srcpkg -> String displayGenericPlanPackage (PreExisting pkg) = "PreExisting " ++ prettyShow (nodeKey pkg) -displayGenericPlanPackage (Configured pkg) = "Configured " ++ prettyShow (nodeKey pkg) -displayGenericPlanPackage (Installed pkg) = "Installed " ++ prettyShow (nodeKey pkg) +displayGenericPlanPackage (Configured pkg) = "Configured " ++ prettyShow (nodeKey pkg) +displayGenericPlanPackage (Installed pkg) = "Installed " ++ prettyShow (nodeKey pkg) -- | Convenience combinator for destructing 'GenericPlanPackage'. -- This is handy because if you case manually, you have to handle -- 'Configured' and 'Installed' separately (where often you want -- them to be the same.) -foldPlanPackage :: (ipkg -> a) - -> (srcpkg -> a) - -> GenericPlanPackage ipkg srcpkg - -> a -foldPlanPackage f _ (PreExisting ipkg) = f ipkg +foldPlanPackage + :: (ipkg -> a) + -> (srcpkg -> a) + -> GenericPlanPackage ipkg srcpkg + -> a +foldPlanPackage f _ (PreExisting ipkg) = f ipkg foldPlanPackage _ g (Configured srcpkg) = g srcpkg -foldPlanPackage _ g (Installed srcpkg) = g srcpkg +foldPlanPackage _ g (Installed srcpkg) = g srcpkg type IsUnit a = (IsNode a, Key a ~ UnitId) @@ -190,133 +198,183 @@ depends = nodeNeighbors -- NB: Expanded constraint synonym here to avoid undecidable -- instance errors in GHC 7.8 and earlier. -instance (IsNode ipkg, IsNode srcpkg, Key ipkg ~ UnitId, Key srcpkg ~ UnitId) - => IsNode (GenericPlanPackage ipkg srcpkg) where - type Key (GenericPlanPackage ipkg srcpkg) = UnitId - nodeKey (PreExisting ipkg) = nodeKey ipkg - nodeKey (Configured spkg) = nodeKey spkg - nodeKey (Installed spkg) = nodeKey spkg - nodeNeighbors (PreExisting ipkg) = nodeNeighbors ipkg - nodeNeighbors (Configured spkg) = nodeNeighbors spkg - nodeNeighbors (Installed spkg) = nodeNeighbors spkg +instance + (IsNode ipkg, IsNode srcpkg, Key ipkg ~ UnitId, Key srcpkg ~ UnitId) + => IsNode (GenericPlanPackage ipkg srcpkg) + where + type Key (GenericPlanPackage ipkg srcpkg) = UnitId + nodeKey (PreExisting ipkg) = nodeKey ipkg + nodeKey (Configured spkg) = nodeKey spkg + nodeKey (Installed spkg) = nodeKey spkg + nodeNeighbors (PreExisting ipkg) = nodeNeighbors ipkg + nodeNeighbors (Configured spkg) = nodeNeighbors spkg + nodeNeighbors (Installed spkg) = nodeNeighbors spkg instance (Binary ipkg, Binary srcpkg) => Binary (GenericPlanPackage ipkg srcpkg) instance (Structured ipkg, Structured srcpkg) => Structured (GenericPlanPackage ipkg srcpkg) -type PlanPackage = GenericPlanPackage - InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc) +type PlanPackage = + GenericPlanPackage + InstalledPackageInfo + (ConfiguredPackage UnresolvedPkgLoc) -instance (Package ipkg, Package srcpkg) => - Package (GenericPlanPackage ipkg srcpkg) where - packageId (PreExisting ipkg) = packageId ipkg - packageId (Configured spkg) = packageId spkg - packageId (Installed spkg) = packageId spkg - -instance (HasMungedPackageId ipkg, HasMungedPackageId srcpkg) => - HasMungedPackageId (GenericPlanPackage ipkg srcpkg) where - mungedId (PreExisting ipkg) = mungedId ipkg - mungedId (Configured spkg) = mungedId spkg - mungedId (Installed spkg) = mungedId spkg +instance + (Package ipkg, Package srcpkg) + => Package (GenericPlanPackage ipkg srcpkg) + where + packageId (PreExisting ipkg) = packageId ipkg + packageId (Configured spkg) = packageId spkg + packageId (Installed spkg) = packageId spkg -instance (HasUnitId ipkg, HasUnitId srcpkg) => - HasUnitId - (GenericPlanPackage ipkg srcpkg) where +instance + (HasMungedPackageId ipkg, HasMungedPackageId srcpkg) + => HasMungedPackageId (GenericPlanPackage ipkg srcpkg) + where + mungedId (PreExisting ipkg) = mungedId ipkg + mungedId (Configured spkg) = mungedId spkg + mungedId (Installed spkg) = mungedId spkg + +instance + (HasUnitId ipkg, HasUnitId srcpkg) + => HasUnitId + (GenericPlanPackage ipkg srcpkg) + where installedUnitId (PreExisting ipkg) = installedUnitId ipkg - installedUnitId (Configured spkg) = installedUnitId spkg - installedUnitId (Installed spkg) = installedUnitId spkg - -instance (HasConfiguredId ipkg, HasConfiguredId srcpkg) => - HasConfiguredId (GenericPlanPackage ipkg srcpkg) where - configuredId (PreExisting ipkg) = configuredId ipkg - configuredId (Configured spkg) = configuredId spkg - configuredId (Installed spkg) = configuredId spkg - -data GenericInstallPlan ipkg srcpkg = GenericInstallPlan { - planGraph :: !(Graph (GenericPlanPackage ipkg srcpkg)), - planIndepGoals :: !IndependentGoals + installedUnitId (Configured spkg) = installedUnitId spkg + installedUnitId (Installed spkg) = installedUnitId spkg + +instance + (HasConfiguredId ipkg, HasConfiguredId srcpkg) + => HasConfiguredId (GenericPlanPackage ipkg srcpkg) + where + configuredId (PreExisting ipkg) = configuredId ipkg + configuredId (Configured spkg) = configuredId spkg + configuredId (Installed spkg) = configuredId spkg + +data GenericInstallPlan ipkg srcpkg = GenericInstallPlan + { planGraph :: !(Graph (GenericPlanPackage ipkg srcpkg)) + , planIndepGoals :: !IndependentGoals } deriving (Typeable) -- | 'GenericInstallPlan' specialised to most commonly used types. -type InstallPlan = GenericInstallPlan - InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc) +type InstallPlan = + GenericInstallPlan + InstalledPackageInfo + (ConfiguredPackage UnresolvedPkgLoc) -- | Smart constructor that deals with caching the 'Graph' representation. --- -mkInstallPlan :: (IsUnit ipkg, IsUnit srcpkg) - => String - -> Graph (GenericPlanPackage ipkg srcpkg) - -> IndependentGoals - -> GenericInstallPlan ipkg srcpkg +mkInstallPlan + :: (IsUnit ipkg, IsUnit srcpkg) + => String + -> Graph (GenericPlanPackage ipkg srcpkg) + -> IndependentGoals + -> GenericInstallPlan ipkg srcpkg mkInstallPlan loc graph indepGoals = - assert (valid loc graph) - GenericInstallPlan { - planGraph = graph, - planIndepGoals = indepGoals - } + assert + (valid loc graph) + GenericInstallPlan + { planGraph = graph + , planIndepGoals = indepGoals + } internalError :: WithCallStack (String -> String -> a) -internalError loc msg = error $ "internal error in InstallPlan." ++ loc - ++ if null msg then "" else ": " ++ msg +internalError loc msg = + error $ + "internal error in InstallPlan." + ++ loc + ++ if null msg then "" else ": " ++ msg instance (Structured ipkg, Structured srcpkg) => Structured (GenericInstallPlan ipkg srcpkg) where - structure p = Nominal (typeRep p) 0 "GenericInstallPlan" - [ structure (Proxy :: Proxy ipkg) - , structure (Proxy :: Proxy srcpkg) - ] - -instance (IsNode ipkg, Key ipkg ~ UnitId, IsNode srcpkg, Key srcpkg ~ UnitId, - Binary ipkg, Binary srcpkg) - => Binary (GenericInstallPlan ipkg srcpkg) where - put GenericInstallPlan { - planGraph = graph, - planIndepGoals = indepGoals - } = put graph >> put indepGoals - - get = do - graph <- get - indepGoals <- get - return $! mkInstallPlan "(instance Binary)" graph indepGoals - -showPlanGraph :: (Package ipkg, Package srcpkg, - IsUnit ipkg, IsUnit srcpkg) - => Graph (GenericPlanPackage ipkg srcpkg) -> String -showPlanGraph graph = renderStyle defaultStyle $ + structure p = + Nominal + (typeRep p) + 0 + "GenericInstallPlan" + [ structure (Proxy :: Proxy ipkg) + , structure (Proxy :: Proxy srcpkg) + ] + +instance + ( IsNode ipkg + , Key ipkg ~ UnitId + , IsNode srcpkg + , Key srcpkg ~ UnitId + , Binary ipkg + , Binary srcpkg + ) + => Binary (GenericInstallPlan ipkg srcpkg) + where + put + GenericInstallPlan + { planGraph = graph + , planIndepGoals = indepGoals + } = put graph >> put indepGoals + + get = do + graph <- get + indepGoals <- get + return $! mkInstallPlan "(instance Binary)" graph indepGoals + +showPlanGraph + :: ( Package ipkg + , Package srcpkg + , IsUnit ipkg + , IsUnit srcpkg + ) + => Graph (GenericPlanPackage ipkg srcpkg) + -> String +showPlanGraph graph = + renderStyle defaultStyle $ vcat (map dispPlanPackage (Foldable.toList graph)) - where dispPlanPackage p = - hang (hsep [ text (showPlanPackageTag p) - , pretty (packageId p) - , parens (pretty (nodeKey p))]) 2 - (vcat (map pretty (nodeNeighbors p))) - -showInstallPlan :: (Package ipkg, Package srcpkg, - IsUnit ipkg, IsUnit srcpkg) - => GenericInstallPlan ipkg srcpkg -> String + where + dispPlanPackage p = + hang + ( hsep + [ text (showPlanPackageTag p) + , pretty (packageId p) + , parens (pretty (nodeKey p)) + ] + ) + 2 + (vcat (map pretty (nodeNeighbors p))) + +showInstallPlan + :: ( Package ipkg + , Package srcpkg + , IsUnit ipkg + , IsUnit srcpkg + ) + => GenericInstallPlan ipkg srcpkg + -> String showInstallPlan = showPlanGraph . planGraph showPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> String -showPlanPackageTag (PreExisting _) = "PreExisting" -showPlanPackageTag (Configured _) = "Configured" -showPlanPackageTag (Installed _) = "Installed" +showPlanPackageTag (PreExisting _) = "PreExisting" +showPlanPackageTag (Configured _) = "Configured" +showPlanPackageTag (Installed _) = "Installed" -- | Build an installation plan from a valid set of resolved packages. --- -new :: (IsUnit ipkg, IsUnit srcpkg) - => IndependentGoals - -> Graph (GenericPlanPackage ipkg srcpkg) - -> GenericInstallPlan ipkg srcpkg +new + :: (IsUnit ipkg, IsUnit srcpkg) + => IndependentGoals + -> Graph (GenericPlanPackage ipkg srcpkg) + -> GenericInstallPlan ipkg srcpkg new indepGoals graph = mkInstallPlan "new" graph indepGoals -toGraph :: GenericInstallPlan ipkg srcpkg - -> Graph (GenericPlanPackage ipkg srcpkg) +toGraph + :: GenericInstallPlan ipkg srcpkg + -> Graph (GenericPlanPackage ipkg srcpkg) toGraph = planGraph -toList :: GenericInstallPlan ipkg srcpkg - -> [GenericPlanPackage ipkg srcpkg] +toList + :: GenericInstallPlan ipkg srcpkg + -> [GenericPlanPackage ipkg srcpkg] toList = Foldable.toList . planGraph -toMap :: GenericInstallPlan ipkg srcpkg - -> Map UnitId (GenericPlanPackage ipkg srcpkg) +toMap + :: GenericInstallPlan ipkg srcpkg + -> Map UnitId (GenericPlanPackage ipkg srcpkg) toMap = Graph.toMap . planGraph keys :: GenericInstallPlan ipkg srcpkg -> [UnitId] @@ -330,70 +388,74 @@ keysSet = Graph.keysSet . planGraph -- package. This is primarily useful for obtaining an install plan for -- the dependencies of a package or set of packages without actually -- installing the package itself, as when doing development. --- -remove :: (IsUnit ipkg, IsUnit srcpkg) - => (GenericPlanPackage ipkg srcpkg -> Bool) - -> GenericInstallPlan ipkg srcpkg - -> GenericInstallPlan ipkg srcpkg +remove + :: (IsUnit ipkg, IsUnit srcpkg) + => (GenericPlanPackage ipkg srcpkg -> Bool) + -> GenericInstallPlan ipkg srcpkg + -> GenericInstallPlan ipkg srcpkg remove shouldRemove plan = - mkInstallPlan "remove" newGraph (planIndepGoals plan) + mkInstallPlan "remove" newGraph (planIndepGoals plan) where - newGraph = Graph.fromDistinctList $ - filter (not . shouldRemove) (toList plan) + newGraph = + Graph.fromDistinctList $ + filter (not . shouldRemove) (toList plan) -- | Change a number of packages in the 'Configured' state to the 'Installed' -- state. -- -- To preserve invariants, the package must have all of its dependencies -- already installed too (that is 'PreExisting' or 'Installed'). --- -installed :: (IsUnit ipkg, IsUnit srcpkg) - => (srcpkg -> Bool) - -> GenericInstallPlan ipkg srcpkg - -> GenericInstallPlan ipkg srcpkg +installed + :: (IsUnit ipkg, IsUnit srcpkg) + => (srcpkg -> Bool) + -> GenericInstallPlan ipkg srcpkg + -> GenericInstallPlan ipkg srcpkg installed shouldBeInstalled installPlan = - foldl' markInstalled installPlan - [ pkg - | Configured pkg <- reverseTopologicalOrder installPlan - , shouldBeInstalled pkg ] + foldl' + markInstalled + installPlan + [ pkg + | Configured pkg <- reverseTopologicalOrder installPlan + , shouldBeInstalled pkg + ] where markInstalled plan pkg = assert (all isInstalled (directDeps plan (nodeKey pkg))) $ - plan { - planGraph = Graph.insert (Installed pkg) (planGraph plan) - } + plan + { planGraph = Graph.insert (Installed pkg) (planGraph plan) + } -- | Lookup a package in the plan. --- -lookup :: (IsUnit ipkg, IsUnit srcpkg) - => GenericInstallPlan ipkg srcpkg - -> UnitId - -> Maybe (GenericPlanPackage ipkg srcpkg) +lookup + :: (IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg + -> UnitId + -> Maybe (GenericPlanPackage ipkg srcpkg) lookup plan pkgid = Graph.lookup pkgid (planGraph plan) -- | Find all the direct dependencies of the given package. -- -- Note that the package must exist in the plan or it is an error. --- -directDeps :: GenericInstallPlan ipkg srcpkg - -> UnitId - -> [GenericPlanPackage ipkg srcpkg] +directDeps + :: GenericInstallPlan ipkg srcpkg + -> UnitId + -> [GenericPlanPackage ipkg srcpkg] directDeps plan pkgid = case Graph.neighbors (planGraph plan) pkgid of Just deps -> deps - Nothing -> internalError "directDeps" "package not in graph" + Nothing -> internalError "directDeps" "package not in graph" -- | Find all the direct reverse dependencies of the given package. -- -- Note that the package must exist in the plan or it is an error. --- -revDirectDeps :: GenericInstallPlan ipkg srcpkg - -> UnitId - -> [GenericPlanPackage ipkg srcpkg] +revDirectDeps + :: GenericInstallPlan ipkg srcpkg + -> UnitId + -> [GenericPlanPackage ipkg srcpkg] revDirectDeps plan pkgid = case Graph.revNeighbors (planGraph plan) pkgid of Just deps -> deps - Nothing -> internalError "revDirectDeps" "package not in graph" + Nothing -> internalError "revDirectDeps" "package not in graph" -- | Return all the packages in the 'InstallPlan' in reverse topological order. -- That is, for each package, all dependencies of the package appear first. @@ -402,30 +464,30 @@ revDirectDeps plan pkgid = -- source packages rather than just the source ones. Also, while both this -- and 'executionOrder' produce reverse topological orderings of the package -- dependency graph, it is not necessarily exactly the same order. --- -reverseTopologicalOrder :: GenericInstallPlan ipkg srcpkg - -> [GenericPlanPackage ipkg srcpkg] +reverseTopologicalOrder + :: GenericInstallPlan ipkg srcpkg + -> [GenericPlanPackage ipkg srcpkg] reverseTopologicalOrder plan = Graph.revTopSort (planGraph plan) - -- | Return the packages in the plan that are direct or indirect dependencies of -- the given packages. --- -dependencyClosure :: GenericInstallPlan ipkg srcpkg - -> [UnitId] - -> [GenericPlanPackage ipkg srcpkg] -dependencyClosure plan = fromMaybe [] - . Graph.closure (planGraph plan) +dependencyClosure + :: GenericInstallPlan ipkg srcpkg + -> [UnitId] + -> [GenericPlanPackage ipkg srcpkg] +dependencyClosure plan = + fromMaybe [] + . Graph.closure (planGraph plan) -- | Return the packages in the plan that depend directly or indirectly on the -- given packages. --- -reverseDependencyClosure :: GenericInstallPlan ipkg srcpkg - -> [UnitId] - -> [GenericPlanPackage ipkg srcpkg] -reverseDependencyClosure plan = fromMaybe [] - . Graph.revClosure (planGraph plan) - +reverseDependencyClosure + :: GenericInstallPlan ipkg srcpkg + -> [UnitId] + -> [GenericPlanPackage ipkg srcpkg] +reverseDependencyClosure plan = + fromMaybe [] + . Graph.revClosure (planGraph plan) -- Alert alert! Why does SolverId map to a LIST of plan packages? -- The sordid story has to do with 'build-depends' on a package @@ -440,112 +502,131 @@ reverseDependencyClosure plan = fromMaybe [] -- etc). This similarly implies we can't return a 'ConfiguredId' -- because that's not enough information. -fromSolverInstallPlan :: - (IsUnit ipkg, IsUnit srcpkg) - => ( (SolverId -> [GenericPlanPackage ipkg srcpkg]) - -> SolverInstallPlan.SolverPlanPackage - -> [GenericPlanPackage ipkg srcpkg] ) - -> SolverInstallPlan - -> GenericInstallPlan ipkg srcpkg +fromSolverInstallPlan + :: (IsUnit ipkg, IsUnit srcpkg) + => ( (SolverId -> [GenericPlanPackage ipkg srcpkg]) + -> SolverInstallPlan.SolverPlanPackage + -> [GenericPlanPackage ipkg srcpkg] + ) + -> SolverInstallPlan + -> GenericInstallPlan ipkg srcpkg fromSolverInstallPlan f plan = - mkInstallPlan "fromSolverInstallPlan" - (Graph.fromDistinctList pkgs'') - (SolverInstallPlan.planIndepGoals plan) + mkInstallPlan + "fromSolverInstallPlan" + (Graph.fromDistinctList pkgs'') + (SolverInstallPlan.planIndepGoals plan) where - (_, _, pkgs'') = foldl' f' (Map.empty, Map.empty, []) - (SolverInstallPlan.reverseTopologicalOrder plan) + (_, _, pkgs'') = + foldl' + f' + (Map.empty, Map.empty, []) + (SolverInstallPlan.reverseTopologicalOrder plan) f' (pidMap, ipiMap, pkgs) pkg = (pidMap', ipiMap', pkgs' ++ pkgs) where - pkgs' = f (mapDep pidMap ipiMap) pkg + pkgs' = f (mapDep pidMap ipiMap) pkg - (pidMap', ipiMap') - = case nodeKey pkg of + (pidMap', ipiMap') = + case nodeKey pkg of PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap) - PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap) + PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap) mapDep _ ipiMap (PreExistingId _pid uid) - | Just pkgs <- Map.lookup uid ipiMap = pkgs - | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid) + | Just pkgs <- Map.lookup uid ipiMap = pkgs + | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid) mapDep pidMap _ (PlannedId pid) - | Just pkgs <- Map.lookup pid pidMap = pkgs - | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid) - -- This shouldn't happen, since mapDep should only be called - -- on neighbor SolverId, which must have all been done already - -- by the reverse top-sort (we assume the graph is not broken). - - -fromSolverInstallPlanWithProgress :: - (IsUnit ipkg, IsUnit srcpkg) - => ( (SolverId -> [GenericPlanPackage ipkg srcpkg]) - -> SolverInstallPlan.SolverPlanPackage - -> LogProgress [GenericPlanPackage ipkg srcpkg] ) - -> SolverInstallPlan - -> LogProgress (GenericInstallPlan ipkg srcpkg) + | Just pkgs <- Map.lookup pid pidMap = pkgs + | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid) + +-- This shouldn't happen, since mapDep should only be called +-- on neighbor SolverId, which must have all been done already +-- by the reverse top-sort (we assume the graph is not broken). + +fromSolverInstallPlanWithProgress + :: (IsUnit ipkg, IsUnit srcpkg) + => ( (SolverId -> [GenericPlanPackage ipkg srcpkg]) + -> SolverInstallPlan.SolverPlanPackage + -> LogProgress [GenericPlanPackage ipkg srcpkg] + ) + -> SolverInstallPlan + -> LogProgress (GenericInstallPlan ipkg srcpkg) fromSolverInstallPlanWithProgress f plan = do - (_, _, pkgs'') <- foldM f' (Map.empty, Map.empty, []) - (SolverInstallPlan.reverseTopologicalOrder plan) - return $ mkInstallPlan "fromSolverInstallPlanWithProgress" - (Graph.fromDistinctList pkgs'') - (SolverInstallPlan.planIndepGoals plan) + (_, _, pkgs'') <- + foldM + f' + (Map.empty, Map.empty, []) + (SolverInstallPlan.reverseTopologicalOrder plan) + return $ + mkInstallPlan + "fromSolverInstallPlanWithProgress" + (Graph.fromDistinctList pkgs'') + (SolverInstallPlan.planIndepGoals plan) where f' (pidMap, ipiMap, pkgs) pkg = do - pkgs' <- f (mapDep pidMap ipiMap) pkg - let (pidMap', ipiMap') - = case nodeKey pkg of - PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap) - PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap) - return (pidMap', ipiMap', pkgs' ++ pkgs) + pkgs' <- f (mapDep pidMap ipiMap) pkg + let (pidMap', ipiMap') = + case nodeKey pkg of + PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap) + PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap) + return (pidMap', ipiMap', pkgs' ++ pkgs) mapDep _ ipiMap (PreExistingId _pid uid) - | Just pkgs <- Map.lookup uid ipiMap = pkgs - | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid) + | Just pkgs <- Map.lookup uid ipiMap = pkgs + | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid) mapDep pidMap _ (PlannedId pid) - | Just pkgs <- Map.lookup pid pidMap = pkgs - | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid) - -- This shouldn't happen, since mapDep should only be called - -- on neighbor SolverId, which must have all been done already - -- by the reverse top-sort (we assume the graph is not broken). + | Just pkgs <- Map.lookup pid pidMap = pkgs + | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid) + +-- This shouldn't happen, since mapDep should only be called +-- on neighbor SolverId, which must have all been done already +-- by the reverse top-sort (we assume the graph is not broken). -- | Conversion of 'SolverInstallPlan' to 'InstallPlan'. -- Similar to 'elaboratedInstallPlan' configureInstallPlan :: Cabal.ConfigFlags -> SolverInstallPlan -> InstallPlan configureInstallPlan configFlags solverPlan = - flip fromSolverInstallPlan solverPlan $ \mapDep planpkg -> - [case planpkg of + flip fromSolverInstallPlan solverPlan $ \mapDep planpkg -> + [ case planpkg of SolverInstallPlan.PreExisting pkg -> PreExisting (instSolverPkgIPI pkg) - - SolverInstallPlan.Configured pkg -> + SolverInstallPlan.Configured pkg -> Configured (configureSolverPackage mapDep pkg) - ] + ] where - configureSolverPackage :: (SolverId -> [PlanPackage]) - -> SolverPackage UnresolvedPkgLoc - -> ConfiguredPackage UnresolvedPkgLoc + configureSolverPackage + :: (SolverId -> [PlanPackage]) + -> SolverPackage UnresolvedPkgLoc + -> ConfiguredPackage UnresolvedPkgLoc configureSolverPackage mapDep spkg = - ConfiguredPackage { - confPkgId = Configure.computeComponentId - (Cabal.fromFlagOrDefault False - (Cabal.configDeterministic configFlags)) - Cabal.NoFlag - Cabal.NoFlag - (packageId spkg) - (PD.CLibName PD.LMainLibName) - (Just (map confInstId (CD.libraryDeps deps), - solverPkgFlags spkg)), - confPkgSource = solverPkgSource spkg, - confPkgFlags = solverPkgFlags spkg, - confPkgStanzas = solverPkgStanzas spkg, - confPkgDeps = deps + ConfiguredPackage + { confPkgId = + Configure.computeComponentId + ( Cabal.fromFlagOrDefault + False + (Cabal.configDeterministic configFlags) + ) + Cabal.NoFlag + Cabal.NoFlag + (packageId spkg) + (PD.CLibName PD.LMainLibName) + ( Just + ( map confInstId (CD.libraryDeps deps) + , solverPkgFlags spkg + ) + ) + , confPkgSource = solverPkgSource spkg + , confPkgFlags = solverPkgFlags spkg + , confPkgStanzas = solverPkgStanzas spkg + , confPkgDeps = deps -- NB: no support for executable dependencies - } + } where deps = fmap (concatMap (map configuredId . mapDep)) (solverPkgLibDeps spkg) - -- ------------------------------------------------------------ + -- * Primitives for traversing plans + -- ------------------------------------------------------------ -- $traversal @@ -580,14 +661,13 @@ configureInstallPlan configFlags solverPlan = -- other packages that depend on the failed package. In addition it returns -- the other failed packages. - -- | The 'Processing' type is used to keep track of the state of a traversal -- and includes the set of packages that are in the processing state, e.g. in -- the process of being installed, plus those that have been completed and -- those where processing failed. --- data Processing = Processing !(Set UnitId) !(Set UnitId) !(Set UnitId) - -- processing, completed, failed + +-- processing, completed, failed -- | The packages in the plan that are initially ready to be installed. -- That is they are in the configured state and have all their dependencies @@ -597,18 +677,18 @@ data Processing = Processing !(Set UnitId) !(Set UnitId) !(Set UnitId) -- a 'Processing' state containing those same packages. The assumption is that -- all the packages that are ready will now be processed and so we can consider -- them to be in the processing state. --- -ready :: (IsUnit ipkg, IsUnit srcpkg) - => GenericInstallPlan ipkg srcpkg - -> ([GenericReadyPackage srcpkg], Processing) +ready + :: (IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg + -> ([GenericReadyPackage srcpkg], Processing) ready plan = - assert (processingInvariant plan processing) $ + assert (processingInvariant plan processing) $ (readyPackages, processing) where !processing = Processing - (Set.fromList [ nodeKey pkg | pkg <- readyPackages ]) - (Set.fromList [ nodeKey pkg | pkg <- toList plan, isInstalled pkg ]) + (Set.fromList [nodeKey pkg | pkg <- readyPackages]) + (Set.fromList [nodeKey pkg | pkg <- toList plan, isInstalled pkg]) Set.empty readyPackages = [ ReadyPackage pkg @@ -617,88 +697,98 @@ ready plan = ] isInstalled :: GenericPlanPackage a b -> Bool -isInstalled (PreExisting {}) = True -isInstalled (Installed {}) = True -isInstalled _ = False +isInstalled (PreExisting{}) = True +isInstalled (Installed{}) = True +isInstalled _ = False -- | Given a package in the processing state, mark the package as completed -- and return any packages that are newly in the processing state (ie ready to -- process), along with the updated 'Processing' state. --- -completed :: forall ipkg srcpkg. (IsUnit ipkg, IsUnit srcpkg) - => GenericInstallPlan ipkg srcpkg - -> Processing -> UnitId - -> ([GenericReadyPackage srcpkg], Processing) +completed + :: forall ipkg srcpkg + . (IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg + -> Processing + -> UnitId + -> ([GenericReadyPackage srcpkg], Processing) completed plan (Processing processingSet completedSet failedSet) pkgid = - assert (pkgid `Set.member` processingSet) $ + assert (pkgid `Set.member` processingSet) $ assert (processingInvariant plan processing') $ - - ( map asReadyPackage newlyReady - , processing' ) + ( map asReadyPackage newlyReady + , processing' + ) where - completedSet' = Set.insert pkgid completedSet + completedSet' = Set.insert pkgid completedSet -- each direct reverse dep where all direct deps are completed - newlyReady = [ dep - | dep <- revDirectDeps plan pkgid - , all ((`Set.member` completedSet') . nodeKey) - (directDeps plan (nodeKey dep)) - ] + newlyReady = + [ dep + | dep <- revDirectDeps plan pkgid + , all + ((`Set.member` completedSet') . nodeKey) + (directDeps plan (nodeKey dep)) + ] - processingSet' = foldl' (flip Set.insert) - (Set.delete pkgid processingSet) - (map nodeKey newlyReady) - processing' = Processing processingSet' completedSet' failedSet + processingSet' = + foldl' + (flip Set.insert) + (Set.delete pkgid processingSet) + (map nodeKey newlyReady) + processing' = Processing processingSet' completedSet' failedSet asReadyPackage :: GenericPlanPackage ipkg srcpkg -> GenericReadyPackage srcpkg - asReadyPackage (Configured pkg) = ReadyPackage pkg + asReadyPackage (Configured pkg) = ReadyPackage pkg asReadyPackage pkg = internalError "completed" $ "not in configured state: " ++ displayGenericPlanPackage pkg -failed :: (IsUnit ipkg, IsUnit srcpkg) - => GenericInstallPlan ipkg srcpkg - -> Processing -> UnitId - -> ([srcpkg], Processing) +failed + :: (IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg + -> Processing + -> UnitId + -> ([srcpkg], Processing) failed plan (Processing processingSet completedSet failedSet) pkgid = - assert (pkgid `Set.member` processingSet) $ + assert (pkgid `Set.member` processingSet) $ assert (all (`Set.notMember` processingSet) (tail newlyFailedIds)) $ - assert (all (`Set.notMember` completedSet) (tail newlyFailedIds)) $ - -- but note that some newlyFailed may already be in the failed set - -- since one package can depend on two packages that both fail and - -- so would be in the rev-dep closure for both. - assert (processingInvariant plan processing') $ - - ( map asConfiguredPackage (tail newlyFailed) - , processing' ) + assert (all (`Set.notMember` completedSet) (tail newlyFailedIds)) $ + -- but note that some newlyFailed may already be in the failed set + -- since one package can depend on two packages that both fail and + -- so would be in the rev-dep closure for both. + assert (processingInvariant plan processing') $ + ( map asConfiguredPackage (tail newlyFailed) + , processing' + ) where processingSet' = Set.delete pkgid processingSet - failedSet' = failedSet `Set.union` Set.fromList newlyFailedIds + failedSet' = failedSet `Set.union` Set.fromList newlyFailedIds newlyFailedIds = map nodeKey newlyFailed - newlyFailed = fromMaybe (internalError "failed" "package not in graph") - $ Graph.revClosure (planGraph plan) [pkgid] - processing' = Processing processingSet' completedSet failedSet' + newlyFailed = + fromMaybe (internalError "failed" "package not in graph") $ + Graph.revClosure (planGraph plan) [pkgid] + processing' = Processing processingSet' completedSet failedSet' asConfiguredPackage (Configured pkg) = pkg asConfiguredPackage pkg = internalError "failed" $ "not in configured state: " ++ displayGenericPlanPackage pkg -processingInvariant :: (IsUnit ipkg, IsUnit srcpkg) - => GenericInstallPlan ipkg srcpkg - -> Processing -> Bool +processingInvariant + :: (IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg + -> Processing + -> Bool processingInvariant plan (Processing processingSet completedSet failedSet) = - - -- All the packages in the three sets are actually in the graph - assert (Foldable.all (flip Graph.member (planGraph plan)) processingSet) $ - assert (Foldable.all (flip Graph.member (planGraph plan)) completedSet) $ - assert (Foldable.all (flip Graph.member (planGraph plan)) failedSet) $ - + -- All the packages in the three sets are actually in the graph + assert (Foldable.all (flip Graph.member (planGraph plan)) processingSet) + $ assert (Foldable.all (flip Graph.member (planGraph plan)) completedSet) + $ assert (Foldable.all (flip Graph.member (planGraph plan)) failedSet) + $ -- The processing, completed and failed sets are disjoint from each other - assert (noIntersection processingSet completedSet) $ - assert (noIntersection processingSet failedSet) $ - assert (noIntersection failedSet completedSet) $ - + assert (noIntersection processingSet completedSet) + $ assert (noIntersection processingSet failedSet) + $ assert (noIntersection failedSet completedSet) + $ -- Packages that depend on a package that's still processing cannot be -- completed - assert (noIntersection (reverseClosure processingSet) completedSet) $ - + assert (noIntersection (reverseClosure processingSet) completedSet) + $ -- On the other hand, packages that depend on a package that's still -- processing /can/ have failed (since they may have depended on multiple -- packages that were processing, but it only takes one to fail to cause @@ -706,40 +796,50 @@ processingInvariant plan (Processing processingSet completedSet failedSet) = -- intersection (reverseClosure processingSet) failedSet -- The failed set is upwards closed, i.e. equal to its own rev dep closure - assert (failedSet == reverseClosure failedSet) $ - + assert (failedSet == reverseClosure failedSet) + $ -- All immediate reverse deps of packages that are currently processing -- are not currently being processed (ie not in the processing set). - assert (and [ rdeppkgid `Set.notMember` processingSet - | pkgid <- Set.toList processingSet - , rdeppkgid <- maybe (internalError "processingInvariant" "") - (map nodeKey) - (Graph.revNeighbors (planGraph plan) pkgid) - ]) $ - + assert + ( and + [ rdeppkgid `Set.notMember` processingSet + | pkgid <- Set.toList processingSet + , rdeppkgid <- + maybe + (internalError "processingInvariant" "") + (map nodeKey) + (Graph.revNeighbors (planGraph plan) pkgid) + ] + ) + $ -- Packages from the processing or failed sets are only ever in the -- configured state. - assert (and [ case Graph.lookup pkgid (planGraph plan) of - Just (Configured _) -> True - Just (PreExisting _) -> False - Just (Installed _) -> False - Nothing -> False - | pkgid <- Set.toList processingSet ++ Set.toList failedSet ]) - - -- We use asserts rather than returning False so that on failure we get - -- better details on which bit of the invariant was violated. - True + assert + ( and + [ case Graph.lookup pkgid (planGraph plan) of + Just (Configured _) -> True + Just (PreExisting _) -> False + Just (Installed _) -> False + Nothing -> False + | pkgid <- Set.toList processingSet ++ Set.toList failedSet + ] + ) + -- We use asserts rather than returning False so that on failure we get + -- better details on which bit of the invariant was violated. + True where - reverseClosure = Set.fromList - . map nodeKey - . fromMaybe (internalError "processingInvariant" "") - . Graph.revClosure (planGraph plan) - . Set.toList + reverseClosure = + Set.fromList + . map nodeKey + . fromMaybe (internalError "processingInvariant" "") + . Graph.revClosure (planGraph plan) + . Set.toList noIntersection a b = Set.null (Set.intersection a b) - -- ------------------------------------------------------------ + -- * Traversing plans + -- ------------------------------------------------------------ -- | Flatten an 'InstallPlan', producing the sequence of source packages in @@ -750,36 +850,37 @@ processingInvariant plan (Processing processingSet completedSet failedSet) = -- in-order 'JobControl'), which is a reverse topological orderings of the -- source packages in the dependency graph, albeit not necessarily exactly the -- same ordering as that produced by 'reverseTopologicalOrder'. --- -executionOrder :: (IsUnit ipkg, IsUnit srcpkg) - => GenericInstallPlan ipkg srcpkg - -> [GenericReadyPackage srcpkg] +executionOrder + :: (IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg + -> [GenericReadyPackage srcpkg] executionOrder plan = - let (newpkgs, processing) = ready plan - in tryNewTasks processing newpkgs + let (newpkgs, processing) = ready plan + in tryNewTasks processing newpkgs where - tryNewTasks _processing [] = [] - tryNewTasks processing (p:todo) = waitForTasks processing p todo + tryNewTasks _processing [] = [] + tryNewTasks processing (p : todo) = waitForTasks processing p todo waitForTasks processing p todo = - p : tryNewTasks processing' (todo++nextpkgs) + p : tryNewTasks processing' (todo ++ nextpkgs) where (nextpkgs, processing') = completed plan processing (nodeKey p) - -- ------------------------------------------------------------ + -- * Executing plans + -- ------------------------------------------------------------ -- | The set of results we get from executing an install plan. --- type BuildOutcomes failure result = Map UnitId (Either failure result) -- | Lookup the build result for a single package. --- -lookupBuildOutcome :: HasUnitId pkg - => pkg -> BuildOutcomes failure result - -> Maybe (Either failure result) +lookupBuildOutcome + :: HasUnitId pkg + => pkg + -> BuildOutcomes failure result + -> Maybe (Either failure result) lookupBuildOutcome = Map.lookup . installedUnitId -- | Execute an install plan. This traverses the plan in dependency order. @@ -796,162 +897,188 @@ lookupBuildOutcome = Map.lookup . installedUnitId -- in the plan. In particular in the default mode where we stop as soon as -- possible after a failure then there may be packages which are skipped and -- these will have no 'BuildOutcome'. --- -execute :: forall m ipkg srcpkg result failure. - (IsUnit ipkg, IsUnit srcpkg, - Monad m) - => JobControl m (UnitId, Either failure result) - -> Bool -- ^ Keep going after failure - -> (srcpkg -> failure) -- ^ Value for dependents of failed packages - -> GenericInstallPlan ipkg srcpkg - -> (GenericReadyPackage srcpkg -> m (Either failure result)) - -> m (BuildOutcomes failure result) +execute + :: forall m ipkg srcpkg result failure + . ( IsUnit ipkg + , IsUnit srcpkg + , Monad m + ) + => JobControl m (UnitId, Either failure result) + -> Bool + -- ^ Keep going after failure + -> (srcpkg -> failure) + -- ^ Value for dependents of failed packages + -> GenericInstallPlan ipkg srcpkg + -> (GenericReadyPackage srcpkg -> m (Either failure result)) + -> m (BuildOutcomes failure result) execute jobCtl keepGoing depFailure plan installPkg = - let (newpkgs, processing) = ready plan - in tryNewTasks Map.empty False False processing newpkgs + let (newpkgs, processing) = ready plan + in tryNewTasks Map.empty False False processing newpkgs where - tryNewTasks :: BuildOutcomes failure result - -> Bool -> Bool -> Processing - -> [GenericReadyPackage srcpkg] - -> m (BuildOutcomes failure result) + tryNewTasks + :: BuildOutcomes failure result + -> Bool + -> Bool + -> Processing + -> [GenericReadyPackage srcpkg] + -> m (BuildOutcomes failure result) tryNewTasks !results tasksFailed tasksRemaining !processing newpkgs -- we were in the process of cancelling and now we're finished - | tasksFailed && not keepGoing && not tasksRemaining - = return results - + | tasksFailed && not keepGoing && not tasksRemaining = + return results -- we are still in the process of cancelling, wait for remaining tasks - | tasksFailed && not keepGoing && tasksRemaining - = waitForTasks results tasksFailed processing - + | tasksFailed && not keepGoing && tasksRemaining = + waitForTasks results tasksFailed processing -- no new tasks to do and all tasks are done so we're finished - | null newpkgs && not tasksRemaining - = return results - + | null newpkgs && not tasksRemaining = + return results -- no new tasks to do, remaining tasks to wait for - | null newpkgs - = waitForTasks results tasksFailed processing - + | null newpkgs = + waitForTasks results tasksFailed processing -- new tasks to do, spawn them, then wait for tasks to complete - | otherwise - = do sequence_ [ spawnJob jobCtl $ do - result <- installPkg pkg - return (nodeKey pkg, result) - | pkg <- newpkgs ] - waitForTasks results tasksFailed processing - - waitForTasks :: BuildOutcomes failure result - -> Bool -> Processing - -> m (BuildOutcomes failure result) + | otherwise = + do + sequence_ + [ spawnJob jobCtl $ do + result <- installPkg pkg + return (nodeKey pkg, result) + | pkg <- newpkgs + ] + waitForTasks results tasksFailed processing + + waitForTasks + :: BuildOutcomes failure result + -> Bool + -> Processing + -> m (BuildOutcomes failure result) waitForTasks !results tasksFailed !processing = do (pkgid, result) <- collectJob jobCtl case result of - Right _success -> do - tasksRemaining <- remainingJobs jobCtl - tryNewTasks results' tasksFailed tasksRemaining - processing' nextpkgs + tasksRemaining <- remainingJobs jobCtl + tryNewTasks + results' + tasksFailed + tasksRemaining + processing' + nextpkgs where results' = Map.insert pkgid result results (nextpkgs, processing') = completed plan processing pkgid - Left _failure -> do - -- if this is the first failure and we're not trying to keep going - -- then try to cancel as many of the remaining jobs as possible - when (not tasksFailed && not keepGoing) $ - cancelJobs jobCtl + -- if this is the first failure and we're not trying to keep going + -- then try to cancel as many of the remaining jobs as possible + when (not tasksFailed && not keepGoing) $ + cancelJobs jobCtl - tasksRemaining <- remainingJobs jobCtl - tryNewTasks results' True tasksRemaining processing' [] + tasksRemaining <- remainingJobs jobCtl + tryNewTasks results' True tasksRemaining processing' [] where (depsfailed, processing') = failed plan processing pkgid - results' = Map.insert pkgid result results `Map.union` depResults - depResults = Map.fromList - [ (nodeKey deppkg, Left (depFailure deppkg)) - | deppkg <- depsfailed ] + results' = Map.insert pkgid result results `Map.union` depResults + depResults = + Map.fromList + [ (nodeKey deppkg, Left (depFailure deppkg)) + | deppkg <- depsfailed + ] -- ------------------------------------------------------------ + -- * Checking validity of plans + -- ------------------------------------------------------------ -- | A valid installation plan is a set of packages that is closed, acyclic -- and respects the package state relation. -- -- * if the result is @False@ use 'problems' to get a detailed list. --- -valid :: (IsUnit ipkg, IsUnit srcpkg) - => String -> Graph (GenericPlanPackage ipkg srcpkg) -> Bool +valid + :: (IsUnit ipkg, IsUnit srcpkg) + => String + -> Graph (GenericPlanPackage ipkg srcpkg) + -> Bool valid loc graph = - case problems graph of - [] -> True - ps -> internalError loc ('\n' : unlines (map showPlanProblem ps)) - -data PlanProblem ipkg srcpkg = - PackageMissingDeps (GenericPlanPackage ipkg srcpkg) [UnitId] - | PackageCycle [GenericPlanPackage ipkg srcpkg] - | PackageStateInvalid (GenericPlanPackage ipkg srcpkg) - (GenericPlanPackage ipkg srcpkg) - -showPlanProblem :: (IsUnit ipkg, IsUnit srcpkg) - => PlanProblem ipkg srcpkg -> String + case problems graph of + [] -> True + ps -> internalError loc ('\n' : unlines (map showPlanProblem ps)) + +data PlanProblem ipkg srcpkg + = PackageMissingDeps (GenericPlanPackage ipkg srcpkg) [UnitId] + | PackageCycle [GenericPlanPackage ipkg srcpkg] + | PackageStateInvalid + (GenericPlanPackage ipkg srcpkg) + (GenericPlanPackage ipkg srcpkg) + +showPlanProblem + :: (IsUnit ipkg, IsUnit srcpkg) + => PlanProblem ipkg srcpkg + -> String showPlanProblem (PackageMissingDeps pkg missingDeps) = - "Package " ++ prettyShow (nodeKey pkg) - ++ " depends on the following packages which are missing from the plan: " - ++ intercalate ", " (map prettyShow missingDeps) - + "Package " + ++ prettyShow (nodeKey pkg) + ++ " depends on the following packages which are missing from the plan: " + ++ intercalate ", " (map prettyShow missingDeps) showPlanProblem (PackageCycle cycleGroup) = - "The following packages are involved in a dependency cycle " - ++ intercalate ", " (map (prettyShow . nodeKey) cycleGroup) + "The following packages are involved in a dependency cycle " + ++ intercalate ", " (map (prettyShow . nodeKey) cycleGroup) showPlanProblem (PackageStateInvalid pkg pkg') = - "Package " ++ prettyShow (nodeKey pkg) - ++ " is in the " ++ showPlanPackageTag pkg - ++ " state but it depends on package " ++ prettyShow (nodeKey pkg') - ++ " which is in the " ++ showPlanPackageTag pkg' - ++ " state" + "Package " + ++ prettyShow (nodeKey pkg) + ++ " is in the " + ++ showPlanPackageTag pkg + ++ " state but it depends on package " + ++ prettyShow (nodeKey pkg') + ++ " which is in the " + ++ showPlanPackageTag pkg' + ++ " state" -- | For an invalid plan, produce a detailed list of problems as human readable -- error messages. This is mainly intended for debugging purposes. -- Use 'showPlanProblem' for a human readable explanation. --- -problems :: (IsUnit ipkg, IsUnit srcpkg) - => Graph (GenericPlanPackage ipkg srcpkg) - -> [PlanProblem ipkg srcpkg] +problems + :: (IsUnit ipkg, IsUnit srcpkg) + => Graph (GenericPlanPackage ipkg srcpkg) + -> [PlanProblem ipkg srcpkg] problems graph = - - [ PackageMissingDeps pkg - (mapMaybe - (fmap nodeKey . flip Graph.lookup graph) - missingDeps) - | (pkg, missingDeps) <- Graph.broken graph ] - - ++ [ PackageCycle cycleGroup - | cycleGroup <- Graph.cycles graph ] -{- - ++ [ PackageInconsistency name inconsistencies - | (name, inconsistencies) <- - dependencyInconsistencies indepGoals graph ] - --TODO: consider re-enabling this one, see SolverInstallPlan --} - ++ [ PackageStateInvalid pkg pkg' - | pkg <- Foldable.toList graph - , Just pkg' <- map (flip Graph.lookup graph) - (nodeNeighbors pkg) - , not (stateDependencyRelation pkg pkg') ] + [ PackageMissingDeps + pkg + ( mapMaybe + (fmap nodeKey . flip Graph.lookup graph) + missingDeps + ) + | (pkg, missingDeps) <- Graph.broken graph + ] + ++ [ PackageCycle cycleGroup + | cycleGroup <- Graph.cycles graph + ] + {- + ++ [ PackageInconsistency name inconsistencies + | (name, inconsistencies) <- + dependencyInconsistencies indepGoals graph ] + --TODO: consider re-enabling this one, see SolverInstallPlan + -} + ++ [ PackageStateInvalid pkg pkg' + | pkg <- Foldable.toList graph + , Just pkg' <- + map + (flip Graph.lookup graph) + (nodeNeighbors pkg) + , not (stateDependencyRelation pkg pkg') + ] -- | The states of packages have that depend on each other must respect -- this relation. That is for very case where package @a@ depends on -- package @b@ we require that @stateDependencyRelation a b = True@. --- -stateDependencyRelation :: GenericPlanPackage ipkg srcpkg - -> GenericPlanPackage ipkg srcpkg -> Bool +stateDependencyRelation + :: GenericPlanPackage ipkg srcpkg + -> GenericPlanPackage ipkg srcpkg + -> Bool stateDependencyRelation PreExisting{} PreExisting{} = True - -stateDependencyRelation Installed{} PreExisting{} = True -stateDependencyRelation Installed{} Installed{} = True - -stateDependencyRelation Configured{} PreExisting{} = True -stateDependencyRelation Configured{} Installed{} = True -stateDependencyRelation Configured{} Configured{} = True - -stateDependencyRelation _ _ = False +stateDependencyRelation Installed{} PreExisting{} = True +stateDependencyRelation Installed{} Installed{} = True +stateDependencyRelation Configured{} PreExisting{} = True +stateDependencyRelation Configured{} Installed{} = True +stateDependencyRelation Configured{} Configured{} = True +stateDependencyRelation _ _ = False diff --git a/cabal-install/src/Distribution/Client/InstallSymlink.hs b/cabal-install/src/Distribution/Client/InstallSymlink.hs index 5acf0092002..cf57c54818e 100644 --- a/cabal-install/src/Distribution/Client/InstallSymlink.hs +++ b/cabal-install/src/Distribution/Client/InstallSymlink.hs @@ -1,6 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.InstallSymlink -- Copyright : (c) Duncan Coutts 2008 @@ -11,60 +15,87 @@ -- Portability : portable -- -- Managing installing binaries with symlinks. ------------------------------------------------------------------------------ -module Distribution.Client.InstallSymlink ( - symlinkBinaries, - symlinkBinary, - trySymlink, - promptRun +module Distribution.Client.InstallSymlink + ( symlinkBinaries + , symlinkBinary + , trySymlink + , promptRun ) where import Distribution.Client.Compat.Prelude hiding (ioError) import Prelude () -import Distribution.Client.Types - ( ConfiguredPackage(..), BuildOutcomes ) -import Distribution.Client.Setup - ( InstallFlags(installSymlinkBinDir) ) -import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.Setup + ( InstallFlags (installSymlinkBinDir) + ) +import Distribution.Client.Types + ( BuildOutcomes + , ConfiguredPackage (..) + ) -import Distribution.Solver.Types.SourcePackage import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.SourcePackage -import Distribution.Package - ( PackageIdentifier, Package(packageId), UnitId, installedUnitId ) -import Distribution.Types.UnqualComponentName import Distribution.Compiler - ( CompilerId(..) ) -import qualified Distribution.PackageDescription as PackageDescription + ( CompilerId (..) + ) +import Distribution.Package + ( Package (packageId) + , PackageIdentifier + , UnitId + , installedUnitId + ) import Distribution.PackageDescription - ( PackageDescription ) + ( PackageDescription + ) +import qualified Distribution.PackageDescription as PackageDescription import Distribution.PackageDescription.Configuration - ( finalizePD ) -import Distribution.Simple.Setup - ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe ) -import qualified Distribution.Simple.InstallDirs as InstallDirs + ( finalizePD + ) import Distribution.Simple.Compiler - ( Compiler, compilerInfo, CompilerInfo(..) ) + ( Compiler + , CompilerInfo (..) + , compilerInfo + ) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.Simple.Setup + ( ConfigFlags (..) + , flagToMaybe + , fromFlag + , fromFlagOrDefault + ) +import Distribution.Simple.Utils (info, withTempDirectory) import Distribution.System - ( Platform ) -import Distribution.Simple.Utils ( info, withTempDirectory ) + ( Platform + ) +import Distribution.Types.UnqualComponentName import System.Directory - ( canonicalizePath, getTemporaryDirectory, removeFile ) + ( canonicalizePath + , getTemporaryDirectory + , removeFile + ) import System.FilePath - ( (), splitPath, joinPath, isAbsolute ) + ( isAbsolute + , joinPath + , splitPath + , () + ) -import System.IO.Error - ( isDoesNotExistError, ioError ) import Control.Exception - ( assert ) + ( assert + ) +import System.IO.Error + ( ioError + , isDoesNotExistError + ) -import Distribution.Client.Compat.Directory ( createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink ) +import Distribution.Client.Compat.Directory (createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink) +import Distribution.Client.Init.Prompt (promptYesNo) +import Distribution.Client.Init.Types (DefaultPrompt (MandatoryPrompt)) import Distribution.Client.Types.OverwritePolicy -import Distribution.Client.Init.Types ( DefaultPrompt(MandatoryPrompt) ) -import Distribution.Client.Init.Prompt ( promptYesNo ) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 @@ -88,117 +119,168 @@ import qualified Data.ByteString.Char8 as BS8 -- This is an optional feature that users can choose to use or not. It is -- controlled from the config file. Of course it only works on POSIX systems -- with symlinks so is not available to Windows users. --- -symlinkBinaries :: Platform -> Compiler - -> OverwritePolicy - -> ConfigFlags - -> InstallFlags - -> InstallPlan - -> BuildOutcomes - -> IO [(PackageIdentifier, UnqualComponentName, FilePath)] -symlinkBinaries platform comp overwritePolicy - configFlags installFlags - plan buildOutcomes = - case flagToMaybe (installSymlinkBinDir installFlags) of - Nothing -> return [] - Just symlinkBinDir - | null exes -> return [] - | otherwise -> do - publicBinDir <- canonicalizePath symlinkBinDir --- TODO: do we want to do this here? : --- createDirectoryIfMissing True publicBinDir - fmap catMaybes $ sequenceA - [ do privateBinDir <- pkgBinDir pkg ipid - ok <- symlinkBinary - overwritePolicy - publicBinDir privateBinDir - (prettyShow publicExeName) privateExeName - if ok - then return Nothing - else return (Just (pkgid, publicExeName, - privateBinDir privateExeName)) - | (rpkg, pkg, exe) <- exes - , let pkgid = packageId pkg - -- This is a bit dodgy; probably won't work for Backpack packages - ipid = installedUnitId rpkg - publicExeName = PackageDescription.exeName exe - privateExeName = prefix ++ unUnqualComponentName publicExeName ++ suffix - prefix = substTemplate pkgid ipid prefixTemplate - suffix = substTemplate pkgid ipid suffixTemplate ] - where - exes = - [ (cpkg, pkg, exe) - | InstallPlan.Configured cpkg <- InstallPlan.toList plan - , case InstallPlan.lookupBuildOutcome cpkg buildOutcomes of - Just (Right _success) -> True - _ -> False - , let pkg :: PackageDescription - pkg = pkgDescription cpkg - , exe <- PackageDescription.executables pkg - , PackageDescription.buildable (PackageDescription.buildInfo exe) ] +symlinkBinaries + :: Platform + -> Compiler + -> OverwritePolicy + -> ConfigFlags + -> InstallFlags + -> InstallPlan + -> BuildOutcomes + -> IO [(PackageIdentifier, UnqualComponentName, FilePath)] +symlinkBinaries + platform + comp + overwritePolicy + configFlags + installFlags + plan + buildOutcomes = + case flagToMaybe (installSymlinkBinDir installFlags) of + Nothing -> return [] + Just symlinkBinDir + | null exes -> return [] + | otherwise -> do + publicBinDir <- canonicalizePath symlinkBinDir + -- TODO: do we want to do this here? : + -- createDirectoryIfMissing True publicBinDir + fmap catMaybes $ + sequenceA + [ do + privateBinDir <- pkgBinDir pkg ipid + ok <- + symlinkBinary + overwritePolicy + publicBinDir + privateBinDir + (prettyShow publicExeName) + privateExeName + if ok + then return Nothing + else + return + ( Just + ( pkgid + , publicExeName + , privateBinDir privateExeName + ) + ) + | (rpkg, pkg, exe) <- exes + , let pkgid = packageId pkg + -- This is a bit dodgy; probably won't work for Backpack packages + ipid = installedUnitId rpkg + publicExeName = PackageDescription.exeName exe + privateExeName = prefix ++ unUnqualComponentName publicExeName ++ suffix + prefix = substTemplate pkgid ipid prefixTemplate + suffix = substTemplate pkgid ipid suffixTemplate + ] + where + exes = + [ (cpkg, pkg, exe) + | InstallPlan.Configured cpkg <- InstallPlan.toList plan + , case InstallPlan.lookupBuildOutcome cpkg buildOutcomes of + Just (Right _success) -> True + _ -> False + , let pkg :: PackageDescription + pkg = pkgDescription cpkg + , exe <- PackageDescription.executables pkg + , PackageDescription.buildable (PackageDescription.buildInfo exe) + ] - pkgDescription (ConfiguredPackage _ (SourcePackage _ gpd _ _) - flags stanzas _) = - case finalizePD flags (enableStanzas stanzas) - (const True) - platform cinfo [] gpd of - Left _ -> error "finalizePD ReadyPackage failed" - Right (desc, _) -> desc + pkgDescription + ( ConfiguredPackage + _ + (SourcePackage _ gpd _ _) + flags + stanzas + _ + ) = + case finalizePD + flags + (enableStanzas stanzas) + (const True) + platform + cinfo + [] + gpd of + Left _ -> error "finalizePD ReadyPackage failed" + Right (desc, _) -> desc - -- This is sadly rather complicated. We're kind of re-doing part of the - -- configuration for the package. :-( - pkgBinDir :: PackageDescription -> UnitId -> IO FilePath - pkgBinDir pkg ipid = do - defaultDirs <- InstallDirs.defaultInstallDirs - compilerFlavor - (fromFlag (configUserInstall configFlags)) - (PackageDescription.hasLibs pkg) - let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault - defaultDirs (configInstallDirs configFlags) - absoluteDirs = InstallDirs.absoluteInstallDirs - (packageId pkg) ipid - cinfo InstallDirs.NoCopyDest - platform templateDirs - canonicalizePath (InstallDirs.bindir absoluteDirs) + -- This is sadly rather complicated. We're kind of re-doing part of the + -- configuration for the package. :-( + pkgBinDir :: PackageDescription -> UnitId -> IO FilePath + pkgBinDir pkg ipid = do + defaultDirs <- + InstallDirs.defaultInstallDirs + compilerFlavor + (fromFlag (configUserInstall configFlags)) + (PackageDescription.hasLibs pkg) + let templateDirs = + InstallDirs.combineInstallDirs + fromFlagOrDefault + defaultDirs + (configInstallDirs configFlags) + absoluteDirs = + InstallDirs.absoluteInstallDirs + (packageId pkg) + ipid + cinfo + InstallDirs.NoCopyDest + platform + templateDirs + canonicalizePath (InstallDirs.bindir absoluteDirs) - substTemplate pkgid ipid = InstallDirs.fromPathTemplate - . InstallDirs.substPathTemplate env - where env = InstallDirs.initialPathTemplateEnv pkgid ipid - cinfo platform + substTemplate pkgid ipid = + InstallDirs.fromPathTemplate + . InstallDirs.substPathTemplate env + where + env = + InstallDirs.initialPathTemplateEnv + pkgid + ipid + cinfo + platform - fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "") - prefixTemplate = fromFlagTemplate (configProgPrefix configFlags) - suffixTemplate = fromFlagTemplate (configProgSuffix configFlags) - cinfo = compilerInfo comp - (CompilerId compilerFlavor _) = compilerInfoId cinfo + fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "") + prefixTemplate = fromFlagTemplate (configProgPrefix configFlags) + suffixTemplate = fromFlagTemplate (configProgSuffix configFlags) + cinfo = compilerInfo comp + (CompilerId compilerFlavor _) = compilerInfoId cinfo -- | Symlink binary. -- -- The paths are take in pieces, so we can make relative link when possible. --- -symlinkBinary :: - OverwritePolicy -- ^ Whether to force overwrite an existing file - -> FilePath -- ^ The canonical path of the public bin dir eg - -- @/home/user/bin@ - -> FilePath -- ^ The canonical path of the private bin dir eg - -- @/home/user/.cabal/bin@ - -> FilePath -- ^ The name of the executable to go in the public bin - -- dir, eg @foo@ - -> String -- ^ The name of the executable to in the private bin - -- dir, eg @foo-1.0@ - -> IO Bool -- ^ If creating the symlink was successful. @False@ if - -- there was another file there already that we did - -- not own. Other errors like permission errors just - -- propagate as exceptions. +symlinkBinary + :: OverwritePolicy + -- ^ Whether to force overwrite an existing file + -> FilePath + -- ^ The canonical path of the public bin dir eg + -- @/home/user/bin@ + -> FilePath + -- ^ The canonical path of the private bin dir eg + -- @/home/user/.cabal/bin@ + -> FilePath + -- ^ The name of the executable to go in the public bin + -- dir, eg @foo@ + -> String + -- ^ The name of the executable to in the private bin + -- dir, eg @foo-1.0@ + -> IO Bool + -- ^ If creating the symlink was successful. @False@ if + -- there was another file there already that we did + -- not own. Other errors like permission errors just + -- propagate as exceptions. symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName = do - ok <- targetOkToOverwrite (publicBindir publicName) - (privateBindir privateName) + ok <- + targetOkToOverwrite + (publicBindir publicName) + (privateBindir privateName) case ok of - NotExists -> mkLink - OkToOverwrite -> overwrite + NotExists -> mkLink + OkToOverwrite -> overwrite NotOurFile -> case overwritePolicy of - NeverOverwrite -> return False + NeverOverwrite -> return False AlwaysOverwrite -> overwrite PromptOverwrite -> maybeOverwrite where @@ -210,8 +292,8 @@ symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName overwrite :: IO Bool overwrite = rmLink *> mkLink maybeOverwrite :: IO Bool - maybeOverwrite - = promptRun + maybeOverwrite = + promptRun "Existing file found while installing symlink. Do you want to overwrite that file? (y/n)" overwrite @@ -223,22 +305,24 @@ promptRun s m = do -- | Check a file path of a symlink that we would like to create to see if it -- is OK. For it to be OK to overwrite it must either not already exist yet or -- be a symlink to our target (in which case we can assume ownership). --- -targetOkToOverwrite :: FilePath -- ^ The file path of the symlink to the private - -- binary that we would like to create - -> FilePath -- ^ The canonical path of the private binary. - -- Use 'canonicalizePath' to make this. - -> IO SymlinkStatus +targetOkToOverwrite + :: FilePath + -- ^ The file path of the symlink to the private + -- binary that we would like to create + -> FilePath + -- ^ The canonical path of the private binary. + -- Use 'canonicalizePath' to make this. + -> IO SymlinkStatus targetOkToOverwrite symlink target = handleNotExist $ do isLink <- pathIsSymbolicLink symlink if not isLink then return NotOurFile - else do target' <- canonicalizePath =<< getSymbolicLinkTarget symlink - -- This partially relies on canonicalizePath handling symlinks - if target == target' - then return OkToOverwrite - else return NotOurFile - + else do + target' <- canonicalizePath =<< getSymbolicLinkTarget symlink + -- This partially relies on canonicalizePath handling symlinks + if target == target' + then return OkToOverwrite + else return NotOurFile where handleNotExist action = catchIO action $ \ioexception -> -- If the target doesn't exist then there's no problem overwriting it! @@ -247,35 +331,38 @@ targetOkToOverwrite symlink target = handleNotExist $ do else ioError ioexception data SymlinkStatus - = NotExists -- ^ The file doesn't exist so we can make a symlink. - | OkToOverwrite -- ^ A symlink already exists, though it is ours. We'll - -- have to delete it first before we make a new symlink. - | NotOurFile -- ^ A file already exists and it is not one of our existing - -- symlinks (either because it is not a symlink or because - -- it points somewhere other than our managed space). - deriving Show + = -- | The file doesn't exist so we can make a symlink. + NotExists + | -- | A symlink already exists, though it is ours. We'll + -- have to delete it first before we make a new symlink. + OkToOverwrite + | -- | A file already exists and it is not one of our existing + -- symlinks (either because it is not a symlink or because + -- it points somewhere other than our managed space). + NotOurFile + deriving (Show) -- | Take two canonical paths and produce a relative path to get from the first -- to the second, even if it means adding @..@ path components. --- makeRelative :: FilePath -> FilePath -> FilePath -makeRelative a b = assert (isAbsolute a && isAbsolute b) $ - let as = splitPath a - bs = splitPath b - commonLen = length $ takeWhile id $ zipWith (==) as bs - in joinPath $ [ ".." | _ <- drop commonLen as ] - ++ drop commonLen bs +makeRelative a b = + assert (isAbsolute a && isAbsolute b) $ + let as = splitPath a + bs = splitPath b + commonLen = length $ takeWhile id $ zipWith (==) as bs + in joinPath $ + [".." | _ <- drop commonLen as] + ++ drop commonLen bs -- | Try to make a symlink in a temporary directory. -- -- If this works, we can try to symlink: even on Windows. --- trySymlink :: Verbosity -> IO Bool trySymlink verbosity = do tmp <- getTemporaryDirectory withTempDirectory verbosity tmp "cabal-symlink-test" $ \tmpDirPath -> do let from = tmpDirPath "file.txt" - let to = tmpDirPath "file2.txt" + let to = tmpDirPath "file2.txt" -- create a file BS.writeFile from (BS8.pack "TEST") diff --git a/cabal-install/src/Distribution/Client/JobControl.hs b/cabal-install/src/Distribution/Client/JobControl.hs index c9c16647ac1..d45efe3c8b2 100644 --- a/cabal-install/src/Distribution/Client/JobControl.hs +++ b/cabal-install/src/Distribution/Client/JobControl.hs @@ -1,5 +1,9 @@ {-# LANGUAGE FlexibleContexts #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.JobControl -- Copyright : (c) Duncan Coutts 2012 @@ -10,74 +14,65 @@ -- Portability : portable -- -- A job control concurrency abstraction ------------------------------------------------------------------------------ -module Distribution.Client.JobControl ( - JobControl, - newSerialJobControl, - newParallelJobControl, - spawnJob, - collectJob, - remainingJobs, - cancelJobs, - - JobLimit, - newJobLimit, - withJobLimit, - - Lock, - newLock, - criticalSection +module Distribution.Client.JobControl + ( JobControl + , newSerialJobControl + , newParallelJobControl + , spawnJob + , collectJob + , remainingJobs + , cancelJobs + , JobLimit + , newJobLimit + , withJobLimit + , Lock + , newLock + , criticalSection ) where import Distribution.Client.Compat.Prelude import Prelude () -import Control.Monad (forever, replicateM_) import Control.Concurrent (forkIO) import Control.Concurrent.MVar import Control.Concurrent.STM (STM, atomically) -import Control.Concurrent.STM.TVar import Control.Concurrent.STM.TChan +import Control.Concurrent.STM.TVar import Control.Exception (bracket_, try) -import Distribution.Compat.Stack +import Control.Monad (forever, replicateM_) import Distribution.Client.Compat.Semaphore - +import Distribution.Compat.Stack -- | A simple concurrency abstraction. Jobs can be spawned and can complete -- in any order. This allows both serial and parallel implementations. --- -data JobControl m a = JobControl { - -- | Add a new job to the pool of jobs - spawnJob :: m a -> m (), - - -- | Wait until one job is complete - collectJob :: m a, - - -- | Returns True if there are any outstanding jobs - -- (ie spawned but yet to be collected) - remainingJobs :: m Bool, - - -- | Try to cancel any outstanding but not-yet-started jobs. - -- Call 'remainingJobs' after this to find out if any jobs are left - -- (ie could not be cancelled). - cancelJobs :: m () - } - +data JobControl m a = JobControl + { spawnJob :: m a -> m () + -- ^ Add a new job to the pool of jobs + , collectJob :: m a + -- ^ Wait until one job is complete + , remainingJobs :: m Bool + -- ^ Returns True if there are any outstanding jobs + -- (ie spawned but yet to be collected) + , cancelJobs :: m () + -- ^ Try to cancel any outstanding but not-yet-started jobs. + -- Call 'remainingJobs' after this to find out if any jobs are left + -- (ie could not be cancelled). + } -- | Make a 'JobControl' that executes all jobs serially and in order. -- It only executes jobs on demand when they are collected, not eagerly. -- -- Cancelling will cancel /all/ jobs that have not been collected yet. --- newSerialJobControl :: IO (JobControl IO a) newSerialJobControl = do - qVar <- newTChanIO - return JobControl { - spawnJob = spawn qVar, - collectJob = collect qVar, - remainingJobs = remaining qVar, - cancelJobs = cancel qVar - } + qVar <- newTChanIO + return + JobControl + { spawnJob = spawn qVar + , collectJob = collect qVar + , remainingJobs = remaining qVar + , cancelJobs = cancel qVar + } where spawn :: TChan (IO a) -> IO a -> IO () spawn qVar job = atomically $ writeTChan qVar job @@ -87,7 +82,7 @@ newSerialJobControl = do join $ atomically $ readTChan qVar remaining :: TChan (IO a) -> IO Bool - remaining qVar = fmap not $ atomically $ isEmptyTChan qVar + remaining qVar = fmap not $ atomically $ isEmptyTChan qVar cancel :: TChan (IO a) -> IO () cancel qVar = do @@ -100,25 +95,26 @@ newSerialJobControl = do -- Cancelling will cancel jobs that have not yet begun executing, but jobs -- that have already been executed or are currently executing cannot be -- cancelled. --- newParallelJobControl :: WithCallStack (Int -> IO (JobControl IO a)) -newParallelJobControl n | n < 1 || n > 1000 = - error $ "newParallelJobControl: not a sensible number of jobs: " ++ show n +newParallelJobControl n + | n < 1 || n > 1000 = + error $ "newParallelJobControl: not a sensible number of jobs: " ++ show n newParallelJobControl maxJobLimit = do - inqVar <- newTChanIO - outqVar <- newTChanIO - countVar <- newTVarIO 0 - replicateM_ maxJobLimit $ - forkIO $ - worker inqVar outqVar - return JobControl { - spawnJob = spawn inqVar countVar, - collectJob = collect outqVar countVar, - remainingJobs = remaining countVar, - cancelJobs = cancel inqVar countVar - } + inqVar <- newTChanIO + outqVar <- newTChanIO + countVar <- newTVarIO 0 + replicateM_ maxJobLimit $ + forkIO $ + worker inqVar outqVar + return + JobControl + { spawnJob = spawn inqVar countVar + , collectJob = collect outqVar countVar + , remainingJobs = remaining countVar + , cancelJobs = cancel inqVar countVar + } where - worker :: TChan (IO a) -> TChan (Either SomeException a) -> IO () + worker :: TChan (IO a) -> TChan (Either SomeException a) -> IO () worker inqVar outqVar = forever $ do job <- atomically $ readTChan inqVar @@ -128,7 +124,7 @@ newParallelJobControl maxJobLimit = do spawn :: TChan (IO a) -> TVar Int -> IO a -> IO () spawn inqVar countVar job = atomically $ do - modifyTVar' countVar (+1) + modifyTVar' countVar (+ 1) writeTChan inqVar job collect :: TChan (Either SomeException a) -> TVar Int -> IO a @@ -139,7 +135,7 @@ newParallelJobControl maxJobLimit = do either throwIO return res remaining :: TVar Int -> IO Bool - remaining countVar = fmap (/=0) $ atomically $ readTVar countVar + remaining countVar = fmap (/= 0) $ atomically $ readTVar countVar cancel :: TChan (IO a) -> TVar Int -> IO () cancel inqVar countVar = @@ -154,7 +150,7 @@ readAllTChan qvar = go [] mx <- tryReadTChan qvar case mx of Nothing -> return (reverse xs) - Just x -> go (x:xs) + Just x -> go (x : xs) ------------------------- -- Job limits and locks diff --git a/cabal-install/src/Distribution/Client/List.hs b/cabal-install/src/Distribution/Client/List.hs index a8bede49dd7..ef9285bf39d 100644 --- a/cabal-install/src/Distribution/Client/List.hs +++ b/cabal-install/src/Distribution/Client/List.hs @@ -1,5 +1,9 @@ {-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.List -- Copyright : (c) David Himmelstrup 2005 @@ -9,264 +13,368 @@ -- Maintainer : cabal-devel@haskell.org -- -- Search for and print information about packages ------------------------------------------------------------------------------ -module Distribution.Client.List ( - list, info +module Distribution.Client.List + ( list + , info ) where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () -import Distribution.Package - ( PackageName, Package(..), packageName - , packageVersion, UnitId ) -import Distribution.Types.Dependency -import Distribution.Types.UnqualComponentName -import Distribution.ModuleName (ModuleName) -import Distribution.License (License) import qualified Distribution.InstalledPackageInfo as Installed -import qualified Distribution.PackageDescription as Source +import Distribution.License (License) +import Distribution.ModuleName (ModuleName) +import Distribution.Package + ( Package (..) + , PackageName + , UnitId + , packageName + , packageVersion + ) import Distribution.PackageDescription - ( PackageFlag(..), unFlagName ) + ( PackageFlag (..) + , unFlagName + ) +import qualified Distribution.PackageDescription as Source import Distribution.PackageDescription.Configuration - ( flattenPackageDescription ) + ( flattenPackageDescription + ) +import Distribution.Types.Dependency +import Distribution.Types.UnqualComponentName import Distribution.Simple.Compiler - ( Compiler, PackageDBStack ) -import Distribution.Simple.Program (ProgramDb) -import Distribution.Simple.Utils - ( equating, die', notice ) -import Distribution.Simple.Setup (fromFlag, fromFlagOrDefault) + ( Compiler + , PackageDBStack + ) import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex +import Distribution.Simple.Program (ProgramDb) +import Distribution.Simple.Setup (fromFlag, fromFlagOrDefault) +import Distribution.Simple.Utils + ( die' + , equating + , notice + ) import Distribution.Version - ( Version, mkVersion, versionNumbers, VersionRange, withinRange, anyVersion - , intersectVersionRanges, simplifyVersionRange ) + ( Version + , VersionRange + , anyVersion + , intersectVersionRanges + , mkVersion + , simplifyVersionRange + , versionNumbers + , withinRange + ) import qualified Distribution.SPDX as SPDX -import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.PackageConstraint import qualified Distribution.Solver.Types.PackageIndex as PackageIndex -import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.SourcePackage -import Distribution.Client.Types - ( SourcePackageDb(..), PackageSpecifier(..), UnresolvedSourcePackage ) -import Distribution.Client.Targets - ( UserTarget, resolveUserTargets ) +import Distribution.Client.FetchUtils + ( isFetched + ) +import Distribution.Client.IndexUtils as IndexUtils + ( getInstalledPackages + , getSourcePackages + ) import Distribution.Client.Setup - ( GlobalFlags(..), ListFlags(..), InfoFlags(..) - , RepoContext(..) ) + ( GlobalFlags (..) + , InfoFlags (..) + , ListFlags (..) + , RepoContext (..) + ) +import Distribution.Client.Targets + ( UserTarget + , resolveUserTargets + ) +import Distribution.Client.Types + ( PackageSpecifier (..) + , SourcePackageDb (..) + , UnresolvedSourcePackage + ) import Distribution.Client.Utils - ( mergeBy, MergeResult(..) ) -import Distribution.Client.IndexUtils as IndexUtils - ( getSourcePackages, getInstalledPackages ) -import Distribution.Client.FetchUtils - ( isFetched ) + ( MergeResult (..) + , mergeBy + ) +import Control.Exception + ( assert + ) import Data.Bits ((.|.)) import Data.List - ( maximumBy ) -import Data.List.NonEmpty (groupBy) + ( maximumBy + ) import qualified Data.List as L -import Data.Maybe - ( fromJust ) +import Data.List.NonEmpty (groupBy) import qualified Data.Map as Map +import Data.Maybe + ( fromJust + ) import Data.Tree as Tree -import Control.Exception - ( assert ) -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint - ( lineLength, ribbonsPerLine, Doc, renderStyle, char - , nest, ($+$), text, vcat, style, parens, fsep) import System.Directory - ( doesDirectoryExist ) + ( doesDirectoryExist + ) +import Text.PrettyPrint + ( Doc + , char + , fsep + , lineLength + , nest + , parens + , renderStyle + , ribbonsPerLine + , style + , text + , vcat + , ($+$) + ) +import qualified Text.PrettyPrint as Disp import Distribution.Utils.ShortText (ShortText) import qualified Distribution.Utils.ShortText as ShortText import qualified Text.Regex.Base as Regex import qualified Text.Regex.Posix.String as Regex - -- | Return a list of packages matching given search strings. -getPkgList :: Verbosity - -> PackageDBStack - -> RepoContext - -> Maybe (Compiler, ProgramDb) - -> ListFlags - -> [String] - -> IO [PackageDisplayInfo] +getPkgList + :: Verbosity + -> PackageDBStack + -> RepoContext + -> Maybe (Compiler, ProgramDb) + -> ListFlags + -> [String] + -> IO [PackageDisplayInfo] getPkgList verbosity packageDBs repoCtxt mcompprogdb listFlags pats = do - installedPkgIndex <- for mcompprogdb $ \(comp, progdb) -> - getInstalledPackages verbosity comp packageDBs progdb - sourcePkgDb <- getSourcePackages verbosity repoCtxt - - regexps <- for pats $ \pat -> do - e <- Regex.compile compOption Regex.execBlank pat - case e of - Right r -> return r - Left err -> die' verbosity $ "Failed to compile regex " ++ pat ++ ": " ++ snd err - - let sourcePkgIndex = packageIndex sourcePkgDb - prefs name = fromMaybe anyVersion - (Map.lookup name (packagePreferences sourcePkgDb)) - - pkgsInfoMatching :: - [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])] - pkgsInfoMatching = - let matchingInstalled = maybe [] (matchingPackages InstalledPackageIndex.searchWithPredicate regexps) installedPkgIndex - matchingSource = matchingPackages (\ idx n -> concatMap snd (PackageIndex.searchWithPredicate idx n)) regexps sourcePkgIndex - in mergePackages matchingInstalled matchingSource - - pkgsInfo :: - [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])] - pkgsInfo - -- gather info for all packages - | null regexps = mergePackages - (maybe [] InstalledPackageIndex.allPackages installedPkgIndex) - ( PackageIndex.allPackages sourcePkgIndex) - - -- gather info for packages matching search term - | otherwise = pkgsInfoMatching - - matches :: [PackageDisplayInfo] - matches = [ mergePackageInfo pref - installedPkgs sourcePkgs selectedPkg False - | (pkgname, installedPkgs, sourcePkgs) <- pkgsInfo - , not onlyInstalled || not (null installedPkgs) - , let pref = prefs pkgname - selectedPkg = latestWithPref pref sourcePkgs ] - return matches + installedPkgIndex <- for mcompprogdb $ \(comp, progdb) -> + getInstalledPackages verbosity comp packageDBs progdb + sourcePkgDb <- getSourcePackages verbosity repoCtxt + + regexps <- for pats $ \pat -> do + e <- Regex.compile compOption Regex.execBlank pat + case e of + Right r -> return r + Left err -> die' verbosity $ "Failed to compile regex " ++ pat ++ ": " ++ snd err + + let sourcePkgIndex = packageIndex sourcePkgDb + prefs name = + fromMaybe + anyVersion + (Map.lookup name (packagePreferences sourcePkgDb)) + + pkgsInfoMatching + :: [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])] + pkgsInfoMatching = + let matchingInstalled = maybe [] (matchingPackages InstalledPackageIndex.searchWithPredicate regexps) installedPkgIndex + matchingSource = matchingPackages (\idx n -> concatMap snd (PackageIndex.searchWithPredicate idx n)) regexps sourcePkgIndex + in mergePackages matchingInstalled matchingSource + + pkgsInfo + :: [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])] + pkgsInfo + -- gather info for all packages + | null regexps = + mergePackages + (maybe [] InstalledPackageIndex.allPackages installedPkgIndex) + (PackageIndex.allPackages sourcePkgIndex) + -- gather info for packages matching search term + | otherwise = pkgsInfoMatching + + matches :: [PackageDisplayInfo] + matches = + [ mergePackageInfo + pref + installedPkgs + sourcePkgs + selectedPkg + False + | (pkgname, installedPkgs, sourcePkgs) <- pkgsInfo + , not onlyInstalled || not (null installedPkgs) + , let pref = prefs pkgname + selectedPkg = latestWithPref pref sourcePkgs + ] + return matches where - onlyInstalled = fromFlagOrDefault False (listInstalled listFlags) + onlyInstalled = fromFlagOrDefault False (listInstalled listFlags) caseInsensitive = fromFlagOrDefault True (listCaseInsensitive listFlags) - compOption | caseInsensitive = Regex.compExtended .|. Regex.compIgnoreCase - | otherwise = Regex.compExtended + compOption + | caseInsensitive = Regex.compExtended .|. Regex.compIgnoreCase + | otherwise = Regex.compExtended matchingPackages search regexps index = [ pkg | re <- regexps - , pkg <- search index (Regex.matchTest re) ] - + , pkg <- search index (Regex.matchTest re) + ] -- | Show information about packages. -list :: Verbosity - -> PackageDBStack - -> RepoContext - -> Maybe (Compiler, ProgramDb) - -> ListFlags - -> [String] - -> IO () +list + :: Verbosity + -> PackageDBStack + -> RepoContext + -> Maybe (Compiler, ProgramDb) + -> ListFlags + -> [String] + -> IO () list verbosity packageDBs repos mcompProgdb listFlags pats = do - matches <- getPkgList verbosity packageDBs repos mcompProgdb listFlags pats - - if simpleOutput - then putStr $ unlines - [ prettyShow (pkgName pkg) ++ " " ++ prettyShow version - | pkg <- matches - , version <- if onlyInstalled - then installedVersions pkg - else nub . sort $ installedVersions pkg - ++ sourceVersions pkg ] - -- Note: this only works because for 'list', one cannot currently - -- specify any version constraints, so listing all installed - -- and source ones works. - else - if null matches - then notice verbosity "No matches found." - else putStr $ unlines (map showPackageSummaryInfo matches) + matches <- getPkgList verbosity packageDBs repos mcompProgdb listFlags pats + + if simpleOutput + then + putStr $ + unlines + [ prettyShow (pkgName pkg) ++ " " ++ prettyShow version + | pkg <- matches + , version <- + if onlyInstalled + then installedVersions pkg + else + nub . sort $ + installedVersions pkg + ++ sourceVersions pkg + ] + else -- Note: this only works because for 'list', one cannot currently + -- specify any version constraints, so listing all installed + -- and source ones works. + + if null matches + then notice verbosity "No matches found." + else putStr $ unlines (map showPackageSummaryInfo matches) where onlyInstalled = fromFlag (listInstalled listFlags) - simpleOutput = fromFlag (listSimpleOutput listFlags) - -info :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> ProgramDb - -> GlobalFlags - -> InfoFlags - -> [UserTarget] - -> IO () + simpleOutput = fromFlag (listSimpleOutput listFlags) + +info + :: Verbosity + -> PackageDBStack + -> RepoContext + -> Compiler + -> ProgramDb + -> GlobalFlags + -> InfoFlags + -> [UserTarget] + -> IO () info verbosity _ _ _ _ _ _ [] = - notice verbosity "No packages requested. Nothing to do." - -info verbosity packageDBs repoCtxt comp progdb - _ _listFlags userTargets = do - + notice verbosity "No packages requested. Nothing to do." +info + verbosity + packageDBs + repoCtxt + comp + progdb + _ + _listFlags + userTargets = do installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb - sourcePkgDb <- getSourcePackages verbosity repoCtxt + sourcePkgDb <- getSourcePackages verbosity repoCtxt let sourcePkgIndex = packageIndex sourcePkgDb - prefs name = fromMaybe anyVersion - (Map.lookup name (packagePreferences sourcePkgDb)) - - -- Users may specify names of packages that are only installed, not - -- just available source packages, so we must resolve targets using - -- the combination of installed and source packages. - let sourcePkgs' = PackageIndex.fromList - $ map packageId - (InstalledPackageIndex.allPackages installedPkgIndex) - ++ map packageId - (PackageIndex.allPackages sourcePkgIndex) - pkgSpecifiers <- resolveUserTargets verbosity repoCtxt - sourcePkgs' userTargets - - pkgsinfo <- sequenceA - [ do pkginfo <- either (die' verbosity) return $ - gatherPkgInfo prefs - installedPkgIndex sourcePkgIndex - pkgSpecifier - updateFileSystemPackageDetails pkginfo - | pkgSpecifier <- pkgSpecifiers ] + prefs name = + fromMaybe + anyVersion + (Map.lookup name (packagePreferences sourcePkgDb)) + + -- Users may specify names of packages that are only installed, not + -- just available source packages, so we must resolve targets using + -- the combination of installed and source packages. + let sourcePkgs' = + PackageIndex.fromList $ + map + packageId + (InstalledPackageIndex.allPackages installedPkgIndex) + ++ map + packageId + (PackageIndex.allPackages sourcePkgIndex) + pkgSpecifiers <- + resolveUserTargets + verbosity + repoCtxt + sourcePkgs' + userTargets + + pkgsinfo <- + sequenceA + [ do + pkginfo <- + either (die' verbosity) return $ + gatherPkgInfo + prefs + installedPkgIndex + sourcePkgIndex + pkgSpecifier + updateFileSystemPackageDetails pkginfo + | pkgSpecifier <- pkgSpecifiers + ] putStr $ unlines (map showPackageDetailedInfo pkgsinfo) - - where - gatherPkgInfo :: (PackageName -> VersionRange) -> - InstalledPackageIndex -> - PackageIndex.PackageIndex UnresolvedSourcePackage -> - PackageSpecifier UnresolvedSourcePackage -> - Either String PackageDisplayInfo - gatherPkgInfo prefs installedPkgIndex sourcePkgIndex - (NamedPackage name props) - | null (selectedInstalledPkgs) && null (selectedSourcePkgs) - = Left $ "There is no available version of " ++ prettyShow name - ++ " that satisfies " - ++ prettyShow (simplifyVersionRange verConstraint) - - | otherwise - = Right $ mergePackageInfo pref installedPkgs - sourcePkgs selectedSourcePkg' - showPkgVersion - where - (pref, installedPkgs, sourcePkgs) = - sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex - - selectedInstalledPkgs = InstalledPackageIndex.lookupDependency - installedPkgIndex - name verConstraint - selectedSourcePkgs = PackageIndex.lookupDependency sourcePkgIndex - name verConstraint - selectedSourcePkg' = latestWithPref pref selectedSourcePkgs - - -- display a specific package version if the user - -- supplied a non-trivial version constraint - showPkgVersion = not (null verConstraints) - verConstraint = foldr intersectVersionRanges anyVersion verConstraints - verConstraints = [ vr | PackagePropertyVersion vr <- props ] - - gatherPkgInfo prefs installedPkgIndex sourcePkgIndex - (SpecificSourcePackage pkg) = - Right $ mergePackageInfo pref installedPkgs sourcePkgs - selectedPkg True - where - name = packageName pkg - selectedPkg = Just pkg - (pref, installedPkgs, sourcePkgs) = - sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex - -sourcePkgsInfo :: - (PackageName -> VersionRange) + where + gatherPkgInfo + :: (PackageName -> VersionRange) + -> InstalledPackageIndex + -> PackageIndex.PackageIndex UnresolvedSourcePackage + -> PackageSpecifier UnresolvedSourcePackage + -> Either String PackageDisplayInfo + gatherPkgInfo + prefs + installedPkgIndex + sourcePkgIndex + (NamedPackage name props) + | null (selectedInstalledPkgs) && null (selectedSourcePkgs) = + Left $ + "There is no available version of " + ++ prettyShow name + ++ " that satisfies " + ++ prettyShow (simplifyVersionRange verConstraint) + | otherwise = + Right $ + mergePackageInfo + pref + installedPkgs + sourcePkgs + selectedSourcePkg' + showPkgVersion + where + (pref, installedPkgs, sourcePkgs) = + sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex + + selectedInstalledPkgs = + InstalledPackageIndex.lookupDependency + installedPkgIndex + name + verConstraint + selectedSourcePkgs = + PackageIndex.lookupDependency + sourcePkgIndex + name + verConstraint + selectedSourcePkg' = latestWithPref pref selectedSourcePkgs + + -- display a specific package version if the user + -- supplied a non-trivial version constraint + showPkgVersion = not (null verConstraints) + verConstraint = foldr intersectVersionRanges anyVersion verConstraints + verConstraints = [vr | PackagePropertyVersion vr <- props] + gatherPkgInfo + prefs + installedPkgIndex + sourcePkgIndex + (SpecificSourcePackage pkg) = + Right $ + mergePackageInfo + pref + installedPkgs + sourcePkgs + selectedPkg + True + where + name = packageName pkg + selectedPkg = Just pkg + (pref, installedPkgs, sourcePkgs) = + sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex + +sourcePkgsInfo + :: (PackageName -> VersionRange) -> PackageName -> InstalledPackageIndex -> PackageIndex.PackageIndex UnresolvedSourcePackage @@ -274,157 +382,179 @@ sourcePkgsInfo :: sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex = (pref, installedPkgs, sourcePkgs) where - pref = prefs name - installedPkgs = concatMap snd (InstalledPackageIndex.lookupPackageName - installedPkgIndex name) - sourcePkgs = PackageIndex.lookupPackageName sourcePkgIndex name - + pref = prefs name + installedPkgs = + concatMap + snd + ( InstalledPackageIndex.lookupPackageName + installedPkgIndex + name + ) + sourcePkgs = PackageIndex.lookupPackageName sourcePkgIndex name -- | The info that we can display for each package. It is information per -- package name and covers all installed and available versions. --- -data PackageDisplayInfo = PackageDisplayInfo { - pkgName :: PackageName, - selectedVersion :: Maybe Version, - selectedSourcePkg :: Maybe UnresolvedSourcePackage, - installedVersions :: [Version], - sourceVersions :: [Version], - preferredVersions :: VersionRange, - homepage :: ShortText, - bugReports :: ShortText, - sourceRepo :: String, -- TODO - synopsis :: ShortText, - description :: ShortText, - category :: ShortText, - license :: Either SPDX.License License, - author :: ShortText, - maintainer :: ShortText, - dependencies :: [ExtDependency], - flags :: [PackageFlag], - hasLib :: Bool, - hasExe :: Bool, - executables :: [UnqualComponentName], - modules :: [ModuleName], - haddockHtml :: FilePath, - haveTarball :: Bool +data PackageDisplayInfo = PackageDisplayInfo + { pkgName :: PackageName + , selectedVersion :: Maybe Version + , selectedSourcePkg :: Maybe UnresolvedSourcePackage + , installedVersions :: [Version] + , sourceVersions :: [Version] + , preferredVersions :: VersionRange + , homepage :: ShortText + , bugReports :: ShortText + , sourceRepo :: String -- TODO + , synopsis :: ShortText + , description :: ShortText + , category :: ShortText + , license :: Either SPDX.License License + , author :: ShortText + , maintainer :: ShortText + , dependencies :: [ExtDependency] + , flags :: [PackageFlag] + , hasLib :: Bool + , hasExe :: Bool + , executables :: [UnqualComponentName] + , modules :: [ModuleName] + , haddockHtml :: FilePath + , haveTarball :: Bool } -- | Covers source dependencies and installed dependencies in -- one type. -data ExtDependency = SourceDependency Dependency - | InstalledDependency UnitId +data ExtDependency + = SourceDependency Dependency + | InstalledDependency UnitId showPackageSummaryInfo :: PackageDisplayInfo -> String showPackageSummaryInfo pkginfo = - renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ - char '*' <+> pretty (pkgName pkginfo) - $+$ - (nest 4 $ vcat [ - maybeShowST (synopsis pkginfo) "Synopsis:" reflowParagraphs - , text "Default available version:" <+> - case selectedSourcePkg pkginfo of - Nothing -> text "[ Not available from any configured repository ]" - Just pkg -> pretty (packageVersion pkg) - , text "Installed versions:" <+> - case installedVersions pkginfo of - [] | hasLib pkginfo -> text "[ Not installed ]" - | otherwise -> text "[ Unknown ]" - versions -> dispTopVersions 4 - (preferredVersions pkginfo) versions - , maybeShowST (homepage pkginfo) "Homepage:" text - , text "License: " <+> either pretty pretty (license pkginfo) - ]) - $+$ text "" + renderStyle (style{lineLength = 80, ribbonsPerLine = 1}) $ + char '*' + <+> pretty (pkgName pkginfo) + $+$ ( nest 4 $ + vcat + [ maybeShowST (synopsis pkginfo) "Synopsis:" reflowParagraphs + , text "Default available version:" + <+> case selectedSourcePkg pkginfo of + Nothing -> text "[ Not available from any configured repository ]" + Just pkg -> pretty (packageVersion pkg) + , text "Installed versions:" + <+> case installedVersions pkginfo of + [] + | hasLib pkginfo -> text "[ Not installed ]" + | otherwise -> text "[ Unknown ]" + versions -> + dispTopVersions + 4 + (preferredVersions pkginfo) + versions + , maybeShowST (homepage pkginfo) "Homepage:" text + , text "License: " <+> either pretty pretty (license pkginfo) + ] + ) + $+$ text "" where maybeShowST l s f - | ShortText.null l = Disp.empty - | otherwise = text s <+> f (ShortText.fromShortText l) + | ShortText.null l = Disp.empty + | otherwise = text s <+> f (ShortText.fromShortText l) showPackageDetailedInfo :: PackageDisplayInfo -> String showPackageDetailedInfo pkginfo = - renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ - char '*' <+> pretty (pkgName pkginfo) - <<>> maybe Disp.empty (\v -> char '-' Disp.<> pretty v) (selectedVersion pkginfo) - <+> text (replicate (16 - length (prettyShow (pkgName pkginfo))) ' ') - <<>> parens pkgkind - $+$ - (nest 4 $ vcat [ - entryST "Synopsis" synopsis hideIfNull reflowParagraphs - , entry "Versions available" sourceVersions - (altText null "[ Not available from server ]") - (dispTopVersions 9 (preferredVersions pkginfo)) - , entry "Versions installed" installedVersions - (altText null (if hasLib pkginfo then "[ Not installed ]" - else "[ Unknown ]")) - (dispTopVersions 4 (preferredVersions pkginfo)) - , entryST "Homepage" homepage orNotSpecified text - , entryST "Bug reports" bugReports orNotSpecified text - , entryST "Description" description hideIfNull reflowParagraphs - , entryST "Category" category hideIfNull text - , entry "License" license alwaysShow (either pretty pretty) - , entryST "Author" author hideIfNull reflowLines - , entryST "Maintainer" maintainer hideIfNull reflowLines - , entry "Source repo" sourceRepo orNotSpecified text - , entry "Executables" executables hideIfNull (commaSep pretty) - , entry "Flags" flags hideIfNull (commaSep dispFlag) - , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep) - , entry "Documentation" haddockHtml showIfInstalled text - , entry "Cached" haveTarball alwaysShow dispYesNo - , if not (hasLib pkginfo) then mempty else - text "Modules:" $+$ nest 4 (vcat (map pretty . sort . modules $ pkginfo)) - ]) - $+$ text "" + renderStyle (style{lineLength = 80, ribbonsPerLine = 1}) $ + char '*' + <+> pretty (pkgName pkginfo) + <<>> maybe Disp.empty (\v -> char '-' Disp.<> pretty v) (selectedVersion pkginfo) + <+> text (replicate (16 - length (prettyShow (pkgName pkginfo))) ' ') + <<>> parens pkgkind + $+$ ( nest 4 $ + vcat + [ entryST "Synopsis" synopsis hideIfNull reflowParagraphs + , entry + "Versions available" + sourceVersions + (altText null "[ Not available from server ]") + (dispTopVersions 9 (preferredVersions pkginfo)) + , entry + "Versions installed" + installedVersions + ( altText + null + ( if hasLib pkginfo + then "[ Not installed ]" + else "[ Unknown ]" + ) + ) + (dispTopVersions 4 (preferredVersions pkginfo)) + , entryST "Homepage" homepage orNotSpecified text + , entryST "Bug reports" bugReports orNotSpecified text + , entryST "Description" description hideIfNull reflowParagraphs + , entryST "Category" category hideIfNull text + , entry "License" license alwaysShow (either pretty pretty) + , entryST "Author" author hideIfNull reflowLines + , entryST "Maintainer" maintainer hideIfNull reflowLines + , entry "Source repo" sourceRepo orNotSpecified text + , entry "Executables" executables hideIfNull (commaSep pretty) + , entry "Flags" flags hideIfNull (commaSep dispFlag) + , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep) + , entry "Documentation" haddockHtml showIfInstalled text + , entry "Cached" haveTarball alwaysShow dispYesNo + , if not (hasLib pkginfo) + then mempty + else text "Modules:" $+$ nest 4 (vcat (map pretty . sort . modules $ pkginfo)) + ] + ) + $+$ text "" where entry fname field cond format = case cond (field pkginfo) of - Nothing -> label <+> format (field pkginfo) - Just Nothing -> mempty + Nothing -> label <+> format (field pkginfo) + Just Nothing -> mempty Just (Just other) -> label <+> text other where - label = text fname Disp.<> char ':' Disp.<> padding - padding = text (replicate (13 - length fname ) ' ') + label = text fname Disp.<> char ':' Disp.<> padding + padding = text (replicate (13 - length fname) ' ') entryST fname field = entry fname (ShortText.fromShortText . field) - normal = Nothing - hide = Just Nothing + normal = Nothing + hide = Just Nothing replace msg = Just (Just msg) alwaysShow = const normal hideIfNull v = if null v then hide else normal showIfInstalled v | not isInstalled = hide - | null v = replace "[ Not installed ]" - | otherwise = normal + | null v = replace "[ Not installed ]" + | otherwise = normal altText nul msg v = if nul v then replace msg else normal orNotSpecified = altText null "[ Not specified ]" commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f dispFlag = text . unFlagName . flagName - dispYesNo True = text "Yes" + dispYesNo True = text "Yes" dispYesNo False = text "No" - dispExtDep (SourceDependency dep) = pretty dep + dispExtDep (SourceDependency dep) = pretty dep dispExtDep (InstalledDependency dep) = pretty dep isInstalled = not (null (installedVersions pkginfo)) hasExes = length (executables pkginfo) >= 2 - --TODO: exclude non-buildable exes - pkgkind | hasLib pkginfo && hasExes = text "programs and library" - | hasLib pkginfo && hasExe pkginfo = text "program and library" - | hasLib pkginfo = text "library" - | hasExes = text "programs" - | hasExe pkginfo = text "program" - | otherwise = mempty - + -- TODO: exclude non-buildable exes + pkgkind + | hasLib pkginfo && hasExes = text "programs and library" + | hasLib pkginfo && hasExe pkginfo = text "program and library" + | hasLib pkginfo = text "library" + | hasExes = text "programs" + | hasExe pkginfo = text "program" + | otherwise = mempty reflowParagraphs :: String -> Doc reflowParagraphs = - vcat - . intersperse (text "") -- re-insert blank lines - . map (fsep . map text . concatMap words) -- reflow paragraphs - . filter (/= [""]) - . L.groupBy (\x y -> "" `notElem` [x,y]) -- break on blank lines - . lines + vcat + . intersperse (text "") -- re-insert blank lines + . map (fsep . map text . concatMap words) -- reflow paragraphs + . filter (/= [""]) + . L.groupBy (\x y -> "" `notElem` [x, y]) -- break on blank lines + . lines reflowLines :: String -> Doc reflowLines = vcat . map text . lines @@ -435,147 +565,203 @@ reflowLines = vcat . map text . lines -- * We're building info about a various versions of a single named package so -- the input package info records are all supposed to refer to the same -- package name. --- -mergePackageInfo :: VersionRange - -> [Installed.InstalledPackageInfo] - -> [UnresolvedSourcePackage] - -> Maybe UnresolvedSourcePackage - -> Bool - -> PackageDisplayInfo +mergePackageInfo + :: VersionRange + -> [Installed.InstalledPackageInfo] + -> [UnresolvedSourcePackage] + -> Maybe UnresolvedSourcePackage + -> Bool + -> PackageDisplayInfo mergePackageInfo versionPref installedPkgs sourcePkgs selectedPkg showVer = assert (length installedPkgs + length sourcePkgs > 0) $ - PackageDisplayInfo { - pkgName = combine packageName source - packageName installed, - selectedVersion = if showVer then fmap packageVersion selectedPkg - else Nothing, - selectedSourcePkg = sourceSelected, - installedVersions = map packageVersion installedPkgs, - sourceVersions = map packageVersion sourcePkgs, - preferredVersions = versionPref, - - license = combine Source.licenseRaw source - Installed.license installed, - maintainer = combine Source.maintainer source - Installed.maintainer installed, - author = combine Source.author source - Installed.author installed, - homepage = combine Source.homepage source - Installed.homepage installed, - bugReports = maybe mempty Source.bugReports source, - sourceRepo = fromMaybe mempty . join - . fmap (uncons Nothing Source.repoLocation - . sortBy (comparing Source.repoKind) - . Source.sourceRepos) - $ source, - --TODO: installed package info is missing synopsis - synopsis = maybe mempty Source.synopsis source, - description = combine Source.description source - Installed.description installed, - category = combine Source.category source - Installed.category installed, - flags = maybe [] Source.genPackageFlags sourceGeneric, - hasLib = isJust installed - || maybe False (isJust . Source.condLibrary) sourceGeneric, - hasExe = maybe False (not . null . Source.condExecutables) sourceGeneric, - executables = map fst (maybe [] Source.condExecutables sourceGeneric), - modules = combine (map Installed.exposedName . Installed.exposedModules) - installed - -- NB: only for the PUBLIC library - (concatMap getListOfExposedModules . maybeToList . Source.library) - source, - dependencies = - combine (map (SourceDependency . simplifyDependency) - . Source.allBuildDepends) source - (map InstalledDependency . Installed.depends) installed, - haddockHtml = fromMaybe "" . join - . fmap (listToMaybe . Installed.haddockHTMLs) - $ installed, - haveTarball = False - } + PackageDisplayInfo + { pkgName = + combine + packageName + source + packageName + installed + , selectedVersion = + if showVer + then fmap packageVersion selectedPkg + else Nothing + , selectedSourcePkg = sourceSelected + , installedVersions = map packageVersion installedPkgs + , sourceVersions = map packageVersion sourcePkgs + , preferredVersions = versionPref + , license = + combine + Source.licenseRaw + source + Installed.license + installed + , maintainer = + combine + Source.maintainer + source + Installed.maintainer + installed + , author = + combine + Source.author + source + Installed.author + installed + , homepage = + combine + Source.homepage + source + Installed.homepage + installed + , bugReports = maybe mempty Source.bugReports source + , sourceRepo = + fromMaybe mempty + . join + . fmap + ( uncons Nothing Source.repoLocation + . sortBy (comparing Source.repoKind) + . Source.sourceRepos + ) + $ source + , -- TODO: installed package info is missing synopsis + synopsis = maybe mempty Source.synopsis source + , description = + combine + Source.description + source + Installed.description + installed + , category = + combine + Source.category + source + Installed.category + installed + , flags = maybe [] Source.genPackageFlags sourceGeneric + , hasLib = + isJust installed + || maybe False (isJust . Source.condLibrary) sourceGeneric + , hasExe = maybe False (not . null . Source.condExecutables) sourceGeneric + , executables = map fst (maybe [] Source.condExecutables sourceGeneric) + , modules = + combine + (map Installed.exposedName . Installed.exposedModules) + installed + -- NB: only for the PUBLIC library + (concatMap getListOfExposedModules . maybeToList . Source.library) + source + , dependencies = + combine + ( map (SourceDependency . simplifyDependency) + . Source.allBuildDepends + ) + source + (map InstalledDependency . Installed.depends) + installed + , haddockHtml = + fromMaybe "" + . join + . fmap (listToMaybe . Installed.haddockHTMLs) + $ installed + , haveTarball = False + } where - combine f x g y = fromJust (fmap f x `mplus` fmap g y) + combine f x g y = fromJust (fmap f x `mplus` fmap g y) installed :: Maybe Installed.InstalledPackageInfo installed = latestWithPref versionPref installedPkgs - getListOfExposedModules lib = Source.exposedModules lib - ++ map Source.moduleReexportName - (Source.reexportedModules lib) + getListOfExposedModules lib = + Source.exposedModules lib + ++ map + Source.moduleReexportName + (Source.reexportedModules lib) sourceSelected | isJust selectedPkg = selectedPkg - | otherwise = latestWithPref versionPref sourcePkgs + | otherwise = latestWithPref versionPref sourcePkgs sourceGeneric = fmap srcpkgDescription sourceSelected - source = fmap flattenPackageDescription sourceGeneric + source = fmap flattenPackageDescription sourceGeneric uncons :: b -> (a -> b) -> [a] -> b - uncons z _ [] = z - uncons _ f (x:_) = f x - + uncons z _ [] = z + uncons _ f (x : _) = f x -- | Not all the info is pure. We have to check if the docs really are -- installed, because the registered package info lies. Similarly we have to -- check if the tarball has indeed been fetched. --- updateFileSystemPackageDetails :: PackageDisplayInfo -> IO PackageDisplayInfo updateFileSystemPackageDetails pkginfo = do - fetched <- maybe (return False) (isFetched . srcpkgSource) - (selectedSourcePkg pkginfo) + fetched <- + maybe + (return False) + (isFetched . srcpkgSource) + (selectedSourcePkg pkginfo) docsExist <- doesDirectoryExist (haddockHtml pkginfo) - return pkginfo { - haveTarball = fetched, - haddockHtml = if docsExist then haddockHtml pkginfo else "" - } + return + pkginfo + { haveTarball = fetched + , haddockHtml = if docsExist then haddockHtml pkginfo else "" + } latestWithPref :: Package pkg => VersionRange -> [pkg] -> Maybe pkg -latestWithPref _ [] = Nothing +latestWithPref _ [] = Nothing latestWithPref pref pkgs = Just (maximumBy (comparing prefThenVersion) pkgs) where - prefThenVersion pkg = let ver = packageVersion pkg - in (withinRange ver pref, ver) - + prefThenVersion pkg = + let ver = packageVersion pkg + in (withinRange ver pref, ver) -- | Rearrange installed and source packages into groups referring to the -- same package by name. In the result pairs, the lists are guaranteed to not -- both be empty. --- -mergePackages :: [Installed.InstalledPackageInfo] - -> [UnresolvedSourcePackage] - -> [( PackageName - , [Installed.InstalledPackageInfo] - , [UnresolvedSourcePackage] )] +mergePackages + :: [Installed.InstalledPackageInfo] + -> [UnresolvedSourcePackage] + -> [ ( PackageName + , [Installed.InstalledPackageInfo] + , [UnresolvedSourcePackage] + ) + ] mergePackages installedPkgs sourcePkgs = - map collect - $ mergeBy (\i a -> fst i `compare` fst a) - (groupOn packageName installedPkgs) - (groupOn packageName sourcePkgs) + map collect $ + mergeBy + (\i a -> fst i `compare` fst a) + (groupOn packageName installedPkgs) + (groupOn packageName sourcePkgs) where - collect (OnlyInLeft (name,is) ) = (name, is, []) - collect ( InBoth (_,is) (name,as)) = (name, is, as) - collect (OnlyInRight (name,as)) = (name, [], as) + collect (OnlyInLeft (name, is)) = (name, is, []) + collect (InBoth (_, is) (name, as)) = (name, is, as) + collect (OnlyInRight (name, as)) = (name, [], as) -groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])] -groupOn key = map (\xs -> (key (head xs), toList xs)) - . groupBy (equating key) - . sortBy (comparing key) +groupOn :: Ord key => (a -> key) -> [a] -> [(key, [a])] +groupOn key = + map (\xs -> (key (head xs), toList xs)) + . groupBy (equating key) + . sortBy (comparing key) dispTopVersions :: Int -> VersionRange -> [Version] -> Doc dispTopVersions n pref vs = - (Disp.fsep . Disp.punctuate (Disp.char ',') - . map (\ver -> if ispref ver then pretty ver else parens (pretty ver)) - . sort . take n . interestingVersions ispref - $ vs) + ( Disp.fsep + . Disp.punctuate (Disp.char ',') + . map (\ver -> if ispref ver then pretty ver else parens (pretty ver)) + . sort + . take n + . interestingVersions ispref + $ vs + ) <+> trailingMessage - where ispref ver = withinRange ver pref extra = length vs - n trailingMessage | extra <= 0 = Disp.empty - | otherwise = Disp.parens $ Disp.text "and" - <+> Disp.int (length vs - n) - <+> if extra == 1 then Disp.text "other" - else Disp.text "others" + | otherwise = + Disp.parens $ + Disp.text "and" + <+> Disp.int (length vs - n) + <+> if extra == 1 + then Disp.text "other" + else Disp.text "others" -- | Reorder a bunch of versions to put the most interesting / significant -- versions first. A preferred version range is taken into account. @@ -584,30 +770,30 @@ dispTopVersions n pref vs = -- to present to the user, e.g. -- -- > let selectVersions = sort . take 5 . interestingVersions pref --- interestingVersions :: (Version -> Bool) -> [Version] -> [Version] interestingVersions pref = - map (mkVersion . fst) . filter snd - . concat . Tree.levels + map (mkVersion . fst) + . filter snd + . concat + . Tree.levels . swizzleTree - . reorderTree (\(Node (v,_) _) -> pref (mkVersion v)) + . reorderTree (\(Node (v, _) _) -> pref (mkVersion v)) . reverseTree . mkTree . map (or0 . versionNumbers) - where - or0 [] = 0 :| [] - or0 (x:xs) = x :| xs + or0 [] = 0 :| [] + or0 (x : xs) = x :| xs swizzleTree = unfoldTree (spine []) where - spine ts' (Node x []) = (x, ts') - spine ts' (Node x (t:ts)) = spine (Node x ts:ts') t + spine ts' (Node x []) = (x, ts') + spine ts' (Node x (t : ts)) = spine (Node x ts : ts') t reorderTree _ (Node x []) = Node x [] reorderTree p (Node x ts) = Node x (ts' ++ ts'') where - (ts',ts'') = partition p (map (reorderTree p) ts) + (ts', ts'') = partition p (map (reorderTree p) ts) reverseTree (Node x cs) = Node x (reverse (map reverseTree cs)) @@ -615,13 +801,14 @@ interestingVersions pref = mkTree xs = unfoldTree step (False, [], xs) where step :: (Bool, [a], [NonEmpty a]) -> (([a], Bool), [(Bool, [a], [NonEmpty a])]) - step (node,ns,vs) = + step (node, ns, vs) = ( (reverse ns, node) - , [ (any null vs', n:ns, mapMaybe nonEmpty (toList vs')) + , [ (any null vs', n : ns, mapMaybe nonEmpty (toList vs')) | (n, vs') <- groups vs ] ) groups :: [NonEmpty a] -> [(a, NonEmpty [a])] - groups = map (\g -> (head (head g), fmap tail g)) - . groupBy (equating head) + groups = + map (\g -> (head (head g), fmap tail g)) + . groupBy (equating head) diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs index 889fa634390..1a3cc94d49f 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/cabal-install/src/Distribution/Client/Main.hs @@ -3,6 +3,9 @@ {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Main -- Copyright : (c) David Himmelstrup 2005 @@ -15,166 +18,254 @@ -- Entry point to the default cabal-install front-end. -- -- @since 3.10.0.0 ------------------------------------------------------------------------------ - module Distribution.Client.Main (main) where import Distribution.Client.Setup - ( GlobalFlags(..), globalCommand, withRepoContext - , ConfigFlags(..) - , ConfigExFlags(..), defaultConfigExFlags, configureExCommand - , reconfigureCommand - , configCompilerAux', configPackageDB' - , BuildFlags(..) - , buildCommand, replCommand, testCommand, benchmarkCommand - , InstallFlags(..), defaultInstallFlags - , installCommand - , FetchFlags(..), fetchCommand - , FreezeFlags(..), freezeCommand - , genBoundsCommand - , GetFlags(..), getCommand, unpackCommand - , checkCommand - , formatCommand - , ListFlags(..), listCommand, listNeedsCompiler - , InfoFlags(..), infoCommand - , UploadFlags(..), uploadCommand - , ReportFlags(..), reportCommand - , runCommand - , InitFlags(initVerbosity, initHcPath), initCommand - , ActAsSetupFlags(..), actAsSetupCommand - , UserConfigFlags(..), userConfigCommand - , reportCommand - , manpageCommand - , haddockCommand - , cleanCommand - , copyCommand - , registerCommand - ) + ( ActAsSetupFlags (..) + , BuildFlags (..) + , ConfigExFlags (..) + , ConfigFlags (..) + , FetchFlags (..) + , FreezeFlags (..) + , GetFlags (..) + , GlobalFlags (..) + , InfoFlags (..) + , InitFlags (initHcPath, initVerbosity) + , InstallFlags (..) + , ListFlags (..) + , ReportFlags (..) + , UploadFlags (..) + , UserConfigFlags (..) + , actAsSetupCommand + , benchmarkCommand + , buildCommand + , checkCommand + , cleanCommand + , configCompilerAux' + , configPackageDB' + , configureExCommand + , copyCommand + , defaultConfigExFlags + , defaultInstallFlags + , fetchCommand + , formatCommand + , freezeCommand + , genBoundsCommand + , getCommand + , globalCommand + , haddockCommand + , infoCommand + , initCommand + , installCommand + , listCommand + , listNeedsCompiler + , manpageCommand + , reconfigureCommand + , registerCommand + , replCommand + , reportCommand + , runCommand + , testCommand + , unpackCommand + , uploadCommand + , userConfigCommand + , withRepoContext + ) import Distribution.Simple.Setup - ( HaddockTarget(..) - , HaddockFlags(..), defaultHaddockFlags - , HscolourFlags(..), hscolourCommand - , ReplFlags(..) - , CopyFlags(..) - , RegisterFlags(..) - , CleanFlags(..) - , TestFlags(..), BenchmarkFlags(..) - , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag - , configAbsolutePaths - ) + ( BenchmarkFlags (..) + , CleanFlags (..) + , CopyFlags (..) + , Flag (..) + , HaddockFlags (..) + , HaddockTarget (..) + , HscolourFlags (..) + , RegisterFlags (..) + , ReplFlags (..) + , TestFlags (..) + , configAbsolutePaths + , defaultHaddockFlags + , flagToMaybe + , fromFlag + , fromFlagOrDefault + , hscolourCommand + , toFlag + ) -import Prelude () import Distribution.Client.Compat.Prelude hiding (get) +import Prelude () -import Distribution.Client.SetupWrapper - ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) import Distribution.Client.Config - ( SavedConfig(..), loadConfig, defaultConfigFile, userConfigDiff - , userConfigUpdate, createDefaultConfigFile, getConfigFilePath ) -import Distribution.Client.Targets - ( readUserTargets ) + ( SavedConfig (..) + , createDefaultConfigFile + , defaultConfigFile + , getConfigFilePath + , loadConfig + , userConfigDiff + , userConfigUpdate + ) import qualified Distribution.Client.List as List - ( list, info ) + ( info + , list + ) +import Distribution.Client.SetupWrapper + ( SetupScriptOptions (..) + , defaultSetupScriptOptions + , setupWrapper + ) +import Distribution.Client.Targets + ( readUserTargets + ) +import qualified Distribution.Client.CmdBench as CmdBench +import qualified Distribution.Client.CmdBuild as CmdBuild +import qualified Distribution.Client.CmdClean as CmdClean import qualified Distribution.Client.CmdConfigure as CmdConfigure -import qualified Distribution.Client.CmdUpdate as CmdUpdate -import qualified Distribution.Client.CmdBuild as CmdBuild -import qualified Distribution.Client.CmdRepl as CmdRepl -import qualified Distribution.Client.CmdFreeze as CmdFreeze -import qualified Distribution.Client.CmdHaddock as CmdHaddock +import qualified Distribution.Client.CmdExec as CmdExec +import qualified Distribution.Client.CmdFreeze as CmdFreeze +import qualified Distribution.Client.CmdHaddock as CmdHaddock import qualified Distribution.Client.CmdHaddockProject as CmdHaddockProject -import qualified Distribution.Client.CmdInstall as CmdInstall -import qualified Distribution.Client.CmdRun as CmdRun -import qualified Distribution.Client.CmdTest as CmdTest -import qualified Distribution.Client.CmdBench as CmdBench -import qualified Distribution.Client.CmdExec as CmdExec -import qualified Distribution.Client.CmdClean as CmdClean -import qualified Distribution.Client.CmdSdist as CmdSdist -import qualified Distribution.Client.CmdListBin as CmdListBin -import qualified Distribution.Client.CmdOutdated as CmdOutdated -import Distribution.Client.CmdLegacy - -import Distribution.Client.Install (install) -import Distribution.Client.Configure (configure, writeConfigFlags) -import Distribution.Client.Fetch (fetch) -import Distribution.Client.Freeze (freeze) -import Distribution.Client.GenBounds (genBounds) -import Distribution.Client.Check as Check (check) ---import Distribution.Client.Clean (clean) +import qualified Distribution.Client.CmdInstall as CmdInstall +import Distribution.Client.CmdLegacy +import qualified Distribution.Client.CmdListBin as CmdListBin +import qualified Distribution.Client.CmdOutdated as CmdOutdated +import qualified Distribution.Client.CmdRepl as CmdRepl +import qualified Distribution.Client.CmdRun as CmdRun +import qualified Distribution.Client.CmdSdist as CmdSdist +import qualified Distribution.Client.CmdTest as CmdTest +import qualified Distribution.Client.CmdUpdate as CmdUpdate + +import Distribution.Client.Check as Check (check) +import Distribution.Client.Configure (configure, writeConfigFlags) +import Distribution.Client.Fetch (fetch) +import Distribution.Client.Freeze (freeze) +import Distribution.Client.GenBounds (genBounds) +import Distribution.Client.Install (install) + +-- import Distribution.Client.Clean (clean) + +import Distribution.Client.Get (get) +import Distribution.Client.Init (initCmd) +import Distribution.Client.Manpage (manpageCmd) +import Distribution.Client.ManpageFlags (ManpageFlags (..)) +import Distribution.Client.Nix + ( nixInstantiate + , nixShell + ) +import Distribution.Client.Reconfigure (Check (..), reconfigure) +import Distribution.Client.Run (run, splitRunArgs) +import Distribution.Client.Sandbox + ( findSavedDistPref + , loadConfigOrSandboxConfig + , updateInstallDirs + ) +import Distribution.Client.Signal + ( installTerminationHandler + ) +import Distribution.Client.Tar (createTarGzFile) +import Distribution.Client.Types.Credentials (Password (..)) import qualified Distribution.Client.Upload as Upload -import Distribution.Client.Run (run, splitRunArgs) -import Distribution.Client.Get (get) -import Distribution.Client.Reconfigure (Check(..), reconfigure) -import Distribution.Client.Nix (nixInstantiate - ,nixShell - ) -import Distribution.Client.Sandbox (loadConfigOrSandboxConfig - ,findSavedDistPref - ,updateInstallDirs) -import Distribution.Client.Tar (createTarGzFile) -import Distribution.Client.Types.Credentials (Password (..)) -import Distribution.Client.Init (initCmd) -import Distribution.Client.Manpage (manpageCmd) -import Distribution.Client.ManpageFlags (ManpageFlags (..)) import Distribution.Client.Utils - ( determineNumJobs, relaxEncodingErrors ) -import Distribution.Client.Signal - ( installTerminationHandler ) + ( determineNumJobs + , relaxEncodingErrors + ) import Distribution.Client.Version - ( cabalInstallVersion ) + ( cabalInstallVersion + ) import Distribution.Package (packageId) import Distribution.PackageDescription - ( BuildType(..), Executable(..), buildable ) + ( BuildType (..) + , Executable (..) + , buildable + ) +import qualified Distribution.Make as Make import Distribution.PackageDescription.PrettyPrint - ( writeGenericPackageDescription ) + ( writeGenericPackageDescription + ) import qualified Distribution.Simple as Simple -import qualified Distribution.Make as Make -import qualified Distribution.Types.UnqualComponentName as Make import Distribution.Simple.Build - ( startInterpreter ) + ( startInterpreter + ) import Distribution.Simple.Command - ( CommandParse(..), CommandUI(..), Command, CommandSpec(..) - , CommandType(..), commandsRun, commandAddAction, hiddenCommand - , commandFromSpec, commandShowOptions ) + ( Command + , CommandParse (..) + , CommandSpec (..) + , CommandType (..) + , CommandUI (..) + , commandAddAction + , commandFromSpec + , commandShowOptions + , commandsRun + , hiddenCommand + ) import Distribution.Simple.Compiler (PackageDBStack) import Distribution.Simple.Configure - ( configCompilerAuxEx, ConfigStateFileError(..) - , getPersistBuildConfig, interpretPackageDbFlags - , tryGetPersistBuildConfig ) + ( ConfigStateFileError (..) + , configCompilerAuxEx + , getPersistBuildConfig + , interpretPackageDbFlags + , tryGetPersistBuildConfig + ) import qualified Distribution.Simple.LocalBuildInfo as LBI -import Distribution.Simple.PackageDescription ( readGenericPackageDescription ) -import Distribution.Simple.Program (defaultProgramDb - ,configureAllKnownPrograms - ,simpleProgramInvocation - ,getProgramInvocationOutput) +import Distribution.Simple.PackageDescription (readGenericPackageDescription) +import Distribution.Simple.Program + ( configureAllKnownPrograms + , defaultProgramDb + , getProgramInvocationOutput + , simpleProgramInvocation + ) import Distribution.Simple.Program.Db (reconfigurePrograms) import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Utils - ( cabalVersion, die', dieNoVerbosity, info, notice, topHandler - , findPackageDesc, tryFindPackageDesc, createDirectoryIfMissingVerbose ) + ( cabalVersion + , createDirectoryIfMissingVerbose + , die' + , dieNoVerbosity + , findPackageDesc + , info + , notice + , topHandler + , tryFindPackageDesc + ) import Distribution.Text - ( display ) + ( display + ) +import qualified Distribution.Types.UnqualComponentName as Make import Distribution.Verbosity as Verbosity - ( normal ) + ( normal + ) import Distribution.Version - ( Version, mkVersion, orLaterVersion ) + ( Version + , mkVersion + , orLaterVersion + ) +import Control.Exception (AssertionFailed, assert, try) +import Data.Monoid (Any (..)) import Distribution.Compat.ResponseFile -import System.Environment (getProgName) -import System.FilePath ( dropExtension, splitExtension - , takeExtension, (), (<.>) ) -import System.IO ( BufferMode(LineBuffering), hSetBuffering - , hPutStrLn, stderr, stdout ) -import System.Directory ( doesFileExist, getCurrentDirectory - , withCurrentDirectory) -import Data.Monoid (Any(..)) -import Control.Exception (AssertionFailed, assert, try) - +import System.Directory + ( doesFileExist + , getCurrentDirectory + , withCurrentDirectory + ) +import System.Environment (getProgName) +import System.FilePath + ( dropExtension + , splitExtension + , takeExtension + , (<.>) + , () + ) +import System.IO + ( BufferMode (LineBuffering) + , hPutStrLn + , hSetBuffering + , stderr + , stdout + ) -- | Entry point --- main :: [String] -> IO () main args = do installTerminationHandler @@ -194,12 +285,13 @@ main args = do -- | Check whether assertions are enabled and print a warning in that case. warnIfAssertionsAreEnabled :: IO () warnIfAssertionsAreEnabled = - assert False (return ()) `catch` - (\(_e :: AssertionFailed) -> hPutStrLn stderr assertionsEnabledMsg) + assert False (return ()) + `catch` (\(_e :: AssertionFailed) -> hPutStrLn stderr assertionsEnabledMsg) + where -- Andreas, 2022-12-30, issue #8654: -- The verbosity machinery is not in place at this point (option -v not parsed), -- so instead of using function @warn@, we print straight to stderr. - where + assertionsEnabledMsg = "Warning: this is a debug build of cabal-install with assertions enabled." @@ -207,34 +299,33 @@ mainWorker :: [String] -> IO () mainWorker args = do topHandler $ case commandsRun (globalCommand commands) commands args of - CommandHelp help -> printGlobalHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo (globalFlags, commandParse) -> + CommandHelp help -> printGlobalHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (globalFlags, commandParse) -> case commandParse of - _ | fromFlagOrDefault False (globalVersion globalFlags) - -> printVersion - | fromFlagOrDefault False (globalNumericVersion globalFlags) - -> printNumericVersion - CommandHelp help -> printCommandHelp help - CommandList opts -> printOptionsList opts - - CommandErrors errs -> do + _ + | fromFlagOrDefault False (globalVersion globalFlags) -> + printVersion + | fromFlagOrDefault False (globalNumericVersion globalFlags) -> + printNumericVersion + CommandHelp help -> printCommandHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> do -- Check whether cabal is called from a script, like #!/path/to/cabal. case args of - [] -> printErrors errs - script : scriptArgs -> CmdRun.validScript script >>= \case - False -> printErrors errs - True -> do - -- In main operation (not help, version etc.) print warning if assertions are on. - warnIfAssertionsAreEnabled - CmdRun.handleShebang script scriptArgs - - CommandReadyToGo action -> do + [] -> printErrors errs + script : scriptArgs -> + CmdRun.validScript script >>= \case + False -> printErrors errs + True -> do + -- In main operation (not help, version etc.) print warning if assertions are on. + warnIfAssertionsAreEnabled + CmdRun.handleShebang script scriptArgs + CommandReadyToGo action -> do -- In main operation (not help, version etc.) print warning if assertions are on. warnIfAssertionsAreEnabled action globalFlags - where printCommandHelp help = do pname <- getProgName @@ -243,20 +334,26 @@ mainWorker args = do pname <- getProgName configFile <- defaultConfigFile putStr (help pname) - putStr $ "\nYou can edit the cabal configuration file to set defaults:\n" - ++ " " ++ configFile ++ "\n" + putStr $ + "\nYou can edit the cabal configuration file to set defaults:\n" + ++ " " + ++ configFile + ++ "\n" exists <- doesFileExist configFile unless exists $ - putStrLn $ "This file will be generated with sensible " - ++ "defaults if you run 'cabal update'." + putStrLn $ + "This file will be generated with sensible " + ++ "defaults if you run 'cabal update'." printOptionsList = putStr . unlines printErrors errs = dieNoVerbosity $ intercalate "\n" errs printNumericVersion = putStrLn $ display cabalInstallVersion - printVersion = putStrLn $ "cabal-install version " - ++ display cabalInstallVersion - ++ "\ncompiled using version " - ++ display cabalVersion - ++ " of the Cabal library " + printVersion = + putStrLn $ + "cabal-install version " + ++ display cabalInstallVersion + ++ "\ncompiled using version " + ++ display cabalVersion + ++ " of the Cabal library " commands = map commandFromSpec commandSpecs commandSpecs = @@ -273,112 +370,145 @@ mainWorker args = do , regularCmd genBoundsCommand genBoundsAction , regularCmd CmdOutdated.outdatedCommand CmdOutdated.outdatedAction , wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref - , hiddenCmd formatCommand formatAction - , hiddenCmd actAsSetupCommand actAsSetupAction - , hiddenCmd manpageCommand (manpageAction commandSpecs) - , regularCmd CmdListBin.listbinCommand CmdListBin.listbinAction - - ] ++ concat - [ newCmd CmdConfigure.configureCommand CmdConfigure.configureAction - , newCmd CmdUpdate.updateCommand CmdUpdate.updateAction - , newCmd CmdBuild.buildCommand CmdBuild.buildAction - , newCmd CmdRepl.replCommand CmdRepl.replAction - , newCmd CmdFreeze.freezeCommand CmdFreeze.freezeAction - , newCmd CmdHaddock.haddockCommand CmdHaddock.haddockAction - , newCmd CmdHaddockProject.haddockProjectCommand - CmdHaddockProject.haddockProjectAction - , newCmd CmdInstall.installCommand CmdInstall.installAction - , newCmd CmdRun.runCommand CmdRun.runAction - , newCmd CmdTest.testCommand CmdTest.testAction - , newCmd CmdBench.benchCommand CmdBench.benchAction - , newCmd CmdExec.execCommand CmdExec.execAction - , newCmd CmdClean.cleanCommand CmdClean.cleanAction - , newCmd CmdSdist.sdistCommand CmdSdist.sdistAction - - , legacyCmd configureExCommand configureAction - , legacyCmd buildCommand buildAction - , legacyCmd replCommand replAction - , legacyCmd freezeCommand freezeAction - , legacyCmd haddockCommand haddockAction - , legacyCmd installCommand installAction - , legacyCmd runCommand runAction - , legacyCmd testCommand testAction - , legacyCmd benchmarkCommand benchmarkAction - , legacyCmd cleanCommand cleanAction - , legacyWrapperCmd copyCommand copyVerbosity copyDistPref - , legacyWrapperCmd registerCommand regVerbosity regDistPref - , legacyCmd reconfigureCommand reconfigureAction + , hiddenCmd formatCommand formatAction + , hiddenCmd actAsSetupCommand actAsSetupAction + , hiddenCmd manpageCommand (manpageAction commandSpecs) + , regularCmd CmdListBin.listbinCommand CmdListBin.listbinAction ] + ++ concat + [ newCmd CmdConfigure.configureCommand CmdConfigure.configureAction + , newCmd CmdUpdate.updateCommand CmdUpdate.updateAction + , newCmd CmdBuild.buildCommand CmdBuild.buildAction + , newCmd CmdRepl.replCommand CmdRepl.replAction + , newCmd CmdFreeze.freezeCommand CmdFreeze.freezeAction + , newCmd CmdHaddock.haddockCommand CmdHaddock.haddockAction + , newCmd + CmdHaddockProject.haddockProjectCommand + CmdHaddockProject.haddockProjectAction + , newCmd CmdInstall.installCommand CmdInstall.installAction + , newCmd CmdRun.runCommand CmdRun.runAction + , newCmd CmdTest.testCommand CmdTest.testAction + , newCmd CmdBench.benchCommand CmdBench.benchAction + , newCmd CmdExec.execCommand CmdExec.execAction + , newCmd CmdClean.cleanCommand CmdClean.cleanAction + , newCmd CmdSdist.sdistCommand CmdSdist.sdistAction + , legacyCmd configureExCommand configureAction + , legacyCmd buildCommand buildAction + , legacyCmd replCommand replAction + , legacyCmd freezeCommand freezeAction + , legacyCmd haddockCommand haddockAction + , legacyCmd installCommand installAction + , legacyCmd runCommand runAction + , legacyCmd testCommand testAction + , legacyCmd benchmarkCommand benchmarkAction + , legacyCmd cleanCommand cleanAction + , legacyWrapperCmd copyCommand copyVerbosity copyDistPref + , legacyWrapperCmd registerCommand regVerbosity regDistPref + , legacyCmd reconfigureCommand reconfigureAction + ] type Action = GlobalFlags -> IO () -- Duplicated in Distribution.Client.CmdLegacy. Any changes must be -- reflected there, as well. -regularCmd :: CommandUI flags -> (flags -> [String] -> action) - -> CommandSpec action +regularCmd + :: CommandUI flags + -> (flags -> [String] -> action) + -> CommandSpec action regularCmd ui action = CommandSpec ui ((flip commandAddAction) action) NormalCommand -hiddenCmd :: CommandUI flags -> (flags -> [String] -> action) - -> CommandSpec action +hiddenCmd + :: CommandUI flags + -> (flags -> [String] -> action) + -> CommandSpec action hiddenCmd ui action = - CommandSpec ui (\ui' -> hiddenCommand (commandAddAction ui' action)) - HiddenCommand - -wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity) - -> (flags -> Flag String) -> CommandSpec Action + CommandSpec + ui + (\ui' -> hiddenCommand (commandAddAction ui' action)) + HiddenCommand + +wrapperCmd + :: Monoid flags + => CommandUI flags + -> (flags -> Flag Verbosity) + -> (flags -> Flag String) + -> CommandSpec Action wrapperCmd ui verbosity distPref = CommandSpec ui (\ui' -> wrapperAction ui' verbosity distPref) NormalCommand -wrapperAction :: Monoid flags - => CommandUI flags - -> (flags -> Flag Verbosity) - -> (flags -> Flag String) - -> Command Action +wrapperAction + :: Monoid flags + => CommandUI flags + -> (flags -> Flag Verbosity) + -> (flags -> Flag String) + -> Command Action wrapperAction command verbosityFlag distPrefFlag = - commandAddAction command - { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do - let verbosity = fromFlagOrDefault normal (verbosityFlag flags) - load <- try (loadConfigOrSandboxConfig verbosity globalFlags) - let config = either (\(SomeException _) -> mempty) id load - distPref <- findSavedDistPref config (distPrefFlag flags) - let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref } - setupWrapper verbosity setupScriptOptions Nothing - command (const flags) (const extraArgs) - -configureAction :: (ConfigFlags, ConfigExFlags) - -> [String] -> Action + commandAddAction + command + { commandDefaultFlags = mempty + } + $ \flags extraArgs globalFlags -> do + let verbosity = fromFlagOrDefault normal (verbosityFlag flags) + load <- try (loadConfigOrSandboxConfig verbosity globalFlags) + let config = either (\(SomeException _) -> mempty) id load + distPref <- findSavedDistPref config (distPrefFlag flags) + let setupScriptOptions = defaultSetupScriptOptions{useDistPref = distPref} + setupWrapper + verbosity + setupScriptOptions + Nothing + command + (const flags) + (const extraArgs) + +configureAction + :: (ConfigFlags, ConfigExFlags) + -> [String] + -> Action configureAction (configFlags, configExFlags) extraArgs globalFlags = do let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - config <- updateInstallDirs (configUserInstall configFlags) - <$> loadConfigOrSandboxConfig verbosity globalFlags + config <- + updateInstallDirs (configUserInstall configFlags) + <$> loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config (configDistPref configFlags) nixInstantiate verbosity distPref True globalFlags config nixShell verbosity distPref globalFlags config $ do - let configFlags' = savedConfigureFlags config `mappend` configFlags + let configFlags' = savedConfigureFlags config `mappend` configFlags configExFlags' = savedConfigureExFlags config `mappend` configExFlags - globalFlags' = savedGlobalFlags config `mappend` globalFlags + globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, platform, progdb) <- configCompilerAuxEx configFlags' writeConfigFlags verbosity distPref (configFlags', configExFlags') -- What package database(s) to use let packageDBs :: PackageDBStack - packageDBs - = interpretPackageDbFlags + packageDBs = + interpretPackageDbFlags (fromFlag (configUserInstall configFlags')) (configPackageDBs configFlags') withRepoContext verbosity globalFlags' $ \repoContext -> - configure verbosity packageDBs repoContext - comp platform progdb configFlags' configExFlags' extraArgs - -reconfigureAction :: (ConfigFlags, ConfigExFlags) - -> [String] -> Action + configure + verbosity + packageDBs + repoContext + comp + platform + progdb + configFlags' + configExFlags' + extraArgs + +reconfigureAction + :: (ConfigFlags, ConfigExFlags) + -> [String] + -> Action reconfigureAction flags@(configFlags, _) _ globalFlags = do let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - config <- updateInstallDirs (configUserInstall configFlags) - <$> loadConfigOrSandboxConfig verbosity globalFlags + config <- + updateInstallDirs (configUserInstall configFlags) + <$> loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config (configDistPref configFlags) let checkFlags = Check $ \_ saved -> do let flags' = saved <> flags @@ -387,15 +517,21 @@ reconfigureAction flags@(configFlags, _) _ globalFlags = do where -- This message is correct, but not very specific: it will list all -- of the new flags, even if some have not actually changed. The - -- *minimal* set of changes is more difficult to determine. + -- \*minimal* set of changes is more difficult to determine. message = "flags changed: " - ++ unwords (commandShowOptions configureExCommand flags) + ++ unwords (commandShowOptions configureExCommand flags) nixInstantiate verbosity distPref True globalFlags config _ <- - reconfigure configureAction - verbosity distPref NoFlag - checkFlags [] globalFlags config + reconfigure + configureAction + verbosity + distPref + NoFlag + checkFlags + [] + globalFlags + config pure () buildAction :: BuildFlags -> [String] -> Action @@ -406,56 +542,69 @@ buildAction buildFlags extraArgs globalFlags = do -- Calls 'configureAction' to do the real work, so nothing special has to be -- done to support sandboxes. config' <- - reconfigure configureAction - verbosity distPref (buildNumJobs buildFlags) - mempty [] globalFlags config + reconfigure + configureAction + verbosity + distPref + (buildNumJobs buildFlags) + mempty + [] + globalFlags + config nixShell verbosity 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 config distPref buildFlags extraArgs = - setupWrapper verbosity setupOptions Nothing - (Cabal.buildCommand progDb) mkBuildFlags (const extraArgs) + setupWrapper + verbosity + setupOptions + Nothing + (Cabal.buildCommand progDb) + mkBuildFlags + (const extraArgs) where - progDb = defaultProgramDb - setupOptions = defaultSetupScriptOptions { useDistPref = distPref } + progDb = defaultProgramDb + setupOptions = defaultSetupScriptOptions{useDistPref = distPref} mkBuildFlags version = filterBuildFlags version config buildFlags' - buildFlags' = buildFlags - { buildVerbosity = toFlag verbosity - , buildDistPref = toFlag distPref - } + buildFlags' = + buildFlags + { buildVerbosity = toFlag verbosity + , buildDistPref = 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 - | version >= mkVersion [1,19,1] = buildFlags_latest + | version >= mkVersion [1, 19, 1] = buildFlags_latest -- Cabal < 1.19.1 doesn't support 'build -j'. - | otherwise = buildFlags_pre_1_19_1 + | otherwise = buildFlags_pre_1_19_1 where - buildFlags_pre_1_19_1 = buildFlags { - buildNumJobs = NoFlag - } - buildFlags_latest = buildFlags { - -- Take the 'jobs' setting config file into account. - buildNumJobs = Flag . Just . determineNumJobs $ - (numJobsConfigFlag `mappend` numJobsCmdLineFlag) - } - numJobsConfigFlag = installNumJobs . savedInstallFlags $ config + buildFlags_pre_1_19_1 = + buildFlags + { buildNumJobs = NoFlag + } + buildFlags_latest = + buildFlags + { -- Take the 'jobs' setting config file into account. + buildNumJobs = + Flag . Just . determineNumJobs $ + (numJobsConfigFlag `mappend` numJobsCmdLineFlag) + } + numJobsConfigFlag = installNumJobs . savedInstallFlags $ config numJobsCmdLineFlag = buildNumJobs buildFlags - replAction :: ReplFlags -> [String] -> Action replAction replFlags extraArgs globalFlags = do let verbosity = fromFlagOrDefault normal (replVerbosity replFlags) config <- loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config (replDistPref replFlags) - cwd <- getCurrentDirectory + cwd <- getCurrentDirectory pkgDesc <- findPackageDesc cwd let -- There is a .cabal file in the current directory: start a REPL and load @@ -464,18 +613,26 @@ replAction replFlags extraArgs globalFlags = do -- Calls 'configureAction' to do the real work, so nothing special has to -- be done to support sandboxes. _ <- - reconfigure configureAction - verbosity distPref NoFlag - mempty [] globalFlags config + reconfigure + configureAction + verbosity + distPref + NoFlag + mempty + [] + globalFlags + config let progDb = defaultProgramDb - setupOptions = defaultSetupScriptOptions - { useCabalVersion = orLaterVersion $ mkVersion [1,18,0] - , useDistPref = distPref - } - replFlags' = replFlags - { replVerbosity = toFlag verbosity - , replDistPref = toFlag distPref - } + setupOptions = + defaultSetupScriptOptions + { useCabalVersion = orLaterVersion $ mkVersion [1, 18, 0] + , useDistPref = distPref + } + replFlags' = + replFlags + { replVerbosity = toFlag verbosity + , replDistPref = toFlag distPref + } nixShell verbosity distPref globalFlags config $ setupWrapper verbosity setupOptions Nothing (Cabal.replCommand progDb) (const replFlags') (const extraArgs) @@ -485,130 +642,189 @@ replAction replFlags extraArgs globalFlags = do onNoPkgDesc = do let configFlags = savedConfigureFlags config (comp, platform, programDb) <- configCompilerAux' configFlags - programDb' <- reconfigurePrograms verbosity - (replProgramPaths replFlags) - (replProgramArgs replFlags) - programDb + programDb' <- + reconfigurePrograms + verbosity + (replProgramPaths replFlags) + (replProgramArgs replFlags) + programDb nixShell verbosity distPref globalFlags config $ do - startInterpreter verbosity programDb' comp platform - (configPackageDB' configFlags) + startInterpreter + verbosity + programDb' + comp + platform + (configPackageDB' configFlags) either (const onNoPkgDesc) (const onPkgDesc) pkgDesc -installAction :: ( ConfigFlags, ConfigExFlags, InstallFlags - , HaddockFlags, TestFlags, BenchmarkFlags ) - -> [String] -> Action +installAction + :: ( ConfigFlags + , ConfigExFlags + , InstallFlags + , HaddockFlags + , TestFlags + , BenchmarkFlags + ) + -> [String] + -> Action installAction (configFlags, _, installFlags, _, _, _) _ globalFlags | fromFlagOrDefault False (installOnly installFlags) = do let verb = fromFlagOrDefault normal (configVerbosity configFlags) config <- loadConfigOrSandboxConfig verb globalFlags dist <- findSavedDistPref config (configDistPref configFlags) - let setupOpts = defaultSetupScriptOptions { useDistPref = dist } + let setupOpts = defaultSetupScriptOptions{useDistPref = dist} setupWrapper - verb setupOpts Nothing - installCommand (const (mempty, mempty, mempty, mempty, mempty, mempty)) - (const []) - + verb + setupOpts + Nothing + installCommand + (const (mempty, mempty, mempty, mempty, mempty, mempty)) + (const []) installAction - ( configFlags, configExFlags, installFlags - , haddockFlags, testFlags, benchmarkFlags ) - extraArgs globalFlags = do - let verb = fromFlagOrDefault normal (configVerbosity configFlags) - config <- updateInstallDirs (configUserInstall configFlags) - <$> loadConfigOrSandboxConfig verb globalFlags - - dist <- findSavedDistPref config (configDistPref configFlags) - - do - targets <- readUserTargets verb extraArgs - - let configFlags' = maybeForceTests installFlags' $ - savedConfigureFlags config `mappend` - configFlags { configDistPref = toFlag dist } - configExFlags' = defaultConfigExFlags `mappend` - savedConfigureExFlags config `mappend` configExFlags - installFlags' = defaultInstallFlags `mappend` - savedInstallFlags config `mappend` installFlags - haddockFlags' = defaultHaddockFlags `mappend` - savedHaddockFlags config `mappend` - haddockFlags { haddockDistPref = toFlag dist } - testFlags' = Cabal.defaultTestFlags `mappend` - savedTestFlags config `mappend` - testFlags { testDistPref = toFlag dist } - benchmarkFlags' = Cabal.defaultBenchmarkFlags `mappend` - savedBenchmarkFlags config `mappend` - benchmarkFlags { benchmarkDistPref = toFlag dist } - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, platform, progdb) <- configCompilerAux' configFlags' - - -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the - -- future. - progdb' <- configureAllKnownPrograms verb progdb - - configFlags'' <- configAbsolutePaths configFlags' - - withRepoContext verb globalFlags' $ \repoContext -> - install verb - (configPackageDB' configFlags'') - repoContext - comp platform progdb' - globalFlags' configFlags'' configExFlags' - installFlags' haddockFlags' testFlags' benchmarkFlags' - targets - - where - -- '--run-tests' implies '--enable-tests'. - maybeForceTests installFlags' configFlags' = - if fromFlagOrDefault False (installRunTests installFlags') - then configFlags' { configTests = toFlag True } + ( configFlags + , configExFlags + , installFlags + , haddockFlags + , testFlags + , benchmarkFlags + ) + extraArgs + globalFlags = do + let verb = fromFlagOrDefault normal (configVerbosity configFlags) + config <- + updateInstallDirs (configUserInstall configFlags) + <$> loadConfigOrSandboxConfig verb globalFlags + + dist <- findSavedDistPref config (configDistPref configFlags) + + do + targets <- readUserTargets verb extraArgs + + let configFlags' = + maybeForceTests installFlags' $ + savedConfigureFlags config + `mappend` configFlags{configDistPref = toFlag dist} + configExFlags' = + defaultConfigExFlags + `mappend` savedConfigureExFlags config + `mappend` configExFlags + installFlags' = + defaultInstallFlags + `mappend` savedInstallFlags config + `mappend` installFlags + haddockFlags' = + defaultHaddockFlags + `mappend` savedHaddockFlags config + `mappend` haddockFlags{haddockDistPref = toFlag dist} + testFlags' = + Cabal.defaultTestFlags + `mappend` savedTestFlags config + `mappend` testFlags{testDistPref = toFlag dist} + benchmarkFlags' = + Cabal.defaultBenchmarkFlags + `mappend` savedBenchmarkFlags config + `mappend` benchmarkFlags{benchmarkDistPref = toFlag dist} + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, platform, progdb) <- configCompilerAux' configFlags' + + -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the + -- future. + progdb' <- configureAllKnownPrograms verb progdb + + configFlags'' <- configAbsolutePaths configFlags' + + withRepoContext verb globalFlags' $ \repoContext -> + install + verb + (configPackageDB' configFlags'') + repoContext + comp + platform + progdb' + globalFlags' + configFlags'' + configExFlags' + installFlags' + haddockFlags' + testFlags' + benchmarkFlags' + targets + where + -- '--run-tests' implies '--enable-tests'. + maybeForceTests installFlags' configFlags' = + if fromFlagOrDefault False (installRunTests installFlags') + then configFlags'{configTests = toFlag True} else configFlags' -testAction :: (BuildFlags, TestFlags) -> [String] -> GlobalFlags - -> IO () +testAction + :: (BuildFlags, TestFlags) + -> [String] + -> GlobalFlags + -> IO () testAction (buildFlags, testFlags) extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) + let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) config <- loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config (testDistPref testFlags) - let buildFlags' = buildFlags - { buildVerbosity = testVerbosity testFlags } + let buildFlags' = + buildFlags + { buildVerbosity = testVerbosity testFlags + } checkFlags = Check $ \_ flags@(configFlags, configExFlags) -> if fromFlagOrDefault False (configTests configFlags) then pure (mempty, flags) else do info verbosity "reconfiguring to enable tests" - let flags' = ( configFlags { configTests = toFlag True } - , configExFlags - ) + let flags' = + ( configFlags{configTests = toFlag True} + , configExFlags + ) pure (Any True, flags') _ <- - reconfigure configureAction - verbosity distPref (buildNumJobs buildFlags') - checkFlags [] globalFlags config + reconfigure + configureAction + verbosity + distPref + (buildNumJobs buildFlags') + checkFlags + [] + globalFlags + config nixShell verbosity distPref globalFlags config $ do - let setupOptions = defaultSetupScriptOptions { useDistPref = distPref } - testFlags' = testFlags { testDistPref = toFlag distPref } + let setupOptions = defaultSetupScriptOptions{useDistPref = distPref} + testFlags' = testFlags{testDistPref = toFlag distPref} -- The package was just configured, so the LBI must be available. - names <- componentNamesFromLBI verbosity distPref "test suites" - (\c -> case c of { LBI.CTest{} -> True; _ -> False }) + names <- + componentNamesFromLBI + verbosity + distPref + "test suites" + (\c -> case c of LBI.CTest{} -> True; _ -> False) let extraArgs' | null extraArgs = case names of - ComponentNamesUnknown -> [] - ComponentNames names' -> [ Make.unUnqualComponentName name - | LBI.CTestName name <- names' ] - | otherwise = extraArgs + ComponentNamesUnknown -> [] + ComponentNames names' -> + [ Make.unUnqualComponentName name + | LBI.CTestName name <- names' + ] + | otherwise = extraArgs build verbosity config distPref buildFlags' extraArgs' setupWrapper verbosity setupOptions Nothing Cabal.testCommand (const testFlags') (const extraArgs') -data ComponentNames = ComponentNamesUnknown - | ComponentNames [LBI.ComponentName] +data ComponentNames + = ComponentNamesUnknown + | ComponentNames [LBI.ComponentName] -- | Return the names of all buildable components matching a given predicate. -componentNamesFromLBI :: Verbosity -> FilePath -> String - -> (LBI.Component -> Bool) - -> IO ComponentNames +componentNamesFromLBI + :: Verbosity + -> FilePath + -> String + -> (LBI.Component -> Bool) + -> IO ComponentNames componentNamesFromLBI verbosity distPref targetsDescr compPred = do eLBI <- tryGetPersistBuildConfig distPref case eLBI of @@ -617,64 +833,87 @@ componentNamesFromLBI verbosity distPref targetsDescr compPred = do -- script built against a different Cabal version, so it's crucial that -- we ignore the bad version error here. ConfigStateFileBadVersion _ _ _ -> return ComponentNamesUnknown - _ -> die' verbosity (show err) + _ -> die' verbosity (show err) Right lbi -> do let pkgDescr = LBI.localPkgDescr lbi - names = map LBI.componentName - . filter (buildable . LBI.componentBuildInfo) - . filter compPred $ - LBI.pkgComponents pkgDescr + names = + map LBI.componentName + . filter (buildable . LBI.componentBuildInfo) + . filter compPred + $ LBI.pkgComponents pkgDescr if null names - then do notice verbosity $ "Package has no buildable " - ++ targetsDescr ++ "." - exitSuccess -- See #3215. - + then do + notice verbosity $ + "Package has no buildable " + ++ targetsDescr + ++ "." + exitSuccess -- See #3215. else return $! (ComponentNames names) -benchmarkAction :: (BuildFlags, BenchmarkFlags) - -> [String] -> GlobalFlags - -> IO () +benchmarkAction + :: (BuildFlags, BenchmarkFlags) + -> [String] + -> GlobalFlags + -> IO () benchmarkAction (buildFlags, benchmarkFlags) - extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal - (buildVerbosity buildFlags) - - config <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (benchmarkDistPref benchmarkFlags) - let buildFlags' = buildFlags - { buildVerbosity = benchmarkVerbosity benchmarkFlags } - - let checkFlags = Check $ \_ flags@(configFlags, configExFlags) -> - if fromFlagOrDefault False (configBenchmarks configFlags) - then pure (mempty, flags) - else do - info verbosity "reconfiguring to enable benchmarks" - let flags' = ( configFlags { configBenchmarks = toFlag True } - , configExFlags - ) - pure (Any True, flags') - - config' <- - reconfigure configureAction - verbosity distPref (buildNumJobs buildFlags') - checkFlags [] globalFlags config - nixShell verbosity distPref globalFlags config $ do - let setupOptions = defaultSetupScriptOptions { useDistPref = distPref } - benchmarkFlags'= benchmarkFlags { benchmarkDistPref = toFlag distPref } - - -- The package was just configured, so the LBI must be available. - names <- componentNamesFromLBI verbosity distPref "benchmarks" - (\c -> case c of { LBI.CBench{} -> True; _ -> False; }) - let extraArgs' - | null extraArgs = case names of - ComponentNamesUnknown -> [] - ComponentNames names' -> [ Make.unUnqualComponentName name - | LBI.CBenchName name <- names'] - | otherwise = extraArgs + extraArgs + globalFlags = do + let verbosity = + fromFlagOrDefault + normal + (buildVerbosity buildFlags) + + config <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (benchmarkDistPref benchmarkFlags) + let buildFlags' = + buildFlags + { buildVerbosity = benchmarkVerbosity benchmarkFlags + } - build verbosity config' distPref buildFlags' extraArgs' - setupWrapper verbosity setupOptions Nothing Cabal.benchmarkCommand (const benchmarkFlags') (const extraArgs') + let checkFlags = Check $ \_ flags@(configFlags, configExFlags) -> + if fromFlagOrDefault False (configBenchmarks configFlags) + then pure (mempty, flags) + else do + info verbosity "reconfiguring to enable benchmarks" + let flags' = + ( configFlags{configBenchmarks = toFlag True} + , configExFlags + ) + pure (Any True, flags') + + config' <- + reconfigure + configureAction + verbosity + distPref + (buildNumJobs buildFlags') + checkFlags + [] + globalFlags + config + nixShell verbosity distPref globalFlags config $ do + let setupOptions = defaultSetupScriptOptions{useDistPref = distPref} + benchmarkFlags' = benchmarkFlags{benchmarkDistPref = toFlag distPref} + + -- The package was just configured, so the LBI must be available. + names <- + componentNamesFromLBI + verbosity + distPref + "benchmarks" + (\c -> case c of LBI.CBench{} -> True; _ -> False) + let extraArgs' + | null extraArgs = case names of + ComponentNamesUnknown -> [] + ComponentNames names' -> + [ Make.unUnqualComponentName name + | LBI.CBenchName name <- names' + ] + | otherwise = extraArgs + + build verbosity config' distPref buildFlags' extraArgs' + setupWrapper verbosity setupOptions Nothing Cabal.benchmarkCommand (const benchmarkFlags') (const extraArgs') haddockAction :: HaddockFlags -> [String] -> Action haddockAction haddockFlags extraArgs globalFlags = do @@ -682,17 +921,31 @@ haddockAction haddockFlags extraArgs globalFlags = do config <- loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config (haddockDistPref haddockFlags) config' <- - reconfigure configureAction - verbosity distPref NoFlag - mempty [] globalFlags config + reconfigure + configureAction + verbosity + distPref + NoFlag + mempty + [] + globalFlags + config nixShell verbosity distPref globalFlags config $ do - let haddockFlags' = defaultHaddockFlags `mappend` - savedHaddockFlags config' `mappend` - haddockFlags { haddockDistPref = toFlag distPref } - setupScriptOptions = defaultSetupScriptOptions - { useDistPref = distPref } - setupWrapper verbosity setupScriptOptions Nothing - haddockCommand (const haddockFlags') (const extraArgs) + let haddockFlags' = + defaultHaddockFlags + `mappend` savedHaddockFlags config' + `mappend` haddockFlags{haddockDistPref = toFlag distPref} + setupScriptOptions = + defaultSetupScriptOptions + { useDistPref = distPref + } + setupWrapper + verbosity + setupScriptOptions + Nothing + haddockCommand + (const haddockFlags') + (const extraArgs) when (haddockForHackage haddockFlags == Flag ForHackage) $ do pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) let dest = distPref name <.> "tar.gz" @@ -706,13 +959,19 @@ cleanAction cleanFlags extraArgs globalFlags = do load <- try (loadConfigOrSandboxConfig verbosity globalFlags) let config = either (\(SomeException _) -> mempty) id load distPref <- findSavedDistPref config (cleanDistPref cleanFlags) - let setupScriptOptions = defaultSetupScriptOptions - { useDistPref = distPref - , useWin32CleanHack = True - } - cleanFlags' = cleanFlags { cleanDistPref = toFlag distPref } - setupWrapper verbosity setupScriptOptions Nothing - cleanCommand (const cleanFlags') (const extraArgs) + let setupScriptOptions = + defaultSetupScriptOptions + { useDistPref = distPref + , useWin32CleanHack = True + } + cleanFlags' = cleanFlags{cleanDistPref = toFlag distPref} + setupWrapper + verbosity + setupScriptOptions + Nothing + cleanCommand + (const cleanFlags') + (const extraArgs) where verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags) @@ -721,24 +980,28 @@ listAction listFlags extraArgs globalFlags = do let verbosity = fromFlag (listVerbosity listFlags) config <- loadConfigOrSandboxConfig verbosity globalFlags let configFlags' = savedConfigureFlags config - configFlags = configFlags' - { configPackageDBs = configPackageDBs configFlags' - `mappend` listPackageDBs listFlags - , configHcPath = listHcPath listFlags - } - globalFlags' = savedGlobalFlags config `mappend` globalFlags - compProgdb <- if listNeedsCompiler listFlags + configFlags = + configFlags' + { configPackageDBs = + configPackageDBs configFlags' + `mappend` listPackageDBs listFlags + , configHcPath = listHcPath listFlags + } + globalFlags' = savedGlobalFlags config `mappend` globalFlags + compProgdb <- + if listNeedsCompiler listFlags then do - (comp, _, progdb) <- configCompilerAux' configFlags - return (Just (comp, progdb)) + (comp, _, progdb) <- configCompilerAux' configFlags + return (Just (comp, progdb)) else return Nothing withRepoContext verbosity globalFlags' $ \repoContext -> - List.list verbosity - (configPackageDB' configFlags) - repoContext - compProgdb - listFlags - extraArgs + List.list + verbosity + (configPackageDB' configFlags) + repoContext + compProgdb + listFlags + extraArgs infoAction :: InfoFlags -> [String] -> Action infoAction infoFlags extraArgs globalFlags = do @@ -746,36 +1009,44 @@ infoAction infoFlags extraArgs globalFlags = do targets <- readUserTargets verbosity extraArgs config <- loadConfigOrSandboxConfig verbosity globalFlags let configFlags' = savedConfigureFlags config - configFlags = configFlags' { - configPackageDBs = configPackageDBs configFlags' - `mappend` infoPackageDBs infoFlags - } - globalFlags' = savedGlobalFlags config `mappend` globalFlags + configFlags = + configFlags' + { configPackageDBs = + configPackageDBs configFlags' + `mappend` infoPackageDBs infoFlags + } + globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, _, progdb) <- configCompilerAuxEx configFlags withRepoContext verbosity globalFlags' $ \repoContext -> - List.info verbosity - (configPackageDB' configFlags) - repoContext - comp - progdb - globalFlags' - infoFlags - targets + List.info + verbosity + (configPackageDB' configFlags) + repoContext + comp + progdb + globalFlags' + infoFlags + targets fetchAction :: FetchFlags -> [String] -> Action fetchAction fetchFlags extraArgs globalFlags = do let verbosity = fromFlag (fetchVerbosity fetchFlags) targets <- readUserTargets verbosity extraArgs config <- loadConfig verbosity (globalConfigFile globalFlags) - let configFlags = savedConfigureFlags config + let configFlags = savedConfigureFlags config globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, platform, progdb) <- configCompilerAux' configFlags withRepoContext verbosity globalFlags' $ \repoContext -> - fetch verbosity - (configPackageDB' configFlags) - repoContext - comp platform progdb globalFlags' fetchFlags - targets + fetch + verbosity + (configPackageDB' configFlags) + repoContext + comp + platform + progdb + globalFlags' + fetchFlags + targets freezeAction :: FreezeFlags -> [String] -> Action freezeAction freezeFlags _extraArgs globalFlags = do @@ -783,16 +1054,20 @@ freezeAction freezeFlags _extraArgs globalFlags = do config <- loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config NoFlag nixShell verbosity distPref globalFlags config $ do - let configFlags = savedConfigureFlags config + let configFlags = savedConfigureFlags config globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, platform, progdb) <- configCompilerAux' configFlags withRepoContext verbosity globalFlags' $ \repoContext -> - freeze verbosity - (configPackageDB' configFlags) - repoContext - comp platform progdb - globalFlags' freezeFlags + freeze + verbosity + (configPackageDB' configFlags) + repoContext + comp + platform + progdb + globalFlags' + freezeFlags genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO () genBoundsAction freezeFlags _extraArgs globalFlags = do @@ -800,76 +1075,91 @@ genBoundsAction freezeFlags _extraArgs globalFlags = do config <- loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config NoFlag nixShell verbosity distPref globalFlags config $ do - let configFlags = savedConfigureFlags config + let configFlags = savedConfigureFlags config globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, platform, progdb) <- configCompilerAux' configFlags withRepoContext verbosity globalFlags' $ \repoContext -> - genBounds verbosity - (configPackageDB' configFlags) - repoContext - comp platform progdb - globalFlags' freezeFlags + genBounds + verbosity + (configPackageDB' configFlags) + repoContext + comp + platform + progdb + globalFlags' + freezeFlags uploadAction :: UploadFlags -> [String] -> Action uploadAction uploadFlags extraArgs globalFlags = do config <- loadConfig verbosity (globalConfigFile globalFlags) let uploadFlags' = savedUploadFlags config `mappend` uploadFlags globalFlags' = savedGlobalFlags config `mappend` globalFlags - tarfiles = extraArgs + tarfiles = extraArgs when (null tarfiles && not (fromFlag (uploadDoc uploadFlags'))) $ die' verbosity "the 'upload' command expects at least one .tar.gz archive." checkTarFiles extraArgs maybe_password <- - case uploadPasswordCmd uploadFlags' - of Flag (xs:xss) -> Just . Password <$> - getProgramInvocationOutput verbosity - (simpleProgramInvocation xs xss) - _ -> pure $ flagToMaybe $ uploadPassword uploadFlags' + case uploadPasswordCmd uploadFlags' of + Flag (xs : xss) -> + Just . Password + <$> getProgramInvocationOutput + verbosity + (simpleProgramInvocation xs xss) + _ -> pure $ flagToMaybe $ uploadPassword uploadFlags' withRepoContext verbosity globalFlags' $ \repoContext -> do if fromFlag (uploadDoc uploadFlags') - then do - when (length tarfiles > 1) $ - die' verbosity $ "the 'upload' command can only upload documentation " - ++ "for one package at a time." - tarfile <- maybe (generateDocTarball config) return $ listToMaybe tarfiles - Upload.uploadDoc verbosity - repoContext - (flagToMaybe $ uploadUsername uploadFlags') - maybe_password - (fromFlag (uploadCandidate uploadFlags')) - tarfile - else do - Upload.upload verbosity - repoContext - (flagToMaybe $ uploadUsername uploadFlags') - maybe_password - (fromFlag (uploadCandidate uploadFlags')) - tarfiles - where + then do + when (length tarfiles > 1) $ + die' verbosity $ + "the 'upload' command can only upload documentation " + ++ "for one package at a time." + tarfile <- maybe (generateDocTarball config) return $ listToMaybe tarfiles + Upload.uploadDoc + verbosity + repoContext + (flagToMaybe $ uploadUsername uploadFlags') + maybe_password + (fromFlag (uploadCandidate uploadFlags')) + tarfile + else do + Upload.upload + verbosity + repoContext + (flagToMaybe $ uploadUsername uploadFlags') + maybe_password + (fromFlag (uploadCandidate uploadFlags')) + tarfiles + where verbosity = fromFlag (uploadVerbosity uploadFlags) checkTarFiles tarfiles - | not (null otherFiles) - = die' verbosity $ "the 'upload' command expects only .tar.gz archives: " - ++ intercalate ", " otherFiles - | otherwise = sequence_ - [ do exists <- doesFileExist tarfile - unless exists $ die' verbosity $ "file not found: " ++ tarfile - | tarfile <- tarfiles ] - - where otherFiles = filter (not . isTarGzFile) tarfiles - isTarGzFile file = case splitExtension file of - (file', ".gz") -> takeExtension file' == ".tar" - _ -> False + | not (null otherFiles) = + die' verbosity $ + "the 'upload' command expects only .tar.gz archives: " + ++ intercalate ", " otherFiles + | otherwise = + sequence_ + [ do + exists <- doesFileExist tarfile + unless exists $ die' verbosity $ "file not found: " ++ tarfile + | tarfile <- tarfiles + ] + where + otherFiles = filter (not . isTarGzFile) tarfiles + isTarGzFile file = case splitExtension file of + (file', ".gz") -> takeExtension file' == ".tar" + _ -> False generateDocTarball config = do notice verbosity $ "No documentation tarball specified. " - ++ "Building a documentation tarball with default settings...\n" - ++ "If you need to customise Haddock options, " - ++ "run 'haddock --for-hackage' first " - ++ "to generate a documentation tarball." - haddockAction (defaultHaddockFlags { haddockForHackage = Flag ForHackage }) - [] globalFlags + ++ "Building a documentation tarball with default settings...\n" + ++ "If you need to customise Haddock options, " + ++ "run 'haddock --for-hackage' first " + ++ "to generate a documentation tarball." + haddockAction + (defaultHaddockFlags{haddockForHackage = Flag ForHackage}) + [] + globalFlags distPref <- findSavedDistPref config NoFlag pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) return $ distPref display (packageId pkg) ++ "-docs" <.> "tar.gz" @@ -878,7 +1168,8 @@ checkAction :: Flag Verbosity -> [String] -> Action checkAction verbosityFlag extraArgs _globalFlags = do let verbosity = fromFlag verbosityFlag unless (null extraArgs) $ - die' verbosity $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs + die' verbosity $ + "'check' doesn't take any extra arguments: " ++ unwords extraArgs allOk <- Check.check (fromFlag verbosityFlag) unless allOk exitFailure @@ -886,9 +1177,10 @@ formatAction :: Flag Verbosity -> [String] -> Action formatAction verbosityFlag extraArgs _globalFlags = do let verbosity = fromFlag verbosityFlag path <- case extraArgs of - [] -> do cwd <- getCurrentDirectory - tryFindPackageDesc verbosity cwd - (p:_) -> return p + [] -> do + cwd <- getCurrentDirectory + tryFindPackageDesc verbosity cwd + (p : _) -> return p pkgDesc <- readGenericPackageDescription verbosity path -- Uses 'writeFileAtomic' under the hood. writeGenericPackageDescription path pkgDesc @@ -897,25 +1189,34 @@ reportAction :: ReportFlags -> [String] -> Action reportAction reportFlags extraArgs globalFlags = do let verbosity = fromFlag (reportVerbosity reportFlags) unless (null extraArgs) $ - die' verbosity $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs + die' verbosity $ + "'report' doesn't take any extra arguments: " ++ unwords extraArgs config <- loadConfig verbosity (globalConfigFile globalFlags) let globalFlags' = savedGlobalFlags config `mappend` globalFlags reportFlags' = savedReportFlags config `mappend` reportFlags withRepoContext verbosity globalFlags' $ \repoContext -> - Upload.report verbosity repoContext - (flagToMaybe $ reportUsername reportFlags') - (flagToMaybe $ reportPassword reportFlags') + Upload.report + verbosity + repoContext + (flagToMaybe $ reportUsername reportFlags') + (flagToMaybe $ reportPassword reportFlags') runAction :: BuildFlags -> [String] -> Action runAction buildFlags extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) + let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) config <- loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config (buildDistPref buildFlags) config' <- - reconfigure configureAction - verbosity distPref (buildNumJobs buildFlags) - mempty [] globalFlags config + reconfigure + configureAction + verbosity + distPref + (buildNumJobs buildFlags) + mempty + [] + globalFlags + config nixShell verbosity distPref globalFlags config $ do lbi <- getPersistBuildConfig distPref (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs @@ -930,11 +1231,12 @@ getAction getFlags extraArgs globalFlags = do config <- loadConfigOrSandboxConfig verbosity globalFlags let globalFlags' = savedGlobalFlags config `mappend` globalFlags withRepoContext verbosity (savedGlobalFlags config) $ \repoContext -> - get verbosity - repoContext - globalFlags' - getFlags - targets + get + verbosity + repoContext + globalFlags' + getFlags + targets unpackAction :: GetFlags -> [String] -> Action unpackAction getFlags extraArgs globalFlags = do @@ -949,9 +1251,10 @@ initAction initFlags extraArgs globalFlags = do [projectDir] -> do createDirectoryIfMissingVerbose verbosity True projectDir withCurrentDirectory projectDir initAction' - _ -> die' verbosity $ - "'init' only takes a single, optional, extra " ++ - "argument for the project root directory" + _ -> + die' verbosity $ + "'init' only takes a single, optional, extra " + ++ "argument for the project root directory" where initAction' = do confFlags <- loadConfigOrSandboxConfig verbosity globalFlags @@ -963,51 +1266,60 @@ initAction initFlags extraArgs globalFlags = do (comp, _, progdb) <- configCompilerAux' confFlags' withRepoContext verbosity globalFlags' $ \repoContext -> - initCmd verbosity (configPackageDB' confFlags') - repoContext comp progdb initFlags' + initCmd + verbosity + (configPackageDB' confFlags') + repoContext + comp + progdb + initFlags' verbosity = fromFlag (initVerbosity initFlags) - compFlags = mempty { configHcPath = initHcPath initFlags } + compFlags = mempty{configHcPath = initHcPath initFlags} userConfigAction :: UserConfigFlags -> [String] -> Action userConfigAction ucflags extraArgs globalFlags = do - let verbosity = fromFlag (userConfigVerbosity ucflags) - frc = fromFlag (userConfigForce ucflags) + let verbosity = fromFlag (userConfigVerbosity ucflags) + frc = fromFlag (userConfigForce ucflags) extraLines = fromFlag (userConfigAppendLines ucflags) case extraArgs of - ("init":_) -> do - path <- configFile + ("init" : _) -> do + path <- configFile fileExists <- doesFileExist path if (not fileExists || (fileExists && frc)) - then void $ createDefaultConfigFile verbosity extraLines path - else die' verbosity $ path ++ " already exists." - ("diff":_) -> traverse_ putStrLn =<< userConfigDiff verbosity globalFlags extraLines - ("update":_) -> userConfigUpdate verbosity globalFlags extraLines + then void $ createDefaultConfigFile verbosity extraLines path + else die' verbosity $ path ++ " already exists." + ("diff" : _) -> traverse_ putStrLn =<< userConfigDiff verbosity globalFlags extraLines + ("update" : _) -> userConfigUpdate verbosity globalFlags extraLines -- Error handling. [] -> die' verbosity $ "Please specify a subcommand (see 'help user-config')" - _ -> die' verbosity $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs - where configFile = getConfigFilePath (globalConfigFile globalFlags) + _ -> die' verbosity $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs + where + configFile = getConfigFilePath (globalConfigFile globalFlags) -- | Used as an entry point when cabal-install needs to invoke itself -- as a setup script. This can happen e.g. when doing parallel builds. --- actAsSetupAction :: ActAsSetupFlags -> [String] -> Action actAsSetupAction actAsSetupFlags args _globalFlags = let bt = fromFlag (actAsSetupBuildType actAsSetupFlags) - in case bt of - Simple -> Simple.defaultMainArgs args - Configure -> Simple.defaultMainWithHooksArgs - Simple.autoconfUserHooks args - Make -> Make.defaultMainArgs args - Custom -> error "actAsSetupAction Custom" + in case bt of + Simple -> Simple.defaultMainArgs args + Configure -> + Simple.defaultMainWithHooksArgs + Simple.autoconfUserHooks + args + Make -> Make.defaultMainArgs args + Custom -> error "actAsSetupAction Custom" manpageAction :: [CommandSpec action] -> ManpageFlags -> [String] -> Action manpageAction commands flags extraArgs _ = do let verbosity = fromFlag (manpageVerbosity flags) unless (null extraArgs) $ - die' verbosity $ "'man' doesn't take any extra arguments: " ++ unwords extraArgs + die' verbosity $ + "'man' doesn't take any extra arguments: " ++ unwords extraArgs pname <- getProgName - let cabalCmd = if takeExtension pname == ".exe" - then dropExtension pname - else pname + let cabalCmd = + if takeExtension pname == ".exe" + then dropExtension pname + else pname manpageCmd cabalCmd commands flags diff --git a/cabal-install/src/Distribution/Client/Manpage.hs b/cabal-install/src/Distribution/Client/Manpage.hs index 34023c7bd48..7bdb5bc1eb6 100644 --- a/cabal-install/src/Distribution/Client/Manpage.hs +++ b/cabal-install/src/Distribution/Client/Manpage.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.Manpage -- Copyright : (c) Maciek Makowski 2015 @@ -10,7 +12,6 @@ -- Portability : portable -- -- Functions for building the manual page. - module Distribution.Client.Manpage ( -- * Manual page generation manpage @@ -20,24 +21,32 @@ module Distribution.Client.Manpage , manpageOptions ) where +import qualified Data.List.NonEmpty as List1 import Distribution.Client.Compat.Prelude import Prelude () -import qualified Data.List.NonEmpty as List1 -import Distribution.Client.Init.Utils (trim) +import Distribution.Client.Init.Utils (trim) import Distribution.Client.ManpageFlags -import Distribution.Client.Setup (globalCommand) -import Distribution.Compat.Process (proc) +import Distribution.Client.Setup (globalCommand) +import Distribution.Compat.Process (proc) import Distribution.Simple.Command -import Distribution.Simple.Flag (fromFlag, fromFlagOrDefault) +import Distribution.Simple.Flag (fromFlag, fromFlagOrDefault) import Distribution.Simple.Utils - ( IOData(..), IODataMode(..), ignoreSigPipe, rawSystemStdInOut, rawSystemProcAction, - fromCreatePipe, die' ) -import System.IO (hClose, hPutStr) -import System.Environment (lookupEnv) + ( IOData (..) + , IODataMode (..) + , die' + , fromCreatePipe + , ignoreSigPipe + , rawSystemProcAction + , rawSystemStdInOut + ) +import System.Environment (lookupEnv) +import System.IO (hClose, hPutStr) import qualified System.Process as Process -data FileInfo = FileInfo String String -- ^ path, description +data FileInfo + = -- | path, description + FileInfo String String ------------------------------------------------------------------------------- -- @@ -51,10 +60,10 @@ files = manpageCmd :: String -> [CommandSpec a] -> ManpageFlags -> IO () manpageCmd pname commands flags - | fromFlagOrDefault False (manpageRaw flags) - = putStrLn contents - | otherwise - = ignoreSigPipe $ do + | fromFlagOrDefault False (manpageRaw flags) = + putStrLn contents + | otherwise = + ignoreSigPipe $ do -- 2021-10-08, issue #7714 -- @cabal man --raw | man -l -@ does not work on macOS/BSD, -- because BSD-man does not support option @-l@, rather would @@ -67,29 +76,31 @@ manpageCmd pname commands flags -- So let us simulate this! -- Feed contents into @nroff -man /dev/stdin@ - (formatted, _errors, ec1) <- rawSystemStdInOut - verbosity - "nroff" - [ "-man", "/dev/stdin" ] - Nothing -- Inherit working directory - Nothing -- Inherit environment - (Just $ IODataText contents) - IODataModeText + (formatted, _errors, ec1) <- + rawSystemStdInOut + verbosity + "nroff" + ["-man", "/dev/stdin"] + Nothing -- Inherit working directory + Nothing -- Inherit environment + (Just $ IODataText contents) + IODataModeText unless (ec1 == ExitSuccess) $ exitWith ec1 pagerAndArgs <- fromMaybe "less -R" <$> lookupEnv "PAGER" -- 'less' is borked with color sequences otherwise, hence -R (pager, pagerArgs) <- case words pagerAndArgs of - [] -> die' verbosity "man: empty value of the PAGER environment variable" - (p:pa) -> pure (p, pa) + [] -> die' verbosity "man: empty value of the PAGER environment variable" + (p : pa) -> pure (p, pa) -- Pipe output of @nroff@ into @less@ - (ec2, _) <- rawSystemProcAction verbosity - (proc pager pagerArgs) { Process.std_in = Process.CreatePipe } - $ \mIn _ _ -> do - let wIn = fromCreatePipe mIn - hPutStr wIn formatted - hClose wIn + (ec2, _) <- rawSystemProcAction + verbosity + (proc pager pagerArgs){Process.std_in = Process.CreatePipe} + $ \mIn _ _ -> do + let wIn = fromCreatePipe mIn + hPutStr wIn formatted + hClose wIn exitWith ec2 where contents :: String @@ -98,46 +109,47 @@ manpageCmd pname commands flags -- | Produces a manual page with @troff@ markup. manpage :: String -> [CommandSpec a] -> String -manpage pname commands = unlines $ - [ ".TH " ++ map toUpper pname ++ " 1" - , ".SH NAME" - , pname ++ " \\- a system for building and packaging Haskell libraries and programs" - , ".SH SYNOPSIS" - , ".B " ++ pname - , ".I command" - , ".RI < arguments |[ options ]>..." - , "" - , "Where the" - , ".I commands" - , "are" - , "" - ] ++ - concatMap (commandSynopsisLines pname) commands ++ - [ ".SH DESCRIPTION" - , "Cabal is the standard package system for Haskell software. It helps people to configure, " - , "build and install Haskell software and to distribute it easily to other users and developers." - , "" - , "The command line " ++ pname ++ " tool (also referred to as cabal-install) helps with " - , "installing existing packages and developing new packages. " - , "It can be used to work with local packages or to install packages from online package archives, " - , "including automatically installing dependencies. By default it is configured to use Hackage, " - , "which is Haskell's central package archive that contains thousands of libraries and applications " - , "in the Cabal package format." - , ".SH OPTIONS" - , "Global options:" - , "" - ] ++ - optionsLines (globalCommand []) ++ - [ ".SH COMMANDS" - ] ++ - concatMap (commandDetailsLines pname) commands ++ - [ ".SH FILES" - ] ++ - concatMap fileLines files ++ - [ ".SH BUGS" - , "To browse the list of known issues or report a new one please see " - , "https://github.com/haskell/cabal/labels/cabal-install." - ] +manpage pname commands = + unlines $ + [ ".TH " ++ map toUpper pname ++ " 1" + , ".SH NAME" + , pname ++ " \\- a system for building and packaging Haskell libraries and programs" + , ".SH SYNOPSIS" + , ".B " ++ pname + , ".I command" + , ".RI < arguments |[ options ]>..." + , "" + , "Where the" + , ".I commands" + , "are" + , "" + ] + ++ concatMap (commandSynopsisLines pname) commands + ++ [ ".SH DESCRIPTION" + , "Cabal is the standard package system for Haskell software. It helps people to configure, " + , "build and install Haskell software and to distribute it easily to other users and developers." + , "" + , "The command line " ++ pname ++ " tool (also referred to as cabal-install) helps with " + , "installing existing packages and developing new packages. " + , "It can be used to work with local packages or to install packages from online package archives, " + , "including automatically installing dependencies. By default it is configured to use Hackage, " + , "which is Haskell's central package archive that contains thousands of libraries and applications " + , "in the Cabal package format." + , ".SH OPTIONS" + , "Global options:" + , "" + ] + ++ optionsLines (globalCommand []) + ++ [ ".SH COMMANDS" + ] + ++ concatMap (commandDetailsLines pname) commands + ++ [ ".SH FILES" + ] + ++ concatMap fileLines files + ++ [ ".SH BUGS" + , "To browse the list of known issues or report a new one please see " + , "https://github.com/haskell/cabal/labels/cabal-install." + ] commandSynopsisLines :: String -> CommandSpec action -> [String] commandSynopsisLines pname (CommandSpec ui _ NormalCommand) = @@ -153,37 +165,37 @@ commandDetailsLines pname (CommandSpec ui _ NormalCommand) = , "" , commandUsage ui pname , "" - ] ++ - optional removeLineBreaks commandDescription ++ - optional id commandNotes ++ - [ "Flags:" - , ".RS" - ] ++ - optionsLines ui ++ - [ ".RE" - , "" ] + ++ optional removeLineBreaks commandDescription + ++ optional id commandNotes + ++ [ "Flags:" + , ".RS" + ] + ++ optionsLines ui + ++ [ ".RE" + , "" + ] where optional f field = case field ui of - Just text -> [ f $ text pname, "" ] - Nothing -> [] + Just text -> [f $ text pname, ""] + Nothing -> [] -- 2021-10-12, https://github.com/haskell/cabal/issues/7714#issuecomment-940842905 -- Line breaks just before e.g. 'new-build' cause weird @nroff@ warnings. -- Thus: -- Remove line breaks but preserve paragraph breaks. -- We group lines by empty/non-empty and then 'unwords' -- blocks consisting of non-empty lines. - removeLineBreaks - = unlines - . concatMap unwordsNonEmpty - . List1.groupWith null - . map trim - . lines + removeLineBreaks = + unlines + . concatMap unwordsNonEmpty + . List1.groupWith null + . map trim + . lines unwordsNonEmpty :: List1.NonEmpty String -> [String] unwordsNonEmpty ls1 = if null (List1.head ls1) then ls else [unwords ls] - where ls = List1.toList ls1 - + where + ls = List1.toList ls1 commandDetailsLines _ (CommandSpec _ _ HiddenCommand) = [] optionsLines :: CommandUI flags -> [String] @@ -198,27 +210,28 @@ optionLines (ReqArg description (optionChars, optionStrings) placeHolder _ _) = optionLines (OptArg description (optionChars, optionStrings) placeHolder _ _ _) = argOptionLines description optionChars optionStrings (Optional, placeHolder) optionLines (BoolOpt description (trueChars, trueStrings) (falseChars, falseStrings) _ _) = - optionLinesIfPresent trueChars trueStrings ++ - optionLinesIfPresent falseChars falseStrings ++ - optionDescriptionLines description + optionLinesIfPresent trueChars trueStrings + ++ optionLinesIfPresent falseChars falseStrings + ++ optionDescriptionLines description optionLines (ChoiceOpt options) = concatMap choiceLines options where choiceLines (description, (optionChars, optionStrings), _, _) = - [ optionsLine optionChars optionStrings ] ++ - optionDescriptionLines description + [optionsLine optionChars optionStrings] + ++ optionDescriptionLines description argOptionLines :: String -> [Char] -> [String] -> OptionArg -> [String] argOptionLines description optionChars optionStrings arg = [ optionsLine optionChars optionStrings , optionArgLine arg - ] ++ - optionDescriptionLines description + ] + ++ optionDescriptionLines description optionLinesIfPresent :: [Char] -> [String] -> [String] optionLinesIfPresent optionChars optionStrings = - if null optionChars && null optionStrings then [] - else [ optionsLine optionChars optionStrings, ".br" ] + if null optionChars && null optionStrings + then [] + else [optionsLine optionChars optionStrings, ".br"] optionDescriptionLines :: String -> [String] optionDescriptionLines description = diff --git a/cabal-install/src/Distribution/Client/ManpageFlags.hs b/cabal-install/src/Distribution/Client/ManpageFlags.hs index 79ed9e5dc6a..ba76e314af2 100644 --- a/cabal-install/src/Distribution/Client/ManpageFlags.hs +++ b/cabal-install/src/Distribution/Client/ManpageFlags.hs @@ -1,23 +1,25 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} + module Distribution.Client.ManpageFlags -( ManpageFlags (..) -, defaultManpageFlags -, manpageOptions, -) where + ( ManpageFlags (..) + , defaultManpageFlags + , manpageOptions + ) where import Distribution.Client.Compat.Prelude import Distribution.Simple.Command (OptionField (..), ShowOrParseArgs (..), option) -import Distribution.Simple.Setup (Flag (..), toFlag, trueArg, optionVerbosity) -import Distribution.Verbosity (normal) +import Distribution.Simple.Setup (Flag (..), optionVerbosity, toFlag, trueArg) +import Distribution.Verbosity (normal) data ManpageFlags = ManpageFlags { manpageVerbosity :: Flag Verbosity - , manpageRaw :: Flag Bool - } deriving (Eq, Show, Generic) + , manpageRaw :: Flag Bool + } + deriving (Eq, Show, Generic) -instance Monoid ManpageFlags where +instance Monoid ManpageFlags where mempty = gmempty mappend = (<>) @@ -25,16 +27,20 @@ instance Semigroup ManpageFlags where (<>) = gmappend defaultManpageFlags :: ManpageFlags -defaultManpageFlags = ManpageFlags +defaultManpageFlags = + ManpageFlags { manpageVerbosity = toFlag normal - , manpageRaw = toFlag False + , manpageRaw = toFlag False } manpageOptions :: ShowOrParseArgs -> [OptionField ManpageFlags] manpageOptions _ = - [ optionVerbosity manpageVerbosity (\v flags -> flags { manpageVerbosity = v }) - , option "" ["raw"] + [ optionVerbosity manpageVerbosity (\v flags -> flags{manpageVerbosity = v}) + , option + "" + ["raw"] "Output raw troff content" - manpageRaw (\v flags -> flags { manpageRaw = v }) + manpageRaw + (\v flags -> flags{manpageRaw = v}) trueArg - ] + ] diff --git a/cabal-install/src/Distribution/Client/Nix.hs b/cabal-install/src/Distribution/Client/Nix.hs index 4798f8e8be9..34a12f9157b 100644 --- a/cabal-install/src/Distribution/Client/Nix.hs +++ b/cabal-install/src/Distribution/Client/Nix.hs @@ -2,67 +2,82 @@ {-# LANGUAGE ViewPatterns #-} module Distribution.Client.Nix - ( findNixExpr - , inNixShell - , nixInstantiate - , nixShell - ) where + ( findNixExpr + , inNixShell + , nixInstantiate + , nixShell + ) where import Distribution.Client.Compat.Prelude import Control.Exception (bracket) import System.Directory - ( canonicalizePath, createDirectoryIfMissing, doesDirectoryExist - , doesFileExist, removeDirectoryRecursive, removeFile ) + ( canonicalizePath + , createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , removeDirectoryRecursive + , removeFile + ) import System.Environment (getArgs, getExecutablePath) import System.FilePath - ( (), replaceExtension, takeDirectory, takeFileName ) -import System.IO (IOMode(..), hClose, openFile) + ( replaceExtension + , takeDirectory + , takeFileName + , () + ) +import System.IO (IOMode (..), hClose, openFile) import System.IO.Error (isDoesNotExistError) import System.Process (showCommandForUser) import Distribution.Compat.Environment - ( lookupEnv, setEnv, unsetEnv ) + ( lookupEnv + , setEnv + , unsetEnv + ) import Distribution.Simple.Program - ( Program(..), ProgramDb - , addKnownProgram, configureProgram, emptyProgramDb, getDbProgramOutput - , runDbProgram, simpleProgram ) + ( Program (..) + , ProgramDb + , addKnownProgram + , configureProgram + , emptyProgramDb + , getDbProgramOutput + , runDbProgram + , simpleProgram + ) import Distribution.Simple.Setup (fromFlagOrDefault) import Distribution.Simple.Utils (debug, existsAndIsMoreRecentThan) -import Distribution.Client.Config (SavedConfig(..)) -import Distribution.Client.GlobalFlags (GlobalFlags(..)) - +import Distribution.Client.Config (SavedConfig (..)) +import Distribution.Client.GlobalFlags (GlobalFlags (..)) configureOneProgram :: Verbosity -> Program -> IO ProgramDb configureOneProgram verb prog = configureProgram verb prog (addKnownProgram prog emptyProgramDb) - touchFile :: FilePath -> IO () touchFile path = do catch (removeFile path) (\e -> when (isDoesNotExistError e) (return ())) createDirectoryIfMissing True (takeDirectory path) openFile path WriteMode >>= hClose - findNixExpr :: GlobalFlags -> SavedConfig -> IO (Maybe FilePath) findNixExpr globalFlags config = do -- criteria for deciding to run nix-shell let nixEnabled = - fromFlagOrDefault False - (globalNix (savedGlobalFlags config) <> globalNix globalFlags) + fromFlagOrDefault + False + (globalNix (savedGlobalFlags config) <> globalNix globalFlags) if nixEnabled then do - let exprPaths = [ "shell.nix", "default.nix" ] + let exprPaths = ["shell.nix", "default.nix"] filterM doesFileExist exprPaths >>= \case [] -> return Nothing (path : _) -> return (Just path) else return Nothing - -- set IN_NIX_SHELL so that builtins.getEnv in Nix works as in nix-shell inFakeNixShell :: IO a -> IO a inFakeNixShell f = @@ -74,7 +89,6 @@ inFakeNixShell f = return old resetEnv var = maybe (unsetEnv var) (setEnv var) - nixInstantiate :: Verbosity -> FilePath @@ -96,30 +110,32 @@ nixInstantiate verb dist force' globalFlags config = let ready = alreadyInShell || (instantiated && upToDate && not force') unless ready $ do - let prog = simpleProgram "nix-instantiate" progdb <- configureOneProgram verb prog removeGCRoots verb dist touchFile timestamp - _ <- inFakeNixShell - (getDbProgramOutput verb prog progdb - [ "--add-root", shellDrv, "--indirect", shellNix ]) + _ <- + inFakeNixShell + ( getDbProgramOutput + verb + prog + progdb + ["--add-root", shellDrv, "--indirect", shellNix] + ) return () - nixShell :: Verbosity -> FilePath -> GlobalFlags -> SavedConfig -> IO () - -- ^ The action to perform inside a nix-shell. This is also the action - -- that will be performed immediately if Nix is disabled. + -- ^ The action to perform inside a nix-shell. This is also the action + -- that will be performed immediately if Nix is disabled. -> IO () nixShell verb dist globalFlags config go = do - alreadyInShell <- inNixShell if alreadyInShell @@ -128,7 +144,6 @@ nixShell verb dist globalFlags config go = do findNixExpr globalFlags config >>= \case Nothing -> go Just shellNix -> do - let prog = simpleProgram "nix-shell" progdb <- configureOneProgram verb prog @@ -143,12 +158,18 @@ nixShell verb dist globalFlags config go = do -- automatically. shellDrv <- drvPath dist shellNix args <- getArgs - runDbProgram verb prog progdb - [ "--add-root", gcrootPath dist "result", "--indirect", shellDrv - , "--run", showCommandForUser cabal args + runDbProgram + verb + prog + progdb + [ "--add-root" + , gcrootPath dist "result" + , "--indirect" + , shellDrv + , "--run" + , showCommandForUser cabal args ] - drvPath :: FilePath -> FilePath -> IO FilePath drvPath dist path = do -- We do not actually care about canonicity, but makeAbsolute is only @@ -159,20 +180,16 @@ drvPath dist path = do -- Nix garbage collector roots must be absolute paths return (distNix replaceExtension (takeFileName path) "drv") - timestampPath :: FilePath -> FilePath -> FilePath timestampPath dist path = dist "nix" replaceExtension (takeFileName path) "drv.timestamp" - gcrootPath :: FilePath -> FilePath gcrootPath dist = dist "nix" "gcroots" - inNixShell :: IO Bool inNixShell = isJust <$> lookupEnv "CABAL_IN_NIX_SHELL" - removeGCRoots :: Verbosity -> FilePath -> IO () removeGCRoots verb dist = do let tgt = gcrootPath dist diff --git a/cabal-install/src/Distribution/Client/NixStyleOptions.hs b/cabal-install/src/Distribution/Client/NixStyleOptions.hs index 965ef74c5be..2e9bfb91382 100644 --- a/cabal-install/src/Distribution/Client/NixStyleOptions.hs +++ b/cabal-install/src/Distribution/Client/NixStyleOptions.hs @@ -4,84 +4,123 @@ -- -- The commands take a lot of the same options, which affect how install plan -- is constructed. -module Distribution.Client.NixStyleOptions ( - NixStyleFlags (..), - nixStyleOptions, - defaultNixStyleFlags, -) where +module Distribution.Client.NixStyleOptions + ( NixStyleFlags (..) + , nixStyleOptions + , defaultNixStyleFlags + ) where import Distribution.Client.Compat.Prelude import Prelude () -import Distribution.Simple.Command (OptionField (..), ShowOrParseArgs) -import Distribution.Simple.Setup (BenchmarkFlags, HaddockFlags, TestFlags) -import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) +import Distribution.Simple.Command (OptionField (..), ShowOrParseArgs) +import Distribution.Simple.Setup (BenchmarkFlags, HaddockFlags, TestFlags) +import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) import Distribution.Client.ProjectFlags - (ProjectFlags (..), defaultProjectFlags, projectFlagsOptions) + ( ProjectFlags (..) + , defaultProjectFlags + , projectFlagsOptions + ) import Distribution.Client.Setup - (ConfigExFlags, ConfigFlags (..), InstallFlags (..), benchmarkOptions, configureExOptions, - configureOptions, haddockOptions, installOptions, liftOptions, testOptions) + ( ConfigExFlags + , ConfigFlags (..) + , InstallFlags (..) + , benchmarkOptions + , configureExOptions + , configureOptions + , haddockOptions + , installOptions + , liftOptions + , testOptions + ) data NixStyleFlags a = NixStyleFlags - { configFlags :: ConfigFlags - , configExFlags :: ConfigExFlags - , installFlags :: InstallFlags - , haddockFlags :: HaddockFlags - , testFlags :: TestFlags - , benchmarkFlags :: BenchmarkFlags - , projectFlags :: ProjectFlags - , extraFlags :: a - } + { configFlags :: ConfigFlags + , configExFlags :: ConfigExFlags + , installFlags :: InstallFlags + , haddockFlags :: HaddockFlags + , testFlags :: TestFlags + , benchmarkFlags :: BenchmarkFlags + , projectFlags :: ProjectFlags + , extraFlags :: a + } nixStyleOptions - :: (ShowOrParseArgs -> [OptionField a]) - -> ShowOrParseArgs -> [OptionField (NixStyleFlags a)] + :: (ShowOrParseArgs -> [OptionField a]) + -> ShowOrParseArgs + -> [OptionField (NixStyleFlags a)] nixStyleOptions commandOptions showOrParseArgs = - liftOptions configFlags set1 - -- Note: [Hidden Flags] - -- hide "constraint", "dependency", and - -- "exact-configuration" from the configure options. - (filter ((`notElem` ["constraint", "dependency" - , "exact-configuration"]) - . optionName) $ configureOptions showOrParseArgs) - ++ liftOptions configExFlags set2 (configureExOptions showOrParseArgs - ConstraintSourceCommandlineFlag) - ++ liftOptions installFlags set3 - -- hide "target-package-db" and "symlink-bindir" flags from the - -- install options. - -- "symlink-bindir" is obsoleted by "installdir" in ClientInstallFlags - (filter ((`notElem` ["target-package-db", "symlink-bindir"]) - . optionName) $ - installOptions showOrParseArgs) - ++ liftOptions haddockFlags set4 - -- hide "verbose" and "builddir" flags from the - -- haddock options. - (filter ((`notElem` ["v", "verbose", "builddir"]) - . optionName) $ - haddockOptions showOrParseArgs) - ++ liftOptions testFlags set5 (testOptions showOrParseArgs) - ++ liftOptions benchmarkFlags set6 (benchmarkOptions showOrParseArgs) - ++ liftOptions projectFlags set7 (projectFlagsOptions showOrParseArgs) - ++ liftOptions extraFlags set8 (commandOptions showOrParseArgs) + liftOptions + configFlags + set1 + -- Note: [Hidden Flags] + -- hide "constraint", "dependency", and + -- "exact-configuration" from the configure options. + ( filter + ( ( `notElem` + [ "constraint" + , "dependency" + , "exact-configuration" + ] + ) + . optionName + ) + $ configureOptions showOrParseArgs + ) + ++ liftOptions + configExFlags + set2 + ( configureExOptions + showOrParseArgs + ConstraintSourceCommandlineFlag + ) + ++ liftOptions + installFlags + set3 + -- hide "target-package-db" and "symlink-bindir" flags from the + -- install options. + -- "symlink-bindir" is obsoleted by "installdir" in ClientInstallFlags + ( filter + ( (`notElem` ["target-package-db", "symlink-bindir"]) + . optionName + ) + $ installOptions showOrParseArgs + ) + ++ liftOptions + haddockFlags + set4 + -- hide "verbose" and "builddir" flags from the + -- haddock options. + ( filter + ( (`notElem` ["v", "verbose", "builddir"]) + . optionName + ) + $ haddockOptions showOrParseArgs + ) + ++ liftOptions testFlags set5 (testOptions showOrParseArgs) + ++ liftOptions benchmarkFlags set6 (benchmarkOptions showOrParseArgs) + ++ liftOptions projectFlags set7 (projectFlagsOptions showOrParseArgs) + ++ liftOptions extraFlags set8 (commandOptions showOrParseArgs) where - set1 x flags = flags { configFlags = x } - set2 x flags = flags { configExFlags = x } - set3 x flags = flags { installFlags = x } - set4 x flags = flags { haddockFlags = x } - set5 x flags = flags { testFlags = x } - set6 x flags = flags { benchmarkFlags = x } - set7 x flags = flags { projectFlags = x } - set8 x flags = flags { extraFlags = x } + set1 x flags = flags{configFlags = x} + set2 x flags = flags{configExFlags = x} + set3 x flags = flags{installFlags = x} + set4 x flags = flags{haddockFlags = x} + set5 x flags = flags{testFlags = x} + set6 x flags = flags{benchmarkFlags = x} + set7 x flags = flags{projectFlags = x} + set8 x flags = flags{extraFlags = x} -defaultNixStyleFlags :: a -> NixStyleFlags a -defaultNixStyleFlags x = NixStyleFlags - { configFlags = mempty - , configExFlags = mempty - , installFlags = mempty - , haddockFlags = mempty - , testFlags = mempty +defaultNixStyleFlags :: a -> NixStyleFlags a +defaultNixStyleFlags x = + NixStyleFlags + { configFlags = mempty + , configExFlags = mempty + , installFlags = mempty + , haddockFlags = mempty + , testFlags = mempty , benchmarkFlags = mempty - , projectFlags = defaultProjectFlags - , extraFlags = x + , projectFlags = defaultProjectFlags + , extraFlags = x } diff --git a/cabal-install/src/Distribution/Client/PackageHash.hs b/cabal-install/src/Distribution/Client/PackageHash.hs index d2a3d1d901d..18be444cde7 100644 --- a/cabal-install/src/Distribution/Client/PackageHash.hs +++ b/cabal-install/src/Distribution/Client/PackageHash.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} -- | Functions to calculate nix-style hashes for package ids. -- @@ -8,40 +10,56 @@ -- * the package tarball -- * the ids of all the direct dependencies -- * other local configuration (flags, profiling, etc) --- -module Distribution.Client.PackageHash ( - -- * Calculating package hashes - PackageHashInputs(..), - PackageHashConfigInputs(..), - PackageSourceHash, - hashedInstalledPackageId, - hashPackageHashInputs, - renderPackageHashInputs, +module Distribution.Client.PackageHash + ( -- * Calculating package hashes + PackageHashInputs (..) + , PackageHashConfigInputs (..) + , PackageSourceHash + , hashedInstalledPackageId + , hashPackageHashInputs + , renderPackageHashInputs + -- ** Platform-specific variations - hashedInstalledPackageIdLong, - hashedInstalledPackageIdShort, + , hashedInstalledPackageIdLong + , hashedInstalledPackageIdShort ) where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () +import Distribution.Client.HashValue +import Distribution.Client.Types + ( InstalledPackageId + ) import Distribution.Package - ( PackageId, PackageIdentifier(..), mkComponentId - , PkgconfigName ) -import Distribution.System - ( Platform, OS(Windows, OSX), buildOS ) -import Distribution.Types.Flag - ( FlagAssignment, showFlagAssignment ) + ( PackageId + , PackageIdentifier (..) + , PkgconfigName + , mkComponentId + ) import Distribution.Simple.Compiler - ( CompilerId, OptimisationLevel(..), DebugInfoLevel(..) - , ProfDetailLevel(..), PackageDB, showProfDetailLevel ) + ( CompilerId + , DebugInfoLevel (..) + , OptimisationLevel (..) + , PackageDB + , ProfDetailLevel (..) + , showProfDetailLevel + ) import Distribution.Simple.InstallDirs - ( PathTemplate, fromPathTemplate ) -import Distribution.Types.PkgconfigVersion (PkgconfigVersion) -import Distribution.Client.HashValue -import Distribution.Client.Types - ( InstalledPackageId ) + ( PathTemplate + , fromPathTemplate + ) import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.System + ( OS (OSX, Windows) + , Platform + , buildOS + ) +import Distribution.Types.Flag + ( FlagAssignment + , showFlagAssignment + ) +import Distribution.Types.PkgconfigVersion (PkgconfigVersion) import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.Map as Map @@ -57,36 +75,34 @@ import qualified Data.Set as Set -- Note that due to path length limitations on Windows, this function uses -- a different method on Windows that produces shorted package ids. -- See 'hashedInstalledPackageIdLong' vs 'hashedInstalledPackageIdShort'. --- hashedInstalledPackageId :: PackageHashInputs -> InstalledPackageId hashedInstalledPackageId | buildOS == Windows = hashedInstalledPackageIdShort - | buildOS == OSX = hashedInstalledPackageIdVeryShort - | otherwise = hashedInstalledPackageIdLong + | buildOS == OSX = hashedInstalledPackageIdVeryShort + | otherwise = hashedInstalledPackageIdLong -- | Calculate a 'InstalledPackageId' for a package using our nix-style -- inputs hashing method. -- -- This produces large ids with big hashes. It is only suitable for systems -- without significant path length limitations (ie not Windows). --- hashedInstalledPackageIdLong :: PackageHashInputs -> InstalledPackageId hashedInstalledPackageIdLong - pkghashinputs@PackageHashInputs{pkgHashPkgId,pkgHashComponent} - = mkComponentId $ - prettyShow pkgHashPkgId -- to be a bit user friendly + pkghashinputs@PackageHashInputs{pkgHashPkgId, pkgHashComponent} = + mkComponentId $ + prettyShow pkgHashPkgId -- to be a bit user friendly ++ maybe "" displayComponent pkgHashComponent ++ "-" ++ showHashValue (hashPackageHashInputs pkghashinputs) - where - displayComponent :: CD.Component -> String - displayComponent CD.ComponentLib = "" - displayComponent (CD.ComponentSubLib s) = "-l-" ++ prettyShow s - displayComponent (CD.ComponentFLib s) = "-f-" ++ prettyShow s - displayComponent (CD.ComponentExe s) = "-e-" ++ prettyShow s - displayComponent (CD.ComponentTest s) = "-t-" ++ prettyShow s - displayComponent (CD.ComponentBench s) = "-b-" ++ prettyShow s - displayComponent CD.ComponentSetup = "-setup" + where + displayComponent :: CD.Component -> String + displayComponent CD.ComponentLib = "" + displayComponent (CD.ComponentSubLib s) = "-l-" ++ prettyShow s + displayComponent (CD.ComponentFLib s) = "-f-" ++ prettyShow s + displayComponent (CD.ComponentExe s) = "-e-" ++ prettyShow s + displayComponent (CD.ComponentTest s) = "-t-" ++ prettyShow s + displayComponent (CD.ComponentBench s) = "-b-" ++ prettyShow s + displayComponent CD.ComponentSetup = "-setup" -- | On Windows we have serious problems with path lengths. Windows imposes a -- maximum path length of 260 chars, and even if we can use the windows long @@ -105,22 +121,23 @@ hashedInstalledPackageIdLong -- Truncating the hash size is disappointing but also technically ok. We -- rely on the hash primarily for collision avoidance not for any security -- properties (at least for now). --- hashedInstalledPackageIdShort :: PackageHashInputs -> InstalledPackageId hashedInstalledPackageIdShort pkghashinputs@PackageHashInputs{pkgHashPkgId} = - mkComponentId $ - intercalate "-" - -- max length now 64 - [ truncateStr 14 (prettyShow name) - , truncateStr 8 (prettyShow version) - , showHashValue (truncateHash 20 (hashPackageHashInputs pkghashinputs)) - ] + mkComponentId $ + intercalate + "-" + -- max length now 64 + [ truncateStr 14 (prettyShow name) + , truncateStr 8 (prettyShow version) + , showHashValue (truncateHash 20 (hashPackageHashInputs pkghashinputs)) + ] where PackageIdentifier name version = pkgHashPkgId -- Truncate a string, with a visual indication that it is truncated. - truncateStr n s | length s <= n = s - | otherwise = take (n-1) s ++ "_" + truncateStr n s + | length s <= n = s + | otherwise = take (n - 1) s ++ "_" -- | On macOS we shorten the name very aggressively. The mach-o linker on -- macOS has a limited load command size, to which the name of the library @@ -148,7 +165,8 @@ hashedInstalledPackageIdShort pkghashinputs@PackageHashInputs{pkgHashPkgId} = hashedInstalledPackageIdVeryShort :: PackageHashInputs -> InstalledPackageId hashedInstalledPackageIdVeryShort pkghashinputs@PackageHashInputs{pkgHashPkgId} = mkComponentId $ - intercalate "-" + intercalate + "-" [ filter (not . flip elem "aeiou") (prettyShow name) , prettyShow version , showHashValue (truncateHash 4 (hashPackageHashInputs pkghashinputs)) @@ -158,95 +176,89 @@ hashedInstalledPackageIdVeryShort pkghashinputs@PackageHashInputs{pkgHashPkgId} -- | All the information that contributes to a package's hash, and thus its -- 'InstalledPackageId'. --- -data PackageHashInputs = PackageHashInputs { - pkgHashPkgId :: PackageId, - pkgHashComponent :: Maybe CD.Component, - pkgHashSourceHash :: PackageSourceHash, - pkgHashPkgConfigDeps :: Set (PkgconfigName, Maybe PkgconfigVersion), - pkgHashDirectDeps :: Set InstalledPackageId, - pkgHashOtherConfig :: PackageHashConfigInputs - } +data PackageHashInputs = PackageHashInputs + { pkgHashPkgId :: PackageId + , pkgHashComponent :: Maybe CD.Component + , pkgHashSourceHash :: PackageSourceHash + , pkgHashPkgConfigDeps :: Set (PkgconfigName, Maybe PkgconfigVersion) + , pkgHashDirectDeps :: Set InstalledPackageId + , pkgHashOtherConfig :: PackageHashConfigInputs + } type PackageSourceHash = HashValue -- | Those parts of the package configuration that contribute to the -- package hash. --- -data PackageHashConfigInputs = PackageHashConfigInputs { - pkgHashCompilerId :: CompilerId, - pkgHashPlatform :: Platform, - pkgHashFlagAssignment :: FlagAssignment, -- complete not partial - pkgHashConfigureScriptArgs :: [String], -- just ./configure for build-type Configure - pkgHashVanillaLib :: Bool, - pkgHashSharedLib :: Bool, - pkgHashDynExe :: Bool, - pkgHashFullyStaticExe :: Bool, - pkgHashGHCiLib :: Bool, - pkgHashProfLib :: Bool, - pkgHashProfExe :: Bool, - pkgHashProfLibDetail :: ProfDetailLevel, - pkgHashProfExeDetail :: ProfDetailLevel, - pkgHashCoverage :: Bool, - pkgHashOptimization :: OptimisationLevel, - pkgHashSplitObjs :: Bool, - pkgHashSplitSections :: Bool, - pkgHashStripLibs :: Bool, - pkgHashStripExes :: Bool, - pkgHashDebugInfo :: DebugInfoLevel, - pkgHashProgramArgs :: Map String [String], - pkgHashExtraLibDirs :: [FilePath], - pkgHashExtraLibDirsStatic :: [FilePath], - pkgHashExtraFrameworkDirs :: [FilePath], - pkgHashExtraIncludeDirs :: [FilePath], - pkgHashProgPrefix :: Maybe PathTemplate, - pkgHashProgSuffix :: Maybe PathTemplate, - pkgHashPackageDbs :: [Maybe PackageDB], - - -- Haddock options - pkgHashDocumentation :: Bool, - pkgHashHaddockHoogle :: Bool, - pkgHashHaddockHtml :: Bool, - pkgHashHaddockHtmlLocation :: Maybe String, - pkgHashHaddockForeignLibs :: Bool, - pkgHashHaddockExecutables :: Bool, - pkgHashHaddockTestSuites :: Bool, - pkgHashHaddockBenchmarks :: Bool, - pkgHashHaddockInternal :: Bool, - pkgHashHaddockCss :: Maybe FilePath, - pkgHashHaddockLinkedSource :: Bool, - pkgHashHaddockQuickJump :: Bool, - pkgHashHaddockContents :: Maybe PathTemplate, - pkgHashHaddockIndex :: Maybe PathTemplate, - pkgHashHaddockBaseUrl :: Maybe String, - pkgHashHaddockLib :: Maybe String, - pkgHashHaddockOutputDir :: Maybe FilePath - --- TODO: [required eventually] pkgHashToolsVersions ? --- TODO: [required eventually] pkgHashToolsExtraOptions ? - } - deriving Show - +data PackageHashConfigInputs = PackageHashConfigInputs + { pkgHashCompilerId :: CompilerId + , pkgHashPlatform :: Platform + , pkgHashFlagAssignment :: FlagAssignment -- complete not partial + , pkgHashConfigureScriptArgs :: [String] -- just ./configure for build-type Configure + , pkgHashVanillaLib :: Bool + , pkgHashSharedLib :: Bool + , pkgHashDynExe :: Bool + , pkgHashFullyStaticExe :: Bool + , pkgHashGHCiLib :: Bool + , pkgHashProfLib :: Bool + , pkgHashProfExe :: Bool + , pkgHashProfLibDetail :: ProfDetailLevel + , pkgHashProfExeDetail :: ProfDetailLevel + , pkgHashCoverage :: Bool + , pkgHashOptimization :: OptimisationLevel + , pkgHashSplitObjs :: Bool + , pkgHashSplitSections :: Bool + , pkgHashStripLibs :: Bool + , pkgHashStripExes :: Bool + , pkgHashDebugInfo :: DebugInfoLevel + , pkgHashProgramArgs :: Map String [String] + , pkgHashExtraLibDirs :: [FilePath] + , pkgHashExtraLibDirsStatic :: [FilePath] + , pkgHashExtraFrameworkDirs :: [FilePath] + , pkgHashExtraIncludeDirs :: [FilePath] + , pkgHashProgPrefix :: Maybe PathTemplate + , pkgHashProgSuffix :: Maybe PathTemplate + , pkgHashPackageDbs :: [Maybe PackageDB] + , -- Haddock options + pkgHashDocumentation :: Bool + , pkgHashHaddockHoogle :: Bool + , pkgHashHaddockHtml :: Bool + , pkgHashHaddockHtmlLocation :: Maybe String + , pkgHashHaddockForeignLibs :: Bool + , pkgHashHaddockExecutables :: Bool + , pkgHashHaddockTestSuites :: Bool + , pkgHashHaddockBenchmarks :: Bool + , pkgHashHaddockInternal :: Bool + , pkgHashHaddockCss :: Maybe FilePath + , pkgHashHaddockLinkedSource :: Bool + , pkgHashHaddockQuickJump :: Bool + , pkgHashHaddockContents :: Maybe PathTemplate + , pkgHashHaddockIndex :: Maybe PathTemplate + , pkgHashHaddockBaseUrl :: Maybe String + , pkgHashHaddockLib :: Maybe String + , pkgHashHaddockOutputDir :: Maybe FilePath + -- TODO: [required eventually] pkgHashToolsVersions ? + -- TODO: [required eventually] pkgHashToolsExtraOptions ? + } + deriving (Show) -- | Calculate the overall hash to be used for an 'InstalledPackageId'. --- hashPackageHashInputs :: PackageHashInputs -> HashValue hashPackageHashInputs = hashValue . renderPackageHashInputs -- | Render a textual representation of the 'PackageHashInputs'. -- -- The 'hashValue' of this text is the overall package hash. --- renderPackageHashInputs :: PackageHashInputs -> LBS.ByteString -renderPackageHashInputs PackageHashInputs{ - pkgHashPkgId, - pkgHashComponent, - pkgHashSourceHash, - pkgHashDirectDeps, - pkgHashPkgConfigDeps, - pkgHashOtherConfig = - PackageHashConfigInputs{..} - } = +renderPackageHashInputs + PackageHashInputs + { pkgHashPkgId + , pkgHashComponent + , pkgHashSourceHash + , pkgHashDirectDeps + , pkgHashPkgConfigDeps + , pkgHashOtherConfig = + PackageHashConfigInputs{..} + } = -- The purpose of this somewhat laboured rendering (e.g. why not just -- use show?) is so that existing package hashes do not change -- unnecessarily when new configuration inputs are added into the hash. @@ -258,72 +270,85 @@ renderPackageHashInputs PackageHashInputs{ -- change the hashes of existing packages and so fewer packages will need -- to be rebuilt. - --TODO: [nice to have] ultimately we probably want to put this config info + -- TODO: [nice to have] ultimately we probably want to put this config info -- into the ghc-pkg db. At that point this should probably be changed to -- use the config file infrastructure so it can be read back in again. - LBS.pack $ unlines $ catMaybes $ - [ entry "pkgid" prettyShow pkgHashPkgId - , mentry "component" show pkgHashComponent - , entry "src" showHashValue pkgHashSourceHash - , entry "pkg-config-deps" - (intercalate ", " . map (\(pn, mb_v) -> prettyShow pn ++ - case mb_v of - Nothing -> "" - Just v -> " " ++ prettyShow v) - . Set.toList) pkgHashPkgConfigDeps - , entry "deps" (intercalate ", " . map prettyShow - . Set.toList) pkgHashDirectDeps - -- and then all the config - , entry "compilerid" prettyShow pkgHashCompilerId - , entry "platform" prettyShow pkgHashPlatform - , opt "flags" mempty showFlagAssignment pkgHashFlagAssignment - , opt "configure-script" [] unwords pkgHashConfigureScriptArgs - , opt "vanilla-lib" True prettyShow pkgHashVanillaLib - , opt "shared-lib" False prettyShow pkgHashSharedLib - , opt "dynamic-exe" False prettyShow pkgHashDynExe - , opt "fully-static-exe" False prettyShow pkgHashFullyStaticExe - , opt "ghci-lib" False prettyShow pkgHashGHCiLib - , opt "prof-lib" False prettyShow pkgHashProfLib - , opt "prof-exe" False prettyShow pkgHashProfExe - , opt "prof-lib-detail" ProfDetailDefault showProfDetailLevel pkgHashProfLibDetail - , opt "prof-exe-detail" ProfDetailDefault showProfDetailLevel pkgHashProfExeDetail - , opt "hpc" False prettyShow pkgHashCoverage - , opt "optimisation" NormalOptimisation (show . fromEnum) pkgHashOptimization - , opt "split-objs" False prettyShow pkgHashSplitObjs - , opt "split-sections" False prettyShow pkgHashSplitSections - , opt "stripped-lib" False prettyShow pkgHashStripLibs - , opt "stripped-exe" True prettyShow pkgHashStripExes - , opt "debug-info" NormalDebugInfo (show . fromEnum) pkgHashDebugInfo - , opt "extra-lib-dirs" [] unwords pkgHashExtraLibDirs - , opt "extra-lib-dirs-static" [] unwords pkgHashExtraLibDirsStatic - , opt "extra-framework-dirs" [] unwords pkgHashExtraFrameworkDirs - , opt "extra-include-dirs" [] unwords pkgHashExtraIncludeDirs - , opt "prog-prefix" Nothing (maybe "" fromPathTemplate) pkgHashProgPrefix - , opt "prog-suffix" Nothing (maybe "" fromPathTemplate) pkgHashProgSuffix - , opt "package-dbs" [] (unwords . map show) pkgHashPackageDbs - - , opt "documentation" False prettyShow pkgHashDocumentation - , opt "haddock-hoogle" False prettyShow pkgHashHaddockHoogle - , opt "haddock-html" False prettyShow pkgHashHaddockHtml - , opt "haddock-html-location" Nothing (fromMaybe "") pkgHashHaddockHtmlLocation - , opt "haddock-foreign-libraries" False prettyShow pkgHashHaddockForeignLibs - , opt "haddock-executables" False prettyShow pkgHashHaddockExecutables - , opt "haddock-tests" False prettyShow pkgHashHaddockTestSuites - , opt "haddock-benchmarks" False prettyShow pkgHashHaddockBenchmarks - , opt "haddock-internal" False prettyShow pkgHashHaddockInternal - , opt "haddock-css" Nothing (fromMaybe "") pkgHashHaddockCss - , opt "haddock-hyperlink-source" False prettyShow pkgHashHaddockLinkedSource - , opt "haddock-quickjump" False prettyShow pkgHashHaddockQuickJump - , 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-output-dir" Nothing (fromMaybe "") pkgHashHaddockOutputDir - - ] ++ Map.foldrWithKey (\prog args acc -> opt (prog ++ "-options") [] unwords args : acc) [] pkgHashProgramArgs - where - entry key format value = Just (key ++ ": " ++ format value) - mentry key format value = fmap (\v -> key ++ ": " ++ format v) value - opt key def format value - | value == def = Nothing - | otherwise = entry key format value + LBS.pack $ + unlines $ + catMaybes $ + [ entry "pkgid" prettyShow pkgHashPkgId + , mentry "component" show pkgHashComponent + , entry "src" showHashValue pkgHashSourceHash + , entry + "pkg-config-deps" + ( intercalate ", " + . map + ( \(pn, mb_v) -> + prettyShow pn + ++ case mb_v of + Nothing -> "" + Just v -> " " ++ prettyShow v + ) + . Set.toList + ) + pkgHashPkgConfigDeps + , entry + "deps" + ( intercalate ", " + . map prettyShow + . Set.toList + ) + pkgHashDirectDeps + , -- and then all the config + entry "compilerid" prettyShow pkgHashCompilerId + , entry "platform" prettyShow pkgHashPlatform + , opt "flags" mempty showFlagAssignment pkgHashFlagAssignment + , opt "configure-script" [] unwords pkgHashConfigureScriptArgs + , opt "vanilla-lib" True prettyShow pkgHashVanillaLib + , opt "shared-lib" False prettyShow pkgHashSharedLib + , opt "dynamic-exe" False prettyShow pkgHashDynExe + , opt "fully-static-exe" False prettyShow pkgHashFullyStaticExe + , opt "ghci-lib" False prettyShow pkgHashGHCiLib + , opt "prof-lib" False prettyShow pkgHashProfLib + , opt "prof-exe" False prettyShow pkgHashProfExe + , opt "prof-lib-detail" ProfDetailDefault showProfDetailLevel pkgHashProfLibDetail + , opt "prof-exe-detail" ProfDetailDefault showProfDetailLevel pkgHashProfExeDetail + , opt "hpc" False prettyShow pkgHashCoverage + , opt "optimisation" NormalOptimisation (show . fromEnum) pkgHashOptimization + , opt "split-objs" False prettyShow pkgHashSplitObjs + , opt "split-sections" False prettyShow pkgHashSplitSections + , opt "stripped-lib" False prettyShow pkgHashStripLibs + , opt "stripped-exe" True prettyShow pkgHashStripExes + , opt "debug-info" NormalDebugInfo (show . fromEnum) pkgHashDebugInfo + , opt "extra-lib-dirs" [] unwords pkgHashExtraLibDirs + , opt "extra-lib-dirs-static" [] unwords pkgHashExtraLibDirsStatic + , opt "extra-framework-dirs" [] unwords pkgHashExtraFrameworkDirs + , opt "extra-include-dirs" [] unwords pkgHashExtraIncludeDirs + , opt "prog-prefix" Nothing (maybe "" fromPathTemplate) pkgHashProgPrefix + , opt "prog-suffix" Nothing (maybe "" fromPathTemplate) pkgHashProgSuffix + , opt "package-dbs" [] (unwords . map show) pkgHashPackageDbs + , opt "documentation" False prettyShow pkgHashDocumentation + , opt "haddock-hoogle" False prettyShow pkgHashHaddockHoogle + , opt "haddock-html" False prettyShow pkgHashHaddockHtml + , opt "haddock-html-location" Nothing (fromMaybe "") pkgHashHaddockHtmlLocation + , opt "haddock-foreign-libraries" False prettyShow pkgHashHaddockForeignLibs + , opt "haddock-executables" False prettyShow pkgHashHaddockExecutables + , opt "haddock-tests" False prettyShow pkgHashHaddockTestSuites + , opt "haddock-benchmarks" False prettyShow pkgHashHaddockBenchmarks + , opt "haddock-internal" False prettyShow pkgHashHaddockInternal + , opt "haddock-css" Nothing (fromMaybe "") pkgHashHaddockCss + , opt "haddock-hyperlink-source" False prettyShow pkgHashHaddockLinkedSource + , opt "haddock-quickjump" False prettyShow pkgHashHaddockQuickJump + , 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-output-dir" Nothing (fromMaybe "") pkgHashHaddockOutputDir + ] + ++ Map.foldrWithKey (\prog args acc -> opt (prog ++ "-options") [] unwords args : acc) [] pkgHashProgramArgs + where + entry key format value = Just (key ++ ": " ++ format value) + mentry key format value = fmap (\v -> key ++ ": " ++ format v) value + opt key def format value + | value == def = Nothing + | otherwise = entry key format value diff --git a/cabal-install/src/Distribution/Client/ParseUtils.hs b/cabal-install/src/Distribution/Client/ParseUtils.hs index 0b8e45c5641..44cdc4ccc22 100644 --- a/cabal-install/src/Distribution/Client/ParseUtils.hs +++ b/cabal-install/src/Distribution/Client/ParseUtils.hs @@ -1,137 +1,150 @@ -{-# LANGUAGE ExistentialQuantification, NamedFieldPuns, RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.ParseUtils -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- Parsing utilities. ------------------------------------------------------------------------------ - -module Distribution.Client.ParseUtils ( - - -- * Fields and field utilities - FieldDescr(..), - liftField, - liftFields, - filterFields, - mapFieldNames, - commandOptionToField, - commandOptionsToFields, +module Distribution.Client.ParseUtils + ( -- * Fields and field utilities + FieldDescr (..) + , liftField + , liftFields + , filterFields + , mapFieldNames + , commandOptionToField + , commandOptionsToFields -- * Sections and utilities - SectionDescr(..), - liftSection, + , SectionDescr (..) + , liftSection -- * FieldGrammar sections - FGSectionDescr(..), + , FGSectionDescr (..) -- * Parsing and printing flat config - parseFields, - ppFields, - ppSection, + , parseFields + , ppFields + , ppSection -- * Parsing and printing config with sections and subsections - parseFieldsAndSections, - ppFieldsAndSections, + , parseFieldsAndSections + , ppFieldsAndSections -- ** Top level of config files - parseConfig, - showConfig, + , parseConfig + , showConfig ) - where +where import Distribution.Client.Compat.Prelude hiding (empty, get) import Prelude () import Distribution.Deprecated.ParseUtils - ( FieldDescr(..), ParseResult(..), warning, LineNo, lineNo - , Field(..), liftField, readFields ) + ( Field (..) + , FieldDescr (..) + , LineNo + , ParseResult (..) + , liftField + , lineNo + , readFields + , warning + ) import Distribution.Deprecated.ViewAsFieldDescr - ( viewAsFieldDescr ) + ( viewAsFieldDescr + ) import Distribution.Simple.Command - ( OptionField ) + ( OptionField + ) -import Text.PrettyPrint ( ($+$) ) import qualified Data.ByteString as BS import qualified Data.Map as Map +import Text.PrettyPrint (($+$)) import qualified Text.PrettyPrint as Disp - ( (<>), Doc, text, colon, vcat, empty, isEmpty, nest ) + ( Doc + , colon + , empty + , isEmpty + , nest + , text + , vcat + , (<>) + ) -- For new parser stuff import Distribution.CabalSpecVersion (cabalSpecLatest) -import Distribution.FieldGrammar (partitionFields, parseFieldGrammar) +import Distribution.FieldGrammar (parseFieldGrammar, partitionFields) +import qualified Distribution.FieldGrammar as FG +import qualified Distribution.Fields as F import Distribution.Fields.ParseResult (runParseResult) import Distribution.Parsec.Error (showPError) import Distribution.Parsec.Position (Position (..)) import Distribution.Parsec.Warning (showPWarning) import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS) -import qualified Distribution.Fields as F -import qualified Distribution.FieldGrammar as FG - ------------------------- -- FieldDescr utilities -- -liftFields :: (b -> a) - -> (a -> b -> b) - -> [FieldDescr a] - -> [FieldDescr b] +liftFields + :: (b -> a) + -> (a -> b -> b) + -> [FieldDescr a] + -> [FieldDescr b] liftFields get set = map (liftField get set) - -- | Given a collection of field descriptions, keep only a given list of them, -- identified by name. --- filterFields :: [String] -> [FieldDescr a] -> [FieldDescr a] filterFields includeFields = filter ((`elem` includeFields) . fieldName) -- | Apply a name mangling function to the field names of all the field -- descriptions. The typical use case is to apply some prefix. --- mapFieldNames :: (String -> String) -> [FieldDescr a] -> [FieldDescr a] mapFieldNames mangleName = - map (\descr -> descr { fieldName = mangleName (fieldName descr) }) - + map (\descr -> descr{fieldName = mangleName (fieldName descr)}) -- | Reuse a command line 'OptionField' as a config file 'FieldDescr'. --- commandOptionToField :: OptionField a -> FieldDescr a commandOptionToField = viewAsFieldDescr -- | Reuse a bunch of command line 'OptionField's as config file 'FieldDescr's. --- commandOptionsToFields :: [OptionField a] -> [FieldDescr a] commandOptionsToFields = map viewAsFieldDescr - ------------------------------------------ -- SectionDescr definition and utilities -- -- | The description of a section in a config file. It can contain both -- fields and optionally further subsections. See also 'FieldDescr'. --- -data SectionDescr a = forall b. SectionDescr { - sectionName :: String, - sectionFields :: [FieldDescr b], - sectionSubsections :: [SectionDescr b], - sectionGet :: a -> [(String, b)], - sectionSet :: LineNo -> String -> b -> a -> ParseResult a, - sectionEmpty :: b - } +data SectionDescr a = forall b. + SectionDescr + { sectionName :: String + , sectionFields :: [FieldDescr b] + , sectionSubsections :: [SectionDescr b] + , sectionGet :: a -> [(String, b)] + , sectionSet :: LineNo -> String -> b -> a -> ParseResult a + , sectionEmpty :: b + } -- | 'FieldGrammar' section description -data FGSectionDescr g a = forall s. FGSectionDescr - { fgSectionName :: String - , fgSectionGrammar :: g s s - -- todo: add subsections? - , fgSectionGet :: a -> [(String, s)] - , fgSectionSet :: LineNo -> String -> s -> a -> ParseResult a - } +data FGSectionDescr g a = forall s. + FGSectionDescr + { fgSectionName :: String + , fgSectionGrammar :: g s s + , -- todo: add subsections? + fgSectionGet :: a -> [(String, s)] + , fgSectionSet :: LineNo -> String -> s -> a -> ParseResult a + } -- | To help construction of config file descriptions in a modular way it is -- useful to define fields and sections on local types and then hoist them @@ -139,18 +152,17 @@ data FGSectionDescr g a = forall s. FGSectionDescr -- -- This is essentially a lens operation for 'SectionDescr' to help embedding -- one inside another. --- -liftSection :: (b -> a) - -> (a -> b -> b) - -> SectionDescr a - -> SectionDescr b +liftSection + :: (b -> a) + -> (a -> b -> b) + -> SectionDescr a + -> SectionDescr b liftSection get' set' (SectionDescr name fields sections get set empty) = - let sectionGet' = get . get' - sectionSet' lineno param x y = do - x' <- set lineno param x (get' y) - return (set' x' y) - in SectionDescr name fields sections sectionGet' sectionSet' empty - + let sectionGet' = get . get' + sectionSet' lineno param x y = do + x' <- set lineno param x (get' y) + return (set' x' y) + in SectionDescr name fields sections sectionGet' sectionSet' empty ------------------------------------- -- Parsing and printing flat config @@ -161,12 +173,11 @@ liftSection get' set' (SectionDescr name fields sections get set empty) = -- -- This only covers the case of flat configuration without subsections. See -- also 'parseFieldsAndSections'. --- parseFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a parseFields fieldDescrs = - foldM setField + foldM setField where - fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ] + fieldMap = Map.fromList [(fieldName f, f) | f <- fieldDescrs] setField accum (F line name value) = case Map.lookup name fieldMap of @@ -176,43 +187,52 @@ parseFields fieldDescrs = -- it was automatically added to many config files -- before that, so its warning is silently ignored unless (name == "world-file") $ - warning $ "Unrecognized field " ++ name ++ " on line " ++ show line + warning $ + "Unrecognized field " ++ name ++ " on line " ++ show line return accum - setField accum f = do warning $ "Unrecognized stanza on line " ++ show (lineNo f) return accum -- | This is a customised version of the functions from Distribution.Deprecated.ParseUtils -- that also optionally print default values for empty fields as comments. --- ppFields :: [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc ppFields fields def cur = - Disp.vcat [ ppField name (fmap getter def) (getter cur) - | FieldDescr name getter _ <- fields] + Disp.vcat + [ ppField name (fmap getter def) (getter cur) + | FieldDescr name getter _ <- fields + ] ppField :: String -> (Maybe Disp.Doc) -> Disp.Doc -> Disp.Doc ppField name mdef cur - | Disp.isEmpty cur = maybe Disp.empty - (\def -> Disp.text "--" <+> Disp.text name - Disp.<> Disp.colon <+> def) mdef - | otherwise = Disp.text name Disp.<> Disp.colon <+> cur + | Disp.isEmpty cur = + maybe + Disp.empty + ( \def -> + Disp.text "--" + <+> Disp.text name + Disp.<> Disp.colon + <+> def + ) + mdef + | otherwise = Disp.text name Disp.<> Disp.colon <+> cur -- | Pretty print a section. -- -- Since 'ppFields' does not cover subsections you can use this to add them. -- Or alternatively use a 'SectionDescr' and use 'ppFieldsAndSections'. --- ppSection :: String -> String -> [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc ppSection name arg fields def cur | Disp.isEmpty fieldsDoc = Disp.empty - | otherwise = Disp.text name <+> argDoc - $+$ (Disp.nest 2 fieldsDoc) + | otherwise = + Disp.text name + <+> argDoc + $+$ (Disp.nest 2 fieldsDoc) where fieldsDoc = ppFields fields def cur - argDoc | arg == "" = Disp.empty - | otherwise = Disp.text arg - + argDoc + | arg == "" = Disp.empty + | otherwise = Disp.text arg ----------------------------------------- -- Parsing and printing non-flat config @@ -220,28 +240,33 @@ ppSection name arg fields def cur -- | Much like 'parseFields' but it also allows subsections. The permitted -- subsections are given by a list of 'SectionDescr's. --- parseFieldsAndSections - :: [FieldDescr a] -- ^ field - -> [SectionDescr a] -- ^ legacy sections - -> [FGSectionDescr FG.ParsecFieldGrammar a] -- ^ FieldGrammar sections - -> a - -> [Field] -> ParseResult a + :: [FieldDescr a] + -- ^ field + -> [SectionDescr a] + -- ^ legacy sections + -> [FGSectionDescr FG.ParsecFieldGrammar a] + -- ^ FieldGrammar sections + -> a + -> [Field] + -> ParseResult a parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs = - foldM setField + foldM setField where - fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ] - sectionMap = Map.fromList [ (sectionName s, s) | s <- sectionDescrs ] - fgSectionMap = Map.fromList [ (fgSectionName s, s) | s <- fgSectionDescrs ] + fieldMap = Map.fromList [(fieldName f, f) | f <- fieldDescrs] + sectionMap = Map.fromList [(sectionName s, s) | s <- sectionDescrs] + fgSectionMap = Map.fromList [(fgSectionName s, s) | s <- fgSectionDescrs] setField a (F line name value) = case Map.lookup name fieldMap of Just (FieldDescr _ _ set) -> set line value a Nothing -> do - warning $ "Unrecognized field '" ++ name - ++ "' on line " ++ show line + warning $ + "Unrecognized field '" + ++ name + ++ "' on line " + ++ show line return a - setField a (Section line name param fields) = case Left <$> Map.lookup name sectionMap <|> Right <$> Map.lookup name fgSectionMap of Just (Left (SectionDescr _ fieldDescrs' sectionDescrs' _ set sectionEmpty)) -> do @@ -252,8 +277,11 @@ parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs = (fields2, sections) = partitionFields fields1 -- TODO: recurse into sections for_ (concat sections) $ \(FG.MkSection (F.Name (Position line' _) name') _ _) -> - warning $ "Unrecognized section '" ++ fromUTF8BS name' - ++ "' on line " ++ show line' + warning $ + "Unrecognized section '" + ++ fromUTF8BS name' + ++ "' on line " + ++ show line' case runParseResult $ parseFieldGrammar cabalSpecLatest fields2 grammar of (warnings, Right b) -> do for_ warnings $ \w -> warning $ showPWarning "???" w @@ -263,18 +291,21 @@ parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs = case errs of err :| _errs -> fail $ showPError "???" err Nothing -> do - warning $ "Unrecognized section '" ++ name - ++ "' on line " ++ show line + warning $ + "Unrecognized section '" + ++ name + ++ "' on line " + ++ show line return a convertField :: Field -> F.Field Position convertField (F line name str) = - F.Field (F.Name pos (toUTF8BS name)) [ F.FieldLine pos $ toUTF8BS str ] + F.Field (F.Name pos (toUTF8BS name)) [F.FieldLine pos $ toUTF8BS str] where pos = Position line 0 -- arguments omitted convertField (Section line name _arg fields) = - F.Section (F.Name pos (toUTF8BS name)) [] (map convertField fields) + F.Section (F.Name pos (toUTF8BS name)) [] (map convertField fields) where pos = Position line 0 @@ -283,72 +314,91 @@ convertField (Section line name _arg fields) = -- -- Note that unlike 'ppFields', at present it does not support printing -- default values. If needed, adding such support would be quite reasonable. --- ppFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc ppFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs val = - ppFields fieldDescrs Nothing val - $+$ - Disp.vcat ( - [ Disp.text "" $+$ sectionDoc - | SectionDescr { - sectionName, sectionGet, - sectionFields, sectionSubsections - } <- sectionDescrs - , (param, x) <- sectionGet val - , let sectionDoc = ppSectionAndSubsections - sectionName param - sectionFields sectionSubsections [] x - , not (Disp.isEmpty sectionDoc) - ] ++ - [ Disp.text "" $+$ sectionDoc - | FGSectionDescr { fgSectionName, fgSectionGrammar, fgSectionGet } <- fgSectionDescrs - , (param, x) <- fgSectionGet val - , let sectionDoc = ppFgSection fgSectionName param fgSectionGrammar x - , not (Disp.isEmpty sectionDoc) - ]) + ppFields fieldDescrs Nothing val + $+$ Disp.vcat + ( [ Disp.text "" $+$ sectionDoc + | SectionDescr + { sectionName + , sectionGet + , sectionFields + , sectionSubsections + } <- + sectionDescrs + , (param, x) <- sectionGet val + , let sectionDoc = + ppSectionAndSubsections + sectionName + param + sectionFields + sectionSubsections + [] + x + , not (Disp.isEmpty sectionDoc) + ] + ++ [ Disp.text "" $+$ sectionDoc + | FGSectionDescr{fgSectionName, fgSectionGrammar, fgSectionGet} <- fgSectionDescrs + , (param, x) <- fgSectionGet val + , let sectionDoc = ppFgSection fgSectionName param fgSectionGrammar x + , not (Disp.isEmpty sectionDoc) + ] + ) -- | Unlike 'ppSection' which has to be called directly, this gets used via -- 'ppFieldsAndSections' and so does not need to be exported. --- -ppSectionAndSubsections :: String -> String - -> [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc +ppSectionAndSubsections + :: String + -> String + -> [FieldDescr a] + -> [SectionDescr a] + -> [FGSectionDescr FG.PrettyFieldGrammar a] + -> a + -> Disp.Doc ppSectionAndSubsections name arg fields sections fgSections cur | Disp.isEmpty fieldsDoc = Disp.empty - | otherwise = Disp.text name <+> argDoc - $+$ (Disp.nest 2 fieldsDoc) + | otherwise = + Disp.text name + <+> argDoc + $+$ (Disp.nest 2 fieldsDoc) where fieldsDoc = showConfig fields sections fgSections cur - argDoc | arg == "" = Disp.empty - | otherwise = Disp.text arg + argDoc + | arg == "" = Disp.empty + | otherwise = Disp.text arg -- | -- -- TODO: subsections -- TODO: this should simply build 'PrettyField' ppFgSection - :: String -- ^ section name - -> String -- ^ parameter - -> FG.PrettyFieldGrammar a a - -> a - -> Disp.Doc + :: String + -- ^ section name + -> String + -- ^ parameter + -> FG.PrettyFieldGrammar a a + -> a + -> Disp.Doc ppFgSection secName arg grammar x - | null prettyFields = Disp.empty - | otherwise = - Disp.text secName <+> argDoc + | null prettyFields = Disp.empty + | otherwise = + Disp.text secName + <+> argDoc $+$ (Disp.nest 2 fieldsDoc) where prettyFields = FG.prettyFieldGrammar cabalSpecLatest grammar x - argDoc | arg == "" = Disp.empty - | otherwise = Disp.text arg + argDoc + | arg == "" = Disp.empty + | otherwise = Disp.text arg - fieldsDoc = Disp.vcat + fieldsDoc = + Disp.vcat [ Disp.text fname' <<>> Disp.colon <<>> doc | F.PrettyField _ fname doc <- prettyFields -- TODO: this skips sections , let fname' = fromUTF8BS fname ] - ----------------------------------------------- -- Top level config file parsing and printing -- @@ -357,15 +407,18 @@ ppFgSection secName arg grammar x -- description of the configuration file in terms of its fields and sections. -- -- It accumulates the result on top of a given initial (typically empty) value. --- -parseConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.ParsecFieldGrammar a] -> a - -> BS.ByteString -> ParseResult a +parseConfig + :: [FieldDescr a] + -> [SectionDescr a] + -> [FGSectionDescr FG.ParsecFieldGrammar a] + -> a + -> BS.ByteString + -> ParseResult a parseConfig fieldDescrs sectionDescrs fgSectionDescrs empty str = - parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs empty - =<< readFields str + parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs empty + =<< readFields str -- | Render a value in the config file syntax, based on a description of the -- configuration file in terms of its fields and sections. --- showConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc showConfig = ppFieldsAndSections diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 19a6661b6f6..627ec3acec1 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -1,117 +1,139 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoMonoLocalBinds #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoMonoLocalBinds #-} + +module Distribution.Client.ProjectBuilding + ( -- * Dry run phase --- | --- -module Distribution.Client.ProjectBuilding ( - -- * Dry run phase -- | What bits of the plan will we execute? The dry run does not change -- anything but tells us what will need to be built. - rebuildTargetsDryRun, - improveInstallPlanWithUpToDatePackages, + rebuildTargetsDryRun + , improveInstallPlanWithUpToDatePackages -- ** Build status + -- | This is the detailed status information we get from the dry run. - BuildStatusMap, - BuildStatus(..), - BuildStatusRebuild(..), - BuildReason(..), - MonitorChangedReason(..), - buildStatusToString, + , BuildStatusMap + , BuildStatus (..) + , BuildStatusRebuild (..) + , BuildReason (..) + , MonitorChangedReason (..) + , buildStatusToString -- * Build phase + -- | Now we actually execute the plan. - rebuildTargets, + , rebuildTargets + -- ** Build outcomes + -- | This is the outcome for each package of executing the plan. -- For each package, did the build succeed or fail? - BuildOutcomes, - BuildOutcome, - BuildResult(..), - BuildFailure(..), - BuildFailureReason(..), + , BuildOutcomes + , BuildOutcome + , BuildResult (..) + , BuildFailure (..) + , BuildFailureReason (..) ) where import Distribution.Client.Compat.Prelude import Prelude () -import Distribution.Client.PackageHash (renderPackageHashInputs) -import Distribution.Client.RebuildMonad -import Distribution.Client.ProjectConfig -import Distribution.Client.ProjectPlanning -import Distribution.Client.ProjectPlanning.Types -import Distribution.Client.ProjectBuilding.Types -import Distribution.Client.Store - -import Distribution.Client.Types - hiding (BuildOutcomes, BuildOutcome, - BuildResult(..), BuildFailure(..)) -import Distribution.Client.InstallPlan - ( GenericInstallPlan, GenericPlanPackage, IsUnit ) +import Distribution.Client.PackageHash (renderPackageHashInputs) +import Distribution.Client.ProjectBuilding.Types +import Distribution.Client.ProjectConfig +import Distribution.Client.ProjectPlanning +import Distribution.Client.ProjectPlanning.Types +import Distribution.Client.RebuildMonad +import Distribution.Client.Store + +import Distribution.Client.DistDirLayout +import Distribution.Client.FetchUtils +import Distribution.Client.FileMonitor +import Distribution.Client.GlobalFlags (RepoContext) +import Distribution.Client.InstallPlan + ( GenericInstallPlan + , GenericPlanPackage + , IsUnit + ) import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.DistDirLayout -import Distribution.Client.FileMonitor -import Distribution.Client.SetupWrapper -import Distribution.Client.JobControl -import Distribution.Client.FetchUtils -import Distribution.Client.GlobalFlags (RepoContext) +import Distribution.Client.JobControl +import Distribution.Client.Setup + ( filterConfigureFlags + , filterHaddockArgs + , filterHaddockFlags + , filterTestFlags + ) +import Distribution.Client.SetupWrapper +import Distribution.Client.SourceFiles +import Distribution.Client.SrcDist (allPackageSourceFiles) import qualified Distribution.Client.Tar as Tar -import Distribution.Client.Setup - ( filterConfigureFlags, filterHaddockArgs - , filterHaddockFlags, filterTestFlags ) -import Distribution.Client.SourceFiles -import Distribution.Client.SrcDist (allPackageSourceFiles) -import Distribution.Client.Utils - ( ProgressPhase(..), findOpenProgramLocation, progressMessage, removeExistingFile ) - -import Distribution.Compat.Lens -import Distribution.Package -import qualified Distribution.PackageDescription as PD -import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import Distribution.Client.Types hiding + ( BuildFailure (..) + , BuildOutcome + , BuildOutcomes + , BuildResult (..) + ) +import Distribution.Client.Utils + ( ProgressPhase (..) + , findOpenProgramLocation + , progressMessage + , removeExistingFile + ) + +import Distribution.Compat.Lens +import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as Installed -import Distribution.Simple.BuildPaths (haddockDirName) +import Distribution.Package +import qualified Distribution.PackageDescription as PD +import Distribution.Simple.BuildPaths (haddockDirName) +import Distribution.Simple.Command (CommandUI) +import Distribution.Simple.Compiler + ( Compiler + , PackageDB (..) + , compilerId + ) import qualified Distribution.Simple.InstallDirs as InstallDirs -import Distribution.Types.BuildType -import Distribution.Types.PackageDescription.Lens (componentModules) -import Distribution.Simple.Program -import qualified Distribution.Simple.Setup as Cabal -import Distribution.Simple.Command (CommandUI) +import Distribution.Simple.LocalBuildInfo + ( ComponentName (..) + , LibraryName (..) + ) +import Distribution.Simple.Program import qualified Distribution.Simple.Register as Cabal -import Distribution.Simple.LocalBuildInfo - ( ComponentName(..), LibraryName(..) ) -import Distribution.Simple.Compiler - ( Compiler, compilerId, PackageDB(..) ) +import qualified Distribution.Simple.Setup as Cabal +import Distribution.Types.BuildType +import Distribution.Types.PackageDescription.Lens (componentModules) -import Distribution.Simple.Utils -import Distribution.Version -import Distribution.Compat.Graph (IsNode(..)) +import Distribution.Compat.Graph (IsNode (..)) +import Distribution.Simple.Utils +import Distribution.Version -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as Map -import qualified Data.Set as Set import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as LBS.Char8 +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map +import qualified Data.Set as Set import qualified Text.PrettyPrint as Disp import Control.Exception (Handler (..), SomeAsyncException, assert, catches, handle) -import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory) -import System.FilePath (dropDrive, makeRelative, normalise, takeDirectory, (<.>), ()) -import System.IO (IOMode (AppendMode), Handle, withFile) +import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory) +import System.FilePath (dropDrive, makeRelative, normalise, takeDirectory, (<.>), ()) +import System.IO (Handle, IOMode (AppendMode), withFile) import Distribution.Compat.Directory (listDirectory) import Distribution.Simple.Flag (fromFlagOrDefault) - ------------------------------------------------------------------------------ + -- * Overall building strategy. + ------------------------------------------------------------------------------ -- -- We start with an 'ElaboratedInstallPlan' that has already been improved by @@ -157,9 +179,10 @@ import Distribution.Simple.Flag (fromFlagOrDefault) -- definitely out of date. See "Distribution.Client.ProjectPlanOutput" for -- details. - ------------------------------------------------------------------------------ + -- * Dry run: what bits of the 'ElaboratedInstallPlan' will we execute? + ------------------------------------------------------------------------------ -- Refer to ProjectBuilding.Types for details of these important types: @@ -175,57 +198,51 @@ import Distribution.Simple.Flag (fromFlagOrDefault) -- 'improveInstallPlanWithUpToDatePackages' to give an improved version of -- the 'ElaboratedInstallPlan' with packages switched to the -- 'InstallPlan.Installed' state when we find that they're already up to date. --- -rebuildTargetsDryRun :: DistDirLayout - -> ElaboratedSharedConfig - -> ElaboratedInstallPlan - -> IO BuildStatusMap +rebuildTargetsDryRun + :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> IO BuildStatusMap rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared = - -- Do the various checks to work out the 'BuildStatus' of each package - foldMInstallPlanDepOrder dryRunPkg + -- Do the various checks to work out the 'BuildStatus' of each package + foldMInstallPlanDepOrder dryRunPkg where - dryRunPkg :: ElaboratedPlanPackage - -> [BuildStatus] - -> IO BuildStatus + dryRunPkg + :: ElaboratedPlanPackage + -> [BuildStatus] + -> IO BuildStatus dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus = return BuildStatusPreExisting - dryRunPkg (InstallPlan.Installed _pkg) _depsBuildStatus = return BuildStatusInstalled - dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do mloc <- checkFetched (elabPkgSourceLocation pkg) case mloc of Nothing -> return BuildStatusDownload - Just (LocalUnpackedPackage srcdir) -> -- For the case of a user-managed local dir, irrespective of the -- build style, we build from that directory and put build -- artifacts under the shared dist directory. dryRunLocalPkg pkg depsBuildStatus srcdir - -- The rest cases are all tarball cases are, -- and handled the same as each other though depending on the build style. - Just (LocalTarballPackage tarball) -> + Just (LocalTarballPackage tarball) -> dryRunTarballPkg pkg depsBuildStatus tarball - Just (RemoteTarballPackage _ tarball) -> dryRunTarballPkg pkg depsBuildStatus tarball - Just (RepoTarballPackage _ _ tarball) -> dryRunTarballPkg pkg depsBuildStatus tarball - Just (RemoteSourceRepoPackage _repo tarball) -> dryRunTarballPkg pkg depsBuildStatus tarball - - dryRunTarballPkg :: ElaboratedConfiguredPackage - -> [BuildStatus] - -> FilePath - -> IO BuildStatus + dryRunTarballPkg + :: ElaboratedConfiguredPackage + -> [BuildStatus] + -> FilePath + -> IO BuildStatus dryRunTarballPkg pkg depsBuildStatus tarball = case elabBuildStyle pkg of - BuildAndInstall -> return (BuildStatusUnpack tarball) + BuildAndInstall -> return (BuildStatusUnpack tarball) BuildInplaceOnly -> do -- TODO: [nice to have] use a proper file monitor rather -- than this dir exists test @@ -237,29 +254,34 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared = srcdir :: FilePath srcdir = distUnpackedSrcDirectory (packageId pkg) - dryRunLocalPkg :: ElaboratedConfiguredPackage - -> [BuildStatus] - -> FilePath - -> IO BuildStatus + dryRunLocalPkg + :: ElaboratedConfiguredPackage + -> [BuildStatus] + -> FilePath + -> IO BuildStatus dryRunLocalPkg pkg depsBuildStatus srcdir = do - -- Go and do lots of I/O, reading caches and probing files to work out - -- if anything has changed - change <- checkPackageFileMonitorChanged - packageFileMonitor pkg srcdir depsBuildStatus - case change of - -- It did change, giving us 'BuildStatusRebuild' info on why - Left rebuild -> - return (BuildStatusRebuild srcdir rebuild) - - -- No changes, the package is up to date. Use the saved build results. - Right buildResult -> - return (BuildStatusUpToDate buildResult) + -- Go and do lots of I/O, reading caches and probing files to work out + -- if anything has changed + change <- + checkPackageFileMonitorChanged + packageFileMonitor + pkg + srcdir + depsBuildStatus + case change of + -- It did change, giving us 'BuildStatusRebuild' info on why + Left rebuild -> + return (BuildStatusRebuild srcdir rebuild) + -- No changes, the package is up to date. Use the saved build results. + Right buildResult -> + return (BuildStatusUpToDate buildResult) where packageFileMonitor :: PackageFileMonitor packageFileMonitor = - newPackageFileMonitor shared distDirLayout - (elabDistDirParams shared pkg) - + newPackageFileMonitor + shared + distDirLayout + (elabDistDirParams shared pkg) -- | A specialised traversal over the packages in an install plan. -- @@ -268,47 +290,54 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared = -- returned as the final result. In addition, when visiting a package, the -- visiting function is passed the results for all the immediate package -- dependencies. This can be used to propagate information from dependencies. --- foldMInstallPlanDepOrder - :: forall m ipkg srcpkg b. - (Monad m, IsUnit ipkg, IsUnit srcpkg) - => (GenericPlanPackage ipkg srcpkg -> - [b] -> m b) + :: forall m ipkg srcpkg b + . (Monad m, IsUnit ipkg, IsUnit srcpkg) + => ( GenericPlanPackage ipkg srcpkg + -> [b] + -> m b + ) -> GenericInstallPlan ipkg srcpkg -> m (Map UnitId b) foldMInstallPlanDepOrder visit = - go Map.empty . InstallPlan.reverseTopologicalOrder + go Map.empty . InstallPlan.reverseTopologicalOrder where - go :: Map UnitId b - -> [GenericPlanPackage ipkg srcpkg] - -> m (Map UnitId b) + go + :: Map UnitId b + -> [GenericPlanPackage ipkg srcpkg] + -> m (Map UnitId b) go !results [] = return results - go !results (pkg : pkgs) = do -- we go in the right order so the results map has entries for all deps let depresults :: [b] depresults = - map (\ipkgid -> let result = Map.findWithDefault (error "foldMInstallPlanDepOrder") ipkgid results - in result) - (InstallPlan.depends pkg) + map + ( \ipkgid -> + let result = Map.findWithDefault (error "foldMInstallPlanDepOrder") ipkgid results + in result + ) + (InstallPlan.depends pkg) result <- visit pkg depresults let results' = Map.insert (nodeKey pkg) result results go results' pkgs -improveInstallPlanWithUpToDatePackages :: BuildStatusMap - -> ElaboratedInstallPlan - -> ElaboratedInstallPlan +improveInstallPlanWithUpToDatePackages + :: BuildStatusMap + -> ElaboratedInstallPlan + -> ElaboratedInstallPlan improveInstallPlanWithUpToDatePackages pkgsBuildStatus = - InstallPlan.installed canPackageBeImproved + InstallPlan.installed canPackageBeImproved where canPackageBeImproved :: ElaboratedConfiguredPackage -> Bool canPackageBeImproved pkg = case Map.lookup (installedUnitId pkg) pkgsBuildStatus of - Just BuildStatusUpToDate {} -> True - Just _ -> False - Nothing -> error $ "improveInstallPlanWithUpToDatePackages: " - ++ prettyShow (packageId pkg) ++ " not in status map" - + Just BuildStatusUpToDate{} -> True + Just _ -> False + Nothing -> + error $ + "improveInstallPlanWithUpToDatePackages: " + ++ prettyShow (packageId pkg) + ++ " not in status map" ----------------------------- -- Package change detection @@ -323,58 +352,56 @@ improveInstallPlanWithUpToDatePackages pkgsBuildStatus = -- state updates are split into two, one for package config changes and one -- for other changes. This is the purpose of 'updatePackageConfigFileMonitor' -- and 'updatePackageBuildFileMonitor'. --- -data PackageFileMonitor = PackageFileMonitor { - pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage (), - pkgFileMonitorBuild :: FileMonitor (Set ComponentName) BuildResultMisc, - pkgFileMonitorReg :: FileMonitor () (Maybe InstalledPackageInfo) - } +data PackageFileMonitor = PackageFileMonitor + { pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage () + , pkgFileMonitorBuild :: FileMonitor (Set ComponentName) BuildResultMisc + , pkgFileMonitorReg :: FileMonitor () (Maybe InstalledPackageInfo) + } -- | This is all the components of the 'BuildResult' other than the -- @['InstalledPackageInfo']@. -- -- We have to split up the 'BuildResult' components since they get produced -- at different times (or rather, when different things change). --- type BuildResultMisc = (DocsResult, TestsResult) -newPackageFileMonitor :: ElaboratedSharedConfig - -> DistDirLayout - -> DistDirParams - -> PackageFileMonitor -newPackageFileMonitor shared - DistDirLayout{distPackageCacheFile} - dparams = - PackageFileMonitor { - pkgFileMonitorConfig = - FileMonitor { - fileMonitorCacheFile = distPackageCacheFile dparams "config", - fileMonitorKeyValid = (==) `on` normaliseConfiguredPackage shared, - fileMonitorCheckIfOnlyValueChanged = False - }, - - pkgFileMonitorBuild = - FileMonitor { - fileMonitorCacheFile = distPackageCacheFile dparams "build", - fileMonitorKeyValid = \componentsToBuild componentsAlreadyBuilt -> - componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt, - fileMonitorCheckIfOnlyValueChanged = True - }, - - pkgFileMonitorReg = - newFileMonitor (distPackageCacheFile dparams "registration") - } +newPackageFileMonitor + :: ElaboratedSharedConfig + -> DistDirLayout + -> DistDirParams + -> PackageFileMonitor +newPackageFileMonitor + shared + DistDirLayout{distPackageCacheFile} + dparams = + PackageFileMonitor + { pkgFileMonitorConfig = + FileMonitor + { fileMonitorCacheFile = distPackageCacheFile dparams "config" + , fileMonitorKeyValid = (==) `on` normaliseConfiguredPackage shared + , fileMonitorCheckIfOnlyValueChanged = False + } + , pkgFileMonitorBuild = + FileMonitor + { fileMonitorCacheFile = distPackageCacheFile dparams "build" + , fileMonitorKeyValid = \componentsToBuild componentsAlreadyBuilt -> + componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt + , fileMonitorCheckIfOnlyValueChanged = True + } + , pkgFileMonitorReg = + newFileMonitor (distPackageCacheFile dparams "registration") + } -- | Helper function for 'checkPackageFileMonitorChanged', -- 'updatePackageConfigFileMonitor' and 'updatePackageBuildFileMonitor'. -- -- It selects the info from a 'ElaboratedConfiguredPackage' that are used by -- the 'FileMonitor's (in the 'PackageFileMonitor') to detect value changes. --- -packageFileMonitorKeyValues :: ElaboratedConfiguredPackage - -> (ElaboratedConfiguredPackage, Set ComponentName) +packageFileMonitorKeyValues + :: ElaboratedConfiguredPackage + -> (ElaboratedConfiguredPackage, Set ComponentName) packageFileMonitorKeyValues elab = - (elab_config, buildComponents) + (elab_config, buildComponents) where -- The first part is the value used to guard (re)configuring the package. -- That is, if this value changes then we will reconfigure. @@ -391,20 +418,19 @@ packageFileMonitorKeyValues elab = elab_config :: ElaboratedConfiguredPackage elab_config = - elab { - elabBuildTargets = [], - elabTestTargets = [], - elabBenchTargets = [], - elabReplTarget = Nothing, - elabHaddockTargets = [], - elabBuildHaddocks = False, - - elabTestMachineLog = Nothing, - elabTestHumanLog = Nothing, - elabTestShowDetails = Nothing, - elabTestKeepTix = False, - elabTestTestOptions = [], - elabBenchmarkOptions = [] + elab + { elabBuildTargets = [] + , elabTestTargets = [] + , elabBenchTargets = [] + , elabReplTarget = Nothing + , elabHaddockTargets = [] + , elabBuildHaddocks = False + , elabTestMachineLog = Nothing + , elabTestHumanLog = Nothing + , elabTestShowDetails = Nothing + , elabTestKeepTix = False + , elabTestTestOptions = [] + , elabBenchmarkOptions = [] } -- The second part is the value used to guard the build step. So this is @@ -416,137 +442,172 @@ packageFileMonitorKeyValues elab = -- | Do all the checks on whether a package has changed and thus needs either -- rebuilding or reconfiguring and rebuilding. --- -checkPackageFileMonitorChanged :: PackageFileMonitor - -> ElaboratedConfiguredPackage - -> FilePath - -> [BuildStatus] - -> IO (Either BuildStatusRebuild BuildResult) -checkPackageFileMonitorChanged PackageFileMonitor{..} - pkg srcdir depsBuildStatus = do - --TODO: [nice to have] some debug-level message about file - --changes, like rerunIfChanged - configChanged <- checkFileMonitorChanged - pkgFileMonitorConfig srcdir pkgconfig +checkPackageFileMonitorChanged + :: PackageFileMonitor + -> ElaboratedConfiguredPackage + -> FilePath + -> [BuildStatus] + -> IO (Either BuildStatusRebuild BuildResult) +checkPackageFileMonitorChanged + PackageFileMonitor{..} + pkg + srcdir + depsBuildStatus = do + -- TODO: [nice to have] some debug-level message about file + -- changes, like rerunIfChanged + configChanged <- + checkFileMonitorChanged + pkgFileMonitorConfig + srcdir + pkgconfig case configChanged of MonitorChanged monitorReason -> - return (Left (BuildStatusConfigure monitorReason')) + return (Left (BuildStatusConfigure monitorReason')) where monitorReason' = fmap (const ()) monitorReason - MonitorUnchanged () _ - -- The configChanged here includes the identity of the dependencies, - -- so depsBuildStatus is just needed for the changes in the content - -- of dependencies. + -- The configChanged here includes the identity of the dependencies, + -- so depsBuildStatus is just needed for the changes in the content + -- of dependencies. | any buildStatusRequiresBuild depsBuildStatus -> do regChanged <- checkFileMonitorChanged pkgFileMonitorReg srcdir () let mreg = changedToMaybe regChanged return (Left (BuildStatusBuild mreg BuildReasonDepsRebuilt)) - | otherwise -> do - buildChanged <- checkFileMonitorChanged - pkgFileMonitorBuild srcdir buildComponents - regChanged <- checkFileMonitorChanged - pkgFileMonitorReg srcdir () + buildChanged <- + checkFileMonitorChanged + pkgFileMonitorBuild + srcdir + buildComponents + regChanged <- + checkFileMonitorChanged + pkgFileMonitorReg + srcdir + () let mreg = changedToMaybe regChanged case (buildChanged, regChanged) of (MonitorChanged (MonitoredValueChanged prevBuildComponents), _) -> - return (Left (BuildStatusBuild mreg buildReason)) + return (Left (BuildStatusBuild mreg buildReason)) where buildReason = BuildReasonExtraTargets prevBuildComponents - (MonitorChanged monitorReason, _) -> - return (Left (BuildStatusBuild mreg buildReason)) + return (Left (BuildStatusBuild mreg buildReason)) where - buildReason = BuildReasonFilesChanged monitorReason' + buildReason = BuildReasonFilesChanged monitorReason' monitorReason' = fmap (const ()) monitorReason - (MonitorUnchanged _ _, MonitorChanged monitorReason) -> -- this should only happen if the file is corrupt or been -- manually deleted. We don't want to bother with another -- phase just for this, so we'll reregister by doing a build. - return (Left (BuildStatusBuild Nothing buildReason)) + return (Left (BuildStatusBuild Nothing buildReason)) where - buildReason = BuildReasonFilesChanged monitorReason' + buildReason = BuildReasonFilesChanged monitorReason' monitorReason' = fmap (const ()) monitorReason - (MonitorUnchanged _ _, MonitorUnchanged _ _) | pkgHasEphemeralBuildTargets pkg -> - return (Left (BuildStatusBuild mreg buildReason)) + return (Left (BuildStatusBuild mreg buildReason)) where buildReason = BuildReasonEphemeralTargets - (MonitorUnchanged buildResult _, MonitorUnchanged _ _) -> - return $ Right BuildResult { - buildResultDocs = docsResult, - buildResultTests = testsResult, - buildResultLogFile = Nothing - } + return $ + Right + BuildResult + { buildResultDocs = docsResult + , buildResultTests = testsResult + , buildResultLogFile = Nothing + } where (docsResult, testsResult) = buildResult - where - (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg - changedToMaybe :: MonitorChanged a b -> Maybe b - changedToMaybe (MonitorChanged _) = Nothing - changedToMaybe (MonitorUnchanged x _) = Just x - - -updatePackageConfigFileMonitor :: PackageFileMonitor - -> FilePath - -> ElaboratedConfiguredPackage - -> IO () -updatePackageConfigFileMonitor PackageFileMonitor{pkgFileMonitorConfig} - srcdir pkg = - updateFileMonitor pkgFileMonitorConfig srcdir Nothing - [] pkgconfig () - where - (pkgconfig, _buildComponents) = packageFileMonitorKeyValues pkg - -updatePackageBuildFileMonitor :: PackageFileMonitor - -> FilePath - -> MonitorTimestamp - -> ElaboratedConfiguredPackage - -> BuildStatusRebuild - -> [MonitorFilePath] - -> BuildResultMisc - -> IO () -updatePackageBuildFileMonitor PackageFileMonitor{pkgFileMonitorBuild} - srcdir timestamp pkg pkgBuildStatus - monitors buildResult = - updateFileMonitor pkgFileMonitorBuild srcdir (Just timestamp) - monitors buildComponents' buildResult - where - (_pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg - - -- If the only thing that's changed is that we're now building extra - -- components, then we can avoid later unnecessary rebuilds by saving the - -- total set of components that have been built, namely the union of the - -- existing ones plus the new ones. If files also changed this would be - -- the wrong thing to do. Note that we rely on the - -- fileMonitorCheckIfOnlyValueChanged = True mode to get this guarantee - -- that it's /only/ the value that changed not any files that changed. - buildComponents' = - case pkgBuildStatus of - BuildStatusBuild _ (BuildReasonExtraTargets prevBuildComponents) - -> buildComponents `Set.union` prevBuildComponents - _ -> buildComponents - -updatePackageRegFileMonitor :: PackageFileMonitor - -> FilePath - -> Maybe InstalledPackageInfo - -> IO () -updatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} - srcdir mipkg = - updateFileMonitor pkgFileMonitorReg srcdir Nothing - [] () mipkg + where + (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg + changedToMaybe :: MonitorChanged a b -> Maybe b + changedToMaybe (MonitorChanged _) = Nothing + changedToMaybe (MonitorUnchanged x _) = Just x + +updatePackageConfigFileMonitor + :: PackageFileMonitor + -> FilePath + -> ElaboratedConfiguredPackage + -> IO () +updatePackageConfigFileMonitor + PackageFileMonitor{pkgFileMonitorConfig} + srcdir + pkg = + updateFileMonitor + pkgFileMonitorConfig + srcdir + Nothing + [] + pkgconfig + () + where + (pkgconfig, _buildComponents) = packageFileMonitorKeyValues pkg + +updatePackageBuildFileMonitor + :: PackageFileMonitor + -> FilePath + -> MonitorTimestamp + -> ElaboratedConfiguredPackage + -> BuildStatusRebuild + -> [MonitorFilePath] + -> BuildResultMisc + -> IO () +updatePackageBuildFileMonitor + PackageFileMonitor{pkgFileMonitorBuild} + srcdir + timestamp + pkg + pkgBuildStatus + monitors + buildResult = + updateFileMonitor + pkgFileMonitorBuild + srcdir + (Just timestamp) + monitors + buildComponents' + buildResult + where + (_pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg + + -- If the only thing that's changed is that we're now building extra + -- components, then we can avoid later unnecessary rebuilds by saving the + -- total set of components that have been built, namely the union of the + -- existing ones plus the new ones. If files also changed this would be + -- the wrong thing to do. Note that we rely on the + -- fileMonitorCheckIfOnlyValueChanged = True mode to get this guarantee + -- that it's /only/ the value that changed not any files that changed. + buildComponents' = + case pkgBuildStatus of + BuildStatusBuild _ (BuildReasonExtraTargets prevBuildComponents) -> + buildComponents `Set.union` prevBuildComponents + _ -> buildComponents + +updatePackageRegFileMonitor + :: PackageFileMonitor + -> FilePath + -> Maybe InstalledPackageInfo + -> IO () +updatePackageRegFileMonitor + PackageFileMonitor{pkgFileMonitorReg} + srcdir + mipkg = + updateFileMonitor + pkgFileMonitorReg + srcdir + Nothing + [] + () + mipkg invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO () invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} = - removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg) - + removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg) ------------------------------------------------------------------------------ + -- * Doing it: executing an 'ElaboratedInstallPlan' + ------------------------------------------------------------------------------ -- Refer to ProjectBuilding.Types for details of these important types: @@ -560,153 +621,186 @@ invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} = -- | Build things for real. -- -- It requires the 'BuildStatusMap' gathered by 'rebuildTargetsDryRun'. --- -rebuildTargets :: Verbosity - -> ProjectConfig - -> DistDirLayout - -> StoreDirLayout - -> ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> BuildStatusMap - -> BuildTimeSettings - -> IO BuildOutcomes -rebuildTargets verbosity - ProjectConfig { - projectConfigBuildOnly = config - } - distDirLayout@DistDirLayout{..} - storeDirLayout - installPlan - sharedPackageConfig@ElaboratedSharedConfig { - pkgConfigCompiler = compiler, - pkgConfigCompilerProgs = progdb - } - pkgsBuildStatus - buildSettings@BuildTimeSettings{ - buildSettingNumJobs, - buildSettingKeepGoing - } - | fromFlagOrDefault False (projectConfigOfflineMode config) && not (null packagesToDownload) = return offlineError - | otherwise = do - -- Concurrency control: create the job controller and concurrency limits - -- for downloading, building and installing. - jobControl <- if isParallelBuild - then newParallelJobControl buildSettingNumJobs - else newSerialJobControl - registerLock <- newLock -- serialise registration - cacheLock <- newLock -- serialise access to setup exe cache - --TODO: [code cleanup] eliminate setup exe cache - - debug verbosity $ - "Executing install plan " - ++ if isParallelBuild - then " in parallel using " ++ show buildSettingNumJobs ++ " threads." - else " serially." - - createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory - createDirectoryIfMissingVerbose verbosity True distTempDirectory - traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse - - -- Before traversing the install plan, preemptively find all packages that - -- will need to be downloaded and start downloading them. - asyncDownloadPackages verbosity withRepoCtx - installPlan pkgsBuildStatus $ \downloadMap -> - - -- For each package in the plan, in dependency order, but in parallel... - InstallPlan.execute jobControl keepGoing - (BuildFailure Nothing . DependentFailed . packageId) - installPlan $ \pkg -> - --TODO: review exception handling - handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ - - let uid = installedUnitId pkg - pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus in - - rebuildTarget +rebuildTargets + :: Verbosity + -> ProjectConfig + -> DistDirLayout + -> StoreDirLayout + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> BuildStatusMap + -> BuildTimeSettings + -> IO BuildOutcomes +rebuildTargets + verbosity + ProjectConfig + { projectConfigBuildOnly = config + } + distDirLayout@DistDirLayout{..} + storeDirLayout + installPlan + sharedPackageConfig@ElaboratedSharedConfig + { pkgConfigCompiler = compiler + , pkgConfigCompilerProgs = progdb + } + pkgsBuildStatus + buildSettings@BuildTimeSettings + { buildSettingNumJobs + , buildSettingKeepGoing + } + | fromFlagOrDefault False (projectConfigOfflineMode config) && not (null packagesToDownload) = return offlineError + | otherwise = do + -- Concurrency control: create the job controller and concurrency limits + -- for downloading, building and installing. + jobControl <- + if isParallelBuild + then newParallelJobControl buildSettingNumJobs + else newSerialJobControl + registerLock <- newLock -- serialise registration + cacheLock <- newLock -- serialise access to setup exe cache + -- TODO: [code cleanup] eliminate setup exe cache + debug verbosity $ + "Executing install plan " + ++ if isParallelBuild + then " in parallel using " ++ show buildSettingNumJobs ++ " threads." + else " serially." + + createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory + createDirectoryIfMissingVerbose verbosity True distTempDirectory + traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse + + -- Before traversing the install plan, preemptively find all packages that + -- will need to be downloaded and start downloading them. + asyncDownloadPackages verbosity - distDirLayout - storeDirLayout - buildSettings downloadMap - registerLock cacheLock - sharedPackageConfig - installPlan pkg - pkgBuildStatus - where - isParallelBuild = buildSettingNumJobs >= 2 - keepGoing = buildSettingKeepGoing - withRepoCtx = projectConfigWithBuilderRepoContext verbosity - buildSettings - packageDBsToUse = -- all the package dbs we may need to create - (Set.toList . Set.fromList) - [ pkgdb - | InstallPlan.Configured elab <- InstallPlan.toList installPlan - , pkgdb <- concat [ elabBuildPackageDBStack elab - , elabRegisterPackageDBStack elab - , elabSetupPackageDBStack elab ] + withRepoCtx + installPlan + pkgsBuildStatus + $ \downloadMap -> + -- For each package in the plan, in dependency order, but in parallel... + InstallPlan.execute + jobControl + keepGoing + (BuildFailure Nothing . DependentFailed . packageId) + installPlan + $ \pkg -> + -- TODO: review exception handling + handle (\(e :: BuildFailure) -> return (Left e)) $ + fmap Right $ + let uid = installedUnitId pkg + pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus + in rebuildTarget + verbosity + distDirLayout + storeDirLayout + buildSettings + downloadMap + registerLock + cacheLock + sharedPackageConfig + installPlan + pkg + pkgBuildStatus + where + isParallelBuild = buildSettingNumJobs >= 2 + keepGoing = buildSettingKeepGoing + withRepoCtx = + projectConfigWithBuilderRepoContext + verbosity + buildSettings + packageDBsToUse = + -- all the package dbs we may need to create + (Set.toList . Set.fromList) + [ pkgdb + | InstallPlan.Configured elab <- InstallPlan.toList installPlan + , pkgdb <- + concat + [ elabBuildPackageDBStack elab + , elabRegisterPackageDBStack elab + , elabSetupPackageDBStack elab + ] + ] + + offlineError :: BuildOutcomes + offlineError = Map.fromList . map makeBuildOutcome $ packagesToDownload + where + makeBuildOutcome :: ElaboratedConfiguredPackage -> (UnitId, BuildOutcome) + makeBuildOutcome + ElaboratedConfiguredPackage + { elabUnitId + , elabPkgSourceId = PackageIdentifier{pkgName, pkgVersion} + } = + ( elabUnitId + , Left + ( BuildFailure + { buildFailureLogFile = Nothing + , buildFailureReason = GracefulFailure $ makeError pkgName pkgVersion + } + ) + ) + makeError :: PackageName -> Version -> String + makeError n v = + "--offline was specified, hence refusing to download the package: " + ++ unPackageName n + ++ " version " + ++ Disp.render (pretty v) + + packagesToDownload :: [ElaboratedConfiguredPackage] + packagesToDownload = + [ elab | InstallPlan.Configured elab <- InstallPlan.reverseTopologicalOrder installPlan, isRemote $ elabPkgSourceLocation elab ] - - offlineError :: BuildOutcomes - offlineError = Map.fromList . map makeBuildOutcome $ packagesToDownload - where - makeBuildOutcome :: ElaboratedConfiguredPackage -> (UnitId, BuildOutcome) - makeBuildOutcome ElaboratedConfiguredPackage { - elabUnitId, - elabPkgSourceId = PackageIdentifier { pkgName, pkgVersion } - } = (elabUnitId, Left (BuildFailure { - buildFailureLogFile = Nothing, - buildFailureReason = GracefulFailure $ makeError pkgName pkgVersion - })) - makeError :: PackageName -> Version -> String - makeError n v = "--offline was specified, hence refusing to download the package: " - ++ unPackageName n - ++ " version " ++ Disp.render (pretty v) - - packagesToDownload :: [ElaboratedConfiguredPackage] - packagesToDownload = [elab | InstallPlan.Configured elab <- InstallPlan.reverseTopologicalOrder installPlan, - isRemote $ elabPkgSourceLocation elab] - where - isRemote :: PackageLocation a -> Bool - isRemote (RemoteTarballPackage _ _) = True - isRemote (RepoTarballPackage {}) = True - isRemote (RemoteSourceRepoPackage _ _) = True - isRemote _ = False - + where + isRemote :: PackageLocation a -> Bool + isRemote (RemoteTarballPackage _ _) = True + isRemote (RepoTarballPackage{}) = True + isRemote (RemoteSourceRepoPackage _ _) = True + isRemote _ = False -- | Create a package DB if it does not currently exist. Note that this action -- is /not/ safe to run concurrently. --- -createPackageDBIfMissing :: Verbosity -> Compiler -> ProgramDb - -> PackageDB -> IO () -createPackageDBIfMissing verbosity compiler progdb - (SpecificPackageDB dbPath) = do +createPackageDBIfMissing + :: Verbosity + -> Compiler + -> ProgramDb + -> PackageDB + -> IO () +createPackageDBIfMissing + verbosity + compiler + progdb + (SpecificPackageDB dbPath) = do exists <- Cabal.doesPackageDBExist dbPath unless exists $ do createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath) Cabal.createPackageDB verbosity compiler progdb False dbPath createPackageDBIfMissing _ _ _ _ = return () - -- | Given all the context and resources, (re)build an individual package. --- -rebuildTarget :: Verbosity - -> DistDirLayout - -> StoreDirLayout - -> BuildTimeSettings - -> AsyncFetchMap - -> Lock -> Lock - -> ElaboratedSharedConfig - -> ElaboratedInstallPlan - -> ElaboratedReadyPackage - -> BuildStatus - -> IO BuildResult -rebuildTarget verbosity - distDirLayout@DistDirLayout{distBuildDirectory} - storeDirLayout - buildSettings downloadMap - registerLock cacheLock - sharedPackageConfig - plan rpkg@(ReadyPackage pkg) - pkgBuildStatus +rebuildTarget + :: Verbosity + -> DistDirLayout + -> StoreDirLayout + -> BuildTimeSettings + -> AsyncFetchMap + -> Lock + -> Lock + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedReadyPackage + -> BuildStatus + -> IO BuildResult +rebuildTarget + verbosity + distDirLayout@DistDirLayout{distBuildDirectory} + storeDirLayout + buildSettings + downloadMap + registerLock + cacheLock + sharedPackageConfig + plan + rpkg@(ReadyPackage pkg) + pkgBuildStatus -- Technically, doing the --only-download filtering only in this function is -- not perfect. We could also prune the plan at an earlier stage, like it's -- done with --only-dependencies. But... @@ -722,77 +816,89 @@ rebuildTarget verbosity _ -> return () return $ BuildResult DocsNotTried TestsNotTried Nothing | otherwise = - -- We rely on the 'BuildStatus' to decide which phase to start from: - case pkgBuildStatus of - BuildStatusDownload -> downloadPhase - BuildStatusUnpack tarball -> unpackTarballPhase tarball - BuildStatusRebuild srcdir status -> rebuildPhase status srcdir - - -- TODO: perhaps re-nest the types to make these impossible - BuildStatusPreExisting {} -> unexpectedState - BuildStatusInstalled {} -> unexpectedState - BuildStatusUpToDate {} -> unexpectedState - where - unexpectedState = error "rebuildTarget: unexpected package status" - - downloadPhase :: IO BuildResult - downloadPhase = do - downsrcloc <- annotateFailureNoLog DownloadFailed $ - waitAsyncPackageDownload verbosity downloadMap pkg + -- We rely on the 'BuildStatus' to decide which phase to start from: + case pkgBuildStatus of + BuildStatusDownload -> downloadPhase + BuildStatusUnpack tarball -> unpackTarballPhase tarball + BuildStatusRebuild srcdir status -> rebuildPhase status srcdir + -- TODO: perhaps re-nest the types to make these impossible + BuildStatusPreExisting{} -> unexpectedState + BuildStatusInstalled{} -> unexpectedState + BuildStatusUpToDate{} -> unexpectedState + where + unexpectedState = error "rebuildTarget: unexpected package status" + + downloadPhase :: IO BuildResult + downloadPhase = do + downsrcloc <- + annotateFailureNoLog DownloadFailed $ + waitAsyncPackageDownload verbosity downloadMap pkg case downsrcloc of DownloadedTarball tarball -> unpackTarballPhase tarball - --TODO: [nice to have] git/darcs repos etc + -- TODO: [nice to have] git/darcs repos etc - - unpackTarballPhase :: FilePath -> IO BuildResult - unpackTarballPhase tarball = + unpackTarballPhase :: FilePath -> IO BuildResult + unpackTarballPhase tarball = withTarballLocalDirectory - verbosity distDirLayout tarball - (packageId pkg) (elabDistDirParams sharedPackageConfig pkg) + verbosity + distDirLayout + tarball + (packageId pkg) + (elabDistDirParams sharedPackageConfig pkg) (elabBuildStyle pkg) - (elabPkgDescriptionOverride pkg) $ - - case elabBuildStyle pkg of - BuildAndInstall -> buildAndInstall + (elabPkgDescriptionOverride pkg) + $ case elabBuildStyle pkg of + BuildAndInstall -> buildAndInstall BuildInplaceOnly -> buildInplace buildStatus where buildStatus = BuildStatusConfigure MonitorFirstRun - -- Note that this really is rebuild, not build. It can only happen for - -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages - -- would only start from download or unpack phases. - -- - rebuildPhase :: BuildStatusRebuild -> FilePath -> IO BuildResult - rebuildPhase buildStatus srcdir = + -- Note that this really is rebuild, not build. It can only happen for + -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages + -- would only start from download or unpack phases. + -- + rebuildPhase :: BuildStatusRebuild -> FilePath -> IO BuildResult + rebuildPhase buildStatus srcdir = assert (elabBuildStyle pkg == BuildInplaceOnly) $ - buildInplace buildStatus srcdir builddir - where - builddir = distBuildDirectory - (elabDistDirParams sharedPackageConfig pkg) + where + builddir = + distBuildDirectory + (elabDistDirParams sharedPackageConfig pkg) - buildAndInstall :: FilePath -> FilePath -> IO BuildResult - buildAndInstall srcdir builddir = + buildAndInstall :: FilePath -> FilePath -> IO BuildResult + buildAndInstall srcdir builddir = buildAndInstallUnpackedPackage - verbosity distDirLayout storeDirLayout - buildSettings registerLock cacheLock + verbosity + distDirLayout + storeDirLayout + buildSettings + registerLock + cacheLock sharedPackageConfig - plan rpkg - srcdir builddir' - where - builddir' = makeRelative srcdir builddir - --TODO: [nice to have] ^^ do this relative stuff better + plan + rpkg + srcdir + builddir' + where + builddir' = makeRelative srcdir builddir + -- TODO: [nice to have] ^^ do this relative stuff better - buildInplace :: BuildStatusRebuild -> FilePath -> FilePath -> IO BuildResult - buildInplace buildStatus srcdir builddir = - --TODO: [nice to have] use a relative build dir rather than absolute + buildInplace :: BuildStatusRebuild -> FilePath -> FilePath -> IO BuildResult + buildInplace buildStatus srcdir builddir = + -- TODO: [nice to have] use a relative build dir rather than absolute buildInplaceUnpackedPackage - verbosity distDirLayout - buildSettings registerLock cacheLock + verbosity + distDirLayout + buildSettings + registerLock + cacheLock sharedPackageConfig - plan rpkg + plan + rpkg buildStatus - srcdir builddir + srcdir + builddir -- TODO: [nice to have] do we need to use a with-style for the temp -- files for downloading http packages, or are we going to cache them @@ -806,62 +912,65 @@ rebuildTarget verbosity -- The body action is passed a map from those packages (identified by their -- location) to a completion var for that package. So the body action should -- lookup the location and use 'waitAsyncPackageDownload' to get the result. --- -asyncDownloadPackages :: Verbosity - -> ((RepoContext -> IO a) -> IO a) - -> ElaboratedInstallPlan - -> BuildStatusMap - -> (AsyncFetchMap -> IO a) - -> IO a +asyncDownloadPackages + :: Verbosity + -> ((RepoContext -> IO a) -> IO a) + -> ElaboratedInstallPlan + -> BuildStatusMap + -> (AsyncFetchMap -> IO a) + -> IO a asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body | null pkgsToDownload = body Map.empty - | otherwise = withRepoCtx $ \repoctx -> - asyncFetchPackages verbosity repoctx - pkgsToDownload body + | otherwise = withRepoCtx $ \repoctx -> + asyncFetchPackages + verbosity + repoctx + pkgsToDownload + body where pkgsToDownload :: [PackageLocation (Maybe FilePath)] pkgsToDownload = ordNub $ - [ elabPkgSourceLocation elab - | InstallPlan.Configured elab - <- InstallPlan.reverseTopologicalOrder installPlan - , let uid = installedUnitId elab - pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") uid pkgsBuildStatus - , BuildStatusDownload <- [pkgBuildStatus] - ] - + [ elabPkgSourceLocation elab + | InstallPlan.Configured elab <- + InstallPlan.reverseTopologicalOrder installPlan + , let uid = installedUnitId elab + pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") uid pkgsBuildStatus + , BuildStatusDownload <- [pkgBuildStatus] + ] -- | Check if a package needs downloading, and if so expect to find a download -- in progress in the given 'AsyncFetchMap' and wait on it to finish. --- -waitAsyncPackageDownload :: Verbosity - -> AsyncFetchMap - -> ElaboratedConfiguredPackage - -> IO DownloadedSourceLocation +waitAsyncPackageDownload + :: Verbosity + -> AsyncFetchMap + -> ElaboratedConfiguredPackage + -> IO DownloadedSourceLocation waitAsyncPackageDownload verbosity downloadMap elab = do - pkgloc <- waitAsyncFetchPackage verbosity downloadMap - (elabPkgSourceLocation elab) - case downloadedSourceLocation pkgloc of - Just loc -> return loc - Nothing -> fail "waitAsyncPackageDownload: unexpected source location" + pkgloc <- + waitAsyncFetchPackage + verbosity + downloadMap + (elabPkgSourceLocation elab) + case downloadedSourceLocation pkgloc of + Just loc -> return loc + Nothing -> fail "waitAsyncPackageDownload: unexpected source location" data DownloadedSourceLocation = DownloadedTarball FilePath - --TODO: [nice to have] git/darcs repos etc - -downloadedSourceLocation :: PackageLocation FilePath - -> Maybe DownloadedSourceLocation -downloadedSourceLocation pkgloc = - case pkgloc of - RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball) - RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball) - _ -> Nothing - +-- TODO: [nice to have] git/darcs repos etc +downloadedSourceLocation + :: PackageLocation FilePath + -> Maybe DownloadedSourceLocation +downloadedSourceLocation pkgloc = + case pkgloc of + RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball) + RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball) + _ -> Nothing -- | Ensure that the package is unpacked in an appropriate directory, either -- a temporary one or a persistent one under the shared dist directory. --- withTarballLocalDirectory :: Verbosity -> DistDirLayout @@ -870,85 +979,109 @@ withTarballLocalDirectory -> DistDirParams -> BuildStyle -> Maybe CabalFileText - -> (FilePath -> -- Source directory - FilePath -> -- Build directory - IO a) + -> ( FilePath -- Source directory + -> FilePath -- Build directory + -> IO a + ) -> IO a -withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..} - tarball pkgid dparams buildstyle pkgTextOverride - buildPkg = - case buildstyle of - -- In this case we make a temp dir (e.g. tmp/src2345/), unpack - -- the tarball to it (e.g. tmp/src2345/foo-1.0/), and for - -- compatibility we put the dist dir within it - -- (i.e. tmp/src2345/foo-1.0/dist/). - -- - -- Unfortunately, a few custom Setup.hs scripts do not respect - -- the --builddir flag and always look for it at ./dist/ so - -- this way we avoid breaking those packages - BuildAndInstall -> - let tmpdir = distTempDirectory in - withTempDirectory verbosity tmpdir "src" $ \unpackdir -> do - 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 - -- appropriate location under the shared dist dir, and then build it - -- inplace there - BuildInplaceOnly -> do - let srcrootdir = distUnpackedSrcRootDirectory - srcdir = distUnpackedSrcDirectory pkgid - builddir = distBuildDirectory dparams - -- 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 verbosity tarball srcrootdir - pkgid pkgTextOverride - moveTarballShippedDistDirectory verbosity distDirLayout - srcrootdir pkgid dparams - buildPkg srcdir builddir - - -unpackPackageTarball :: Verbosity -> FilePath -> FilePath - -> PackageId -> Maybe CabalFileText - -> IO () -unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride = - --TODO: [nice to have] switch to tar package and catch tar exceptions - annotateFailureNoLog UnpackFailed $ do - - -- Unpack the tarball +withTarballLocalDirectory + verbosity + distDirLayout@DistDirLayout{..} + tarball + pkgid + dparams + buildstyle + pkgTextOverride + buildPkg = + case buildstyle of + -- In this case we make a temp dir (e.g. tmp/src2345/), unpack + -- the tarball to it (e.g. tmp/src2345/foo-1.0/), and for + -- compatibility we put the dist dir within it + -- (i.e. tmp/src2345/foo-1.0/dist/). -- - info verbosity $ "Extracting " ++ tarball ++ " to " ++ parentdir ++ "..." - Tar.extractTarGzFile parentdir pkgsubdir tarball + -- Unfortunately, a few custom Setup.hs scripts do not respect + -- the --builddir flag and always look for it at ./dist/ so + -- this way we avoid breaking those packages + BuildAndInstall -> + let tmpdir = distTempDirectory + in withTempDirectory verbosity tmpdir "src" $ \unpackdir -> do + 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 + -- appropriate location under the shared dist dir, and then build it + -- inplace there + BuildInplaceOnly -> do + let srcrootdir = distUnpackedSrcRootDirectory + srcdir = distUnpackedSrcDirectory pkgid + builddir = distBuildDirectory dparams + -- 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 + verbosity + tarball + srcrootdir + pkgid + pkgTextOverride + moveTarballShippedDistDirectory + verbosity + distDirLayout + srcrootdir + pkgid + dparams + buildPkg srcdir builddir + +unpackPackageTarball + :: Verbosity + -> FilePath + -> FilePath + -> PackageId + -> Maybe CabalFileText + -> IO () +unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride = + -- TODO: [nice to have] switch to tar package and catch tar exceptions + annotateFailureNoLog UnpackFailed $ do + -- Unpack the tarball + -- + info verbosity $ "Extracting " ++ tarball ++ " to " ++ parentdir ++ "..." + Tar.extractTarGzFile parentdir pkgsubdir tarball - -- Sanity check - -- - exists <- doesFileExist cabalFile - unless exists $ - die' verbosity $ + -- Sanity check + -- + exists <- doesFileExist cabalFile + unless exists $ + die' verbosity $ "Package .cabal file not found in the tarball: " ++ cabalFile - -- Overwrite the .cabal with the one from the index, when appropriate - -- - case pkgTextOverride of - Nothing -> return () - Just pkgtxt -> do - info verbosity $ "Updating " ++ prettyShow pkgname <.> "cabal" - ++ " with the latest revision from the index." - writeFileAtomic cabalFile pkgtxt - + -- Overwrite the .cabal with the one from the index, when appropriate + -- + case pkgTextOverride of + Nothing -> return () + Just pkgtxt -> do + info verbosity $ + "Updating " + ++ prettyShow pkgname <.> "cabal" + ++ " with the latest revision from the index." + writeFileAtomic cabalFile pkgtxt where cabalFile :: FilePath - cabalFile = parentdir pkgsubdir - prettyShow pkgname <.> "cabal" + cabalFile = + parentdir + pkgsubdir + prettyShow pkgname + <.> "cabal" pkgsubdir = prettyShow pkgid - pkgname = packageName pkgid - + pkgname = packageName pkgid -- | This is a bit of a hacky workaround. A number of packages ship -- pre-processed .hs files in a dist directory inside the tarball. We don't @@ -956,54 +1089,71 @@ unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride = -- right place then we'll miss the shipped pre-processed files. This hacky -- approach to shipped pre-processed files ought to be replaced by a proper -- system, though we'll still need to keep this hack for older packages. --- -moveTarballShippedDistDirectory :: Verbosity -> DistDirLayout - -> FilePath -> PackageId -> DistDirParams - -> IO () -moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory} - parentdir pkgid dparams = do +moveTarballShippedDistDirectory + :: Verbosity + -> DistDirLayout + -> FilePath + -> PackageId + -> DistDirParams + -> IO () +moveTarballShippedDistDirectory + verbosity + DistDirLayout{distBuildDirectory} + parentdir + pkgid + dparams = do distDirExists <- doesDirectoryExist tarballDistDir when distDirExists $ do - debug verbosity $ "Moving '" ++ tarballDistDir ++ "' to '" - ++ targetDistDir ++ "'" - --TODO: [nice to have] or perhaps better to copy, and use a file monitor + debug verbosity $ + "Moving '" + ++ tarballDistDir + ++ "' to '" + ++ targetDistDir + ++ "'" + -- TODO: [nice to have] or perhaps better to copy, and use a file monitor renameDirectory tarballDistDir targetDistDir - where - tarballDistDir = parentdir prettyShow pkgid "dist" - targetDistDir = distBuildDirectory dparams - - -buildAndInstallUnpackedPackage :: Verbosity - -> DistDirLayout - -> StoreDirLayout - -> BuildTimeSettings -> Lock -> Lock - -> ElaboratedSharedConfig - -> ElaboratedInstallPlan - -> ElaboratedReadyPackage - -> FilePath -> FilePath - -> IO BuildResult -buildAndInstallUnpackedPackage verbosity - distDirLayout@DistDirLayout{distTempDirectory} - storeDirLayout@StoreDirLayout { - storePackageDBStack - } - BuildTimeSettings { - buildSettingNumJobs, - buildSettingLogFile - } - registerLock cacheLock - pkgshared@ElaboratedSharedConfig { - pkgConfigPlatform = platform, - pkgConfigCompiler = compiler, - pkgConfigCompilerProgs = progdb - } - plan rpkg@(ReadyPackage pkg) - srcdir builddir = do + where + tarballDistDir = parentdir prettyShow pkgid "dist" + targetDistDir = distBuildDirectory dparams +buildAndInstallUnpackedPackage + :: Verbosity + -> DistDirLayout + -> StoreDirLayout + -> BuildTimeSettings + -> Lock + -> Lock + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedReadyPackage + -> FilePath + -> FilePath + -> IO BuildResult +buildAndInstallUnpackedPackage + verbosity + distDirLayout@DistDirLayout{distTempDirectory} + storeDirLayout@StoreDirLayout + { storePackageDBStack + } + BuildTimeSettings + { buildSettingNumJobs + , buildSettingLogFile + } + registerLock + cacheLock + pkgshared@ElaboratedSharedConfig + { pkgConfigPlatform = platform + , pkgConfigCompiler = compiler + , pkgConfigCompilerProgs = progdb + } + plan + rpkg@(ReadyPackage pkg) + srcdir + builddir = do createDirectoryIfMissingVerbose verbosity True (srcdir builddir) initLogFile - --TODO: [code cleanup] deal consistently with talking to older + -- TODO: [code cleanup] deal consistently with talking to older -- Setup.hs versions, much like we do for ghc, with a proper -- options type and rendering step which will also let us -- call directly into the lib, rather than always going via @@ -1011,8 +1161,8 @@ buildAndInstallUnpackedPackage verbosity -- passing data like installed packages, compiler, and -- program db for a quicker configure. - --TODO: [required feature] docs and tests - --TODO: [required feature] sudo re-exec + -- TODO: [required feature] docs and tests + -- TODO: [required feature] sudo re-exec -- Configure phase noticeProgress ProgressStarting @@ -1035,15 +1185,15 @@ buildAndInstallUnpackedPackage verbosity -- Install phase noticeProgress ProgressInstalling annotateFailure mlogFile InstallFailed $ do - let copyPkgFiles tmpDir = do let tmpDirNormalised = normalise tmpDir setup Cabal.copyCommand (copyFlags tmpDirNormalised) -- Note that the copy command has put the files into -- @$tmpDir/$prefix@ so we need to return this dir so -- the store knows which dir will be the final store entry. - let prefix = normalise $ - dropDrive (InstallDirs.prefix (elabInstallDirs pkg)) + let prefix = + normalise $ + dropDrive (InstallDirs.prefix (elabInstallDirs pkg)) entryDir = tmpDirNormalised prefix -- if there weren't anything to build, it might be that directory is not created @@ -1051,7 +1201,7 @@ buildAndInstallUnpackedPackage verbosity -- https://github.com/haskell/cabal/issues/4130 createDirectoryIfMissingVerbose verbosity True entryDir - let hashFileName = entryDir "cabal-hash.txt" + let hashFileName = entryDir "cabal-hash.txt" outPkgHashInputs = renderPackageHashInputs (packageHashInputs pkgshared pkg) info verbosity $ @@ -1074,8 +1224,9 @@ buildAndInstallUnpackedPackage verbosity -- We also normalise paths to ensure that there are no -- different representations for the same path. Like / and -- \\ on windows under msys. - otherFiles <- filter (not . isPrefixOf entryDir) <$> - listFilesRecursive tmpDirNormalised + otherFiles <- + filter (not . isPrefixOf entryDir) + <$> listFilesRecursive tmpDirNormalised -- Here's where we could keep track of the installed files -- ourselves if we wanted to by making a manifest of the -- files in the tmp dir. @@ -1093,33 +1244,43 @@ buildAndInstallUnpackedPackage verbosity registerPkg | not (elabRequiresRegistration pkg) = - debug verbosity $ - "registerPkg: elab does NOT require registration for " - ++ prettyShow uid + debug verbosity $ + "registerPkg: elab does NOT require registration for " + ++ prettyShow uid | otherwise = do - -- We register ourselves rather than via Setup.hs. We need to - -- grab and modify the InstalledPackageInfo. We decide what - -- the installed package id is, not the build system. - ipkg0 <- generateInstalledPackageInfo - let ipkg = ipkg0 { Installed.installedUnitId = uid } - assert ( elabRegisterPackageDBStack pkg - == storePackageDBStack compid) (return ()) - criticalSection registerLock $ - Cabal.registerPackage - verbosity compiler progdb - (storePackageDBStack compid) ipkg - Cabal.defaultRegisterOptions { - Cabal.registerMultiInstance = True, - Cabal.registerSuppressFilesCheck = True - } - + -- We register ourselves rather than via Setup.hs. We need to + -- grab and modify the InstalledPackageInfo. We decide what + -- the installed package id is, not the build system. + ipkg0 <- generateInstalledPackageInfo + let ipkg = ipkg0{Installed.installedUnitId = uid} + assert + ( elabRegisterPackageDBStack pkg + == storePackageDBStack compid + ) + (return ()) + criticalSection registerLock $ + Cabal.registerPackage + verbosity + compiler + progdb + (storePackageDBStack compid) + ipkg + Cabal.defaultRegisterOptions + { Cabal.registerMultiInstance = True + , Cabal.registerSuppressFilesCheck = True + } -- Actual installation - void $ newStoreEntry verbosity storeDirLayout - compid uid - copyPkgFiles registerPkg + void $ + newStoreEntry + verbosity + storeDirLayout + compid + uid + copyPkgFiles + registerPkg - --TODO: [nice to have] we currently rely on Setup.hs copy to do the right + -- TODO: [nice to have] we currently rely on Setup.hs copy to do the right -- thing. Although we do copy into an image dir and do the move into the -- final location ourselves, perhaps we ought to do some sanity checks on -- the image dir first. @@ -1129,412 +1290,529 @@ buildAndInstallUnpackedPackage verbosity -- 'withWin32SelfUpgrade' dance, but it would be necessary for a -- shared bin dir. - --TODO: [required feature] docs and test phases - let docsResult = DocsNotTried + -- TODO: [required feature] docs and test phases + let docsResult = DocsNotTried testsResult = TestsNotTried noticeProgress ProgressCompleted - return BuildResult { - buildResultDocs = docsResult, - buildResultTests = testsResult, - buildResultLogFile = mlogFile - } - - where - pkgid = packageId rpkg - uid = installedUnitId rpkg - compid = compilerId compiler - - dispname :: String - dispname = case elabPkgOrComp pkg of - ElabPackage _ -> prettyShow pkgid + return + BuildResult + { buildResultDocs = docsResult + , buildResultTests = testsResult + , buildResultLogFile = mlogFile + } + where + pkgid = packageId rpkg + uid = installedUnitId rpkg + compid = compilerId compiler + + dispname :: String + dispname = case elabPkgOrComp pkg of + ElabPackage _ -> + prettyShow pkgid ++ " (all, legacy fallback)" - ElabComponent comp -> prettyShow pkgid - ++ " (" ++ maybe "custom" prettyShow (compComponentName comp) ++ ")" - - noticeProgress :: ProgressPhase -> IO () - noticeProgress phase = when isParallelBuild $ - progressMessage verbosity phase dispname - - isParallelBuild = buildSettingNumJobs >= 2 - - whenHaddock action - | hasValidHaddockTargets pkg = action - | otherwise = return () - - configureCommand = Cabal.configureCommand defaultProgramDb - configureFlags v = flip filterConfigureFlags v $ - setupHsConfigureFlags rpkg pkgshared - verbosity builddir - configureArgs _ = setupHsConfigureArgs pkg - - buildCommand = Cabal.buildCommand defaultProgramDb - buildFlags _ = setupHsBuildFlags pkg pkgshared verbosity builddir - - haddockCommand = Cabal.haddockCommand - haddockFlags _ = setupHsHaddockFlags pkg pkgshared - verbosity builddir - - generateInstalledPackageInfo :: IO InstalledPackageInfo - generateInstalledPackageInfo = - withTempInstalledPackageInfoFile - verbosity distTempDirectory $ \pkgConfDest -> do - let registerFlags _ = setupHsRegisterFlags - pkg pkgshared - verbosity builddir - pkgConfDest - setup Cabal.registerCommand registerFlags - - copyFlags destdir _ = setupHsCopyFlags pkg pkgshared verbosity - builddir destdir - - scriptOptions = setupHsScriptOptions rpkg plan pkgshared - distDirLayout srcdir builddir - isParallelBuild cacheLock - - setup :: CommandUI flags -> (Version -> flags) -> IO () - setup cmd flags = setup' cmd flags (const []) - - setup' :: CommandUI flags -> (Version -> flags) -> (Version -> [String]) - -> IO () - setup' cmd flags args = - withLogging $ \mLogFileHandle -> - setupWrapper + ElabComponent comp -> + prettyShow pkgid + ++ " (" + ++ maybe "custom" prettyShow (compComponentName comp) + ++ ")" + + noticeProgress :: ProgressPhase -> IO () + noticeProgress phase = + when isParallelBuild $ + progressMessage verbosity phase dispname + + isParallelBuild = buildSettingNumJobs >= 2 + + whenHaddock action + | hasValidHaddockTargets pkg = action + | otherwise = return () + + configureCommand = Cabal.configureCommand defaultProgramDb + configureFlags v = + flip filterConfigureFlags v $ + setupHsConfigureFlags + rpkg + pkgshared + verbosity + builddir + configureArgs _ = setupHsConfigureArgs pkg + + buildCommand = Cabal.buildCommand defaultProgramDb + buildFlags _ = setupHsBuildFlags pkg pkgshared verbosity builddir + + haddockCommand = Cabal.haddockCommand + haddockFlags _ = + setupHsHaddockFlags + pkg + pkgshared verbosity - scriptOptions - { useLoggingHandle = mLogFileHandle - , useExtraEnvOverrides = dataDirsEnvironmentForPlan - distDirLayout plan } - (Just (elabPkgDescription pkg)) - cmd flags args - - mlogFile :: Maybe FilePath - mlogFile = - case buildSettingLogFile of - Nothing -> Nothing - Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid) - - initLogFile :: IO () - initLogFile = - case mlogFile of - Nothing -> return () - Just logFile -> do - createDirectoryIfMissing True (takeDirectory logFile) - exists <- doesFileExist logFile - when exists $ removeFile logFile - - withLogging :: (Maybe Handle -> IO r) -> IO r - withLogging action = - case mlogFile of - Nothing -> action Nothing - Just logFile -> withFile logFile AppendMode (action . Just) + builddir + generateInstalledPackageInfo :: IO InstalledPackageInfo + generateInstalledPackageInfo = + withTempInstalledPackageInfoFile + verbosity + distTempDirectory + $ \pkgConfDest -> do + let registerFlags _ = + setupHsRegisterFlags + pkg + pkgshared + verbosity + builddir + pkgConfDest + setup Cabal.registerCommand registerFlags + + copyFlags destdir _ = + setupHsCopyFlags + pkg + pkgshared + verbosity + builddir + destdir + + scriptOptions = + setupHsScriptOptions + rpkg + plan + pkgshared + distDirLayout + srcdir + builddir + isParallelBuild + cacheLock + + setup :: CommandUI flags -> (Version -> flags) -> IO () + setup cmd flags = setup' cmd flags (const []) + + setup' + :: CommandUI flags + -> (Version -> flags) + -> (Version -> [String]) + -> IO () + setup' cmd flags args = + withLogging $ \mLogFileHandle -> + setupWrapper + verbosity + scriptOptions + { useLoggingHandle = mLogFileHandle + , useExtraEnvOverrides = + dataDirsEnvironmentForPlan + distDirLayout + plan + } + (Just (elabPkgDescription pkg)) + cmd + flags + args + + mlogFile :: Maybe FilePath + mlogFile = + case buildSettingLogFile of + Nothing -> Nothing + Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid) + + initLogFile :: IO () + initLogFile = + case mlogFile of + Nothing -> return () + Just logFile -> do + createDirectoryIfMissing True (takeDirectory logFile) + exists <- doesFileExist logFile + when exists $ removeFile logFile + + withLogging :: (Maybe Handle -> IO r) -> IO r + withLogging action = + case mlogFile of + Nothing -> action Nothing + Just logFile -> withFile logFile AppendMode (action . Just) hasValidHaddockTargets :: ElaboratedConfiguredPackage -> Bool hasValidHaddockTargets ElaboratedConfiguredPackage{..} | not elabBuildHaddocks = False - | otherwise = any componentHasHaddocks components + | otherwise = any componentHasHaddocks components where components :: [ComponentTarget] - components = elabBuildTargets ++ elabTestTargets ++ elabBenchTargets - ++ maybeToList elabReplTarget ++ elabHaddockTargets + components = + elabBuildTargets + ++ elabTestTargets + ++ elabBenchTargets + ++ maybeToList elabReplTarget + ++ elabHaddockTargets componentHasHaddocks :: ComponentTarget -> Bool componentHasHaddocks (ComponentTarget name _) = case name of - CLibName LMainLibName -> hasHaddocks - CLibName (LSubLibName _) -> elabHaddockInternal && hasHaddocks - CFLibName _ -> elabHaddockForeignLibs && hasHaddocks - CExeName _ -> elabHaddockExecutables && hasHaddocks - CTestName _ -> elabHaddockTestSuites && hasHaddocks - CBenchName _ -> elabHaddockBenchmarks && hasHaddocks + CLibName LMainLibName -> hasHaddocks + CLibName (LSubLibName _) -> elabHaddockInternal && hasHaddocks + CFLibName _ -> elabHaddockForeignLibs && hasHaddocks + CExeName _ -> elabHaddockExecutables && hasHaddocks + CTestName _ -> elabHaddockTestSuites && hasHaddocks + CBenchName _ -> elabHaddockBenchmarks && hasHaddocks where hasHaddocks = not (null (elabPkgDescription ^. componentModules name)) +buildInplaceUnpackedPackage + :: Verbosity + -> DistDirLayout + -> BuildTimeSettings + -> Lock + -> Lock + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedReadyPackage + -> BuildStatusRebuild + -> FilePath + -> FilePath + -> IO BuildResult +buildInplaceUnpackedPackage + verbosity + distDirLayout@DistDirLayout + { distTempDirectory + , distPackageCacheDirectory + , distDirectory + , distHaddockOutputDir + } + BuildTimeSettings{buildSettingNumJobs, buildSettingHaddockOpen} + registerLock + cacheLock + pkgshared@ElaboratedSharedConfig + { pkgConfigCompiler = compiler + , pkgConfigCompilerProgs = progdb + , pkgConfigPlatform = platform + } + plan + rpkg@(ReadyPackage pkg) + buildStatus + srcdir + builddir = do + -- 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 + (distPackageCacheDirectory dparams) + + -- Configure phase + -- + whenReConfigure $ do + annotateFailureNoLog ConfigureFailed $ + setup configureCommand configureFlags configureArgs + invalidatePackageRegFileMonitor packageFileMonitor + updatePackageConfigFileMonitor packageFileMonitor srcdir pkg + + -- Build phase + -- + let docsResult = DocsNotTried + testsResult = TestsNotTried -buildInplaceUnpackedPackage :: Verbosity - -> DistDirLayout - -> BuildTimeSettings -> Lock -> Lock - -> ElaboratedSharedConfig - -> ElaboratedInstallPlan - -> ElaboratedReadyPackage - -> BuildStatusRebuild - -> FilePath -> FilePath - -> IO BuildResult -buildInplaceUnpackedPackage verbosity - distDirLayout@DistDirLayout { - distTempDirectory, - distPackageCacheDirectory, - distDirectory, - distHaddockOutputDir - } - BuildTimeSettings{buildSettingNumJobs, buildSettingHaddockOpen} - registerLock cacheLock - pkgshared@ElaboratedSharedConfig { - pkgConfigCompiler = compiler, - pkgConfigCompilerProgs = progdb, - pkgConfigPlatform = platform - } - plan - rpkg@(ReadyPackage pkg) - buildStatus - srcdir builddir = do - - --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 - (distPackageCacheDirectory dparams) - - -- Configure phase - -- - whenReConfigure $ do - annotateFailureNoLog ConfigureFailed $ - setup configureCommand configureFlags configureArgs - invalidatePackageRegFileMonitor packageFileMonitor - updatePackageConfigFileMonitor packageFileMonitor srcdir pkg - - -- Build phase - -- - let docsResult = DocsNotTried - testsResult = TestsNotTried - - buildResult :: BuildResultMisc - buildResult = (docsResult, testsResult) - - whenRebuild $ do - timestamp <- beginUpdateFileMonitor - annotateFailureNoLog BuildFailed $ - setup buildCommand buildFlags buildArgs - - let listSimple = - execRebuild srcdir (needElaboratedConfiguredPackage pkg) - listSdist = - fmap (map monitorFileHashed) $ - allPackageSourceFiles verbosity srcdir - ifNullThen m m' = do xs <- m - if null xs then m' else return xs - monitors <- case PD.buildType (elabPkgDescription pkg) of - Simple -> listSimple - -- If a Custom setup was used, AND the Cabal is recent - -- enough to have sdist --list-sources, use that to - -- determine the files that we need to track. This can - -- cause unnecessary rebuilding (for example, if README - -- is edited, we will try to rebuild) but there isn't - -- a more accurate Custom interface we can use to get - -- this info. We prefer not to use listSimple here - -- as it can miss extra source files that are considered - -- by the Custom setup. - _ | elabSetupScriptCliVersion pkg >= mkVersion [1,17] + buildResult :: BuildResultMisc + buildResult = (docsResult, testsResult) + + whenRebuild $ do + timestamp <- beginUpdateFileMonitor + annotateFailureNoLog BuildFailed $ + setup buildCommand buildFlags buildArgs + + let listSimple = + execRebuild srcdir (needElaboratedConfiguredPackage pkg) + listSdist = + fmap (map monitorFileHashed) $ + allPackageSourceFiles verbosity srcdir + ifNullThen m m' = do + xs <- m + if null xs then m' else return xs + monitors <- case PD.buildType (elabPkgDescription pkg) of + Simple -> listSimple + -- If a Custom setup was used, AND the Cabal is recent + -- enough to have sdist --list-sources, use that to + -- determine the files that we need to track. This can + -- cause unnecessary rebuilding (for example, if README + -- is edited, we will try to rebuild) but there isn't + -- a more accurate Custom interface we can use to get + -- this info. We prefer not to use listSimple here + -- as it can miss extra source files that are considered + -- by the Custom setup. + _ + | elabSetupScriptCliVersion pkg >= mkVersion [1, 17] -> -- However, sometimes sdist --list-sources will fail -- and return an empty list. In that case, fall -- back on the (inaccurate) simple tracking. - -> listSdist `ifNullThen` listSimple - | otherwise - -> listSimple - - let dep_monitors = map monitorFileHashed - $ elabInplaceDependencyBuildCacheFiles - distDirLayout pkgshared plan pkg - updatePackageBuildFileMonitor packageFileMonitor srcdir timestamp - pkg buildStatus - (monitors ++ dep_monitors) buildResult - - -- PURPOSELY omitted: no copy! - - whenReRegister $ annotateFailureNoLog InstallFailed $ do - -- Register locally - mipkg <- if elabRequiresRegistration pkg - then do - ipkg0 <- generateInstalledPackageInfo - -- We register ourselves rather than via Setup.hs. We need to - -- grab and modify the InstalledPackageInfo. We decide what - -- the installed package id is, not the build system. - let ipkg = ipkg0 { Installed.installedUnitId = ipkgid } - criticalSection registerLock $ - Cabal.registerPackage verbosity compiler progdb - (elabRegisterPackageDBStack pkg) - ipkg Cabal.defaultRegisterOptions - return (Just ipkg) - - else return Nothing - - updatePackageRegFileMonitor packageFileMonitor srcdir mipkg - - whenTest $ do - annotateFailureNoLog TestsFailed $ - setup testCommand testFlags testArgs - - whenBench $ - annotateFailureNoLog BenchFailed $ - setup benchCommand benchFlags benchArgs - - -- Repl phase - -- - whenRepl $ - annotateFailureNoLog ReplFailed $ - setupInteractive replCommand replFlags replArgs - - -- Haddock phase - whenHaddock $ - annotateFailureNoLog HaddocksFailed $ do - setup haddockCommand haddockFlags haddockArgs - let haddockTarget = elabHaddockForHackage pkg - when (haddockTarget == Cabal.ForHackage) $ do - let dest = distDirectory name <.> "tar.gz" - name = haddockDirName haddockTarget (elabPkgDescription pkg) - docDir = distBuildDirectory distDirLayout dparams - "doc" "html" - Tar.createTarGzFile dest docDir name - notice verbosity $ "Documentation tarball created: " ++ dest - - when (buildSettingHaddockOpen && haddockTarget /= Cabal.ForHackage) $ do - let dest = docDir "index.html" - name = haddockDirName haddockTarget (elabPkgDescription pkg) - docDir = case distHaddockOutputDir of - Nothing -> distBuildDirectory distDirLayout dparams "doc" "html" name - Just dir -> dir - exe <- findOpenProgramLocation platform - case exe of - Right open -> runProgramInvocation verbosity (simpleProgramInvocation open [dest]) - Left err -> die' verbosity err - - - return BuildResult { - buildResultDocs = docsResult, - buildResultTests = testsResult, - buildResultLogFile = Nothing - } + listSdist `ifNullThen` listSimple + | otherwise -> + listSimple + + let dep_monitors = + map monitorFileHashed $ + elabInplaceDependencyBuildCacheFiles + distDirLayout + pkgshared + plan + pkg + updatePackageBuildFileMonitor + packageFileMonitor + srcdir + timestamp + pkg + buildStatus + (monitors ++ dep_monitors) + buildResult + + -- PURPOSELY omitted: no copy! + + whenReRegister $ annotateFailureNoLog InstallFailed $ do + -- Register locally + mipkg <- + if elabRequiresRegistration pkg + then do + ipkg0 <- generateInstalledPackageInfo + -- We register ourselves rather than via Setup.hs. We need to + -- grab and modify the InstalledPackageInfo. We decide what + -- the installed package id is, not the build system. + let ipkg = ipkg0{Installed.installedUnitId = ipkgid} + criticalSection registerLock $ + Cabal.registerPackage + verbosity + compiler + progdb + (elabRegisterPackageDBStack pkg) + ipkg + Cabal.defaultRegisterOptions + return (Just ipkg) + else return Nothing + + updatePackageRegFileMonitor packageFileMonitor srcdir mipkg + + whenTest $ do + annotateFailureNoLog TestsFailed $ + setup testCommand testFlags testArgs + + whenBench $ + annotateFailureNoLog BenchFailed $ + setup benchCommand benchFlags benchArgs + + -- Repl phase + -- + whenRepl $ + annotateFailureNoLog ReplFailed $ + setupInteractive replCommand replFlags replArgs - where - ipkgid = installedUnitId pkg - dparams = elabDistDirParams pkgshared pkg + -- Haddock phase + whenHaddock $ + annotateFailureNoLog HaddocksFailed $ do + setup haddockCommand haddockFlags haddockArgs + let haddockTarget = elabHaddockForHackage pkg + when (haddockTarget == Cabal.ForHackage) $ do + let dest = distDirectory name <.> "tar.gz" + name = haddockDirName haddockTarget (elabPkgDescription pkg) + docDir = + distBuildDirectory distDirLayout dparams + "doc" + "html" + Tar.createTarGzFile dest docDir name + notice verbosity $ "Documentation tarball created: " ++ dest + + when (buildSettingHaddockOpen && haddockTarget /= Cabal.ForHackage) $ do + let dest = docDir "index.html" + name = haddockDirName haddockTarget (elabPkgDescription pkg) + docDir = case distHaddockOutputDir of + Nothing -> distBuildDirectory distDirLayout dparams "doc" "html" name + Just dir -> dir + exe <- findOpenProgramLocation platform + case exe of + Right open -> runProgramInvocation verbosity (simpleProgramInvocation open [dest]) + Left err -> die' verbosity err + + return + BuildResult + { buildResultDocs = docsResult + , buildResultTests = testsResult + , buildResultLogFile = Nothing + } + where + ipkgid = installedUnitId pkg + dparams = elabDistDirParams pkgshared pkg - isParallelBuild = buildSettingNumJobs >= 2 + isParallelBuild = buildSettingNumJobs >= 2 - packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams + packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams - whenReConfigure action = case buildStatus of - BuildStatusConfigure _ -> action - _ -> return () + whenReConfigure action = case buildStatus of + BuildStatusConfigure _ -> action + _ -> return () - whenRebuild action - | null (elabBuildTargets pkg) - -- NB: we have to build the test/bench suite! - , null (elabTestTargets pkg) - , null (elabBenchTargets pkg) = return () - | otherwise = action + whenRebuild action + | null (elabBuildTargets pkg) + , -- NB: we have to build the test/bench suite! + null (elabTestTargets pkg) + , null (elabBenchTargets pkg) = + return () + | otherwise = action - whenTest action - | null (elabTestTargets pkg) = return () - | otherwise = action + whenTest action + | null (elabTestTargets pkg) = return () + | otherwise = action - whenBench action - | null (elabBenchTargets pkg) = return () - | otherwise = action + whenBench action + | null (elabBenchTargets pkg) = return () + | otherwise = action - whenRepl action - | isNothing (elabReplTarget pkg) = return () - | otherwise = action + whenRepl action + | isNothing (elabReplTarget pkg) = return () + | otherwise = action - whenHaddock action - | hasValidHaddockTargets pkg = action - | otherwise = return () + whenHaddock action + | hasValidHaddockTargets pkg = action + | otherwise = return () - whenReRegister action - = case buildStatus of + whenReRegister action = + case buildStatus of -- We registered the package already - BuildStatusBuild (Just _) _ -> + BuildStatusBuild (Just _) _ -> info verbosity "whenReRegister: previously registered" -- There is nothing to register - _ | null (elabBuildTargets pkg) -> - info verbosity "whenReRegister: nothing to register" - | otherwise -> action - - configureCommand = Cabal.configureCommand defaultProgramDb - configureFlags v = flip filterConfigureFlags v $ - setupHsConfigureFlags rpkg pkgshared - verbosity builddir - configureArgs _ = setupHsConfigureArgs pkg - - buildCommand = Cabal.buildCommand defaultProgramDb - buildFlags _ = setupHsBuildFlags pkg pkgshared - verbosity builddir - buildArgs _ = setupHsBuildArgs pkg - - testCommand = Cabal.testCommand -- defaultProgramDb - testFlags v = flip filterTestFlags v $ - setupHsTestFlags pkg pkgshared - verbosity builddir - testArgs _ = setupHsTestArgs pkg - - benchCommand = Cabal.benchmarkCommand - benchFlags _ = setupHsBenchFlags pkg pkgshared - verbosity builddir - benchArgs _ = setupHsBenchArgs pkg - - replCommand = Cabal.replCommand defaultProgramDb - replFlags _ = setupHsReplFlags pkg pkgshared - verbosity builddir - replArgs _ = setupHsReplArgs pkg - - haddockCommand = Cabal.haddockCommand - haddockFlags v = flip filterHaddockFlags v $ - setupHsHaddockFlags pkg pkgshared - verbosity builddir - haddockArgs v = flip filterHaddockArgs v $ - setupHsHaddockArgs pkg - - scriptOptions = setupHsScriptOptions rpkg plan pkgshared - distDirLayout srcdir builddir - isParallelBuild cacheLock - - setupInteractive :: CommandUI flags - -> (Version -> flags) -> (Version -> [String]) -> IO () - setupInteractive cmd flags args = - setupWrapper verbosity - scriptOptions { isInteractive = True } - (Just (elabPkgDescription pkg)) - cmd flags args - - setup :: CommandUI flags -> (Version -> flags) -> (Version -> [String]) - -> IO () - setup cmd flags args = - setupWrapper verbosity - scriptOptions - (Just (elabPkgDescription pkg)) - cmd flags args - - generateInstalledPackageInfo :: IO InstalledPackageInfo - generateInstalledPackageInfo = - withTempInstalledPackageInfoFile - verbosity distTempDirectory $ \pkgConfDest -> do - let registerFlags _ = setupHsRegisterFlags - pkg pkgshared - verbosity builddir - pkgConfDest - setup Cabal.registerCommand registerFlags (const []) - -withTempInstalledPackageInfoFile :: Verbosity -> FilePath - -> (FilePath -> IO ()) - -> IO InstalledPackageInfo + _ + | null (elabBuildTargets pkg) -> + info verbosity "whenReRegister: nothing to register" + | otherwise -> action + + configureCommand = Cabal.configureCommand defaultProgramDb + configureFlags v = + flip filterConfigureFlags v $ + setupHsConfigureFlags + rpkg + pkgshared + verbosity + builddir + configureArgs _ = setupHsConfigureArgs pkg + + buildCommand = Cabal.buildCommand defaultProgramDb + buildFlags _ = + setupHsBuildFlags + pkg + pkgshared + verbosity + builddir + buildArgs _ = setupHsBuildArgs pkg + + testCommand = Cabal.testCommand -- defaultProgramDb + testFlags v = + flip filterTestFlags v $ + setupHsTestFlags + pkg + pkgshared + verbosity + builddir + testArgs _ = setupHsTestArgs pkg + + benchCommand = Cabal.benchmarkCommand + benchFlags _ = + setupHsBenchFlags + pkg + pkgshared + verbosity + builddir + benchArgs _ = setupHsBenchArgs pkg + + replCommand = Cabal.replCommand defaultProgramDb + replFlags _ = + setupHsReplFlags + pkg + pkgshared + verbosity + builddir + replArgs _ = setupHsReplArgs pkg + + haddockCommand = Cabal.haddockCommand + haddockFlags v = + flip filterHaddockFlags v $ + setupHsHaddockFlags + pkg + pkgshared + verbosity + builddir + haddockArgs v = + flip filterHaddockArgs v $ + setupHsHaddockArgs pkg + + scriptOptions = + setupHsScriptOptions + rpkg + plan + pkgshared + distDirLayout + srcdir + builddir + isParallelBuild + cacheLock + + setupInteractive + :: CommandUI flags + -> (Version -> flags) + -> (Version -> [String]) + -> IO () + setupInteractive cmd flags args = + setupWrapper + verbosity + scriptOptions{isInteractive = True} + (Just (elabPkgDescription pkg)) + cmd + flags + args + + setup + :: CommandUI flags + -> (Version -> flags) + -> (Version -> [String]) + -> IO () + setup cmd flags args = + setupWrapper + verbosity + scriptOptions + (Just (elabPkgDescription pkg)) + cmd + flags + args + + generateInstalledPackageInfo :: IO InstalledPackageInfo + generateInstalledPackageInfo = + withTempInstalledPackageInfoFile + verbosity + distTempDirectory + $ \pkgConfDest -> do + let registerFlags _ = + setupHsRegisterFlags + pkg + pkgshared + verbosity + builddir + pkgConfDest + setup Cabal.registerCommand registerFlags (const []) + +withTempInstalledPackageInfoFile + :: Verbosity + -> FilePath + -> (FilePath -> IO ()) + -> IO InstalledPackageInfo withTempInstalledPackageInfoFile verbosity tempdir action = - withTempDirectory verbosity tempdir "package-registration-" $ \dir -> do - -- make absolute since @action@ will often change directory - abs_dir <- canonicalizePath dir + withTempDirectory verbosity tempdir "package-registration-" $ \dir -> do + -- make absolute since @action@ will often change directory + abs_dir <- canonicalizePath dir - let pkgConfDest = abs_dir "pkgConf" - action pkgConfDest + let pkgConfDest = abs_dir "pkgConf" + action pkgConfDest - readPkgConf "." pkgConfDest + readPkgConf "." pkgConfDest where pkgConfParseFailed :: String -> IO a pkgConfParseFailed perror = die' verbosity $ - "Couldn't parse the output of 'setup register --gen-pkg-config':" - ++ show perror + "Couldn't parse the output of 'setup register --gen-pkg-config':" + ++ show perror readPkgConf :: FilePath -> FilePath -> IO InstalledPackageInfo readPkgConf pkgConfDir pkgConfFile = do @@ -1544,15 +1822,18 @@ withTempInstalledPackageInfoFile verbosity tempdir action = Right (warns, ipkg) -> return (warns, ipkg) unless (null warns) $ - warn verbosity $ unlines warns + warn verbosity $ + unlines warns return ipkg - ------------------------------------------------------------------------------ + -- * Utilities + ------------------------------------------------------------------------------ +{- FOURMOLU_DISABLE -} annotateFailureNoLog :: (SomeException -> BuildFailureReason) -> IO a -> IO a annotateFailureNoLog annotate action = diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs index 684ec033956..397a01ee68e 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs @@ -3,36 +3,34 @@ -- | Types for the "Distribution.Client.ProjectBuilding" -- -- Moved out to avoid module cycles. --- -module Distribution.Client.ProjectBuilding.Types ( - -- * Pre-build status - BuildStatusMap, - BuildStatus(..), - buildStatusRequiresBuild, - buildStatusToString, - BuildStatusRebuild(..), - BuildReason(..), - MonitorChangedReason(..), +module Distribution.Client.ProjectBuilding.Types + ( -- * Pre-build status + BuildStatusMap + , BuildStatus (..) + , buildStatusRequiresBuild + , buildStatusToString + , BuildStatusRebuild (..) + , BuildReason (..) + , MonitorChangedReason (..) -- * Build outcomes - BuildOutcomes, - BuildOutcome, - BuildResult(..), - BuildFailure(..), - BuildFailureReason(..), + , BuildOutcomes + , BuildOutcome + , BuildResult (..) + , BuildFailure (..) + , BuildFailureReason (..) ) where import Distribution.Client.Compat.Prelude import Prelude () -import Distribution.Client.Types (DocsResult, TestsResult) -import Distribution.Client.FileMonitor (MonitorChangedReason(..)) +import Distribution.Client.FileMonitor (MonitorChangedReason (..)) +import Distribution.Client.Types (DocsResult, TestsResult) -import Distribution.Package (UnitId, PackageId) -import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import Distribution.Package (PackageId, UnitId) import Distribution.Simple.LocalBuildInfo (ComponentName) - ------------------------------------------------------------------------------ -- Pre-build status: result of the dry run -- @@ -40,7 +38,6 @@ import Distribution.Simple.LocalBuildInfo (ComponentName) -- | The 'BuildStatus' of every package in the 'ElaboratedInstallPlan'. -- -- This is used as the result of the dry-run of building an install plan. --- type BuildStatusMap = Map UnitId BuildStatus -- | The build status for an individual package is the state that the @@ -56,150 +53,124 @@ type BuildStatusMap = Map UnitId BuildStatus -- -- * It tell us what step to start or resume building from, and carries -- enough information for us to be able to do so. --- -data BuildStatus = - - -- | The package is in the 'InstallPlan.PreExisting' state, so does not - -- need building. - BuildStatusPreExisting - - -- | The package is in the 'InstallPlan.Installed' state, so does not - -- need building. - | BuildStatusInstalled - - -- | The package has not been downloaded yet, so it will have to be - -- downloaded, unpacked and built. - | BuildStatusDownload - - -- | The package has not been unpacked yet, so it will have to be - -- unpacked and built. - | BuildStatusUnpack FilePath - - -- | The package exists in a local dir already, and just needs building - -- or rebuilding. So this can only happen for 'BuildInplaceOnly' style - -- packages. - | BuildStatusRebuild FilePath BuildStatusRebuild - - -- | The package exists in a local dir already, and is fully up to date. - -- So this package can be put into the 'InstallPlan.Installed' state - -- and it does not need to be built. - | BuildStatusUpToDate BuildResult - +data BuildStatus + = -- | The package is in the 'InstallPlan.PreExisting' state, so does not + -- need building. + BuildStatusPreExisting + | -- | The package is in the 'InstallPlan.Installed' state, so does not + -- need building. + BuildStatusInstalled + | -- | The package has not been downloaded yet, so it will have to be + -- downloaded, unpacked and built. + BuildStatusDownload + | -- | The package has not been unpacked yet, so it will have to be + -- unpacked and built. + BuildStatusUnpack FilePath + | -- | The package exists in a local dir already, and just needs building + -- or rebuilding. So this can only happen for 'BuildInplaceOnly' style + -- packages. + BuildStatusRebuild FilePath BuildStatusRebuild + | -- | The package exists in a local dir already, and is fully up to date. + -- So this package can be put into the 'InstallPlan.Installed' state + -- and it does not need to be built. + BuildStatusUpToDate BuildResult -- | Which 'BuildStatus' values indicate we'll have to do some build work of -- some sort. In particular we use this as part of checking if any of a -- package's deps have changed. --- buildStatusRequiresBuild :: BuildStatus -> Bool buildStatusRequiresBuild BuildStatusPreExisting = False -buildStatusRequiresBuild BuildStatusInstalled = False -buildStatusRequiresBuild BuildStatusUpToDate {} = False -buildStatusRequiresBuild _ = True +buildStatusRequiresBuild BuildStatusInstalled = False +buildStatusRequiresBuild BuildStatusUpToDate{} = False +buildStatusRequiresBuild _ = True -- | This is primarily here for debugging. It's not actually used anywhere. --- buildStatusToString :: BuildStatus -> String -buildStatusToString BuildStatusPreExisting = "BuildStatusPreExisting" -buildStatusToString BuildStatusInstalled = "BuildStatusInstalled" -buildStatusToString BuildStatusDownload = "BuildStatusDownload" -buildStatusToString (BuildStatusUnpack fp) = "BuildStatusUnpack " ++ show fp +buildStatusToString BuildStatusPreExisting = "BuildStatusPreExisting" +buildStatusToString BuildStatusInstalled = "BuildStatusInstalled" +buildStatusToString BuildStatusDownload = "BuildStatusDownload" +buildStatusToString (BuildStatusUnpack fp) = "BuildStatusUnpack " ++ show fp buildStatusToString (BuildStatusRebuild fp _) = "BuildStatusRebuild " ++ show fp -buildStatusToString (BuildStatusUpToDate _) = "BuildStatusUpToDate" - +buildStatusToString (BuildStatusUpToDate _) = "BuildStatusUpToDate" -- | For a package that is going to be built or rebuilt, the state it's in now. -- -- So again, this tells us why a package needs to be rebuilt and what build -- phases need to be run. The 'MonitorChangedReason' gives us details like -- which file changed, which is mainly for high verbosity debug output. --- -data BuildStatusRebuild = - - -- | The package configuration changed, so the configure and build phases - -- needs to be (re)run. - BuildStatusConfigure (MonitorChangedReason ()) - - -- | The configuration has not changed but the build phase needs to be - -- rerun. We record the reason the (re)build is needed. - -- - -- The optional registration info here tells us if we've registered the - -- package already, or if we still need to do that after building. - -- @Just Nothing@ indicates that we know that no registration is - -- necessary (e.g., executable.) - -- - | BuildStatusBuild (Maybe (Maybe InstalledPackageInfo)) BuildReason - -data BuildReason = - -- | The dependencies of this package have been (re)built so the build - -- phase needs to be rerun. - -- - BuildReasonDepsRebuilt - - -- | Changes in files within the package (or first run or corrupt cache) - | BuildReasonFilesChanged (MonitorChangedReason ()) - - -- | An important special case is that no files have changed but the - -- set of components the /user asked to build/ has changed. We track the - -- set of components /we have built/, which of course only grows (until - -- some other change resets it). - -- - -- The @Set 'ComponentName'@ is the set of components we have built - -- previously. When we update the monitor we take the union of the ones - -- we have built previously with the ones the user has asked for this - -- time and save those. See 'updatePackageBuildFileMonitor'. - -- - | BuildReasonExtraTargets (Set ComponentName) - - -- | Although we're not going to build any additional targets as a whole, - -- we're going to build some part of a component or run a repl or any - -- other action that does not result in additional persistent artifacts. - -- - | BuildReasonEphemeralTargets - +data BuildStatusRebuild + = -- | The package configuration changed, so the configure and build phases + -- needs to be (re)run. + BuildStatusConfigure (MonitorChangedReason ()) + | -- | The configuration has not changed but the build phase needs to be + -- rerun. We record the reason the (re)build is needed. + -- + -- The optional registration info here tells us if we've registered the + -- package already, or if we still need to do that after building. + -- @Just Nothing@ indicates that we know that no registration is + -- necessary (e.g., executable.) + BuildStatusBuild (Maybe (Maybe InstalledPackageInfo)) BuildReason + +data BuildReason + = -- | The dependencies of this package have been (re)built so the build + -- phase needs to be rerun. + BuildReasonDepsRebuilt + | -- | Changes in files within the package (or first run or corrupt cache) + BuildReasonFilesChanged (MonitorChangedReason ()) + | -- | An important special case is that no files have changed but the + -- set of components the /user asked to build/ has changed. We track the + -- set of components /we have built/, which of course only grows (until + -- some other change resets it). + -- + -- The @Set 'ComponentName'@ is the set of components we have built + -- previously. When we update the monitor we take the union of the ones + -- we have built previously with the ones the user has asked for this + -- time and save those. See 'updatePackageBuildFileMonitor'. + BuildReasonExtraTargets (Set ComponentName) + | -- | Although we're not going to build any additional targets as a whole, + -- we're going to build some part of a component or run a repl or any + -- other action that does not result in additional persistent artifacts. + BuildReasonEphemeralTargets ------------------------------------------------------------------------------ -- Build outcomes: result of the build -- -- | A summary of the outcome for building a whole set of packages. --- type BuildOutcomes = Map UnitId BuildOutcome -- | A summary of the outcome for building a single package: either success -- or failure. --- -type BuildOutcome = Either BuildFailure BuildResult +type BuildOutcome = Either BuildFailure BuildResult -- | Information arising from successfully building a single package. --- -data BuildResult = BuildResult { - buildResultDocs :: DocsResult, - buildResultTests :: TestsResult, - buildResultLogFile :: Maybe FilePath - } - deriving Show +data BuildResult = BuildResult + { buildResultDocs :: DocsResult + , buildResultTests :: TestsResult + , buildResultLogFile :: Maybe FilePath + } + deriving (Show) -- | Information arising from the failure to build a single package. --- -data BuildFailure = BuildFailure { - buildFailureLogFile :: Maybe FilePath, - buildFailureReason :: BuildFailureReason - } +data BuildFailure = BuildFailure + { buildFailureLogFile :: Maybe FilePath + , buildFailureReason :: BuildFailureReason + } deriving (Show, Typeable) instance Exception BuildFailure -- | Detail on the reason that a package failed to build. --- -data BuildFailureReason = DependentFailed PackageId - | GracefulFailure String - | DownloadFailed SomeException - | UnpackFailed SomeException - | ConfigureFailed SomeException - | BuildFailed SomeException - | ReplFailed SomeException - | HaddocksFailed SomeException - | TestsFailed SomeException - | BenchFailed SomeException - | InstallFailed SomeException - deriving Show +data BuildFailureReason + = DependentFailed PackageId + | GracefulFailure String + | DownloadFailed SomeException + | UnpackFailed SomeException + | ConfigureFailed SomeException + | BuildFailed SomeException + | ReplFailed SomeException + | HaddocksFailed SomeException + | TestsFailed SomeException + | BenchFailed SomeException + | InstallFailed SomeException + deriving (Show) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index 0807a305815..a88ec3e829f 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -1,159 +1,227 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} -- | Handling project configuration. --- -module Distribution.Client.ProjectConfig ( - - -- * Types for project config - ProjectConfig(..), - ProjectConfigBuildOnly(..), - ProjectConfigShared(..), - ProjectConfigProvenance(..), - PackageConfig(..), - MapLast(..), - MapMappend(..), +module Distribution.Client.ProjectConfig + ( -- * Types for project config + ProjectConfig (..) + , ProjectConfigBuildOnly (..) + , ProjectConfigShared (..) + , ProjectConfigProvenance (..) + , PackageConfig (..) + , MapLast (..) + , MapMappend (..) -- * Project root - findProjectRoot, - ProjectRoot(..), - BadProjectRoot, + , findProjectRoot + , ProjectRoot (..) + , BadProjectRoot -- * Project config files - readProjectConfig, - readGlobalConfig, - readProjectLocalExtraConfig, - readProjectLocalFreezeConfig, - reportParseResult, - showProjectConfig, - withProjectOrGlobalConfig, - writeProjectLocalExtraConfig, - writeProjectLocalFreezeConfig, - writeProjectConfigFile, - commandLineFlagsToProjectConfig, + , readProjectConfig + , readGlobalConfig + , readProjectLocalExtraConfig + , readProjectLocalFreezeConfig + , reportParseResult + , showProjectConfig + , withProjectOrGlobalConfig + , writeProjectLocalExtraConfig + , writeProjectLocalFreezeConfig + , writeProjectConfigFile + , commandLineFlagsToProjectConfig -- * Packages within projects - ProjectPackageLocation(..), - BadPackageLocations(..), - BadPackageLocation(..), - BadPackageLocationMatch(..), - findProjectPackages, - fetchAndReadSourcePackages, + , ProjectPackageLocation (..) + , BadPackageLocations (..) + , BadPackageLocation (..) + , BadPackageLocationMatch (..) + , findProjectPackages + , fetchAndReadSourcePackages -- * Resolving configuration - lookupLocalPackageConfig, - projectConfigWithBuilderRepoContext, - projectConfigWithSolverRepoContext, - SolverSettings(..), - resolveSolverSettings, - BuildTimeSettings(..), - resolveBuildTimeSettings, + , lookupLocalPackageConfig + , projectConfigWithBuilderRepoContext + , projectConfigWithSolverRepoContext + , SolverSettings (..) + , resolveSolverSettings + , BuildTimeSettings (..) + , resolveBuildTimeSettings -- * Checking configuration - checkBadPerPackageCompilerPaths, - BadPerPackageCompilerPaths(..) + , checkBadPerPackageCompilerPaths + , BadPerPackageCompilerPaths (..) ) where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () -import Distribution.Client.ProjectConfig.Types +import Distribution.Client.Glob + ( isTrivialFilePathGlob + ) import Distribution.Client.ProjectConfig.Legacy +import Distribution.Client.ProjectConfig.Types import Distribution.Client.RebuildMonad -import Distribution.Client.Glob - ( isTrivialFilePathGlob ) import Distribution.Client.VCS - ( validateSourceRepos, SourceRepoProblem(..) - , VCS(..), knownVCSs, configureVCS, syncSourceRepos ) + ( SourceRepoProblem (..) + , VCS (..) + , configureVCS + , knownVCSs + , syncSourceRepos + , validateSourceRepos + ) -import Distribution.Client.Types -import Distribution.Client.DistDirLayout - ( DistDirLayout(..), CabalDirLayout(..), ProjectRoot(..), defaultProjectFile ) -import Distribution.Client.GlobalFlags - ( RepoContext(..), withRepoContext' ) import Distribution.Client.BuildReports.Types - ( ReportLevel(..) ) + ( ReportLevel (..) + ) import Distribution.Client.Config - ( loadConfig, getConfigFilePath ) + ( getConfigFilePath + , loadConfig + ) +import Distribution.Client.DistDirLayout + ( CabalDirLayout (..) + , DistDirLayout (..) + , ProjectRoot (..) + , defaultProjectFile + ) +import Distribution.Client.GlobalFlags + ( RepoContext (..) + , withRepoContext' + ) import Distribution.Client.HttpUtils - ( HttpTransport, configureTransport, transportCheckHttps - , downloadURI ) + ( HttpTransport + , configureTransport + , downloadURI + , transportCheckHttps + ) +import Distribution.Client.Types import Distribution.Client.Utils.Parsec (renderParseError) -import Distribution.Solver.Types.SourcePackage -import Distribution.Solver.Types.Settings import Distribution.Solver.Types.PackageConstraint - ( PackageProperty(..) ) + ( PackageProperty (..) + ) +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.SourcePackage +import Distribution.Client.Setup + ( defaultMaxBackjumps + , defaultSolver + ) +import Distribution.Client.SrcDist + ( packageDirToSdist + ) +import Distribution.Client.Types.SourceRepo + ( SourceRepoList + , SourceRepositoryPackage (..) + , srpFanOut + ) +import Distribution.Client.Utils + ( determineNumJobs + ) +import qualified Distribution.Deprecated.ParseUtils as OldParser + ( ParseResult (..) + , locatedErrorMsg + , showPWarning + ) +import Distribution.Fields + ( PError + , PWarning + , runParseResult + , showPWarning + ) import Distribution.Package - ( PackageName, PackageId, UnitId, packageId ) -import Distribution.Types.PackageVersionConstraint - ( PackageVersionConstraint(..) ) -import Distribution.System - ( Platform ) -import Distribution.Types.GenericPackageDescription - ( GenericPackageDescription ) + ( PackageId + , PackageName + , UnitId + , packageId + ) import Distribution.PackageDescription.Parsec - ( parseGenericPackageDescription ) -import Distribution.Fields - ( runParseResult, PError, PWarning, showPWarning) -import Distribution.Types.SourceRepo - ( RepoType(..) ) -import Distribution.Client.Types.SourceRepo - ( SourceRepoList, SourceRepositoryPackage (..), srpFanOut ) + ( parseGenericPackageDescription + ) import Distribution.Simple.Compiler - ( Compiler, compilerInfo ) + ( Compiler + , compilerInfo + ) +import Distribution.Simple.InstallDirs + ( PathTemplate + , fromPathTemplate + , initialPathTemplateEnv + , substPathTemplate + , toPathTemplate + ) import Distribution.Simple.Program - ( ConfiguredProgram(..) ) + ( ConfiguredProgram (..) + ) import Distribution.Simple.Setup - ( Flag(Flag), toFlag, flagToMaybe, flagToList - , fromFlag, fromFlagOrDefault ) -import Distribution.Client.Setup - ( defaultSolver, defaultMaxBackjumps ) -import Distribution.Simple.InstallDirs - ( PathTemplate, fromPathTemplate - , toPathTemplate, substPathTemplate, initialPathTemplateEnv ) + ( Flag (Flag) + , flagToList + , flagToMaybe + , fromFlag + , fromFlagOrDefault + , toFlag + ) import Distribution.Simple.Utils - ( die', warn, notice, info, createDirectoryIfMissingVerbose, maybeExit, rawSystemIOWithEnv ) -import Distribution.Client.Utils - ( determineNumJobs ) + ( createDirectoryIfMissingVerbose + , die' + , info + , maybeExit + , notice + , rawSystemIOWithEnv + , warn + ) +import Distribution.System + ( Platform + ) +import Distribution.Types.GenericPackageDescription + ( GenericPackageDescription + ) +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint (..) + ) +import Distribution.Types.SourceRepo + ( RepoType (..) + ) import Distribution.Utils.NubList - ( fromNubList ) + ( fromNubList + ) import Distribution.Verbosity - ( modifyVerbosity, verbose ) + ( modifyVerbosity + , verbose + ) import Distribution.Version - ( Version ) -import qualified Distribution.Deprecated.ParseUtils as OldParser - ( ParseResult(..), locatedErrorMsg, showPWarning ) -import Distribution.Client.SrcDist - ( packageDirToSdist ) + ( Version + ) -import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar -import qualified Distribution.Client.Tar as Tar import qualified Distribution.Client.GZipUtils as GZipUtils +import qualified Distribution.Client.Tar as Tar import Control.Monad.Trans (liftIO) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Map as Map +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 qualified Data.Hashable as Hashable import Numeric (showHex) +import Network.URI + ( URI (..) + , URIAuth (..) + , parseAbsoluteURI + , uriToString + ) +import System.Directory import System.FilePath hiding (combine) import System.IO - ( withBinaryFile, IOMode(ReadMode) ) -import System.Directory -import Network.URI - ( URI(..), URIAuth(..), parseAbsoluteURI, uriToString ) - + ( IOMode (ReadMode) + , withBinaryFile + ) ---------------------------------------- -- Resolving configuration to settings @@ -162,237 +230,268 @@ import Network.URI -- | Look up a 'PackageConfig' field in the 'ProjectConfig' for a specific -- 'PackageName'. This returns the configuration that applies to all local -- packages plus any package-specific configuration for this package. --- lookupLocalPackageConfig :: (Semigroup a, Monoid a) - => (PackageConfig -> a) -> ProjectConfig -> PackageName + => (PackageConfig -> a) + -> ProjectConfig + -> PackageName -> a -lookupLocalPackageConfig field ProjectConfig { - projectConfigLocalPackages, - projectConfigSpecificPackage - } pkgname = +lookupLocalPackageConfig + field + ProjectConfig + { projectConfigLocalPackages + , projectConfigSpecificPackage + } + pkgname = field projectConfigLocalPackages - <> maybe mempty field - (Map.lookup pkgname (getMapMappend projectConfigSpecificPackage)) - + <> maybe + mempty + field + (Map.lookup pkgname (getMapMappend projectConfigSpecificPackage)) -- | Use a 'RepoContext' based on the 'BuildTimeSettings'. --- -projectConfigWithBuilderRepoContext :: Verbosity - -> BuildTimeSettings - -> (RepoContext -> IO a) -> IO a +projectConfigWithBuilderRepoContext + :: Verbosity + -> BuildTimeSettings + -> (RepoContext -> IO a) + -> IO a projectConfigWithBuilderRepoContext verbosity BuildTimeSettings{..} = - withRepoContext' - verbosity - buildSettingRemoteRepos - buildSettingLocalNoIndexRepos - buildSettingCacheDir - buildSettingHttpTransport - (Just buildSettingIgnoreExpiry) - buildSettingProgPathExtra - + withRepoContext' + verbosity + buildSettingRemoteRepos + buildSettingLocalNoIndexRepos + buildSettingCacheDir + buildSettingHttpTransport + (Just buildSettingIgnoreExpiry) + buildSettingProgPathExtra -- | Use a 'RepoContext', but only for the solver. The solver does not use the -- full facilities of the 'RepoContext' so we can get away with making one -- that doesn't have an http transport. And that avoids having to have access -- to the 'BuildTimeSettings' --- projectConfigWithSolverRepoContext - :: Verbosity -> ProjectConfigShared -> ProjectConfigBuildOnly + :: Verbosity + -> ProjectConfigShared + -> ProjectConfigBuildOnly -> (RepoContext -> IO a) -> IO a -projectConfigWithSolverRepoContext verbosity - ProjectConfigShared{..} - ProjectConfigBuildOnly{..} = +projectConfigWithSolverRepoContext + verbosity + ProjectConfigShared{..} + ProjectConfigBuildOnly{..} = withRepoContext' verbosity (fromNubList projectConfigRemoteRepos) (fromNubList projectConfigLocalNoIndexRepos) - (fromFlagOrDefault - (error - "projectConfigWithSolverRepoContext: projectConfigCacheDir") - projectConfigCacheDir) + ( fromFlagOrDefault + ( error + "projectConfigWithSolverRepoContext: projectConfigCacheDir" + ) + projectConfigCacheDir + ) (flagToMaybe projectConfigHttpTransport) (flagToMaybe projectConfigIgnoreExpiry) (fromNubList projectConfigProgPathExtra) - -- | Resolve the project configuration, with all its optional fields, into -- 'SolverSettings' with no optional fields (by applying defaults). --- resolveSolverSettings :: ProjectConfig -> SolverSettings -resolveSolverSettings ProjectConfig{ - projectConfigShared, - projectConfigLocalPackages, - projectConfigSpecificPackage - } = - SolverSettings {..} - where - --TODO: [required eventually] some of these settings need validation, e.g. - -- the flag assignments need checking. - solverSettingRemoteRepos = fromNubList projectConfigRemoteRepos - solverSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos - solverSettingConstraints = projectConfigConstraints - solverSettingPreferences = projectConfigPreferences - solverSettingFlagAssignment = packageConfigFlagAssignment projectConfigLocalPackages - solverSettingFlagAssignments = fmap packageConfigFlagAssignment - (getMapMappend projectConfigSpecificPackage) - solverSettingCabalVersion = flagToMaybe projectConfigCabalVersion - solverSettingSolver = fromFlag projectConfigSolver - solverSettingAllowOlder = fromMaybe mempty projectConfigAllowOlder - solverSettingAllowNewer = fromMaybe mempty projectConfigAllowNewer - solverSettingMaxBackjumps = case fromFlag projectConfigMaxBackjumps of - n | n < 0 -> Nothing - | otherwise -> Just n - solverSettingReorderGoals = fromFlag projectConfigReorderGoals - solverSettingCountConflicts = fromFlag projectConfigCountConflicts - solverSettingFineGrainedConflicts = fromFlag projectConfigFineGrainedConflicts - solverSettingMinimizeConflictSet = fromFlag projectConfigMinimizeConflictSet - solverSettingStrongFlags = fromFlag projectConfigStrongFlags - solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls - solverSettingOnlyConstrained = fromFlag projectConfigOnlyConstrained - solverSettingIndexState = flagToMaybe projectConfigIndexState - solverSettingActiveRepos = flagToMaybe projectConfigActiveRepos - solverSettingIndependentGoals = fromFlag projectConfigIndependentGoals - solverSettingPreferOldest = fromFlag projectConfigPreferOldest - --solverSettingShadowPkgs = fromFlag projectConfigShadowPkgs - --solverSettingReinstall = fromFlag projectConfigReinstall - --solverSettingAvoidReinstalls = fromFlag projectConfigAvoidReinstalls - --solverSettingOverrideReinstall = fromFlag projectConfigOverrideReinstall - --solverSettingUpgradeDeps = fromFlag projectConfigUpgradeDeps - - ProjectConfigShared {..} = defaults <> projectConfigShared - - defaults = mempty { - projectConfigSolver = Flag defaultSolver, - projectConfigAllowOlder = Just (AllowOlder mempty), - projectConfigAllowNewer = Just (AllowNewer mempty), - projectConfigMaxBackjumps = Flag defaultMaxBackjumps, - projectConfigReorderGoals = Flag (ReorderGoals False), - projectConfigCountConflicts = Flag (CountConflicts True), - projectConfigFineGrainedConflicts = Flag (FineGrainedConflicts True), - projectConfigMinimizeConflictSet = Flag (MinimizeConflictSet False), - projectConfigStrongFlags = Flag (StrongFlags False), - projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False), - projectConfigOnlyConstrained = Flag OnlyConstrainedNone, - projectConfigIndependentGoals = Flag (IndependentGoals False), - projectConfigPreferOldest = Flag (PreferOldest False) - --projectConfigShadowPkgs = Flag False, - --projectConfigReinstall = Flag False, - --projectConfigAvoidReinstalls = Flag False, - --projectConfigOverrideReinstall = Flag False, - --projectConfigUpgradeDeps = Flag False - } - +resolveSolverSettings + ProjectConfig + { projectConfigShared + , projectConfigLocalPackages + , projectConfigSpecificPackage + } = + SolverSettings{..} + where + -- TODO: [required eventually] some of these settings need validation, e.g. + -- the flag assignments need checking. + solverSettingRemoteRepos = fromNubList projectConfigRemoteRepos + solverSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos + solverSettingConstraints = projectConfigConstraints + solverSettingPreferences = projectConfigPreferences + solverSettingFlagAssignment = packageConfigFlagAssignment projectConfigLocalPackages + solverSettingFlagAssignments = + fmap + packageConfigFlagAssignment + (getMapMappend projectConfigSpecificPackage) + solverSettingCabalVersion = flagToMaybe projectConfigCabalVersion + solverSettingSolver = fromFlag projectConfigSolver + solverSettingAllowOlder = fromMaybe mempty projectConfigAllowOlder + solverSettingAllowNewer = fromMaybe mempty projectConfigAllowNewer + solverSettingMaxBackjumps = case fromFlag projectConfigMaxBackjumps of + n + | n < 0 -> Nothing + | otherwise -> Just n + solverSettingReorderGoals = fromFlag projectConfigReorderGoals + solverSettingCountConflicts = fromFlag projectConfigCountConflicts + solverSettingFineGrainedConflicts = fromFlag projectConfigFineGrainedConflicts + solverSettingMinimizeConflictSet = fromFlag projectConfigMinimizeConflictSet + solverSettingStrongFlags = fromFlag projectConfigStrongFlags + solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls + solverSettingOnlyConstrained = fromFlag projectConfigOnlyConstrained + solverSettingIndexState = flagToMaybe projectConfigIndexState + solverSettingActiveRepos = flagToMaybe projectConfigActiveRepos + solverSettingIndependentGoals = fromFlag projectConfigIndependentGoals + solverSettingPreferOldest = fromFlag projectConfigPreferOldest + -- solverSettingShadowPkgs = fromFlag projectConfigShadowPkgs + -- solverSettingReinstall = fromFlag projectConfigReinstall + -- solverSettingAvoidReinstalls = fromFlag projectConfigAvoidReinstalls + -- solverSettingOverrideReinstall = fromFlag projectConfigOverrideReinstall + -- solverSettingUpgradeDeps = fromFlag projectConfigUpgradeDeps + + ProjectConfigShared{..} = defaults <> projectConfigShared + + defaults = + mempty + { projectConfigSolver = Flag defaultSolver + , projectConfigAllowOlder = Just (AllowOlder mempty) + , projectConfigAllowNewer = Just (AllowNewer mempty) + , projectConfigMaxBackjumps = Flag defaultMaxBackjumps + , projectConfigReorderGoals = Flag (ReorderGoals False) + , projectConfigCountConflicts = Flag (CountConflicts True) + , projectConfigFineGrainedConflicts = Flag (FineGrainedConflicts True) + , projectConfigMinimizeConflictSet = Flag (MinimizeConflictSet False) + , projectConfigStrongFlags = Flag (StrongFlags False) + , projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False) + , projectConfigOnlyConstrained = Flag OnlyConstrainedNone + , projectConfigIndependentGoals = Flag (IndependentGoals False) + , projectConfigPreferOldest = Flag (PreferOldest False) + -- projectConfigShadowPkgs = Flag False, + -- projectConfigReinstall = Flag False, + -- projectConfigAvoidReinstalls = Flag False, + -- projectConfigOverrideReinstall = Flag False, + -- projectConfigUpgradeDeps = Flag False + } -- | Resolve the project configuration, with all its optional fields, into -- 'BuildTimeSettings' with no optional fields (by applying defaults). --- -resolveBuildTimeSettings :: Verbosity - -> CabalDirLayout - -> ProjectConfig - -> BuildTimeSettings -resolveBuildTimeSettings verbosity - CabalDirLayout { - cabalLogsDirectory - } - ProjectConfig { - projectConfigShared = ProjectConfigShared { - projectConfigRemoteRepos, - projectConfigLocalNoIndexRepos, - projectConfigProgPathExtra - }, - projectConfigBuildOnly - } = - BuildTimeSettings {..} - where - buildSettingDryRun = fromFlag projectConfigDryRun - buildSettingOnlyDeps = fromFlag projectConfigOnlyDeps - buildSettingOnlyDownload = fromFlag projectConfigOnlyDownload - buildSettingSummaryFile = fromNubList projectConfigSummaryFile - --buildSettingLogFile -- defined below, more complicated - --buildSettingLogVerbosity -- defined below, more complicated - buildSettingBuildReports = fromFlag projectConfigBuildReports - buildSettingSymlinkBinDir = flagToList projectConfigSymlinkBinDir - buildSettingNumJobs = determineNumJobs projectConfigNumJobs - buildSettingKeepGoing = fromFlag projectConfigKeepGoing - buildSettingOfflineMode = fromFlag projectConfigOfflineMode - buildSettingKeepTempFiles = fromFlag projectConfigKeepTempFiles - buildSettingRemoteRepos = fromNubList projectConfigRemoteRepos - buildSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos - buildSettingCacheDir = fromFlag projectConfigCacheDir - buildSettingHttpTransport = flagToMaybe projectConfigHttpTransport - buildSettingIgnoreExpiry = fromFlag projectConfigIgnoreExpiry - buildSettingReportPlanningFailure - = fromFlag projectConfigReportPlanningFailure - buildSettingProgPathExtra = fromNubList projectConfigProgPathExtra - buildSettingHaddockOpen = False - - ProjectConfigBuildOnly{..} = defaults - <> projectConfigBuildOnly - - defaults = mempty { - projectConfigDryRun = toFlag False, - projectConfigOnlyDeps = toFlag False, - projectConfigOnlyDownload = toFlag False, - projectConfigBuildReports = toFlag NoReports, - projectConfigReportPlanningFailure = toFlag False, - projectConfigKeepGoing = toFlag False, - projectConfigOfflineMode = toFlag False, - projectConfigKeepTempFiles = toFlag False, - projectConfigIgnoreExpiry = toFlag False +resolveBuildTimeSettings + :: Verbosity + -> CabalDirLayout + -> ProjectConfig + -> BuildTimeSettings +resolveBuildTimeSettings + verbosity + CabalDirLayout + { cabalLogsDirectory } + ProjectConfig + { projectConfigShared = + ProjectConfigShared + { projectConfigRemoteRepos + , projectConfigLocalNoIndexRepos + , projectConfigProgPathExtra + } + , projectConfigBuildOnly + } = + BuildTimeSettings{..} + where + buildSettingDryRun = fromFlag projectConfigDryRun + buildSettingOnlyDeps = fromFlag projectConfigOnlyDeps + buildSettingOnlyDownload = fromFlag projectConfigOnlyDownload + buildSettingSummaryFile = fromNubList projectConfigSummaryFile + -- buildSettingLogFile -- defined below, more complicated + -- buildSettingLogVerbosity -- defined below, more complicated + buildSettingBuildReports = fromFlag projectConfigBuildReports + buildSettingSymlinkBinDir = flagToList projectConfigSymlinkBinDir + buildSettingNumJobs = determineNumJobs projectConfigNumJobs + buildSettingKeepGoing = fromFlag projectConfigKeepGoing + buildSettingOfflineMode = fromFlag projectConfigOfflineMode + buildSettingKeepTempFiles = fromFlag projectConfigKeepTempFiles + buildSettingRemoteRepos = fromNubList projectConfigRemoteRepos + buildSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos + buildSettingCacheDir = fromFlag projectConfigCacheDir + buildSettingHttpTransport = flagToMaybe projectConfigHttpTransport + buildSettingIgnoreExpiry = fromFlag projectConfigIgnoreExpiry + buildSettingReportPlanningFailure = + fromFlag projectConfigReportPlanningFailure + buildSettingProgPathExtra = fromNubList projectConfigProgPathExtra + buildSettingHaddockOpen = False + + ProjectConfigBuildOnly{..} = + defaults + <> projectConfigBuildOnly + + defaults = + mempty + { projectConfigDryRun = toFlag False + , projectConfigOnlyDeps = toFlag False + , projectConfigOnlyDownload = toFlag False + , projectConfigBuildReports = toFlag NoReports + , projectConfigReportPlanningFailure = toFlag False + , projectConfigKeepGoing = toFlag False + , projectConfigOfflineMode = toFlag False + , projectConfigKeepTempFiles = toFlag False + , projectConfigIgnoreExpiry = toFlag False + } - -- The logging logic: what log file to use and what verbosity. - -- - -- If the user has specified --remote-build-reporting=detailed, use the - -- default log file location. If the --build-log option is set, use the - -- provided location. Otherwise don't use logging, unless building in - -- parallel (in which case the default location is used). - -- - buildSettingLogFile :: Maybe (Compiler -> Platform - -> PackageId -> UnitId -> FilePath) - buildSettingLogFile - | useDefaultTemplate = Just (substLogFileName defaultTemplate) - | otherwise = fmap substLogFileName givenTemplate - - defaultTemplate = toPathTemplate $ - cabalLogsDirectory - "$compiler" "$libname" <.> "log" - givenTemplate = flagToMaybe projectConfigLogFile - - useDefaultTemplate - | buildSettingBuildReports == DetailedReports = True - | isJust givenTemplate = False - | isParallelBuild = True - | otherwise = False - - isParallelBuild = buildSettingNumJobs >= 2 - - substLogFileName :: PathTemplate - -> Compiler -> Platform - -> PackageId -> UnitId -> FilePath - substLogFileName template compiler platform pkgid uid = + -- The logging logic: what log file to use and what verbosity. + -- + -- If the user has specified --remote-build-reporting=detailed, use the + -- default log file location. If the --build-log option is set, use the + -- provided location. Otherwise don't use logging, unless building in + -- parallel (in which case the default location is used). + -- + buildSettingLogFile + :: Maybe + ( Compiler + -> Platform + -> PackageId + -> UnitId + -> FilePath + ) + buildSettingLogFile + | useDefaultTemplate = Just (substLogFileName defaultTemplate) + | otherwise = fmap substLogFileName givenTemplate + + defaultTemplate = + toPathTemplate $ + cabalLogsDirectory + "$compiler" + "$libname" + <.> "log" + givenTemplate = flagToMaybe projectConfigLogFile + + useDefaultTemplate + | buildSettingBuildReports == DetailedReports = True + | isJust givenTemplate = False + | isParallelBuild = True + | otherwise = False + + isParallelBuild = buildSettingNumJobs >= 2 + + substLogFileName + :: PathTemplate + -> Compiler + -> Platform + -> PackageId + -> UnitId + -> FilePath + substLogFileName template compiler platform pkgid uid = fromPathTemplate (substPathTemplate env template) - where - env = initialPathTemplateEnv - pkgid uid (compilerInfo compiler) platform - - -- If the user has specified --remote-build-reporting=detailed or - -- --build-log, use more verbose logging. - -- - buildSettingLogVerbosity :: Verbosity - buildSettingLogVerbosity - | overrideVerbosity = modifyVerbosity (max verbose) verbosity - | otherwise = verbosity - - overrideVerbosity :: Bool - overrideVerbosity - | buildSettingBuildReports == DetailedReports = True - | isJust givenTemplate = True - | isParallelBuild = False - | otherwise = False - + where + env = + initialPathTemplateEnv + pkgid + uid + (compilerInfo compiler) + platform + + -- If the user has specified --remote-build-reporting=detailed or + -- --build-log, use more verbose logging. + -- + buildSettingLogVerbosity :: Verbosity + buildSettingLogVerbosity + | overrideVerbosity = modifyVerbosity (max verbose) verbosity + | otherwise = verbosity + + overrideVerbosity :: Bool + overrideVerbosity + | buildSettingBuildReports == DetailedReports = True + | isJust givenTemplate = True + | isParallelBuild = False + | otherwise = False --------------------------------------------- -- Reading and writing project config files @@ -405,42 +504,43 @@ resolveBuildTimeSettings verbosity -- 2. The first directory containing @mprojectFile@/@cabal.project@, starting from the current directory -- and recursively checking parent directories -- 3. The current directory --- findProjectRoot :: Verbosity - -> Maybe FilePath -- ^ Explicit project directory - -> Maybe FilePath -- ^ Explicit project file + -> Maybe FilePath + -- ^ Explicit project directory + -> Maybe FilePath + -- ^ Explicit project file -> IO (Either BadProjectRoot ProjectRoot) findProjectRoot verbosity mprojectDir mprojectFile = do case mprojectDir of Nothing - | Just file <- mprojectFile, isAbsolute file -> do + | Just file <- mprojectFile + , isAbsolute file -> do warn verbosity $ "Specifying an absolute path to the project file is deprecated." - <> " Use --project-dir to set the project's directory." + <> " Use --project-dir to set the project's directory." doesFileExist file >>= \case False -> left (BadProjectRootExplicitFile file) - True -> uncurry projectRoot =<< first dropTrailingPathSeparator . splitFileName <$> canonicalizePath file - + True -> uncurry projectRoot =<< first dropTrailingPathSeparator . splitFileName <$> canonicalizePath file | otherwise -> probeProjectRoot mprojectFile + Just dir -> + doesDirectoryExist dir >>= \case + False -> left (BadProjectRootDir dir) + True -> do + projectDir <- canonicalizePath dir - Just dir -> doesDirectoryExist dir >>= \case - False -> left (BadProjectRootDir dir) - True -> do - projectDir <- canonicalizePath dir - - case mprojectFile of - Nothing -> pure $ Right (ProjectRootExplicit projectDir defaultProjectFile) - - Just projectFile - | isAbsolute projectFile -> doesFileExist projectFile >>= \case - False -> left (BadProjectRootAbsoluteFile projectFile) - True -> Right . ProjectRootExplicitAbsolute dir <$> canonicalizePath projectFile - - | otherwise -> doesFileExist (projectDir projectFile) >>= \case - False -> left (BadProjectRootDirFile dir projectFile) - True -> projectRoot projectDir projectFile + case mprojectFile of + Nothing -> pure $ Right (ProjectRootExplicit projectDir defaultProjectFile) + Just projectFile + | isAbsolute projectFile -> + doesFileExist projectFile >>= \case + False -> left (BadProjectRootAbsoluteFile projectFile) + True -> Right . ProjectRootExplicitAbsolute dir <$> canonicalizePath projectFile + | otherwise -> + doesFileExist (projectDir projectFile) >>= \case + False -> left (BadProjectRootDirFile dir projectFile) + True -> projectRoot projectDir projectFile where left = pure . Left @@ -449,9 +549,9 @@ findProjectRoot verbosity mprojectDir mprojectFile = do probeProjectRoot :: Maybe FilePath -> IO (Either BadProjectRoot ProjectRoot) probeProjectRoot mprojectFile = do - startdir <- getCurrentDirectory - homedir <- getHomeDirectory - probe startdir homedir + startdir <- getCurrentDirectory + homedir <- getHomeDirectory + probe startdir homedir where projectFileName :: String projectFileName = fromMaybe defaultProjectFile mprojectFile @@ -464,7 +564,7 @@ probeProjectRoot mprojectFile = do go :: FilePath -> IO (Either BadProjectRoot ProjectRoot) go dir | isDrive dir || dir == homedir = case mprojectFile of - Nothing -> return (Right (ProjectRootImplicit startdir)) + Nothing -> return (Right (ProjectRootImplicit startdir)) Just file -> return (Left (BadProjectRootExplicitFile file)) go dir = do exists <- doesFileExist (dir projectFileName) @@ -473,7 +573,6 @@ probeProjectRoot mprojectFile = do else go (takeDirectory dir) -- | Errors returned by 'findProjectRoot'. --- data BadProjectRoot = BadProjectRootExplicitFile FilePath | BadProjectRootDir FilePath @@ -488,87 +587,94 @@ instance Show BadProjectRoot where show = renderBadProjectRoot #endif +{- FOURMOLU_DISABLE -} instance Exception BadProjectRoot where #if MIN_VERSION_base(4,8,0) displayException = renderBadProjectRoot #endif +{- FOURMOLU_ENABLE -} renderBadProjectRoot :: BadProjectRoot -> String renderBadProjectRoot = \case BadProjectRootExplicitFile projectFile -> "The given project file '" ++ projectFile ++ "' does not exist." - BadProjectRootDir dir -> "The given project directory '" <> dir <> "' does not exist." - BadProjectRootAbsoluteFile file -> "The given project file '" <> file <> "' does not exist." - BadProjectRootDirFile dir file -> "The given project directory/file combination '" <> dir file <> "' does not exist." withProjectOrGlobalConfig - :: Verbosity -- ^ verbosity - -> Flag Bool -- ^ whether to ignore local project (--ignore-project flag) - -> Flag FilePath -- ^ @--cabal-config@ - -> IO a -- ^ with project - -> (ProjectConfig -> IO a) -- ^ without project - -> IO a + :: Verbosity + -- ^ verbosity + -> Flag Bool + -- ^ whether to ignore local project (--ignore-project flag) + -> Flag FilePath + -- ^ @--cabal-config@ + -> IO a + -- ^ with project + -> (ProjectConfig -> IO a) + -- ^ without project + -> IO a withProjectOrGlobalConfig verbosity (Flag True) gcf _with without = do - globalConfig <- runRebuild "" $ readGlobalConfig verbosity gcf - without globalConfig -withProjectOrGlobalConfig verbosity _ignorePrj gcf with without = - withProjectOrGlobalConfig' verbosity gcf with without + globalConfig <- runRebuild "" $ readGlobalConfig verbosity gcf + without globalConfig +withProjectOrGlobalConfig verbosity _ignorePrj gcf with without = + withProjectOrGlobalConfig' verbosity gcf with without withProjectOrGlobalConfig' - :: Verbosity - -> Flag FilePath - -> IO a - -> (ProjectConfig -> IO a) - -> IO a + :: Verbosity + -> Flag FilePath + -> IO a + -> (ProjectConfig -> IO a) + -> IO a withProjectOrGlobalConfig' verbosity globalConfigFlag with without = do globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag - catch with - $ \case - (BadPackageLocations prov locs) - | prov == Set.singleton Implicit - , let + catch with $ + \case + (BadPackageLocations prov locs) + | prov == Set.singleton Implicit + , let isGlobErr (BadLocGlobEmptyMatch _) = True isGlobErr _ = False - , any isGlobErr locs -> + , any isGlobErr locs -> without globalConfig - err -> throwIO err + err -> throwIO err -- | Read all the config relevant for a project. This includes the project -- file if any, plus other global config. --- -readProjectConfig :: Verbosity - -> HttpTransport - -> Flag Bool -- ^ @--ignore-project@ - -> Flag FilePath - -> DistDirLayout - -> Rebuild ProjectConfigSkeleton +readProjectConfig + :: Verbosity + -> HttpTransport + -> Flag Bool + -- ^ @--ignore-project@ + -> Flag FilePath + -> DistDirLayout + -> Rebuild ProjectConfigSkeleton readProjectConfig verbosity httpTransport ignoreProjectFlag configFileFlag distDirLayout = do - global <- singletonProjectConfigSkeleton <$> readGlobalConfig verbosity configFileFlag - local <- readProjectLocalConfigOrDefault verbosity httpTransport distDirLayout - freeze <- readProjectLocalFreezeConfig verbosity httpTransport distDirLayout - extra <- readProjectLocalExtraConfig verbosity httpTransport distDirLayout - if ignoreProjectFlag == Flag True then return (global <> (singletonProjectConfigSkeleton defaultProject)) + global <- singletonProjectConfigSkeleton <$> readGlobalConfig verbosity configFileFlag + local <- readProjectLocalConfigOrDefault verbosity httpTransport distDirLayout + freeze <- readProjectLocalFreezeConfig verbosity httpTransport distDirLayout + extra <- readProjectLocalExtraConfig verbosity httpTransport distDirLayout + if ignoreProjectFlag == Flag True + then return (global <> (singletonProjectConfigSkeleton defaultProject)) else return (global <> local <> freeze <> extra) - where - defaultProject :: ProjectConfig - defaultProject = mempty { - projectPackages = ["./"] - } + where + defaultProject :: ProjectConfig + defaultProject = + mempty + { projectPackages = ["./"] + } -- | Reads an explicit @cabal.project@ file in the given project root dir, -- or returns the default project config for an implicitly defined project. --- -readProjectLocalConfigOrDefault :: Verbosity - -> HttpTransport - -> DistDirLayout - -> Rebuild ProjectConfigSkeleton +readProjectLocalConfigOrDefault + :: Verbosity + -> HttpTransport + -> DistDirLayout + -> Rebuild ProjectConfigSkeleton readProjectLocalConfigOrDefault verbosity httpTransport distDirLayout = do usesExplicitProjectRoot <- liftIO $ doesFileExist projectFile if usesExplicitProjectRoot @@ -577,110 +683,122 @@ readProjectLocalConfigOrDefault verbosity httpTransport distDirLayout = do else do monitorFiles [monitorNonExistentFile projectFile] return (singletonProjectConfigSkeleton defaultImplicitProjectConfig) - where projectFile :: FilePath projectFile = distProjectFile distDirLayout "" defaultImplicitProjectConfig :: ProjectConfig - defaultImplicitProjectConfig = mempty { - -- We expect a package in the current directory. - projectPackages = [ "./*.cabal" ], - - projectConfigProvenance = Set.singleton Implicit - } + defaultImplicitProjectConfig = + mempty + { -- We expect a package in the current directory. + projectPackages = ["./*.cabal"] + , projectConfigProvenance = Set.singleton Implicit + } -- | Reads a @cabal.project.local@ file in the given project root dir, -- or returns empty. This file gets written by @cabal configure@, or in -- principle can be edited manually or by other tools. --- -readProjectLocalExtraConfig :: Verbosity -> HttpTransport -> DistDirLayout - -> Rebuild ProjectConfigSkeleton +readProjectLocalExtraConfig + :: Verbosity + -> HttpTransport + -> DistDirLayout + -> Rebuild ProjectConfigSkeleton readProjectLocalExtraConfig verbosity httpTransport distDirLayout = - readProjectFileSkeleton verbosity httpTransport distDirLayout "local" - "project local configuration file" + readProjectFileSkeleton + verbosity + httpTransport + distDirLayout + "local" + "project local configuration file" -- | Reads a @cabal.project.freeze@ file in the given project root dir, -- or returns empty. This file gets written by @cabal freeze@, or in -- principle can be edited manually or by other tools. --- -readProjectLocalFreezeConfig :: Verbosity -> HttpTransport ->DistDirLayout - -> Rebuild ProjectConfigSkeleton +readProjectLocalFreezeConfig + :: Verbosity + -> HttpTransport + -> DistDirLayout + -> Rebuild ProjectConfigSkeleton readProjectLocalFreezeConfig verbosity httpTransport distDirLayout = - readProjectFileSkeleton verbosity httpTransport distDirLayout "freeze" - "project freeze file" + readProjectFileSkeleton + verbosity + httpTransport + distDirLayout + "freeze" + "project freeze file" -- | Reads a named extended (with imports and conditionals) config file in the given project root dir, or returns empty. --- readProjectFileSkeleton :: Verbosity -> HttpTransport -> DistDirLayout -> String -> String -> Rebuild ProjectConfigSkeleton -readProjectFileSkeleton verbosity httpTransport DistDirLayout{distProjectFile, distDownloadSrcDirectory} - extensionName extensionDescription = do +readProjectFileSkeleton + verbosity + httpTransport + DistDirLayout{distProjectFile, distDownloadSrcDirectory} + extensionName + extensionDescription = do exists <- liftIO $ doesFileExist extensionFile if exists - then do monitorFiles [monitorFileHashed extensionFile] - pcs <- liftIO readExtensionFile - monitorFiles $ map monitorFileHashed (projectSkeletonImports pcs) - pure pcs - else do monitorFiles [monitorNonExistentFile extensionFile] - return mempty - where - extensionFile = distProjectFile extensionName + then do + monitorFiles [monitorFileHashed extensionFile] + pcs <- liftIO readExtensionFile + monitorFiles $ map monitorFileHashed (projectSkeletonImports pcs) + pure pcs + else do + monitorFiles [monitorNonExistentFile extensionFile] + return mempty + where + extensionFile = distProjectFile extensionName - readExtensionFile = - reportParseResult verbosity extensionDescription extensionFile - =<< parseProjectSkeleton distDownloadSrcDirectory httpTransport verbosity [] extensionFile - =<< BS.readFile extensionFile + readExtensionFile = + reportParseResult verbosity extensionDescription extensionFile + =<< parseProjectSkeleton distDownloadSrcDirectory httpTransport verbosity [] extensionFile + =<< BS.readFile extensionFile -- | Render the 'ProjectConfig' format. -- -- For the moment this is implemented in terms of a pretty printer for the -- legacy configuration types, plus a conversion. --- showProjectConfig :: ProjectConfig -> String showProjectConfig = - showLegacyProjectConfig . convertToLegacyProjectConfig - + showLegacyProjectConfig . convertToLegacyProjectConfig -- | Write a @cabal.project.local@ file in the given project root dir. --- writeProjectLocalExtraConfig :: DistDirLayout -> ProjectConfig -> IO () writeProjectLocalExtraConfig DistDirLayout{distProjectFile} = - writeProjectConfigFile (distProjectFile "local") - + writeProjectConfigFile (distProjectFile "local") -- | Write a @cabal.project.freeze@ file in the given project root dir. --- writeProjectLocalFreezeConfig :: DistDirLayout -> ProjectConfig -> IO () writeProjectLocalFreezeConfig DistDirLayout{distProjectFile} = - writeProjectConfigFile (distProjectFile "freeze") - + writeProjectConfigFile (distProjectFile "freeze") -- | Write in the @cabal.project@ format to the given file. --- writeProjectConfigFile :: FilePath -> ProjectConfig -> IO () writeProjectConfigFile file = - writeFile file . showProjectConfig - + writeFile file . showProjectConfig -- | Read the user's cabal-install config file. --- readGlobalConfig :: Verbosity -> Flag FilePath -> Rebuild ProjectConfig readGlobalConfig verbosity configFileFlag = do - config <- liftIO (loadConfig verbosity configFileFlag) - configFile <- liftIO (getConfigFilePath configFileFlag) - monitorFiles [monitorFileHashed configFile] - return (convertLegacyGlobalConfig config) + config <- liftIO (loadConfig verbosity configFileFlag) + configFile <- liftIO (getConfigFilePath configFileFlag) + monitorFiles [monitorFileHashed configFile] + return (convertLegacyGlobalConfig config) reportParseResult :: Verbosity -> String -> FilePath -> OldParser.ParseResult ProjectConfigSkeleton -> IO ProjectConfigSkeleton reportParseResult verbosity _filetype filename (OldParser.ParseOk warnings x) = do - unless (null warnings) $ - let msg = unlines (map (OldParser.showPWarning (intercalate ", " $ filename : projectSkeletonImports x)) warnings) - in warn verbosity msg - return x + unless (null warnings) $ + let msg = unlines (map (OldParser.showPWarning (intercalate ", " $ filename : projectSkeletonImports x)) warnings) + in warn verbosity msg + return x reportParseResult verbosity filetype filename (OldParser.ParseFailed err) = - let (line, msg) = OldParser.locatedErrorMsg err - in die' verbosity $ "Error parsing " ++ filetype ++ " " ++ filename - ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg - + let (line, msg) = OldParser.locatedErrorMsg err + in die' verbosity $ + "Error parsing " + ++ filetype + ++ " " + ++ filename + ++ maybe "" (\n -> ':' : show n) line + ++ ":\n" + ++ msg --------------------------------------------- -- Finding packages in the project @@ -689,21 +807,18 @@ reportParseResult verbosity filetype filename (OldParser.ParseFailed err) = -- | The location of a package as part of a project. Local file paths are -- either absolute (if the user specified it as such) or they are relative -- to the project root. --- -data ProjectPackageLocation = - ProjectPackageLocalCabalFile FilePath - | ProjectPackageLocalDirectory FilePath FilePath -- dir and .cabal file - | ProjectPackageLocalTarball FilePath - | ProjectPackageRemoteTarball URI - | ProjectPackageRemoteRepo SourceRepoList - | ProjectPackageNamed PackageVersionConstraint - deriving Show - +data ProjectPackageLocation + = ProjectPackageLocalCabalFile FilePath + | ProjectPackageLocalDirectory FilePath FilePath -- dir and .cabal file + | ProjectPackageLocalTarball FilePath + | ProjectPackageRemoteTarball URI + | ProjectPackageRemoteRepo SourceRepoList + | ProjectPackageNamed PackageVersionConstraint + deriving (Show) -- | Exception thrown by 'findProjectPackages'. --- data BadPackageLocations - = BadPackageLocations (Set ProjectConfigProvenance) [BadPackageLocation] + = BadPackageLocations (Set ProjectConfigProvenance) [BadPackageLocation] #if MIN_VERSION_base(4,8,0) deriving (Show, Typeable) #else @@ -713,63 +828,62 @@ instance Show BadPackageLocations where show = renderBadPackageLocations #endif +{- FOURMOLU_DISABLE -} instance Exception BadPackageLocations where #if MIN_VERSION_base(4,8,0) displayException = renderBadPackageLocations #endif ---TODO: [nice to have] custom exception subclass for Doc rendering, colour etc +{- FOURMOLU_ENABLE -} +-- TODO: [nice to have] custom exception subclass for Doc rendering, colour etc data BadPackageLocation - = BadPackageLocationFile BadPackageLocationMatch - | BadLocGlobEmptyMatch String - | BadLocGlobBadMatches String [BadPackageLocationMatch] - | BadLocUnexpectedUriScheme String - | BadLocUnrecognisedUri String - | BadLocUnrecognised String - deriving Show + = BadPackageLocationFile BadPackageLocationMatch + | BadLocGlobEmptyMatch String + | BadLocGlobBadMatches String [BadPackageLocationMatch] + | BadLocUnexpectedUriScheme String + | BadLocUnrecognisedUri String + | BadLocUnrecognised String + deriving (Show) data BadPackageLocationMatch - = BadLocUnexpectedFile String - | BadLocNonexistantFile String - | BadLocDirNoCabalFile String - | BadLocDirManyCabalFiles String - deriving Show + = BadLocUnexpectedFile String + | BadLocNonexistantFile String + | BadLocDirNoCabalFile String + | BadLocDirManyCabalFiles String + deriving (Show) renderBadPackageLocations :: BadPackageLocations -> String renderBadPackageLocations (BadPackageLocations provenance bpls) - -- There is no provenance information, - -- render standard bad package error information. - | Set.null provenance = renderErrors renderBadPackageLocation - - -- The configuration is implicit, render bad package locations - -- using possibly specialized error messages. - | Set.singleton Implicit == provenance = - renderErrors renderImplicitBadPackageLocation - - -- The configuration contains both implicit and explicit provenance. - -- This should not occur, and a message is output to assist debugging. - | Implicit `Set.member` provenance = - "Warning: both implicit and explicit configuration is present." + -- There is no provenance information, + -- render standard bad package error information. + | Set.null provenance = renderErrors renderBadPackageLocation + -- The configuration is implicit, render bad package locations + -- using possibly specialized error messages. + | Set.singleton Implicit == provenance = + renderErrors renderImplicitBadPackageLocation + -- The configuration contains both implicit and explicit provenance. + -- This should not occur, and a message is output to assist debugging. + | Implicit `Set.member` provenance = + "Warning: both implicit and explicit configuration is present." ++ renderExplicit - - -- The configuration was read from one or more explicit path(s), - -- list the locations and render the bad package error information. - -- The intent is to supersede this with the relevant location information - -- per package error. - | otherwise = renderExplicit + -- The configuration was read from one or more explicit path(s), + -- list the locations and render the bad package error information. + -- The intent is to supersede this with the relevant location information + -- per package error. + | otherwise = renderExplicit where renderErrors f = unlines (map f bpls) renderExplicit = - "When using configuration(s) from " + "When using configuration(s) from " ++ intercalate ", " (mapMaybe getExplicit (Set.toList provenance)) ++ ", the following errors occurred:\n" ++ renderErrors renderBadPackageLocation getExplicit (Explicit path) = Just path - getExplicit Implicit = Nothing + getExplicit Implicit = Nothing ---TODO: [nice to have] keep track of the config file (and src loc) packages +-- TODO: [nice to have] keep track of the config file (and src loc) packages -- were listed, to use in error messages -- | Render bad package location error information for the implicit @@ -781,225 +895,260 @@ renderBadPackageLocations (BadPackageLocations provenance bpls) -- is present. renderImplicitBadPackageLocation :: BadPackageLocation -> String renderImplicitBadPackageLocation bpl = case bpl of - BadLocGlobEmptyMatch pkglocstr -> - "No cabal.project file or cabal file matching the default glob '" - ++ pkglocstr ++ "' was found.\n" - ++ "Please create a package description file .cabal " - ++ "or a cabal.project file referencing the packages you " - ++ "want to build." - _ -> renderBadPackageLocation bpl + BadLocGlobEmptyMatch pkglocstr -> + "No cabal.project file or cabal file matching the default glob '" + ++ pkglocstr + ++ "' was found.\n" + ++ "Please create a package description file .cabal " + ++ "or a cabal.project file referencing the packages you " + ++ "want to build." + _ -> renderBadPackageLocation bpl renderBadPackageLocation :: BadPackageLocation -> String renderBadPackageLocation bpl = case bpl of - BadPackageLocationFile badmatch -> - renderBadPackageLocationMatch badmatch - BadLocGlobEmptyMatch pkglocstr -> - "The package location glob '" ++ pkglocstr - ++ "' does not match any files or directories." - BadLocGlobBadMatches pkglocstr failures -> - "The package location glob '" ++ pkglocstr ++ "' does not match any " - ++ "recognised forms of package. " - ++ concatMap ((' ':) . renderBadPackageLocationMatch) failures - BadLocUnexpectedUriScheme pkglocstr -> - "The package location URI '" ++ pkglocstr ++ "' does not use a " - ++ "supported URI scheme. The supported URI schemes are http, https and " - ++ "file." - BadLocUnrecognisedUri pkglocstr -> - "The package location URI '" ++ pkglocstr ++ "' does not appear to " - ++ "be a valid absolute URI." - BadLocUnrecognised pkglocstr -> - "The package location syntax '" ++ pkglocstr ++ "' is not recognised." + BadPackageLocationFile badmatch -> + renderBadPackageLocationMatch badmatch + BadLocGlobEmptyMatch pkglocstr -> + "The package location glob '" + ++ pkglocstr + ++ "' does not match any files or directories." + BadLocGlobBadMatches pkglocstr failures -> + "The package location glob '" + ++ pkglocstr + ++ "' does not match any " + ++ "recognised forms of package. " + ++ concatMap ((' ' :) . renderBadPackageLocationMatch) failures + BadLocUnexpectedUriScheme pkglocstr -> + "The package location URI '" + ++ pkglocstr + ++ "' does not use a " + ++ "supported URI scheme. The supported URI schemes are http, https and " + ++ "file." + BadLocUnrecognisedUri pkglocstr -> + "The package location URI '" + ++ pkglocstr + ++ "' does not appear to " + ++ "be a valid absolute URI." + BadLocUnrecognised pkglocstr -> + "The package location syntax '" ++ pkglocstr ++ "' is not recognised." renderBadPackageLocationMatch :: BadPackageLocationMatch -> String renderBadPackageLocationMatch bplm = case bplm of - BadLocUnexpectedFile pkglocstr -> - "The package location '" ++ pkglocstr ++ "' is not recognised. The " - ++ "supported file targets are .cabal files, .tar.gz tarballs or package " - ++ "directories (i.e. directories containing a .cabal file)." - BadLocNonexistantFile pkglocstr -> - "The package location '" ++ pkglocstr ++ "' does not exist." - BadLocDirNoCabalFile pkglocstr -> - "The package directory '" ++ pkglocstr ++ "' does not contain any " - ++ ".cabal file." - BadLocDirManyCabalFiles pkglocstr -> - "The package directory '" ++ pkglocstr ++ "' contains multiple " - ++ ".cabal files (which is not currently supported)." + BadLocUnexpectedFile pkglocstr -> + "The package location '" + ++ pkglocstr + ++ "' is not recognised. The " + ++ "supported file targets are .cabal files, .tar.gz tarballs or package " + ++ "directories (i.e. directories containing a .cabal file)." + BadLocNonexistantFile pkglocstr -> + "The package location '" ++ pkglocstr ++ "' does not exist." + BadLocDirNoCabalFile pkglocstr -> + "The package directory '" + ++ pkglocstr + ++ "' does not contain any " + ++ ".cabal file." + BadLocDirManyCabalFiles pkglocstr -> + "The package directory '" + ++ pkglocstr + ++ "' contains multiple " + ++ ".cabal files (which is not currently supported)." -- | Given the project config, -- -- Throws 'BadPackageLocations'. --- -findProjectPackages :: DistDirLayout -> ProjectConfig - -> Rebuild [ProjectPackageLocation] -findProjectPackages DistDirLayout{distProjectRootDirectory} - ProjectConfig{..} = do - - requiredPkgs <- findPackageLocations True projectPackages - optionalPkgs <- findPackageLocations False projectPackagesOptional - let repoPkgs = map ProjectPackageRemoteRepo projectPackagesRepo - namedPkgs = map ProjectPackageNamed projectPackagesNamed +findProjectPackages + :: DistDirLayout + -> ProjectConfig + -> Rebuild [ProjectPackageLocation] +findProjectPackages + DistDirLayout{distProjectRootDirectory} + ProjectConfig{..} = do + requiredPkgs <- findPackageLocations True projectPackages + optionalPkgs <- findPackageLocations False projectPackagesOptional + let repoPkgs = map ProjectPackageRemoteRepo projectPackagesRepo + namedPkgs = map ProjectPackageNamed projectPackagesNamed return (concat [requiredPkgs, optionalPkgs, repoPkgs, namedPkgs]) - where - findPackageLocations :: Bool -> [String] -> Rebuild [ProjectPackageLocation] - findPackageLocations required pkglocstr = do - (problems, pkglocs) <- - partitionEithers <$> traverse (findPackageLocation required) pkglocstr - unless (null problems) $ - liftIO $ throwIO $ BadPackageLocations projectConfigProvenance problems - return (concat pkglocs) - - - findPackageLocation :: Bool -> String - -> Rebuild (Either BadPackageLocation - [ProjectPackageLocation]) - findPackageLocation _required@True pkglocstr = - -- strategy: try first as a file:// or http(s):// URL. - -- then as a file glob (usually encompassing single file) - -- finally as a single file, for files that fail to parse as globs - checkIsUriPackage pkglocstr - `mplusMaybeT` checkIsFileGlobPackage pkglocstr - `mplusMaybeT` checkIsSingleFilePackage pkglocstr - >>= maybe (return (Left (BadLocUnrecognised pkglocstr))) return - - - findPackageLocation _required@False pkglocstr = do - -- just globs for optional case - res <- checkIsFileGlobPackage pkglocstr - case res of - Nothing -> return (Left (BadLocUnrecognised pkglocstr)) - Just (Left _) -> return (Right []) -- it's optional - Just (Right pkglocs) -> return (Right pkglocs) - - - checkIsUriPackage, checkIsFileGlobPackage, checkIsSingleFilePackage - :: String -> Rebuild (Maybe (Either BadPackageLocation - [ProjectPackageLocation])) - checkIsUriPackage pkglocstr = - case parseAbsoluteURI pkglocstr of - Just uri@URI { - uriScheme = scheme, - uriAuthority = Just URIAuth { uriRegName = host }, - uriPath = path, - uriQuery = query, - uriFragment = frag - } - | recognisedScheme && not (null host) -> - return (Just (Right [ProjectPackageRemoteTarball uri])) - - | scheme == "file:" && null host && null query && null frag -> - checkIsSingleFilePackage path - - | not recognisedScheme && not (null host) -> - return (Just (Left (BadLocUnexpectedUriScheme pkglocstr))) - - | recognisedScheme && null host -> - return (Just (Left (BadLocUnrecognisedUri pkglocstr))) - where - recognisedScheme = scheme == "http:" || scheme == "https:" - || scheme == "file:" - - _ -> return Nothing - - - checkIsFileGlobPackage pkglocstr = - case simpleParsec pkglocstr of - Nothing -> return Nothing - Just glob -> liftM Just $ do - matches <- matchFileGlob glob - case matches of - [] | isJust (isTrivialFilePathGlob glob) - -> return (Left (BadPackageLocationFile - (BadLocNonexistantFile pkglocstr))) - - [] -> return (Left (BadLocGlobEmptyMatch pkglocstr)) - - _ -> do - (failures, pkglocs) <- partitionEithers <$> - traverse checkFilePackageMatch matches - return $! case (failures, pkglocs) of - ([failure], []) | isJust (isTrivialFilePathGlob glob) - -> Left (BadPackageLocationFile failure) - (_, []) -> Left (BadLocGlobBadMatches pkglocstr failures) - _ -> Right pkglocs - - - checkIsSingleFilePackage pkglocstr = do - let filename = distProjectRootDirectory pkglocstr - isFile <- liftIO $ doesFileExist filename - isDir <- liftIO $ doesDirectoryExist filename - if isFile || isDir - then checkFilePackageMatch pkglocstr - >>= either (return . Just . Left . BadPackageLocationFile) - (return . Just . Right . (\x->[x])) - else return Nothing - - - checkFilePackageMatch :: String -> Rebuild (Either BadPackageLocationMatch - ProjectPackageLocation) - checkFilePackageMatch pkglocstr = do - -- The pkglocstr may be absolute or may be relative to the project root. - -- Either way, does the right thing here. We return relative paths if - -- they were relative in the first place. - let abspath = distProjectRootDirectory pkglocstr - isFile <- liftIO $ doesFileExist abspath - isDir <- liftIO $ doesDirectoryExist abspath - parentDirExists <- case takeDirectory abspath of - [] -> return False - dir -> liftIO $ doesDirectoryExist dir - case () of - _ | isDir - -> do matches <- matchFileGlob (globStarDotCabal pkglocstr) - case matches of - [cabalFile] - -> return (Right (ProjectPackageLocalDirectory - pkglocstr cabalFile)) - [] -> return (Left (BadLocDirNoCabalFile pkglocstr)) - _ -> return (Left (BadLocDirManyCabalFiles pkglocstr)) - - | extensionIsTarGz pkglocstr - -> return (Right (ProjectPackageLocalTarball pkglocstr)) - - | takeExtension pkglocstr == ".cabal" - -> return (Right (ProjectPackageLocalCabalFile pkglocstr)) - - | isFile - -> return (Left (BadLocUnexpectedFile pkglocstr)) - - | parentDirExists - -> return (Left (BadLocNonexistantFile pkglocstr)) - - | otherwise - -> return (Left (BadLocUnexpectedFile pkglocstr)) - - - extensionIsTarGz f = takeExtension f == ".gz" - && takeExtension (dropExtension f) == ".tar" - + where + findPackageLocations :: Bool -> [String] -> Rebuild [ProjectPackageLocation] + findPackageLocations required pkglocstr = do + (problems, pkglocs) <- + partitionEithers <$> traverse (findPackageLocation required) pkglocstr + unless (null problems) $ + liftIO $ + throwIO $ + BadPackageLocations projectConfigProvenance problems + return (concat pkglocs) + + findPackageLocation + :: Bool + -> String + -> Rebuild + ( Either + BadPackageLocation + [ProjectPackageLocation] + ) + findPackageLocation _required@True pkglocstr = + -- strategy: try first as a file:// or http(s):// URL. + -- then as a file glob (usually encompassing single file) + -- finally as a single file, for files that fail to parse as globs + checkIsUriPackage pkglocstr + `mplusMaybeT` checkIsFileGlobPackage pkglocstr + `mplusMaybeT` checkIsSingleFilePackage pkglocstr + >>= maybe (return (Left (BadLocUnrecognised pkglocstr))) return + findPackageLocation _required@False pkglocstr = do + -- just globs for optional case + res <- checkIsFileGlobPackage pkglocstr + case res of + Nothing -> return (Left (BadLocUnrecognised pkglocstr)) + Just (Left _) -> return (Right []) -- it's optional + Just (Right pkglocs) -> return (Right pkglocs) + + checkIsUriPackage + , checkIsFileGlobPackage + , checkIsSingleFilePackage + :: String + -> Rebuild + ( Maybe + ( Either + BadPackageLocation + [ProjectPackageLocation] + ) + ) + checkIsUriPackage pkglocstr = + case parseAbsoluteURI pkglocstr of + Just + uri@URI + { uriScheme = scheme + , uriAuthority = Just URIAuth{uriRegName = host} + , uriPath = path + , uriQuery = query + , uriFragment = frag + } + | recognisedScheme && not (null host) -> + return (Just (Right [ProjectPackageRemoteTarball uri])) + | scheme == "file:" && null host && null query && null frag -> + checkIsSingleFilePackage path + | not recognisedScheme && not (null host) -> + return (Just (Left (BadLocUnexpectedUriScheme pkglocstr))) + | recognisedScheme && null host -> + return (Just (Left (BadLocUnrecognisedUri pkglocstr))) + where + recognisedScheme = + scheme == "http:" + || scheme == "https:" + || scheme == "file:" + _ -> return Nothing + + checkIsFileGlobPackage pkglocstr = + case simpleParsec pkglocstr of + Nothing -> return Nothing + Just glob -> liftM Just $ do + matches <- matchFileGlob glob + case matches of + [] + | isJust (isTrivialFilePathGlob glob) -> + return + ( Left + ( BadPackageLocationFile + (BadLocNonexistantFile pkglocstr) + ) + ) + [] -> return (Left (BadLocGlobEmptyMatch pkglocstr)) + _ -> do + (failures, pkglocs) <- + partitionEithers + <$> traverse checkFilePackageMatch matches + return $! case (failures, pkglocs) of + ([failure], []) + | isJust (isTrivialFilePathGlob glob) -> + Left (BadPackageLocationFile failure) + (_, []) -> Left (BadLocGlobBadMatches pkglocstr failures) + _ -> Right pkglocs + + checkIsSingleFilePackage pkglocstr = do + let filename = distProjectRootDirectory pkglocstr + isFile <- liftIO $ doesFileExist filename + isDir <- liftIO $ doesDirectoryExist filename + if isFile || isDir + then + checkFilePackageMatch pkglocstr + >>= either + (return . Just . Left . BadPackageLocationFile) + (return . Just . Right . (\x -> [x])) + else return Nothing + + checkFilePackageMatch + :: String + -> Rebuild + ( Either + BadPackageLocationMatch + ProjectPackageLocation + ) + checkFilePackageMatch pkglocstr = do + -- The pkglocstr may be absolute or may be relative to the project root. + -- Either way, does the right thing here. We return relative paths if + -- they were relative in the first place. + let abspath = distProjectRootDirectory pkglocstr + isFile <- liftIO $ doesFileExist abspath + isDir <- liftIO $ doesDirectoryExist abspath + parentDirExists <- case takeDirectory abspath of + [] -> return False + dir -> liftIO $ doesDirectoryExist dir + case () of + _ + | isDir -> + do + matches <- matchFileGlob (globStarDotCabal pkglocstr) + case matches of + [cabalFile] -> + return + ( Right + ( ProjectPackageLocalDirectory + pkglocstr + cabalFile + ) + ) + [] -> return (Left (BadLocDirNoCabalFile pkglocstr)) + _ -> return (Left (BadLocDirManyCabalFiles pkglocstr)) + | extensionIsTarGz pkglocstr -> + return (Right (ProjectPackageLocalTarball pkglocstr)) + | takeExtension pkglocstr == ".cabal" -> + return (Right (ProjectPackageLocalCabalFile pkglocstr)) + | isFile -> + return (Left (BadLocUnexpectedFile pkglocstr)) + | parentDirExists -> + return (Left (BadLocNonexistantFile pkglocstr)) + | otherwise -> + return (Left (BadLocUnexpectedFile pkglocstr)) + + extensionIsTarGz f = + takeExtension f == ".gz" + && takeExtension (dropExtension f) == ".tar" -- | A glob to find all the cabal files in a directory. -- -- For a directory @some/dir/@, this is a glob of the form @some/dir/\*.cabal@. -- The directory part can be either absolute or relative. --- globStarDotCabal :: FilePath -> FilePathGlob globStarDotCabal dir = - FilePathGlob - (if isAbsolute dir then FilePathRoot root else FilePathRelative) - (foldr (\d -> GlobDir [Literal d]) - (GlobFile [WildCard, Literal ".cabal"]) dirComponents) + FilePathGlob + (if isAbsolute dir then FilePathRoot root else FilePathRelative) + ( foldr + (\d -> GlobDir [Literal d]) + (GlobFile [WildCard, Literal ".cabal"]) + dirComponents + ) where (root, dirComponents) = fmap splitDirectories (splitDrive dir) - ---TODO: [code cleanup] use sufficiently recent transformers package +-- TODO: [code cleanup] use sufficiently recent transformers package mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a) mplusMaybeT ma mb = do mx <- ma case mx of Nothing -> mb - Just x -> return (Just x) - + Just x -> return (Just x) ------------------------------------------------- -- Fetching and reading packages in the project @@ -1010,7 +1159,6 @@ mplusMaybeT ma mb = do -- -- Note here is where we convert from project-root relative paths to absolute -- paths. --- fetchAndReadSourcePackages :: Verbosity -> DistDirLayout @@ -1018,246 +1166,281 @@ fetchAndReadSourcePackages -> ProjectConfigBuildOnly -> [ProjectPackageLocation] -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] -fetchAndReadSourcePackages verbosity distDirLayout - projectConfigShared - projectConfigBuildOnly - pkgLocations = do - +fetchAndReadSourcePackages + verbosity + distDirLayout + projectConfigShared + projectConfigBuildOnly + pkgLocations = do pkgsLocalDirectory <- sequenceA [ readSourcePackageLocalDirectory verbosity dir cabalFile | location <- pkgLocations - , (dir, cabalFile) <- projectPackageLocal location ] + , (dir, cabalFile) <- projectPackageLocal location + ] pkgsLocalTarball <- sequenceA [ readSourcePackageLocalTarball verbosity path - | ProjectPackageLocalTarball path <- pkgLocations ] + | ProjectPackageLocalTarball path <- pkgLocations + ] pkgsRemoteTarball <- do - getTransport <- delayInitSharedResource $ - configureTransport verbosity progPathExtra - preferredHttpTransport + getTransport <- + delayInitSharedResource $ + configureTransport + verbosity + progPathExtra + preferredHttpTransport sequenceA - [ fetchAndReadSourcePackageRemoteTarball verbosity distDirLayout - getTransport uri - | ProjectPackageRemoteTarball uri <- pkgLocations ] + [ fetchAndReadSourcePackageRemoteTarball + verbosity + distDirLayout + getTransport + uri + | ProjectPackageRemoteTarball uri <- pkgLocations + ] pkgsRemoteRepo <- syncAndReadSourcePackagesRemoteRepos - verbosity distDirLayout + verbosity + distDirLayout projectConfigShared - [ repo | ProjectPackageRemoteRepo repo <- pkgLocations ] + [repo | ProjectPackageRemoteRepo repo <- pkgLocations] let pkgsNamed = [ NamedPackage pkgname [PackagePropertyVersion verrange] - | ProjectPackageNamed (PackageVersionConstraint pkgname verrange) <- pkgLocations ] - - return $ concat - [ pkgsLocalDirectory - , pkgsLocalTarball - , pkgsRemoteTarball - , pkgsRemoteRepo - , pkgsNamed - ] - where - projectPackageLocal (ProjectPackageLocalDirectory dir file) = [(dir, file)] - projectPackageLocal (ProjectPackageLocalCabalFile file) = [(dir, file)] - where dir = takeDirectory file - projectPackageLocal _ = [] + | ProjectPackageNamed (PackageVersionConstraint pkgname verrange) <- pkgLocations + ] + + return $ + concat + [ pkgsLocalDirectory + , pkgsLocalTarball + , pkgsRemoteTarball + , pkgsRemoteRepo + , pkgsNamed + ] + where + projectPackageLocal (ProjectPackageLocalDirectory dir file) = [(dir, file)] + projectPackageLocal (ProjectPackageLocalCabalFile file) = [(dir, file)] + where + dir = takeDirectory file + projectPackageLocal _ = [] - progPathExtra = fromNubList (projectConfigProgPathExtra projectConfigShared) - preferredHttpTransport = - flagToMaybe (projectConfigHttpTransport projectConfigBuildOnly) + progPathExtra = fromNubList (projectConfigProgPathExtra projectConfigShared) + preferredHttpTransport = + flagToMaybe (projectConfigHttpTransport projectConfigBuildOnly) -- | A helper for 'fetchAndReadSourcePackages' to handle the case of -- 'ProjectPackageLocalDirectory' and 'ProjectPackageLocalCabalFile'. -- We simply read the @.cabal@ file. --- readSourcePackageLocalDirectory :: Verbosity - -> FilePath -- ^ The package directory - -> FilePath -- ^ The package @.cabal@ file + -> FilePath + -- ^ The package directory + -> FilePath + -- ^ The package @.cabal@ file -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) readSourcePackageLocalDirectory verbosity dir cabalFile = do - monitorFiles [monitorFileHashed cabalFile] - root <- askRoot - let location = LocalUnpackedPackage (root dir) - liftIO $ fmap (mkSpecificSourcePackage location) - . readSourcePackageCabalFile verbosity cabalFile - =<< BS.readFile (root cabalFile) - + monitorFiles [monitorFileHashed cabalFile] + root <- askRoot + let location = LocalUnpackedPackage (root dir) + liftIO $ + fmap (mkSpecificSourcePackage location) + . readSourcePackageCabalFile verbosity cabalFile + =<< BS.readFile (root cabalFile) -- | A helper for 'fetchAndReadSourcePackages' to handle the case of -- 'ProjectPackageLocalTarball'. We scan through the @.tar.gz@ file to find -- the @.cabal@ file and read that. --- readSourcePackageLocalTarball :: Verbosity -> FilePath -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) readSourcePackageLocalTarball verbosity tarballFile = do - monitorFiles [monitorFile tarballFile] - root <- askRoot - let location = LocalTarballPackage (root tarballFile) - liftIO $ fmap (mkSpecificSourcePackage location) - . uncurry (readSourcePackageCabalFile verbosity) - =<< extractTarballPackageCabalFile (root tarballFile) + monitorFiles [monitorFile tarballFile] + root <- askRoot + let location = LocalTarballPackage (root tarballFile) + liftIO $ + fmap (mkSpecificSourcePackage location) + . uncurry (readSourcePackageCabalFile verbosity) + =<< extractTarballPackageCabalFile (root tarballFile) -- | A helper for 'fetchAndReadSourcePackages' to handle the case of -- 'ProjectPackageRemoteTarball'. We download the tarball to the dist src dir -- and after that handle it like the local tarball case. --- fetchAndReadSourcePackageRemoteTarball :: Verbosity -> DistDirLayout -> Rebuild HttpTransport -> URI -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) -fetchAndReadSourcePackageRemoteTarball verbosity - DistDirLayout { - distDownloadSrcDirectory - } - getTransport - tarballUri = +fetchAndReadSourcePackageRemoteTarball + verbosity + DistDirLayout + { distDownloadSrcDirectory + } + getTransport + tarballUri = -- The tarball download is expensive so we use another layer of file -- monitor to avoid it whenever possible. rerunIfChanged verbosity monitor tarballUri $ do - -- Download transport <- getTransport liftIO $ do transportCheckHttps verbosity transport tarballUri notice verbosity ("Downloading " ++ show tarballUri) - createDirectoryIfMissingVerbose verbosity True - distDownloadSrcDirectory + createDirectoryIfMissingVerbose + verbosity + True + distDownloadSrcDirectory _ <- downloadURI transport verbosity tarballUri tarballFile return () -- Read monitorFiles [monitorFile tarballFile] let location = RemoteTarballPackage tarballUri tarballFile - liftIO $ fmap (mkSpecificSourcePackage location) - . uncurry (readSourcePackageCabalFile verbosity) - =<< extractTarballPackageCabalFile tarballFile - where - tarballStem :: FilePath - tarballStem = distDownloadSrcDirectory - localFileNameForRemoteTarball tarballUri - tarballFile :: FilePath - tarballFile = tarballStem <.> "tar.gz" - - monitor :: FileMonitor URI (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) - monitor = newFileMonitor (tarballStem <.> "cache") + liftIO $ + fmap (mkSpecificSourcePackage location) + . uncurry (readSourcePackageCabalFile verbosity) + =<< extractTarballPackageCabalFile tarballFile + where + tarballStem :: FilePath + tarballStem = + distDownloadSrcDirectory + localFileNameForRemoteTarball tarballUri + tarballFile :: FilePath + tarballFile = tarballStem <.> "tar.gz" + monitor :: FileMonitor URI (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) + monitor = newFileMonitor (tarballStem <.> "cache") -- | A helper for 'fetchAndReadSourcePackages' to handle all the cases of -- 'ProjectPackageRemoteRepo'. --- syncAndReadSourcePackagesRemoteRepos :: Verbosity -> DistDirLayout -> ProjectConfigShared -> [SourceRepoList] -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] -syncAndReadSourcePackagesRemoteRepos verbosity - DistDirLayout{distDownloadSrcDirectory} - ProjectConfigShared { - projectConfigProgPathExtra - } - repos = do - - repos' <- either reportSourceRepoProblems return $ - validateSourceRepos repos +syncAndReadSourcePackagesRemoteRepos + verbosity + DistDirLayout{distDownloadSrcDirectory} + ProjectConfigShared + { projectConfigProgPathExtra + } + repos = do + repos' <- + either reportSourceRepoProblems return $ + validateSourceRepos repos -- All 'SourceRepo's grouped by referring to the "same" remote repo -- instance. So same location but can differ in commit/tag/branch/subdir. - let reposByLocation :: Map (RepoType, String) - [(SourceRepoList, RepoType)] - reposByLocation = Map.fromListWith (++) - [ ((rtype, rloc), [(repo, vcsRepoType vcs)]) - | (repo, rloc, rtype, vcs) <- repos' ] - - --TODO: pass progPathExtra on to 'configureVCS' + let reposByLocation + :: Map + (RepoType, String) + [(SourceRepoList, RepoType)] + reposByLocation = + Map.fromListWith + (++) + [ ((rtype, rloc), [(repo, vcsRepoType vcs)]) + | (repo, rloc, rtype, vcs) <- repos' + ] + + -- TODO: pass progPathExtra on to 'configureVCS' let _progPathExtra = fromNubList projectConfigProgPathExtra getConfiguredVCS <- delayInitSharedResources $ \repoType -> - let vcs = Map.findWithDefault (error $ "Unknown VCS: " ++ prettyShow repoType) repoType knownVCSs in - configureVCS verbosity {-progPathExtra-} vcs + let vcs = Map.findWithDefault (error $ "Unknown VCS: " ++ prettyShow repoType) repoType knownVCSs + in configureVCS verbosity {-progPathExtra-} vcs - concat <$> sequenceA - [ rerunIfChanged verbosity monitor repoGroup' $ do + concat + <$> sequenceA + [ rerunIfChanged verbosity monitor repoGroup' $ do vcs' <- getConfiguredVCS repoType syncRepoGroupAndReadSourcePackages vcs' pathStem repoGroup' - | repoGroup@((primaryRepo, repoType):_) <- Map.elems reposByLocation - , let repoGroup' = map fst repoGroup - pathStem = distDownloadSrcDirectory - localFileNameForRemoteRepo primaryRepo - monitor :: FileMonitor - [SourceRepoList] - [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] - monitor = newFileMonitor (pathStem <.> "cache") - ] - where - syncRepoGroupAndReadSourcePackages - :: VCS ConfiguredProgram - -> FilePath - -> [SourceRepoList] - -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] - syncRepoGroupAndReadSourcePackages vcs pathStem repoGroup = do - liftIO $ createDirectoryIfMissingVerbose verbosity False - distDownloadSrcDirectory + | repoGroup@((primaryRepo, repoType) : _) <- Map.elems reposByLocation + , let repoGroup' = map fst repoGroup + pathStem = + distDownloadSrcDirectory + localFileNameForRemoteRepo primaryRepo + monitor + :: FileMonitor + [SourceRepoList] + [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] + monitor = newFileMonitor (pathStem <.> "cache") + ] + where + syncRepoGroupAndReadSourcePackages + :: VCS ConfiguredProgram + -> FilePath + -> [SourceRepoList] + -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] + syncRepoGroupAndReadSourcePackages vcs pathStem repoGroup = do + liftIO $ + createDirectoryIfMissingVerbose + verbosity + False + distDownloadSrcDirectory -- For syncing we don't care about different 'SourceRepo' values that -- are just different subdirs in the same repo. - syncSourceRepos verbosity vcs + syncSourceRepos + verbosity + vcs [ (repo, repoPath) - | (repo, _, repoPath) <- repoGroupWithPaths ] + | (repo, _, repoPath) <- repoGroupWithPaths + ] -- Run post-checkout-command if it is specified for_ repoGroupWithPaths $ \(repo, _, repoPath) -> - for_ (nonEmpty (srpCommand repo)) $ \(cmd :| args) -> liftIO $ do - maybeExit $ rawSystemIOWithEnv verbosity cmd args (Just repoPath) Nothing Nothing Nothing Nothing + for_ (nonEmpty (srpCommand repo)) $ \(cmd :| args) -> liftIO $ do + maybeExit $ rawSystemIOWithEnv verbosity cmd args (Just repoPath) Nothing Nothing Nothing Nothing -- But for reading we go through each 'SourceRepo' including its subdir -- value and have to know which path each one ended up in. sequenceA [ readPackageFromSourceRepo repoWithSubdir repoPath | (_, reposWithSubdir, repoPath) <- repoGroupWithPaths - , repoWithSubdir <- NE.toList reposWithSubdir ] - where - -- So to do both things above, we pair them up here. - repoGroupWithPaths - :: [(SourceRepositoryPackage Proxy, NonEmpty (SourceRepositoryPackage Maybe), FilePath)] - repoGroupWithPaths = - zipWith (\(x, y) z -> (x,y,z)) - (mapGroup - [ (repo { srpSubdir = Proxy }, repo) - | repo <- foldMap (NE.toList . srpFanOut) repoGroup - ]) - repoPaths - - mapGroup :: Ord k => [(k, v)] -> [(k, NonEmpty v)] - mapGroup = Map.toList . Map.fromListWith (<>) . map (\(k, v) -> (k, pure v)) - - -- The repos in a group are given distinct names by simple enumeration - -- foo, foo-2, foo-3 etc - repoPaths :: [FilePath] - repoPaths = pathStem - : [ pathStem ++ "-" ++ show (i :: Int) | i <- [2..] ] - - readPackageFromSourceRepo + , repoWithSubdir <- NE.toList reposWithSubdir + ] + where + -- So to do both things above, we pair them up here. + repoGroupWithPaths + :: [(SourceRepositoryPackage Proxy, NonEmpty (SourceRepositoryPackage Maybe), FilePath)] + repoGroupWithPaths = + zipWith + (\(x, y) z -> (x, y, z)) + ( mapGroup + [ (repo{srpSubdir = Proxy}, repo) + | repo <- foldMap (NE.toList . srpFanOut) repoGroup + ] + ) + repoPaths + + mapGroup :: Ord k => [(k, v)] -> [(k, NonEmpty v)] + mapGroup = Map.toList . Map.fromListWith (<>) . map (\(k, v) -> (k, pure v)) + + -- The repos in a group are given distinct names by simple enumeration + -- foo, foo-2, foo-3 etc + repoPaths :: [FilePath] + repoPaths = + pathStem + : [pathStem ++ "-" ++ show (i :: Int) | i <- [2 ..]] + + readPackageFromSourceRepo :: SourceRepositoryPackage Maybe -> FilePath -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) - readPackageFromSourceRepo repo repoPath = do + readPackageFromSourceRepo repo repoPath = do let packageDir :: FilePath packageDir = maybe repoPath (repoPath ) (srpSubdir repo) entries <- liftIO $ getDirectoryContents packageDir - --TODO: dcoutts 2018-06-23: wrap exceptions + -- TODO: dcoutts 2018-06-23: wrap exceptions case filter (\e -> takeExtension e == ".cabal") entries of - [] -> liftIO $ throwIO $ NoCabalFileFound packageDir - (_:_:_) -> liftIO $ throwIO $ MultipleCabalFilesFound packageDir + [] -> liftIO $ throwIO $ NoCabalFileFound packageDir + (_ : _ : _) -> liftIO $ throwIO $ MultipleCabalFilesFound packageDir [cabalFileName] -> do let cabalFilePath = packageDir cabalFileName monitorFiles [monitorFileHashed cabalFilePath] @@ -1271,48 +1454,58 @@ syncAndReadSourcePackagesRemoteRepos verbosity let location = RemoteSourceRepoPackage repo tarballPath return $ mkSpecificSourcePackage location gpd - reportSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> Rebuild a - reportSourceRepoProblems = liftIO . die' verbosity . renderSourceRepoProblems - - renderSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> String - renderSourceRepoProblems = unlines . map show -- "TODO: the repo problems" + reportSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> Rebuild a + reportSourceRepoProblems = liftIO . die' verbosity . renderSourceRepoProblems + renderSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> String + renderSourceRepoProblems = unlines . map show -- "TODO: the repo problems" -- | Utility used by all the helpers of 'fetchAndReadSourcePackages' to make an -- appropriate @'PackageSpecifier' ('SourcePackage' (..))@ for a given package -- from a given location. --- -mkSpecificSourcePackage :: PackageLocation FilePath - -> GenericPackageDescription - -> PackageSpecifier (SourcePackage UnresolvedPkgLoc) +mkSpecificSourcePackage + :: PackageLocation FilePath + -> GenericPackageDescription + -> PackageSpecifier (SourcePackage UnresolvedPkgLoc) mkSpecificSourcePackage location pkg = - SpecificSourcePackage SourcePackage - { srcpkgPackageId = packageId pkg - , srcpkgDescription = pkg - , srcpkgSource = fmap Just location + SpecificSourcePackage + SourcePackage + { srcpkgPackageId = packageId pkg + , srcpkgDescription = pkg + , srcpkgSource = fmap Just location , srcpkgDescrOverride = Nothing } - -- | Errors reported upon failing to parse a @.cabal@ file. --- -data CabalFileParseError = CabalFileParseError - FilePath -- ^ @.cabal@ file path - BS.ByteString -- ^ @.cabal@ file contents - (NonEmpty PError) -- ^ errors - (Maybe Version) -- ^ We might discover the spec version the package needs - [PWarning] -- ^ warnings +data CabalFileParseError + = CabalFileParseError + FilePath + -- ^ @.cabal@ file path + BS.ByteString + -- ^ @.cabal@ file contents + (NonEmpty PError) + -- ^ errors + (Maybe Version) + -- ^ We might discover the spec version the package needs + [PWarning] + -- ^ warnings deriving (Typeable) -- | Manual instance which skips file contents instance Show CabalFileParseError where - showsPrec d (CabalFileParseError fp _ es mv ws) = showParen (d > 10) - $ showString "CabalFileParseError" - . showChar ' ' . showsPrec 11 fp - . showChar ' ' . showsPrec 11 ("" :: String) - . showChar ' ' . showsPrec 11 es - . showChar ' ' . showsPrec 11 mv - . showChar ' ' . showsPrec 11 ws + showsPrec d (CabalFileParseError fp _ es mv ws) = + showParen (d > 10) $ + showString "CabalFileParseError" + . showChar ' ' + . showsPrec 11 fp + . showChar ' ' + . showsPrec 11 ("" :: String) + . showChar ' ' + . showsPrec 11 es + . showChar ' ' + . showsPrec 11 mv + . showChar ' ' + . showsPrec 11 ws instance Exception CabalFileParseError #if MIN_VERSION_base(4,8,0) @@ -1322,127 +1515,130 @@ instance Exception CabalFileParseError renderCabalFileParseError :: CabalFileParseError -> String renderCabalFileParseError (CabalFileParseError filePath contents errors _ warnings) = - renderParseError filePath contents errors warnings + renderParseError filePath contents errors warnings -- | Wrapper for the @.cabal@ file parser. It reports warnings on higher -- verbosity levels and throws 'CabalFileParseError' on failure. --- -readSourcePackageCabalFile :: Verbosity - -> FilePath - -> BS.ByteString - -> IO GenericPackageDescription +readSourcePackageCabalFile + :: Verbosity + -> FilePath + -> BS.ByteString + -> IO GenericPackageDescription readSourcePackageCabalFile verbosity pkgfilename content = - case runParseResult (parseGenericPackageDescription content) of - (warnings, Right pkg) -> do - unless (null warnings) $ - info verbosity (formatWarnings warnings) - return pkg - - (warnings, Left (mspecVersion, errors)) -> - throwIO $ CabalFileParseError pkgfilename content errors mspecVersion warnings + case runParseResult (parseGenericPackageDescription content) of + (warnings, Right pkg) -> do + unless (null warnings) $ + info verbosity (formatWarnings warnings) + return pkg + (warnings, Left (mspecVersion, errors)) -> + throwIO $ CabalFileParseError pkgfilename content errors mspecVersion warnings where formatWarnings warnings = - "The package description file " ++ pkgfilename - ++ " has warnings: " - ++ unlines (map (showPWarning pkgfilename) warnings) - + "The package description file " + ++ pkgfilename + ++ " has warnings: " + ++ unlines (map (showPWarning pkgfilename) warnings) -- | When looking for a package's @.cabal@ file we can find none, or several, -- both of which are failures. --- data CabalFileSearchFailure - = NoCabalFileFound FilePath - | MultipleCabalFilesFound FilePath + = NoCabalFileFound FilePath + | MultipleCabalFilesFound FilePath deriving (Show, Typeable) instance Exception CabalFileSearchFailure - -- | Find the @.cabal@ file within a tarball file and return it by value. -- -- Can fail with a 'Tar.FormatError' or 'CabalFileSearchFailure' exception. --- extractTarballPackageCabalFile :: FilePath -> IO (FilePath, BS.ByteString) extractTarballPackageCabalFile tarballFile = - withBinaryFile tarballFile ReadMode $ \hnd -> do - content <- LBS.hGetContents hnd - case extractTarballPackageCabalFilePure tarballFile content of - Left (Left e) -> throwIO e - Left (Right e) -> throwIO e - Right (fileName, fileContent) -> - (,) fileName <$> evaluate (LBS.toStrict fileContent) - + withBinaryFile tarballFile ReadMode $ \hnd -> do + content <- LBS.hGetContents hnd + case extractTarballPackageCabalFilePure tarballFile content of + Left (Left e) -> throwIO e + Left (Right e) -> throwIO e + Right (fileName, fileContent) -> + (,) fileName <$> evaluate (LBS.toStrict fileContent) -- | Scan through a tar file stream and collect the @.cabal@ file, or fail. --- -extractTarballPackageCabalFilePure :: FilePath - -> LBS.ByteString - -> Either (Either Tar.FormatError - CabalFileSearchFailure) - (FilePath, LBS.ByteString) +extractTarballPackageCabalFilePure + :: FilePath + -> LBS.ByteString + -> Either + ( Either + Tar.FormatError + CabalFileSearchFailure + ) + (FilePath, LBS.ByteString) extractTarballPackageCabalFilePure tarballFile = - check + check . accumEntryMap . Tar.filterEntries isCabalFile . Tar.read . GZipUtils.maybeDecompress where - accumEntryMap = Tar.foldlEntries - (\m e -> Map.insert (Tar.entryTarPath e) e m) - Map.empty + accumEntryMap = + Tar.foldlEntries + (\m e -> Map.insert (Tar.entryTarPath e) e m) + Map.empty check (Left (e, _m)) = Left (Left e) check (Right m) = case Map.elems m of - [] -> Left (Right $ NoCabalFileFound tarballFile) - [file] -> case Tar.entryContent file of - Tar.NormalFile content _ -> Right (Tar.entryPath file, content) - _ -> Left (Right $ NoCabalFileFound tarballFile) - _files -> Left (Right $ MultipleCabalFilesFound tarballFile) + [] -> Left (Right $ NoCabalFileFound tarballFile) + [file] -> case Tar.entryContent file of + Tar.NormalFile content _ -> Right (Tar.entryPath file, content) + _ -> Left (Right $ NoCabalFileFound tarballFile) + _files -> Left (Right $ MultipleCabalFilesFound tarballFile) isCabalFile e = case splitPath (Tar.entryPath e) of - [ _dir, file] -> takeExtension file == ".cabal" + [_dir, file] -> takeExtension file == ".cabal" [".", _dir, file] -> takeExtension file == ".cabal" - _ -> False - + _ -> False -- | The name to use for a local file for a remote tarball 'SourceRepo'. -- This is deterministic based on the remote tarball URI, and is intended -- to produce non-clashing file names for different tarballs. --- localFileNameForRemoteTarball :: URI -> FilePath localFileNameForRemoteTarball uri = - mangleName uri - ++ "-" ++ showHex locationHash "" + mangleName uri + ++ "-" + ++ showHex locationHash "" where - mangleName = truncateString 10 . dropExtension . dropExtension - . takeFileName . dropTrailingPathSeparator . uriPath + mangleName = + truncateString 10 + . dropExtension + . dropExtension + . takeFileName + . dropTrailingPathSeparator + . uriPath locationHash :: Word locationHash = fromIntegral (Hashable.hash (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 "" +localFileNameForRemoteRepo SourceRepositoryPackage{srpType, srpLocation} = + mangleName srpLocation ++ "-" ++ showHex locationHash "" where - mangleName = truncateString 10 . dropExtension - . takeFileName . dropTrailingPathSeparator + mangleName = + truncateString 10 + . dropExtension + . takeFileName + . dropTrailingPathSeparator -- just the parts that make up the "identity" of the repo locationHash :: Word locationHash = fromIntegral (Hashable.hash (show srpType, srpLocation)) - -- | Truncate a string, with a visual indication that it is truncated. truncateString :: Int -> String -> String -truncateString n s | length s <= n = s - | otherwise = take (n-1) s ++ "_" - +truncateString n s + | length s <= n = s + | otherwise = take (n - 1) s ++ "_" -- TODO: add something like this, here or in the project planning -- Based on the package location, which packages will be built inplace in the @@ -1451,13 +1647,12 @@ truncateString n s | length s <= n = s -- -- packageIsLocalToProject :: ProjectPackageLocation -> Bool - --------------------------------------------- -- Checking configuration sanity -- data BadPerPackageCompilerPaths - = BadPerPackageCompilerPaths [(PackageName, String)] + = BadPerPackageCompilerPaths [(PackageName, String)] #if MIN_VERSION_base(4,8,0) deriving (Show, Typeable) #else @@ -1467,23 +1662,28 @@ instance Show BadPerPackageCompilerPaths where show = renderBadPerPackageCompilerPaths #endif +{- FOURMOLU_DISABLE -} instance Exception BadPerPackageCompilerPaths where #if MIN_VERSION_base(4,8,0) displayException = renderBadPerPackageCompilerPaths #endif ---TODO: [nice to have] custom exception subclass for Doc rendering, colour etc +{- FOURMOLU_ENABLE -} +-- TODO: [nice to have] custom exception subclass for Doc rendering, colour etc renderBadPerPackageCompilerPaths :: BadPerPackageCompilerPaths -> String renderBadPerPackageCompilerPaths (BadPerPackageCompilerPaths ((pkgname, progname) : _)) = "The path to the compiler program (or programs used by the compiler) " - ++ "cannot be specified on a per-package basis in the cabal.project file " - ++ "(i.e. setting the '" ++ progname ++ "-location' for package '" - ++ prettyShow pkgname ++ "'). All packages have to use the same compiler, so " - ++ "specify the path in a global 'program-locations' section." - --TODO: [nice to have] better format control so we can pretty-print the - -- offending part of the project file. Currently the line wrapping breaks any - -- formatting. + ++ "cannot be specified on a per-package basis in the cabal.project file " + ++ "(i.e. setting the '" + ++ progname + ++ "-location' for package '" + ++ prettyShow pkgname + ++ "'). All packages have to use the same compiler, so " + ++ "specify the path in a global 'program-locations' section." +-- TODO: [nice to have] better format control so we can pretty-print the +-- offending part of the project file. Currently the line wrapping breaks any +-- formatting. renderBadPerPackageCompilerPaths _ = error "renderBadPerPackageCompilerPaths" -- | The project configuration is not allowed to specify program locations for @@ -1494,15 +1694,16 @@ renderBadPerPackageCompilerPaths _ = error "renderBadPerPackageCompilerPaths" -- in principle is not until we've configured the compiler. -- -- Throws 'BadPerPackageCompilerPaths' --- -checkBadPerPackageCompilerPaths :: [ConfiguredProgram] - -> Map PackageName PackageConfig - -> IO () +checkBadPerPackageCompilerPaths + :: [ConfiguredProgram] + -> Map PackageName PackageConfig + -> IO () checkBadPerPackageCompilerPaths compilerPrograms packagesConfig = - case [ (pkgname, progname) - | let compProgNames = Set.fromList (map programId compilerPrograms) - , (pkgname, pkgconf) <- Map.toList packagesConfig - , progname <- Map.keys (getMapLast (packageConfigProgramPaths pkgconf)) - , progname `Set.member` compProgNames ] of - [] -> return () - ps -> throwIO (BadPerPackageCompilerPaths ps) + case [ (pkgname, progname) + | let compProgNames = Set.fromList (map programId compilerPrograms) + , (pkgname, pkgconf) <- Map.toList packagesConfig + , progname <- Map.keys (getMapLast (packageConfigProgramPaths pkgconf)) + , progname `Set.member` compProgNames + ] of + [] -> return () + ps -> throwIO (BadPerPackageCompilerPaths ps) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index d86998f1fad..57a21a7c0d0 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -1,127 +1,189 @@ -{-# LANGUAGE RecordWildCards, NamedFieldPuns, DeriveGeneric, ConstraintKinds, FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} -- | Project configuration, implementation in terms of legacy types. --- -module Distribution.Client.ProjectConfig.Legacy ( - - -- Project config skeletons - ProjectConfigSkeleton, - parseProjectSkeleton, - instantiateProjectConfigSkeletonFetchingCompiler, - instantiateProjectConfigSkeletonWithCompiler, - singletonProjectConfigSkeleton, - projectSkeletonImports, +module Distribution.Client.ProjectConfig.Legacy + ( -- Project config skeletons + ProjectConfigSkeleton + , parseProjectSkeleton + , instantiateProjectConfigSkeletonFetchingCompiler + , instantiateProjectConfigSkeletonWithCompiler + , singletonProjectConfigSkeleton + , projectSkeletonImports -- * Project config in terms of legacy types - LegacyProjectConfig, - parseLegacyProjectConfig, - showLegacyProjectConfig, + , LegacyProjectConfig + , parseLegacyProjectConfig + , showLegacyProjectConfig -- * Conversion to and from legacy config types - commandLineFlagsToProjectConfig, - convertLegacyProjectConfig, - convertLegacyGlobalConfig, - convertToLegacyProjectConfig, + , commandLineFlagsToProjectConfig + , convertLegacyProjectConfig + , convertLegacyGlobalConfig + , convertToLegacyProjectConfig -- * Internals, just for tests - parsePackageLocationTokenQ, - renderPackageLocationToken + , parsePackageLocationTokenQ + , renderPackageLocationToken ) where import Distribution.Client.Compat.Prelude -import Distribution.Types.Flag (parsecFlagAssignment, FlagName) +import Distribution.Types.Flag (FlagName, parsecFlagAssignment) import Distribution.Client.ProjectConfig.Types +import Distribution.Client.Types.AllowNewer (AllowNewer (..), AllowOlder (..)) +import Distribution.Client.Types.Repo (LocalRepo (..), RemoteRepo (..), emptyRemoteRepo) import Distribution.Client.Types.RepoName (RepoName (..), unRepoName) -import Distribution.Client.Types.Repo (RemoteRepo(..), LocalRepo (..), emptyRemoteRepo) -import Distribution.Client.Types.AllowNewer (AllowNewer(..), AllowOlder(..)) -import Distribution.Client.Types.SourceRepo (sourceRepositoryPackageGrammar, SourceRepoList) +import Distribution.Client.Types.SourceRepo (SourceRepoList, sourceRepositoryPackageGrammar) import Distribution.Client.Config - ( SavedConfig(..), remoteRepoFields, postProcessRepo ) + ( SavedConfig (..) + , postProcessRepo + , remoteRepoFields + ) import Distribution.Client.CmdInstall.ClientInstallFlags - ( ClientInstallFlags(..), defaultClientInstallFlags - , clientInstallOptions ) + ( ClientInstallFlags (..) + , clientInstallOptions + , defaultClientInstallFlags + ) -import Distribution.Compat.Lens (view, toListOf) +import Distribution.Compat.Lens (toListOf, view) import Distribution.Solver.Types.ConstraintSource +import Distribution.Client.NixStyleOptions (NixStyleFlags (..)) +import Distribution.Client.ProjectFlags (ProjectFlags (..), defaultProjectFlags, projectFlagsOptions) +import Distribution.Client.Setup + ( ConfigExFlags (..) + , GlobalFlags (..) + , InstallFlags (..) + , configureExOptions + , defaultConfigExFlags + , defaultInstallFlags + , globalCommand + , installOptions + ) import Distribution.FieldGrammar import Distribution.Package -import Distribution.Types.SourceRepo (RepoType) -import Distribution.Types.CondTree - ( CondTree (..), CondBranch (..), mapTreeConds, traverseCondTreeC, traverseCondTreeV, ignoreConditions ) import Distribution.PackageDescription - ( dispFlagAssignment, Condition (..), ConfVar (..), FlagAssignment ) + ( Condition (..) + , ConfVar (..) + , FlagAssignment + , dispFlagAssignment + ) import Distribution.PackageDescription.Configuration (simplifyWithSysParams) import Distribution.Simple.Compiler - ( OptimisationLevel(..), DebugInfoLevel(..), CompilerInfo(..) ) -import Distribution.Simple.InstallDirs ( CopyDest (NoCopyDest) ) -import Distribution.Simple.Setup - ( Flag(..), toFlag, fromFlagOrDefault - , ConfigFlags(..), configureOptions - , HaddockFlags(..), haddockOptions, defaultHaddockFlags - , TestFlags(..), testOptions', defaultTestFlags - , BenchmarkFlags(..), benchmarkOptions', defaultBenchmarkFlags - , programDbPaths', splitArgs, DumpBuildInfo (NoDumpBuildInfo, DumpBuildInfo) - , readPackageDb, showPackageDb, installDirsOptions - ) -import Distribution.Client.NixStyleOptions (NixStyleFlags (..)) -import Distribution.Client.ProjectFlags (ProjectFlags (..), projectFlagsOptions, defaultProjectFlags) -import Distribution.Client.Setup - ( GlobalFlags(..), globalCommand - , ConfigExFlags(..), configureExOptions, defaultConfigExFlags - , InstallFlags(..), installOptions, defaultInstallFlags ) + ( CompilerInfo (..) + , DebugInfoLevel (..) + , OptimisationLevel (..) + ) +import Distribution.Simple.InstallDirs (CopyDest (NoCopyDest)) +import Distribution.Simple.LocalBuildInfo + ( fromPathTemplate + , toPathTemplate + ) import Distribution.Simple.Program - ( programName, knownPrograms ) + ( knownPrograms + , programName + ) import Distribution.Simple.Program.Db - ( ProgramDb, defaultProgramDb ) + ( ProgramDb + , defaultProgramDb + ) +import Distribution.Simple.Setup + ( BenchmarkFlags (..) + , ConfigFlags (..) + , DumpBuildInfo (DumpBuildInfo, NoDumpBuildInfo) + , Flag (..) + , HaddockFlags (..) + , TestFlags (..) + , benchmarkOptions' + , configureOptions + , defaultBenchmarkFlags + , defaultHaddockFlags + , defaultTestFlags + , fromFlagOrDefault + , haddockOptions + , installDirsOptions + , programDbPaths' + , readPackageDb + , showPackageDb + , splitArgs + , testOptions' + , toFlag + ) import Distribution.Simple.Utils - ( lowercase ) + ( lowercase + ) +import Distribution.Types.CondTree + ( CondBranch (..) + , CondTree (..) + , ignoreConditions + , mapTreeConds + , traverseCondTreeC + , traverseCondTreeV + ) +import Distribution.Types.SourceRepo (RepoType) import Distribution.Utils.NubList - ( toNubList, fromNubList, overNubList ) -import Distribution.Simple.LocalBuildInfo - ( toPathTemplate, fromPathTemplate ) + ( fromNubList + , overNubList + , toNubList + ) -import qualified Distribution.Deprecated.ReadP as Parse -import Distribution.Deprecated.ReadP - ( ReadP, (+++) ) -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint - ( Doc, ($+$) ) -import qualified Distribution.Deprecated.ParseUtils as ParseUtils -import Distribution.Deprecated.ParseUtils - ( ParseResult(..), PError(..), syntaxError, PWarning(..) - , commaNewLineListFieldParsec, newLineListField, parseTokenQ - , parseHaskellString, showToken - , simpleFieldParsec, parseFail - ) import Distribution.Client.ParseUtils +import Distribution.Deprecated.ParseUtils + ( PError (..) + , PWarning (..) + , ParseResult (..) + , commaNewLineListFieldParsec + , newLineListField + , parseFail + , parseHaskellString + , parseTokenQ + , showToken + , simpleFieldParsec + , syntaxError + ) +import qualified Distribution.Deprecated.ParseUtils as ParseUtils +import Distribution.Deprecated.ReadP + ( ReadP + , (+++) + ) +import qualified Distribution.Deprecated.ReadP as Parse +import Distribution.Parsec (ParsecParser, parsecToken) import Distribution.Simple.Command - ( CommandUI(commandOptions), ShowOrParseArgs(..) - , OptionField(..), option, reqArg' ) + ( CommandUI (commandOptions) + , OptionField (..) + , ShowOrParseArgs (..) + , option + , reqArg' + ) +import Distribution.System (Arch, OS) import Distribution.Types.PackageVersionConstraint - ( PackageVersionConstraint ) -import Distribution.Parsec (ParsecParser, parsecToken) -import Distribution.System (OS, Arch) + ( PackageVersionConstraint + ) +import Text.PrettyPrint + ( Doc + , ($+$) + ) +import qualified Text.PrettyPrint as Disp +import qualified Data.ByteString.Char8 as BS import qualified Data.Map as Map import qualified Data.Set as Set -import qualified Data.ByteString.Char8 as BS import Network.URI (URI (..), parseURI) import Distribution.Fields.ConfVar (parseConditionConfVarFromClause) import Distribution.Client.HttpUtils -import System.FilePath ((), isPathSeparator, makeValid, isAbsolute, takeDirectory) import System.Directory (createDirectoryIfMissing) - - - +import System.FilePath (isAbsolute, isPathSeparator, makeValid, takeDirectory, ()) ------------------------------------------------------------------ -- Handle extended project config files with conditionals and imports. @@ -130,35 +192,35 @@ import System.Directory (createDirectoryIfMissing) -- | ProjectConfigSkeleton is a tree of conditional blocks and imports wrapping a config. It can be finalized by providing the conditional resolution info -- and then resolving and downloading the imports type ProjectConfigSkeleton = CondTree ConfVar [ProjectConfigImport] ProjectConfig -type ProjectConfigImport = String +type ProjectConfigImport = String singletonProjectConfigSkeleton :: ProjectConfig -> ProjectConfigSkeleton singletonProjectConfigSkeleton x = CondNode x mempty mempty -instantiateProjectConfigSkeletonFetchingCompiler :: Monad m => m (OS, Arch, CompilerInfo) -> FlagAssignment -> ProjectConfigSkeleton -> m ProjectConfig +instantiateProjectConfigSkeletonFetchingCompiler :: Monad m => m (OS, Arch, CompilerInfo) -> FlagAssignment -> ProjectConfigSkeleton -> m ProjectConfig instantiateProjectConfigSkeletonFetchingCompiler fetch flags skel - | null (toListOf traverseCondTreeV skel) = pure $ fst (ignoreConditions skel) - | otherwise = do - (os, arch, impl) <- fetch - pure $ instantiateProjectConfigSkeletonWithCompiler os arch impl flags skel - + | null (toListOf traverseCondTreeV skel) = pure $ fst (ignoreConditions skel) + | otherwise = do + (os, arch, impl) <- fetch + pure $ instantiateProjectConfigSkeletonWithCompiler os arch impl flags skel instantiateProjectConfigSkeletonWithCompiler :: OS -> Arch -> CompilerInfo -> FlagAssignment -> ProjectConfigSkeleton -> ProjectConfig instantiateProjectConfigSkeletonWithCompiler os arch impl _flags skel = go $ mapTreeConds (fst . simplifyWithSysParams os arch impl) skel - where - go :: CondTree - FlagName - [ProjectConfigImport] - ProjectConfig - -> ProjectConfig - go (CondNode l _imps ts) = - let branches = concatMap processBranch ts - in l <> mconcat branches - processBranch (CondBranch cnd t mf) = case cnd of - (Lit True) -> [go t] - (Lit False) -> maybe ([]) ((:[]) . go) mf - _ -> error $ "unable to process condition: " ++ show cnd -- TODO it would be nice if there were a pretty printer + where + go + :: CondTree + FlagName + [ProjectConfigImport] + ProjectConfig + -> ProjectConfig + go (CondNode l _imps ts) = + let branches = concatMap processBranch ts + in l <> mconcat branches + processBranch (CondBranch cnd t mf) = case cnd of + (Lit True) -> [go t] + (Lit False) -> maybe ([]) ((: []) . go) mf + _ -> error $ "unable to process condition: " ++ show cnd -- TODO it would be nice if there were a pretty printer projectSkeletonImports :: ProjectConfigSkeleton -> [ProjectConfigImport] projectSkeletonImports = view traverseCondTreeC @@ -167,77 +229,82 @@ parseProjectSkeleton :: FilePath -> HttpTransport -> Verbosity -> [ProjectConfig parseProjectSkeleton cacheDir httpTransport verbosity seenImports source bs = (sanityWalkPCS False =<<) <$> liftPR (go []) (ParseUtils.readFields bs) where go :: [ParseUtils.Field] -> [ParseUtils.Field] -> IO (ParseResult ProjectConfigSkeleton) - go acc (x:xs) = case x of - (ParseUtils.F l "import" importLoc) -> - if importLoc `elem` seenImports - then pure . parseFail $ ParseUtils.FromString ("cyclical import of " ++ importLoc) (Just l) - else do - let fs = fmap (\z -> CondNode z [importLoc] mempty) $ fieldsToConfig (reverse acc) - res <- parseProjectSkeleton cacheDir httpTransport verbosity (importLoc : seenImports) importLoc =<< fetchImportConfig importLoc - rest <- go [] xs - pure . fmap mconcat . sequence $ [fs, res, rest] - (ParseUtils.Section l "if" p xs') -> do - subpcs <- go [] xs' - let fs = fmap singletonProjectConfigSkeleton $ fieldsToConfig (reverse acc) - (elseClauses, rest) <- parseElseClauses xs - let condNode = (\c pcs e -> CondNode mempty mempty [CondBranch c pcs e]) <$> - -- we rewrap as as a section so the readFields lexer of the conditional parser doesn't get confused - adaptParseError l (parseConditionConfVarFromClause . BS.pack $ "if(" <> p <> ")") <*> - subpcs <*> - elseClauses - pure . fmap mconcat . sequence $ [fs, condNode, rest] - _ -> go (x:acc) xs + go acc (x : xs) = case x of + (ParseUtils.F l "import" importLoc) -> + if importLoc `elem` seenImports + then pure . parseFail $ ParseUtils.FromString ("cyclical import of " ++ importLoc) (Just l) + else do + let fs = fmap (\z -> CondNode z [importLoc] mempty) $ fieldsToConfig (reverse acc) + res <- parseProjectSkeleton cacheDir httpTransport verbosity (importLoc : seenImports) importLoc =<< fetchImportConfig importLoc + rest <- go [] xs + pure . fmap mconcat . sequence $ [fs, res, rest] + (ParseUtils.Section l "if" p xs') -> do + subpcs <- go [] xs' + let fs = fmap singletonProjectConfigSkeleton $ fieldsToConfig (reverse acc) + (elseClauses, rest) <- parseElseClauses xs + let condNode = + (\c pcs e -> CondNode mempty mempty [CondBranch c pcs e]) + <$> + -- we rewrap as as a section so the readFields lexer of the conditional parser doesn't get confused + adaptParseError l (parseConditionConfVarFromClause . BS.pack $ "if(" <> p <> ")") + <*> subpcs + <*> elseClauses + pure . fmap mconcat . sequence $ [fs, condNode, rest] + _ -> go (x : acc) xs go acc [] = pure . fmap singletonProjectConfigSkeleton . fieldsToConfig $ reverse acc parseElseClauses :: [ParseUtils.Field] -> IO (ParseResult (Maybe ProjectConfigSkeleton), ParseResult ProjectConfigSkeleton) parseElseClauses x = case x of - (ParseUtils.Section _l "else" _p xs':xs) -> do - subpcs <- go [] xs' - rest <- go [] xs - pure (Just <$> subpcs, rest) - (ParseUtils.Section l "elif" p xs':xs) -> do - subpcs <- go [] xs' - (elseClauses, rest) <- parseElseClauses xs - let condNode = (\c pcs e -> CondNode mempty mempty [CondBranch c pcs e]) <$> - adaptParseError l (parseConditionConfVarFromClause . BS.pack $ "else("<> p <> ")") <*> - subpcs <*> - elseClauses - pure (Just <$> condNode, rest) - _ -> (\r -> (pure Nothing,r)) <$> go [] x + (ParseUtils.Section _l "else" _p xs' : xs) -> do + subpcs <- go [] xs' + rest <- go [] xs + pure (Just <$> subpcs, rest) + (ParseUtils.Section l "elif" p xs' : xs) -> do + subpcs <- go [] xs' + (elseClauses, rest) <- parseElseClauses xs + let condNode = + (\c pcs e -> CondNode mempty mempty [CondBranch c pcs e]) + <$> adaptParseError l (parseConditionConfVarFromClause . BS.pack $ "else(" <> p <> ")") + <*> subpcs + <*> elseClauses + pure (Just <$> condNode, rest) + _ -> (\r -> (pure Nothing, r)) <$> go [] x fieldsToConfig xs = fmap (addProvenance . convertLegacyProjectConfig) $ parseLegacyProjectConfigFields source xs - addProvenance x = x {projectConfigProvenance = Set.singleton (Explicit source)} + addProvenance x = x{projectConfigProvenance = Set.singleton (Explicit source)} adaptParseError _ (Right x) = pure x adaptParseError l (Left e) = parseFail $ ParseUtils.FromString (show e) (Just l) liftPR :: (a -> IO (ParseResult b)) -> ParseResult a -> IO (ParseResult b) liftPR f (ParseOk ws x) = addWarnings <$> f x - where addWarnings (ParseOk ws' x') = ParseOk (ws' ++ ws) x' - addWarnings x' = x' + where + addWarnings (ParseOk ws' x') = ParseOk (ws' ++ ws) x' + addWarnings x' = x' liftPR _ (ParseFailed e) = pure $ ParseFailed e fetchImportConfig :: ProjectConfigImport -> IO BS.ByteString fetchImportConfig pci = case parseURI pci of - Just uri -> do - let fp = cacheDir map (\x -> if isPathSeparator x then '_' else x) (makeValid $ show uri) - createDirectoryIfMissing True cacheDir - _ <- downloadURI httpTransport verbosity uri fp - BS.readFile fp - Nothing -> BS.readFile $ - if isAbsolute pci then pci else takeDirectory source pci + Just uri -> do + let fp = cacheDir map (\x -> if isPathSeparator x then '_' else x) (makeValid $ show uri) + createDirectoryIfMissing True cacheDir + _ <- downloadURI httpTransport verbosity uri fp + BS.readFile fp + Nothing -> + BS.readFile $ + if isAbsolute pci then pci else takeDirectory source pci modifiesCompiler :: ProjectConfig -> Bool modifiesCompiler pc = isSet projectConfigHcFlavor || isSet projectConfigHcPath || isSet projectConfigHcPkg where - isSet f = f (projectConfigShared pc) /= NoFlag + isSet f = f (projectConfigShared pc) /= NoFlag sanityWalkPCS :: Bool -> ProjectConfigSkeleton -> ParseResult ProjectConfigSkeleton sanityWalkPCS underConditional t@(CondNode d _c comps) - | underConditional && modifiesCompiler d = parseFail $ ParseUtils.FromString "Cannot set compiler in a conditional clause of a cabal project file" Nothing - | otherwise = mapM_ sanityWalkBranch comps >> pure t + | underConditional && modifiesCompiler d = parseFail $ ParseUtils.FromString "Cannot set compiler in a conditional clause of a cabal project file" Nothing + | otherwise = mapM_ sanityWalkBranch comps >> pure t - sanityWalkBranch:: CondBranch ConfVar [ProjectConfigImport] ProjectConfig -> ParseResult () + sanityWalkBranch :: CondBranch ConfVar [ProjectConfigImport] ProjectConfig -> ParseResult () sanityWalkBranch (CondBranch _c t f) = traverse (sanityWalkPCS True) f >> sanityWalkPCS True t >> pure () ------------------------------------------------------------------ @@ -252,58 +319,58 @@ parseProjectSkeleton cacheDir httpTransport verbosity seenImports source bs = (s -- -- Ultimately if\/when this project-based approach becomes the default then we -- can redefine the parsers directly for the new types. --- -data LegacyProjectConfig = LegacyProjectConfig { - legacyPackages :: [String], - legacyPackagesOptional :: [String], - legacyPackagesRepo :: [SourceRepoList], - legacyPackagesNamed :: [PackageVersionConstraint], - - legacySharedConfig :: LegacySharedConfig, - legacyAllConfig :: LegacyPackageConfig, - legacyLocalConfig :: LegacyPackageConfig, - legacySpecificConfig :: MapMappend PackageName LegacyPackageConfig - } deriving (Show, Generic) +data LegacyProjectConfig = LegacyProjectConfig + { legacyPackages :: [String] + , legacyPackagesOptional :: [String] + , legacyPackagesRepo :: [SourceRepoList] + , legacyPackagesNamed :: [PackageVersionConstraint] + , legacySharedConfig :: LegacySharedConfig + , legacyAllConfig :: LegacyPackageConfig + , legacyLocalConfig :: LegacyPackageConfig + , legacySpecificConfig :: MapMappend PackageName LegacyPackageConfig + } + deriving (Show, Generic) instance Monoid LegacyProjectConfig where - mempty = gmempty + mempty = gmempty mappend = (<>) instance Semigroup LegacyProjectConfig where (<>) = gmappend -data LegacyPackageConfig = LegacyPackageConfig { - legacyConfigureFlags :: ConfigFlags, - legacyInstallPkgFlags :: InstallFlags, - legacyHaddockFlags :: HaddockFlags, - legacyTestFlags :: TestFlags, - legacyBenchmarkFlags :: BenchmarkFlags - } deriving (Show, Generic) +data LegacyPackageConfig = LegacyPackageConfig + { legacyConfigureFlags :: ConfigFlags + , legacyInstallPkgFlags :: InstallFlags + , legacyHaddockFlags :: HaddockFlags + , legacyTestFlags :: TestFlags + , legacyBenchmarkFlags :: BenchmarkFlags + } + deriving (Show, Generic) instance Monoid LegacyPackageConfig where - mempty = gmempty + mempty = gmempty mappend = (<>) instance Semigroup LegacyPackageConfig where (<>) = gmappend -data LegacySharedConfig = LegacySharedConfig { - legacyGlobalFlags :: GlobalFlags, - legacyConfigureShFlags :: ConfigFlags, - legacyConfigureExFlags :: ConfigExFlags, - legacyInstallFlags :: InstallFlags, - legacyClientInstallFlags:: ClientInstallFlags, - legacyProjectFlags :: ProjectFlags - } deriving (Show, Generic) +data LegacySharedConfig = LegacySharedConfig + { legacyGlobalFlags :: GlobalFlags + , legacyConfigureShFlags :: ConfigFlags + , legacyConfigureExFlags :: ConfigExFlags + , legacyInstallFlags :: InstallFlags + , legacyClientInstallFlags :: ClientInstallFlags + , legacyProjectFlags :: ProjectFlags + } + deriving (Show, Generic) instance Monoid LegacySharedConfig where - mempty = gmempty + mempty = gmempty mappend = (<>) instance Semigroup LegacySharedConfig where (<>) = gmappend - ------------------------------------------------------------------ -- Converting from and to the legacy types -- @@ -314,57 +381,74 @@ instance Semigroup LegacySharedConfig where -- -- At the moment this uses the legacy command line flag types. See -- 'LegacyProjectConfig' for an explanation. --- -commandLineFlagsToProjectConfig :: GlobalFlags - -> NixStyleFlags a - -> ClientInstallFlags - -> ProjectConfig -commandLineFlagsToProjectConfig globalFlags NixStyleFlags {..} clientInstallFlags = - mempty { - projectConfigBuildOnly = convertLegacyBuildOnlyFlags - globalFlags configFlags - installFlags clientInstallFlags - haddockFlags testFlags benchmarkFlags, - projectConfigShared = convertLegacyAllPackageFlags - globalFlags configFlags - configExFlags installFlags projectFlags, - projectConfigLocalPackages = localConfig, - projectConfigAllPackages = allConfig +commandLineFlagsToProjectConfig + :: GlobalFlags + -> NixStyleFlags a + -> ClientInstallFlags + -> ProjectConfig +commandLineFlagsToProjectConfig globalFlags NixStyleFlags{..} clientInstallFlags = + mempty + { projectConfigBuildOnly = + convertLegacyBuildOnlyFlags + globalFlags + configFlags + installFlags + clientInstallFlags + haddockFlags + testFlags + benchmarkFlags + , projectConfigShared = + convertLegacyAllPackageFlags + globalFlags + configFlags + configExFlags + installFlags + projectFlags + , projectConfigLocalPackages = localConfig + , projectConfigAllPackages = allConfig } - where (localConfig, allConfig) = splitConfig - (convertLegacyPerPackageFlags - configFlags installFlags - haddockFlags testFlags benchmarkFlags) - -- split the package config (from command line arguments) into - -- those applied to all packages and those to local only. - -- - -- for now we will just copy over the ProgramPaths/Extra into - -- the AllPackages. The LocalPackages do not inherit them from - -- AllPackages, and as such need to retain them. - -- - -- The general decision rule for what to put into allConfig - -- into localConfig is the following: - -- - -- - anything that is host/toolchain/env specific should be applied - -- to all packages, as packagesets have to be host/toolchain/env - -- consistent. - -- - anything else should be in the local config and could potentially - -- be lifted into all-packages vial the `package *` cabal.project - -- section. - -- - splitConfig :: PackageConfig -> (PackageConfig, PackageConfig) - splitConfig pc = (pc - , mempty { packageConfigProgramPaths = packageConfigProgramPaths pc - , packageConfigProgramPathExtra = packageConfigProgramPathExtra pc - - -- Some flags to haddock should be passed to dependencies - , packageConfigDocumentation = packageConfigDocumentation pc - , packageConfigHaddockHoogle = packageConfigHaddockHoogle pc - , packageConfigHaddockHtml = packageConfigHaddockHtml pc - , packageConfigHaddockInternal = packageConfigHaddockInternal pc - , packageConfigHaddockQuickJump = packageConfigHaddockQuickJump pc - , packageConfigHaddockLinkedSource = packageConfigHaddockLinkedSource pc - }) + where + (localConfig, allConfig) = + splitConfig + ( convertLegacyPerPackageFlags + configFlags + installFlags + haddockFlags + testFlags + benchmarkFlags + ) + -- split the package config (from command line arguments) into + -- those applied to all packages and those to local only. + -- + -- for now we will just copy over the ProgramPaths/Extra into + -- the AllPackages. The LocalPackages do not inherit them from + -- AllPackages, and as such need to retain them. + -- + -- The general decision rule for what to put into allConfig + -- into localConfig is the following: + -- + -- - anything that is host/toolchain/env specific should be applied + -- to all packages, as packagesets have to be host/toolchain/env + -- consistent. + -- - anything else should be in the local config and could potentially + -- be lifted into all-packages vial the `package *` cabal.project + -- section. + -- + splitConfig :: PackageConfig -> (PackageConfig, PackageConfig) + splitConfig pc = + ( pc + , mempty + { packageConfigProgramPaths = packageConfigProgramPaths pc + , packageConfigProgramPathExtra = packageConfigProgramPathExtra pc + , -- Some flags to haddock should be passed to dependencies + packageConfigDocumentation = packageConfigDocumentation pc + , packageConfigHaddockHoogle = packageConfigHaddockHoogle pc + , packageConfigHaddockHtml = packageConfigHaddockHtml pc + , packageConfigHaddockInternal = packageConfigHaddockInternal pc + , packageConfigHaddockQuickJump = packageConfigHaddockQuickJump pc + , packageConfigHaddockLinkedSource = packageConfigHaddockLinkedSource pc + } + ) -- | Convert from the types currently used for the user-wide Cabal config -- file into the 'ProjectConfig' type. @@ -373,640 +457,705 @@ commandLineFlagsToProjectConfig globalFlags NixStyleFlags {..} clientInstallFlag -- config. In particular it does not include packages that are in the project, -- and it also doesn't support package-specific configuration (only -- configuration that applies to all packages). --- convertLegacyGlobalConfig :: SavedConfig -> ProjectConfig convertLegacyGlobalConfig - SavedConfig { - savedGlobalFlags = globalFlags, - savedInstallFlags = installFlags, - savedClientInstallFlags= clientInstallFlags, - savedConfigureFlags = configFlags, - savedConfigureExFlags = configExFlags, - savedUserInstallDirs = _, - savedGlobalInstallDirs = _, - savedUploadFlags = _, - savedReportFlags = _, - savedHaddockFlags = haddockFlags, - savedTestFlags = testFlags, - savedBenchmarkFlags = benchmarkFlags, - savedProjectFlags = projectFlags + SavedConfig + { savedGlobalFlags = globalFlags + , savedInstallFlags = installFlags + , savedClientInstallFlags = clientInstallFlags + , savedConfigureFlags = configFlags + , savedConfigureExFlags = configExFlags + , savedUserInstallDirs = _ + , savedGlobalInstallDirs = _ + , savedUploadFlags = _ + , savedReportFlags = _ + , savedHaddockFlags = haddockFlags + , savedTestFlags = testFlags + , savedBenchmarkFlags = benchmarkFlags + , savedProjectFlags = projectFlags } = - mempty { - projectConfigBuildOnly = configBuildOnly, - projectConfigShared = configShared, - projectConfigAllPackages = configAllPackages - } - where - --TODO: [code cleanup] eliminate use of default*Flags here and specify the - -- defaults in the various resolve functions in terms of the new types. - configExFlags' = defaultConfigExFlags <> configExFlags - installFlags' = defaultInstallFlags <> installFlags - clientInstallFlags' = defaultClientInstallFlags <> clientInstallFlags - haddockFlags' = defaultHaddockFlags <> haddockFlags - testFlags' = defaultTestFlags <> testFlags - benchmarkFlags' = defaultBenchmarkFlags <> benchmarkFlags - projectFlags' = defaultProjectFlags <> projectFlags - - configAllPackages = convertLegacyPerPackageFlags - configFlags installFlags' - haddockFlags' testFlags' benchmarkFlags' - configShared = convertLegacyAllPackageFlags - globalFlags configFlags - configExFlags' installFlags' projectFlags' - configBuildOnly = convertLegacyBuildOnlyFlags - globalFlags configFlags - installFlags' clientInstallFlags' - haddockFlags' testFlags' benchmarkFlags' - + mempty + { projectConfigBuildOnly = configBuildOnly + , projectConfigShared = configShared + , projectConfigAllPackages = configAllPackages + } + where + -- TODO: [code cleanup] eliminate use of default*Flags here and specify the + -- defaults in the various resolve functions in terms of the new types. + configExFlags' = defaultConfigExFlags <> configExFlags + installFlags' = defaultInstallFlags <> installFlags + clientInstallFlags' = defaultClientInstallFlags <> clientInstallFlags + haddockFlags' = defaultHaddockFlags <> haddockFlags + testFlags' = defaultTestFlags <> testFlags + benchmarkFlags' = defaultBenchmarkFlags <> benchmarkFlags + projectFlags' = defaultProjectFlags <> projectFlags + + configAllPackages = + convertLegacyPerPackageFlags + configFlags + installFlags' + haddockFlags' + testFlags' + benchmarkFlags' + configShared = + convertLegacyAllPackageFlags + globalFlags + configFlags + configExFlags' + installFlags' + projectFlags' + configBuildOnly = + convertLegacyBuildOnlyFlags + globalFlags + configFlags + installFlags' + clientInstallFlags' + haddockFlags' + testFlags' + benchmarkFlags' -- | Convert the project config from the legacy types to the 'ProjectConfig' -- and associated types. See 'LegacyProjectConfig' for an explanation of the -- approach. --- convertLegacyProjectConfig :: LegacyProjectConfig -> ProjectConfig convertLegacyProjectConfig - LegacyProjectConfig { - legacyPackages, - legacyPackagesOptional, - legacyPackagesRepo, - legacyPackagesNamed, - legacySharedConfig = LegacySharedConfig globalFlags configShFlags - configExFlags installSharedFlags - clientInstallFlags projectFlags, - legacyAllConfig, - legacyLocalConfig = LegacyPackageConfig configFlags installPerPkgFlags - haddockFlags testFlags benchmarkFlags, - legacySpecificConfig - } = - - ProjectConfig { - projectPackages = legacyPackages, - projectPackagesOptional = legacyPackagesOptional, - projectPackagesRepo = legacyPackagesRepo, - projectPackagesNamed = legacyPackagesNamed, - - projectConfigBuildOnly = configBuildOnly, - projectConfigShared = configPackagesShared, - projectConfigProvenance = mempty, - projectConfigAllPackages = configAllPackages, - projectConfigLocalPackages = configLocalPackages, - projectConfigSpecificPackage = fmap perPackage legacySpecificConfig - } - where - configAllPackages = convertLegacyPerPackageFlags g i h t b - where LegacyPackageConfig g i h t b = legacyAllConfig - configLocalPackages = convertLegacyPerPackageFlags - configFlags installPerPkgFlags haddockFlags - testFlags benchmarkFlags - configPackagesShared= convertLegacyAllPackageFlags - globalFlags (configFlags <> configShFlags) - configExFlags installSharedFlags projectFlags - configBuildOnly = convertLegacyBuildOnlyFlags - globalFlags configShFlags - installSharedFlags clientInstallFlags - haddockFlags testFlags benchmarkFlags - - perPackage (LegacyPackageConfig perPkgConfigFlags perPkgInstallFlags - perPkgHaddockFlags perPkgTestFlags - perPkgBenchmarkFlags) = - convertLegacyPerPackageFlags - perPkgConfigFlags perPkgInstallFlags perPkgHaddockFlags - perPkgTestFlags perPkgBenchmarkFlags - + LegacyProjectConfig + { legacyPackages + , legacyPackagesOptional + , legacyPackagesRepo + , legacyPackagesNamed + , legacySharedConfig = + LegacySharedConfig + globalFlags + configShFlags + configExFlags + installSharedFlags + clientInstallFlags + projectFlags + , legacyAllConfig + , legacyLocalConfig = + LegacyPackageConfig + configFlags + installPerPkgFlags + haddockFlags + testFlags + benchmarkFlags + , legacySpecificConfig + } = + ProjectConfig + { projectPackages = legacyPackages + , projectPackagesOptional = legacyPackagesOptional + , projectPackagesRepo = legacyPackagesRepo + , projectPackagesNamed = legacyPackagesNamed + , projectConfigBuildOnly = configBuildOnly + , projectConfigShared = configPackagesShared + , projectConfigProvenance = mempty + , projectConfigAllPackages = configAllPackages + , projectConfigLocalPackages = configLocalPackages + , projectConfigSpecificPackage = fmap perPackage legacySpecificConfig + } + where + configAllPackages = convertLegacyPerPackageFlags g i h t b + where + LegacyPackageConfig g i h t b = legacyAllConfig + configLocalPackages = + convertLegacyPerPackageFlags + configFlags + installPerPkgFlags + haddockFlags + testFlags + benchmarkFlags + configPackagesShared = + convertLegacyAllPackageFlags + globalFlags + (configFlags <> configShFlags) + configExFlags + installSharedFlags + projectFlags + configBuildOnly = + convertLegacyBuildOnlyFlags + globalFlags + configShFlags + installSharedFlags + clientInstallFlags + haddockFlags + testFlags + benchmarkFlags + + perPackage + ( LegacyPackageConfig + perPkgConfigFlags + perPkgInstallFlags + perPkgHaddockFlags + perPkgTestFlags + perPkgBenchmarkFlags + ) = + convertLegacyPerPackageFlags + perPkgConfigFlags + perPkgInstallFlags + perPkgHaddockFlags + perPkgTestFlags + perPkgBenchmarkFlags -- | Helper used by other conversion functions that returns the -- 'ProjectConfigShared' subset of the 'ProjectConfig'. --- convertLegacyAllPackageFlags - :: GlobalFlags - -> ConfigFlags - -> ConfigExFlags - -> InstallFlags - -> ProjectFlags - -> ProjectConfigShared + :: GlobalFlags + -> ConfigFlags + -> ConfigExFlags + -> InstallFlags + -> ProjectFlags + -> ProjectConfigShared convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags projectFlags = - ProjectConfigShared{..} + ProjectConfigShared{..} where - GlobalFlags { - globalConfigFile = projectConfigConfigFile, - globalRemoteRepos = projectConfigRemoteRepos, - globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos, - globalActiveRepos = projectConfigActiveRepos, - globalProgPathExtra = projectConfigProgPathExtra, - globalStoreDir = projectConfigStoreDir - } = globalFlags - - ConfigFlags { - configDistPref = projectConfigDistDir, - configHcFlavor = projectConfigHcFlavor, - configHcPath = projectConfigHcPath, - configHcPkg = projectConfigHcPkg, - --configProgramPathExtra = projectConfigProgPathExtra DELETE ME - configInstallDirs = projectConfigInstallDirs, - --configUserInstall = projectConfigUserInstall, - configPackageDBs = projectConfigPackageDBs - } = configFlags - - ConfigExFlags { - configCabalVersion = projectConfigCabalVersion, - configExConstraints = projectConfigConstraints, - configPreferences = projectConfigPreferences, - configSolver = projectConfigSolver, - configAllowOlder = projectConfigAllowOlder, - configAllowNewer = projectConfigAllowNewer, - configWriteGhcEnvironmentFilesPolicy - = projectConfigWriteGhcEnvironmentFilesPolicy - } = configExFlags - - InstallFlags { - installHaddockIndex = projectConfigHaddockIndex, - --installReinstall = projectConfigReinstall, - --installAvoidReinstalls = projectConfigAvoidReinstalls, - --installOverrideReinstall = projectConfigOverrideReinstall, - installIndexState = projectConfigIndexState, - installMaxBackjumps = projectConfigMaxBackjumps, - --installUpgradeDeps = projectConfigUpgradeDeps, - installReorderGoals = projectConfigReorderGoals, - installCountConflicts = projectConfigCountConflicts, - installFineGrainedConflicts = projectConfigFineGrainedConflicts, - installMinimizeConflictSet = projectConfigMinimizeConflictSet, - installPerComponent = projectConfigPerComponent, - installIndependentGoals = projectConfigIndependentGoals, - installPreferOldest = projectConfigPreferOldest, - --installShadowPkgs = projectConfigShadowPkgs, - installStrongFlags = projectConfigStrongFlags, - installAllowBootLibInstalls = projectConfigAllowBootLibInstalls, - installOnlyConstrained = projectConfigOnlyConstrained - } = installFlags + GlobalFlags + { globalConfigFile = projectConfigConfigFile + , globalRemoteRepos = projectConfigRemoteRepos + , globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos + , globalActiveRepos = projectConfigActiveRepos + , globalProgPathExtra = projectConfigProgPathExtra + , globalStoreDir = projectConfigStoreDir + } = globalFlags + + ConfigFlags + { configDistPref = projectConfigDistDir + , configHcFlavor = projectConfigHcFlavor + , configHcPath = projectConfigHcPath + , configHcPkg = projectConfigHcPkg + , -- configProgramPathExtra = projectConfigProgPathExtra DELETE ME + configInstallDirs = projectConfigInstallDirs + , -- configUserInstall = projectConfigUserInstall, + configPackageDBs = projectConfigPackageDBs + } = configFlags + + ConfigExFlags + { configCabalVersion = projectConfigCabalVersion + , configExConstraints = projectConfigConstraints + , configPreferences = projectConfigPreferences + , configSolver = projectConfigSolver + , configAllowOlder = projectConfigAllowOlder + , configAllowNewer = projectConfigAllowNewer + , configWriteGhcEnvironmentFilesPolicy = + projectConfigWriteGhcEnvironmentFilesPolicy + } = configExFlags + + InstallFlags + { installHaddockIndex = projectConfigHaddockIndex + , -- installReinstall = projectConfigReinstall, + -- installAvoidReinstalls = projectConfigAvoidReinstalls, + -- installOverrideReinstall = projectConfigOverrideReinstall, + installIndexState = projectConfigIndexState + , installMaxBackjumps = projectConfigMaxBackjumps + , -- installUpgradeDeps = projectConfigUpgradeDeps, + installReorderGoals = projectConfigReorderGoals + , installCountConflicts = projectConfigCountConflicts + , installFineGrainedConflicts = projectConfigFineGrainedConflicts + , installMinimizeConflictSet = projectConfigMinimizeConflictSet + , installPerComponent = projectConfigPerComponent + , installIndependentGoals = projectConfigIndependentGoals + , installPreferOldest = projectConfigPreferOldest + , -- installShadowPkgs = projectConfigShadowPkgs, + installStrongFlags = projectConfigStrongFlags + , installAllowBootLibInstalls = projectConfigAllowBootLibInstalls + , installOnlyConstrained = projectConfigOnlyConstrained + } = installFlags ProjectFlags - { flagProjectDir = projectConfigProjectDir - , flagProjectFile = projectConfigProjectFile - , flagIgnoreProject = projectConfigIgnoreProject - } = projectFlags + { flagProjectDir = projectConfigProjectDir + , flagProjectFile = projectConfigProjectFile + , flagIgnoreProject = projectConfigIgnoreProject + } = projectFlags -- | Helper used by other conversion functions that returns the -- 'PackageConfig' subset of the 'ProjectConfig'. --- -convertLegacyPerPackageFlags :: ConfigFlags -> InstallFlags -> HaddockFlags - -> TestFlags -> BenchmarkFlags -> PackageConfig -convertLegacyPerPackageFlags configFlags installFlags - haddockFlags testFlags benchmarkFlags = +convertLegacyPerPackageFlags + :: ConfigFlags + -> InstallFlags + -> HaddockFlags + -> TestFlags + -> BenchmarkFlags + -> PackageConfig +convertLegacyPerPackageFlags + configFlags + installFlags + haddockFlags + testFlags + benchmarkFlags = PackageConfig{..} - where - ConfigFlags { - configProgramPaths, - configProgramArgs, - configProgramPathExtra = packageConfigProgramPathExtra, - configVanillaLib = packageConfigVanillaLib, - configProfLib = packageConfigProfLib, - configSharedLib = packageConfigSharedLib, - configStaticLib = packageConfigStaticLib, - configDynExe = packageConfigDynExe, - configFullyStaticExe = packageConfigFullyStaticExe, - configProfExe = packageConfigProfExe, - configProf = packageConfigProf, - configProfDetail = packageConfigProfDetail, - configProfLibDetail = packageConfigProfLibDetail, - configConfigureArgs = packageConfigConfigureArgs, - configOptimization = packageConfigOptimization, - configProgPrefix = packageConfigProgPrefix, - configProgSuffix = packageConfigProgSuffix, - configGHCiLib = packageConfigGHCiLib, - configSplitSections = packageConfigSplitSections, - configSplitObjs = packageConfigSplitObjs, - configStripExes = packageConfigStripExes, - configStripLibs = packageConfigStripLibs, - configExtraLibDirs = packageConfigExtraLibDirs, - configExtraLibDirsStatic = packageConfigExtraLibDirsStatic, - configExtraFrameworkDirs = packageConfigExtraFrameworkDirs, - configExtraIncludeDirs = packageConfigExtraIncludeDirs, - configConfigurationsFlags = packageConfigFlagAssignment, - configTests = packageConfigTests, - configBenchmarks = packageConfigBenchmarks, - configCoverage = coverage, - configLibCoverage = libcoverage, --deprecated - configDebugInfo = packageConfigDebugInfo, - configDumpBuildInfo = packageConfigDumpBuildInfo, - configRelocatable = packageConfigRelocatable - } = configFlags - packageConfigProgramPaths = MapLast (Map.fromList configProgramPaths) - packageConfigProgramArgs = MapMappend (Map.fromListWith (++) configProgramArgs) - - packageConfigCoverage = coverage <> libcoverage - --TODO: defer this merging to the resolve phase - - InstallFlags { - installDocumentation = packageConfigDocumentation, - installRunTests = packageConfigRunTests - } = installFlags - - HaddockFlags { - haddockHoogle = packageConfigHaddockHoogle, - haddockHtml = packageConfigHaddockHtml, - haddockHtmlLocation = packageConfigHaddockHtmlLocation, - haddockForeignLibs = packageConfigHaddockForeignLibs, - haddockForHackage = packageConfigHaddockForHackage, - haddockExecutables = packageConfigHaddockExecutables, - haddockTestSuites = packageConfigHaddockTestSuites, - haddockBenchmarks = packageConfigHaddockBenchmarks, - haddockInternal = packageConfigHaddockInternal, - haddockCss = packageConfigHaddockCss, - haddockLinkedSource = packageConfigHaddockLinkedSource, - haddockQuickJump = packageConfigHaddockQuickJump, - haddockHscolourCss = packageConfigHaddockHscolourCss, - haddockContents = packageConfigHaddockContents, - haddockIndex = packageConfigHaddockIndex, - haddockBaseUrl = packageConfigHaddockBaseUrl, - haddockLib = packageConfigHaddockLib, - haddockOutputDir = packageConfigHaddockOutputDir - } = haddockFlags - - TestFlags { - testHumanLog = packageConfigTestHumanLog, - testMachineLog = packageConfigTestMachineLog, - testShowDetails = packageConfigTestShowDetails, - testKeepTix = packageConfigTestKeepTix, - testWrapper = packageConfigTestWrapper, - testFailWhenNoTestSuites = packageConfigTestFailWhenNoTestSuites, - testOptions = packageConfigTestTestOptions - } = testFlags - - BenchmarkFlags { - benchmarkOptions = packageConfigBenchmarkOptions - } = benchmarkFlags - + where + ConfigFlags + { configProgramPaths + , configProgramArgs + , configProgramPathExtra = packageConfigProgramPathExtra + , configVanillaLib = packageConfigVanillaLib + , configProfLib = packageConfigProfLib + , configSharedLib = packageConfigSharedLib + , configStaticLib = packageConfigStaticLib + , configDynExe = packageConfigDynExe + , configFullyStaticExe = packageConfigFullyStaticExe + , configProfExe = packageConfigProfExe + , configProf = packageConfigProf + , configProfDetail = packageConfigProfDetail + , configProfLibDetail = packageConfigProfLibDetail + , configConfigureArgs = packageConfigConfigureArgs + , configOptimization = packageConfigOptimization + , configProgPrefix = packageConfigProgPrefix + , configProgSuffix = packageConfigProgSuffix + , configGHCiLib = packageConfigGHCiLib + , configSplitSections = packageConfigSplitSections + , configSplitObjs = packageConfigSplitObjs + , configStripExes = packageConfigStripExes + , configStripLibs = packageConfigStripLibs + , configExtraLibDirs = packageConfigExtraLibDirs + , configExtraLibDirsStatic = packageConfigExtraLibDirsStatic + , configExtraFrameworkDirs = packageConfigExtraFrameworkDirs + , configExtraIncludeDirs = packageConfigExtraIncludeDirs + , configConfigurationsFlags = packageConfigFlagAssignment + , configTests = packageConfigTests + , configBenchmarks = packageConfigBenchmarks + , configCoverage = coverage + , configLibCoverage = libcoverage -- deprecated + , configDebugInfo = packageConfigDebugInfo + , configDumpBuildInfo = packageConfigDumpBuildInfo + , configRelocatable = packageConfigRelocatable + } = configFlags + packageConfigProgramPaths = MapLast (Map.fromList configProgramPaths) + packageConfigProgramArgs = MapMappend (Map.fromListWith (++) configProgramArgs) + + packageConfigCoverage = coverage <> libcoverage + -- TODO: defer this merging to the resolve phase + + InstallFlags + { installDocumentation = packageConfigDocumentation + , installRunTests = packageConfigRunTests + } = installFlags + + HaddockFlags + { haddockHoogle = packageConfigHaddockHoogle + , haddockHtml = packageConfigHaddockHtml + , haddockHtmlLocation = packageConfigHaddockHtmlLocation + , haddockForeignLibs = packageConfigHaddockForeignLibs + , haddockForHackage = packageConfigHaddockForHackage + , haddockExecutables = packageConfigHaddockExecutables + , haddockTestSuites = packageConfigHaddockTestSuites + , haddockBenchmarks = packageConfigHaddockBenchmarks + , haddockInternal = packageConfigHaddockInternal + , haddockCss = packageConfigHaddockCss + , haddockLinkedSource = packageConfigHaddockLinkedSource + , haddockQuickJump = packageConfigHaddockQuickJump + , haddockHscolourCss = packageConfigHaddockHscolourCss + , haddockContents = packageConfigHaddockContents + , haddockIndex = packageConfigHaddockIndex + , haddockBaseUrl = packageConfigHaddockBaseUrl + , haddockLib = packageConfigHaddockLib + , haddockOutputDir = packageConfigHaddockOutputDir + } = haddockFlags + + TestFlags + { testHumanLog = packageConfigTestHumanLog + , testMachineLog = packageConfigTestMachineLog + , testShowDetails = packageConfigTestShowDetails + , testKeepTix = packageConfigTestKeepTix + , testWrapper = packageConfigTestWrapper + , testFailWhenNoTestSuites = packageConfigTestFailWhenNoTestSuites + , testOptions = packageConfigTestTestOptions + } = testFlags + + BenchmarkFlags + { benchmarkOptions = packageConfigBenchmarkOptions + } = benchmarkFlags -- | Helper used by other conversion functions that returns the -- 'ProjectConfigBuildOnly' subset of the 'ProjectConfig'. --- -convertLegacyBuildOnlyFlags :: GlobalFlags -> ConfigFlags - -> InstallFlags -> ClientInstallFlags - -> HaddockFlags -> TestFlags - -> BenchmarkFlags - -> ProjectConfigBuildOnly -convertLegacyBuildOnlyFlags globalFlags configFlags - installFlags clientInstallFlags - haddockFlags _ _ = +convertLegacyBuildOnlyFlags + :: GlobalFlags + -> ConfigFlags + -> InstallFlags + -> ClientInstallFlags + -> HaddockFlags + -> TestFlags + -> BenchmarkFlags + -> ProjectConfigBuildOnly +convertLegacyBuildOnlyFlags + globalFlags + configFlags + installFlags + clientInstallFlags + haddockFlags + _ + _ = ProjectConfigBuildOnly{..} - where - projectConfigClientInstallFlags = clientInstallFlags - GlobalFlags { - globalCacheDir = projectConfigCacheDir, - globalLogsDir = projectConfigLogsDir, - globalHttpTransport = projectConfigHttpTransport, - globalIgnoreExpiry = projectConfigIgnoreExpiry - } = globalFlags - - ConfigFlags { - configVerbosity = projectConfigVerbosity - } = configFlags - - InstallFlags { - installDryRun = projectConfigDryRun, - installOnlyDownload = projectConfigOnlyDownload, - installOnly = _, - installOnlyDeps = projectConfigOnlyDeps, - installRootCmd = _, - installSummaryFile = projectConfigSummaryFile, - installLogFile = projectConfigLogFile, - installBuildReports = projectConfigBuildReports, - installReportPlanningFailure = projectConfigReportPlanningFailure, - installSymlinkBinDir = projectConfigSymlinkBinDir, - installNumJobs = projectConfigNumJobs, - installKeepGoing = projectConfigKeepGoing, - installOfflineMode = projectConfigOfflineMode - } = installFlags - - HaddockFlags { - haddockKeepTempFiles = projectConfigKeepTempFiles --TODO: this ought to live elsewhere - } = haddockFlags - + where + projectConfigClientInstallFlags = clientInstallFlags + GlobalFlags + { globalCacheDir = projectConfigCacheDir + , globalLogsDir = projectConfigLogsDir + , globalHttpTransport = projectConfigHttpTransport + , globalIgnoreExpiry = projectConfigIgnoreExpiry + } = globalFlags + + ConfigFlags + { configVerbosity = projectConfigVerbosity + } = configFlags + + InstallFlags + { installDryRun = projectConfigDryRun + , installOnlyDownload = projectConfigOnlyDownload + , installOnly = _ + , installOnlyDeps = projectConfigOnlyDeps + , installRootCmd = _ + , installSummaryFile = projectConfigSummaryFile + , installLogFile = projectConfigLogFile + , installBuildReports = projectConfigBuildReports + , installReportPlanningFailure = projectConfigReportPlanningFailure + , installSymlinkBinDir = projectConfigSymlinkBinDir + , installNumJobs = projectConfigNumJobs + , installKeepGoing = projectConfigKeepGoing + , installOfflineMode = projectConfigOfflineMode + } = installFlags + + HaddockFlags + { haddockKeepTempFiles = projectConfigKeepTempFiles -- TODO: this ought to live elsewhere + } = haddockFlags convertToLegacyProjectConfig :: ProjectConfig -> LegacyProjectConfig convertToLegacyProjectConfig - projectConfig@ProjectConfig { - projectPackages, - projectPackagesOptional, - projectPackagesRepo, - projectPackagesNamed, - projectConfigAllPackages, - projectConfigLocalPackages, - projectConfigSpecificPackage + projectConfig@ProjectConfig + { projectPackages + , projectPackagesOptional + , projectPackagesRepo + , projectPackagesNamed + , projectConfigAllPackages + , projectConfigLocalPackages + , projectConfigSpecificPackage } = - LegacyProjectConfig { - legacyPackages = projectPackages, - legacyPackagesOptional = projectPackagesOptional, - legacyPackagesRepo = projectPackagesRepo, - legacyPackagesNamed = projectPackagesNamed, - legacySharedConfig = convertToLegacySharedConfig projectConfig, - legacyAllConfig = convertToLegacyPerPackageConfig - projectConfigAllPackages, - legacyLocalConfig = convertToLegacyAllPackageConfig projectConfig - <> convertToLegacyPerPackageConfig - projectConfigLocalPackages, - legacySpecificConfig = fmap convertToLegacyPerPackageConfig - projectConfigSpecificPackage - } + LegacyProjectConfig + { legacyPackages = projectPackages + , legacyPackagesOptional = projectPackagesOptional + , legacyPackagesRepo = projectPackagesRepo + , legacyPackagesNamed = projectPackagesNamed + , legacySharedConfig = convertToLegacySharedConfig projectConfig + , legacyAllConfig = + convertToLegacyPerPackageConfig + projectConfigAllPackages + , legacyLocalConfig = + convertToLegacyAllPackageConfig projectConfig + <> convertToLegacyPerPackageConfig + projectConfigLocalPackages + , legacySpecificConfig = + fmap + convertToLegacyPerPackageConfig + projectConfigSpecificPackage + } convertToLegacySharedConfig :: ProjectConfig -> LegacySharedConfig convertToLegacySharedConfig - ProjectConfig { - projectConfigBuildOnly = ProjectConfigBuildOnly {..}, - projectConfigShared = ProjectConfigShared {..}, - projectConfigAllPackages = PackageConfig { - packageConfigDocumentation - } + ProjectConfig + { projectConfigBuildOnly = ProjectConfigBuildOnly{..} + , projectConfigShared = ProjectConfigShared{..} + , projectConfigAllPackages = + PackageConfig + { packageConfigDocumentation + } } = - LegacySharedConfig - { legacyGlobalFlags = globalFlags - , legacyConfigureShFlags = configFlags - , legacyConfigureExFlags = configExFlags - , legacyInstallFlags = installFlags + { legacyGlobalFlags = globalFlags + , legacyConfigureShFlags = configFlags + , legacyConfigureExFlags = configExFlags + , legacyInstallFlags = installFlags , legacyClientInstallFlags = projectConfigClientInstallFlags - , legacyProjectFlags = projectFlags + , legacyProjectFlags = projectFlags } - where - globalFlags = GlobalFlags { - globalVersion = mempty, - globalNumericVersion = mempty, - globalConfigFile = projectConfigConfigFile, - globalConstraintsFile = mempty, - globalRemoteRepos = projectConfigRemoteRepos, - globalCacheDir = projectConfigCacheDir, - globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos, - globalActiveRepos = projectConfigActiveRepos, - globalLogsDir = projectConfigLogsDir, - globalIgnoreExpiry = projectConfigIgnoreExpiry, - globalHttpTransport = projectConfigHttpTransport, - globalNix = mempty, - globalStoreDir = projectConfigStoreDir, - globalProgPathExtra = projectConfigProgPathExtra - } - - configFlags = mempty { - configVerbosity = projectConfigVerbosity, - configDistPref = projectConfigDistDir, - configPackageDBs = projectConfigPackageDBs, - configInstallDirs = projectConfigInstallDirs - } + where + globalFlags = + GlobalFlags + { globalVersion = mempty + , globalNumericVersion = mempty + , globalConfigFile = projectConfigConfigFile + , globalConstraintsFile = mempty + , globalRemoteRepos = projectConfigRemoteRepos + , globalCacheDir = projectConfigCacheDir + , globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos + , globalActiveRepos = projectConfigActiveRepos + , globalLogsDir = projectConfigLogsDir + , globalIgnoreExpiry = projectConfigIgnoreExpiry + , globalHttpTransport = projectConfigHttpTransport + , globalNix = mempty + , globalStoreDir = projectConfigStoreDir + , globalProgPathExtra = projectConfigProgPathExtra + } - configExFlags = ConfigExFlags { - configCabalVersion = projectConfigCabalVersion, - configAppend = mempty, - configBackup = mempty, - configExConstraints = projectConfigConstraints, - configPreferences = projectConfigPreferences, - configSolver = projectConfigSolver, - configAllowOlder = projectConfigAllowOlder, - configAllowNewer = projectConfigAllowNewer, - configWriteGhcEnvironmentFilesPolicy - = projectConfigWriteGhcEnvironmentFilesPolicy - } + configFlags = + mempty + { configVerbosity = projectConfigVerbosity + , configDistPref = projectConfigDistDir + , configPackageDBs = projectConfigPackageDBs + , configInstallDirs = projectConfigInstallDirs + } - installFlags = InstallFlags { - installDocumentation = packageConfigDocumentation, - installHaddockIndex = projectConfigHaddockIndex, - installDest = Flag NoCopyDest, - installDryRun = projectConfigDryRun, - installOnlyDownload = projectConfigOnlyDownload, - installReinstall = mempty, --projectConfigReinstall, - installAvoidReinstalls = mempty, --projectConfigAvoidReinstalls, - installOverrideReinstall = mempty, --projectConfigOverrideReinstall, - installMaxBackjumps = projectConfigMaxBackjumps, - installUpgradeDeps = mempty, --projectConfigUpgradeDeps, - installReorderGoals = projectConfigReorderGoals, - installCountConflicts = projectConfigCountConflicts, - installFineGrainedConflicts = projectConfigFineGrainedConflicts, - installMinimizeConflictSet = projectConfigMinimizeConflictSet, - installIndependentGoals = projectConfigIndependentGoals, - installPreferOldest = projectConfigPreferOldest, - installShadowPkgs = mempty, --projectConfigShadowPkgs, - installStrongFlags = projectConfigStrongFlags, - installAllowBootLibInstalls = projectConfigAllowBootLibInstalls, - installOnlyConstrained = projectConfigOnlyConstrained, - installOnly = mempty, - installOnlyDeps = projectConfigOnlyDeps, - installIndexState = projectConfigIndexState, - installRootCmd = mempty, --no longer supported - installSummaryFile = projectConfigSummaryFile, - installLogFile = projectConfigLogFile, - installBuildReports = projectConfigBuildReports, - installReportPlanningFailure = projectConfigReportPlanningFailure, - installSymlinkBinDir = projectConfigSymlinkBinDir, - installPerComponent = projectConfigPerComponent, - installNumJobs = projectConfigNumJobs, - installKeepGoing = projectConfigKeepGoing, - installRunTests = mempty, - installOfflineMode = projectConfigOfflineMode - } + configExFlags = + ConfigExFlags + { configCabalVersion = projectConfigCabalVersion + , configAppend = mempty + , configBackup = mempty + , configExConstraints = projectConfigConstraints + , configPreferences = projectConfigPreferences + , configSolver = projectConfigSolver + , configAllowOlder = projectConfigAllowOlder + , configAllowNewer = projectConfigAllowNewer + , configWriteGhcEnvironmentFilesPolicy = + projectConfigWriteGhcEnvironmentFilesPolicy + } - projectFlags = ProjectFlags - { flagProjectDir = projectConfigProjectDir - , flagProjectFile = projectConfigProjectFile - , flagIgnoreProject = projectConfigIgnoreProject - } + installFlags = + InstallFlags + { installDocumentation = packageConfigDocumentation + , installHaddockIndex = projectConfigHaddockIndex + , installDest = Flag NoCopyDest + , installDryRun = projectConfigDryRun + , installOnlyDownload = projectConfigOnlyDownload + , installReinstall = mempty -- projectConfigReinstall, + , installAvoidReinstalls = mempty -- projectConfigAvoidReinstalls, + , installOverrideReinstall = mempty -- projectConfigOverrideReinstall, + , installMaxBackjumps = projectConfigMaxBackjumps + , installUpgradeDeps = mempty -- projectConfigUpgradeDeps, + , installReorderGoals = projectConfigReorderGoals + , installCountConflicts = projectConfigCountConflicts + , installFineGrainedConflicts = projectConfigFineGrainedConflicts + , installMinimizeConflictSet = projectConfigMinimizeConflictSet + , installIndependentGoals = projectConfigIndependentGoals + , installPreferOldest = projectConfigPreferOldest + , installShadowPkgs = mempty -- projectConfigShadowPkgs, + , installStrongFlags = projectConfigStrongFlags + , installAllowBootLibInstalls = projectConfigAllowBootLibInstalls + , installOnlyConstrained = projectConfigOnlyConstrained + , installOnly = mempty + , installOnlyDeps = projectConfigOnlyDeps + , installIndexState = projectConfigIndexState + , installRootCmd = mempty -- no longer supported + , installSummaryFile = projectConfigSummaryFile + , installLogFile = projectConfigLogFile + , installBuildReports = projectConfigBuildReports + , installReportPlanningFailure = projectConfigReportPlanningFailure + , installSymlinkBinDir = projectConfigSymlinkBinDir + , installPerComponent = projectConfigPerComponent + , installNumJobs = projectConfigNumJobs + , installKeepGoing = projectConfigKeepGoing + , installRunTests = mempty + , installOfflineMode = projectConfigOfflineMode + } + projectFlags = + ProjectFlags + { flagProjectDir = projectConfigProjectDir + , flagProjectFile = projectConfigProjectFile + , flagIgnoreProject = projectConfigIgnoreProject + } convertToLegacyAllPackageConfig :: ProjectConfig -> LegacyPackageConfig convertToLegacyAllPackageConfig - ProjectConfig { - projectConfigBuildOnly = ProjectConfigBuildOnly {..}, - projectConfigShared = ProjectConfigShared {..} + ProjectConfig + { projectConfigBuildOnly = ProjectConfigBuildOnly{..} + , projectConfigShared = ProjectConfigShared{..} } = + LegacyPackageConfig + { legacyConfigureFlags = configFlags + , legacyInstallPkgFlags = mempty + , legacyHaddockFlags = haddockFlags + , legacyTestFlags = mempty + , legacyBenchmarkFlags = mempty + } + where + configFlags = + ConfigFlags + { configArgs = mempty + , configPrograms_ = mempty + , configProgramPaths = mempty + , configProgramArgs = mempty + , configProgramPathExtra = mempty + , configHcFlavor = projectConfigHcFlavor + , configHcPath = projectConfigHcPath + , configHcPkg = projectConfigHcPkg + , configInstantiateWith = mempty + , configVanillaLib = mempty + , configProfLib = mempty + , configSharedLib = mempty + , configStaticLib = mempty + , configDynExe = mempty + , configFullyStaticExe = mempty + , configProfExe = mempty + , configProf = mempty + , configProfDetail = mempty + , configProfLibDetail = mempty + , configConfigureArgs = mempty + , configOptimization = mempty + , configProgPrefix = mempty + , configProgSuffix = mempty + , configInstallDirs = projectConfigInstallDirs + , configScratchDir = mempty + , configDistPref = mempty + , configCabalFilePath = mempty + , configVerbosity = mempty + , configUserInstall = mempty -- projectConfigUserInstall, + , configPackageDBs = mempty + , configGHCiLib = mempty + , configSplitSections = mempty + , configSplitObjs = mempty + , configStripExes = mempty + , configStripLibs = mempty + , configExtraLibDirs = mempty + , configExtraLibDirsStatic = mempty + , configExtraFrameworkDirs = mempty + , configConstraints = mempty + , configDependencies = mempty + , configExtraIncludeDirs = mempty + , configDeterministic = mempty + , configIPID = mempty + , configCID = mempty + , configConfigurationsFlags = mempty + , configTests = mempty + , configCoverage = mempty -- TODO: don't merge + , configLibCoverage = mempty -- TODO: don't merge + , configExactConfiguration = mempty + , configBenchmarks = mempty + , configFlagError = mempty -- TODO: ??? + , configRelocatable = mempty + , configDebugInfo = mempty + , configUseResponseFiles = mempty + , configDumpBuildInfo = mempty + , configAllowDependingOnPrivateLibs = mempty + } - LegacyPackageConfig { - legacyConfigureFlags = configFlags, - legacyInstallPkgFlags= mempty, - legacyHaddockFlags = haddockFlags, - legacyTestFlags = mempty, - legacyBenchmarkFlags = mempty - } - where - configFlags = ConfigFlags { - configArgs = mempty, - configPrograms_ = mempty, - configProgramPaths = mempty, - configProgramArgs = mempty, - configProgramPathExtra = mempty, - configHcFlavor = projectConfigHcFlavor, - configHcPath = projectConfigHcPath, - configHcPkg = projectConfigHcPkg, - configInstantiateWith = mempty, - configVanillaLib = mempty, - configProfLib = mempty, - configSharedLib = mempty, - configStaticLib = mempty, - configDynExe = mempty, - configFullyStaticExe = mempty, - configProfExe = mempty, - configProf = mempty, - configProfDetail = mempty, - configProfLibDetail = mempty, - configConfigureArgs = mempty, - configOptimization = mempty, - configProgPrefix = mempty, - configProgSuffix = mempty, - configInstallDirs = projectConfigInstallDirs, - configScratchDir = mempty, - configDistPref = mempty, - configCabalFilePath = mempty, - configVerbosity = mempty, - configUserInstall = mempty, --projectConfigUserInstall, - configPackageDBs = mempty, - configGHCiLib = mempty, - configSplitSections = mempty, - configSplitObjs = mempty, - configStripExes = mempty, - configStripLibs = mempty, - configExtraLibDirs = mempty, - configExtraLibDirsStatic = mempty, - configExtraFrameworkDirs = mempty, - configConstraints = mempty, - configDependencies = mempty, - configExtraIncludeDirs = mempty, - configDeterministic = mempty, - configIPID = mempty, - configCID = mempty, - configConfigurationsFlags = mempty, - configTests = mempty, - configCoverage = mempty, --TODO: don't merge - configLibCoverage = mempty, --TODO: don't merge - configExactConfiguration = mempty, - configBenchmarks = mempty, - configFlagError = mempty, --TODO: ??? - configRelocatable = mempty, - configDebugInfo = mempty, - configUseResponseFiles = mempty, - configDumpBuildInfo = mempty, - configAllowDependingOnPrivateLibs = mempty - } - - haddockFlags = mempty { - haddockKeepTempFiles = projectConfigKeepTempFiles - } - + haddockFlags = + mempty + { haddockKeepTempFiles = projectConfigKeepTempFiles + } convertToLegacyPerPackageConfig :: PackageConfig -> LegacyPackageConfig -convertToLegacyPerPackageConfig PackageConfig {..} = - LegacyPackageConfig { - legacyConfigureFlags = configFlags, - legacyInstallPkgFlags = installFlags, - legacyHaddockFlags = haddockFlags, - legacyTestFlags = testFlags, - legacyBenchmarkFlags = benchmarkFlags +convertToLegacyPerPackageConfig PackageConfig{..} = + LegacyPackageConfig + { legacyConfigureFlags = configFlags + , legacyInstallPkgFlags = installFlags + , legacyHaddockFlags = haddockFlags + , legacyTestFlags = testFlags + , legacyBenchmarkFlags = benchmarkFlags } where - configFlags = ConfigFlags { - configArgs = mempty, - configPrograms_ = configPrograms_ mempty, - configProgramPaths = Map.toList (getMapLast packageConfigProgramPaths), - configProgramArgs = Map.toList (getMapMappend packageConfigProgramArgs), - configProgramPathExtra = packageConfigProgramPathExtra, - configHcFlavor = mempty, - configHcPath = mempty, - configHcPkg = mempty, - configInstantiateWith = mempty, - configVanillaLib = packageConfigVanillaLib, - configProfLib = packageConfigProfLib, - configSharedLib = packageConfigSharedLib, - configStaticLib = packageConfigStaticLib, - configDynExe = packageConfigDynExe, - configFullyStaticExe = packageConfigFullyStaticExe, - configProfExe = packageConfigProfExe, - configProf = packageConfigProf, - configProfDetail = packageConfigProfDetail, - configProfLibDetail = packageConfigProfLibDetail, - configConfigureArgs = packageConfigConfigureArgs, - configOptimization = packageConfigOptimization, - configProgPrefix = packageConfigProgPrefix, - configProgSuffix = packageConfigProgSuffix, - configInstallDirs = mempty, - configScratchDir = mempty, - configDistPref = mempty, - configCabalFilePath = mempty, - configVerbosity = mempty, - configUserInstall = mempty, - configPackageDBs = mempty, - configGHCiLib = packageConfigGHCiLib, - configSplitSections = packageConfigSplitSections, - configSplitObjs = packageConfigSplitObjs, - configStripExes = packageConfigStripExes, - configStripLibs = packageConfigStripLibs, - configExtraLibDirs = packageConfigExtraLibDirs, - configExtraLibDirsStatic = packageConfigExtraLibDirsStatic, - configExtraFrameworkDirs = packageConfigExtraFrameworkDirs, - configConstraints = mempty, - configDependencies = mempty, - configExtraIncludeDirs = packageConfigExtraIncludeDirs, - configIPID = mempty, - configCID = mempty, - configDeterministic = mempty, - configConfigurationsFlags = packageConfigFlagAssignment, - configTests = packageConfigTests, - configCoverage = packageConfigCoverage, --TODO: don't merge - configLibCoverage = packageConfigCoverage, --TODO: don't merge - configExactConfiguration = mempty, - configBenchmarks = packageConfigBenchmarks, - configFlagError = mempty, --TODO: ??? - configRelocatable = packageConfigRelocatable, - configDebugInfo = packageConfigDebugInfo, - configUseResponseFiles = mempty, - configDumpBuildInfo = packageConfigDumpBuildInfo, - configAllowDependingOnPrivateLibs = mempty - } + configFlags = + ConfigFlags + { configArgs = mempty + , configPrograms_ = configPrograms_ mempty + , configProgramPaths = Map.toList (getMapLast packageConfigProgramPaths) + , configProgramArgs = Map.toList (getMapMappend packageConfigProgramArgs) + , configProgramPathExtra = packageConfigProgramPathExtra + , configHcFlavor = mempty + , configHcPath = mempty + , configHcPkg = mempty + , configInstantiateWith = mempty + , configVanillaLib = packageConfigVanillaLib + , configProfLib = packageConfigProfLib + , configSharedLib = packageConfigSharedLib + , configStaticLib = packageConfigStaticLib + , configDynExe = packageConfigDynExe + , configFullyStaticExe = packageConfigFullyStaticExe + , configProfExe = packageConfigProfExe + , configProf = packageConfigProf + , configProfDetail = packageConfigProfDetail + , configProfLibDetail = packageConfigProfLibDetail + , configConfigureArgs = packageConfigConfigureArgs + , configOptimization = packageConfigOptimization + , configProgPrefix = packageConfigProgPrefix + , configProgSuffix = packageConfigProgSuffix + , configInstallDirs = mempty + , configScratchDir = mempty + , configDistPref = mempty + , configCabalFilePath = mempty + , configVerbosity = mempty + , configUserInstall = mempty + , configPackageDBs = mempty + , configGHCiLib = packageConfigGHCiLib + , configSplitSections = packageConfigSplitSections + , configSplitObjs = packageConfigSplitObjs + , configStripExes = packageConfigStripExes + , configStripLibs = packageConfigStripLibs + , configExtraLibDirs = packageConfigExtraLibDirs + , configExtraLibDirsStatic = packageConfigExtraLibDirsStatic + , configExtraFrameworkDirs = packageConfigExtraFrameworkDirs + , configConstraints = mempty + , configDependencies = mempty + , configExtraIncludeDirs = packageConfigExtraIncludeDirs + , configIPID = mempty + , configCID = mempty + , configDeterministic = mempty + , configConfigurationsFlags = packageConfigFlagAssignment + , configTests = packageConfigTests + , configCoverage = packageConfigCoverage -- TODO: don't merge + , configLibCoverage = packageConfigCoverage -- TODO: don't merge + , configExactConfiguration = mempty + , configBenchmarks = packageConfigBenchmarks + , configFlagError = mempty -- TODO: ??? + , configRelocatable = packageConfigRelocatable + , configDebugInfo = packageConfigDebugInfo + , configUseResponseFiles = mempty + , configDumpBuildInfo = packageConfigDumpBuildInfo + , configAllowDependingOnPrivateLibs = mempty + } - installFlags = mempty { - installDocumentation = packageConfigDocumentation, - installRunTests = packageConfigRunTests - } + installFlags = + mempty + { installDocumentation = packageConfigDocumentation + , installRunTests = packageConfigRunTests + } - haddockFlags = HaddockFlags { - haddockProgramPaths = mempty, - haddockProgramArgs = mempty, - haddockHoogle = packageConfigHaddockHoogle, - haddockHtml = packageConfigHaddockHtml, - haddockHtmlLocation = packageConfigHaddockHtmlLocation, - haddockForHackage = packageConfigHaddockForHackage, - haddockForeignLibs = packageConfigHaddockForeignLibs, - haddockExecutables = packageConfigHaddockExecutables, - haddockTestSuites = packageConfigHaddockTestSuites, - haddockBenchmarks = packageConfigHaddockBenchmarks, - haddockInternal = packageConfigHaddockInternal, - haddockCss = packageConfigHaddockCss, - haddockLinkedSource = packageConfigHaddockLinkedSource, - haddockQuickJump = packageConfigHaddockQuickJump, - haddockHscolourCss = packageConfigHaddockHscolourCss, - haddockContents = packageConfigHaddockContents, - haddockDistPref = mempty, - haddockKeepTempFiles = mempty, - haddockVerbosity = mempty, - haddockCabalFilePath = mempty, - haddockIndex = packageConfigHaddockIndex, - haddockBaseUrl = packageConfigHaddockBaseUrl, - haddockLib = packageConfigHaddockLib, - haddockOutputDir = packageConfigHaddockOutputDir, - haddockArgs = mempty - } + haddockFlags = + HaddockFlags + { haddockProgramPaths = mempty + , haddockProgramArgs = mempty + , haddockHoogle = packageConfigHaddockHoogle + , haddockHtml = packageConfigHaddockHtml + , haddockHtmlLocation = packageConfigHaddockHtmlLocation + , haddockForHackage = packageConfigHaddockForHackage + , haddockForeignLibs = packageConfigHaddockForeignLibs + , haddockExecutables = packageConfigHaddockExecutables + , haddockTestSuites = packageConfigHaddockTestSuites + , haddockBenchmarks = packageConfigHaddockBenchmarks + , haddockInternal = packageConfigHaddockInternal + , haddockCss = packageConfigHaddockCss + , haddockLinkedSource = packageConfigHaddockLinkedSource + , haddockQuickJump = packageConfigHaddockQuickJump + , haddockHscolourCss = packageConfigHaddockHscolourCss + , haddockContents = packageConfigHaddockContents + , haddockDistPref = mempty + , haddockKeepTempFiles = mempty + , haddockVerbosity = mempty + , haddockCabalFilePath = mempty + , haddockIndex = packageConfigHaddockIndex + , haddockBaseUrl = packageConfigHaddockBaseUrl + , haddockLib = packageConfigHaddockLib + , haddockOutputDir = packageConfigHaddockOutputDir + , haddockArgs = mempty + } - testFlags = TestFlags { - testDistPref = mempty, - testVerbosity = mempty, - testHumanLog = packageConfigTestHumanLog, - testMachineLog = packageConfigTestMachineLog, - testShowDetails = packageConfigTestShowDetails, - testKeepTix = packageConfigTestKeepTix, - testWrapper = packageConfigTestWrapper, - testFailWhenNoTestSuites = packageConfigTestFailWhenNoTestSuites, - testOptions = packageConfigTestTestOptions - } + testFlags = + TestFlags + { testDistPref = mempty + , testVerbosity = mempty + , testHumanLog = packageConfigTestHumanLog + , testMachineLog = packageConfigTestMachineLog + , testShowDetails = packageConfigTestShowDetails + , testKeepTix = packageConfigTestKeepTix + , testWrapper = packageConfigTestWrapper + , testFailWhenNoTestSuites = packageConfigTestFailWhenNoTestSuites + , testOptions = packageConfigTestTestOptions + } - benchmarkFlags = BenchmarkFlags { - benchmarkDistPref = mempty, - benchmarkVerbosity = mempty, - benchmarkOptions = packageConfigBenchmarkOptions - } + benchmarkFlags = + BenchmarkFlags + { benchmarkDistPref = mempty + , benchmarkVerbosity = mempty + , benchmarkOptions = packageConfigBenchmarkOptions + } ------------------------------------------------ -- Parsing and showing the project config file @@ -1014,10 +1163,11 @@ convertToLegacyPerPackageConfig PackageConfig {..} = parseLegacyProjectConfigFields :: FilePath -> [ParseUtils.Field] -> ParseResult LegacyProjectConfig parseLegacyProjectConfigFields source = - parseFieldsAndSections (legacyProjectConfigFieldDescrs constraintSrc) - legacyPackageConfigSectionDescrs - legacyPackageConfigFGSectionDescrs - mempty + parseFieldsAndSections + (legacyProjectConfigFieldDescrs constraintSrc) + legacyPackageConfigSectionDescrs + legacyPackageConfigFGSectionDescrs + mempty where constraintSrc = ConstraintSourceProjectConfig source @@ -1026,347 +1176,442 @@ parseLegacyProjectConfig source bs = parseLegacyProjectConfigFields source =<< P showLegacyProjectConfig :: LegacyProjectConfig -> String showLegacyProjectConfig config = - Disp.render $ - showConfig (legacyProjectConfigFieldDescrs constraintSrc) - legacyPackageConfigSectionDescrs - legacyPackageConfigFGSectionDescrs - config - $+$ - Disp.text "" + Disp.render $ + showConfig + (legacyProjectConfigFieldDescrs constraintSrc) + legacyPackageConfigSectionDescrs + legacyPackageConfigFGSectionDescrs + config + $+$ Disp.text "" where -- Note: ConstraintSource is unused when pretty-printing. We fake -- it here to avoid having to pass it on call-sites. It's not great -- but requires re-work of how we annotate provenance. constraintSrc = ConstraintSourceProjectConfig "unused" - legacyProjectConfigFieldDescrs :: ConstraintSource -> [FieldDescr LegacyProjectConfig] legacyProjectConfigFieldDescrs constraintSrc = - - [ newLineListField "packages" - (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ - legacyPackages - (\v flags -> flags { legacyPackages = v }) - , newLineListField "optional-packages" - (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ - legacyPackagesOptional - (\v flags -> flags { legacyPackagesOptional = v }) - , commaNewLineListFieldParsec "extra-packages" - pretty parsec - legacyPackagesNamed - (\v flags -> flags { legacyPackagesNamed = v }) - ] - - ++ map (liftField - legacySharedConfig - (\flags conf -> conf { legacySharedConfig = flags })) - (legacySharedConfigFieldDescrs constraintSrc) - - ++ map (liftField - legacyLocalConfig - (\flags conf -> conf { legacyLocalConfig = flags })) - legacyPackageConfigFieldDescrs + [ newLineListField + "packages" + (Disp.text . renderPackageLocationToken) + parsePackageLocationTokenQ + legacyPackages + (\v flags -> flags{legacyPackages = v}) + , newLineListField + "optional-packages" + (Disp.text . renderPackageLocationToken) + parsePackageLocationTokenQ + legacyPackagesOptional + (\v flags -> flags{legacyPackagesOptional = v}) + , commaNewLineListFieldParsec + "extra-packages" + pretty + parsec + legacyPackagesNamed + (\v flags -> flags{legacyPackagesNamed = v}) + ] + ++ map + ( liftField + legacySharedConfig + (\flags conf -> conf{legacySharedConfig = flags}) + ) + (legacySharedConfigFieldDescrs constraintSrc) + ++ map + ( liftField + legacyLocalConfig + (\flags conf -> conf{legacyLocalConfig = flags}) + ) + legacyPackageConfigFieldDescrs -- | This is a bit tricky since it has to cover globs which have embedded @,@ -- chars. But we don't just want to parse strictly as a glob since we want to -- allow http urls which don't parse as globs, and possibly some -- system-dependent file paths. So we parse fairly liberally as a token, but -- we allow @,@ inside matched @{}@ braces. --- parsePackageLocationTokenQ :: ReadP r String -parsePackageLocationTokenQ = parseHaskellString - Parse.<++ parsePackageLocationToken +parsePackageLocationTokenQ = + parseHaskellString + Parse.<++ parsePackageLocationToken where parsePackageLocationToken :: ReadP r String parsePackageLocationToken = fmap fst (Parse.gather outerTerm) where - outerTerm = alternateEither1 outerToken (braces innerTerm) - innerTerm = alternateEither innerToken (braces innerTerm) - outerToken = Parse.munch1 outerChar >> return () - innerToken = Parse.munch1 innerChar >> return () + outerTerm = alternateEither1 outerToken (braces innerTerm) + innerTerm = alternateEither innerToken (braces innerTerm) + outerToken = Parse.munch1 outerChar >> return () + innerToken = Parse.munch1 innerChar >> return () outerChar c = not (isSpace c || c == '{' || c == '}' || c == ',') innerChar c = not (isSpace c || c == '{' || c == '}') - braces = Parse.between (Parse.char '{') (Parse.char '}') + braces = Parse.between (Parse.char '{') (Parse.char '}') - alternateEither, alternateEither1, - alternatePQs, alternate1PQs, alternateQsP, alternate1QsP - :: ReadP r () -> ReadP r () -> ReadP r () + alternateEither + , alternateEither1 + , alternatePQs + , alternate1PQs + , alternateQsP + , alternate1QsP + :: ReadP r () -> ReadP r () -> ReadP r () alternateEither1 p q = alternate1PQs p q +++ alternate1QsP q p - alternateEither p q = alternateEither1 p q +++ return () - alternate1PQs p q = p >> alternateQsP q p - alternatePQs p q = alternate1PQs p q +++ return () - alternate1QsP q p = Parse.many1 q >> alternatePQs p q - alternateQsP q p = alternate1QsP q p +++ return () + alternateEither p q = alternateEither1 p q +++ return () + alternate1PQs p q = p >> alternateQsP q p + alternatePQs p q = alternate1PQs p q +++ return () + alternate1QsP q p = Parse.many1 q >> alternatePQs p q + alternateQsP q p = alternate1QsP q p +++ return () renderPackageLocationToken :: String -> String -renderPackageLocationToken s | needsQuoting = show s - | otherwise = s +renderPackageLocationToken s + | needsQuoting = show s + | otherwise = s where - needsQuoting = not (ok 0 s) - || s == "." -- . on its own on a line has special meaning - || take 2 s == "--" -- on its own line is comment syntax - --TODO: [code cleanup] these "." and "--" escaping issues - -- ought to be dealt with systematically in ParseUtils. + needsQuoting = + not (ok 0 s) + || s == "." -- . on its own on a line has special meaning + || take 2 s == "--" -- on its own line is comment syntax + -- TODO: [code cleanup] these "." and "--" escaping issues + -- ought to be dealt with systematically in ParseUtils. ok :: Int -> String -> Bool - ok n [] = n == 0 - ok _ ('"':_) = False - ok n ('{':cs) = ok (n+1) cs - ok n ('}':cs) = ok (n-1) cs - ok n (',':cs) = (n > 0) && ok n cs - ok _ (c:_) + ok n [] = n == 0 + ok _ ('"' : _) = False + ok n ('{' : cs) = ok (n + 1) cs + ok n ('}' : cs) = ok (n - 1) cs + ok n (',' : cs) = (n > 0) && ok n cs + ok _ (c : _) | isSpace c = False - ok n (_ :cs) = ok n cs - + ok n (_ : cs) = ok n cs legacySharedConfigFieldDescrs :: ConstraintSource -> [FieldDescr LegacySharedConfig] -legacySharedConfigFieldDescrs constraintSrc = concat - [ liftFields - legacyGlobalFlags - (\flags conf -> conf { legacyGlobalFlags = flags }) - . addFields - [ newLineListField "extra-prog-path-shared-only" - showTokenQ parseTokenQ - (fromNubList . globalProgPathExtra) - (\v conf -> conf { globalProgPathExtra = toNubList v }) - ] - . filterFields - [ "remote-repo-cache" - , "logs-dir", "store-dir", "ignore-expiry", "http-transport" - , "active-repositories" - ] - . commandOptionsToFields - $ commandOptions (globalCommand []) ParseArgs - - , liftFields - legacyConfigureShFlags - (\flags conf -> conf { legacyConfigureShFlags = flags }) - . addFields - [ commaNewLineListFieldParsec "package-dbs" - (Disp.text . showPackageDb) (fmap readPackageDb parsecToken) - configPackageDBs (\v conf -> conf { configPackageDBs = v }) - ] - . filterFields (["verbose", "builddir"] ++ map optionName installDirsOptions) - . commandOptionsToFields - $ configureOptions ParseArgs - - , liftFields - legacyConfigureExFlags - (\flags conf -> conf { legacyConfigureExFlags = flags }) - . addFields - [ commaNewLineListFieldParsec "constraints" - (pretty . fst) (fmap (\constraint -> (constraint, constraintSrc)) parsec) - configExConstraints (\v conf -> conf { configExConstraints = v }) - - , commaNewLineListFieldParsec "preferences" - pretty parsec - configPreferences (\v conf -> conf { configPreferences = v }) - - , monoidFieldParsec "allow-older" - (maybe mempty pretty) (fmap Just parsec) - (fmap unAllowOlder . configAllowOlder) - (\v conf -> conf { configAllowOlder = fmap AllowOlder v }) - - , monoidFieldParsec "allow-newer" - (maybe mempty pretty) (fmap Just parsec) - (fmap unAllowNewer . configAllowNewer) - (\v conf -> conf { configAllowNewer = fmap AllowNewer v }) - ] - . filterFields - [ "cabal-lib-version", "solver", "write-ghc-environment-files" - -- not "constraint" or "preference", we use our own plural ones above - ] - . commandOptionsToFields - $ configureExOptions ParseArgs constraintSrc - - , liftFields - legacyInstallFlags - (\flags conf -> conf { legacyInstallFlags = flags }) - . addFields - [ newLineListField "build-summary" - (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ) - (fromNubList . installSummaryFile) - (\v conf -> conf { installSummaryFile = toNubList v }) - ] - . filterFields - [ "doc-index-file" - , "root-cmd", "symlink-bindir" - , "build-log" - , "remote-build-reporting", "report-planning-failure" - , "jobs", "keep-going", "offline", "per-component" - -- solver flags: - , "max-backjumps", "reorder-goals", "count-conflicts" - , "fine-grained-conflicts" , "minimize-conflict-set", "independent-goals", "prefer-oldest" - , "strong-flags" , "allow-boot-library-installs" - , "reject-unconstrained-dependencies", "index-state" - ] - . commandOptionsToFields - $ installOptions ParseArgs - - , liftFields - legacyClientInstallFlags - (\flags conf -> conf { legacyClientInstallFlags = flags }) - . commandOptionsToFields - $ clientInstallOptions ParseArgs - - , liftFields - legacyProjectFlags - (\flags conf -> conf { legacyProjectFlags = flags }) - . commandOptionsToFields - $ projectFlagsOptions ParseArgs - - ] - +legacySharedConfigFieldDescrs constraintSrc = + concat + [ liftFields + legacyGlobalFlags + (\flags conf -> conf{legacyGlobalFlags = flags}) + . addFields + [ newLineListField + "extra-prog-path-shared-only" + showTokenQ + parseTokenQ + (fromNubList . globalProgPathExtra) + (\v conf -> conf{globalProgPathExtra = toNubList v}) + ] + . filterFields + [ "remote-repo-cache" + , "logs-dir" + , "store-dir" + , "ignore-expiry" + , "http-transport" + , "active-repositories" + ] + . commandOptionsToFields + $ commandOptions (globalCommand []) ParseArgs + , liftFields + legacyConfigureShFlags + (\flags conf -> conf{legacyConfigureShFlags = flags}) + . addFields + [ commaNewLineListFieldParsec + "package-dbs" + (Disp.text . showPackageDb) + (fmap readPackageDb parsecToken) + configPackageDBs + (\v conf -> conf{configPackageDBs = v}) + ] + . filterFields (["verbose", "builddir"] ++ map optionName installDirsOptions) + . commandOptionsToFields + $ configureOptions ParseArgs + , liftFields + legacyConfigureExFlags + (\flags conf -> conf{legacyConfigureExFlags = flags}) + . addFields + [ commaNewLineListFieldParsec + "constraints" + (pretty . fst) + (fmap (\constraint -> (constraint, constraintSrc)) parsec) + configExConstraints + (\v conf -> conf{configExConstraints = v}) + , commaNewLineListFieldParsec + "preferences" + pretty + parsec + configPreferences + (\v conf -> conf{configPreferences = v}) + , monoidFieldParsec + "allow-older" + (maybe mempty pretty) + (fmap Just parsec) + (fmap unAllowOlder . configAllowOlder) + (\v conf -> conf{configAllowOlder = fmap AllowOlder v}) + , monoidFieldParsec + "allow-newer" + (maybe mempty pretty) + (fmap Just parsec) + (fmap unAllowNewer . configAllowNewer) + (\v conf -> conf{configAllowNewer = fmap AllowNewer v}) + ] + . filterFields + [ "cabal-lib-version" + , "solver" + , "write-ghc-environment-files" + -- not "constraint" or "preference", we use our own plural ones above + ] + . commandOptionsToFields + $ configureExOptions ParseArgs constraintSrc + , liftFields + legacyInstallFlags + (\flags conf -> conf{legacyInstallFlags = flags}) + . addFields + [ newLineListField + "build-summary" + (showTokenQ . fromPathTemplate) + (fmap toPathTemplate parseTokenQ) + (fromNubList . installSummaryFile) + (\v conf -> conf{installSummaryFile = toNubList v}) + ] + . filterFields + [ "doc-index-file" + , "root-cmd" + , "symlink-bindir" + , "build-log" + , "remote-build-reporting" + , "report-planning-failure" + , "jobs" + , "keep-going" + , "offline" + , "per-component" + , -- solver flags: + "max-backjumps" + , "reorder-goals" + , "count-conflicts" + , "fine-grained-conflicts" + , "minimize-conflict-set" + , "independent-goals" + , "prefer-oldest" + , "strong-flags" + , "allow-boot-library-installs" + , "reject-unconstrained-dependencies" + , "index-state" + ] + . commandOptionsToFields + $ installOptions ParseArgs + , liftFields + legacyClientInstallFlags + (\flags conf -> conf{legacyClientInstallFlags = flags}) + . commandOptionsToFields + $ clientInstallOptions ParseArgs + , liftFields + legacyProjectFlags + (\flags conf -> conf{legacyProjectFlags = flags}) + . commandOptionsToFields + $ projectFlagsOptions ParseArgs + ] legacyPackageConfigFieldDescrs :: [FieldDescr LegacyPackageConfig] legacyPackageConfigFieldDescrs = ( liftFields legacyConfigureFlags - (\flags conf -> conf { legacyConfigureFlags = flags }) - . addFields - [ newLineListField "extra-include-dirs" - showTokenQ parseTokenQ - configExtraIncludeDirs - (\v conf -> conf { configExtraIncludeDirs = v }) - , newLineListField "extra-lib-dirs" - showTokenQ parseTokenQ - configExtraLibDirs - (\v conf -> conf { configExtraLibDirs = v }) - , newLineListField "extra-lib-dirs-static" - showTokenQ parseTokenQ - configExtraLibDirsStatic - (\v conf -> conf { configExtraLibDirsStatic = v }) - , newLineListField "extra-framework-dirs" - showTokenQ parseTokenQ - configExtraFrameworkDirs - (\v conf -> conf { configExtraFrameworkDirs = v }) - , newLineListField "extra-prog-path" - showTokenQ parseTokenQ - (fromNubList . configProgramPathExtra) - (\v conf -> conf { configProgramPathExtra = toNubList v }) - , newLineListField "configure-options" - showTokenQ parseTokenQ - configConfigureArgs - (\v conf -> conf { configConfigureArgs = v }) - , simpleFieldParsec "flags" - dispFlagAssignment parsecFlagAssignment - configConfigurationsFlags - (\v conf -> conf { configConfigurationsFlags = v }) - , overrideDumpBuildInfo - ] - . filterFields - [ "with-compiler", "with-hc-pkg" - , "program-prefix", "program-suffix" - , "library-vanilla", "library-profiling" - , "shared", "static", "executable-dynamic", "executable-static" - , "profiling", "executable-profiling" - , "profiling-detail", "library-profiling-detail" - , "library-for-ghci", "split-objs", "split-sections" - , "executable-stripping", "library-stripping" - , "tests", "benchmarks" - , "coverage", "library-coverage" - , "relocatable" + (\flags conf -> conf{legacyConfigureFlags = flags}) + . addFields + [ newLineListField + "extra-include-dirs" + showTokenQ + parseTokenQ + configExtraIncludeDirs + (\v conf -> conf{configExtraIncludeDirs = v}) + , newLineListField + "extra-lib-dirs" + showTokenQ + parseTokenQ + configExtraLibDirs + (\v conf -> conf{configExtraLibDirs = v}) + , newLineListField + "extra-lib-dirs-static" + showTokenQ + parseTokenQ + configExtraLibDirsStatic + (\v conf -> conf{configExtraLibDirsStatic = v}) + , newLineListField + "extra-framework-dirs" + showTokenQ + parseTokenQ + configExtraFrameworkDirs + (\v conf -> conf{configExtraFrameworkDirs = v}) + , newLineListField + "extra-prog-path" + showTokenQ + parseTokenQ + (fromNubList . configProgramPathExtra) + (\v conf -> conf{configProgramPathExtra = toNubList v}) + , newLineListField + "configure-options" + showTokenQ + parseTokenQ + configConfigureArgs + (\v conf -> conf{configConfigureArgs = v}) + , simpleFieldParsec + "flags" + dispFlagAssignment + parsecFlagAssignment + configConfigurationsFlags + (\v conf -> conf{configConfigurationsFlags = v}) + , overrideDumpBuildInfo + ] + . filterFields + [ "with-compiler" + , "with-hc-pkg" + , "program-prefix" + , "program-suffix" + , "library-vanilla" + , "library-profiling" + , "shared" + , "static" + , "executable-dynamic" + , "executable-static" + , "profiling" + , "executable-profiling" + , "profiling-detail" + , "library-profiling-detail" + , "library-for-ghci" + , "split-objs" + , "split-sections" + , "executable-stripping" + , "library-stripping" + , "tests" + , "benchmarks" + , "coverage" + , "library-coverage" + , "relocatable" -- not "extra-include-dirs", "extra-lib-dirs", "extra-framework-dirs" -- or "extra-prog-path". We use corrected ones above that parse -- as list fields. - ] - . commandOptionsToFields - ) (configureOptions ParseArgs) - ++ - liftFields + ] + . commandOptionsToFields + ) + (configureOptions ParseArgs) + ++ liftFields legacyConfigureFlags - (\flags conf -> conf { legacyConfigureFlags = flags }) - [ overrideFieldCompiler - , overrideFieldOptimization - , overrideFieldDebugInfo - ] - ++ - ( liftFields - legacyInstallPkgFlags - (\flags conf -> conf { legacyInstallPkgFlags = flags }) - . filterFields - [ "documentation", "run-tests" - ] - . commandOptionsToFields - ) (installOptions ParseArgs) - ++ - ( liftFields - legacyHaddockFlags - (\flags conf -> conf { legacyHaddockFlags = flags }) - . mapFieldNames - ("haddock-"++) - . addFields - [ simpleFieldParsec "for-hackage" - -- TODO: turn this into a library function - (fromFlagOrDefault Disp.empty . fmap pretty) (toFlag <$> parsec <|> pure mempty) - haddockForHackage (\v conf -> conf { haddockForHackage = v }) - ] - . filterFields - [ "hoogle", "html", "html-location" - , "foreign-libraries" - , "executables", "tests", "benchmarks", "all", "internal", "css" - , "hyperlink-source", "quickjump", "hscolour-css" - , "contents-location", "index-location", "keep-temp-files", "base-url" - , "lib", "output-dir" - ] - . commandOptionsToFields - ) (haddockOptions ParseArgs) - ++ - ( liftFields - legacyTestFlags - (\flags conf -> conf { legacyTestFlags = flags }) - . mapFieldNames - prefixTest - . addFields - [ newLineListField "test-options" - (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ) - testOptions - (\v conf -> conf { testOptions = v }) - ] - . filterFields - [ "log", "machine-log", "show-details", "keep-tix-files" - , "fail-when-no-test-suites", "test-wrapper" ] - . commandOptionsToFields - ) (testOptions' ParseArgs) - ++ - ( liftFields - legacyBenchmarkFlags - (\flags conf -> conf { legacyBenchmarkFlags = flags }) - . addFields - [ newLineListField "benchmark-options" - (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ) - benchmarkOptions - (\v conf -> conf { benchmarkOptions = v }) + (\flags conf -> conf{legacyConfigureFlags = flags}) + [ overrideFieldCompiler + , overrideFieldOptimization + , overrideFieldDebugInfo ] - . filterFields - [] - . commandOptionsToFields - ) (benchmarkOptions' ParseArgs) - + ++ ( liftFields + legacyInstallPkgFlags + (\flags conf -> conf{legacyInstallPkgFlags = flags}) + . filterFields + [ "documentation" + , "run-tests" + ] + . commandOptionsToFields + ) + (installOptions ParseArgs) + ++ ( liftFields + legacyHaddockFlags + (\flags conf -> conf{legacyHaddockFlags = flags}) + . mapFieldNames + ("haddock-" ++) + . addFields + [ simpleFieldParsec + "for-hackage" + -- TODO: turn this into a library function + (fromFlagOrDefault Disp.empty . fmap pretty) + (toFlag <$> parsec <|> pure mempty) + haddockForHackage + (\v conf -> conf{haddockForHackage = v}) + ] + . filterFields + [ "hoogle" + , "html" + , "html-location" + , "foreign-libraries" + , "executables" + , "tests" + , "benchmarks" + , "all" + , "internal" + , "css" + , "hyperlink-source" + , "quickjump" + , "hscolour-css" + , "contents-location" + , "index-location" + , "keep-temp-files" + , "base-url" + , "lib" + , "output-dir" + ] + . commandOptionsToFields + ) + (haddockOptions ParseArgs) + ++ ( liftFields + legacyTestFlags + (\flags conf -> conf{legacyTestFlags = flags}) + . mapFieldNames + prefixTest + . addFields + [ newLineListField + "test-options" + (showTokenQ . fromPathTemplate) + (fmap toPathTemplate parseTokenQ) + testOptions + (\v conf -> conf{testOptions = v}) + ] + . filterFields + [ "log" + , "machine-log" + , "show-details" + , "keep-tix-files" + , "fail-when-no-test-suites" + , "test-wrapper" + ] + . commandOptionsToFields + ) + (testOptions' ParseArgs) + ++ ( liftFields + legacyBenchmarkFlags + (\flags conf -> conf{legacyBenchmarkFlags = flags}) + . addFields + [ newLineListField + "benchmark-options" + (showTokenQ . fromPathTemplate) + (fmap toPathTemplate parseTokenQ) + benchmarkOptions + (\v conf -> conf{benchmarkOptions = v}) + ] + . filterFields + [] + . commandOptionsToFields + ) + (benchmarkOptions' ParseArgs) where overrideFieldCompiler = - simpleFieldParsec "compiler" + simpleFieldParsec + "compiler" (fromFlagOrDefault Disp.empty . fmap pretty) (toFlag <$> parsec <|> pure mempty) - configHcFlavor (\v flags -> flags { configHcFlavor = v }) + configHcFlavor + (\v flags -> flags{configHcFlavor = v}) overrideDumpBuildInfo = - liftField configDumpBuildInfo - (\v flags -> flags { configDumpBuildInfo = v }) $ - let name = "build-info" in - FieldDescr name - (\f -> case f of - Flag NoDumpBuildInfo -> Disp.text "False" - Flag DumpBuildInfo -> Disp.text "True" - _ -> Disp.empty) - (\line str _ -> case () of - _ | str == "False" -> ParseOk [] (Flag NoDumpBuildInfo) - | str == "True" -> ParseOk [] (Flag DumpBuildInfo) - | lstr == "false" -> ParseOk [caseWarning name] (Flag NoDumpBuildInfo) - | lstr == "true" -> ParseOk [caseWarning name] (Flag DumpBuildInfo) - | otherwise -> ParseFailed (NoParse name line) - where - lstr = lowercase str) + liftField + configDumpBuildInfo + (\v flags -> flags{configDumpBuildInfo = v}) + $ let name = "build-info" + in FieldDescr + name + ( \f -> case f of + Flag NoDumpBuildInfo -> Disp.text "False" + Flag DumpBuildInfo -> Disp.text "True" + _ -> Disp.empty + ) + ( \line str _ -> case () of + _ + | str == "False" -> ParseOk [] (Flag NoDumpBuildInfo) + | str == "True" -> ParseOk [] (Flag DumpBuildInfo) + | lstr == "false" -> ParseOk [caseWarning name] (Flag NoDumpBuildInfo) + | lstr == "true" -> ParseOk [caseWarning name] (Flag DumpBuildInfo) + | otherwise -> ParseFailed (NoParse name line) + where + lstr = lowercase str + ) -- TODO: [code cleanup] The following is a hack. The "optimization" and -- "debug-info" fields are OptArg, and viewAsFieldDescr fails on that. @@ -1374,224 +1619,256 @@ legacyPackageConfigFieldDescrs = -- properly in the library. overrideFieldOptimization = - liftField configOptimization - (\v flags -> flags { configOptimization = v }) $ - let name = "optimization" in - FieldDescr name - (\f -> case f of - Flag NoOptimisation -> Disp.text "False" - Flag NormalOptimisation -> Disp.text "True" - Flag MaximumOptimisation -> Disp.text "2" - _ -> Disp.empty) - (\line str _ -> case () of - _ | str == "False" -> ParseOk [] (Flag NoOptimisation) - | str == "True" -> ParseOk [] (Flag NormalOptimisation) - | str == "0" -> ParseOk [] (Flag NoOptimisation) - | str == "1" -> ParseOk [] (Flag NormalOptimisation) - | str == "2" -> ParseOk [] (Flag MaximumOptimisation) - | lstr == "false" -> ParseOk [caseWarning name] (Flag NoOptimisation) - | lstr == "true" -> ParseOk [caseWarning name] (Flag NormalOptimisation) - | otherwise -> ParseFailed (NoParse name line) - where - lstr = lowercase str) + liftField + configOptimization + (\v flags -> flags{configOptimization = v}) + $ let name = "optimization" + in FieldDescr + name + ( \f -> case f of + Flag NoOptimisation -> Disp.text "False" + Flag NormalOptimisation -> Disp.text "True" + Flag MaximumOptimisation -> Disp.text "2" + _ -> Disp.empty + ) + ( \line str _ -> case () of + _ + | str == "False" -> ParseOk [] (Flag NoOptimisation) + | str == "True" -> ParseOk [] (Flag NormalOptimisation) + | str == "0" -> ParseOk [] (Flag NoOptimisation) + | str == "1" -> ParseOk [] (Flag NormalOptimisation) + | str == "2" -> ParseOk [] (Flag MaximumOptimisation) + | lstr == "false" -> ParseOk [caseWarning name] (Flag NoOptimisation) + | lstr == "true" -> ParseOk [caseWarning name] (Flag NormalOptimisation) + | otherwise -> ParseFailed (NoParse name line) + where + lstr = lowercase str + ) overrideFieldDebugInfo = - liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $ - let name = "debug-info" in - FieldDescr name - (\f -> case f of - Flag NoDebugInfo -> Disp.text "False" - Flag MinimalDebugInfo -> Disp.text "1" - Flag NormalDebugInfo -> Disp.text "True" - Flag MaximalDebugInfo -> Disp.text "3" - _ -> Disp.empty) - (\line str _ -> case () of - _ | str == "False" -> ParseOk [] (Flag NoDebugInfo) - | str == "True" -> ParseOk [] (Flag NormalDebugInfo) - | str == "0" -> ParseOk [] (Flag NoDebugInfo) - | str == "1" -> ParseOk [] (Flag MinimalDebugInfo) - | str == "2" -> ParseOk [] (Flag NormalDebugInfo) - | str == "3" -> ParseOk [] (Flag MaximalDebugInfo) - | lstr == "false" -> ParseOk [caseWarning name] (Flag NoDebugInfo) - | lstr == "true" -> ParseOk [caseWarning name] (Flag NormalDebugInfo) - | otherwise -> ParseFailed (NoParse name line) - where - lstr = lowercase str) - - caseWarning name = PWarning $ - "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'." - - prefixTest name | "test-" `isPrefixOf` name = name - | otherwise = "test-" ++ name - + liftField configDebugInfo (\v flags -> flags{configDebugInfo = v}) $ + let name = "debug-info" + in FieldDescr + name + ( \f -> case f of + Flag NoDebugInfo -> Disp.text "False" + Flag MinimalDebugInfo -> Disp.text "1" + Flag NormalDebugInfo -> Disp.text "True" + Flag MaximalDebugInfo -> Disp.text "3" + _ -> Disp.empty + ) + ( \line str _ -> case () of + _ + | str == "False" -> ParseOk [] (Flag NoDebugInfo) + | str == "True" -> ParseOk [] (Flag NormalDebugInfo) + | str == "0" -> ParseOk [] (Flag NoDebugInfo) + | str == "1" -> ParseOk [] (Flag MinimalDebugInfo) + | str == "2" -> ParseOk [] (Flag NormalDebugInfo) + | str == "3" -> ParseOk [] (Flag MaximalDebugInfo) + | lstr == "false" -> ParseOk [caseWarning name] (Flag NoDebugInfo) + | lstr == "true" -> ParseOk [caseWarning name] (Flag NormalDebugInfo) + | otherwise -> ParseFailed (NoParse name line) + where + lstr = lowercase str + ) + + caseWarning name = + PWarning $ + "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'." + + prefixTest name + | "test-" `isPrefixOf` name = name + | otherwise = "test-" ++ name legacyPackageConfigFGSectionDescrs - :: ( FieldGrammar c g, Applicative (g SourceRepoList) - , c (Identity RepoType) - , c (List NoCommaFSep FilePathNT String) - , c (NonEmpty' NoCommaFSep Token String) - ) - => [FGSectionDescr g LegacyProjectConfig] + :: ( FieldGrammar c g + , Applicative (g SourceRepoList) + , c (Identity RepoType) + , c (List NoCommaFSep FilePathNT String) + , c (NonEmpty' NoCommaFSep Token String) + ) + => [FGSectionDescr g LegacyProjectConfig] legacyPackageConfigFGSectionDescrs = - [ packageRepoSectionDescr - ] + [ packageRepoSectionDescr + ] legacyPackageConfigSectionDescrs :: [SectionDescr LegacyProjectConfig] legacyPackageConfigSectionDescrs = - [ packageSpecificOptionsSectionDescr - , liftSection - legacyLocalConfig - (\flags conf -> conf { legacyLocalConfig = flags }) - programOptionsSectionDescr - , liftSection - legacyLocalConfig - (\flags conf -> conf { legacyLocalConfig = flags }) - programLocationsSectionDescr - , liftSection - legacySharedConfig - (\flags conf -> conf { legacySharedConfig = flags }) $ - liftSection + [ packageSpecificOptionsSectionDescr + , liftSection + legacyLocalConfig + (\flags conf -> conf{legacyLocalConfig = flags}) + programOptionsSectionDescr + , liftSection + legacyLocalConfig + (\flags conf -> conf{legacyLocalConfig = flags}) + programLocationsSectionDescr + , liftSection + legacySharedConfig + (\flags conf -> conf{legacySharedConfig = flags}) + $ liftSection legacyGlobalFlags - (\flags conf -> conf { legacyGlobalFlags = flags }) + (\flags conf -> conf{legacyGlobalFlags = flags}) remoteRepoSectionDescr - ] + ] packageRepoSectionDescr - :: ( FieldGrammar c g, Applicative (g SourceRepoList) - , c (Identity RepoType) - , c (List NoCommaFSep FilePathNT String) - , c (NonEmpty' NoCommaFSep Token String) - ) - => FGSectionDescr g LegacyProjectConfig -packageRepoSectionDescr = FGSectionDescr - { fgSectionName = "source-repository-package" - , fgSectionGrammar = sourceRepositoryPackageGrammar - , fgSectionGet = map (\x->("", x)) . legacyPackagesRepo - , fgSectionSet = + :: ( FieldGrammar c g + , Applicative (g SourceRepoList) + , c (Identity RepoType) + , c (List NoCommaFSep FilePathNT String) + , c (NonEmpty' NoCommaFSep Token String) + ) + => FGSectionDescr g LegacyProjectConfig +packageRepoSectionDescr = + FGSectionDescr + { fgSectionName = "source-repository-package" + , fgSectionGrammar = sourceRepositoryPackageGrammar + , fgSectionGet = map (\x -> ("", x)) . legacyPackagesRepo + , fgSectionSet = \lineno unused pkgrepo projconf -> do unless (null unused) $ syntaxError lineno "the section 'source-repository-package' takes no arguments" - return projconf { - legacyPackagesRepo = legacyPackagesRepo projconf ++ [pkgrepo] - } - } + return + projconf + { legacyPackagesRepo = legacyPackagesRepo projconf ++ [pkgrepo] + } + } -- | The definitions of all the fields that can appear in the @package pkgfoo@ -- and @package *@ sections of the @cabal.project@-format files. --- packageSpecificOptionsFieldDescrs :: [FieldDescr LegacyPackageConfig] packageSpecificOptionsFieldDescrs = - legacyPackageConfigFieldDescrs - ++ programOptionsFieldDescrs + legacyPackageConfigFieldDescrs + ++ programOptionsFieldDescrs (configProgramArgs . legacyConfigureFlags) - (\args pkgconf -> pkgconf { - legacyConfigureFlags = (legacyConfigureFlags pkgconf) { - configProgramArgs = args - } - } + ( \args pkgconf -> + pkgconf + { legacyConfigureFlags = + (legacyConfigureFlags pkgconf) + { configProgramArgs = args + } + } ) - ++ liftFields + ++ liftFields legacyConfigureFlags - (\flags pkgconf -> pkgconf { - legacyConfigureFlags = flags - } + ( \flags pkgconf -> + pkgconf + { legacyConfigureFlags = flags + } ) programLocationsFieldDescrs -- | The definition of the @package pkgfoo@ sections of the @cabal.project@-format -- files. This section is per-package name. The special package @*@ applies to all -- packages used anywhere by the project, locally or as dependencies. --- packageSpecificOptionsSectionDescr :: SectionDescr LegacyProjectConfig packageSpecificOptionsSectionDescr = - SectionDescr { - sectionName = "package", - sectionFields = packageSpecificOptionsFieldDescrs, - sectionSubsections = [], - sectionGet = \projconf -> - [ (prettyShow pkgname, pkgconf) - | (pkgname, pkgconf) <- - Map.toList . getMapMappend - . legacySpecificConfig $ projconf ] - ++ [ ("*", legacyAllConfig projconf) ], - sectionSet = + SectionDescr + { sectionName = "package" + , sectionFields = packageSpecificOptionsFieldDescrs + , sectionSubsections = [] + , sectionGet = \projconf -> + [ (prettyShow pkgname, pkgconf) + | (pkgname, pkgconf) <- + Map.toList + . getMapMappend + . legacySpecificConfig + $ projconf + ] + ++ [("*", legacyAllConfig projconf)] + , sectionSet = \lineno pkgnamestr pkgconf projconf -> case pkgnamestr of - "*" -> return projconf { - legacyAllConfig = legacyAllConfig projconf <> pkgconf - } - _ -> do + "*" -> + return + projconf + { legacyAllConfig = legacyAllConfig projconf <> pkgconf + } + _ -> do pkgname <- case simpleParsec pkgnamestr of Just pkgname -> return pkgname - Nothing -> syntaxError lineno $ - "a 'package' section requires a package name " - ++ "as an argument" - return projconf { - legacySpecificConfig = - MapMappend $ - Map.insertWith mappend pkgname pkgconf - (getMapMappend $ legacySpecificConfig projconf) - }, - sectionEmpty = mempty + Nothing -> + syntaxError lineno $ + "a 'package' section requires a package name " + ++ "as an argument" + return + projconf + { legacySpecificConfig = + MapMappend $ + Map.insertWith + mappend + pkgname + pkgconf + (getMapMappend $ legacySpecificConfig projconf) + } + , sectionEmpty = mempty } -programOptionsFieldDescrs :: (a -> [(String, [String])]) - -> ([(String, [String])] -> a -> a) - -> [FieldDescr a] +programOptionsFieldDescrs + :: (a -> [(String, [String])]) + -> ([(String, [String])] -> a -> a) + -> [FieldDescr a] programOptionsFieldDescrs get' set = - commandOptionsToFields - $ programDbOptions + commandOptionsToFields $ + programDbOptions defaultProgramDb - ParseArgs get' set + ParseArgs + get' + set programOptionsSectionDescr :: SectionDescr LegacyPackageConfig programOptionsSectionDescr = - SectionDescr { - sectionName = "program-options", - sectionFields = programOptionsFieldDescrs - configProgramArgs - (\args conf -> conf { configProgramArgs = args }), - sectionSubsections = [], - sectionGet = (\x->[("", x)]) - . legacyConfigureFlags, - sectionSet = + SectionDescr + { sectionName = "program-options" + , sectionFields = + programOptionsFieldDescrs + configProgramArgs + (\args conf -> conf{configProgramArgs = args}) + , sectionSubsections = [] + , sectionGet = + (\x -> [("", x)]) + . legacyConfigureFlags + , sectionSet = \lineno unused confflags pkgconf -> do unless (null unused) $ syntaxError lineno "the section 'program-options' takes no arguments" - return pkgconf { - legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags - }, - sectionEmpty = mempty + return + pkgconf + { legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags + } + , sectionEmpty = mempty } programLocationsFieldDescrs :: [FieldDescr ConfigFlags] programLocationsFieldDescrs = - commandOptionsToFields - $ programDbPaths' - (++ "-location") - defaultProgramDb - ParseArgs - configProgramPaths - (\paths conf -> conf { configProgramPaths = paths }) + commandOptionsToFields $ + programDbPaths' + (++ "-location") + defaultProgramDb + ParseArgs + configProgramPaths + (\paths conf -> conf{configProgramPaths = paths}) programLocationsSectionDescr :: SectionDescr LegacyPackageConfig programLocationsSectionDescr = - SectionDescr { - sectionName = "program-locations", - sectionFields = programLocationsFieldDescrs, - sectionSubsections = [], - sectionGet = (\x->[("", x)]) - . legacyConfigureFlags, - sectionSet = + SectionDescr + { sectionName = "program-locations" + , sectionFields = programLocationsFieldDescrs + , sectionSubsections = [] + , sectionGet = + (\x -> [("", x)]) + . legacyConfigureFlags + , sectionSet = \lineno unused confflags pkgconf -> do unless (null unused) $ syntaxError lineno "the section 'program-locations' takes no arguments" - return pkgconf { - legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags - }, - sectionEmpty = mempty + return + pkgconf + { legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags + } + , sectionEmpty = mempty } - -- | For each known program @PROG@ in 'progDb', produce a @PROG-options@ -- 'OptionField'. programDbOptions @@ -1603,55 +1880,71 @@ programDbOptions programDbOptions progDb showOrParseArgs get' set = case showOrParseArgs of -- we don't want a verbose help text list so we just show a generic one: - ShowArgs -> [programOptions "PROG"] - ParseArgs -> map (programOptions . programName . fst) - (knownPrograms progDb) + ShowArgs -> [programOptions "PROG"] + ParseArgs -> + map + (programOptions . programName . fst) + (knownPrograms progDb) where programOptions prog = - option "" [prog ++ "-options"] + option + "" + [prog ++ "-options"] ("give extra options to " ++ prog) - get' set - (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) - (\progArgs -> [ joinsArgs args - | (prog', args) <- progArgs, prog==prog' ])) - + get' + set + ( reqArg' + "OPTS" + (\args -> [(prog, splitArgs args)]) + ( \progArgs -> + [ joinsArgs args + | (prog', args) <- progArgs + , prog == prog' + ] + ) + ) joinsArgs = unwords . map escape - escape arg | any isSpace arg = "\"" ++ arg ++ "\"" - | otherwise = arg - + escape arg + | any isSpace arg = "\"" ++ arg ++ "\"" + | otherwise = arg -- The implementation is slight hack: we parse all as remote repository -- but if the url schema is file+noindex, we switch to local. remoteRepoSectionDescr :: SectionDescr GlobalFlags -remoteRepoSectionDescr = SectionDescr - { sectionName = "repository" - , sectionEmpty = emptyRemoteRepo (RepoName "") - , sectionFields = remoteRepoFields +remoteRepoSectionDescr = + SectionDescr + { sectionName = "repository" + , sectionEmpty = emptyRemoteRepo (RepoName "") + , sectionFields = remoteRepoFields , sectionSubsections = [] - , sectionGet = getS - , sectionSet = setS + , sectionGet = getS + , sectionSet = setS } where getS :: GlobalFlags -> [(String, RemoteRepo)] getS gf = - map (\x->(unRepoName $ remoteRepoName x, x)) (fromNubList (globalRemoteRepos gf)) - ++ - map (\x->(unRepoName $ localRepoName x, localToRemote x)) (fromNubList (globalLocalNoIndexRepos gf)) + map (\x -> (unRepoName $ remoteRepoName x, x)) (fromNubList (globalRemoteRepos gf)) + ++ map (\x -> (unRepoName $ localRepoName x, localToRemote x)) (fromNubList (globalLocalNoIndexRepos gf)) setS :: Int -> String -> RemoteRepo -> GlobalFlags -> ParseResult GlobalFlags setS lineno reponame repo0 conf = do - repo1 <- postProcessRepo lineno reponame repo0 - case repo1 of - Left repo -> return conf - { globalLocalNoIndexRepos = overNubList (++[repo]) (globalLocalNoIndexRepos conf) - } - Right repo -> return conf - { globalRemoteRepos = overNubList (++[repo]) (globalRemoteRepos conf) - } + repo1 <- postProcessRepo lineno reponame repo0 + case repo1 of + Left repo -> + return + conf + { globalLocalNoIndexRepos = overNubList (++ [repo]) (globalLocalNoIndexRepos conf) + } + Right repo -> + return + conf + { globalRemoteRepos = overNubList (++ [repo]) (globalRemoteRepos conf) + } localToRemote :: LocalRepo -> RemoteRepo - localToRemote (LocalRepo name path sharedCache) = (emptyRemoteRepo name) + localToRemote (LocalRepo name path sharedCache) = + (emptyRemoteRepo name) { remoteRepoURI = URI "file+noindex:" Nothing path "" (if sharedCache then "#shared-cache" else "") } @@ -1662,25 +1955,29 @@ remoteRepoSectionDescr = SectionDescr -- | Parser combinator for simple fields which uses the field type's -- 'Monoid' instance for combining multiple occurrences of the field. monoidFieldParsec - :: Monoid a => String -> (a -> Doc) -> ParsecParser a - -> (b -> a) -> (a -> b -> b) -> FieldDescr b + :: Monoid a + => String + -> (a -> Doc) + -> ParsecParser a + -> (b -> a) + -> (a -> b -> b) + -> FieldDescr b monoidFieldParsec name showF readF get' set = liftField get' set' $ ParseUtils.fieldParsec name showF readF where set' xs b = set (get' b `mappend` xs) b - ---TODO: [code cleanup] local redefinition that should replace the version in +-- TODO: [code cleanup] local redefinition that should replace the version in -- D.ParseUtils called showFilePath. This version escapes "." and "--" which -- otherwise are special syntax. showTokenQ :: String -> Doc -showTokenQ "" = Disp.empty -showTokenQ x@('-':'-':_) = Disp.text (show x) -showTokenQ x@('.':[]) = Disp.text (show x) -showTokenQ x = showToken x - +showTokenQ "" = Disp.empty +showTokenQ x@('-' : '-' : _) = Disp.text (show x) +showTokenQ x@('.' : []) = Disp.text (show x) +showTokenQ x = showToken x -- Handy util -addFields :: [FieldDescr a] - -> ([FieldDescr a] -> [FieldDescr a]) +addFields + :: [FieldDescr a] + -> ([FieldDescr a] -> [FieldDescr a]) addFields = (++) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs index 991551b9545..f5f7c4f1514 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs @@ -1,69 +1,94 @@ -{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Handling project configuration, types. --- -module Distribution.Client.ProjectConfig.Types ( - - -- * Types for project config - ProjectConfig(..), - ProjectConfigBuildOnly(..), - ProjectConfigShared(..), - ProjectConfigProvenance(..), - PackageConfig(..), +module Distribution.Client.ProjectConfig.Types + ( -- * Types for project config + ProjectConfig (..) + , ProjectConfigBuildOnly (..) + , ProjectConfigShared (..) + , ProjectConfigProvenance (..) + , PackageConfig (..) -- * Resolving configuration - SolverSettings(..), - BuildTimeSettings(..), + , SolverSettings (..) + , BuildTimeSettings (..) -- * Extra useful Monoids - MapLast(..), - MapMappend(..), + , MapLast (..) + , MapMappend (..) ) where import Distribution.Client.Compat.Prelude import Prelude () -import Distribution.Client.Types.Repo ( RemoteRepo, LocalRepo ) -import Distribution.Client.Types.AllowNewer ( AllowNewer(..), AllowOlder(..) ) -import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy ( WriteGhcEnvironmentFilesPolicy ) +import Distribution.Client.BuildReports.Types + ( ReportLevel (..) + ) import Distribution.Client.Dependency.Types - ( PreSolver ) + ( PreSolver + ) import Distribution.Client.Targets - ( UserConstraint ) -import Distribution.Client.BuildReports.Types - ( ReportLevel(..) ) + ( UserConstraint + ) +import Distribution.Client.Types.AllowNewer (AllowNewer (..), AllowOlder (..)) +import Distribution.Client.Types.Repo (LocalRepo, RemoteRepo) import Distribution.Client.Types.SourceRepo (SourceRepoList) +import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy (WriteGhcEnvironmentFilesPolicy) -import Distribution.Client.IndexUtils.IndexState - ( TotalIndexState ) import Distribution.Client.IndexUtils.ActiveRepos - ( ActiveRepos ) + ( ActiveRepos + ) +import Distribution.Client.IndexUtils.IndexState + ( TotalIndexState + ) import Distribution.Client.CmdInstall.ClientInstallFlags - ( ClientInstallFlags(..) ) + ( ClientInstallFlags (..) + ) -import Distribution.Solver.Types.Settings import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.Settings import Distribution.Package - ( PackageName, PackageId, UnitId ) -import Distribution.Types.PackageVersionConstraint - ( PackageVersionConstraint ) -import Distribution.Version - ( Version ) -import Distribution.System - ( Platform ) + ( PackageId + , PackageName + , UnitId + ) import Distribution.PackageDescription - ( FlagAssignment ) + ( FlagAssignment + ) import Distribution.Simple.Compiler - ( Compiler, CompilerFlavor, PackageDB - , OptimisationLevel(..), ProfDetailLevel, DebugInfoLevel(..) ) -import Distribution.Simple.Setup - ( Flag, HaddockTarget(..), TestShowDetails(..), DumpBuildInfo (..) ) + ( Compiler + , CompilerFlavor + , DebugInfoLevel (..) + , OptimisationLevel (..) + , PackageDB + , ProfDetailLevel + ) import Distribution.Simple.InstallDirs - ( PathTemplate, InstallDirs ) + ( InstallDirs + , PathTemplate + ) +import Distribution.Simple.Setup + ( DumpBuildInfo (..) + , Flag + , HaddockTarget (..) + , TestShowDetails (..) + ) +import Distribution.System + ( Platform + ) +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint + ) import Distribution.Utils.NubList - ( NubList ) + ( NubList + ) +import Distribution.Version + ( Version + ) import qualified Data.Map as Map @@ -87,223 +112,199 @@ import qualified Data.Map as Map -- Future directions: multiple profiles, conditionals. If we add these -- features then the gap between configuration as written in the config file -- and resolved settings we actually use will become even bigger. --- -data ProjectConfig - = ProjectConfig { - - -- | Packages in this project, including local dirs, local .cabal files - -- local and remote tarballs. When these are file globs, they must - -- match at least one package. - projectPackages :: [String], - - -- | Like 'projectConfigPackageGlobs' but /optional/ in the sense that - -- file globs are allowed to match nothing. The primary use case for - -- this is to be able to say @optional-packages: */@ to automagically - -- pick up deps that we unpack locally without erroring when - -- there aren't any. - projectPackagesOptional :: [String], - - -- | Packages in this project from remote source repositories. - projectPackagesRepo :: [SourceRepoList], - - -- | Packages in this project from hackage repositories. - projectPackagesNamed :: [PackageVersionConstraint], - - -- See respective types for an explanation of what these - -- values are about: - projectConfigBuildOnly :: ProjectConfigBuildOnly, - projectConfigShared :: ProjectConfigShared, - projectConfigProvenance :: Set ProjectConfigProvenance, - - -- | Configuration to be applied to *all* packages, - -- whether named in `cabal.project` or not. - projectConfigAllPackages :: PackageConfig, - - -- | Configuration to be applied to *local* packages; i.e., - -- any packages which are explicitly named in `cabal.project`. - projectConfigLocalPackages :: PackageConfig, - projectConfigSpecificPackage :: MapMappend PackageName PackageConfig - } +data ProjectConfig = ProjectConfig + { projectPackages :: [String] + -- ^ Packages in this project, including local dirs, local .cabal files + -- local and remote tarballs. When these are file globs, they must + -- match at least one package. + , projectPackagesOptional :: [String] + -- ^ Like 'projectConfigPackageGlobs' but /optional/ in the sense that + -- file globs are allowed to match nothing. The primary use case for + -- this is to be able to say @optional-packages: */@ to automagically + -- pick up deps that we unpack locally without erroring when + -- there aren't any. + , projectPackagesRepo :: [SourceRepoList] + -- ^ Packages in this project from remote source repositories. + , projectPackagesNamed :: [PackageVersionConstraint] + -- ^ Packages in this project from hackage repositories. + , -- See respective types for an explanation of what these + -- values are about: + projectConfigBuildOnly :: ProjectConfigBuildOnly + , projectConfigShared :: ProjectConfigShared + , projectConfigProvenance :: Set ProjectConfigProvenance + , projectConfigAllPackages :: PackageConfig + -- ^ Configuration to be applied to *all* packages, + -- whether named in `cabal.project` or not. + , projectConfigLocalPackages :: PackageConfig + -- ^ Configuration to be applied to *local* packages; i.e., + -- any packages which are explicitly named in `cabal.project`. + , projectConfigSpecificPackage :: MapMappend PackageName PackageConfig + } deriving (Eq, Show, Generic, Typeable) -- | That part of the project configuration that only affects /how/ we build -- and not the /value/ of the things we build. This means this information -- does not need to be tracked for changes since it does not affect the -- outcome. --- -data ProjectConfigBuildOnly - = ProjectConfigBuildOnly { - projectConfigVerbosity :: Flag Verbosity, - projectConfigDryRun :: Flag Bool, - projectConfigOnlyDeps :: Flag Bool, - projectConfigOnlyDownload :: Flag Bool, - projectConfigSummaryFile :: NubList PathTemplate, - projectConfigLogFile :: Flag PathTemplate, - projectConfigBuildReports :: Flag ReportLevel, - projectConfigReportPlanningFailure :: Flag Bool, - projectConfigSymlinkBinDir :: Flag FilePath, - projectConfigNumJobs :: Flag (Maybe Int), - projectConfigKeepGoing :: Flag Bool, - projectConfigOfflineMode :: Flag Bool, - projectConfigKeepTempFiles :: Flag Bool, - projectConfigHttpTransport :: Flag String, - projectConfigIgnoreExpiry :: Flag Bool, - projectConfigCacheDir :: Flag FilePath, - projectConfigLogsDir :: Flag FilePath, - projectConfigClientInstallFlags :: ClientInstallFlags - } +data ProjectConfigBuildOnly = ProjectConfigBuildOnly + { projectConfigVerbosity :: Flag Verbosity + , projectConfigDryRun :: Flag Bool + , projectConfigOnlyDeps :: Flag Bool + , projectConfigOnlyDownload :: Flag Bool + , projectConfigSummaryFile :: NubList PathTemplate + , projectConfigLogFile :: Flag PathTemplate + , projectConfigBuildReports :: Flag ReportLevel + , projectConfigReportPlanningFailure :: Flag Bool + , projectConfigSymlinkBinDir :: Flag FilePath + , projectConfigNumJobs :: Flag (Maybe Int) + , projectConfigKeepGoing :: Flag Bool + , projectConfigOfflineMode :: Flag Bool + , projectConfigKeepTempFiles :: Flag Bool + , projectConfigHttpTransport :: Flag String + , projectConfigIgnoreExpiry :: Flag Bool + , projectConfigCacheDir :: Flag FilePath + , projectConfigLogsDir :: Flag FilePath + , projectConfigClientInstallFlags :: ClientInstallFlags + } deriving (Eq, Show, Generic) - -- | Project configuration that is shared between all packages in the project. -- In particular this includes configuration that affects the solver. --- -data ProjectConfigShared - = ProjectConfigShared { - projectConfigDistDir :: Flag FilePath, - projectConfigConfigFile :: Flag FilePath, - projectConfigProjectDir :: Flag FilePath, - projectConfigProjectFile :: Flag FilePath, - projectConfigIgnoreProject :: Flag Bool, - projectConfigHcFlavor :: Flag CompilerFlavor, - projectConfigHcPath :: Flag FilePath, - projectConfigHcPkg :: Flag FilePath, - projectConfigHaddockIndex :: Flag PathTemplate, - - -- Only makes sense for manual mode, not --local mode - -- too much control! - --projectConfigUserInstall :: Flag Bool, - - projectConfigInstallDirs :: InstallDirs (Flag PathTemplate), - projectConfigPackageDBs :: [Maybe PackageDB], - - -- configuration used both by the solver and other phases - projectConfigRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers. - projectConfigLocalNoIndexRepos :: NubList LocalRepo, - projectConfigActiveRepos :: Flag ActiveRepos, - projectConfigIndexState :: Flag TotalIndexState, - projectConfigStoreDir :: Flag FilePath, - - -- solver configuration - projectConfigConstraints :: [(UserConstraint, ConstraintSource)], - projectConfigPreferences :: [PackageVersionConstraint], - projectConfigCabalVersion :: Flag Version, --TODO: [required eventually] unused - projectConfigSolver :: Flag PreSolver, - projectConfigAllowOlder :: Maybe AllowOlder, - projectConfigAllowNewer :: Maybe AllowNewer, - projectConfigWriteGhcEnvironmentFilesPolicy - :: Flag WriteGhcEnvironmentFilesPolicy, - projectConfigMaxBackjumps :: Flag Int, - projectConfigReorderGoals :: Flag ReorderGoals, - projectConfigCountConflicts :: Flag CountConflicts, - projectConfigFineGrainedConflicts :: Flag FineGrainedConflicts, - projectConfigMinimizeConflictSet :: Flag MinimizeConflictSet, - projectConfigStrongFlags :: Flag StrongFlags, - projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls, - projectConfigOnlyConstrained :: Flag OnlyConstrained, - projectConfigPerComponent :: Flag Bool, - projectConfigIndependentGoals :: Flag IndependentGoals, - projectConfigPreferOldest :: Flag PreferOldest, - - projectConfigProgPathExtra :: NubList FilePath - - -- More things that only make sense for manual mode, not --local mode - -- too much control! - --projectConfigShadowPkgs :: Flag Bool, - --projectConfigReinstall :: Flag Bool, - --projectConfigAvoidReinstalls :: Flag Bool, - --projectConfigOverrideReinstall :: Flag Bool, - --projectConfigUpgradeDeps :: Flag Bool - } +data ProjectConfigShared = ProjectConfigShared + { projectConfigDistDir :: Flag FilePath + , projectConfigConfigFile :: Flag FilePath + , projectConfigProjectDir :: Flag FilePath + , projectConfigProjectFile :: Flag FilePath + , projectConfigIgnoreProject :: Flag Bool + , projectConfigHcFlavor :: Flag CompilerFlavor + , projectConfigHcPath :: Flag FilePath + , projectConfigHcPkg :: Flag FilePath + , projectConfigHaddockIndex :: Flag PathTemplate + , -- Only makes sense for manual mode, not --local mode + -- too much control! + -- projectConfigUserInstall :: Flag Bool, + + projectConfigInstallDirs :: InstallDirs (Flag PathTemplate) + , projectConfigPackageDBs :: [Maybe PackageDB] + , -- configuration used both by the solver and other phases + projectConfigRemoteRepos :: NubList RemoteRepo + -- ^ Available Hackage servers. + , projectConfigLocalNoIndexRepos :: NubList LocalRepo + , projectConfigActiveRepos :: Flag ActiveRepos + , projectConfigIndexState :: Flag TotalIndexState + , projectConfigStoreDir :: Flag FilePath + , -- solver configuration + projectConfigConstraints :: [(UserConstraint, ConstraintSource)] + , projectConfigPreferences :: [PackageVersionConstraint] + , projectConfigCabalVersion :: Flag Version -- TODO: [required eventually] unused + , projectConfigSolver :: Flag PreSolver + , projectConfigAllowOlder :: Maybe AllowOlder + , projectConfigAllowNewer :: Maybe AllowNewer + , projectConfigWriteGhcEnvironmentFilesPolicy + :: Flag WriteGhcEnvironmentFilesPolicy + , projectConfigMaxBackjumps :: Flag Int + , projectConfigReorderGoals :: Flag ReorderGoals + , projectConfigCountConflicts :: Flag CountConflicts + , projectConfigFineGrainedConflicts :: Flag FineGrainedConflicts + , projectConfigMinimizeConflictSet :: Flag MinimizeConflictSet + , projectConfigStrongFlags :: Flag StrongFlags + , projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls + , projectConfigOnlyConstrained :: Flag OnlyConstrained + , projectConfigPerComponent :: Flag Bool + , projectConfigIndependentGoals :: Flag IndependentGoals + , projectConfigPreferOldest :: Flag PreferOldest + , projectConfigProgPathExtra :: NubList FilePath + -- More things that only make sense for manual mode, not --local mode + -- too much control! + -- projectConfigShadowPkgs :: Flag Bool, + -- projectConfigReinstall :: Flag Bool, + -- projectConfigAvoidReinstalls :: Flag Bool, + -- projectConfigOverrideReinstall :: Flag Bool, + -- projectConfigUpgradeDeps :: Flag Bool + } deriving (Eq, Show, Generic) - -- | Specifies the provenance of project configuration, whether defaults were -- used or if the configuration was read from an explicit file path. data ProjectConfigProvenance - - -- | The configuration is implicit due to no explicit configuration - -- being found. See 'Distribution.Client.ProjectConfig.readProjectConfig' - -- for how implicit configuration is determined. - = Implicit - - -- | The path the project configuration was explicitly read from. - -- | The configuration was explicitly read from the specified 'FilePath'. - | Explicit FilePath + = -- | The configuration is implicit due to no explicit configuration + -- being found. See 'Distribution.Client.ProjectConfig.readProjectConfig' + -- for how implicit configuration is determined. + Implicit + | -- | The path the project configuration was explicitly read from. + -- | The configuration was explicitly read from the specified 'FilePath'. + Explicit FilePath deriving (Eq, Ord, Show, Generic) - -- | Project configuration that is specific to each package, that is where we -- can in principle have different values for different packages in the same -- project. --- -data PackageConfig - = PackageConfig { - packageConfigProgramPaths :: MapLast String FilePath, - packageConfigProgramArgs :: MapMappend String [String], - packageConfigProgramPathExtra :: NubList FilePath, - packageConfigFlagAssignment :: FlagAssignment, - packageConfigVanillaLib :: Flag Bool, - packageConfigSharedLib :: Flag Bool, - packageConfigStaticLib :: Flag Bool, - packageConfigDynExe :: Flag Bool, - packageConfigFullyStaticExe :: Flag Bool, - packageConfigProf :: Flag Bool, --TODO: [code cleanup] sort out - packageConfigProfLib :: Flag Bool, -- this duplication - packageConfigProfExe :: Flag Bool, -- and consistency - packageConfigProfDetail :: Flag ProfDetailLevel, - packageConfigProfLibDetail :: Flag ProfDetailLevel, - packageConfigConfigureArgs :: [String], - packageConfigOptimization :: Flag OptimisationLevel, - packageConfigProgPrefix :: Flag PathTemplate, - packageConfigProgSuffix :: Flag PathTemplate, - packageConfigExtraLibDirs :: [FilePath], - packageConfigExtraLibDirsStatic :: [FilePath], - packageConfigExtraFrameworkDirs :: [FilePath], - packageConfigExtraIncludeDirs :: [FilePath], - packageConfigGHCiLib :: Flag Bool, - packageConfigSplitSections :: Flag Bool, - packageConfigSplitObjs :: Flag Bool, - packageConfigStripExes :: Flag Bool, - packageConfigStripLibs :: Flag Bool, - packageConfigTests :: Flag Bool, - packageConfigBenchmarks :: Flag Bool, - packageConfigCoverage :: Flag Bool, - packageConfigRelocatable :: Flag Bool, - packageConfigDebugInfo :: Flag DebugInfoLevel, - packageConfigDumpBuildInfo :: Flag DumpBuildInfo, - packageConfigRunTests :: Flag Bool, --TODO: [required eventually] use this - packageConfigDocumentation :: Flag Bool, --TODO: [required eventually] use this - -- Haddock options - packageConfigHaddockHoogle :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockHtml :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockHtmlLocation :: Flag String, --TODO: [required eventually] use this - packageConfigHaddockForeignLibs :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockExecutables :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockTestSuites :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockBenchmarks :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockInternal :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockCss :: Flag FilePath, --TODO: [required eventually] use this - packageConfigHaddockLinkedSource :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockQuickJump :: Flag Bool, --TODO: [required eventually] use this - packageConfigHaddockHscolourCss :: Flag FilePath, --TODO: [required eventually] use this - 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 - packageConfigHaddockOutputDir :: Flag FilePath, --TODO: [required eventually] use this - packageConfigHaddockForHackage :: Flag HaddockTarget, - -- Test options - packageConfigTestHumanLog :: Flag PathTemplate, - packageConfigTestMachineLog :: Flag PathTemplate, - packageConfigTestShowDetails :: Flag TestShowDetails, - packageConfigTestKeepTix :: Flag Bool, - packageConfigTestWrapper :: Flag FilePath, - packageConfigTestFailWhenNoTestSuites :: Flag Bool, - packageConfigTestTestOptions :: [PathTemplate], - -- Benchmark options - packageConfigBenchmarkOptions :: [PathTemplate] - } +data PackageConfig = PackageConfig + { packageConfigProgramPaths :: MapLast String FilePath + , packageConfigProgramArgs :: MapMappend String [String] + , packageConfigProgramPathExtra :: NubList FilePath + , packageConfigFlagAssignment :: FlagAssignment + , packageConfigVanillaLib :: Flag Bool + , packageConfigSharedLib :: Flag Bool + , packageConfigStaticLib :: Flag Bool + , packageConfigDynExe :: Flag Bool + , packageConfigFullyStaticExe :: Flag Bool + , packageConfigProf :: Flag Bool -- TODO: [code cleanup] sort out + , packageConfigProfLib :: Flag Bool -- this duplication + , packageConfigProfExe :: Flag Bool -- and consistency + , packageConfigProfDetail :: Flag ProfDetailLevel + , packageConfigProfLibDetail :: Flag ProfDetailLevel + , packageConfigConfigureArgs :: [String] + , packageConfigOptimization :: Flag OptimisationLevel + , packageConfigProgPrefix :: Flag PathTemplate + , packageConfigProgSuffix :: Flag PathTemplate + , packageConfigExtraLibDirs :: [FilePath] + , packageConfigExtraLibDirsStatic :: [FilePath] + , packageConfigExtraFrameworkDirs :: [FilePath] + , packageConfigExtraIncludeDirs :: [FilePath] + , packageConfigGHCiLib :: Flag Bool + , packageConfigSplitSections :: Flag Bool + , packageConfigSplitObjs :: Flag Bool + , packageConfigStripExes :: Flag Bool + , packageConfigStripLibs :: Flag Bool + , packageConfigTests :: Flag Bool + , packageConfigBenchmarks :: Flag Bool + , packageConfigCoverage :: Flag Bool + , packageConfigRelocatable :: Flag Bool + , packageConfigDebugInfo :: Flag DebugInfoLevel + , packageConfigDumpBuildInfo :: Flag DumpBuildInfo + , packageConfigRunTests :: Flag Bool -- TODO: [required eventually] use this + , packageConfigDocumentation :: Flag Bool -- TODO: [required eventually] use this + -- Haddock options + , packageConfigHaddockHoogle :: Flag Bool -- TODO: [required eventually] use this + , packageConfigHaddockHtml :: Flag Bool -- TODO: [required eventually] use this + , packageConfigHaddockHtmlLocation :: Flag String -- TODO: [required eventually] use this + , packageConfigHaddockForeignLibs :: Flag Bool -- TODO: [required eventually] use this + , packageConfigHaddockExecutables :: Flag Bool -- TODO: [required eventually] use this + , packageConfigHaddockTestSuites :: Flag Bool -- TODO: [required eventually] use this + , packageConfigHaddockBenchmarks :: Flag Bool -- TODO: [required eventually] use this + , packageConfigHaddockInternal :: Flag Bool -- TODO: [required eventually] use this + , packageConfigHaddockCss :: Flag FilePath -- TODO: [required eventually] use this + , packageConfigHaddockLinkedSource :: Flag Bool -- TODO: [required eventually] use this + , packageConfigHaddockQuickJump :: Flag Bool -- TODO: [required eventually] use this + , packageConfigHaddockHscolourCss :: Flag FilePath -- TODO: [required eventually] use this + , 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 + , packageConfigHaddockOutputDir :: Flag FilePath -- TODO: [required eventually] use this + , packageConfigHaddockForHackage :: Flag HaddockTarget + , -- Test options + packageConfigTestHumanLog :: Flag PathTemplate + , packageConfigTestMachineLog :: Flag PathTemplate + , packageConfigTestShowDetails :: Flag TestShowDetails + , packageConfigTestKeepTix :: Flag Bool + , packageConfigTestWrapper :: Flag FilePath + , packageConfigTestFailWhenNoTestSuites :: Flag Bool + , packageConfigTestTestOptions :: [PathTemplate] + , -- Benchmark options + packageConfigBenchmarkOptions :: [PathTemplate] + } deriving (Eq, Show, Generic) instance Binary ProjectConfig @@ -320,35 +321,35 @@ instance Structured PackageConfig -- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that takes -- the last value rather than the first value for overlapping keys. -newtype MapLast k v = MapLast { getMapLast :: Map k v } +newtype MapLast k v = MapLast {getMapLast :: Map k v} deriving (Eq, Show, Functor, Generic, Binary, Typeable) instance (Structured k, Structured v) => Structured (MapLast k v) instance Ord k => Monoid (MapLast k v) where - mempty = MapLast Map.empty + mempty = MapLast Map.empty mappend = (<>) instance Ord k => Semigroup (MapLast k v) where MapLast a <> MapLast b = MapLast $ Map.union b a - -- rather than Map.union which is the normal Map monoid instance +-- rather than Map.union which is the normal Map monoid instance -- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that -- 'mappend's values of overlapping keys rather than taking the first. -newtype MapMappend k v = MapMappend { getMapMappend :: Map k v } +newtype MapMappend k v = MapMappend {getMapMappend :: Map k v} deriving (Eq, Show, Functor, Generic, Binary, Typeable) instance (Structured k, Structured v) => Structured (MapMappend k v) instance (Semigroup v, Ord k) => Monoid (MapMappend k v) where - mempty = MapMappend Map.empty + mempty = MapMappend Map.empty mappend = (<>) instance (Semigroup v, Ord k) => Semigroup (MapMappend k v) where MapMappend a <> MapMappend b = MapMappend (Map.unionWith (<>) a b) - -- rather than Map.union which is the normal Map monoid instance +-- rather than Map.union which is the normal Map monoid instance instance Monoid ProjectConfig where mempty = gmempty @@ -357,7 +358,6 @@ instance Monoid ProjectConfig where instance Semigroup ProjectConfig where (<>) = gmappend - instance Monoid ProjectConfigBuildOnly where mempty = gmempty mappend = (<>) @@ -365,7 +365,6 @@ instance Monoid ProjectConfigBuildOnly where instance Semigroup ProjectConfigBuildOnly where (<>) = gmappend - instance Monoid ProjectConfigShared where mempty = gmempty mappend = (<>) @@ -373,7 +372,6 @@ instance Monoid ProjectConfigShared where instance Semigroup ProjectConfigShared where (<>) = gmappend - instance Monoid PackageConfig where mempty = gmempty mappend = (<>) @@ -392,45 +390,44 @@ instance Semigroup PackageConfig where -- -- Use 'resolveSolverSettings' to make one from the project config (by -- applying defaults etc). --- -data SolverSettings - = SolverSettings { - solverSettingRemoteRepos :: [RemoteRepo], -- ^ Available Hackage servers. - solverSettingLocalNoIndexRepos :: [LocalRepo], - solverSettingConstraints :: [(UserConstraint, ConstraintSource)], - solverSettingPreferences :: [PackageVersionConstraint], - solverSettingFlagAssignment :: FlagAssignment, -- ^ For all local packages - solverSettingFlagAssignments :: Map PackageName FlagAssignment, - solverSettingCabalVersion :: Maybe Version, --TODO: [required eventually] unused - solverSettingSolver :: PreSolver, - solverSettingAllowOlder :: AllowOlder, - solverSettingAllowNewer :: AllowNewer, - solverSettingMaxBackjumps :: Maybe Int, - solverSettingReorderGoals :: ReorderGoals, - solverSettingCountConflicts :: CountConflicts, - solverSettingFineGrainedConflicts :: FineGrainedConflicts, - solverSettingMinimizeConflictSet :: MinimizeConflictSet, - solverSettingStrongFlags :: StrongFlags, - solverSettingAllowBootLibInstalls :: AllowBootLibInstalls, - solverSettingOnlyConstrained :: OnlyConstrained, - solverSettingIndexState :: Maybe TotalIndexState, - solverSettingActiveRepos :: Maybe ActiveRepos, - solverSettingIndependentGoals :: IndependentGoals, - solverSettingPreferOldest :: PreferOldest - -- Things that only make sense for manual mode, not --local mode - -- too much control! - --solverSettingShadowPkgs :: Bool, - --solverSettingReinstall :: Bool, - --solverSettingAvoidReinstalls :: Bool, - --solverSettingOverrideReinstall :: Bool, - --solverSettingUpgradeDeps :: Bool - } +data SolverSettings = SolverSettings + { solverSettingRemoteRepos :: [RemoteRepo] + -- ^ Available Hackage servers. + , solverSettingLocalNoIndexRepos :: [LocalRepo] + , solverSettingConstraints :: [(UserConstraint, ConstraintSource)] + , solverSettingPreferences :: [PackageVersionConstraint] + , solverSettingFlagAssignment :: FlagAssignment + -- ^ For all local packages + , solverSettingFlagAssignments :: Map PackageName FlagAssignment + , solverSettingCabalVersion :: Maybe Version -- TODO: [required eventually] unused + , solverSettingSolver :: PreSolver + , solverSettingAllowOlder :: AllowOlder + , solverSettingAllowNewer :: AllowNewer + , solverSettingMaxBackjumps :: Maybe Int + , solverSettingReorderGoals :: ReorderGoals + , solverSettingCountConflicts :: CountConflicts + , solverSettingFineGrainedConflicts :: FineGrainedConflicts + , solverSettingMinimizeConflictSet :: MinimizeConflictSet + , solverSettingStrongFlags :: StrongFlags + , solverSettingAllowBootLibInstalls :: AllowBootLibInstalls + , solverSettingOnlyConstrained :: OnlyConstrained + , solverSettingIndexState :: Maybe TotalIndexState + , solverSettingActiveRepos :: Maybe ActiveRepos + , solverSettingIndependentGoals :: IndependentGoals + , solverSettingPreferOldest :: PreferOldest + -- Things that only make sense for manual mode, not --local mode + -- too much control! + -- solverSettingShadowPkgs :: Bool, + -- solverSettingReinstall :: Bool, + -- solverSettingAvoidReinstalls :: Bool, + -- solverSettingOverrideReinstall :: Bool, + -- solverSettingUpgradeDeps :: Bool + } deriving (Eq, Show, Generic, Typeable) instance Binary SolverSettings instance Structured SolverSettings - -- | Resolved configuration for things that affect how we build and not the -- value of the things we build. The idea is that this is easier to use than -- the raw configuration because in the raw configuration everything is @@ -439,29 +436,32 @@ instance Structured SolverSettings -- -- Use 'resolveBuildTimeSettings' to make one from the project config (by -- applying defaults etc). --- -data BuildTimeSettings - = BuildTimeSettings { - buildSettingDryRun :: Bool, - buildSettingOnlyDeps :: Bool, - buildSettingOnlyDownload :: Bool, - buildSettingSummaryFile :: [PathTemplate], - buildSettingLogFile :: Maybe (Compiler -> Platform - -> PackageId -> UnitId - -> FilePath), - buildSettingLogVerbosity :: Verbosity, - buildSettingBuildReports :: ReportLevel, - buildSettingReportPlanningFailure :: Bool, - buildSettingSymlinkBinDir :: [FilePath], - buildSettingNumJobs :: Int, - buildSettingKeepGoing :: Bool, - buildSettingOfflineMode :: Bool, - buildSettingKeepTempFiles :: Bool, - buildSettingRemoteRepos :: [RemoteRepo], - buildSettingLocalNoIndexRepos :: [LocalRepo], - buildSettingCacheDir :: FilePath, - buildSettingHttpTransport :: Maybe String, - buildSettingIgnoreExpiry :: Bool, - buildSettingProgPathExtra :: [FilePath], - buildSettingHaddockOpen :: Bool - } +data BuildTimeSettings = BuildTimeSettings + { buildSettingDryRun :: Bool + , buildSettingOnlyDeps :: Bool + , buildSettingOnlyDownload :: Bool + , buildSettingSummaryFile :: [PathTemplate] + , buildSettingLogFile + :: Maybe + ( Compiler + -> Platform + -> PackageId + -> UnitId + -> FilePath + ) + , buildSettingLogVerbosity :: Verbosity + , buildSettingBuildReports :: ReportLevel + , buildSettingReportPlanningFailure :: Bool + , buildSettingSymlinkBinDir :: [FilePath] + , buildSettingNumJobs :: Int + , buildSettingKeepGoing :: Bool + , buildSettingOfflineMode :: Bool + , buildSettingKeepTempFiles :: Bool + , buildSettingRemoteRepos :: [RemoteRepo] + , buildSettingLocalNoIndexRepos :: [LocalRepo] + , buildSettingCacheDir :: FilePath + , buildSettingHttpTransport :: Maybe String + , buildSettingIgnoreExpiry :: Bool + , buildSettingProgPathExtra :: [FilePath] + , buildSettingHaddockOpen :: Bool + } diff --git a/cabal-install/src/Distribution/Client/ProjectFlags.hs b/cabal-install/src/Distribution/Client/ProjectFlags.hs index 8959f60aefc..a18814a034b 100644 --- a/cabal-install/src/Distribution/Client/ProjectFlags.hs +++ b/cabal-install/src/Distribution/Client/ProjectFlags.hs @@ -1,71 +1,85 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -module Distribution.Client.ProjectFlags ( - ProjectFlags(..), - defaultProjectFlags, - projectFlagsOptions, - removeIgnoreProjectOption, -) where + +module Distribution.Client.ProjectFlags + ( ProjectFlags (..) + , defaultProjectFlags + , projectFlagsOptions + , removeIgnoreProjectOption + ) where import Distribution.Client.Compat.Prelude import Prelude () -import Distribution.ReadE (succeedReadE) +import Distribution.ReadE (succeedReadE) import Distribution.Simple.Command - ( MkOptDescr, OptionField(optionName), ShowOrParseArgs (..), boolOpt', option - , reqArg ) -import Distribution.Simple.Setup (Flag (..), flagToList, flagToMaybe, toFlag, trueArg) + ( MkOptDescr + , OptionField (optionName) + , ShowOrParseArgs (..) + , boolOpt' + , option + , reqArg + ) +import Distribution.Simple.Setup (Flag (..), flagToList, flagToMaybe, toFlag, trueArg) data ProjectFlags = ProjectFlags - { flagProjectDir :: Flag FilePath - -- ^ The project directory. - - , flagProjectFile :: Flag FilePath - -- ^ The cabal project file path; defaults to @cabal.project@. - -- This path, when relative, is relative to the project directory. - -- The filename portion of the path denotes the cabal project file name, but it also - -- is the base of auxiliary project files, such as - -- @cabal.project.local@ and @cabal.project.freeze@ which are also - -- read and written out in some cases. - -- If a project directory was not specified, and the path is not found - -- in the current working directory, we will successively probe - -- relative to parent directories until this name is found. - - , flagIgnoreProject :: Flag Bool - -- ^ Whether to ignore the local project (i.e. don't search for cabal.project) - -- The exact interpretation might be slightly different per command. - } + { flagProjectDir :: Flag FilePath + -- ^ The project directory. + , flagProjectFile :: Flag FilePath + -- ^ The cabal project file path; defaults to @cabal.project@. + -- This path, when relative, is relative to the project directory. + -- The filename portion of the path denotes the cabal project file name, but it also + -- is the base of auxiliary project files, such as + -- @cabal.project.local@ and @cabal.project.freeze@ which are also + -- read and written out in some cases. + -- If a project directory was not specified, and the path is not found + -- in the current working directory, we will successively probe + -- relative to parent directories until this name is found. + , flagIgnoreProject :: Flag Bool + -- ^ Whether to ignore the local project (i.e. don't search for cabal.project) + -- The exact interpretation might be slightly different per command. + } deriving (Show, Generic) defaultProjectFlags :: ProjectFlags -defaultProjectFlags = ProjectFlags - { flagProjectDir = mempty - , flagProjectFile = mempty - , flagIgnoreProject = toFlag False - -- Should we use 'Last' here? +defaultProjectFlags = + ProjectFlags + { flagProjectDir = mempty + , flagProjectFile = mempty + , flagIgnoreProject = toFlag False + -- Should we use 'Last' here? } projectFlagsOptions :: ShowOrParseArgs -> [OptionField ProjectFlags] projectFlagsOptions showOrParseArgs = - [ option [] ["project-dir"] - "Set the path of the project directory" - flagProjectDir (\path flags -> flags { flagProjectDir = path }) - (reqArg "DIR" (succeedReadE Flag) flagToList) - , option [] ["project-file"] - "Set the path of the cabal.project file (relative to the project directory when relative)" - flagProjectFile (\pf flags -> flags { flagProjectFile = pf }) - (reqArg "FILE" (succeedReadE Flag) flagToList) - , option ['z'] ["ignore-project"] - "Ignore local project configuration (unless --project-dir or --project-file is also set)" - flagIgnoreProject - (\v flags -> flags - { flagIgnoreProject = case v of - Flag True -> toFlag (flagProjectDir flags == NoFlag && flagProjectFile flags == NoFlag) - _ -> v - } - ) - (yesNoOpt showOrParseArgs) - ] + [ option + [] + ["project-dir"] + "Set the path of the project directory" + flagProjectDir + (\path flags -> flags{flagProjectDir = path}) + (reqArg "DIR" (succeedReadE Flag) flagToList) + , option + [] + ["project-file"] + "Set the path of the cabal.project file (relative to the project directory when relative)" + flagProjectFile + (\pf flags -> flags{flagProjectFile = pf}) + (reqArg "FILE" (succeedReadE Flag) flagToList) + , option + ['z'] + ["ignore-project"] + "Ignore local project configuration (unless --project-dir or --project-file is also set)" + flagIgnoreProject + ( \v flags -> + flags + { flagIgnoreProject = case v of + Flag True -> toFlag (flagProjectDir flags == NoFlag && flagProjectFile flags == NoFlag) + _ -> v + } + ) + (yesNoOpt showOrParseArgs) + ] -- | As almost all commands use 'ProjectFlags' but not all can honour -- "ignore-project" flag, provide this utility to remove the flag @@ -74,12 +88,12 @@ removeIgnoreProjectOption :: [OptionField a] -> [OptionField a] removeIgnoreProjectOption = filter (\o -> optionName o /= "ignore-project") instance Monoid ProjectFlags where - mempty = gmempty - mappend = (<>) + mempty = gmempty + mappend = (<>) instance Semigroup ProjectFlags where - (<>) = gmappend + (<>) = gmappend yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b yesNoOpt ShowArgs sf lf = trueArg sf lf -yesNoOpt _ sf lf = boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf +yesNoOpt _ sf lf = boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index 1adf2ed06a0..4c56d3beeb8 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} -{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | This module deals with building and incrementally rebuilding a collection -- of packages. It is what backs the @cabal build@ and @configure@ commands, @@ -38,323 +40,363 @@ -- first phase. Also, the second phase does not have direct access to any of -- the input configuration anyway; all the information has to flow via the -- 'ElaboratedInstallPlan'. --- -module Distribution.Client.ProjectOrchestration ( - -- * Discovery phase: what is in the project? - CurrentCommand(..), - establishProjectBaseContext, - establishProjectBaseContextWithRoot, - ProjectBaseContext(..), - BuildTimeSettings(..), - commandLineFlagsToProjectConfig, +module Distribution.Client.ProjectOrchestration + ( -- * Discovery phase: what is in the project? + CurrentCommand (..) + , establishProjectBaseContext + , establishProjectBaseContextWithRoot + , ProjectBaseContext (..) + , BuildTimeSettings (..) + , commandLineFlagsToProjectConfig -- * Pre-build phase: decide what to do. - withInstallPlan, - runProjectPreBuildPhase, - ProjectBuildContext(..), + , withInstallPlan + , runProjectPreBuildPhase + , ProjectBuildContext (..) -- ** Selecting what targets we mean - readTargetSelectors, - reportTargetSelectorProblems, - resolveTargets, - TargetsMap, - allTargetSelectors, - uniqueTargetSelectors, - TargetSelector(..), - TargetImplicitCwd(..), - PackageId, - AvailableTarget(..), - AvailableTargetStatus(..), - TargetRequested(..), - ComponentName(..), - ComponentKind(..), - ComponentTarget(..), - SubComponentTarget(..), - selectComponentTargetBasic, - distinctTargetComponents, + , readTargetSelectors + , reportTargetSelectorProblems + , resolveTargets + , TargetsMap + , allTargetSelectors + , uniqueTargetSelectors + , TargetSelector (..) + , TargetImplicitCwd (..) + , PackageId + , AvailableTarget (..) + , AvailableTargetStatus (..) + , TargetRequested (..) + , ComponentName (..) + , ComponentKind (..) + , ComponentTarget (..) + , SubComponentTarget (..) + , selectComponentTargetBasic + , distinctTargetComponents + -- ** Utils for selecting targets - filterTargetsKind, - filterTargetsKindWith, - selectBuildableTargets, - selectBuildableTargetsWith, - selectBuildableTargets', - selectBuildableTargetsWith', - forgetTargetsDetail, + , filterTargetsKind + , filterTargetsKindWith + , selectBuildableTargets + , selectBuildableTargetsWith + , selectBuildableTargets' + , selectBuildableTargetsWith' + , forgetTargetsDetail -- ** Adjusting the plan - pruneInstallPlanToTargets, - TargetAction(..), - pruneInstallPlanToDependencies, - CannotPruneDependencies(..), - printPlan, + , pruneInstallPlanToTargets + , TargetAction (..) + , pruneInstallPlanToDependencies + , CannotPruneDependencies (..) + , printPlan -- * Build phase: now do it. - runProjectBuildPhase, + , runProjectBuildPhase -- * Post build actions - runProjectPostBuildPhase, - dieOnBuildFailures, + , runProjectPostBuildPhase + , dieOnBuildFailures -- * Dummy projects - establishDummyProjectBaseContext, - establishDummyDistDirLayout, + , establishDummyProjectBaseContext + , establishDummyDistDirLayout ) where -import Prelude () import Distribution.Client.Compat.Prelude import Distribution.Compat.Directory - ( makeAbsolute ) + ( makeAbsolute + ) +import Prelude () -import Distribution.Client.ProjectConfig -import Distribution.Client.ProjectPlanning - hiding ( pruneInstallPlanToTargets ) +import Distribution.Client.ProjectBuilding +import Distribution.Client.ProjectConfig +import Distribution.Client.ProjectPlanOutput +import Distribution.Client.ProjectPlanning hiding + ( pruneInstallPlanToTargets + ) import qualified Distribution.Client.ProjectPlanning as ProjectPlanning - ( pruneInstallPlanToTargets ) -import Distribution.Client.ProjectPlanning.Types -import Distribution.Client.ProjectBuilding -import Distribution.Client.ProjectPlanOutput - -import Distribution.Client.TargetProblem - ( TargetProblem (..) ) -import Distribution.Client.Types - ( GenericReadyPackage(..), UnresolvedSourcePackage - , PackageSpecifier(..) - , SourcePackageDb(..) - , WriteGhcEnvironmentFilesPolicy(..) - , PackageLocation(..) - , DocsResult(..) - , TestsResult(..) ) -import Distribution.Solver.Types.PackageIndex - ( lookupPackageName ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.TargetSelector - ( TargetSelector(..), TargetImplicitCwd(..) - , ComponentKind(..), componentKind - , readTargetSelectors, reportTargetSelectorProblems ) -import Distribution.Client.DistDirLayout + ( pruneInstallPlanToTargets + ) +import Distribution.Client.ProjectPlanning.Types -import Distribution.Client.BuildReports.Anonymous (cabalInstallID) +import Distribution.Client.DistDirLayout +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.TargetProblem + ( TargetProblem (..) + ) +import Distribution.Client.TargetSelector + ( ComponentKind (..) + , TargetImplicitCwd (..) + , TargetSelector (..) + , componentKind + , readTargetSelectors + , reportTargetSelectorProblems + ) +import Distribution.Client.Types + ( DocsResult (..) + , GenericReadyPackage (..) + , PackageLocation (..) + , PackageSpecifier (..) + , SourcePackageDb (..) + , TestsResult (..) + , UnresolvedSourcePackage + , WriteGhcEnvironmentFilesPolicy (..) + ) +import Distribution.Solver.Types.PackageIndex + ( lookupPackageName + ) + +import Distribution.Client.BuildReports.Anonymous (cabalInstallID) import qualified Distribution.Client.BuildReports.Anonymous as BuildReports import qualified Distribution.Client.BuildReports.Storage as BuildReports - ( storeLocal ) - -import Distribution.Client.HttpUtils -import Distribution.Client.Setup hiding (packageName) -import Distribution.Compiler - ( CompilerFlavor(GHC) ) -import Distribution.Types.ComponentName - ( componentNameString ) -import Distribution.Types.InstalledPackageInfo - ( InstalledPackageInfo ) -import Distribution.Types.UnqualComponentName - ( UnqualComponentName, packageNameToUnqualComponentName ) - -import Distribution.Solver.Types.OptionalStanza - -import Distribution.Package -import Distribution.Types.Flag - ( FlagAssignment, showFlagAssignment, diffFlagAssignment ) -import Distribution.Simple.LocalBuildInfo - ( ComponentName(..), pkgComponents ) -import Distribution.Simple.Flag - ( fromFlagOrDefault, flagToMaybe ) + ( storeLocal + ) + +import Distribution.Client.HttpUtils +import Distribution.Client.Setup hiding (packageName) +import Distribution.Compiler + ( CompilerFlavor (GHC) + ) +import Distribution.Types.ComponentName + ( componentNameString + ) +import Distribution.Types.InstalledPackageInfo + ( InstalledPackageInfo + ) +import Distribution.Types.UnqualComponentName + ( UnqualComponentName + , packageNameToUnqualComponentName + ) + +import Distribution.Solver.Types.OptionalStanza + +import Distribution.Package +import Distribution.Simple.Command (commandShowOptions) +import Distribution.Simple.Compiler + ( OptimisationLevel (..) + , compilerCompatVersion + , compilerId + , compilerInfo + , showCompilerId + ) +import Distribution.Simple.Configure (computeEffectiveProfiling) +import Distribution.Simple.Flag + ( flagToMaybe + , fromFlagOrDefault + ) +import Distribution.Simple.LocalBuildInfo + ( ComponentName (..) + , pkgComponents + ) +import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.Setup as Setup -import Distribution.Simple.Command (commandShowOptions) -import Distribution.Simple.Configure (computeEffectiveProfiling) -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import Distribution.Simple.Utils - ( die', warn, notice, noticeNoWrap, debugNoWrap, createDirectoryIfMissingVerbose, ordNub ) -import Distribution.Verbosity -import Distribution.Version - ( mkVersion ) -import Distribution.Simple.Compiler - ( compilerCompatVersion, showCompilerId, compilerId, compilerInfo - , OptimisationLevel(..)) -import Distribution.Utils.NubList - ( fromNubList ) -import Distribution.System - ( Platform(Platform) ) - +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose + , debugNoWrap + , die' + , notice + , noticeNoWrap + , ordNub + , warn + ) +import Distribution.System + ( Platform (Platform) + ) +import Distribution.Types.Flag + ( FlagAssignment + , diffFlagAssignment + , showFlagAssignment + ) +import Distribution.Utils.NubList + ( fromNubList + ) +import Distribution.Verbosity +import Distribution.Version + ( mkVersion + ) + +import Control.Exception (assert) import qualified Data.List.NonEmpty as NE -import qualified Data.Set as Set import qualified Data.Map as Map -import Control.Exception ( assert ) +import qualified Data.Set as Set #ifdef MIN_VERSION_unix import System.Posix.Signals (sigKILL, sigSEGV) #endif - -- | Tracks what command is being executed, because we need to hide this somewhere -- for cases that need special handling (usually for error reporting). data CurrentCommand = InstallCommand | HaddockCommand | BuildCommand | ReplCommand | OtherCommand - deriving (Show, Eq) + deriving (Show, Eq) -- | This holds the context of a project prior to solving: the content of the -- @cabal.project@ and all the local package @.cabal@ files. --- -data ProjectBaseContext = ProjectBaseContext { - distDirLayout :: DistDirLayout, - cabalDirLayout :: CabalDirLayout, - projectConfig :: ProjectConfig, - localPackages :: [PackageSpecifier UnresolvedSourcePackage], - buildSettings :: BuildTimeSettings, - currentCommand :: CurrentCommand, - installedPackages :: Maybe InstalledPackageIndex - } +data ProjectBaseContext = ProjectBaseContext + { distDirLayout :: DistDirLayout + , cabalDirLayout :: CabalDirLayout + , projectConfig :: ProjectConfig + , localPackages :: [PackageSpecifier UnresolvedSourcePackage] + , buildSettings :: BuildTimeSettings + , currentCommand :: CurrentCommand + , installedPackages :: Maybe InstalledPackageIndex + } establishProjectBaseContext - :: Verbosity - -> ProjectConfig - -> CurrentCommand - -> IO ProjectBaseContext + :: Verbosity + -> ProjectConfig + -> CurrentCommand + -> IO ProjectBaseContext establishProjectBaseContext verbosity cliConfig currentCommand = do - projectRoot <- either throwIO return =<< findProjectRoot verbosity mprojectDir mprojectFile - establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand + projectRoot <- either throwIO return =<< findProjectRoot verbosity mprojectDir mprojectFile + establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand where - mprojectDir = Setup.flagToMaybe projectConfigProjectDir - mprojectFile = Setup.flagToMaybe projectConfigProjectFile - ProjectConfigShared { projectConfigProjectDir, projectConfigProjectFile } = projectConfigShared cliConfig + mprojectDir = Setup.flagToMaybe projectConfigProjectDir + mprojectFile = Setup.flagToMaybe projectConfigProjectFile + ProjectConfigShared{projectConfigProjectDir, projectConfigProjectFile} = projectConfigShared cliConfig -- | Like 'establishProjectBaseContext' but doesn't search for project root. establishProjectBaseContextWithRoot - :: Verbosity - -> ProjectConfig - -> ProjectRoot - -> CurrentCommand - -> IO ProjectBaseContext + :: Verbosity + -> ProjectConfig + -> ProjectRoot + -> CurrentCommand + -> IO ProjectBaseContext establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand = do - let haddockOutputDir = flagToMaybe (packageConfigHaddockOutputDir (projectConfigLocalPackages cliConfig)) - let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory haddockOutputDir - - httpTransport <- configureTransport verbosity - (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig) - (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig) - - (projectConfig, localPackages) <- - rebuildProjectConfig verbosity - httpTransport - distDirLayout - cliConfig - - let ProjectConfigBuildOnly { - projectConfigLogsDir + let haddockOutputDir = flagToMaybe (packageConfigHaddockOutputDir (projectConfigLocalPackages cliConfig)) + let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory haddockOutputDir + + httpTransport <- + configureTransport + verbosity + (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig) + (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig) + + (projectConfig, localPackages) <- + rebuildProjectConfig + verbosity + httpTransport + distDirLayout + cliConfig + + let ProjectConfigBuildOnly + { projectConfigLogsDir } = projectConfigBuildOnly projectConfig - ProjectConfigShared { - projectConfigStoreDir + ProjectConfigShared + { projectConfigStoreDir } = projectConfigShared projectConfig - mlogsDir = Setup.flagToMaybe projectConfigLogsDir - mstoreDir <- sequenceA $ makeAbsolute - <$> Setup.flagToMaybe projectConfigStoreDir - cabalDirLayout <- mkCabalDirLayout mstoreDir mlogsDir - - let buildSettings = resolveBuildTimeSettings - verbosity cabalDirLayout - projectConfig - - -- https://github.com/haskell/cabal/issues/6013 - when (null (projectPackages projectConfig) && null (projectPackagesOptional projectConfig)) $ - warn verbosity "There are no packages or optional-packages in the project" - - return ProjectBaseContext { - distDirLayout, - cabalDirLayout, - projectConfig, - localPackages, - buildSettings, - currentCommand, - installedPackages - } + mlogsDir = Setup.flagToMaybe projectConfigLogsDir + mstoreDir <- + sequenceA $ + makeAbsolute + <$> Setup.flagToMaybe projectConfigStoreDir + cabalDirLayout <- mkCabalDirLayout mstoreDir mlogsDir + + let buildSettings = + resolveBuildTimeSettings + verbosity + cabalDirLayout + projectConfig + + -- https://github.com/haskell/cabal/issues/6013 + when (null (projectPackages projectConfig) && null (projectPackagesOptional projectConfig)) $ + warn verbosity "There are no packages or optional-packages in the project" + + return + ProjectBaseContext + { distDirLayout + , cabalDirLayout + , projectConfig + , localPackages + , buildSettings + , currentCommand + , installedPackages + } where mdistDirectory = Setup.flagToMaybe projectConfigDistDir - ProjectConfigShared { projectConfigDistDir } = projectConfigShared cliConfig + ProjectConfigShared{projectConfigDistDir} = projectConfigShared cliConfig installedPackages = Nothing - -- | This holds the context between the pre-build, build and post-build phases. --- -data ProjectBuildContext = ProjectBuildContext { - -- | This is the improved plan, before we select a plan subset based on - -- the build targets, and before we do the dry-run. So this contains - -- all packages in the project. - elaboratedPlanOriginal :: ElaboratedInstallPlan, - - -- | This is the 'elaboratedPlanOriginal' after we select a plan subset - -- and do the dry-run phase to find out what is up-to or out-of date. - -- This is the plan that will be executed during the build phase. So - -- this contains only a subset of packages in the project. - elaboratedPlanToExecute:: ElaboratedInstallPlan, - - -- | The part of the install plan that's shared between all packages in - -- the plan. This does not change between the two plan variants above, - -- so there is just the one copy. - elaboratedShared :: ElaboratedSharedConfig, - - -- | The result of the dry-run phase. This tells us about each member of - -- the 'elaboratedPlanToExecute'. - pkgsBuildStatus :: BuildStatusMap, - - -- | The targets selected by @selectPlanSubset@. This is useful eg. in - -- CmdRun, where we need a valid target to execute. - targetsMap :: TargetsMap - } - +data ProjectBuildContext = ProjectBuildContext + { elaboratedPlanOriginal :: ElaboratedInstallPlan + -- ^ This is the improved plan, before we select a plan subset based on + -- the build targets, and before we do the dry-run. So this contains + -- all packages in the project. + , elaboratedPlanToExecute :: ElaboratedInstallPlan + -- ^ This is the 'elaboratedPlanOriginal' after we select a plan subset + -- and do the dry-run phase to find out what is up-to or out-of date. + -- This is the plan that will be executed during the build phase. So + -- this contains only a subset of packages in the project. + , elaboratedShared :: ElaboratedSharedConfig + -- ^ The part of the install plan that's shared between all packages in + -- the plan. This does not change between the two plan variants above, + -- so there is just the one copy. + , pkgsBuildStatus :: BuildStatusMap + -- ^ The result of the dry-run phase. This tells us about each member of + -- the 'elaboratedPlanToExecute'. + , targetsMap :: TargetsMap + -- ^ The targets selected by @selectPlanSubset@. This is useful eg. in + -- CmdRun, where we need a valid target to execute. + } -- | Pre-build phase: decide what to do. --- withInstallPlan - :: Verbosity - -> ProjectBaseContext - -> (ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO a) - -> IO a + :: Verbosity + -> ProjectBaseContext + -> (ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO a) + -> IO a withInstallPlan - verbosity - ProjectBaseContext { - distDirLayout, - cabalDirLayout, - projectConfig, - localPackages, - installedPackages + verbosity + ProjectBaseContext + { distDirLayout + , cabalDirLayout + , projectConfig + , localPackages + , installedPackages } - action = do + action = do -- Take the project configuration and make a plan for how to build -- everything in the project. This is independent of any specific targets -- the user has asked for. -- (elaboratedPlan, _, elaboratedShared, _, _) <- - rebuildInstallPlan verbosity - distDirLayout cabalDirLayout - projectConfig - localPackages - installedPackages + rebuildInstallPlan + verbosity + distDirLayout + cabalDirLayout + projectConfig + localPackages + installedPackages action elaboratedPlan elaboratedShared runProjectPreBuildPhase - :: Verbosity - -> ProjectBaseContext - -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap)) - -> IO ProjectBuildContext + :: Verbosity + -> ProjectBaseContext + -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap)) + -> IO ProjectBuildContext runProjectPreBuildPhase - verbosity - ProjectBaseContext { - distDirLayout, - cabalDirLayout, - projectConfig, - localPackages, - installedPackages + verbosity + ProjectBaseContext + { distDirLayout + , cabalDirLayout + , projectConfig + , localPackages + , installedPackages } - selectPlanSubset = do + selectPlanSubset = do -- Take the project configuration and make a plan for how to build -- everything in the project. This is independent of any specific targets -- the user has asked for. -- (elaboratedPlan, _, elaboratedShared, _, _) <- - rebuildInstallPlan verbosity - distDirLayout cabalDirLayout - projectConfig - localPackages - installedPackages + rebuildInstallPlan + verbosity + distDirLayout + cabalDirLayout + projectConfig + localPackages + installedPackages -- The plan for what to do is represented by an 'ElaboratedInstallPlan' @@ -366,72 +408,80 @@ runProjectPreBuildPhase -- Check which packages need rebuilding. -- This also gives us more accurate reasons for the --dry-run output. -- - pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout elaboratedShared - elaboratedPlan' + pkgsBuildStatus <- + rebuildTargetsDryRun + distDirLayout + elaboratedShared + elaboratedPlan' -- Improve the plan by marking up-to-date packages as installed. -- - let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages - pkgsBuildStatus elaboratedPlan' + let elaboratedPlan'' = + improveInstallPlanWithUpToDatePackages + pkgsBuildStatus + elaboratedPlan' debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'') - return ProjectBuildContext { - elaboratedPlanOriginal = elaboratedPlan, - elaboratedPlanToExecute = elaboratedPlan'', - elaboratedShared, - pkgsBuildStatus, - targetsMap = targets - } - + return + ProjectBuildContext + { elaboratedPlanOriginal = elaboratedPlan + , elaboratedPlanToExecute = elaboratedPlan'' + , elaboratedShared + , pkgsBuildStatus + , targetsMap = targets + } -- | Build phase: now do it. -- -- Execute all or parts of the description of what to do to build or -- rebuild the various packages needed. --- -runProjectBuildPhase :: Verbosity - -> ProjectBaseContext - -> ProjectBuildContext - -> IO BuildOutcomes +runProjectBuildPhase + :: Verbosity + -> ProjectBaseContext + -> ProjectBuildContext + -> IO BuildOutcomes runProjectBuildPhase _ ProjectBaseContext{buildSettings} _ - | buildSettingDryRun buildSettings - = return Map.empty - -runProjectBuildPhase verbosity - ProjectBaseContext{..} ProjectBuildContext {..} = + | buildSettingDryRun buildSettings = + return Map.empty +runProjectBuildPhase + verbosity + ProjectBaseContext{..} + ProjectBuildContext{..} = fmap (Map.union (previousBuildOutcomes pkgsBuildStatus)) $ - rebuildTargets verbosity - projectConfig - distDirLayout - (cabalStoreDirLayout cabalDirLayout) - elaboratedPlanToExecute - elaboratedShared - pkgsBuildStatus - buildSettings - where - previousBuildOutcomes :: BuildStatusMap -> BuildOutcomes - previousBuildOutcomes = - Map.mapMaybe $ \status -> case status of - BuildStatusUpToDate buildSuccess -> Just (Right buildSuccess) - --TODO: [nice to have] record build failures persistently - _ -> Nothing + rebuildTargets + verbosity + projectConfig + distDirLayout + (cabalStoreDirLayout cabalDirLayout) + elaboratedPlanToExecute + elaboratedShared + pkgsBuildStatus + buildSettings + where + previousBuildOutcomes :: BuildStatusMap -> BuildOutcomes + previousBuildOutcomes = + Map.mapMaybe $ \status -> case status of + BuildStatusUpToDate buildSuccess -> Just (Right buildSuccess) + -- TODO: [nice to have] record build failures persistently + _ -> Nothing -- | Post-build phase: various administrative tasks -- -- Update bits of state based on the build outcomes and report any failures. --- -runProjectPostBuildPhase :: Verbosity - -> ProjectBaseContext - -> ProjectBuildContext - -> BuildOutcomes - -> IO () +runProjectPostBuildPhase + :: Verbosity + -> ProjectBaseContext + -> ProjectBuildContext + -> BuildOutcomes + -> IO () runProjectPostBuildPhase _ ProjectBaseContext{buildSettings} _ _ - | buildSettingDryRun buildSettings - = return () - -runProjectPostBuildPhase verbosity - ProjectBaseContext {..} bc@ProjectBuildContext {..} - buildOutcomes = do + | buildSettingDryRun buildSettings = + return () +runProjectPostBuildPhase + verbosity + ProjectBaseContext{..} + bc@ProjectBuildContext{..} + buildOutcomes = do -- Update other build artefacts -- TODO: currently none, but could include: -- - bin symlinks/wrappers @@ -439,35 +489,38 @@ runProjectPostBuildPhase verbosity -- - delete stale lib registrations -- - delete stale package dirs - postBuildStatus <- updatePostBuildProjectStatus - verbosity - distDirLayout - elaboratedPlanOriginal - pkgsBuildStatus - buildOutcomes + postBuildStatus <- + updatePostBuildProjectStatus + verbosity + distDirLayout + elaboratedPlanOriginal + pkgsBuildStatus + buildOutcomes -- Write the .ghc.environment file (if allowed by the env file write policy). let writeGhcEnvFilesPolicy = - projectConfigWriteGhcEnvironmentFilesPolicy . projectConfigShared - $ projectConfig + projectConfigWriteGhcEnvironmentFilesPolicy . projectConfigShared $ + projectConfig shouldWriteGhcEnvironment :: Bool shouldWriteGhcEnvironment = - case fromFlagOrDefault NeverWriteGhcEnvironmentFiles - writeGhcEnvFilesPolicy - of - AlwaysWriteGhcEnvironmentFiles -> True - NeverWriteGhcEnvironmentFiles -> False + case fromFlagOrDefault + NeverWriteGhcEnvironmentFiles + writeGhcEnvFilesPolicy of + AlwaysWriteGhcEnvironmentFiles -> True + NeverWriteGhcEnvironmentFiles -> False WriteGhcEnvironmentFilesOnlyForGhc844AndNewer -> - let compiler = pkgConfigCompiler elaboratedShared + let compiler = pkgConfigCompiler elaboratedShared ghcCompatVersion = compilerCompatVersion GHC compiler - in maybe False (>= mkVersion [8,4,4]) ghcCompatVersion + in maybe False (>= mkVersion [8, 4, 4]) ghcCompatVersion when shouldWriteGhcEnvironment $ - void $ writePlanGhcEnvironment (distProjectRootDirectory distDirLayout) - elaboratedPlanOriginal - elaboratedShared - postBuildStatus + void $ + writePlanGhcEnvironment + (distProjectRootDirectory distDirLayout) + elaboratedPlanOriginal + elaboratedShared + postBuildStatus -- Write the build reports writeBuildReports buildSettings bc elaboratedPlanToExecute buildOutcomes @@ -476,22 +529,21 @@ runProjectPostBuildPhase verbosity -- an exception to terminate the program dieOnBuildFailures verbosity currentCommand elaboratedPlanToExecute buildOutcomes - -- Note that it is a deliberate design choice that the 'buildTargets' is - -- not passed to phase 1, and the various bits of input config is not - -- passed to phase 2. - -- - -- We make the install plan without looking at the particular targets the - -- user asks us to build. The set of available things we can build is - -- discovered from the env and config and is used to make the install plan. - -- The targets just tell us which parts of the install plan to execute. - -- - -- Conversely, executing the plan does not directly depend on any of the - -- input config. The bits that are needed (or better, the decisions based - -- on it) all go into the install plan. - - -- Notionally, the 'BuildFlags' should be things that do not affect what - -- we build, just how we do it. These ones of course do +-- Note that it is a deliberate design choice that the 'buildTargets' is +-- not passed to phase 1, and the various bits of input config is not +-- passed to phase 2. +-- +-- We make the install plan without looking at the particular targets the +-- user asks us to build. The set of available things we can build is +-- discovered from the env and config and is used to make the install plan. +-- The targets just tell us which parts of the install plan to execute. +-- +-- Conversely, executing the plan does not directly depend on any of the +-- input config. The bits that are needed (or better, the decisions based +-- on it) all go into the install plan. +-- Notionally, the 'BuildFlags' should be things that do not affect what +-- we build, just how we do it. These ones of course do ------------------------------------------------------------------------------ -- Taking targets into account, selecting what to build @@ -505,7 +557,6 @@ runProjectPostBuildPhase verbosity -- matched this target. Typically this is exactly one, but in general it is -- possible to for different selectors to match the same target. This extra -- information is primarily to help make helpful error messages. --- type TargetsMap = Map UnitId [(ComponentTarget, NonEmpty TargetSelector)] -- | Get all target selectors. @@ -547,51 +598,62 @@ uniqueTargetSelectors = ordNub . allTargetSelectors -- checking a user target that refers to a specific component. To help with -- this commands can use 'selectComponentTargetBasic', either directly or as -- a basis for their own @selectComponentTarget@ implementation. --- -resolveTargets :: forall err. - (forall k. TargetSelector - -> [AvailableTarget k] - -> Either (TargetProblem err) [k]) - -> (forall k. SubComponentTarget - -> AvailableTarget k - -> Either (TargetProblem err) k ) - -> ElaboratedInstallPlan - -> Maybe (SourcePackageDb) - -> [TargetSelector] - -> Either [TargetProblem err] TargetsMap -resolveTargets selectPackageTargets selectComponentTarget - installPlan mPkgDb = - fmap mkTargetsMap - . either (Left . toList) Right - . checkErrors - . map (\ts -> (,) ts <$> checkTarget ts) - where - mkTargetsMap :: [(TargetSelector, [(UnitId, ComponentTarget)])] - -> TargetsMap - mkTargetsMap targets = - Map.map nubComponentTargets - $ Map.fromListWith (<>) - [ (uid, [(ct, ts)]) - | (ts, cts) <- targets - , (uid, ct) <- cts ] - - AvailableTargetIndexes{..} = availableTargetIndexes installPlan - - checkTarget :: TargetSelector -> Either (TargetProblem err) [(UnitId, ComponentTarget)] - - -- We can ask to build any whole package, project-local or a dependency - checkTarget bt@(TargetPackage _ [pkgid] mkfilter) - | Just ats <- fmap (maybe id filterTargetsKind mkfilter) - $ Map.lookup pkgid availableTargetsByPackageId - = fmap (componentTargets WholeComponent) - $ selectPackageTargets bt ats - - | otherwise - = Left (TargetProblemNoSuchPackage pkgid) - - checkTarget (TargetPackage _ pkgids _) - = error ("TODO: add support for multiple packages in a directory. Got\n" - ++ unlines (map prettyShow pkgids)) +resolveTargets + :: forall err + . ( forall k + . TargetSelector + -> [AvailableTarget k] + -> Either (TargetProblem err) [k] + ) + -> ( forall k + . SubComponentTarget + -> AvailableTarget k + -> Either (TargetProblem err) k + ) + -> ElaboratedInstallPlan + -> Maybe (SourcePackageDb) + -> [TargetSelector] + -> Either [TargetProblem err] TargetsMap +resolveTargets + selectPackageTargets + selectComponentTarget + installPlan + mPkgDb = + fmap mkTargetsMap + . either (Left . toList) Right + . checkErrors + . map (\ts -> (,) ts <$> checkTarget ts) + where + mkTargetsMap + :: [(TargetSelector, [(UnitId, ComponentTarget)])] + -> TargetsMap + mkTargetsMap targets = + Map.map nubComponentTargets $ + Map.fromListWith + (<>) + [ (uid, [(ct, ts)]) + | (ts, cts) <- targets + , (uid, ct) <- cts + ] + + AvailableTargetIndexes{..} = availableTargetIndexes installPlan + + checkTarget :: TargetSelector -> Either (TargetProblem err) [(UnitId, ComponentTarget)] + + -- We can ask to build any whole package, project-local or a dependency + checkTarget bt@(TargetPackage _ [pkgid] mkfilter) + | Just ats <- + fmap (maybe id filterTargetsKind mkfilter) $ + Map.lookup pkgid availableTargetsByPackageId = + fmap (componentTargets WholeComponent) $ + selectPackageTargets bt ats + | otherwise = + Left (TargetProblemNoSuchPackage pkgid) + checkTarget (TargetPackage _ pkgids _) = + error + ( "TODO: add support for multiple packages in a directory. Got\n" + ++ unlines (map prettyShow pkgids) + ) -- For the moment this error cannot happen here, because it gets -- detected when the package config is being constructed. This case -- will need handling properly when we do add support. @@ -600,92 +662,86 @@ resolveTargets selectPackageTargets selectComponentTarget -- '--cabal-file' option of 'configure' which allows using multiple -- .cabal files for a single package? - checkTarget bt@(TargetAllPackages mkfilter) = + checkTarget bt@(TargetAllPackages mkfilter) = fmap (componentTargets WholeComponent) - . selectPackageTargets bt - . maybe id filterTargetsKind mkfilter - . filter availableTargetLocalToProject - $ concat (Map.elems availableTargetsByPackageId) - - checkTarget (TargetComponent pkgid cname subtarget) - | Just ats <- Map.lookup (pkgid, cname) - availableTargetsByPackageIdAndComponentName - = fmap (componentTargets subtarget) - $ selectComponentTargets subtarget ats - - | Map.member pkgid availableTargetsByPackageId - = Left (TargetProblemNoSuchComponent pkgid cname) - - | otherwise - = Left (TargetProblemNoSuchPackage pkgid) - - checkTarget (TargetComponentUnknown pkgname ecname subtarget) - | Just ats <- case ecname of - Left ucname -> - Map.lookup (pkgname, ucname) - availableTargetsByPackageNameAndUnqualComponentName - Right cname -> - Map.lookup (pkgname, cname) - availableTargetsByPackageNameAndComponentName - = fmap (componentTargets subtarget) - $ selectComponentTargets subtarget ats - - | Map.member pkgname availableTargetsByPackageName - = Left (TargetProblemUnknownComponent pkgname ecname) - - | otherwise - = Left (TargetNotInProject pkgname) - - checkTarget bt@(TargetPackageNamed pkgname mkfilter) - | Just ats <- fmap (maybe id filterTargetsKind mkfilter) - $ Map.lookup pkgname availableTargetsByPackageName - = fmap (componentTargets WholeComponent) - . selectPackageTargets bt - $ ats - - | Just SourcePackageDb{ packageIndex } <- mPkgDb - , let pkg = lookupPackageName packageIndex pkgname - , not (null pkg) - = Left (TargetAvailableInIndex pkgname) - - | otherwise - = Left (TargetNotInProject pkgname) - - componentTargets :: SubComponentTarget - -> [(b, ComponentName)] - -> [(b, ComponentTarget)] - componentTargets subtarget = - map (fmap (\cname -> ComponentTarget cname subtarget)) - - selectComponentTargets :: SubComponentTarget - -> [AvailableTarget k] - -> Either (TargetProblem err) [k] - selectComponentTargets subtarget = + . selectPackageTargets bt + . maybe id filterTargetsKind mkfilter + . filter availableTargetLocalToProject + $ concat (Map.elems availableTargetsByPackageId) + checkTarget (TargetComponent pkgid cname subtarget) + | Just ats <- + Map.lookup + (pkgid, cname) + availableTargetsByPackageIdAndComponentName = + fmap (componentTargets subtarget) $ + selectComponentTargets subtarget ats + | Map.member pkgid availableTargetsByPackageId = + Left (TargetProblemNoSuchComponent pkgid cname) + | otherwise = + Left (TargetProblemNoSuchPackage pkgid) + checkTarget (TargetComponentUnknown pkgname ecname subtarget) + | Just ats <- case ecname of + Left ucname -> + Map.lookup + (pkgname, ucname) + availableTargetsByPackageNameAndUnqualComponentName + Right cname -> + Map.lookup + (pkgname, cname) + availableTargetsByPackageNameAndComponentName = + fmap (componentTargets subtarget) $ + selectComponentTargets subtarget ats + | Map.member pkgname availableTargetsByPackageName = + Left (TargetProblemUnknownComponent pkgname ecname) + | otherwise = + Left (TargetNotInProject pkgname) + checkTarget bt@(TargetPackageNamed pkgname mkfilter) + | Just ats <- + fmap (maybe id filterTargetsKind mkfilter) $ + Map.lookup pkgname availableTargetsByPackageName = + fmap (componentTargets WholeComponent) + . selectPackageTargets bt + $ ats + | Just SourcePackageDb{packageIndex} <- mPkgDb + , let pkg = lookupPackageName packageIndex pkgname + , not (null pkg) = + Left (TargetAvailableInIndex pkgname) + | otherwise = + Left (TargetNotInProject pkgname) + + componentTargets + :: SubComponentTarget + -> [(b, ComponentName)] + -> [(b, ComponentTarget)] + componentTargets subtarget = + map (fmap (\cname -> ComponentTarget cname subtarget)) + + selectComponentTargets + :: SubComponentTarget + -> [AvailableTarget k] + -> Either (TargetProblem err) [k] + selectComponentTargets subtarget = either (Left . NE.head) Right - . checkErrors - . map (selectComponentTarget subtarget) - - checkErrors :: [Either e a] -> Either (NonEmpty e) [a] - checkErrors = (\(es, xs) -> case es of { [] -> Right xs; (e:es') -> Left (e:|es') }) - . partitionEithers - - -data AvailableTargetIndexes = AvailableTargetIndexes { - availableTargetsByPackageIdAndComponentName - :: AvailableTargetsMap (PackageId, ComponentName), - - availableTargetsByPackageId - :: AvailableTargetsMap PackageId, - - availableTargetsByPackageName - :: AvailableTargetsMap PackageName, - - availableTargetsByPackageNameAndComponentName - :: AvailableTargetsMap (PackageName, ComponentName), - - availableTargetsByPackageNameAndUnqualComponentName - :: AvailableTargetsMap (PackageName, UnqualComponentName) - } + . checkErrors + . map (selectComponentTarget subtarget) + + checkErrors :: [Either e a] -> Either (NonEmpty e) [a] + checkErrors = + (\(es, xs) -> case es of [] -> Right xs; (e : es') -> Left (e :| es')) + . partitionEithers + +data AvailableTargetIndexes = AvailableTargetIndexes + { availableTargetsByPackageIdAndComponentName + :: AvailableTargetsMap (PackageId, ComponentName) + , availableTargetsByPackageId + :: AvailableTargetsMap PackageId + , availableTargetsByPackageName + :: AvailableTargetsMap PackageName + , availableTargetsByPackageNameAndComponentName + :: AvailableTargetsMap (PackageName, ComponentName) + , availableTargetsByPackageNameAndUnqualComponentName + :: AvailableTargetsMap (PackageName, UnqualComponentName) + } type AvailableTargetsMap k = Map k [AvailableTarget (UnitId, ComponentName)] -- We define a bunch of indexes to help 'resolveTargets' with resolving @@ -700,50 +756,59 @@ type AvailableTargetsMap k = Map k [AvailableTarget (UnitId, ComponentName)] availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes availableTargetIndexes installPlan = AvailableTargetIndexes{..} where - availableTargetsByPackageIdAndComponentName :: - Map (PackageId, ComponentName) + availableTargetsByPackageIdAndComponentName + :: Map + (PackageId, ComponentName) [AvailableTarget (UnitId, ComponentName)] availableTargetsByPackageIdAndComponentName = availableTargets installPlan - availableTargetsByPackageId :: - Map PackageId [AvailableTarget (UnitId, ComponentName)] + availableTargetsByPackageId + :: Map PackageId [AvailableTarget (UnitId, ComponentName)] availableTargetsByPackageId = - Map.mapKeysWith - (++) (\(pkgid, _cname) -> pkgid) - availableTargetsByPackageIdAndComponentName - `Map.union` availableTargetsEmptyPackages + Map.mapKeysWith + (++) + (\(pkgid, _cname) -> pkgid) + availableTargetsByPackageIdAndComponentName + `Map.union` availableTargetsEmptyPackages - availableTargetsByPackageName :: - Map PackageName [AvailableTarget (UnitId, ComponentName)] + availableTargetsByPackageName + :: Map PackageName [AvailableTarget (UnitId, ComponentName)] availableTargetsByPackageName = Map.mapKeysWith - (++) packageName + (++) + packageName availableTargetsByPackageId - availableTargetsByPackageNameAndComponentName :: - Map (PackageName, ComponentName) + availableTargetsByPackageNameAndComponentName + :: Map + (PackageName, ComponentName) [AvailableTarget (UnitId, ComponentName)] availableTargetsByPackageNameAndComponentName = Map.mapKeysWith - (++) (\(pkgid, cname) -> (packageName pkgid, cname)) + (++) + (\(pkgid, cname) -> (packageName pkgid, cname)) availableTargetsByPackageIdAndComponentName - availableTargetsByPackageNameAndUnqualComponentName :: - Map (PackageName, UnqualComponentName) + availableTargetsByPackageNameAndUnqualComponentName + :: Map + (PackageName, UnqualComponentName) [AvailableTarget (UnitId, ComponentName)] availableTargetsByPackageNameAndUnqualComponentName = Map.mapKeysWith - (++) (\(pkgid, cname) -> let pname = packageName pkgid - cname' = unqualComponentName pname cname - in (pname, cname')) + (++) + ( \(pkgid, cname) -> + let pname = packageName pkgid + cname' = unqualComponentName pname cname + in (pname, cname') + ) availableTargetsByPackageIdAndComponentName where - unqualComponentName :: - PackageName -> ComponentName -> UnqualComponentName + unqualComponentName + :: PackageName -> ComponentName -> UnqualComponentName unqualComponentName pkgname = - fromMaybe (packageNameToUnqualComponentName pkgname) - . componentNameString + fromMaybe (packageNameToUnqualComponentName pkgname) + . componentNameString -- Add in all the empty packages. These do not appear in the -- availableTargetsByComponent map, since that only contains @@ -758,44 +823,51 @@ availableTargetIndexes installPlan = AvailableTargetIndexes{..} | InstallPlan.Configured pkg <- InstallPlan.toList installPlan , case elabPkgOrComp pkg of ElabComponent _ -> False - ElabPackage _ -> null (pkgComponents (elabPkgDescription pkg)) + ElabPackage _ -> null (pkgComponents (elabPkgDescription pkg)) ] - --TODO: [research required] what if the solution has multiple - -- versions of this package? - -- e.g. due to setup deps or due to multiple independent sets - -- of packages being built (e.g. ghc + ghcjs in a project) +-- TODO: [research required] what if the solution has multiple +-- versions of this package? +-- e.g. due to setup deps or due to multiple independent sets +-- of packages being built (e.g. ghc + ghcjs in a project) filterTargetsKind :: ComponentKind -> [AvailableTarget k] -> [AvailableTarget k] filterTargetsKind ckind = filterTargetsKindWith (== ckind) -filterTargetsKindWith :: (ComponentKind -> Bool) - -> [AvailableTarget k] -> [AvailableTarget k] +filterTargetsKindWith + :: (ComponentKind -> Bool) + -> [AvailableTarget k] + -> [AvailableTarget k] filterTargetsKindWith p ts = - [ t | t@(AvailableTarget _ cname _ _) <- ts - , p (componentKind cname) ] + [ t | t@(AvailableTarget _ cname _ _) <- ts, p (componentKind cname) + ] selectBuildableTargets :: [AvailableTarget k] -> [k] selectBuildableTargets = selectBuildableTargetsWith (const True) -zipBuildableTargetsWith :: (TargetRequested -> Bool) - -> [AvailableTarget k] -> [(k, AvailableTarget k)] +zipBuildableTargetsWith + :: (TargetRequested -> Bool) + -> [AvailableTarget k] + -> [(k, AvailableTarget k)] zipBuildableTargetsWith p ts = - [ (k, t) | t@(AvailableTarget _ _ (TargetBuildable k req) _) <- ts, p req ] + [(k, t) | t@(AvailableTarget _ _ (TargetBuildable k req) _) <- ts, p req] -selectBuildableTargetsWith :: (TargetRequested -> Bool) - -> [AvailableTarget k] -> [k] +selectBuildableTargetsWith + :: (TargetRequested -> Bool) + -> [AvailableTarget k] + -> [k] selectBuildableTargetsWith p = map fst . zipBuildableTargetsWith p selectBuildableTargets' :: [AvailableTarget k] -> ([k], [AvailableTarget ()]) selectBuildableTargets' = selectBuildableTargetsWith' (const True) -selectBuildableTargetsWith' :: (TargetRequested -> Bool) - -> [AvailableTarget k] -> ([k], [AvailableTarget ()]) +selectBuildableTargetsWith' + :: (TargetRequested -> Bool) + -> [AvailableTarget k] + -> ([k], [AvailableTarget ()]) selectBuildableTargetsWith' p = (fmap . map) forgetTargetDetail . unzip . zipBuildableTargetsWith p - forgetTargetDetail :: AvailableTarget k -> AvailableTarget () forgetTargetDetail = fmap (const ()) @@ -806,39 +878,38 @@ forgetTargetsDetail = map forgetTargetDetail -- 'resolveTargets', that does the basic checks that the component is -- buildable and isn't a test suite or benchmark that is disabled. This -- can also be used to do these basic checks as part of a custom impl that --- -selectComponentTargetBasic :: SubComponentTarget - -> AvailableTarget k - -> Either (TargetProblem a) k -selectComponentTargetBasic subtarget - AvailableTarget { - availableTargetPackageId = pkgid, - availableTargetComponentName = cname, - availableTargetStatus - } = +selectComponentTargetBasic + :: SubComponentTarget + -> AvailableTarget k + -> Either (TargetProblem a) k +selectComponentTargetBasic + subtarget + AvailableTarget + { availableTargetPackageId = pkgid + , availableTargetComponentName = cname + , availableTargetStatus + } = case availableTargetStatus of TargetDisabledByUser -> Left (TargetOptionalStanzaDisabledByUser pkgid cname subtarget) - TargetDisabledBySolver -> Left (TargetOptionalStanzaDisabledBySolver pkgid cname subtarget) - TargetNotLocal -> Left (TargetComponentNotProjectLocal pkgid cname subtarget) - TargetNotBuildable -> Left (TargetComponentNotBuildable pkgid cname subtarget) - TargetBuildable targetKey _ -> Right targetKey -- | Wrapper around 'ProjectPlanning.pruneInstallPlanToTargets' that adjusts -- for the extra unneeded info in the 'TargetsMap'. --- -pruneInstallPlanToTargets :: TargetAction -> TargetsMap - -> ElaboratedInstallPlan -> ElaboratedInstallPlan +pruneInstallPlanToTargets + :: TargetAction + -> TargetsMap + -> ElaboratedInstallPlan + -> ElaboratedInstallPlan pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan = - assert (Map.size targetsMap > 0) $ + assert (Map.size targetsMap > 0) $ ProjectPlanning.pruneInstallPlanToTargets targetActionType (Map.map (map fst) targetsMap) @@ -846,13 +917,13 @@ pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan = -- | Utility used by repl and run to check if the targets spans multiple -- components, since those commands do not support multiple components. --- distinctTargetComponents :: TargetsMap -> Set.Set (UnitId, ComponentName) distinctTargetComponents targetsMap = - Set.fromList [ (uid, cname) - | (uid, cts) <- Map.toList targetsMap - , (ComponentTarget cname _, _) <- cts ] - + Set.fromList + [ (uid, cname) + | (uid, cts) <- Map.toList targetsMap + , (ComponentTarget cname _, _) <- cts + ] ------------------------------------------------------------------------------ -- Displaying what we plan to do @@ -860,157 +931,179 @@ distinctTargetComponents targetsMap = -- | Print a user-oriented presentation of the install plan, indicating what -- will be built. --- -printPlan :: Verbosity - -> ProjectBaseContext - -> ProjectBuildContext - -> IO () -printPlan verbosity - ProjectBaseContext { - buildSettings = BuildTimeSettings{buildSettingDryRun}, - projectConfig = ProjectConfig { - projectConfigAllPackages = - PackageConfig {packageConfigOptimization = globalOptimization}, - projectConfigLocalPackages = - PackageConfig {packageConfigOptimization = localOptimization} - }, - currentCommand - } - ProjectBuildContext { - elaboratedPlanToExecute = elaboratedPlan, - elaboratedShared, - pkgsBuildStatus - } - | null pkgs && currentCommand == BuildCommand - = notice verbosity "Up to date" - | not (null pkgs) = noticeNoWrap verbosity $ unlines $ - (showBuildProfile ++ "In order, the following " - ++ wouldWill ++ " be built" - ++ ifNormal " (use -v for more details)" ++ ":") - : map showPkgAndReason pkgs - | otherwise = return () - where - pkgs = InstallPlan.executionOrder elaboratedPlan - - ifVerbose s | verbosity >= verbose = s - | otherwise = "" - - ifNormal s | verbosity >= verbose = "" - | otherwise = s - - wouldWill | buildSettingDryRun = "would" - | otherwise = "will" - - showPkgAndReason :: ElaboratedReadyPackage -> String - showPkgAndReason (ReadyPackage elab) = unwords $ filter (not . null) $ - [ " -" - , if verbosity >= deafening - then prettyShow (installedUnitId elab) - else prettyShow (packageId elab) - , case elabPkgOrComp elab of - ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas (pkgStanzasEnabled pkg)) - ElabComponent comp -> - "(" ++ showComp elab comp ++ ")" - , showFlagAssignment (nonDefaultFlags elab) - , showConfigureFlags elab - , let buildStatus = pkgsBuildStatus Map.! installedUnitId elab - in "(" ++ showBuildStatus buildStatus ++ ")" - ] - - showComp :: ElaboratedConfiguredPackage -> ElaboratedComponent -> String - showComp elab comp = - maybe "custom" prettyShow (compComponentName comp) ++ - if Map.null (elabInstantiatedWith elab) +printPlan + :: Verbosity + -> ProjectBaseContext + -> ProjectBuildContext + -> IO () +printPlan + verbosity + ProjectBaseContext + { buildSettings = BuildTimeSettings{buildSettingDryRun} + , projectConfig = + ProjectConfig + { projectConfigAllPackages = + PackageConfig{packageConfigOptimization = globalOptimization} + , projectConfigLocalPackages = + PackageConfig{packageConfigOptimization = localOptimization} + } + , currentCommand + } + ProjectBuildContext + { elaboratedPlanToExecute = elaboratedPlan + , elaboratedShared + , pkgsBuildStatus + } + | null pkgs && currentCommand == BuildCommand = + notice verbosity "Up to date" + | not (null pkgs) = + noticeNoWrap verbosity $ + unlines $ + ( showBuildProfile + ++ "In order, the following " + ++ wouldWill + ++ " be built" + ++ ifNormal " (use -v for more details)" + ++ ":" + ) + : map showPkgAndReason pkgs + | otherwise = return () + where + pkgs = InstallPlan.executionOrder elaboratedPlan + + ifVerbose s + | verbosity >= verbose = s + | otherwise = "" + + ifNormal s + | verbosity >= verbose = "" + | otherwise = s + + wouldWill + | buildSettingDryRun = "would" + | otherwise = "will" + + showPkgAndReason :: ElaboratedReadyPackage -> String + showPkgAndReason (ReadyPackage elab) = + unwords $ + filter (not . null) $ + [ " -" + , if verbosity >= deafening + then prettyShow (installedUnitId elab) + else prettyShow (packageId elab) + , case elabPkgOrComp elab of + ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas (pkgStanzasEnabled pkg)) + ElabComponent comp -> + "(" ++ showComp elab comp ++ ")" + , showFlagAssignment (nonDefaultFlags elab) + , showConfigureFlags elab + , let buildStatus = pkgsBuildStatus Map.! installedUnitId elab + in "(" ++ showBuildStatus buildStatus ++ ")" + ] + + showComp :: ElaboratedConfiguredPackage -> ElaboratedComponent -> String + showComp elab comp = + maybe "custom" prettyShow (compComponentName comp) + ++ if Map.null (elabInstantiatedWith elab) then "" - else " with " ++ - intercalate ", " - -- TODO: Abbreviate the UnitIds - [ prettyShow k ++ "=" ++ prettyShow v - | (k,v) <- Map.toList (elabInstantiatedWith elab) ] - - nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment - nonDefaultFlags elab = - elabFlagAssignment elab `diffFlagAssignment` elabFlagDefaults elab - - showTargets :: ElaboratedConfiguredPackage -> String - showTargets elab - | null (elabBuildTargets elab) = "" - | otherwise - = "(" - ++ intercalate ", " [ showComponentTarget (packageId elab) t - | t <- elabBuildTargets elab ] - ++ ")" - - showConfigureFlags :: ElaboratedConfiguredPackage -> String - showConfigureFlags elab = - let fullConfigureFlags - = setupHsConfigureFlags - (ReadyPackage elab) - elaboratedShared - verbosity - "$builddir" - -- | Given a default value @x@ for a flag, nub @Flag x@ + else + " with " + ++ intercalate + ", " + -- TODO: Abbreviate the UnitIds + [ prettyShow k ++ "=" ++ prettyShow v + | (k, v) <- Map.toList (elabInstantiatedWith elab) + ] + + nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment + nonDefaultFlags elab = + elabFlagAssignment elab `diffFlagAssignment` elabFlagDefaults elab + + showTargets :: ElaboratedConfiguredPackage -> String + showTargets elab + | null (elabBuildTargets elab) = "" + | otherwise = + "(" + ++ intercalate + ", " + [ showComponentTarget (packageId elab) t + | t <- elabBuildTargets elab + ] + ++ ")" + + showConfigureFlags :: ElaboratedConfiguredPackage -> String + showConfigureFlags elab = + let fullConfigureFlags = + setupHsConfigureFlags + (ReadyPackage elab) + elaboratedShared + verbosity + "$builddir" + -- \| Given a default value @x@ for a flag, nub @Flag x@ -- into @NoFlag@. This gives us a tidier command line -- rendering. nubFlag :: Eq a => a -> Setup.Flag a -> Setup.Flag a nubFlag x (Setup.Flag x') | x == x' = Setup.NoFlag - nubFlag _ f = f + nubFlag _ f = f (tryLibProfiling, tryExeProfiling) = computeEffectiveProfiling fullConfigureFlags - partialConfigureFlags - = mempty { - configProf = - nubFlag False (configProf fullConfigureFlags), - configProfExe = - nubFlag tryExeProfiling (configProfExe fullConfigureFlags), - configProfLib = + partialConfigureFlags = + mempty + { configProf = + nubFlag False (configProf fullConfigureFlags) + , configProfExe = + nubFlag tryExeProfiling (configProfExe fullConfigureFlags) + , configProfLib = nubFlag tryLibProfiling (configProfLib fullConfigureFlags) - -- Maybe there are more we can add - } - -- Not necessary to "escape" it, it's just for user output - in unwords . ("":) $ - commandShowOptions - (Setup.configureCommand (pkgConfigCompilerProgs elaboratedShared)) - partialConfigureFlags - - showBuildStatus :: BuildStatus -> String - showBuildStatus status = case status of - BuildStatusPreExisting -> "existing package" - BuildStatusInstalled -> "already installed" - BuildStatusDownload {} -> "requires download & build" - BuildStatusUnpack {} -> "requires build" - BuildStatusRebuild _ rebuild -> case rebuild of - BuildStatusConfigure - (MonitoredValueChanged _) -> "configuration changed" - BuildStatusConfigure mreason -> showMonitorChangedReason mreason - BuildStatusBuild _ buildreason -> case buildreason of - BuildReasonDepsRebuilt -> "dependency rebuilt" - BuildReasonFilesChanged - mreason -> showMonitorChangedReason mreason - BuildReasonExtraTargets _ -> "additional components to build" - BuildReasonEphemeralTargets -> "ephemeral targets" - BuildStatusUpToDate {} -> "up to date" -- doesn't happen - - showMonitorChangedReason :: MonitorChangedReason a -> String - showMonitorChangedReason (MonitoredFileChanged file) = - "file " ++ file ++ " changed" - showMonitorChangedReason (MonitoredValueChanged _) = "value changed" - showMonitorChangedReason MonitorFirstRun = "first run" - showMonitorChangedReason MonitorCorruptCache = - "cannot read state cache" - - showBuildProfile :: String - showBuildProfile = "Build profile: " ++ unwords [ - "-w " ++ (showCompilerId . pkgConfigCompiler) elaboratedShared, - "-O" ++ (case globalOptimization <> localOptimization of -- if local is not set, read global - Setup.Flag NoOptimisation -> "0" - Setup.Flag NormalOptimisation -> "1" - Setup.Flag MaximumOptimisation -> "2" - Setup.NoFlag -> "1")] - ++ "\n" - + -- Maybe there are more we can add + } + in -- Not necessary to "escape" it, it's just for user output + unwords . ("" :) $ + commandShowOptions + (Setup.configureCommand (pkgConfigCompilerProgs elaboratedShared)) + partialConfigureFlags + + showBuildStatus :: BuildStatus -> String + showBuildStatus status = case status of + BuildStatusPreExisting -> "existing package" + BuildStatusInstalled -> "already installed" + BuildStatusDownload{} -> "requires download & build" + BuildStatusUnpack{} -> "requires build" + BuildStatusRebuild _ rebuild -> case rebuild of + BuildStatusConfigure + (MonitoredValueChanged _) -> "configuration changed" + BuildStatusConfigure mreason -> showMonitorChangedReason mreason + BuildStatusBuild _ buildreason -> case buildreason of + BuildReasonDepsRebuilt -> "dependency rebuilt" + BuildReasonFilesChanged + mreason -> showMonitorChangedReason mreason + BuildReasonExtraTargets _ -> "additional components to build" + BuildReasonEphemeralTargets -> "ephemeral targets" + BuildStatusUpToDate{} -> "up to date" -- doesn't happen + showMonitorChangedReason :: MonitorChangedReason a -> String + showMonitorChangedReason (MonitoredFileChanged file) = + "file " ++ file ++ " changed" + showMonitorChangedReason (MonitoredValueChanged _) = "value changed" + showMonitorChangedReason MonitorFirstRun = "first run" + showMonitorChangedReason MonitorCorruptCache = + "cannot read state cache" + + showBuildProfile :: String + showBuildProfile = + "Build profile: " + ++ unwords + [ "-w " ++ (showCompilerId . pkgConfigCompiler) elaboratedShared + , "-O" + ++ ( case globalOptimization <> localOptimization of -- if local is not set, read global + Setup.Flag NoOptimisation -> "0" + Setup.Flag NormalOptimisation -> "1" + Setup.Flag MaximumOptimisation -> "2" + Setup.NoFlag -> "1" + ) + ] + ++ "\n" writeBuildReports :: BuildTimeSettings -> ProjectBuildContext -> ElaboratedInstallPlan -> BuildOutcomes -> IO () writeBuildReports settings buildContext plan buildOutcomes = do @@ -1019,130 +1112,136 @@ writeBuildReports settings buildContext plan buildOutcomes = do getRepo (RepoTarballPackage r _ _) = Just r getRepo _ = Nothing fromPlanPackage (InstallPlan.Configured pkg) (Just result) = - let installOutcome = case result of - Left bf -> case buildFailureReason bf of - GracefulFailure _ -> BuildReports.PlanningFailed - DependentFailed p -> BuildReports.DependencyFailed p - DownloadFailed _ -> BuildReports.DownloadFailed - UnpackFailed _ -> BuildReports.UnpackFailed - ConfigureFailed _ -> BuildReports.ConfigureFailed - BuildFailed _ -> BuildReports.BuildFailed - TestsFailed _ -> BuildReports.TestsFailed - InstallFailed _ -> BuildReports.InstallFailed - - ReplFailed _ -> BuildReports.InstallOk - HaddocksFailed _ -> BuildReports.InstallOk - BenchFailed _ -> BuildReports.InstallOk - - Right _br -> BuildReports.InstallOk - - docsOutcome = case result of - Left bf -> case buildFailureReason bf of - HaddocksFailed _ -> BuildReports.Failed - _ -> BuildReports.NotTried - Right br -> case buildResultDocs br of - DocsNotTried -> BuildReports.NotTried - DocsFailed -> BuildReports.Failed - DocsOk -> BuildReports.Ok - - testsOutcome = case result of - Left bf -> case buildFailureReason bf of - TestsFailed _ -> BuildReports.Failed - _ -> BuildReports.NotTried - Right br -> case buildResultTests br of - TestsNotTried -> BuildReports.NotTried - TestsOk -> BuildReports.Ok - - in Just $ (BuildReports.BuildReport (packageId pkg) os arch (compilerId comp) cabalInstallID (elabFlagAssignment pkg) (map packageId $ elabLibDependencies pkg) installOutcome docsOutcome testsOutcome, getRepo . elabPkgSourceLocation $ pkg) -- TODO handle failure log files? + let installOutcome = case result of + Left bf -> case buildFailureReason bf of + GracefulFailure _ -> BuildReports.PlanningFailed + DependentFailed p -> BuildReports.DependencyFailed p + DownloadFailed _ -> BuildReports.DownloadFailed + UnpackFailed _ -> BuildReports.UnpackFailed + ConfigureFailed _ -> BuildReports.ConfigureFailed + BuildFailed _ -> BuildReports.BuildFailed + TestsFailed _ -> BuildReports.TestsFailed + InstallFailed _ -> BuildReports.InstallFailed + ReplFailed _ -> BuildReports.InstallOk + HaddocksFailed _ -> BuildReports.InstallOk + BenchFailed _ -> BuildReports.InstallOk + Right _br -> BuildReports.InstallOk + + docsOutcome = case result of + Left bf -> case buildFailureReason bf of + HaddocksFailed _ -> BuildReports.Failed + _ -> BuildReports.NotTried + Right br -> case buildResultDocs br of + DocsNotTried -> BuildReports.NotTried + DocsFailed -> BuildReports.Failed + DocsOk -> BuildReports.Ok + + testsOutcome = case result of + Left bf -> case buildFailureReason bf of + TestsFailed _ -> BuildReports.Failed + _ -> BuildReports.NotTried + Right br -> case buildResultTests br of + TestsNotTried -> BuildReports.NotTried + TestsOk -> BuildReports.Ok + in Just $ (BuildReports.BuildReport (packageId pkg) os arch (compilerId comp) cabalInstallID (elabFlagAssignment pkg) (map packageId $ elabLibDependencies pkg) installOutcome docsOutcome testsOutcome, getRepo . elabPkgSourceLocation $ pkg) -- TODO handle failure log files? fromPlanPackage _ _ = Nothing buildReports = mapMaybe (\x -> fromPlanPackage x (InstallPlan.lookupBuildOutcome x buildOutcomes)) $ InstallPlan.toList plan + BuildReports.storeLocal + (compilerInfo comp) + (buildSettingSummaryFile settings) + buildReports + plat - BuildReports.storeLocal (compilerInfo comp) - (buildSettingSummaryFile settings) - buildReports - plat - -- Note this doesn't handle the anonymous build reports set by buildSettingBuildReports but those appear to not be used or missed from v1 - -- The usage pattern appears to be that rather than rely on flags to cabal to send build logs to the right place and package them with reports, etc, it is easier to simply capture its output to an appropriate handle. +-- Note this doesn't handle the anonymous build reports set by buildSettingBuildReports but those appear to not be used or missed from v1 +-- The usage pattern appears to be that rather than rely on flags to cabal to send build logs to the right place and package them with reports, etc, it is easier to simply capture its output to an appropriate handle. -- | If there are build failures then report them and throw an exception. --- -dieOnBuildFailures :: Verbosity -> CurrentCommand - -> ElaboratedInstallPlan -> BuildOutcomes -> IO () +dieOnBuildFailures + :: Verbosity + -> CurrentCommand + -> ElaboratedInstallPlan + -> BuildOutcomes + -> IO () dieOnBuildFailures verbosity currentCommand plan buildOutcomes | null failures = return () - - | isSimpleCase = exitFailure - + | isSimpleCase = exitFailure | otherwise = do -- For failures where we have a build log, print the log plus a header - sequence_ - [ do notice verbosity $ - '\n' : renderFailureDetail False pkg reason - ++ "\nBuild log ( " ++ logfile ++ " ):" - readFile logfile >>= noticeNoWrap verbosity - | (pkg, ShowBuildSummaryAndLog reason logfile) - <- failuresClassification - ] - - -- For all failures, print either a short summary (if we showed the - -- build log) or all details - dieIfNotHaddockFailure verbosity $ unlines - [ case failureClassification of - ShowBuildSummaryAndLog reason _ - | verbosity > normal - -> renderFailureDetail mentionDepOf pkg reason - - | otherwise - -> renderFailureSummary mentionDepOf pkg reason - ++ ". See the build log above for details." - - ShowBuildSummaryOnly reason -> - renderFailureDetail mentionDepOf pkg reason - - | let mentionDepOf = verbosity <= normal - , (pkg, failureClassification) <- failuresClassification ] + sequence_ + [ do + notice verbosity $ + '\n' + : renderFailureDetail False pkg reason + ++ "\nBuild log ( " + ++ logfile + ++ " ):" + readFile logfile >>= noticeNoWrap verbosity + | (pkg, ShowBuildSummaryAndLog reason logfile) <- + failuresClassification + ] + + -- For all failures, print either a short summary (if we showed the + -- build log) or all details + dieIfNotHaddockFailure verbosity $ + unlines + [ case failureClassification of + ShowBuildSummaryAndLog reason _ + | verbosity > normal -> + renderFailureDetail mentionDepOf pkg reason + | otherwise -> + renderFailureSummary mentionDepOf pkg reason + ++ ". See the build log above for details." + ShowBuildSummaryOnly reason -> + renderFailureDetail mentionDepOf pkg reason + | let mentionDepOf = verbosity <= normal + , (pkg, failureClassification) <- failuresClassification + ] where failures :: [(UnitId, BuildFailure)] - failures = [ (pkgid, failure) - | (pkgid, Left failure) <- Map.toList buildOutcomes ] + failures = + [ (pkgid, failure) + | (pkgid, Left failure) <- Map.toList buildOutcomes + ] failuresClassification :: [(ElaboratedConfiguredPackage, BuildFailurePresentation)] failuresClassification = [ (pkg, classifyBuildFailure failure) | (pkgid, failure) <- failures , case buildFailureReason failure of - DependentFailed {} -> verbosity > normal - _ -> True + DependentFailed{} -> verbosity > normal + _ -> True , InstallPlan.Configured pkg <- - maybeToList (InstallPlan.lookup plan pkgid) + maybeToList (InstallPlan.lookup plan pkgid) ] dieIfNotHaddockFailure :: Verbosity -> String -> IO () dieIfNotHaddockFailure - | currentCommand == HaddockCommand = die' + | currentCommand == HaddockCommand = die' | all isHaddockFailure failuresClassification = warn - | otherwise = die' + | otherwise = die' where isHaddockFailure - (_, ShowBuildSummaryOnly (HaddocksFailed _) ) = True + (_, ShowBuildSummaryOnly (HaddocksFailed _)) = True isHaddockFailure (_, ShowBuildSummaryAndLog (HaddocksFailed _) _) = True isHaddockFailure - _ = False - + _ = False classifyBuildFailure :: BuildFailure -> BuildFailurePresentation - classifyBuildFailure BuildFailure { - buildFailureReason = reason, - buildFailureLogFile = mlogfile - } = - maybe (ShowBuildSummaryOnly reason) - (ShowBuildSummaryAndLog reason) $ do - logfile <- mlogfile - e <- buildFailureException reason - ExitFailure 1 <- fromException e - return logfile + classifyBuildFailure + BuildFailure + { buildFailureReason = reason + , buildFailureLogFile = mlogfile + } = + maybe + (ShowBuildSummaryOnly reason) + (ShowBuildSummaryAndLog reason) + $ do + logfile <- mlogfile + e <- buildFailureException reason + ExitFailure 1 <- fromException e + return logfile -- Special case: we don't want to report anything complicated in the case -- of just doing build on the current package, since it's clear from @@ -1158,13 +1257,13 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes isSimpleCase :: Bool isSimpleCase | [(pkgid, failure)] <- failures - , [pkg] <- rootpkgs + , [pkg] <- rootpkgs , installedUnitId pkg == pkgid , isFailureSelfExplanatory (buildFailureReason failure) - , currentCommand `notElem` [InstallCommand, BuildCommand, ReplCommand] - = True - | otherwise - = False + , currentCommand `notElem` [InstallCommand, BuildCommand, ReplCommand] = + True + | otherwise = + False -- NB: if the Setup script segfaulted or was interrupted, -- we should give more detailed information. So only @@ -1172,82 +1271,91 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes isFailureSelfExplanatory :: BuildFailureReason -> Bool isFailureSelfExplanatory (BuildFailed e) | Just (ExitFailure 1) <- fromException e = True - isFailureSelfExplanatory (ConfigureFailed e) | Just (ExitFailure 1) <- fromException e = True - - isFailureSelfExplanatory _ = False + isFailureSelfExplanatory _ = False rootpkgs :: [ElaboratedConfiguredPackage] rootpkgs = [ pkg | InstallPlan.Configured pkg <- InstallPlan.toList plan - , hasNoDependents pkg ] + , hasNoDependents pkg + ] ultimateDeps :: UnitId -> [InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage] ultimateDeps pkgid = - filter (\pkg -> hasNoDependents pkg && installedUnitId pkg /= pkgid) - (InstallPlan.reverseDependencyClosure plan [pkgid]) + filter + (\pkg -> hasNoDependents pkg && installedUnitId pkg /= pkgid) + (InstallPlan.reverseDependencyClosure plan [pkgid]) hasNoDependents :: HasUnitId pkg => pkg -> Bool hasNoDependents = null . InstallPlan.revDirectDeps plan . installedUnitId renderFailureDetail :: Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String renderFailureDetail mentionDepOf pkg reason = - renderFailureSummary mentionDepOf pkg reason ++ "." - ++ renderFailureExtraDetail reason - ++ maybe "" showException (buildFailureException reason) + renderFailureSummary mentionDepOf pkg reason + ++ "." + ++ renderFailureExtraDetail reason + ++ maybe "" showException (buildFailureException reason) renderFailureSummary :: Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String renderFailureSummary mentionDepOf pkg reason = - case reason of - DownloadFailed _ -> "Failed to download " ++ pkgstr - UnpackFailed _ -> "Failed to unpack " ++ pkgstr - ConfigureFailed _ -> "Failed to build " ++ pkgstr - BuildFailed _ -> "Failed to build " ++ pkgstr - ReplFailed _ -> "repl failed for " ++ pkgstr - HaddocksFailed _ -> "Failed to build documentation for " ++ pkgstr - TestsFailed _ -> "Tests failed for " ++ pkgstr - BenchFailed _ -> "Benchmarks failed for " ++ pkgstr - InstallFailed _ -> "Failed to build " ++ pkgstr - GracefulFailure msg -> msg - DependentFailed depid - -> "Failed to build " ++ prettyShow (packageId pkg) - ++ " because it depends on " ++ prettyShow depid - ++ " which itself failed to build" + case reason of + DownloadFailed _ -> "Failed to download " ++ pkgstr + UnpackFailed _ -> "Failed to unpack " ++ pkgstr + ConfigureFailed _ -> "Failed to build " ++ pkgstr + BuildFailed _ -> "Failed to build " ++ pkgstr + ReplFailed _ -> "repl failed for " ++ pkgstr + HaddocksFailed _ -> "Failed to build documentation for " ++ pkgstr + TestsFailed _ -> "Tests failed for " ++ pkgstr + BenchFailed _ -> "Benchmarks failed for " ++ pkgstr + InstallFailed _ -> "Failed to build " ++ pkgstr + GracefulFailure msg -> msg + DependentFailed depid -> + "Failed to build " + ++ prettyShow (packageId pkg) + ++ " because it depends on " + ++ prettyShow depid + ++ " which itself failed to build" where - pkgstr = elabConfiguredName verbosity pkg - ++ if mentionDepOf - then renderDependencyOf (installedUnitId pkg) - else "" + pkgstr = + elabConfiguredName verbosity pkg + ++ if mentionDepOf + then renderDependencyOf (installedUnitId pkg) + else "" renderFailureExtraDetail :: BuildFailureReason -> String renderFailureExtraDetail (ConfigureFailed _) = " The failure occurred during the configure step." - renderFailureExtraDetail (InstallFailed _) = + renderFailureExtraDetail (InstallFailed _) = " The failure occurred during the final install step." - renderFailureExtraDetail _ = + renderFailureExtraDetail _ = "" renderDependencyOf :: UnitId -> String renderDependencyOf pkgid = case ultimateDeps pkgid of - [] -> "" - (p1:[]) -> + [] -> "" + (p1 : []) -> " (which is required by " ++ elabPlanPackageName verbosity p1 ++ ")" - (p1:p2:[]) -> - " (which is required by " ++ elabPlanPackageName verbosity p1 - ++ " and " ++ elabPlanPackageName verbosity p2 ++ ")" - (p1:p2:_) -> - " (which is required by " ++ elabPlanPackageName verbosity p1 - ++ ", " ++ elabPlanPackageName verbosity p2 - ++ " and others)" - + (p1 : p2 : []) -> + " (which is required by " + ++ elabPlanPackageName verbosity p1 + ++ " and " + ++ elabPlanPackageName verbosity p2 + ++ ")" + (p1 : p2 : _) -> + " (which is required by " + ++ elabPlanPackageName verbosity p1 + ++ ", " + ++ elabPlanPackageName verbosity p2 + ++ " and others)" + +{- FOURMOLU_DISABLE -} showException e = case fromException e of Just (ExitFailure 1) -> "" - #ifdef MIN_VERSION_unix -- Note [Positive "signal" exit code] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1265,52 +1373,53 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes Just (ExitFailure n) | -n == fromIntegral sigSEGV -> " The build process segfaulted (i.e. SIGSEGV)." - - | n == fromIntegral sigSEGV -> - " The build process terminated with exit code " ++ show n - ++ " which may be because some part of it segfaulted. (i.e. SIGSEGV)." - + | n == fromIntegral sigSEGV -> + " The build process terminated with exit code " + ++ show n + ++ " which may be because some part of it segfaulted. (i.e. SIGSEGV)." | -n == fromIntegral sigKILL -> " The build process was killed (i.e. SIGKILL). " ++ explanation - - | n == fromIntegral sigKILL -> - " The build process terminated with exit code " ++ show n - ++ " which may be because some part of it was killed " - ++ "(i.e. SIGKILL). " ++ explanation + | n == fromIntegral sigKILL -> + " The build process terminated with exit code " + ++ show n + ++ " which may be because some part of it was killed " + ++ "(i.e. SIGKILL). " + ++ explanation where explanation = "The typical reason for this is that there is not " - ++ "enough memory available (e.g. the OS killed a process " - ++ "using lots of memory)." + ++ "enough memory available (e.g. the OS killed a process " + ++ "using lots of memory)." #endif Just (ExitFailure n) -> " The build process terminated with exit code " ++ show n - - _ -> " The exception was:\n " + _ -> + " The exception was:\n " #if MIN_VERSION_base(4,8,0) - ++ displayException e + ++ displayException e #else - ++ show e + ++ show e #endif buildFailureException :: BuildFailureReason -> Maybe SomeException buildFailureException reason = case reason of - DownloadFailed e -> Just e - UnpackFailed e -> Just e + DownloadFailed e -> Just e + UnpackFailed e -> Just e ConfigureFailed e -> Just e - BuildFailed e -> Just e - ReplFailed e -> Just e - HaddocksFailed e -> Just e - TestsFailed e -> Just e - BenchFailed e -> Just e - InstallFailed e -> Just e + BuildFailed e -> Just e + ReplFailed e -> Just e + HaddocksFailed e -> Just e + TestsFailed e -> Just e + BenchFailed e -> Just e + InstallFailed e -> Just e GracefulFailure _ -> Nothing DependentFailed _ -> Nothing +{- FOURMOLU_ENABLE -} -data BuildFailurePresentation = - ShowBuildSummaryOnly BuildFailureReason - | ShowBuildSummaryAndLog BuildFailureReason FilePath +data BuildFailurePresentation + = ShowBuildSummaryOnly BuildFailureReason + | ShowBuildSummaryAndLog BuildFailureReason FilePath ------------------------------------------------------------------------------- -- Dummy projects @@ -1321,54 +1430,58 @@ data BuildFailurePresentation = establishDummyProjectBaseContext :: Verbosity -> ProjectConfig - -- ^ Project configuration including the global config if needed + -- ^ Project configuration including the global config if needed -> DistDirLayout - -- ^ Where to put the dist directory + -- ^ Where to put the dist directory -> [PackageSpecifier UnresolvedSourcePackage] - -- ^ The packages to be included in the project + -- ^ The packages to be included in the project -> CurrentCommand -> IO ProjectBaseContext establishDummyProjectBaseContext verbosity projectConfig distDirLayout localPackages currentCommand = do - let ProjectConfigBuildOnly { - projectConfigLogsDir + let ProjectConfigBuildOnly + { projectConfigLogsDir } = projectConfigBuildOnly projectConfig - ProjectConfigShared { - projectConfigStoreDir + ProjectConfigShared + { projectConfigStoreDir } = projectConfigShared projectConfig - mlogsDir = flagToMaybe projectConfigLogsDir - mstoreDir = flagToMaybe projectConfigStoreDir - - cabalDirLayout <- mkCabalDirLayout mstoreDir mlogsDir - - let buildSettings :: BuildTimeSettings - buildSettings = resolveBuildTimeSettings - verbosity cabalDirLayout - projectConfig - installedPackages = Nothing - - return ProjectBaseContext { - distDirLayout, - cabalDirLayout, - projectConfig, - localPackages, - buildSettings, - currentCommand, - installedPackages - } + mlogsDir = flagToMaybe projectConfigLogsDir + mstoreDir = flagToMaybe projectConfigStoreDir + + cabalDirLayout <- mkCabalDirLayout mstoreDir mlogsDir + + let buildSettings :: BuildTimeSettings + buildSettings = + resolveBuildTimeSettings + verbosity + cabalDirLayout + projectConfig + installedPackages = Nothing + + return + ProjectBaseContext + { distDirLayout + , cabalDirLayout + , projectConfig + , localPackages + , buildSettings + , currentCommand + , installedPackages + } establishDummyDistDirLayout :: Verbosity -> ProjectConfig -> FilePath -> IO DistDirLayout establishDummyDistDirLayout verbosity cliConfig tmpDir = do - let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory Nothing + let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory Nothing - -- Create the dist directories - createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout - createDirectoryIfMissingVerbose verbosity True $ distProjectCacheDirectory distDirLayout + -- Create the dist directories + createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout + createDirectoryIfMissingVerbose verbosity True $ distProjectCacheDirectory distDirLayout - return distDirLayout + return distDirLayout where - mdistDirectory = flagToMaybe - $ projectConfigDistDir - $ projectConfigShared cliConfig + mdistDirectory = + flagToMaybe $ + projectConfigDistDir $ + projectConfigShared cliConfig projectRoot = ProjectRootImplicit tmpDir diff --git a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs index c9243c310e0..0cdb512e215 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs @@ -1,29 +1,34 @@ -{-# LANGUAGE BangPatterns, RecordWildCards, NamedFieldPuns, - DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving, - ScopedTypeVariables #-} - -module Distribution.Client.ProjectPlanOutput ( - -- * Plan output - writePlanExternalRepresentation, +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Distribution.Client.ProjectPlanOutput + ( -- * Plan output + writePlanExternalRepresentation -- * Project status + -- | Several outputs rely on having a general overview of - PostBuildProjectStatus(..), - updatePostBuildProjectStatus, - createPackageEnvironment, - writePlanGhcEnvironment, - argsEquivalentOfGhcEnvironmentFile, + , PostBuildProjectStatus (..) + , updatePostBuildProjectStatus + , createPackageEnvironment + , writePlanGhcEnvironment + , argsEquivalentOfGhcEnvironmentFile ) where -import Distribution.Client.ProjectPlanning.Types -import Distribution.Client.ProjectBuilding.Types -import Distribution.Client.DistDirLayout -import Distribution.Client.Types.Repo (Repo(..), RemoteRepo(..)) -import Distribution.Client.Types.PackageLocation (PackageLocation(..)) -import Distribution.Client.Types.ConfiguredId (confInstId) -import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..)) -import Distribution.Client.HashValue (showHashValue, hashValue) -import Distribution.Client.Version (cabalInstallVersion) +import Distribution.Client.DistDirLayout +import Distribution.Client.HashValue (hashValue, showHashValue) +import Distribution.Client.ProjectBuilding.Types +import Distribution.Client.ProjectPlanning.Types +import Distribution.Client.Types.ConfiguredId (confInstId) +import Distribution.Client.Types.PackageLocation (PackageLocation (..)) +import Distribution.Client.Types.Repo (RemoteRepo (..), Repo (..)) +import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..)) +import Distribution.Client.Version (cabalInstallVersion) import qualified Distribution.Client.InstallPlan as InstallPlan import qualified Distribution.Client.Utils.Json as J @@ -31,39 +36,52 @@ import qualified Distribution.Simple.InstallDirs as InstallDirs import qualified Distribution.Solver.Types.ComponentDeps as ComponentDeps -import Distribution.Package -import Distribution.System -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.PackageDescription as PD -import Distribution.Compiler (CompilerFlavor(GHC, GHCJS)) -import Distribution.Simple.Compiler - ( PackageDBStack, PackageDB(..) - , compilerVersion, compilerFlavor, showCompilerId - , compilerId, CompilerId(..), Compiler ) -import Distribution.Simple.GHC - ( getImplInfo, GhcImplInfo(supportsPkgEnvFiles) - , GhcEnvironmentFileEntry(..), simpleGhcEnvironmentFile - , writeGhcEnvironmentFile ) -import Distribution.Simple.BuildPaths - ( dllExtension, exeExtension, buildInfoPref ) -import qualified Distribution.Compat.Graph as Graph -import Distribution.Compat.Graph (Graph, Node) import qualified Distribution.Compat.Binary as Binary -import Distribution.Simple.Utils -import Distribution.Types.Version - ( mkVersion ) -import Distribution.Verbosity +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 +import Distribution.Simple.BuildPaths + ( buildInfoPref + , dllExtension + , exeExtension + ) +import Distribution.Simple.Compiler + ( Compiler + , CompilerId (..) + , PackageDB (..) + , PackageDBStack + , compilerFlavor + , compilerId + , compilerVersion + , showCompilerId + ) +import Distribution.Simple.GHC + ( GhcEnvironmentFileEntry (..) + , GhcImplInfo (supportsPkgEnvFiles) + , getImplInfo + , simpleGhcEnvironmentFile + , writeGhcEnvironmentFile + ) +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Types.Version + ( mkVersion + ) +import Distribution.Verbosity -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy as BS import qualified Data.Map as Map import qualified Data.Set as Set -import qualified Data.ByteString.Lazy as BS -import qualified Data.ByteString.Builder as BB -import System.FilePath -import System.IO +import System.FilePath +import System.IO import Distribution.Simple.Program.GHC (packageDbArgsDb) @@ -74,33 +92,36 @@ import Distribution.Simple.Program.GHC (packageDbArgsDb) -- | Write out a representation of the elaborated install plan. -- -- This is for the benefit of debugging and external tools like editors. --- -writePlanExternalRepresentation :: DistDirLayout - -> ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> IO () -writePlanExternalRepresentation distDirLayout elaboratedInstallPlan - elaboratedSharedConfig = - writeFileAtomic (distProjectCacheFile distDirLayout "plan.json") $ - BB.toLazyByteString - . J.encodeToBuilder +writePlanExternalRepresentation + :: DistDirLayout + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> IO () +writePlanExternalRepresentation + distDirLayout + elaboratedInstallPlan + elaboratedSharedConfig = + writeFileAtomic (distProjectCacheFile distDirLayout "plan.json") + $ BB.toLazyByteString + . J.encodeToBuilder $ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig -- | Renders a subset of the elaborated install plan in a semi-stable JSON -- format. --- encodePlanAsJson :: DistDirLayout -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> J.Value encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = - --TODO: [nice to have] include all of the sharedPackageConfig and all of - -- the parts of the elaboratedInstallPlan - J.object [ "cabal-version" J..= jdisplay cabalInstallVersion - , "cabal-lib-version" J..= jdisplay cabalVersion - , "compiler-id" J..= (J.String . showCompilerId . pkgConfigCompiler) - elaboratedSharedConfig - , "os" J..= jdisplay os - , "arch" J..= jdisplay arch - , "install-plan" J..= installPlanToJ elaboratedInstallPlan - ] + -- TODO: [nice to have] include all of the sharedPackageConfig and all of + -- the parts of the elaboratedInstallPlan + J.object + [ "cabal-version" J..= jdisplay cabalInstallVersion + , "cabal-lib-version" J..= jdisplay cabalVersion + , "compiler-id" + J..= (J.String . showCompilerId . pkgConfigCompiler) + elaboratedSharedConfig + , "os" J..= jdisplay os + , "arch" J..= jdisplay arch + , "install-plan" J..= installPlanToJ elaboratedInstallPlan + ] where plat :: Platform plat@(Platform arch os) = pkgConfigPlatform elaboratedSharedConfig @@ -113,11 +134,11 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = case pkg of InstallPlan.PreExisting ipi -> installedPackageInfoToJ ipi InstallPlan.Configured elab -> elaboratedPackageToJ False elab - InstallPlan.Installed elab -> elaboratedPackageToJ True elab - -- Note that the plan.json currently only uses the elaborated plan, - -- not the improved plan. So we will not get the Installed state for - -- that case, but the code supports it in case we want to use this - -- later in some use case where we want the status of the build. + InstallPlan.Installed elab -> elaboratedPackageToJ True elab + -- Note that the plan.json currently only uses the elaborated plan, + -- not the improved plan. So we will not get the Installed state for + -- that case, but the code supports it in case we want to use this + -- later in some use case where we want the status of the build. installedPackageInfoToJ :: InstalledPackageInfo -> J.Value installedPackageInfoToJ ipi = @@ -127,154 +148,181 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = -- So these packages are never local to the project. -- J.object - [ "type" J..= J.String "pre-existing" - , "id" J..= (jdisplay . installedUnitId) ipi - , "pkg-name" J..= (jdisplay . pkgName . packageId) ipi + [ "type" J..= J.String "pre-existing" + , "id" J..= (jdisplay . installedUnitId) ipi + , "pkg-name" J..= (jdisplay . pkgName . packageId) ipi , "pkg-version" J..= (jdisplay . pkgVersion . packageId) ipi - , "depends" J..= map jdisplay (installedDepends ipi) + , "depends" J..= map jdisplay (installedDepends ipi) ] elaboratedPackageToJ :: Bool -> ElaboratedConfiguredPackage -> J.Value elaboratedPackageToJ isInstalled elab = J.object $ - [ "type" J..= J.String (if isInstalled then "installed" - else "configured") - , "id" J..= (jdisplay . installedUnitId) elab - , "pkg-name" J..= (jdisplay . pkgName . packageId) elab + [ "type" + J..= J.String + ( if isInstalled + then "installed" + else "configured" + ) + , "id" J..= (jdisplay . installedUnitId) elab + , "pkg-name" J..= (jdisplay . pkgName . packageId) elab , "pkg-version" J..= (jdisplay . pkgVersion . packageId) elab - , "flags" J..= J.object [ PD.unFlagName fn J..= v - | (fn,v) <- PD.unFlagAssignment (elabFlagAssignment elab) ] - , "style" J..= J.String (style2str (elabLocalToProject elab) (elabBuildStyle elab)) - , "pkg-src" J..= packageLocationToJ (elabPkgSourceLocation elab) - ] ++ - [ "pkg-cabal-sha256" J..= J.String (showHashValue hash) - | Just hash <- [ fmap hashValue (elabPkgDescriptionOverride elab) ] ] ++ - [ "pkg-src-sha256" J..= J.String (showHashValue hash) - | Just hash <- [elabPkgSourceHash elab] ] ++ - (case elabBuildStyle elab of - BuildInplaceOnly -> - ["dist-dir" J..= J.String dist_dir] ++ [buildInfoFileLocation] - BuildAndInstall -> - -- TODO: install dirs? - [] - ) ++ - case elabPkgOrComp elab of - ElabPackage pkg -> - let components = J.object $ - [ comp2str c J..= (J.object $ - [ "depends" J..= map (jdisplay . confInstId) ldeps - , "exe-depends" J..= map (jdisplay . confInstId) edeps - ] ++ - bin_file c) - | (c,(ldeps,edeps)) - <- ComponentDeps.toList $ - ComponentDeps.zip (pkgLibDependencies pkg) - (pkgExeDependencies pkg) ] - in ["components" J..= components] - ElabComponent comp -> - ["depends" J..= map (jdisplay . confInstId) (elabLibDependencies elab) - ,"exe-depends" J..= map jdisplay (elabExeDependencies elab) - ,"component-name" J..= J.String (comp2str (compSolverName comp)) - ] ++ - bin_file (compSolverName comp) - where - -- | Only add build-info file location if the Setup.hs CLI - -- is recent enough to be able to generate build info files. - -- Otherwise, write 'null'. - -- - -- Consumers of `plan.json` can use the nullability of this file location - -- to indicate that the given component uses `build-type: Custom` - -- with an old lib:Cabal version. - buildInfoFileLocation :: J.Pair - buildInfoFileLocation - | elabSetupScriptCliVersion elab < mkVersion [3, 7, 0, 0] - = "build-info" J..= J.Null - | otherwise - = "build-info" J..= J.String (buildInfoPref dist_dir) - - packageLocationToJ :: PackageLocation (Maybe FilePath) -> J.Value - packageLocationToJ pkgloc = - case pkgloc of - LocalUnpackedPackage local -> - J.object [ "type" J..= J.String "local" - , "path" J..= J.String local - ] - LocalTarballPackage local -> - J.object [ "type" J..= J.String "local-tar" - , "path" J..= J.String local - ] - RemoteTarballPackage uri _ -> - J.object [ "type" J..= J.String "remote-tar" - , "uri" J..= J.String (show uri) - ] - RepoTarballPackage repo _ _ -> - J.object [ "type" J..= J.String "repo-tar" - , "repo" J..= repoToJ repo - ] - RemoteSourceRepoPackage srcRepo _ -> - J.object [ "type" J..= J.String "source-repo" - , "source-repo" J..= sourceRepoToJ srcRepo - ] - - repoToJ :: Repo -> J.Value - repoToJ repo = - case repo of - RepoLocalNoIndex{..} -> - J.object [ "type" J..= J.String "local-repo-no-index" - , "path" J..= J.String repoLocalDir - ] - RepoRemote{..} -> - J.object [ "type" J..= J.String "remote-repo" - , "uri" J..= J.String (show (remoteRepoURI repoRemote)) - ] - RepoSecure{..} -> - J.object [ "type" J..= J.String "secure-repo" - , "uri" J..= J.String (show (remoteRepoURI repoRemote)) - ] - - sourceRepoToJ :: SourceRepoMaybe -> J.Value - sourceRepoToJ SourceRepositoryPackage{..} = - J.object $ filter ((/= J.Null) . snd) $ - [ "type" J..= jdisplay srpType - , "location" J..= J.String srpLocation - , "branch" J..= fmap J.String srpBranch - , "tag" J..= fmap J.String srpTag - , "subdir" J..= fmap J.String srpSubdir - ] - - dist_dir :: FilePath - dist_dir = distBuildDirectory distDirLayout - (elabDistDirParams elaboratedSharedConfig elab) - - bin_file :: ComponentDeps.Component -> [J.Pair] - bin_file c = case c of - ComponentDeps.ComponentExe s -> bin_file' s - ComponentDeps.ComponentTest s -> bin_file' s - ComponentDeps.ComponentBench s -> bin_file' s - ComponentDeps.ComponentFLib s -> flib_file' s - _ -> [] - bin_file' s = - ["bin-file" J..= J.String bin] - where - bin = if elabBuildStyle elab == BuildInplaceOnly - then dist_dir "build" prettyShow s prettyShow s <.> exeExtension plat - else InstallDirs.bindir (elabInstallDirs elab) prettyShow s <.> exeExtension plat - - flib_file' :: (Pretty a, Show a) => a -> [J.Pair] - flib_file' s = - ["bin-file" J..= J.String bin] - where - bin = if elabBuildStyle elab == BuildInplaceOnly - then dist_dir "build" prettyShow s ("lib" ++ prettyShow s) <.> dllExtension plat - else InstallDirs.bindir (elabInstallDirs elab) ("lib" ++ prettyShow s) <.> dllExtension plat + , "flags" + J..= J.object + [ PD.unFlagName fn J..= v + | (fn, v) <- PD.unFlagAssignment (elabFlagAssignment elab) + ] + , "style" J..= J.String (style2str (elabLocalToProject elab) (elabBuildStyle elab)) + , "pkg-src" J..= packageLocationToJ (elabPkgSourceLocation elab) + ] + ++ [ "pkg-cabal-sha256" J..= J.String (showHashValue hash) + | Just hash <- [fmap hashValue (elabPkgDescriptionOverride elab)] + ] + ++ [ "pkg-src-sha256" J..= J.String (showHashValue hash) + | Just hash <- [elabPkgSourceHash elab] + ] + ++ ( case elabBuildStyle elab of + BuildInplaceOnly -> + ["dist-dir" J..= J.String dist_dir] ++ [buildInfoFileLocation] + BuildAndInstall -> + -- TODO: install dirs? + [] + ) + ++ case elabPkgOrComp elab of + ElabPackage pkg -> + let components = + J.object $ + [ comp2str c + J..= ( J.object $ + [ "depends" J..= map (jdisplay . confInstId) ldeps + , "exe-depends" J..= map (jdisplay . confInstId) edeps + ] + ++ bin_file c + ) + | (c, (ldeps, edeps)) <- + ComponentDeps.toList $ + ComponentDeps.zip + (pkgLibDependencies pkg) + (pkgExeDependencies pkg) + ] + in ["components" J..= components] + ElabComponent comp -> + [ "depends" J..= map (jdisplay . confInstId) (elabLibDependencies elab) + , "exe-depends" J..= map jdisplay (elabExeDependencies elab) + , "component-name" J..= J.String (comp2str (compSolverName comp)) + ] + ++ bin_file (compSolverName comp) + where + -- \| Only add build-info file location if the Setup.hs CLI + -- is recent enough to be able to generate build info files. + -- Otherwise, write 'null'. + -- + -- Consumers of `plan.json` can use the nullability of this file location + -- to indicate that the given component uses `build-type: Custom` + -- with an old lib:Cabal version. + buildInfoFileLocation :: J.Pair + buildInfoFileLocation + | elabSetupScriptCliVersion elab < mkVersion [3, 7, 0, 0] = + "build-info" J..= J.Null + | otherwise = + "build-info" J..= J.String (buildInfoPref dist_dir) + + packageLocationToJ :: PackageLocation (Maybe FilePath) -> J.Value + packageLocationToJ pkgloc = + case pkgloc of + LocalUnpackedPackage local -> + J.object + [ "type" J..= J.String "local" + , "path" J..= J.String local + ] + LocalTarballPackage local -> + J.object + [ "type" J..= J.String "local-tar" + , "path" J..= J.String local + ] + RemoteTarballPackage uri _ -> + J.object + [ "type" J..= J.String "remote-tar" + , "uri" J..= J.String (show uri) + ] + RepoTarballPackage repo _ _ -> + J.object + [ "type" J..= J.String "repo-tar" + , "repo" J..= repoToJ repo + ] + RemoteSourceRepoPackage srcRepo _ -> + J.object + [ "type" J..= J.String "source-repo" + , "source-repo" J..= sourceRepoToJ srcRepo + ] + + repoToJ :: Repo -> J.Value + repoToJ repo = + case repo of + RepoLocalNoIndex{..} -> + J.object + [ "type" J..= J.String "local-repo-no-index" + , "path" J..= J.String repoLocalDir + ] + RepoRemote{..} -> + J.object + [ "type" J..= J.String "remote-repo" + , "uri" J..= J.String (show (remoteRepoURI repoRemote)) + ] + RepoSecure{..} -> + J.object + [ "type" J..= J.String "secure-repo" + , "uri" J..= J.String (show (remoteRepoURI repoRemote)) + ] + + sourceRepoToJ :: SourceRepoMaybe -> J.Value + sourceRepoToJ SourceRepositoryPackage{..} = + J.object $ + filter ((/= J.Null) . snd) $ + [ "type" J..= jdisplay srpType + , "location" J..= J.String srpLocation + , "branch" J..= fmap J.String srpBranch + , "tag" J..= fmap J.String srpTag + , "subdir" J..= fmap J.String srpSubdir + ] + + dist_dir :: FilePath + dist_dir = + distBuildDirectory + distDirLayout + (elabDistDirParams elaboratedSharedConfig elab) + + bin_file :: ComponentDeps.Component -> [J.Pair] + bin_file c = case c of + ComponentDeps.ComponentExe s -> bin_file' s + ComponentDeps.ComponentTest s -> bin_file' s + ComponentDeps.ComponentBench s -> bin_file' s + ComponentDeps.ComponentFLib s -> flib_file' s + _ -> [] + bin_file' s = + ["bin-file" J..= J.String bin] + where + bin = + if elabBuildStyle elab == BuildInplaceOnly + then dist_dir "build" prettyShow s prettyShow s <.> exeExtension plat + else InstallDirs.bindir (elabInstallDirs elab) prettyShow s <.> exeExtension plat + + flib_file' :: (Pretty a, Show a) => a -> [J.Pair] + flib_file' s = + ["bin-file" J..= J.String bin] + where + bin = + if elabBuildStyle elab == BuildInplaceOnly + then dist_dir "build" prettyShow s ("lib" ++ prettyShow s) <.> dllExtension plat + else InstallDirs.bindir (elabInstallDirs elab) ("lib" ++ prettyShow s) <.> dllExtension plat comp2str :: ComponentDeps.Component -> String comp2str = prettyShow style2str :: Bool -> BuildStyle -> String - style2str True _ = "local" + style2str True _ = "local" style2str False BuildInplaceOnly = "inplace" - style2str False BuildAndInstall = "global" + style2str False BuildAndInstall = "global" jdisplay :: Pretty a => a -> J.Value jdisplay = J.String . prettyShow @@ -400,284 +448,270 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = -- successfully then they're still out of date -- meeting our definition of -- invalid. - -type PackageIdSet = Set UnitId +type PackageIdSet = Set UnitId type PackagesUpToDate = PackageIdSet -data PostBuildProjectStatus = PostBuildProjectStatus { - - -- | Packages that are known to be up to date. These were found to be - -- up to date before the build, or they have a successful build outcome - -- afterwards. - -- - -- This does not include any packages outside of the subset of the plan - -- that was executed because we did not check those and so don't know - -- for sure that they're still up to date. - -- - packagesDefinitelyUpToDate :: PackageIdSet, - - -- | Packages that are probably still up to date (and at least not - -- known to be out of date, and certainly not invalid). This includes - -- 'packagesDefinitelyUpToDate' plus packages that were up to date - -- previously and are outside of the subset of the plan that was - -- executed. It excludes 'packagesOutOfDate'. - -- - packagesProbablyUpToDate :: PackageIdSet, - - -- | Packages that are known to be out of date. These are packages - -- that were determined to be out of date before the build, and they - -- do not have a successful build outcome afterwards. - -- - -- Note that this can sometimes include packages outside of the subset - -- of the plan that was executed. For example suppose package A and B - -- depend on C, and A is the target so only A and C are in the subset - -- to be built. Now suppose C is found to have changed, then both A - -- and B are out-of-date before the build and since B is outside the - -- subset to be built then it will remain out of date. - -- - -- Note also that this is /not/ the inverse of - -- 'packagesDefinitelyUpToDate' or 'packagesProbablyUpToDate'. - -- There are packages where we have no information (ones that were not - -- in the subset of the plan that was executed). - -- - packagesOutOfDate :: PackageIdSet, - - -- | Packages that depend on libraries that have changed during the - -- build (either build success or failure). - -- - -- This corresponds to the fact that libraries and dynamic executables - -- are invalid once any of the libs they depend on change. - -- - -- This does include packages that themselves failed (i.e. it is a - -- superset of 'packagesInvalidByFailedBuild'). It does not include - -- changes in dependencies on executables (i.e. build tools). - -- - packagesInvalidByChangedLibDeps :: PackageIdSet, - - -- | Packages that themselves failed during the build (i.e. them - -- directly not a dep). - -- - -- This corresponds to the fact that static executables are invalid - -- in unlucky circumstances such as linking failing half way though, - -- or data file generation failing. - -- - -- This is a subset of 'packagesInvalidByChangedLibDeps'. - -- - packagesInvalidByFailedBuild :: PackageIdSet, - - -- | A subset of the plan graph, including only dependency-on-library - -- edges. That is, dependencies /on/ libraries, not dependencies /of/ - -- libraries. This tells us all the libraries that packages link to. - -- - -- This is here as a convenience, as strictly speaking it's not status - -- as it's just a function of the original 'ElaboratedInstallPlan'. - -- - packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage), - - -- | As a convenience for 'Set.intersection' with any of the other - -- 'PackageIdSet's to select only packages that are part of the - -- project locally (i.e. with a local source dir). - -- - packagesBuildLocal :: PackageIdSet, - - -- | As a convenience for 'Set.intersection' with any of the other - -- 'PackageIdSet's to select only packages that are being built - -- in-place within the project (i.e. not destined for the store). - -- - packagesBuildInplace :: PackageIdSet, - - -- | As a convenience for 'Set.intersection' or 'Set.difference' with - -- any of the other 'PackageIdSet's to select only packages that were - -- pre-installed or already in the store prior to the build. - -- - packagesAlreadyInStore :: PackageIdSet - } +data PostBuildProjectStatus = PostBuildProjectStatus + { packagesDefinitelyUpToDate :: PackageIdSet + -- ^ Packages that are known to be up to date. These were found to be + -- up to date before the build, or they have a successful build outcome + -- afterwards. + -- + -- This does not include any packages outside of the subset of the plan + -- that was executed because we did not check those and so don't know + -- for sure that they're still up to date. + , packagesProbablyUpToDate :: PackageIdSet + -- ^ Packages that are probably still up to date (and at least not + -- known to be out of date, and certainly not invalid). This includes + -- 'packagesDefinitelyUpToDate' plus packages that were up to date + -- previously and are outside of the subset of the plan that was + -- executed. It excludes 'packagesOutOfDate'. + , packagesOutOfDate :: PackageIdSet + -- ^ Packages that are known to be out of date. These are packages + -- that were determined to be out of date before the build, and they + -- do not have a successful build outcome afterwards. + -- + -- Note that this can sometimes include packages outside of the subset + -- of the plan that was executed. For example suppose package A and B + -- depend on C, and A is the target so only A and C are in the subset + -- to be built. Now suppose C is found to have changed, then both A + -- and B are out-of-date before the build and since B is outside the + -- subset to be built then it will remain out of date. + -- + -- Note also that this is /not/ the inverse of + -- 'packagesDefinitelyUpToDate' or 'packagesProbablyUpToDate'. + -- There are packages where we have no information (ones that were not + -- in the subset of the plan that was executed). + , packagesInvalidByChangedLibDeps :: PackageIdSet + -- ^ Packages that depend on libraries that have changed during the + -- build (either build success or failure). + -- + -- This corresponds to the fact that libraries and dynamic executables + -- are invalid once any of the libs they depend on change. + -- + -- This does include packages that themselves failed (i.e. it is a + -- superset of 'packagesInvalidByFailedBuild'). It does not include + -- changes in dependencies on executables (i.e. build tools). + , packagesInvalidByFailedBuild :: PackageIdSet + -- ^ Packages that themselves failed during the build (i.e. them + -- directly not a dep). + -- + -- This corresponds to the fact that static executables are invalid + -- in unlucky circumstances such as linking failing half way though, + -- or data file generation failing. + -- + -- This is a subset of 'packagesInvalidByChangedLibDeps'. + , packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage) + -- ^ A subset of the plan graph, including only dependency-on-library + -- edges. That is, dependencies /on/ libraries, not dependencies /of/ + -- libraries. This tells us all the libraries that packages link to. + -- + -- This is here as a convenience, as strictly speaking it's not status + -- as it's just a function of the original 'ElaboratedInstallPlan'. + , packagesBuildLocal :: PackageIdSet + -- ^ As a convenience for 'Set.intersection' with any of the other + -- 'PackageIdSet's to select only packages that are part of the + -- project locally (i.e. with a local source dir). + , packagesBuildInplace :: PackageIdSet + -- ^ As a convenience for 'Set.intersection' with any of the other + -- 'PackageIdSet's to select only packages that are being built + -- in-place within the project (i.e. not destined for the store). + , packagesAlreadyInStore :: PackageIdSet + -- ^ As a convenience for 'Set.intersection' or 'Set.difference' with + -- any of the other 'PackageIdSet's to select only packages that were + -- pre-installed or already in the store prior to the build. + } -- | Work out which packages are out of date or invalid after a build. --- -postBuildProjectStatus :: ElaboratedInstallPlan - -> PackagesUpToDate - -> BuildStatusMap - -> BuildOutcomes - -> PostBuildProjectStatus -postBuildProjectStatus plan previousPackagesUpToDate - pkgBuildStatus buildOutcomes = - PostBuildProjectStatus { - packagesDefinitelyUpToDate, - packagesProbablyUpToDate, - packagesOutOfDate, - packagesInvalidByChangedLibDeps, - packagesInvalidByFailedBuild, - -- convenience stuff - packagesLibDepGraph, - packagesBuildLocal, - packagesBuildInplace, - packagesAlreadyInStore - } - where - packagesDefinitelyUpToDate = - packagesUpToDatePreBuild - `Set.union` - packagesSuccessfulPostBuild - - packagesProbablyUpToDate = - packagesDefinitelyUpToDate - `Set.union` - (previousPackagesUpToDate' `Set.difference` packagesOutOfDatePreBuild) - - packagesOutOfDate = - packagesOutOfDatePreBuild `Set.difference` packagesSuccessfulPostBuild - - packagesInvalidByChangedLibDeps = - packagesDepOnChangedLib `Set.difference` packagesSuccessfulPostBuild - - packagesInvalidByFailedBuild = - packagesFailurePostBuild - - -- Note: if any of the intermediate values below turn out to be useful in - -- their own right then we can simply promote them to the result record - - -- The previous set of up-to-date packages will contain bogus package ids - -- when the solver plan or config contributing to the hash changes. - -- So keep only the ones where the package id (i.e. hash) is the same. - previousPackagesUpToDate' = - Set.intersection - previousPackagesUpToDate - (InstallPlan.keysSet plan) - - packagesUpToDatePreBuild = - Set.filter - (\ipkgid -> not (lookupBuildStatusRequiresBuild True ipkgid)) - -- For packages not in the plan subset we did the dry-run on we don't - -- know anything about their status, so not known to be /up to date/. - (InstallPlan.keysSet plan) - - packagesOutOfDatePreBuild = - Set.fromList . map installedUnitId $ - InstallPlan.reverseDependencyClosure plan - [ ipkgid - | pkg <- InstallPlan.toList plan - , let ipkgid = installedUnitId pkg - , lookupBuildStatusRequiresBuild False ipkgid - -- For packages not in the plan subset we did the dry-run on we don't - -- know anything about their status, so not known to be /out of date/. - ] - - packagesSuccessfulPostBuild = - Set.fromList - [ ikgid | (ikgid, Right _) <- Map.toList buildOutcomes ] - - -- direct failures, not failures due to deps - packagesFailurePostBuild = - Set.fromList - [ ikgid - | (ikgid, Left failure) <- Map.toList buildOutcomes - , case buildFailureReason failure of - DependentFailed _ -> False - _ -> True - ] - - -- Packages that have a library dependency on a package for which a build - -- was attempted - packagesDepOnChangedLib = - Set.fromList . map Graph.nodeKey $ - fromMaybe (error "packagesBuildStatusAfterBuild: broken dep closure") $ - Graph.revClosure packagesLibDepGraph - ( Map.keys - . Map.filter (uncurry buildAttempted) - $ Map.intersectionWith (,) pkgBuildStatus buildOutcomes - ) - - -- The plan graph but only counting dependency-on-library edges - packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage) - packagesLibDepGraph = - Graph.fromDistinctList - [ Graph.N pkg (installedUnitId pkg) libdeps - | pkg <- InstallPlan.toList plan - , let libdeps = case pkg of - InstallPlan.PreExisting ipkg -> installedDepends ipkg - InstallPlan.Configured srcpkg -> elabLibDeps srcpkg - InstallPlan.Installed srcpkg -> elabLibDeps srcpkg - ] +postBuildProjectStatus + :: ElaboratedInstallPlan + -> PackagesUpToDate + -> BuildStatusMap + -> BuildOutcomes + -> PostBuildProjectStatus +postBuildProjectStatus + plan + previousPackagesUpToDate + pkgBuildStatus + buildOutcomes = + PostBuildProjectStatus + { packagesDefinitelyUpToDate + , packagesProbablyUpToDate + , packagesOutOfDate + , packagesInvalidByChangedLibDeps + , packagesInvalidByFailedBuild + , -- convenience stuff + packagesLibDepGraph + , packagesBuildLocal + , packagesBuildInplace + , packagesAlreadyInStore + } + where + packagesDefinitelyUpToDate = + packagesUpToDatePreBuild + `Set.union` packagesSuccessfulPostBuild + + packagesProbablyUpToDate = + packagesDefinitelyUpToDate + `Set.union` (previousPackagesUpToDate' `Set.difference` packagesOutOfDatePreBuild) + + packagesOutOfDate = + packagesOutOfDatePreBuild `Set.difference` packagesSuccessfulPostBuild + + packagesInvalidByChangedLibDeps = + packagesDepOnChangedLib `Set.difference` packagesSuccessfulPostBuild + + packagesInvalidByFailedBuild = + packagesFailurePostBuild + + -- Note: if any of the intermediate values below turn out to be useful in + -- their own right then we can simply promote them to the result record + + -- The previous set of up-to-date packages will contain bogus package ids + -- when the solver plan or config contributing to the hash changes. + -- So keep only the ones where the package id (i.e. hash) is the same. + previousPackagesUpToDate' = + Set.intersection + previousPackagesUpToDate + (InstallPlan.keysSet plan) + + packagesUpToDatePreBuild = + Set.filter + (\ipkgid -> not (lookupBuildStatusRequiresBuild True ipkgid)) + -- For packages not in the plan subset we did the dry-run on we don't + -- know anything about their status, so not known to be /up to date/. + (InstallPlan.keysSet plan) + + packagesOutOfDatePreBuild = + Set.fromList . map installedUnitId $ + InstallPlan.reverseDependencyClosure + plan + [ ipkgid + | pkg <- InstallPlan.toList plan + , let ipkgid = installedUnitId pkg + , lookupBuildStatusRequiresBuild False ipkgid + -- For packages not in the plan subset we did the dry-run on we don't + -- know anything about their status, so not known to be /out of date/. + ] + + packagesSuccessfulPostBuild = + Set.fromList + [ikgid | (ikgid, Right _) <- Map.toList buildOutcomes] + + -- direct failures, not failures due to deps + packagesFailurePostBuild = + Set.fromList + [ ikgid + | (ikgid, Left failure) <- Map.toList buildOutcomes + , case buildFailureReason failure of + DependentFailed _ -> False + _ -> True + ] - elabLibDeps :: ElaboratedConfiguredPackage -> [UnitId] - elabLibDeps = map (newSimpleUnitId . confInstId) . elabLibDependencies - - -- Was a build was attempted for this package? - -- If it doesn't have both a build status and outcome then the answer is no. - buildAttempted :: BuildStatus -> BuildOutcome -> Bool - -- And not if it didn't need rebuilding in the first place. - buildAttempted buildStatus _buildOutcome - | not (buildStatusRequiresBuild buildStatus) - = False - - -- And not if it was skipped due to a dep failing first. - buildAttempted _ (Left BuildFailure {buildFailureReason}) - | DependentFailed _ <- buildFailureReason - = False - - -- Otherwise, succeeded or failed, yes the build was tried. - buildAttempted _ (Left BuildFailure {}) = True - buildAttempted _ (Right _) = True - - lookupBuildStatusRequiresBuild :: Bool -> UnitId -> Bool - lookupBuildStatusRequiresBuild def ipkgid = - case Map.lookup ipkgid pkgBuildStatus of - Nothing -> def -- Not in the plan subset we did the dry-run on - Just buildStatus -> buildStatusRequiresBuild buildStatus - - packagesBuildLocal :: Set UnitId - packagesBuildLocal = - selectPlanPackageIdSet $ \pkg -> - case pkg of - InstallPlan.PreExisting _ -> False - InstallPlan.Installed _ -> False - InstallPlan.Configured srcpkg -> elabLocalToProject srcpkg - - packagesBuildInplace :: Set UnitId - packagesBuildInplace = - selectPlanPackageIdSet $ \pkg -> - case pkg of - InstallPlan.PreExisting _ -> False - InstallPlan.Installed _ -> False - InstallPlan.Configured srcpkg -> elabBuildStyle srcpkg - == BuildInplaceOnly - packagesAlreadyInStore :: Set UnitId - packagesAlreadyInStore = - selectPlanPackageIdSet $ \pkg -> - case pkg of - InstallPlan.PreExisting _ -> True - InstallPlan.Installed _ -> True - InstallPlan.Configured _ -> False - - selectPlanPackageIdSet - :: (InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage - -> Bool) - -> Set UnitId - selectPlanPackageIdSet p = Map.keysSet - . Map.filter p - $ InstallPlan.toMap plan - - - -updatePostBuildProjectStatus :: Verbosity - -> DistDirLayout - -> ElaboratedInstallPlan - -> BuildStatusMap - -> BuildOutcomes - -> IO PostBuildProjectStatus -updatePostBuildProjectStatus verbosity distDirLayout - elaboratedInstallPlan - pkgsBuildStatus buildOutcomes = do + -- Packages that have a library dependency on a package for which a build + -- was attempted + packagesDepOnChangedLib = + Set.fromList . map Graph.nodeKey $ + fromMaybe (error "packagesBuildStatusAfterBuild: broken dep closure") $ + Graph.revClosure + packagesLibDepGraph + ( Map.keys + . Map.filter (uncurry buildAttempted) + $ Map.intersectionWith (,) pkgBuildStatus buildOutcomes + ) + + -- The plan graph but only counting dependency-on-library edges + packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage) + packagesLibDepGraph = + Graph.fromDistinctList + [ Graph.N pkg (installedUnitId pkg) libdeps + | pkg <- InstallPlan.toList plan + , let libdeps = case pkg of + InstallPlan.PreExisting ipkg -> installedDepends ipkg + InstallPlan.Configured srcpkg -> elabLibDeps srcpkg + InstallPlan.Installed srcpkg -> elabLibDeps srcpkg + ] + elabLibDeps :: ElaboratedConfiguredPackage -> [UnitId] + elabLibDeps = map (newSimpleUnitId . confInstId) . elabLibDependencies + + -- Was a build was attempted for this package? + -- If it doesn't have both a build status and outcome then the answer is no. + buildAttempted :: BuildStatus -> BuildOutcome -> Bool + -- And not if it didn't need rebuilding in the first place. + buildAttempted buildStatus _buildOutcome + | not (buildStatusRequiresBuild buildStatus) = + False + -- And not if it was skipped due to a dep failing first. + buildAttempted _ (Left BuildFailure{buildFailureReason}) + | DependentFailed _ <- buildFailureReason = + False + -- Otherwise, succeeded or failed, yes the build was tried. + buildAttempted _ (Left BuildFailure{}) = True + buildAttempted _ (Right _) = True + + lookupBuildStatusRequiresBuild :: Bool -> UnitId -> Bool + lookupBuildStatusRequiresBuild def ipkgid = + case Map.lookup ipkgid pkgBuildStatus of + Nothing -> def -- Not in the plan subset we did the dry-run on + Just buildStatus -> buildStatusRequiresBuild buildStatus + + packagesBuildLocal :: Set UnitId + packagesBuildLocal = + selectPlanPackageIdSet $ \pkg -> + case pkg of + InstallPlan.PreExisting _ -> False + InstallPlan.Installed _ -> False + InstallPlan.Configured srcpkg -> elabLocalToProject srcpkg + + packagesBuildInplace :: Set UnitId + packagesBuildInplace = + selectPlanPackageIdSet $ \pkg -> + case pkg of + InstallPlan.PreExisting _ -> False + InstallPlan.Installed _ -> False + InstallPlan.Configured srcpkg -> + elabBuildStyle srcpkg + == BuildInplaceOnly + packagesAlreadyInStore :: Set UnitId + packagesAlreadyInStore = + selectPlanPackageIdSet $ \pkg -> + case pkg of + InstallPlan.PreExisting _ -> True + InstallPlan.Installed _ -> True + InstallPlan.Configured _ -> False + + selectPlanPackageIdSet + :: ( InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage + -> Bool + ) + -> Set UnitId + selectPlanPackageIdSet p = + Map.keysSet + . Map.filter p + $ InstallPlan.toMap plan + +updatePostBuildProjectStatus + :: Verbosity + -> DistDirLayout + -> ElaboratedInstallPlan + -> BuildStatusMap + -> BuildOutcomes + -> IO PostBuildProjectStatus +updatePostBuildProjectStatus + verbosity + distDirLayout + elaboratedInstallPlan + pkgsBuildStatus + buildOutcomes = do -- Read the previous up-to-date set, update it and write it back - previousUpToDate <- readPackagesUpToDateCacheFile distDirLayout - let currentBuildStatus@PostBuildProjectStatus{..} - = postBuildProjectStatus - elaboratedInstallPlan - previousUpToDate - pkgsBuildStatus - buildOutcomes + previousUpToDate <- readPackagesUpToDateCacheFile distDirLayout + let currentBuildStatus@PostBuildProjectStatus{..} = + postBuildProjectStatus + elaboratedInstallPlan + previousUpToDate + pkgsBuildStatus + buildOutcomes let currentUpToDate = packagesProbablyUpToDate writePackagesUpToDateCacheFile distDirLayout currentUpToDate @@ -685,50 +719,59 @@ updatePostBuildProjectStatus verbosity distDirLayout -- We additionally intersect with the packagesBuildInplace so that -- we don't show huge numbers of boring packages from the store. debugNoWrap verbosity $ - "packages definitely up to date: " - ++ displayPackageIdSet (packagesDefinitelyUpToDate - `Set.intersection` packagesBuildInplace) + "packages definitely up to date: " + ++ displayPackageIdSet + ( packagesDefinitelyUpToDate + `Set.intersection` packagesBuildInplace + ) debugNoWrap verbosity $ - "packages previously probably up to date: " - ++ displayPackageIdSet (previousUpToDate - `Set.intersection` packagesBuildInplace) + "packages previously probably up to date: " + ++ displayPackageIdSet + ( previousUpToDate + `Set.intersection` packagesBuildInplace + ) debugNoWrap verbosity $ - "packages now probably up to date: " - ++ displayPackageIdSet (packagesProbablyUpToDate - `Set.intersection` packagesBuildInplace) + "packages now probably up to date: " + ++ displayPackageIdSet + ( packagesProbablyUpToDate + `Set.intersection` packagesBuildInplace + ) debugNoWrap verbosity $ - "packages newly up to date: " - ++ displayPackageIdSet (packagesDefinitelyUpToDate - `Set.difference` previousUpToDate - `Set.intersection` packagesBuildInplace) + "packages newly up to date: " + ++ displayPackageIdSet + ( packagesDefinitelyUpToDate + `Set.difference` previousUpToDate + `Set.intersection` packagesBuildInplace + ) debugNoWrap verbosity $ - "packages out to date: " - ++ displayPackageIdSet (packagesOutOfDate - `Set.intersection` packagesBuildInplace) + "packages out to date: " + ++ displayPackageIdSet + ( packagesOutOfDate + `Set.intersection` packagesBuildInplace + ) debugNoWrap verbosity $ - "packages invalid due to dep change: " - ++ displayPackageIdSet packagesInvalidByChangedLibDeps + "packages invalid due to dep change: " + ++ displayPackageIdSet packagesInvalidByChangedLibDeps debugNoWrap verbosity $ - "packages invalid due to build failure: " - ++ displayPackageIdSet packagesInvalidByFailedBuild + "packages invalid due to build failure: " + ++ displayPackageIdSet packagesInvalidByFailedBuild return currentBuildStatus - where - displayPackageIdSet = intercalate ", " . map prettyShow . Set.toList + where + displayPackageIdSet = intercalate ", " . map prettyShow . Set.toList -- | Helper for reading the cache file. -- -- This determines the type and format of the binary cache file. --- readPackagesUpToDateCacheFile :: DistDirLayout -> IO PackagesUpToDate readPackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} = - handleDoesNotExist Set.empty $ + handleDoesNotExist Set.empty $ handleDecodeFailure $ withBinaryFile (distProjectCacheFile "up-to-date") ReadMode $ \hnd -> Binary.decodeOrFailIO =<< BS.hGetContents hnd @@ -738,11 +781,10 @@ readPackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} = -- | Helper for writing the package up-to-date cache file. -- -- This determines the type and format of the binary cache file. --- writePackagesUpToDateCacheFile :: DistDirLayout -> PackagesUpToDate -> IO () writePackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} upToDate = - writeFileAtomic (distProjectCacheFile "up-to-date") $ - Binary.encode upToDate + writeFileAtomic (distProjectCacheFile "up-to-date") $ + Binary.encode upToDate -- | Prepare a package environment that includes all the library dependencies -- for a plan. @@ -753,84 +795,96 @@ writePackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} upToDate = -- temporarily, in case the compiler wants to learn this information via the -- filesystem, and returns any environment variable overrides the compiler -- needs. -createPackageEnvironment :: Verbosity - -> FilePath - -> ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> PostBuildProjectStatus - -> IO [(String, Maybe String)] -createPackageEnvironment verbosity - path - elaboratedPlan - elaboratedShared - buildStatus - | compilerFlavor (pkgConfigCompiler elaboratedShared) == GHC - = do - envFileM <- writePlanGhcEnvironment - path - elaboratedPlan - elaboratedShared - buildStatus - case envFileM of - Just envFile -> return [("GHC_ENVIRONMENT", Just envFile)] - Nothing -> do - warn verbosity "the configured version of GHC does not support reading package lists from the environment; commands that need the current project's package database are likely to fail" - return [] - | otherwise - = do - warn verbosity "package environment configuration is not supported for the currently configured compiler; commands that need the current project's package database are likely to fail" - return [] +createPackageEnvironment + :: Verbosity + -> FilePath + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> PostBuildProjectStatus + -> IO [(String, Maybe String)] +createPackageEnvironment + verbosity + path + elaboratedPlan + elaboratedShared + buildStatus + | compilerFlavor (pkgConfigCompiler elaboratedShared) == GHC = + do + envFileM <- + writePlanGhcEnvironment + path + elaboratedPlan + elaboratedShared + buildStatus + case envFileM of + Just envFile -> return [("GHC_ENVIRONMENT", Just envFile)] + Nothing -> do + warn verbosity "the configured version of GHC does not support reading package lists from the environment; commands that need the current project's package database are likely to fail" + return [] + | otherwise = + do + warn verbosity "package environment configuration is not supported for the currently configured compiler; commands that need the current project's package database are likely to fail" + return [] -- Writing .ghc.environment files -- -writePlanGhcEnvironment :: FilePath - -> ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> PostBuildProjectStatus - -> IO (Maybe FilePath) -writePlanGhcEnvironment path - elaboratedInstallPlan - ElaboratedSharedConfig { - pkgConfigCompiler = compiler, - pkgConfigPlatform = platform - } - postBuildStatus - | compilerFlavor compiler == GHC - , supportsPkgEnvFiles (getImplInfo compiler) - --TODO: check ghcjs compat - = fmap Just $ writeGhcEnvironmentFile - path - platform (compilerVersion compiler) - (renderGhcEnvironmentFile path - elaboratedInstallPlan - postBuildStatus) - --TODO: [required eventually] support for writing user-wide package - -- environments, e.g. like a global project, but we would not put the - -- env file in the home dir, rather it lives under ~/.ghc/ +writePlanGhcEnvironment + :: FilePath + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> PostBuildProjectStatus + -> IO (Maybe FilePath) +writePlanGhcEnvironment + path + elaboratedInstallPlan + ElaboratedSharedConfig + { pkgConfigCompiler = compiler + , pkgConfigPlatform = platform + } + postBuildStatus + | compilerFlavor compiler == GHC + , supportsPkgEnvFiles (getImplInfo compiler) = + -- TODO: check ghcjs compat + fmap Just $ + writeGhcEnvironmentFile + path + platform + (compilerVersion compiler) + ( renderGhcEnvironmentFile + path + elaboratedInstallPlan + postBuildStatus + ) +-- TODO: [required eventually] support for writing user-wide package +-- environments, e.g. like a global project, but we would not put the +-- env file in the home dir, rather it lives under ~/.ghc/ writePlanGhcEnvironment _ _ _ _ = return Nothing -renderGhcEnvironmentFile :: FilePath - -> ElaboratedInstallPlan - -> PostBuildProjectStatus - -> [GhcEnvironmentFileEntry] -renderGhcEnvironmentFile projectRootDir elaboratedInstallPlan - postBuildStatus = +renderGhcEnvironmentFile + :: FilePath + -> ElaboratedInstallPlan + -> PostBuildProjectStatus + -> [GhcEnvironmentFileEntry] +renderGhcEnvironmentFile + projectRootDir + elaboratedInstallPlan + postBuildStatus = headerComment - : simpleGhcEnvironmentFile packageDBs unitIds - where - headerComment = - GhcEnvFileComment - $ "This is a GHC environment file written by cabal. This means you can\n" - ++ "run ghc or ghci and get the environment of the project as a whole.\n" - ++ "But you still need to use cabal repl $target to get the environment\n" - ++ "of specific components (libs, exes, tests etc) because each one can\n" - ++ "have its own source dirs, cpp flags etc.\n\n" - unitIds = selectGhcEnvironmentFileLibraries postBuildStatus - packageDBs = relativePackageDBPaths projectRootDir $ - selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan - + : simpleGhcEnvironmentFile packageDBs unitIds + where + headerComment = + GhcEnvFileComment $ + "This is a GHC environment file written by cabal. This means you can\n" + ++ "run ghc or ghci and get the environment of the project as a whole.\n" + ++ "But you still need to use cabal repl $target to get the environment\n" + ++ "of specific components (libs, exes, tests etc) because each one can\n" + ++ "have its own source dirs, cpp flags etc.\n\n" + unitIds = selectGhcEnvironmentFileLibraries postBuildStatus + packageDBs = + relativePackageDBPaths projectRootDir $ + selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan argsEquivalentOfGhcEnvironmentFile :: Compiler @@ -839,10 +893,10 @@ argsEquivalentOfGhcEnvironmentFile -> PostBuildProjectStatus -> [String] argsEquivalentOfGhcEnvironmentFile compiler = - case compilerId compiler - of CompilerId GHC _ -> argsEquivalentOfGhcEnvironmentFileGhc - CompilerId GHCJS _ -> argsEquivalentOfGhcEnvironmentFileGhc - CompilerId _ _ -> error "Only GHC and GHCJS are supported" + case compilerId compiler of + CompilerId GHC _ -> argsEquivalentOfGhcEnvironmentFileGhc + CompilerId GHCJS _ -> argsEquivalentOfGhcEnvironmentFileGhc + CompilerId _ _ -> error "Only GHC and GHCJS are supported" -- TODO remove this when we drop support for non-.ghc.env ghc argsEquivalentOfGhcEnvironmentFileGhc @@ -855,17 +909,17 @@ argsEquivalentOfGhcEnvironmentFileGhc elaboratedInstallPlan postBuildStatus = clearPackageDbStackFlag - ++ packageDbArgsDb packageDBs - ++ foldMap packageIdFlag packageIds - where - projectRootDir = distProjectRootDirectory distDirLayout - packageIds = selectGhcEnvironmentFileLibraries postBuildStatus - packageDBs = relativePackageDBPaths projectRootDir $ - selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan - -- TODO use proper flags? but packageDbArgsDb is private - clearPackageDbStackFlag = ["-clear-package-db", "-global-package-db"] - packageIdFlag uid = ["-package-id", prettyShow uid] - + ++ packageDbArgsDb packageDBs + ++ foldMap packageIdFlag packageIds + where + projectRootDir = distProjectRootDirectory distDirLayout + packageIds = selectGhcEnvironmentFileLibraries postBuildStatus + packageDBs = + relativePackageDBPaths projectRootDir $ + selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan + -- TODO use proper flags? but packageDbArgsDb is private + clearPackageDbStackFlag = ["-clear-package-db", "-global-package-db"] + packageIdFlag uid = ["-package-id", prettyShow uid] -- We're producing an environment for users to use in ghci, so of course -- that means libraries only (can't put exes into the ghc package env!). @@ -901,62 +955,63 @@ argsEquivalentOfGhcEnvironmentFileGhc -- selectGhcEnvironmentFileLibraries :: PostBuildProjectStatus -> [UnitId] selectGhcEnvironmentFileLibraries PostBuildProjectStatus{..} = - case Graph.closure packagesLibDepGraph (Set.toList packagesBuildLocal) of - Nothing -> error "renderGhcEnvironmentFile: broken dep closure" - Just nodes -> [ pkgid | Graph.N pkg pkgid _ <- nodes - , hasUpToDateLib pkg ] + case Graph.closure packagesLibDepGraph (Set.toList packagesBuildLocal) of + Nothing -> error "renderGhcEnvironmentFile: broken dep closure" + Just nodes -> + [ pkgid | Graph.N pkg pkgid _ <- nodes, hasUpToDateLib pkg + ] where hasUpToDateLib planpkg = case planpkg of -- A pre-existing global lib - InstallPlan.PreExisting _ -> True - + InstallPlan.PreExisting _ -> True -- A package in the store. Check it's a lib. - InstallPlan.Installed pkg -> elabRequiresRegistration pkg - + InstallPlan.Installed pkg -> elabRequiresRegistration pkg -- A package we were installing this time, either destined for the store -- or just locally. Check it's a lib and that it is probably up to date. InstallPlan.Configured pkg -> - elabRequiresRegistration pkg - && installedUnitId pkg `Set.member` packagesProbablyUpToDate - + elabRequiresRegistration pkg + && installedUnitId pkg `Set.member` packagesProbablyUpToDate selectGhcEnvironmentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStack 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 - -- it's certainly possible to have no local inplace packages - -- e.g. just "extra" packages coming from the store. - case (inplacePackages, sourcePackages) of - ([], pkgs) -> checkSamePackageDBs pkgs - (pkgs, _) -> checkSamePackageDBs pkgs + -- 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 + -- it's certainly possible to have no local inplace packages + -- e.g. just "extra" packages coming from the store. + case (inplacePackages, sourcePackages) of + ([], pkgs) -> checkSamePackageDBs pkgs + (pkgs, _) -> checkSamePackageDBs pkgs where checkSamePackageDBs :: [ElaboratedConfiguredPackage] -> PackageDBStack checkSamePackageDBs pkgs = case ordNub (map elabBuildPackageDBStack pkgs) of [packageDbs] -> packageDbs - [] -> [] - _ -> error $ "renderGhcEnvironmentFile: packages with " - ++ "different package db stacks" - -- This should not happen at the moment but will happen as soon - -- as we support projects where we build packages with different - -- compilers, at which point we have to consider how to adapt - -- this feature, e.g. write out multiple env files, one for each - -- compiler / project profile. + [] -> [] + _ -> + error $ + "renderGhcEnvironmentFile: packages with " + ++ "different package db stacks" + -- This should not happen at the moment but will happen as soon + -- as we support projects where we build packages with different + -- compilers, at which point we have to consider how to adapt + -- this feature, e.g. write out multiple env files, one for each + -- compiler / project profile. inplacePackages :: [ElaboratedConfiguredPackage] inplacePackages = [ srcpkg | srcpkg <- sourcePackages - , elabBuildStyle srcpkg == BuildInplaceOnly ] + , elabBuildStyle srcpkg == BuildInplaceOnly + ] sourcePackages :: [ElaboratedConfiguredPackage] sourcePackages = [ srcpkg | pkg <- InstallPlan.toList elaboratedInstallPlan , srcpkg <- maybeToList $ case pkg of - InstallPlan.Configured srcpkg -> Just srcpkg - InstallPlan.Installed srcpkg -> Just srcpkg - InstallPlan.PreExisting _ -> Nothing + InstallPlan.Configured srcpkg -> Just srcpkg + InstallPlan.Installed srcpkg -> Just srcpkg + InstallPlan.PreExisting _ -> Nothing ] relativePackageDBPaths :: FilePath -> PackageDBStack -> PackageDBStack @@ -964,8 +1019,9 @@ relativePackageDBPaths relroot = map (relativePackageDBPath relroot) relativePackageDBPath :: FilePath -> PackageDB -> PackageDB relativePackageDBPath relroot pkgdb = - case pkgdb of - GlobalPackageDB -> GlobalPackageDB - UserPackageDB -> UserPackageDB - SpecificPackageDB path -> SpecificPackageDB relpath - where relpath = makeRelative relroot path + case pkgdb of + GlobalPackageDB -> GlobalPackageDB + UserPackageDB -> UserPackageDB + SpecificPackageDB path -> SpecificPackageDB relpath + where + relpath = makeRelative relroot path diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 06669fb5643..e7c383f1322 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1,185 +1,204 @@ -{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, RankNTypes #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NoMonoLocalBinds #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoMonoLocalBinds #-} -- | Planning how to build everything in a project. --- -module Distribution.Client.ProjectPlanning ( - -- * elaborated install plan types - ElaboratedInstallPlan, - ElaboratedConfiguredPackage(..), - ElaboratedPlanPackage, - ElaboratedSharedConfig(..), - ElaboratedReadyPackage, - BuildStyle(..), - CabalFileText, +module Distribution.Client.ProjectPlanning + ( -- * elaborated install plan types + ElaboratedInstallPlan + , ElaboratedConfiguredPackage (..) + , ElaboratedPlanPackage + , ElaboratedSharedConfig (..) + , ElaboratedReadyPackage + , BuildStyle (..) + , CabalFileText -- * Producing the elaborated install plan - rebuildProjectConfig, - rebuildInstallPlan, + , rebuildProjectConfig + , rebuildInstallPlan -- * Build targets - availableTargets, - AvailableTarget(..), - AvailableTargetStatus(..), - TargetRequested(..), - ComponentTarget(..), - SubComponentTarget(..), - showComponentTarget, - nubComponentTargets, + , availableTargets + , AvailableTarget (..) + , AvailableTargetStatus (..) + , TargetRequested (..) + , ComponentTarget (..) + , SubComponentTarget (..) + , showComponentTarget + , nubComponentTargets -- * Selecting a plan subset - pruneInstallPlanToTargets, - TargetAction(..), - pruneInstallPlanToDependencies, - CannotPruneDependencies(..), + , pruneInstallPlanToTargets + , TargetAction (..) + , pruneInstallPlanToDependencies + , CannotPruneDependencies (..) -- * Utils required for building - pkgHasEphemeralBuildTargets, - elabBuildTargetWholeComponents, - configureCompiler, + , pkgHasEphemeralBuildTargets + , elabBuildTargetWholeComponents + , configureCompiler -- * Setup.hs CLI flags for building - setupHsScriptOptions, - setupHsConfigureFlags, - setupHsConfigureArgs, - setupHsBuildFlags, - setupHsBuildArgs, - setupHsReplFlags, - setupHsReplArgs, - setupHsTestFlags, - setupHsTestArgs, - setupHsBenchFlags, - setupHsBenchArgs, - setupHsCopyFlags, - setupHsRegisterFlags, - setupHsHaddockFlags, - setupHsHaddockArgs, - - packageHashInputs, + , setupHsScriptOptions + , setupHsConfigureFlags + , setupHsConfigureArgs + , setupHsBuildFlags + , setupHsBuildArgs + , setupHsReplFlags + , setupHsReplArgs + , setupHsTestFlags + , setupHsTestArgs + , setupHsBenchFlags + , setupHsBenchArgs + , setupHsCopyFlags + , setupHsRegisterFlags + , setupHsHaddockFlags + , setupHsHaddockArgs + , packageHashInputs -- * Path construction - binDirectoryFor, - binDirectories, - storePackageInstallDirs, - storePackageInstallDirs' + , binDirectoryFor + , binDirectories + , storePackageInstallDirs + , storePackageInstallDirs' ) where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () -import Distribution.Client.HashValue -import Distribution.Client.HttpUtils -import Distribution.Client.ProjectPlanning.Types as Ty -import Distribution.Client.PackageHash -import Distribution.Client.RebuildMonad -import Distribution.Client.Store -import Distribution.Client.ProjectConfig -import Distribution.Client.ProjectConfig.Legacy -import Distribution.Client.ProjectPlanOutput - -import Distribution.Client.Types +import Distribution.Client.HashValue +import Distribution.Client.HttpUtils +import Distribution.Client.PackageHash +import Distribution.Client.ProjectConfig +import Distribution.Client.ProjectConfig.Legacy +import Distribution.Client.ProjectPlanOutput +import Distribution.Client.ProjectPlanning.Types as Ty +import Distribution.Client.RebuildMonad +import Distribution.Client.Store + +import Distribution.Client.Config +import Distribution.Client.Dependency +import Distribution.Client.Dependency.Types +import Distribution.Client.DistDirLayout +import Distribution.Client.FetchUtils +import qualified Distribution.Client.IndexUtils as IndexUtils import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.JobControl +import Distribution.Client.Setup hiding (cabalVersion, packageName) +import Distribution.Client.SetupWrapper import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan -import Distribution.Client.Dependency -import Distribution.Client.Dependency.Types -import qualified Distribution.Client.IndexUtils as IndexUtils -import Distribution.Client.Utils (incVersion) -import Distribution.Client.Targets (userToPackageConstraint) -import Distribution.Client.DistDirLayout -import Distribution.Client.SetupWrapper -import Distribution.Client.JobControl -import Distribution.Client.FetchUtils -import Distribution.Client.Config +import Distribution.Client.Targets (userToPackageConstraint) +import Distribution.Client.Types +import Distribution.Client.Utils (incVersion) +import Distribution.Utils.LogProgress +import Distribution.Utils.MapAccum +import Distribution.Utils.NubList import qualified Hackage.Security.Client as Sec -import Distribution.Client.Setup hiding (packageName, cabalVersion) -import Distribution.Utils.NubList -import Distribution.Utils.LogProgress -import Distribution.Utils.MapAccum import qualified Distribution.Client.BuildReports.Storage as BuildReports - ( storeLocal, fromPlanningFailure ) + ( fromPlanningFailure + , storeLocal + ) +import Distribution.Solver.Types.ComponentDeps (ComponentDeps) import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.ComponentDeps (ComponentDeps) -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PkgConfigDb -import Distribution.Solver.Types.ResolverPackage -import Distribution.Solver.Types.SolverId -import Distribution.Solver.Types.SolverPackage -import Distribution.Solver.Types.InstSolverPackage -import Distribution.Solver.Types.SourcePackage -import Distribution.Solver.Types.Settings - -import Distribution.CabalSpecVersion -import Distribution.ModuleName -import Distribution.Package -import Distribution.Types.AnnotatedId -import Distribution.Types.ComponentName -import Distribution.Types.DumpBuildInfo - ( DumpBuildInfo (..) ) -import Distribution.Types.LibraryName -import Distribution.Types.GivenComponent - (GivenComponent(..)) -import Distribution.Types.PackageVersionConstraint -import Distribution.Types.PkgconfigDependency -import Distribution.Types.UnqualComponentName -import Distribution.System +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.InstSolverPackage +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PkgConfigDb +import Distribution.Solver.Types.ResolverPackage +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.SourcePackage + +import Distribution.CabalSpecVersion + +-- TODO: [code cleanup] eliminate +-- TODO: [code cleanup] eliminate + +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.ModuleName +import Distribution.Package import qualified Distribution.PackageDescription as Cabal import qualified Distribution.PackageDescription as PD import qualified Distribution.PackageDescription.Configuration as PD -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import Distribution.Simple.Compiler -import qualified Distribution.Simple.GHC as GHC --TODO: [code cleanup] eliminate -import qualified Distribution.Simple.GHCJS as GHCJS --TODO: [code cleanup] eliminate -import Distribution.Simple.Program -import Distribution.Simple.Program.Db -import Distribution.Simple.Program.Find -import qualified Distribution.Simple.Setup as Cabal -import Distribution.Simple.Setup - (Flag(..), toFlag, flagToMaybe, flagToList, fromFlagOrDefault) +import Distribution.Simple.Compiler import qualified Distribution.Simple.Configure as Cabal -import qualified Distribution.Simple.LocalBuildInfo as Cabal -import Distribution.Simple.LocalBuildInfo - ( Component(..), pkgComponents, componentBuildInfo - , componentName ) +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHCJS as GHCJS import qualified Distribution.Simple.InstallDirs as InstallDirs -import qualified Distribution.InstalledPackageInfo as IPI - -import Distribution.Backpack.ConfiguredComponent -import Distribution.Backpack.LinkedComponent -import Distribution.Backpack.ComponentsGraph -import Distribution.Backpack.ModuleShape -import Distribution.Backpack.FullUnitId -import Distribution.Backpack -import Distribution.Types.ComponentInclude - -import Distribution.Simple.Utils -import Distribution.Version - +import Distribution.Simple.LocalBuildInfo + ( Component (..) + , componentBuildInfo + , componentName + , pkgComponents + ) +import qualified Distribution.Simple.LocalBuildInfo as Cabal +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import Distribution.Simple.Program +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Find +import Distribution.Simple.Setup + ( Flag (..) + , flagToList + , flagToMaybe + , fromFlagOrDefault + , toFlag + ) +import qualified Distribution.Simple.Setup as Cabal +import Distribution.System +import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentName +import Distribution.Types.DumpBuildInfo + ( DumpBuildInfo (..) + ) +import Distribution.Types.GivenComponent + ( GivenComponent (..) + ) +import Distribution.Types.LibraryName +import Distribution.Types.PackageVersionConstraint +import Distribution.Types.PkgconfigDependency +import Distribution.Types.UnqualComponentName + +import Distribution.Backpack +import Distribution.Backpack.ComponentsGraph +import Distribution.Backpack.ConfiguredComponent +import Distribution.Backpack.FullUnitId +import Distribution.Backpack.LinkedComponent +import Distribution.Backpack.ModuleShape +import Distribution.Types.ComponentInclude + +import Distribution.Simple.Utils +import Distribution.Version + +import Distribution.Compat.Graph (IsNode (..)) import qualified Distribution.Compat.Graph as Graph -import Distribution.Compat.Graph(IsNode(..)) -import Data.Foldable (fold) -import Text.PrettyPrint (text, hang, quotes, colon, vcat, ($$), fsep, punctuate, comma) -import qualified Text.PrettyPrint as Disp +import Control.Exception (assert) +import Control.Monad (forM, sequence) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.State as State (State, execState, runState, state) +import Data.Foldable (fold) +import Data.List (deleteBy, groupBy) +import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Set as Set -import Control.Monad (sequence, forM) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.State as State (State, execState, runState, state) -import Control.Exception (assert) -import Data.List (groupBy, deleteBy) -import qualified Data.List.NonEmpty as NE -import System.FilePath +import System.FilePath +import Text.PrettyPrint (colon, comma, fsep, hang, punctuate, quotes, text, vcat, ($$)) +import qualified Text.PrettyPrint as Disp ------------------------------------------------------------------------------ + -- * Elaborated install plan + ------------------------------------------------------------------------------ -- "Elaborated" -- worked out with great care and nicety of detail; @@ -203,11 +222,15 @@ import System.FilePath -- So that means we need a representation of this fully elaborated install -- plan. The representation consists of two parts: -- + -- * A 'ElaboratedInstallPlan'. This is a 'GenericInstallPlan' with a + -- representation of source packages that includes a lot more detail about -- that package's individual configuration -- + -- * A 'ElaboratedSharedConfig'. Some package configuration is the same for + -- every package in a plan. Rather than duplicate that info every entry in -- the 'GenericInstallPlan' we keep that separately. -- @@ -227,104 +250,115 @@ import System.FilePath -- data ElaboratedConfiguredPackage = ... -- data BuildStyle = - -- | Check that an 'ElaboratedConfiguredPackage' actually makes -- sense under some 'ElaboratedSharedConfig'. sanityCheckElaboratedConfiguredPackage - :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> a - -> a -sanityCheckElaboratedConfiguredPackage _sharedConfig - elab@ElaboratedConfiguredPackage{..} = - (case elabPkgOrComp of + :: ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> a + -> a +sanityCheckElaboratedConfiguredPackage + _sharedConfig + elab@ElaboratedConfiguredPackage{..} = + ( case elabPkgOrComp of ElabPackage pkg -> sanityCheckElaboratedPackage elab pkg - ElabComponent comp -> sanityCheckElaboratedComponent elab comp) - - -- The assertion below fails occasionally for unknown reason - -- so it was muted until we figure it out, otherwise it severely - -- hinders our ability to share and test development builds of cabal-install. - -- Tracking issue: https://github.com/haskell/cabal/issues/6006 - -- - -- either a package is being built inplace, or the - -- 'installedPackageId' we assigned is consistent with - -- the 'hashedInstalledPackageId' we would compute from - -- the elaborated configured package - -- . assert (elabBuildStyle == BuildInplaceOnly || - -- elabComponentId == hashedInstalledPackageId - -- (packageHashInputs sharedConfig elab)) - - -- the stanzas explicitly disabled should not be available - . assert (optStanzaSetNull $ - optStanzaKeysFilteredByValue (maybe False not) elabStanzasRequested `optStanzaSetIntersection` elabStanzasAvailable) - - -- either a package is built inplace, or we are not attempting to - -- build any test suites or benchmarks (we never build these - -- for remote packages!) - . assert (elabBuildStyle == BuildInplaceOnly || - optStanzaSetNull elabStanzasAvailable) + ElabComponent comp -> sanityCheckElaboratedComponent elab comp + ) + -- The assertion below fails occasionally for unknown reason + -- so it was muted until we figure it out, otherwise it severely + -- hinders our ability to share and test development builds of cabal-install. + -- Tracking issue: https://github.com/haskell/cabal/issues/6006 + -- + -- either a package is being built inplace, or the + -- 'installedPackageId' we assigned is consistent with + -- the 'hashedInstalledPackageId' we would compute from + -- the elaborated configured package + -- . assert (elabBuildStyle == BuildInplaceOnly || + -- elabComponentId == hashedInstalledPackageId + -- (packageHashInputs sharedConfig elab)) + + -- the stanzas explicitly disabled should not be available + . assert + ( optStanzaSetNull $ + optStanzaKeysFilteredByValue (maybe False not) elabStanzasRequested `optStanzaSetIntersection` elabStanzasAvailable + ) + -- either a package is built inplace, or we are not attempting to + -- build any test suites or benchmarks (we never build these + -- for remote packages!) + . assert + ( elabBuildStyle == BuildInplaceOnly + || optStanzaSetNull elabStanzasAvailable + ) sanityCheckElaboratedComponent - :: ElaboratedConfiguredPackage - -> ElaboratedComponent - -> a - -> a -sanityCheckElaboratedComponent ElaboratedConfiguredPackage{..} - ElaboratedComponent{..} = - + :: ElaboratedConfiguredPackage + -> ElaboratedComponent + -> a + -> a +sanityCheckElaboratedComponent + ElaboratedConfiguredPackage{..} + ElaboratedComponent{..} = -- Should not be building bench or test if not inplace. - assert (elabBuildStyle == BuildInplaceOnly || - case compComponentName of - Nothing -> True - Just (CLibName _) -> True - Just (CExeName _) -> True - -- This is interesting: there's no way to declare a dependency - -- on a foreign library at the moment, but you may still want - -- to install these to the store - Just (CFLibName _) -> True - Just (CBenchName _) -> False - Just (CTestName _) -> False) - + assert + ( elabBuildStyle == BuildInplaceOnly + || case compComponentName of + Nothing -> True + Just (CLibName _) -> True + Just (CExeName _) -> True + -- This is interesting: there's no way to declare a dependency + -- on a foreign library at the moment, but you may still want + -- to install these to the store + Just (CFLibName _) -> True + Just (CBenchName _) -> False + Just (CTestName _) -> False + ) sanityCheckElaboratedPackage - :: ElaboratedConfiguredPackage - -> ElaboratedPackage - -> a - -> a -sanityCheckElaboratedPackage ElaboratedConfiguredPackage{..} - ElaboratedPackage{..} = + :: ElaboratedConfiguredPackage + -> ElaboratedPackage + -> a + -> a +sanityCheckElaboratedPackage + ElaboratedConfiguredPackage{..} + ElaboratedPackage{..} = -- we should only have enabled stanzas that actually can be built -- (according to the solver) assert (pkgStanzasEnabled `optStanzaSetIsSubset` elabStanzasAvailable) - - -- the stanzas that the user explicitly requested should be - -- enabled (by the previous test, they are also available) - . assert (optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested - `optStanzaSetIsSubset` pkgStanzasEnabled) + -- the stanzas that the user explicitly requested should be + -- enabled (by the previous test, they are also available) + . assert + ( optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested + `optStanzaSetIsSubset` pkgStanzasEnabled + ) ------------------------------------------------------------------------------ + -- * Deciding what to do: making an 'ElaboratedInstallPlan' + ------------------------------------------------------------------------------ -- | Return the up-to-date project config and information about the local -- packages within the project. --- -rebuildProjectConfig :: Verbosity - -> HttpTransport - -> DistDirLayout - -> ProjectConfig - -> IO ( ProjectConfig - , [PackageSpecifier UnresolvedSourcePackage] ) -rebuildProjectConfig verbosity - httpTransport - distDirLayout@DistDirLayout { - distProjectRootDirectory, - distDirectory, - distProjectCacheFile, - distProjectCacheDirectory, - distProjectFile - } - cliConfig = do +rebuildProjectConfig + :: Verbosity + -> HttpTransport + -> DistDirLayout + -> ProjectConfig + -> IO + ( ProjectConfig + , [PackageSpecifier UnresolvedSourcePackage] + ) +rebuildProjectConfig + verbosity + httpTransport + distDirLayout@DistDirLayout + { distProjectRootDirectory + , distDirectory + , distProjectCacheFile + , distProjectCacheDirectory + , distProjectFile + } + cliConfig = do progsearchpath <- liftIO $ getSystemSearchPath @@ -340,101 +374,114 @@ rebuildProjectConfig verbosity (projectConfig, localPackages) <- runRebuild distProjectRootDirectory - $ rerunIfChanged verbosity - fileMonitorProjectConfig - fileMonitorProjectConfigKey -- todo check deps too? - $ do + $ rerunIfChanged + verbosity + fileMonitorProjectConfig + fileMonitorProjectConfigKey -- todo check deps too? + $ do liftIO $ info verbosity "Project settings changed, reconfiguring..." projectConfigSkeleton <- phaseReadProjectConfig let fetchCompiler = do - -- have to create the cache directory before configuring the compiler - liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory - (compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout ((fst $ PD.ignoreConditions projectConfigSkeleton) <> cliConfig) - pure (os, arch, compilerInfo compiler) + -- have to create the cache directory before configuring the compiler + liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory + (compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout ((fst $ PD.ignoreConditions projectConfigSkeleton) <> cliConfig) + pure (os, arch, compilerInfo compiler) projectConfig <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectConfigSkeleton localPackages <- phaseReadLocalPackages (projectConfig <> cliConfig) return (projectConfig, localPackages) - info verbosity - $ unlines - $ ("this build was affected by the following (project) config files:" :) - $ [ "- " ++ path - | Explicit path <- Set.toList $ projectConfigProvenance projectConfig - ] + info verbosity $ + unlines $ + ("this build was affected by the following (project) config files:" :) $ + [ "- " ++ path + | Explicit path <- Set.toList $ projectConfigProvenance projectConfig + ] return (projectConfig <> cliConfig, localPackages) + where + ProjectConfigShared { projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg, projectConfigIgnoreProject, projectConfigConfigFile } = + projectConfigShared cliConfig + PackageConfig { packageConfigProgramPaths, packageConfigProgramPathExtra } = + projectConfigLocalPackages cliConfig + -- Read the cabal.project (or implicit config) and combine it with + -- arguments from the command line + -- + phaseReadProjectConfig :: Rebuild ProjectConfigSkeleton + phaseReadProjectConfig = do + readProjectConfig verbosity httpTransport projectConfigIgnoreProject projectConfigConfigFile distDirLayout - where - - ProjectConfigShared { projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg, projectConfigIgnoreProject, projectConfigConfigFile } = - projectConfigShared cliConfig - - PackageConfig { packageConfigProgramPaths, packageConfigProgramPathExtra } = - projectConfigLocalPackages cliConfig - - -- Read the cabal.project (or implicit config) and combine it with - -- arguments from the command line - -- - phaseReadProjectConfig :: Rebuild ProjectConfigSkeleton - phaseReadProjectConfig = do - readProjectConfig verbosity httpTransport projectConfigIgnoreProject projectConfigConfigFile distDirLayout - - -- Look for all the cabal packages in the project - -- some of which may be local src dirs, tarballs etc - -- - phaseReadLocalPackages :: ProjectConfig - -> Rebuild [PackageSpecifier UnresolvedSourcePackage] - phaseReadLocalPackages projectConfig@ProjectConfig { - projectConfigShared, - projectConfigBuildOnly - } = do - - pkgLocations <- findProjectPackages distDirLayout projectConfig - -- Create folder only if findProjectPackages did not throw a - -- BadPackageLocations exception. - liftIO $ do - createDirectoryIfMissingVerbose verbosity True distDirectory - createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory - - fetchAndReadSourcePackages verbosity distDirLayout - projectConfigShared - projectConfigBuildOnly - pkgLocations - - -configureCompiler :: Verbosity -> - DistDirLayout -> - ProjectConfig -> - Rebuild (Compiler, Platform, ProgramDb) -configureCompiler verbosity - DistDirLayout { - distProjectCacheFile - } - ProjectConfig { - projectConfigShared = ProjectConfigShared { - projectConfigHcFlavor, - projectConfigHcPath, - projectConfigHcPkg - }, - projectConfigLocalPackages = PackageConfig { - packageConfigProgramPaths, - packageConfigProgramPathExtra - } - } = do - let fileMonitorCompiler = newFileMonitor . distProjectCacheFile $ "compiler" - - progsearchpath <- liftIO $ getSystemSearchPath - rerunIfChanged verbosity fileMonitorCompiler - (hcFlavor, hcPath, hcPkg, progsearchpath, - packageConfigProgramPaths, - packageConfigProgramPathExtra) $ do + -- Look for all the cabal packages in the project + -- some of which may be local src dirs, tarballs etc + -- + phaseReadLocalPackages + :: ProjectConfig + -> Rebuild [PackageSpecifier UnresolvedSourcePackage] + phaseReadLocalPackages + projectConfig@ProjectConfig + { projectConfigShared + , projectConfigBuildOnly + } = do + pkgLocations <- findProjectPackages distDirLayout projectConfig + -- Create folder only if findProjectPackages did not throw a + -- BadPackageLocations exception. + liftIO $ do + createDirectoryIfMissingVerbose verbosity True distDirectory + createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory + + fetchAndReadSourcePackages + verbosity + distDirLayout + projectConfigShared + projectConfigBuildOnly + pkgLocations + +configureCompiler + :: Verbosity + -> DistDirLayout + -> ProjectConfig + -> Rebuild (Compiler, Platform, ProgramDb) +configureCompiler + verbosity + DistDirLayout + { distProjectCacheFile + } + ProjectConfig + { projectConfigShared = + ProjectConfigShared + { projectConfigHcFlavor + , projectConfigHcPath + , projectConfigHcPkg + } + , projectConfigLocalPackages = + PackageConfig + { packageConfigProgramPaths + , packageConfigProgramPathExtra + } + } = do + let fileMonitorCompiler = newFileMonitor . distProjectCacheFile $ "compiler" - liftIO $ info verbosity "Compiler settings changed, reconfiguring..." - result@(_, _, progdb') <- liftIO $ + progsearchpath <- liftIO $ getSystemSearchPath + rerunIfChanged + verbosity + fileMonitorCompiler + ( hcFlavor + , hcPath + , hcPkg + , progsearchpath + , packageConfigProgramPaths + , packageConfigProgramPathExtra + ) + $ do + liftIO $ info verbosity "Compiler settings changed, reconfiguring..." + result@(_, _, progdb') <- + liftIO $ Cabal.configCompilerEx - hcFlavor hcPath hcPkg - progdb verbosity + hcFlavor + hcPath + hcPkg + progdb + verbosity -- Note that we added the user-supplied program locations and args -- for /all/ programs, not just those for the compiler prog and @@ -442,21 +489,23 @@ configureCompiler verbosity -- the compiler will configure (and it does vary between compilers). -- We do know however that the compiler will only configure the -- programs it cares about, and those are the ones we monitor here. - monitorFiles (programsMonitorFiles progdb') + monitorFiles (programsMonitorFiles progdb') - return result - where - hcFlavor = flagToMaybe projectConfigHcFlavor - hcPath = flagToMaybe projectConfigHcPath - hcPkg = flagToMaybe projectConfigHcPkg - progdb = - userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) + return result + where + hcFlavor = flagToMaybe projectConfigHcFlavor + hcPath = flagToMaybe projectConfigHcPath + hcPkg = flagToMaybe projectConfigHcPkg + progdb = + userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) . modifyProgramSearchPath - ([ ProgramSearchPathDir dir - | dir <- fromNubList packageConfigProgramPathExtra ] ++) + ( [ ProgramSearchPathDir dir + | dir <- fromNubList packageConfigProgramPathExtra + ] + ++ + ) $ defaultProgramDb - -- | Return an up-to-date elaborated install plan. -- -- Two variants of the install plan are returned: with and without packages @@ -470,233 +519,295 @@ configureCompiler verbosity -- command needs the source package info to know about flag choices and -- dependencies of executables and setup scripts. -- -rebuildInstallPlan :: Verbosity - -> DistDirLayout -> CabalDirLayout - -> ProjectConfig - -> [PackageSpecifier UnresolvedSourcePackage] - -> Maybe InstalledPackageIndex - -> IO ( ElaboratedInstallPlan -- with store packages - , ElaboratedInstallPlan -- with source packages - , ElaboratedSharedConfig - , IndexUtils.TotalIndexState - , IndexUtils.ActiveRepos - ) - -- ^ @(improvedPlan, elaboratedPlan, _, _, _)@ -rebuildInstallPlan verbosity - distDirLayout@DistDirLayout { - distProjectRootDirectory, - distProjectCacheFile - } - CabalDirLayout { - cabalStoreDirLayout - } = \projectConfig localPackages mbInstalledPackages -> +rebuildInstallPlan + :: Verbosity + -> DistDirLayout + -> CabalDirLayout + -> ProjectConfig + -> [PackageSpecifier UnresolvedSourcePackage] + -> Maybe InstalledPackageIndex + -> IO + ( ElaboratedInstallPlan -- with store packages + , ElaboratedInstallPlan -- with source packages + , ElaboratedSharedConfig + , IndexUtils.TotalIndexState + , IndexUtils.ActiveRepos + ) + -- ^ @(improvedPlan, elaboratedPlan, _, _, _)@ +rebuildInstallPlan + verbosity + distDirLayout@DistDirLayout + { distProjectRootDirectory + , distProjectCacheFile + } + CabalDirLayout + { cabalStoreDirLayout + } = \projectConfig localPackages mbInstalledPackages -> runRebuild distProjectRootDirectory $ do - progsearchpath <- liftIO $ getSystemSearchPath - let projectConfigMonitored = projectConfig { projectConfigBuildOnly = mempty } - - -- The overall improved plan is cached - rerunIfChanged verbosity fileMonitorImprovedPlan - -- react to changes in the project config, - -- the package .cabal files and the path - (projectConfigMonitored, localPackages, progsearchpath) $ do - - -- And so is the elaborated plan that the improved plan based on - (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) <- - rerunIfChanged verbosity fileMonitorElaboratedPlan - (projectConfigMonitored, localPackages, - progsearchpath) $ do - - compilerEtc <- phaseConfigureCompiler projectConfig - _ <- phaseConfigurePrograms projectConfig compilerEtc - (solverPlan, pkgConfigDB, totalIndexState, activeRepos) - <- phaseRunSolver projectConfig - compilerEtc - localPackages - (fromMaybe mempty mbInstalledPackages) - (elaboratedPlan, - elaboratedShared) <- phaseElaboratePlan projectConfig - compilerEtc pkgConfigDB - solverPlan - localPackages - - phaseMaintainPlanOutputs elaboratedPlan elaboratedShared - return (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) - - -- The improved plan changes each time we install something, whereas - -- the underlying elaborated plan only changes when input config - -- changes, so it's worth caching them separately. - improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared - - return (improvedPlan, elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) - - where - fileMonitorSolverPlan = newFileMonitorInCacheDir "solver-plan" - fileMonitorSourceHashes = newFileMonitorInCacheDir "source-hashes" - fileMonitorElaboratedPlan = newFileMonitorInCacheDir "elaborated-plan" - fileMonitorImprovedPlan = newFileMonitorInCacheDir "improved-plan" - - newFileMonitorInCacheDir :: Eq a => FilePath -> FileMonitor a b - newFileMonitorInCacheDir = newFileMonitor . distProjectCacheFile + progsearchpath <- liftIO $ getSystemSearchPath + let projectConfigMonitored = projectConfig{projectConfigBuildOnly = mempty} + + -- The overall improved plan is cached + rerunIfChanged + verbosity + fileMonitorImprovedPlan + -- react to changes in the project config, + -- the package .cabal files and the path + (projectConfigMonitored, localPackages, progsearchpath) + $ do + -- And so is the elaborated plan that the improved plan based on + (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) <- + rerunIfChanged + verbosity + fileMonitorElaboratedPlan + ( projectConfigMonitored + , localPackages + , progsearchpath + ) + $ do + compilerEtc <- phaseConfigureCompiler projectConfig + _ <- phaseConfigurePrograms projectConfig compilerEtc + (solverPlan, pkgConfigDB, totalIndexState, activeRepos) <- + phaseRunSolver + projectConfig + compilerEtc + localPackages + (fromMaybe mempty mbInstalledPackages) + ( elaboratedPlan + , elaboratedShared + ) <- + phaseElaboratePlan + projectConfig + compilerEtc + pkgConfigDB + solverPlan + localPackages + + phaseMaintainPlanOutputs elaboratedPlan elaboratedShared + return (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) + + -- The improved plan changes each time we install something, whereas + -- the underlying elaborated plan only changes when input config + -- changes, so it's worth caching them separately. + improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared + + return (improvedPlan, elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) + where + fileMonitorSolverPlan = newFileMonitorInCacheDir "solver-plan" + fileMonitorSourceHashes = newFileMonitorInCacheDir "source-hashes" + fileMonitorElaboratedPlan = newFileMonitorInCacheDir "elaborated-plan" + fileMonitorImprovedPlan = newFileMonitorInCacheDir "improved-plan" + newFileMonitorInCacheDir :: Eq a => FilePath -> FileMonitor a b + newFileMonitorInCacheDir = newFileMonitor . distProjectCacheFile - -- Configure the compiler we're using. - -- - -- This is moderately expensive and doesn't change that often so we cache - -- it independently. - -- - phaseConfigureCompiler :: ProjectConfig - -> Rebuild (Compiler, Platform, ProgramDb) - phaseConfigureCompiler = configureCompiler verbosity distDirLayout + -- Configure the compiler we're using. + -- + -- This is moderately expensive and doesn't change that often so we cache + -- it independently. + -- + phaseConfigureCompiler + :: ProjectConfig + -> Rebuild (Compiler, Platform, ProgramDb) + phaseConfigureCompiler = configureCompiler verbosity distDirLayout - -- Configuring other programs. - -- - -- Having configred the compiler, now we configure all the remaining - -- programs. This is to check we can find them, and to monitor them for - -- changes. - -- - -- TODO: [required eventually] we don't actually do this yet. - -- - -- We rely on the fact that the previous phase added the program config for - -- all local packages, but that all the programs configured so far are the - -- compiler program or related util programs. - -- - phaseConfigurePrograms :: ProjectConfig - -> (Compiler, Platform, ProgramDb) - -> Rebuild () - phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = do + -- Configuring other programs. + -- + -- Having configred the compiler, now we configure all the remaining + -- programs. This is to check we can find them, and to monitor them for + -- changes. + -- + -- TODO: [required eventually] we don't actually do this yet. + -- + -- We rely on the fact that the previous phase added the program config for + -- all local packages, but that all the programs configured so far are the + -- compiler program or related util programs. + -- + phaseConfigurePrograms + :: ProjectConfig + -> (Compiler, Platform, ProgramDb) + -> Rebuild () + phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = do -- Users are allowed to specify program locations independently for -- each package (e.g. to use a particular version of a pre-processor -- for some packages). However they cannot do this for the compiler -- itself as that's just not going to work. So we check for this. - liftIO $ checkBadPerPackageCompilerPaths - (configuredPrograms compilerprogdb) - (getMapMappend (projectConfigSpecificPackage projectConfig)) - - --TODO: [required eventually] find/configure other programs that the - -- user specifies. + liftIO $ + checkBadPerPackageCompilerPaths + (configuredPrograms compilerprogdb) + (getMapMappend (projectConfigSpecificPackage projectConfig)) - --TODO: [required eventually] find/configure all build-tools - -- but note that some of them may be built as part of the plan. + -- TODO: [required eventually] find/configure other programs that the + -- user specifies. + -- TODO: [required eventually] find/configure all build-tools + -- but note that some of them may be built as part of the plan. - -- Run the solver to get the initial install plan. - -- This is expensive so we cache it independently. - -- - phaseRunSolver + -- Run the solver to get the initial install plan. + -- This is expensive so we cache it independently. + -- + phaseRunSolver :: ProjectConfig -> (Compiler, Platform, ProgramDb) -> [PackageSpecifier UnresolvedSourcePackage] -> InstalledPackageIndex -> Rebuild (SolverInstallPlan, PkgConfigDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos) - phaseRunSolver projectConfig@ProjectConfig { - projectConfigShared, - projectConfigBuildOnly - } - (compiler, platform, progdb) - localPackages - installedPackages = - rerunIfChanged verbosity fileMonitorSolverPlan - (solverSettings, - localPackages, localPackagesEnabledStanzas, - compiler, platform, programDbSignature progdb) $ do - - installedPkgIndex <- getInstalledPackages verbosity - compiler progdb platform - corePackageDbs - (sourcePkgDb, tis, ar) <- getSourcePackages verbosity withRepoCtx - (solverSettingIndexState solverSettings) - (solverSettingActiveRepos solverSettings) - pkgConfigDB <- getPkgConfigDb verbosity progdb - - --TODO: [code cleanup] it'd be better if the Compiler contained the - -- ConfiguredPrograms that it needs, rather than relying on the progdb - -- since we don't need to depend on all the programs here, just the - -- ones relevant for the compiler. - - liftIO $ do - solver <- chooseSolver verbosity - (solverSettingSolver solverSettings) - (compilerInfo compiler) - - notice verbosity "Resolving dependencies..." - planOrError <- foldProgress logMsg (pure . Left) (pure . Right) $ - planPackages verbosity compiler platform solver solverSettings - (installedPackages <> installedPkgIndex) sourcePkgDb pkgConfigDB - localPackages localPackagesEnabledStanzas - case planOrError of - Left msg -> do reportPlanningFailure projectConfig compiler platform localPackages - die' verbosity msg - Right plan -> return (plan, pkgConfigDB, tis, ar) - where - corePackageDbs :: [PackageDB] - corePackageDbs = applyPackageDbFlags [GlobalPackageDB] - (projectConfigPackageDBs projectConfigShared) - - withRepoCtx = projectConfigWithSolverRepoContext verbosity - projectConfigShared - projectConfigBuildOnly - solverSettings = resolveSolverSettings projectConfig - logMsg message rest = debugNoWrap verbosity message >> rest - - localPackagesEnabledStanzas = - Map.fromList - [ (pkgname, stanzas) - | pkg <- localPackages - -- TODO: misnomer: we should separate - -- builtin/global/inplace/local packages - -- and packages explicitly mentioned in the project - -- - , let pkgname = pkgSpecifierTarget pkg - testsEnabled = lookupLocalPackageConfig - packageConfigTests - projectConfig pkgname - benchmarksEnabled = lookupLocalPackageConfig - packageConfigBenchmarks - projectConfig pkgname - isLocal = isJust (shouldBeLocal pkg) - stanzas - | isLocal = Map.fromList $ - [ (TestStanzas, enabled) - | enabled <- flagToList testsEnabled ] ++ - [ (BenchStanzas , enabled) - | enabled <- flagToList benchmarksEnabled ] - | otherwise = Map.fromList [(TestStanzas, False), (BenchStanzas, False) ] - ] - - -- Elaborate the solver's install plan to get a fully detailed plan. This - -- version of the plan has the final nix-style hashed ids. - -- - phaseElaboratePlan :: ProjectConfig - -> (Compiler, Platform, ProgramDb) - -> PkgConfigDb - -> SolverInstallPlan - -> [PackageSpecifier (SourcePackage (PackageLocation loc))] - -> Rebuild ( ElaboratedInstallPlan - , ElaboratedSharedConfig ) - phaseElaboratePlan ProjectConfig { - projectConfigShared, - projectConfigAllPackages, - projectConfigLocalPackages, - projectConfigSpecificPackage, - projectConfigBuildOnly - } - (compiler, platform, progdb) pkgConfigDB - solverPlan localPackages = do - - liftIO $ debug verbosity "Elaborating the install plan..." - - sourcePackageHashes <- - rerunIfChanged verbosity fileMonitorSourceHashes - (packageLocationsSignature solverPlan) $ - getPackageSourceHashes verbosity withRepoCtx solverPlan - - defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler - let installDirs = fmap Cabal.fromFlag $ (fmap Flag defaultInstallDirs) <> (projectConfigInstallDirs projectConfigShared) - (elaboratedPlan, elaboratedShared) - <- liftIO . runLogProgress verbosity $ + phaseRunSolver + projectConfig@ProjectConfig + { projectConfigShared + , projectConfigBuildOnly + } + (compiler, platform, progdb) + localPackages + installedPackages = + rerunIfChanged + verbosity + fileMonitorSolverPlan + ( solverSettings + , localPackages + , localPackagesEnabledStanzas + , compiler + , platform + , programDbSignature progdb + ) + $ do + installedPkgIndex <- + getInstalledPackages + verbosity + compiler + progdb + platform + corePackageDbs + (sourcePkgDb, tis, ar) <- + getSourcePackages + verbosity + withRepoCtx + (solverSettingIndexState solverSettings) + (solverSettingActiveRepos solverSettings) + pkgConfigDB <- getPkgConfigDb verbosity progdb + + -- TODO: [code cleanup] it'd be better if the Compiler contained the + -- ConfiguredPrograms that it needs, rather than relying on the progdb + -- since we don't need to depend on all the programs here, just the + -- ones relevant for the compiler. + + liftIO $ do + solver <- + chooseSolver + verbosity + (solverSettingSolver solverSettings) + (compilerInfo compiler) + + notice verbosity "Resolving dependencies..." + planOrError <- + foldProgress logMsg (pure . Left) (pure . Right) $ + planPackages + verbosity + compiler + platform + solver + solverSettings + (installedPackages <> installedPkgIndex) + sourcePkgDb + pkgConfigDB + localPackages + localPackagesEnabledStanzas + case planOrError of + Left msg -> do + reportPlanningFailure projectConfig compiler platform localPackages + die' verbosity msg + Right plan -> return (plan, pkgConfigDB, tis, ar) + where + corePackageDbs :: [PackageDB] + corePackageDbs = + applyPackageDbFlags + [GlobalPackageDB] + (projectConfigPackageDBs projectConfigShared) + + withRepoCtx = + projectConfigWithSolverRepoContext + verbosity + projectConfigShared + projectConfigBuildOnly + solverSettings = resolveSolverSettings projectConfig + logMsg message rest = debugNoWrap verbosity message >> rest + + localPackagesEnabledStanzas = + Map.fromList + [ (pkgname, stanzas) + | pkg <- localPackages + , -- TODO: misnomer: we should separate + -- builtin/global/inplace/local packages + -- and packages explicitly mentioned in the project + -- + let pkgname = pkgSpecifierTarget pkg + testsEnabled = + lookupLocalPackageConfig + packageConfigTests + projectConfig + pkgname + benchmarksEnabled = + lookupLocalPackageConfig + packageConfigBenchmarks + projectConfig + pkgname + isLocal = isJust (shouldBeLocal pkg) + stanzas + | isLocal = + Map.fromList $ + [ (TestStanzas, enabled) + | enabled <- flagToList testsEnabled + ] + ++ [ (BenchStanzas, enabled) + | enabled <- flagToList benchmarksEnabled + ] + | otherwise = Map.fromList [(TestStanzas, False), (BenchStanzas, False)] + ] + + -- Elaborate the solver's install plan to get a fully detailed plan. This + -- version of the plan has the final nix-style hashed ids. + -- + phaseElaboratePlan + :: ProjectConfig + -> (Compiler, Platform, ProgramDb) + -> PkgConfigDb + -> SolverInstallPlan + -> [PackageSpecifier (SourcePackage (PackageLocation loc))] + -> Rebuild + ( ElaboratedInstallPlan + , ElaboratedSharedConfig + ) + phaseElaboratePlan + ProjectConfig + { projectConfigShared + , projectConfigAllPackages + , projectConfigLocalPackages + , projectConfigSpecificPackage + , projectConfigBuildOnly + } + (compiler, platform, progdb) + pkgConfigDB + solverPlan + localPackages = do + liftIO $ debug verbosity "Elaborating the install plan..." + + sourcePackageHashes <- + rerunIfChanged + verbosity + fileMonitorSourceHashes + (packageLocationsSignature solverPlan) + $ getPackageSourceHashes verbosity withRepoCtx solverPlan + + defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler + let installDirs = fmap Cabal.fromFlag $ (fmap Flag defaultInstallDirs) <> (projectConfigInstallDirs projectConfigShared) + (elaboratedPlan, elaboratedShared) <- + liftIO . runLogProgress verbosity $ elaborateInstallPlan verbosity - platform compiler progdb pkgConfigDB + platform + compiler + progdb + pkgConfigDB distDirLayout cabalStoreDirLayout solverPlan @@ -707,132 +818,154 @@ rebuildInstallPlan verbosity projectConfigAllPackages projectConfigLocalPackages (getMapMappend projectConfigSpecificPackage) - let instantiatedPlan - = instantiateInstallPlan + let instantiatedPlan = + instantiateInstallPlan cabalStoreDirLayout installDirs elaboratedShared elaboratedPlan - liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan) - return (instantiatedPlan, elaboratedShared) - where - withRepoCtx = projectConfigWithSolverRepoContext verbosity - projectConfigShared - projectConfigBuildOnly - - -- Update the files we maintain that reflect our current build environment. - -- In particular we maintain a JSON representation of the elaborated - -- install plan (but not the improved plan since that reflects the state - -- of the build rather than just the input environment). - -- - phaseMaintainPlanOutputs :: ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> Rebuild () - phaseMaintainPlanOutputs elaboratedPlan elaboratedShared = liftIO $ do + liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan) + return (instantiatedPlan, elaboratedShared) + where + withRepoCtx = + projectConfigWithSolverRepoContext + verbosity + projectConfigShared + projectConfigBuildOnly + + -- Update the files we maintain that reflect our current build environment. + -- In particular we maintain a JSON representation of the elaborated + -- install plan (but not the improved plan since that reflects the state + -- of the build rather than just the input environment). + -- + phaseMaintainPlanOutputs + :: ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> Rebuild () + phaseMaintainPlanOutputs elaboratedPlan elaboratedShared = liftIO $ do debug verbosity "Updating plan.json" writePlanExternalRepresentation distDirLayout elaboratedPlan elaboratedShared - - -- Improve the elaborated install plan. The elaborated plan consists - -- mostly of source packages (with full nix-style hashed ids). Where - -- corresponding installed packages already exist in the store, replace - -- them in the plan. - -- - -- Note that we do monitor the store's package db here, so we will redo - -- this improvement phase when the db changes -- including as a result of - -- executing a plan and installing things. - -- - phaseImprovePlan :: ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> Rebuild ElaboratedInstallPlan - phaseImprovePlan elaboratedPlan elaboratedShared = do - + -- Improve the elaborated install plan. The elaborated plan consists + -- mostly of source packages (with full nix-style hashed ids). Where + -- corresponding installed packages already exist in the store, replace + -- them in the plan. + -- + -- Note that we do monitor the store's package db here, so we will redo + -- this improvement phase when the db changes -- including as a result of + -- executing a plan and installing things. + -- + phaseImprovePlan + :: ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> Rebuild ElaboratedInstallPlan + phaseImprovePlan elaboratedPlan elaboratedShared = do liftIO $ debug verbosity "Improving the install plan..." storePkgIdSet <- getStoreEntries cabalStoreDirLayout compid - let improvedPlan = improveInstallPlanWithInstalledPackages - storePkgIdSet - elaboratedPlan + let improvedPlan = + improveInstallPlanWithInstalledPackages + storePkgIdSet + elaboratedPlan liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan improvedPlan) -- TODO: [nice to have] having checked which packages from the store -- we're using, it may be sensible to sanity check those packages -- by loading up the compiler package db and checking everything -- matches up as expected, e.g. no dangling deps, files deleted. return improvedPlan - where - compid = compilerId (pkgConfigCompiler elaboratedShared) - + where + compid = compilerId (pkgConfigCompiler elaboratedShared) -- | If a 'PackageSpecifier' refers to a single package, return Just that -- package. - - reportPlanningFailure :: ProjectConfig -> Compiler -> Platform -> [PackageSpecifier UnresolvedSourcePackage] -> IO () -reportPlanningFailure projectConfig comp platform pkgSpecifiers = when reportFailure $ - - BuildReports.storeLocal (compilerInfo comp) - (fromNubList $ projectConfigSummaryFile . projectConfigBuildOnly $ projectConfig) - buildReports platform - - -- TODO may want to handle the projectConfigLogFile paramenter here, or just remove it entirely? +reportPlanningFailure projectConfig comp platform pkgSpecifiers = + when reportFailure $ + BuildReports.storeLocal + (compilerInfo comp) + (fromNubList $ projectConfigSummaryFile . projectConfigBuildOnly $ projectConfig) + buildReports + platform where + -- TODO may want to handle the projectConfigLogFile paramenter here, or just remove it entirely? + reportFailure = Cabal.fromFlag . projectConfigReportPlanningFailure . projectConfigBuildOnly $ projectConfig pkgids = mapMaybe theSpecifiedPackage pkgSpecifiers - buildReports = BuildReports.fromPlanningFailure platform - (compilerId comp) pkgids - -- TODO we may want to get more flag assignments and merge them here? - (packageConfigFlagAssignment . projectConfigAllPackages $ projectConfig) + buildReports = + BuildReports.fromPlanningFailure + platform + (compilerId comp) + pkgids + -- TODO we may want to get more flag assignments and merge them here? + (packageConfigFlagAssignment . projectConfigAllPackages $ projectConfig) theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId theSpecifiedPackage pkgSpec = - case pkgSpec of - NamedPackage name [PackagePropertyVersion version] - -> PackageIdentifier name <$> trivialRange version - NamedPackage _ _ -> Nothing - SpecificSourcePackage pkg -> Just $ packageId pkg - -- | If a range includes only a single version, return Just that version. + case pkgSpec of + NamedPackage name [PackagePropertyVersion version] -> + PackageIdentifier name <$> trivialRange version + NamedPackage _ _ -> Nothing + SpecificSourcePackage pkg -> Just $ packageId pkg + -- \| If a range includes only a single version, return Just that version. trivialRange :: VersionRange -> Maybe Version - trivialRange = foldVersionRange + trivialRange = + foldVersionRange Nothing - Just -- "== v" + Just -- "== v" (\_ -> Nothing) (\_ -> Nothing) (\_ _ -> Nothing) (\_ _ -> Nothing) - programsMonitorFiles :: ProgramDb -> [MonitorFilePath] programsMonitorFiles progdb = - [ monitor - | prog <- configuredPrograms progdb - , monitor <- monitorFileSearchPath (programMonitorFiles prog) - (programPath prog) - ] + [ monitor + | prog <- configuredPrograms progdb + , monitor <- + monitorFileSearchPath + (programMonitorFiles prog) + (programPath prog) + ] -- | Select the bits of a 'ProgramDb' to monitor for value changes. -- Use 'programsMonitorFiles' for the files to monitor. --- programDbSignature :: ProgramDb -> [ConfiguredProgram] programDbSignature progdb = - [ prog { programMonitorFiles = [] - , programOverrideEnv = filter ((/="PATH") . fst) - (programOverrideEnv prog) } - | prog <- configuredPrograms progdb ] - -getInstalledPackages :: Verbosity - -> Compiler -> ProgramDb -> Platform - -> PackageDBStack - -> Rebuild InstalledPackageIndex + [ prog + { programMonitorFiles = [] + , programOverrideEnv = + filter + ((/= "PATH") . fst) + (programOverrideEnv prog) + } + | prog <- configuredPrograms progdb + ] + +getInstalledPackages + :: Verbosity + -> Compiler + -> ProgramDb + -> Platform + -> PackageDBStack + -> Rebuild InstalledPackageIndex getInstalledPackages verbosity compiler progdb platform packagedbs = do - monitorFiles . map monitorFileOrDirectory - =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles - verbosity compiler - packagedbs progdb platform) - liftIO $ IndexUtils.getInstalledPackages - verbosity compiler - packagedbs progdb + monitorFiles . map monitorFileOrDirectory + =<< liftIO + ( IndexUtils.getInstalledPackagesMonitorFiles + verbosity + compiler + packagedbs + progdb + platform + ) + liftIO $ + IndexUtils.getInstalledPackages + verbosity + compiler + packagedbs + progdb {- --TODO: [nice to have] use this but for sanity / consistency checking @@ -852,414 +985,447 @@ getPackageDBContents verbosity compiler progdb platform packagedb = do -} getSourcePackages - :: Verbosity - -> (forall a. (RepoContext -> IO a) -> IO a) - -> Maybe IndexUtils.TotalIndexState - -> Maybe IndexUtils.ActiveRepos - -> Rebuild (SourcePackageDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos) + :: Verbosity + -> (forall a. (RepoContext -> IO a) -> IO a) + -> Maybe IndexUtils.TotalIndexState + -> Maybe IndexUtils.ActiveRepos + -> Rebuild (SourcePackageDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos) getSourcePackages verbosity withRepoCtx idxState activeRepos = do - (sourcePkgDbWithTIS, repos) <- - liftIO $ - withRepoCtx $ \repoctx -> do - sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity repoctx idxState activeRepos - return (sourcePkgDbWithTIS, repoContextRepos repoctx) - - traverse_ needIfExists - . IndexUtils.getSourcePackagesMonitorFiles - $ repos - return sourcePkgDbWithTIS + (sourcePkgDbWithTIS, repos) <- + liftIO $ + withRepoCtx $ \repoctx -> do + sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity repoctx idxState activeRepos + return (sourcePkgDbWithTIS, repoContextRepos repoctx) + traverse_ needIfExists + . IndexUtils.getSourcePackagesMonitorFiles + $ repos + return sourcePkgDbWithTIS getPkgConfigDb :: Verbosity -> ProgramDb -> Rebuild PkgConfigDb getPkgConfigDb verbosity progdb = do - dirs <- liftIO $ getPkgConfigDbDirs verbosity progdb - -- Just monitor the dirs so we'll notice new .pc files. - -- Alternatively we could monitor all the .pc files too. - traverse_ monitorDirectoryStatus dirs - liftIO $ readPkgConfigDb verbosity progdb - + dirs <- liftIO $ getPkgConfigDbDirs verbosity progdb + -- Just monitor the dirs so we'll notice new .pc files. + -- Alternatively we could monitor all the .pc files too. + traverse_ monitorDirectoryStatus dirs + liftIO $ readPkgConfigDb verbosity progdb -- | Select the config values to monitor for changes package source hashes. -packageLocationsSignature :: SolverInstallPlan - -> [(PackageId, PackageLocation (Maybe FilePath))] +packageLocationsSignature + :: SolverInstallPlan + -> [(PackageId, PackageLocation (Maybe FilePath))] packageLocationsSignature solverPlan = - [ (packageId pkg, srcpkgSource pkg) - | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg}) - <- SolverInstallPlan.toList solverPlan - ] - + [ (packageId pkg, srcpkgSource pkg) + | SolverInstallPlan.Configured (SolverPackage{solverPkgSource = pkg}) <- + SolverInstallPlan.toList solverPlan + ] -- | Get the 'HashValue' for all the source packages where we use hashes, -- and download any packages required to do so. -- -- Note that we don't get hashes for local unpacked packages. --- -getPackageSourceHashes :: Verbosity - -> (forall a. (RepoContext -> IO a) -> IO a) - -> SolverInstallPlan - -> Rebuild (Map PackageId PackageSourceHash) +getPackageSourceHashes + :: Verbosity + -> (forall a. (RepoContext -> IO a) -> IO a) + -> SolverInstallPlan + -> Rebuild (Map PackageId PackageSourceHash) getPackageSourceHashes verbosity withRepoCtx solverPlan = do + -- Determine if and where to get the package's source hash from. + -- + let allPkgLocations :: [(PackageId, PackageLocation (Maybe FilePath))] + allPkgLocations = + [ (packageId pkg, srcpkgSource pkg) + | SolverInstallPlan.Configured (SolverPackage{solverPkgSource = pkg}) <- + SolverInstallPlan.toList solverPlan + ] - -- Determine if and where to get the package's source hash from. - -- - let allPkgLocations :: [(PackageId, PackageLocation (Maybe FilePath))] - allPkgLocations = - [ (packageId pkg, srcpkgSource pkg) - | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg}) - <- SolverInstallPlan.toList solverPlan ] - - -- Tarballs that were local in the first place. - -- We'll hash these tarball files directly. - localTarballPkgs :: [(PackageId, FilePath)] - localTarballPkgs = - [ (pkgid, tarball) - | (pkgid, LocalTarballPackage tarball) <- allPkgLocations ] - - -- Tarballs from remote URLs. We must have downloaded these already - -- (since we extracted the .cabal file earlier) - remoteTarballPkgs = - [ (pkgid, tarball) - | (pkgid, RemoteTarballPackage _ (Just tarball)) <- allPkgLocations ] - - -- tarballs from source-repository-package stanzas - sourceRepoTarballPkgs = - [ (pkgid, tarball) - | (pkgid, RemoteSourceRepoPackage _ (Just tarball)) <- allPkgLocations ] - - -- Tarballs from repositories, either where the repository provides - -- hashes as part of the repo metadata, or where we will have to - -- download and hash the tarball. - repoTarballPkgsWithMetadataUnvalidated :: [(PackageId, Repo)] - repoTarballPkgsWithoutMetadata :: [(PackageId, Repo)] - (repoTarballPkgsWithMetadataUnvalidated, - repoTarballPkgsWithoutMetadata) = + -- Tarballs that were local in the first place. + -- We'll hash these tarball files directly. + localTarballPkgs :: [(PackageId, FilePath)] + localTarballPkgs = + [ (pkgid, tarball) + | (pkgid, LocalTarballPackage tarball) <- allPkgLocations + ] + + -- Tarballs from remote URLs. We must have downloaded these already + -- (since we extracted the .cabal file earlier) + remoteTarballPkgs = + [ (pkgid, tarball) + | (pkgid, RemoteTarballPackage _ (Just tarball)) <- allPkgLocations + ] + + -- tarballs from source-repository-package stanzas + sourceRepoTarballPkgs = + [ (pkgid, tarball) + | (pkgid, RemoteSourceRepoPackage _ (Just tarball)) <- allPkgLocations + ] + + -- Tarballs from repositories, either where the repository provides + -- hashes as part of the repo metadata, or where we will have to + -- download and hash the tarball. + repoTarballPkgsWithMetadataUnvalidated :: [(PackageId, Repo)] + repoTarballPkgsWithoutMetadata :: [(PackageId, Repo)] + ( repoTarballPkgsWithMetadataUnvalidated + , repoTarballPkgsWithoutMetadata + ) = partitionEithers - [ case repo of - RepoSecure{} -> Left (pkgid, repo) - _ -> Right (pkgid, repo) - | (pkgid, RepoTarballPackage repo _ _) <- allPkgLocations ] - - (repoTarballPkgsWithMetadata, repoTarballPkgsToDownloadWithMeta) <- fmap partitionEithers $ - liftIO $ withRepoCtx $ \repoctx -> forM repoTarballPkgsWithMetadataUnvalidated $ - \x@(pkg, repo) -> verifyFetchedTarball verbosity repoctx repo pkg >>= \b -> case b of - True -> return $ Left x - False -> return $ Right x - - -- For tarballs from repos that do not have hashes available we now have - -- to check if the packages were downloaded already. - -- - (repoTarballPkgsToDownloadWithNoMeta, - repoTarballPkgsDownloaded) - <- fmap partitionEithers $ - liftIO $ sequence - [ do mtarball <- checkRepoTarballFetched repo pkgid - case mtarball of - Nothing -> return (Left (pkgid, repo)) - Just tarball -> return (Right (pkgid, tarball)) - | (pkgid, repo) <- repoTarballPkgsWithoutMetadata ] - - let repoTarballPkgsToDownload = repoTarballPkgsToDownloadWithMeta ++ repoTarballPkgsToDownloadWithNoMeta - (hashesFromRepoMetadata, - repoTarballPkgsNewlyDownloaded) <- - -- Avoid having to initialise the repository (ie 'withRepoCtx') if we - -- don't have to. (The main cost is configuring the http client.) - if null repoTarballPkgsToDownload && null repoTarballPkgsWithMetadata - then return (Map.empty, []) - else liftIO $ withRepoCtx $ \repoctx -> do + [ case repo of + RepoSecure{} -> Left (pkgid, repo) + _ -> Right (pkgid, repo) + | (pkgid, RepoTarballPackage repo _ _) <- allPkgLocations + ] - -- For tarballs from repos that do have hashes available as part of the - -- repo metadata we now load up the index for each repo and retrieve - -- the hashes for the packages - -- - hashesFromRepoMetadata <- - Sec.uncheckClientErrors $ --TODO: [code cleanup] wrap in our own exceptions - fmap (Map.fromList . concat) $ + (repoTarballPkgsWithMetadata, repoTarballPkgsToDownloadWithMeta) <- fmap partitionEithers $ + liftIO $ + withRepoCtx $ \repoctx -> forM repoTarballPkgsWithMetadataUnvalidated $ + \x@(pkg, repo) -> + verifyFetchedTarball verbosity repoctx repo pkg >>= \b -> case b of + True -> return $ Left x + False -> return $ Right x + + -- For tarballs from repos that do not have hashes available we now have + -- to check if the packages were downloaded already. + -- + ( repoTarballPkgsToDownloadWithNoMeta + , repoTarballPkgsDownloaded + ) <- + fmap partitionEithers $ + liftIO $ sequence - -- Reading the repo index is expensive so we group the packages by repo - [ repoContextWithSecureRepo repoctx repo $ \secureRepo -> - Sec.withIndex secureRepo $ \repoIndex -> - sequence - [ do hash <- Sec.trusted <$> -- strip off Trusted tag - Sec.indexLookupHash repoIndex pkgid - -- Note that hackage-security currently uses SHA256 - -- but this API could in principle give us some other - -- choice in future. - return (pkgid, hashFromTUF hash) - | pkgid <- pkgids ] - | (repo, pkgids) <- - map (\grp@((_,repo):|_) -> (repo, map fst (NE.toList grp))) - . NE.groupBy ((==) `on` (remoteRepoName . repoRemote . snd)) - . sortBy (compare `on` (remoteRepoName . repoRemote . snd)) - $ repoTarballPkgsWithMetadata + [ do + mtarball <- checkRepoTarballFetched repo pkgid + case mtarball of + Nothing -> return (Left (pkgid, repo)) + Just tarball -> return (Right (pkgid, tarball)) + | (pkgid, repo) <- repoTarballPkgsWithoutMetadata ] - -- For tarballs from repos that do not have hashes available, download - -- the ones we previously determined we need. - -- - repoTarballPkgsNewlyDownloaded <- - sequence - [ do tarball <- fetchRepoTarball verbosity repoctx repo pkgid - return (pkgid, tarball) - | (pkgid, repo) <- repoTarballPkgsToDownload ] - - return (hashesFromRepoMetadata, - repoTarballPkgsNewlyDownloaded) + let repoTarballPkgsToDownload = repoTarballPkgsToDownloadWithMeta ++ repoTarballPkgsToDownloadWithNoMeta + ( hashesFromRepoMetadata + , repoTarballPkgsNewlyDownloaded + ) <- + -- Avoid having to initialise the repository (ie 'withRepoCtx') if we + -- don't have to. (The main cost is configuring the http client.) + if null repoTarballPkgsToDownload && null repoTarballPkgsWithMetadata + then return (Map.empty, []) + else liftIO $ withRepoCtx $ \repoctx -> do + -- For tarballs from repos that do have hashes available as part of the + -- repo metadata we now load up the index for each repo and retrieve + -- the hashes for the packages + -- + hashesFromRepoMetadata <- + Sec.uncheckClientErrors $ -- TODO: [code cleanup] wrap in our own exceptions + fmap (Map.fromList . concat) $ + sequence + -- Reading the repo index is expensive so we group the packages by repo + [ repoContextWithSecureRepo repoctx repo $ \secureRepo -> + Sec.withIndex secureRepo $ \repoIndex -> + sequence + [ do + hash <- + Sec.trusted + <$> Sec.indexLookupHash repoIndex pkgid -- strip off Trusted tag + + -- Note that hackage-security currently uses SHA256 + -- but this API could in principle give us some other + -- choice in future. + return (pkgid, hashFromTUF hash) + | pkgid <- pkgids + ] + | (repo, pkgids) <- + map (\grp@((_, repo) :| _) -> (repo, map fst (NE.toList grp))) + . NE.groupBy ((==) `on` (remoteRepoName . repoRemote . snd)) + . sortBy (compare `on` (remoteRepoName . repoRemote . snd)) + $ repoTarballPkgsWithMetadata + ] + + -- For tarballs from repos that do not have hashes available, download + -- the ones we previously determined we need. + -- + repoTarballPkgsNewlyDownloaded <- + sequence + [ do + tarball <- fetchRepoTarball verbosity repoctx repo pkgid + return (pkgid, tarball) + | (pkgid, repo) <- repoTarballPkgsToDownload + ] - -- Hash tarball files for packages where we have to do that. This includes - -- tarballs that were local in the first place, plus tarballs from repos, - -- either previously cached or freshly downloaded. - -- - let allTarballFilePkgs :: [(PackageId, FilePath)] - allTarballFilePkgs = localTarballPkgs - ++ remoteTarballPkgs - ++ sourceRepoTarballPkgs - ++ repoTarballPkgsDownloaded - ++ repoTarballPkgsNewlyDownloaded - hashesFromTarballFiles <- liftIO $ + return + ( hashesFromRepoMetadata + , repoTarballPkgsNewlyDownloaded + ) + + -- Hash tarball files for packages where we have to do that. This includes + -- tarballs that were local in the first place, plus tarballs from repos, + -- either previously cached or freshly downloaded. + -- + let allTarballFilePkgs :: [(PackageId, FilePath)] + allTarballFilePkgs = + localTarballPkgs + ++ remoteTarballPkgs + ++ sourceRepoTarballPkgs + ++ repoTarballPkgsDownloaded + ++ repoTarballPkgsNewlyDownloaded + hashesFromTarballFiles <- + liftIO $ fmap Map.fromList $ - sequence - [ do srchash <- readFileHashValue tarball - return (pkgid, srchash) - | (pkgid, tarball) <- allTarballFilePkgs - ] - monitorFiles [ monitorFile tarball - | (_pkgid, tarball) <- allTarballFilePkgs ] + sequence + [ do + srchash <- readFileHashValue tarball + return (pkgid, srchash) + | (pkgid, tarball) <- allTarballFilePkgs + ] + monitorFiles + [ monitorFile tarball + | (_pkgid, tarball) <- allTarballFilePkgs + ] - -- Return the combination - return $! hashesFromRepoMetadata - <> hashesFromTarballFiles + -- Return the combination + return $! + hashesFromRepoMetadata + <> hashesFromTarballFiles -- | Append the given package databases to an existing PackageDBStack. -- A @Nothing@ entry will clear everything before it. applyPackageDbFlags :: PackageDBStack -> [Maybe PackageDB] -> PackageDBStack -applyPackageDbFlags dbs' [] = dbs' -applyPackageDbFlags _ (Nothing:dbs) = applyPackageDbFlags [] dbs -applyPackageDbFlags dbs' (Just db:dbs) = applyPackageDbFlags (dbs' ++ [db]) dbs +applyPackageDbFlags dbs' [] = dbs' +applyPackageDbFlags _ (Nothing : dbs) = applyPackageDbFlags [] dbs +applyPackageDbFlags dbs' (Just db : dbs) = applyPackageDbFlags (dbs' ++ [db]) dbs -- ------------------------------------------------------------ + -- * Installation planning + -- ------------------------------------------------------------ -planPackages :: Verbosity - -> Compiler - -> Platform - -> Solver -> SolverSettings - -> InstalledPackageIndex - -> SourcePackageDb - -> PkgConfigDb - -> [PackageSpecifier UnresolvedSourcePackage] - -> Map PackageName (Map OptionalStanza Bool) - -> Progress String String SolverInstallPlan -planPackages verbosity comp platform solver SolverSettings{..} - installedPkgIndex sourcePkgDb pkgConfigDB - localPackages pkgStanzasEnable = +planPackages + :: Verbosity + -> Compiler + -> Platform + -> Solver + -> SolverSettings + -> InstalledPackageIndex + -> SourcePackageDb + -> PkgConfigDb + -> [PackageSpecifier UnresolvedSourcePackage] + -> Map PackageName (Map OptionalStanza Bool) + -> Progress String String SolverInstallPlan +planPackages + verbosity + comp + platform + solver + SolverSettings{..} + installedPkgIndex + sourcePkgDb + pkgConfigDB + localPackages + pkgStanzasEnable = resolveDependencies - platform (compilerInfo comp) - pkgConfigDB solver + platform + (compilerInfo comp) + pkgConfigDB + solver resolverParams - - where - - --TODO: [nice to have] disable multiple instances restriction in - -- the solver, but then make sure we can cope with that in the - -- output. - resolverParams :: DepResolverParams - resolverParams = - + where + -- TODO: [nice to have] disable multiple instances restriction in + -- the solver, but then make sure we can cope with that in the + -- output. + resolverParams :: DepResolverParams + resolverParams = setMaxBackjumps solverSettingMaxBackjumps - - . setIndependentGoals solverSettingIndependentGoals - - . setReorderGoals solverSettingReorderGoals - - . setCountConflicts solverSettingCountConflicts - - . setFineGrainedConflicts solverSettingFineGrainedConflicts - - . setMinimizeConflictSet solverSettingMinimizeConflictSet - - --TODO: [required eventually] should only be configurable for - --custom installs - -- . setAvoidReinstalls solverSettingAvoidReinstalls - - --TODO: [required eventually] should only be configurable for - --custom installs - -- . setShadowPkgs solverSettingShadowPkgs - - . setStrongFlags solverSettingStrongFlags - - . setAllowBootLibInstalls solverSettingAllowBootLibInstalls - - . setOnlyConstrained solverSettingOnlyConstrained - - . setSolverVerbosity verbosity - - --TODO: [required eventually] decide if we need to prefer - -- installed for global packages, or prefer latest even for - -- global packages. Perhaps should be configurable but with a - -- different name than "upgrade-dependencies". - . setPreferenceDefault - (if Cabal.asBool solverSettingPreferOldest - then PreferAllOldest - else PreferLatestForSelected) - {-(if solverSettingUpgradeDeps - then PreferAllLatest - else PreferLatestForSelected)-} - - . removeLowerBounds solverSettingAllowOlder - . removeUpperBounds solverSettingAllowNewer - - . addDefaultSetupDependencies (defaultSetupDeps comp platform - . PD.packageDescription - . srcpkgDescription) - - . addSetupCabalMinVersionConstraint setupMinCabalVersionConstraint - . addSetupCabalMaxVersionConstraint setupMaxCabalVersionConstraint - - . addPreferences - -- preferences from the config file or command line - [ PackageVersionPreference name ver - | PackageVersionConstraint name ver <- solverSettingPreferences ] - - . addConstraints - -- version constraints from the config file or command line + . setIndependentGoals solverSettingIndependentGoals + . setReorderGoals solverSettingReorderGoals + . setCountConflicts solverSettingCountConflicts + . setFineGrainedConflicts solverSettingFineGrainedConflicts + . setMinimizeConflictSet solverSettingMinimizeConflictSet + -- TODO: [required eventually] should only be configurable for + -- custom installs + -- . setAvoidReinstalls solverSettingAvoidReinstalls + + -- TODO: [required eventually] should only be configurable for + -- custom installs + -- . setShadowPkgs solverSettingShadowPkgs + + . setStrongFlags solverSettingStrongFlags + . setAllowBootLibInstalls solverSettingAllowBootLibInstalls + . setOnlyConstrained solverSettingOnlyConstrained + . setSolverVerbosity verbosity + -- TODO: [required eventually] decide if we need to prefer + -- installed for global packages, or prefer latest even for + -- global packages. Perhaps should be configurable but with a + -- different name than "upgrade-dependencies". + . setPreferenceDefault + ( if Cabal.asBool solverSettingPreferOldest + then PreferAllOldest + else PreferLatestForSelected + ) + {-(if solverSettingUpgradeDeps + then PreferAllLatest + else PreferLatestForSelected)-} + + . removeLowerBounds solverSettingAllowOlder + . removeUpperBounds solverSettingAllowNewer + . addDefaultSetupDependencies + ( defaultSetupDeps comp platform + . PD.packageDescription + . srcpkgDescription + ) + . addSetupCabalMinVersionConstraint setupMinCabalVersionConstraint + . addSetupCabalMaxVersionConstraint setupMaxCabalVersionConstraint + . addPreferences + -- preferences from the config file or command line + [ PackageVersionPreference name ver + | PackageVersionConstraint name ver <- solverSettingPreferences + ] + . addConstraints + -- version constraints from the config file or command line [ LabeledPackageConstraint (userToPackageConstraint pc) src - | (pc, src) <- solverSettingConstraints ] - - . addPreferences - -- enable stanza preference unilaterally, regardless if the user asked - -- accordingly or expressed no preference, to help hint the solver - [ PackageStanzasPreference pkgname stanzas - | pkg <- localPackages - , let pkgname = pkgSpecifierTarget pkg - stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable - stanzas = [ stanza | stanza <- [minBound..maxBound] - , Map.lookup stanza stanzaM /= Just False ] - , not (null stanzas) - ] - - . addConstraints - -- enable stanza constraints where the user asked to enable - [ LabeledPackageConstraint - (PackageConstraint (scopeToplevel pkgname) - (PackagePropertyStanzas stanzas)) + | (pc, src) <- solverSettingConstraints + ] + . addPreferences + -- enable stanza preference unilaterally, regardless if the user asked + -- accordingly or expressed no preference, to help hint the solver + [ PackageStanzasPreference pkgname stanzas + | pkg <- localPackages + , let pkgname = pkgSpecifierTarget pkg + stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable + stanzas = + [ stanza | stanza <- [minBound .. maxBound], Map.lookup stanza stanzaM /= Just False + ] + , not (null stanzas) + ] + . addConstraints + -- enable stanza constraints where the user asked to enable + [ LabeledPackageConstraint + ( PackageConstraint + (scopeToplevel pkgname) + (PackagePropertyStanzas stanzas) + ) ConstraintSourceConfigFlagOrTarget - | pkg <- localPackages - , let pkgname = pkgSpecifierTarget pkg - stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable - stanzas = [ stanza | stanza <- [minBound..maxBound] - , Map.lookup stanza stanzaM == Just True ] - , not (null stanzas) - ] - - . addConstraints - --TODO: [nice to have] should have checked at some point that the - -- package in question actually has these flags. - [ LabeledPackageConstraint - (PackageConstraint (scopeToplevel pkgname) - (PackagePropertyFlags flags)) + | pkg <- localPackages + , let pkgname = pkgSpecifierTarget pkg + stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable + stanzas = + [ stanza | stanza <- [minBound .. maxBound], Map.lookup stanza stanzaM == Just True + ] + , not (null stanzas) + ] + . addConstraints + -- TODO: [nice to have] should have checked at some point that the + -- package in question actually has these flags. + [ LabeledPackageConstraint + ( PackageConstraint + (scopeToplevel pkgname) + (PackagePropertyFlags flags) + ) ConstraintSourceConfigFlagOrTarget - | (pkgname, flags) <- Map.toList solverSettingFlagAssignments ] - - . addConstraints - --TODO: [nice to have] we have user-supplied flags for unspecified - -- local packages (as well as specific per-package flags). For the - -- former we just apply all these flags to all local targets which - -- is silly. We should check if the flags are appropriate. - [ LabeledPackageConstraint - (PackageConstraint (scopeToplevel pkgname) - (PackagePropertyFlags flags)) + | (pkgname, flags) <- Map.toList solverSettingFlagAssignments + ] + . addConstraints + -- TODO: [nice to have] we have user-supplied flags for unspecified + -- local packages (as well as specific per-package flags). For the + -- former we just apply all these flags to all local targets which + -- is silly. We should check if the flags are appropriate. + [ LabeledPackageConstraint + ( PackageConstraint + (scopeToplevel pkgname) + (PackagePropertyFlags flags) + ) ConstraintSourceConfigFlagOrTarget - | let flags = solverSettingFlagAssignment - , not (PD.nullFlagAssignment flags) - , pkg <- localPackages - , let pkgname = pkgSpecifierTarget pkg ] - - $ stdResolverParams - - stdResolverParams :: DepResolverParams - stdResolverParams = - -- Note: we don't use the standardInstallPolicy here, since that uses - -- its own addDefaultSetupDependencies that is not appropriate for us. - basicInstallPolicy - installedPkgIndex sourcePkgDb - localPackages - - -- While we can talk to older Cabal versions (we need to be able to - -- do so for custom Setup scripts that require older Cabal lib - -- versions), we have problems talking to some older versions that - -- don't support certain features. - -- - -- For example, Cabal-1.16 and older do not know about build targets. - -- Even worse, 1.18 and older only supported the --constraint flag - -- with source package ids, not --dependency with installed package - -- ids. That is bad because we cannot reliably select the right - -- dependencies in the presence of multiple instances (i.e. the - -- store). See issue #3932. So we require Cabal 1.20 as a minimum. - -- - -- Moreover, lib:Cabal generally only supports the interface of - -- current and past compilers; in fact recent lib:Cabal versions - -- will warn when they encounter a too new or unknown GHC compiler - -- version (c.f. #415). To avoid running into unsupported - -- configurations we encode the compatibility matrix as lower - -- bounds on lib:Cabal here (effectively corresponding to the - -- respective major Cabal version bundled with the respective GHC - -- release). - -- - -- GHC 9.2 needs Cabal >= 3.6 - -- GHC 9.0 needs Cabal >= 3.4 - -- GHC 8.10 needs Cabal >= 3.2 - -- GHC 8.8 needs Cabal >= 3.0 - -- GHC 8.6 needs Cabal >= 2.4 - -- GHC 8.4 needs Cabal >= 2.2 - -- GHC 8.2 needs Cabal >= 2.0 - -- GHC 8.0 needs Cabal >= 1.24 - -- GHC 7.10 needs Cabal >= 1.22 - -- - -- (NB: we don't need to consider older GHCs as Cabal >= 1.20 is - -- the absolute lower bound) - -- - -- TODO: long-term, this compatibility matrix should be - -- stored as a field inside 'Distribution.Compiler.Compiler' - setupMinCabalVersionConstraint - | isGHC, compVer >= mkVersion [9,6] = mkVersion [3,10] - | isGHC, compVer >= mkVersion [9,4] = mkVersion [3,8] - | isGHC, compVer >= mkVersion [9,2] = mkVersion [3,6] - | isGHC, compVer >= mkVersion [9,0] = mkVersion [3,4] - | isGHC, compVer >= mkVersion [8,10] = mkVersion [3,2] - | isGHC, compVer >= mkVersion [8,8] = mkVersion [3,0] - | isGHC, compVer >= mkVersion [8,6] = mkVersion [2,4] - | isGHC, compVer >= mkVersion [8,4] = mkVersion [2,2] - | isGHC, compVer >= mkVersion [8,2] = mkVersion [2,0] - | isGHC, compVer >= mkVersion [8,0] = mkVersion [1,24] - | isGHC, compVer >= mkVersion [7,10] = mkVersion [1,22] - | otherwise = mkVersion [1,20] - where - isGHC = compFlav `elem` [GHC,GHCJS] - compFlav = compilerFlavor comp - compVer = compilerVersion comp + | let flags = solverSettingFlagAssignment + , not (PD.nullFlagAssignment flags) + , pkg <- localPackages + , let pkgname = pkgSpecifierTarget pkg + ] + $ stdResolverParams + + stdResolverParams :: DepResolverParams + stdResolverParams = + -- Note: we don't use the standardInstallPolicy here, since that uses + -- its own addDefaultSetupDependencies that is not appropriate for us. + basicInstallPolicy + installedPkgIndex + sourcePkgDb + localPackages + + -- While we can talk to older Cabal versions (we need to be able to + -- do so for custom Setup scripts that require older Cabal lib + -- versions), we have problems talking to some older versions that + -- don't support certain features. + -- + -- For example, Cabal-1.16 and older do not know about build targets. + -- Even worse, 1.18 and older only supported the --constraint flag + -- with source package ids, not --dependency with installed package + -- ids. That is bad because we cannot reliably select the right + -- dependencies in the presence of multiple instances (i.e. the + -- store). See issue #3932. So we require Cabal 1.20 as a minimum. + -- + -- Moreover, lib:Cabal generally only supports the interface of + -- current and past compilers; in fact recent lib:Cabal versions + -- will warn when they encounter a too new or unknown GHC compiler + -- version (c.f. #415). To avoid running into unsupported + -- configurations we encode the compatibility matrix as lower + -- bounds on lib:Cabal here (effectively corresponding to the + -- respective major Cabal version bundled with the respective GHC + -- release). + -- + -- GHC 9.2 needs Cabal >= 3.6 + -- GHC 9.0 needs Cabal >= 3.4 + -- GHC 8.10 needs Cabal >= 3.2 + -- GHC 8.8 needs Cabal >= 3.0 + -- GHC 8.6 needs Cabal >= 2.4 + -- GHC 8.4 needs Cabal >= 2.2 + -- GHC 8.2 needs Cabal >= 2.0 + -- GHC 8.0 needs Cabal >= 1.24 + -- GHC 7.10 needs Cabal >= 1.22 + -- + -- (NB: we don't need to consider older GHCs as Cabal >= 1.20 is + -- the absolute lower bound) + -- + -- TODO: long-term, this compatibility matrix should be + -- stored as a field inside 'Distribution.Compiler.Compiler' + setupMinCabalVersionConstraint + | isGHC, compVer >= mkVersion [9, 6] = mkVersion [3, 10] + | isGHC, compVer >= mkVersion [9, 4] = mkVersion [3, 8] + | isGHC, compVer >= mkVersion [9, 2] = mkVersion [3, 6] + | isGHC, compVer >= mkVersion [9, 0] = mkVersion [3, 4] + | isGHC, compVer >= mkVersion [8, 10] = mkVersion [3, 2] + | isGHC, compVer >= mkVersion [8, 8] = mkVersion [3, 0] + | isGHC, compVer >= mkVersion [8, 6] = mkVersion [2, 4] + | isGHC, compVer >= mkVersion [8, 4] = mkVersion [2, 2] + | isGHC, compVer >= mkVersion [8, 2] = mkVersion [2, 0] + | isGHC, compVer >= mkVersion [8, 0] = mkVersion [1, 24] + | isGHC, compVer >= mkVersion [7, 10] = mkVersion [1, 22] + | otherwise = mkVersion [1, 20] + where + isGHC = compFlav `elem` [GHC, GHCJS] + compFlav = compilerFlavor comp + compVer = compilerVersion comp - -- As we can't predict the future, we also place a global upper - -- bound on the lib:Cabal version we know how to interact with: - -- - -- The upper bound is computed by incrementing the current major - -- version twice in order to allow for the current version, as - -- well as the next adjacent major version (one of which will not - -- be released, as only "even major" versions of Cabal are - -- released to Hackage or bundled with proper GHC releases). - -- - -- For instance, if the current version of cabal-install is an odd - -- development version, e.g. Cabal-2.1.0.0, then we impose an - -- upper bound `setup.Cabal < 2.3`; if `cabal-install` is on a - -- stable/release even version, e.g. Cabal-2.2.1.0, the upper - -- bound is `setup.Cabal < 2.4`. This gives us enough flexibility - -- when dealing with development snapshots of Cabal and cabal-install. - -- - setupMaxCabalVersionConstraint = - alterVersion (take 2) $ incVersion 1 $ incVersion 1 cabalVersion + -- As we can't predict the future, we also place a global upper + -- bound on the lib:Cabal version we know how to interact with: + -- + -- The upper bound is computed by incrementing the current major + -- version twice in order to allow for the current version, as + -- well as the next adjacent major version (one of which will not + -- be released, as only "even major" versions of Cabal are + -- released to Hackage or bundled with proper GHC releases). + -- + -- For instance, if the current version of cabal-install is an odd + -- development version, e.g. Cabal-2.1.0.0, then we impose an + -- upper bound `setup.Cabal < 2.3`; if `cabal-install` is on a + -- stable/release even version, e.g. Cabal-2.2.1.0, the upper + -- bound is `setup.Cabal < 2.4`. This gives us enough flexibility + -- when dealing with development snapshots of Cabal and cabal-install. + -- + setupMaxCabalVersionConstraint = + alterVersion (take 2) $ incVersion 1 $ incVersion 1 cabalVersion ------------------------------------------------------------------------------ + -- * Install plan post-processing + ------------------------------------------------------------------------------ -- This phase goes from the InstallPlan we get from the solver and has to @@ -1275,11 +1441,10 @@ planPackages verbosity comp platform solver SolverSettings{..} -- way to calculate the installed package ids used for the replacement step is -- from the elaborated configuration for each package. - - - ------------------------------------------------------------------------------ + -- * Install plan elaboration + ------------------------------------------------------------------------------ -- Note [SolverId to ConfiguredId] @@ -1298,7 +1463,9 @@ planPackages verbosity comp platform solver SolverSettings{..} -- library dependencies on lib-0.2, and executable dependencies on pkg-0.1 -- and alex-0.3 (other components of the package may have different -- dependencies). Note that I've "lost" the knowledge that I depend --- *specifically* on the exe1 executable from pkg. + +-- * specifically* on the exe1 executable from pkg. + -- -- So, we have a this graph of packages, and we need to transform it into -- a graph of components which we are actually going to build. In particular: @@ -1353,15 +1520,17 @@ planPackages verbosity comp platform solver SolverSettings{..} -- like a 'ConfiguredId', in that it incorporates the version choices of its -- dependencies, but less fine grained. - -- | Produce an elaborated install plan using the policy for local builds with -- a nix-style shared store. -- -- In theory should be able to make an elaborated install plan with a policy -- matching that of the classic @cabal install --user@ or @--global@ --- elaborateInstallPlan - :: Verbosity -> Platform -> Compiler -> ProgramDb -> PkgConfigDb + :: Verbosity + -> Platform + -> Compiler + -> ProgramDb + -> PkgConfigDb -> DistDirLayout -> StoreDirLayout -> SolverInstallPlan @@ -1373,759 +1542,879 @@ elaborateInstallPlan -> PackageConfig -> Map PackageName PackageConfig -> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig) -elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB - distDirLayout@DistDirLayout{..} - storeDirLayout@StoreDirLayout{storePackageDBStack} - solverPlan localPackages - sourcePackageHashes - defaultInstallDirs - sharedPackageConfig - allPackagesConfig - localPackagesConfig - perPackageConfig = do +elaborateInstallPlan + verbosity + platform + compiler + compilerprogdb + pkgConfigDB + distDirLayout@DistDirLayout{..} + storeDirLayout@StoreDirLayout{storePackageDBStack} + solverPlan + localPackages + sourcePackageHashes + defaultInstallDirs + sharedPackageConfig + allPackagesConfig + localPackagesConfig + perPackageConfig = do x <- elaboratedInstallPlan return (x, elaboratedSharedConfig) - where - elaboratedSharedConfig = - ElaboratedSharedConfig { - pkgConfigPlatform = platform, - pkgConfigCompiler = compiler, - pkgConfigCompilerProgs = compilerprogdb, - pkgConfigReplOptions = mempty - } - - preexistingInstantiatedPkgs :: Map UnitId FullUnitId - preexistingInstantiatedPkgs = + where + elaboratedSharedConfig = + ElaboratedSharedConfig + { pkgConfigPlatform = platform + , pkgConfigCompiler = compiler + , pkgConfigCompilerProgs = compilerprogdb + , pkgConfigReplOptions = mempty + } + + preexistingInstantiatedPkgs :: Map UnitId FullUnitId + preexistingInstantiatedPkgs = Map.fromList (mapMaybe f (SolverInstallPlan.toList solverPlan)) - where - f (SolverInstallPlan.PreExisting inst) + where + f (SolverInstallPlan.PreExisting inst) | let ipkg = instSolverPkgIPI inst - , not (IPI.indefinite ipkg) - = Just (IPI.installedUnitId ipkg, - (FullUnitId (IPI.installedComponentId ipkg) - (Map.fromList (IPI.instantiatedWith ipkg)))) - f _ = Nothing - - elaboratedInstallPlan :: - LogProgress (InstallPlan.GenericInstallPlan IPI.InstalledPackageInfo ElaboratedConfiguredPackage) - elaboratedInstallPlan = - flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg -> - case planpkg of - SolverInstallPlan.PreExisting pkg -> - return [InstallPlan.PreExisting (instSolverPkgIPI pkg)] - - SolverInstallPlan.Configured pkg -> - let inplace_doc | shouldBuildInplaceOnly pkg = text "inplace" - | otherwise = Disp.empty - in addProgressCtx (text "In the" <+> inplace_doc <+> text "package" <+> - quotes (pretty (packageId pkg))) $ - map InstallPlan.Configured <$> elaborateSolverToComponents mapDep pkg - - -- NB: We don't INSTANTIATE packages at this point. That's - -- a post-pass. This makes it simpler to compute dependencies. - elaborateSolverToComponents + , not (IPI.indefinite ipkg) = + Just + ( IPI.installedUnitId ipkg + , ( FullUnitId + (IPI.installedComponentId ipkg) + (Map.fromList (IPI.instantiatedWith ipkg)) + ) + ) + f _ = Nothing + + elaboratedInstallPlan + :: LogProgress (InstallPlan.GenericInstallPlan IPI.InstalledPackageInfo ElaboratedConfiguredPackage) + elaboratedInstallPlan = + flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg -> + case planpkg of + SolverInstallPlan.PreExisting pkg -> + return [InstallPlan.PreExisting (instSolverPkgIPI pkg)] + SolverInstallPlan.Configured pkg -> + let inplace_doc + | shouldBuildInplaceOnly pkg = text "inplace" + | otherwise = Disp.empty + in addProgressCtx + ( text "In the" + <+> inplace_doc + <+> text "package" + <+> quotes (pretty (packageId pkg)) + ) + $ map InstallPlan.Configured <$> elaborateSolverToComponents mapDep pkg + + -- NB: We don't INSTANTIATE packages at this point. That's + -- a post-pass. This makes it simpler to compute dependencies. + elaborateSolverToComponents :: (SolverId -> [ElaboratedPlanPackage]) -> SolverPackage UnresolvedPkgLoc -> LogProgress [ElaboratedConfiguredPackage] - elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ deps0 exe_deps0) - = case mkComponentsGraph (elabEnabledSpec elab0) pd of - Right g -> do + elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ deps0 exe_deps0) = + case mkComponentsGraph (elabEnabledSpec elab0) pd of + Right g -> do let src_comps = componentsGraphToList g - infoProgress $ hang (text "Component graph for" <+> pretty pkgid <<>> colon) - 4 (dispComponentsWithDeps src_comps) - (_, comps) <- mapAccumM buildComponent - (Map.empty, Map.empty, Map.empty) - (map fst src_comps) + infoProgress $ + hang + (text "Component graph for" <+> pretty pkgid <<>> colon) + 4 + (dispComponentsWithDeps src_comps) + (_, comps) <- + mapAccumM + buildComponent + (Map.empty, Map.empty, Map.empty) + (map fst src_comps) let not_per_component_reasons = why_not_per_component src_comps if null not_per_component_reasons - then return comps - else do checkPerPackageOk comps not_per_component_reasons - return [elaborateSolverToPackage spkg g $ - comps ++ maybeToList setupComponent] - Left cns -> + then return comps + else do + checkPerPackageOk comps not_per_component_reasons + return + [ elaborateSolverToPackage spkg g $ + comps ++ maybeToList setupComponent + ] + Left cns -> dieProgress $ - hang (text "Dependency cycle between the following components:") 4 - (vcat (map (text . componentNameStanza) cns)) - where - -- 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 ++ cuz_coverage - where - cuz reason = [text reason] - -- We have to disable per-component for now with - -- Configure-type scripts in order to prevent parallel - -- invocation of the same `./configure` script. - -- See https://github.com/haskell/cabal/issues/4548 - -- - -- Moreover, at this point in time, only non-Custom setup scripts - -- are supported. Implementing per-component builds with - -- Custom would require us to create a new 'ElabSetup' - -- type, and teach all of the code paths how to handle it. - -- Once you've implemented this, swap it for the code below. - cuz_buildtype = + hang + (text "Dependency cycle between the following components:") + 4 + (vcat (map (text . componentNameStanza) cns)) + where + -- 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 ++ cuz_coverage + where + cuz reason = [text reason] + -- We have to disable per-component for now with + -- Configure-type scripts in order to prevent parallel + -- invocation of the same `./configure` script. + -- See https://github.com/haskell/cabal/issues/4548 + -- + -- Moreover, at this point in time, only non-Custom setup scripts + -- are supported. Implementing per-component builds with + -- Custom would require us to create a new 'ElabSetup' + -- type, and teach all of the code paths how to handle it. + -- Once you've implemented this, swap it for the code below. + cuz_buildtype = case PD.buildType (elabPkgDescription elab0) of - PD.Configure -> cuz "build-type is Configure" - PD.Custom -> cuz "build-type is Custom" - _ -> [] - -- 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 - cuz_spec + PD.Configure -> cuz "build-type is Configure" + PD.Custom -> cuz "build-type is Custom" + _ -> [] + -- 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 + cuz_spec | PD.specVersion pd >= CabalSpecV1_8 = [] | otherwise = cuz "cabal-version is less than 1.8" - -- In the odd corner case that a package has no components at all - -- then keep it as a whole package, since otherwise it turns into - -- 0 component graph nodes and effectively vanishes. We want to - -- keep it around at least for error reporting purposes. - cuz_length + -- In the odd corner case that a package has no components at all + -- then keep it as a whole package, since otherwise it turns into + -- 0 component graph nodes and effectively vanishes. We want to + -- keep it around at least for error reporting purposes. + cuz_length | length g > 0 = [] - | otherwise = cuz "there are no buildable components" - -- For ease of testing, we let per-component builds be toggled - -- at the top level - cuz_flag - | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig) - = [] + | otherwise = cuz "there are no buildable components" + -- For ease of testing, we let per-component builds be toggled + -- at the top level + cuz_flag + | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig) = + [] | otherwise = cuz "you passed --disable-per-component" - -- Enabling program coverage introduces odd runtime dependencies - -- between components. - cuz_coverage - | fromFlagOrDefault False (packageConfigCoverage localPackagesConfig) - = cuz "program coverage is enabled" + -- Enabling program coverage introduces odd runtime dependencies + -- between components. + cuz_coverage + | fromFlagOrDefault False (packageConfigCoverage localPackagesConfig) = + cuz "program coverage is enabled" | otherwise = [] - -- | Sometimes a package may make use of features which are only - -- supported in per-package mode. If this is the case, we should - -- give an error when this occurs. - checkPerPackageOk comps reasons = do + -- \| Sometimes a package may make use of features which are only + -- supported in per-package mode. If this is the case, we should + -- give an error when this occurs. + checkPerPackageOk comps reasons = do let is_sublib (CLibName (LSubLibName _)) = True is_sublib _ = False when (any (matchElabPkg is_sublib) comps) $ - dieProgress $ - text "Internal libraries only supported with per-component builds." $$ - text "Per-component builds were disabled because" <+> - fsep (punctuate comma reasons) - -- TODO: Maybe exclude Backpack too - - elab0 = elaborateSolverToCommon spkg - pkgid = elabPkgSourceId elab0 - pd = elabPkgDescription elab0 - - -- TODO: This is just a skeleton to get elaborateSolverToPackage - -- working correctly - -- TODO: When we actually support building these components, we - -- have to add dependencies on this from all other components - setupComponent :: Maybe ElaboratedConfiguredPackage - setupComponent - | PD.buildType (elabPkgDescription elab0) == PD.Custom - = Just elab0 { - elabModuleShape = emptyModuleShape, - elabUnitId = notImpl "elabUnitId", - elabComponentId = notImpl "elabComponentId", - elabLinkedInstantiatedWith = Map.empty, - elabInstallDirs = notImpl "elabInstallDirs", - elabPkgOrComp = ElabComponent (ElaboratedComponent {..}) - } - | otherwise - = Nothing - where - compSolverName = CD.ComponentSetup - compComponentName = Nothing - dep_pkgs = elaborateLibSolverId mapDep =<< CD.setupDeps deps0 - compLibDependencies - = map configuredId dep_pkgs - compLinkedLibDependencies = notImpl "compLinkedLibDependencies" - compOrderLibDependencies = notImpl "compOrderLibDependencies" - -- Not supported: - compExeDependencies = [] - compExeDependencyPaths = [] - compPkgConfigDependencies = [] - - notImpl f = - error $ "Distribution.Client.ProjectPlanning.setupComponent: " ++ - f ++ " not implemented yet" - - - buildComponent - :: (ConfiguredComponentMap, - LinkedComponentMap, - Map ComponentId FilePath) + dieProgress $ + text "Internal libraries only supported with per-component builds." + $$ text "Per-component builds were disabled because" + <+> fsep (punctuate comma reasons) + -- TODO: Maybe exclude Backpack too + + elab0 = elaborateSolverToCommon spkg + pkgid = elabPkgSourceId elab0 + pd = elabPkgDescription elab0 + + -- TODO: This is just a skeleton to get elaborateSolverToPackage + -- working correctly + -- TODO: When we actually support building these components, we + -- have to add dependencies on this from all other components + setupComponent :: Maybe ElaboratedConfiguredPackage + setupComponent + | PD.buildType (elabPkgDescription elab0) == PD.Custom = + Just + elab0 + { elabModuleShape = emptyModuleShape + , elabUnitId = notImpl "elabUnitId" + , elabComponentId = notImpl "elabComponentId" + , elabLinkedInstantiatedWith = Map.empty + , elabInstallDirs = notImpl "elabInstallDirs" + , elabPkgOrComp = ElabComponent (ElaboratedComponent{..}) + } + | otherwise = + Nothing + where + compSolverName = CD.ComponentSetup + compComponentName = Nothing + dep_pkgs = elaborateLibSolverId mapDep =<< CD.setupDeps deps0 + compLibDependencies = + map configuredId dep_pkgs + compLinkedLibDependencies = notImpl "compLinkedLibDependencies" + compOrderLibDependencies = notImpl "compOrderLibDependencies" + -- Not supported: + compExeDependencies = [] + compExeDependencyPaths = [] + compPkgConfigDependencies = [] + + notImpl f = + error $ + "Distribution.Client.ProjectPlanning.setupComponent: " + ++ f + ++ " not implemented yet" + + buildComponent + :: ( ConfiguredComponentMap + , LinkedComponentMap + , Map ComponentId FilePath + ) -> Cabal.Component -> LogProgress - ((ConfiguredComponentMap, - LinkedComponentMap, - Map ComponentId FilePath), - ElaboratedConfiguredPackage) - buildComponent (cc_map, lc_map, exe_map) comp = - addProgressCtx (text "In the stanza" <+> - quotes (text (componentNameStanza cname))) $ do - - -- 1. Configure the component, but with a place holder ComponentId. - cc0 <- toConfiguredComponent + ( ( ConfiguredComponentMap + , LinkedComponentMap + , Map ComponentId FilePath + ) + , ElaboratedConfiguredPackage + ) + buildComponent (cc_map, lc_map, exe_map) comp = + addProgressCtx + ( text "In the stanza" + <+> quotes (text (componentNameStanza cname)) + ) + $ do + -- 1. Configure the component, but with a place holder ComponentId. + cc0 <- + toConfiguredComponent pd (error "Distribution.Client.ProjectPlanning.cc_cid: filled in later") (Map.unionWith Map.union external_lib_cc_map cc_map) (Map.unionWith Map.union external_exe_cc_map cc_map) comp - - -- 2. Read out the dependencies from the ConfiguredComponent cc0 - let compLibDependencies = - -- Nub because includes can show up multiple times - ordNub (map (annotatedIdToConfiguredId . ci_ann_id) - (cc_includes cc0)) - compExeDependencies = - map annotatedIdToConfiguredId + -- 2. Read out the dependencies from the ConfiguredComponent cc0 + let compLibDependencies = + -- Nub because includes can show up multiple times + ordNub + ( map + (annotatedIdToConfiguredId . ci_ann_id) + (cc_includes cc0) + ) + compExeDependencies = + map + annotatedIdToConfiguredId (cc_exe_deps cc0) - compExeDependencyPaths = - [ (annotatedIdToConfiguredId aid', path) - | aid' <- cc_exe_deps cc0 - , Just paths <- [Map.lookup (ann_id aid') exe_map1] - , path <- paths ] - elab_comp = ElaboratedComponent {..} - - -- 3. Construct a preliminary ElaboratedConfiguredPackage, - -- and use this to compute the component ID. Fix up cc_id - -- correctly. - let elab1 = elab0 { - elabPkgOrComp = ElabComponent $ elab_comp - } - cid = case elabBuildStyle elab0 of - BuildInplaceOnly -> - mkComponentId $ - prettyShow pkgid ++ "-inplace" ++ - (case Cabal.componentNameString cname of + compExeDependencyPaths = + [ (annotatedIdToConfiguredId aid', path) + | aid' <- cc_exe_deps cc0 + , Just paths <- [Map.lookup (ann_id aid') exe_map1] + , path <- paths + ] + elab_comp = ElaboratedComponent{..} + + -- 3. Construct a preliminary ElaboratedConfiguredPackage, + -- and use this to compute the component ID. Fix up cc_id + -- correctly. + let elab1 = + elab0 + { elabPkgOrComp = ElabComponent $ elab_comp + } + cid = case elabBuildStyle elab0 of + BuildInplaceOnly -> + mkComponentId $ + prettyShow pkgid + ++ "-inplace" + ++ ( case Cabal.componentNameString cname of Nothing -> "" - Just s -> "-" ++ prettyShow s) - BuildAndInstall -> - hashedInstalledPackageId - (packageHashInputs - elaboratedSharedConfig - elab1) -- knot tied - cc = cc0 { cc_ann_id = fmap (const cid) (cc_ann_id cc0) } - infoProgress $ dispConfiguredComponent cc - - -- 4. Perform mix-in linking - let lookup_uid def_uid = - case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of + Just s -> "-" ++ prettyShow s + ) + BuildAndInstall -> + hashedInstalledPackageId + ( packageHashInputs + elaboratedSharedConfig + elab1 -- knot tied + ) + cc = cc0{cc_ann_id = fmap (const cid) (cc_ann_id cc0)} + infoProgress $ dispConfiguredComponent cc + + -- 4. Perform mix-in linking + let lookup_uid def_uid = + case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of Just full -> full Nothing -> error ("lookup_uid: " ++ prettyShow def_uid) - lc <- toLinkedComponent verbosity lookup_uid (elabPkgSourceId elab0) - (Map.union external_lc_map lc_map) cc - infoProgress $ dispLinkedComponent lc - -- NB: elab is setup to be the correct form for an - -- indefinite library, or a definite library with no holes. - -- We will modify it in 'instantiateInstallPlan' to handle - -- instantiated packages. - - -- 5. Construct the final ElaboratedConfiguredPackage - let - elab2 = elab1 { - elabModuleShape = lc_shape lc, - elabUnitId = abstractUnitId (lc_uid lc), - elabComponentId = lc_cid lc, - elabLinkedInstantiatedWith = Map.fromList (lc_insts lc), - elabPkgOrComp = ElabComponent $ elab_comp { - compLinkedLibDependencies = ordNub (map ci_id (lc_includes lc)), - compOrderLibDependencies = - ordNub (map (abstractUnitId . ci_id) - (lc_includes lc ++ lc_sig_includes lc)) + lc <- + toLinkedComponent + verbosity + lookup_uid + (elabPkgSourceId elab0) + (Map.union external_lc_map lc_map) + cc + infoProgress $ dispLinkedComponent lc + -- NB: elab is setup to be the correct form for an + -- indefinite library, or a definite library with no holes. + -- We will modify it in 'instantiateInstallPlan' to handle + -- instantiated packages. + + -- 5. Construct the final ElaboratedConfiguredPackage + let + elab2 = + elab1 + { elabModuleShape = lc_shape lc + , elabUnitId = abstractUnitId (lc_uid lc) + , elabComponentId = lc_cid lc + , elabLinkedInstantiatedWith = Map.fromList (lc_insts lc) + , elabPkgOrComp = + ElabComponent $ + elab_comp + { compLinkedLibDependencies = ordNub (map ci_id (lc_includes lc)) + , compOrderLibDependencies = + ordNub + ( map + (abstractUnitId . ci_id) + (lc_includes lc ++ lc_sig_includes lc) + ) + } + } + elab = + elab2 + { elabInstallDirs = + computeInstallDirs + storeDirLayout + defaultInstallDirs + elaboratedSharedConfig + elab2 } - } - elab = elab2 { - elabInstallDirs = computeInstallDirs - storeDirLayout - defaultInstallDirs - elaboratedSharedConfig - elab2 - } - -- 6. Construct the updated local maps - let cc_map' = extendConfiguredComponentMap cc cc_map - lc_map' = extendLinkedComponentMap lc lc_map - exe_map' = Map.insert cid (inplace_bin_dir elab) exe_map + -- 6. Construct the updated local maps + let cc_map' = extendConfiguredComponentMap cc cc_map + lc_map' = extendLinkedComponentMap lc lc_map + exe_map' = Map.insert cid (inplace_bin_dir elab) exe_map - return ((cc_map', lc_map', exe_map'), elab) - where - compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies" - compOrderLibDependencies = error "buildComponent: compOrderLibDependencies" - - cname = Cabal.componentName comp - compComponentName = Just cname - compSolverName = CD.componentNameToComponent cname - - -- NB: compLinkedLibDependencies and - -- compOrderLibDependencies are defined when we define - -- 'elab'. - external_lib_dep_sids = CD.select (== compSolverName) deps0 - external_exe_dep_sids = CD.select (== compSolverName) exe_deps0 - - external_lib_dep_pkgs = concatMap mapDep external_lib_dep_sids - - -- Combine library and build-tool dependencies, for backwards - -- compatibility (See issue #5412 and the documentation for - -- InstallPlan.fromSolverInstallPlan), but prefer the versions - -- specified as build-tools. - external_exe_dep_pkgs = + return ((cc_map', lc_map', exe_map'), elab) + where + compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies" + compOrderLibDependencies = error "buildComponent: compOrderLibDependencies" + + cname = Cabal.componentName comp + compComponentName = Just cname + compSolverName = CD.componentNameToComponent cname + + -- NB: compLinkedLibDependencies and + -- compOrderLibDependencies are defined when we define + -- 'elab'. + external_lib_dep_sids = CD.select (== compSolverName) deps0 + external_exe_dep_sids = CD.select (== compSolverName) exe_deps0 + + external_lib_dep_pkgs = concatMap mapDep external_lib_dep_sids + + -- Combine library and build-tool dependencies, for backwards + -- compatibility (See issue #5412 and the documentation for + -- InstallPlan.fromSolverInstallPlan), but prefer the versions + -- specified as build-tools. + external_exe_dep_pkgs = concatMap mapDep $ - ordNubBy (pkgName . packageId) $ - external_exe_dep_sids ++ external_lib_dep_sids - - external_exe_map = Map.fromList $ - [ (getComponentId pkg, paths) - | pkg <- external_exe_dep_pkgs - , let paths = planPackageExePaths pkg ] - exe_map1 = Map.union external_exe_map $ fmap (\x -> [x]) exe_map - - external_lib_cc_map = Map.fromListWith Map.union - $ map mkCCMapping external_lib_dep_pkgs - external_exe_cc_map = Map.fromListWith Map.union - $ map mkCCMapping external_exe_dep_pkgs - external_lc_map = - Map.fromList $ map mkShapeMapping $ - external_lib_dep_pkgs ++ concatMap mapDep external_exe_dep_sids - - compPkgConfigDependencies = - [ (pn, fromMaybe (error $ "compPkgConfigDependencies: impossible! " - ++ prettyShow pn ++ " from " - ++ prettyShow (elabPkgSourceId elab0)) - (pkgConfigDbPkgVersion pkgConfigDB pn)) - | PkgconfigDependency pn _ <- PD.pkgconfigDepends - (Cabal.componentBuildInfo comp) ] - - inplace_bin_dir elab = + ordNubBy (pkgName . packageId) $ + external_exe_dep_sids ++ external_lib_dep_sids + + external_exe_map = + Map.fromList $ + [ (getComponentId pkg, paths) + | pkg <- external_exe_dep_pkgs + , let paths = planPackageExePaths pkg + ] + exe_map1 = Map.union external_exe_map $ fmap (\x -> [x]) exe_map + + external_lib_cc_map = + Map.fromListWith Map.union $ + map mkCCMapping external_lib_dep_pkgs + external_exe_cc_map = + Map.fromListWith Map.union $ + map mkCCMapping external_exe_dep_pkgs + external_lc_map = + Map.fromList $ + map mkShapeMapping $ + external_lib_dep_pkgs ++ concatMap mapDep external_exe_dep_sids + + compPkgConfigDependencies = + [ ( pn + , fromMaybe + ( error $ + "compPkgConfigDependencies: impossible! " + ++ prettyShow pn + ++ " from " + ++ prettyShow (elabPkgSourceId elab0) + ) + (pkgConfigDbPkgVersion pkgConfigDB pn) + ) + | PkgconfigDependency pn _ <- + PD.pkgconfigDepends + (Cabal.componentBuildInfo comp) + ] + + inplace_bin_dir elab = binDirectoryFor - distDirLayout - elaboratedSharedConfig - elab $ - case Cabal.componentNameString cname of - Just n -> prettyShow n - Nothing -> "" - - - -- | Given a 'SolverId' referencing a dependency on a library, return - -- the 'ElaboratedPlanPackage' corresponding to the library. This - -- returns at most one result. - elaborateLibSolverId :: (SolverId -> [ElaboratedPlanPackage]) - -> SolverId -> [ElaboratedPlanPackage] - elaborateLibSolverId mapDep = filter (matchPlanPkg (== (CLibName LMainLibName))) . mapDep - - -- | Given an 'ElaboratedPlanPackage', return the paths to where the - -- executables that this package represents would be installed. - -- The only case where multiple paths can be returned is the inplace - -- monolithic package one, since there can be multiple exes and each one - -- has its own directory. - planPackageExePaths :: ElaboratedPlanPackage -> [FilePath] - planPackageExePaths = + distDirLayout + elaboratedSharedConfig + elab + $ case Cabal.componentNameString cname of + Just n -> prettyShow n + Nothing -> "" + + -- \| Given a 'SolverId' referencing a dependency on a library, return + -- the 'ElaboratedPlanPackage' corresponding to the library. This + -- returns at most one result. + elaborateLibSolverId + :: (SolverId -> [ElaboratedPlanPackage]) + -> SolverId + -> [ElaboratedPlanPackage] + elaborateLibSolverId mapDep = filter (matchPlanPkg (== (CLibName LMainLibName))) . mapDep + + -- \| Given an 'ElaboratedPlanPackage', return the paths to where the + -- executables that this package represents would be installed. + -- The only case where multiple paths can be returned is the inplace + -- monolithic package one, since there can be multiple exes and each one + -- has its own directory. + planPackageExePaths :: ElaboratedPlanPackage -> [FilePath] + planPackageExePaths = -- Pre-existing executables are assumed to be in PATH -- already. In fact, this should be impossible. InstallPlan.foldPlanPackage (const []) $ \elab -> - let - executables :: [FilePath] - executables = - case elabPkgOrComp elab of - -- Monolithic mode: all exes of the package - ElabPackage _ -> unUnqualComponentName . PD.exeName - <$> PD.executables (elabPkgDescription elab) - -- Per-component mode: just the selected exe - ElabComponent comp -> - case fmap Cabal.componentNameString - (compComponentName comp) of - Just (Just n) -> [prettyShow n] - _ -> [""] - in - binDirectoryFor - distDirLayout - elaboratedSharedConfig - elab - <$> executables - - elaborateSolverToPackage :: SolverPackage UnresolvedPkgLoc - -> ComponentsGraph - -> [ElaboratedConfiguredPackage] - -> ElaboratedConfiguredPackage - elaborateSolverToPackage - pkg@(SolverPackage (SourcePackage pkgid _gpd _srcloc _descOverride) - _flags _stanzas _deps0 _exe_deps0) - compGraph comps = - -- Knot tying: the final elab includes the - -- pkgInstalledId, which is calculated by hashing many - -- of the other fields of the elaboratedPackage. - elab - where - elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon pkg - elab1 = elab0 { - elabUnitId = newSimpleUnitId pkgInstalledId, - elabComponentId = pkgInstalledId, - elabLinkedInstantiatedWith = Map.empty, - elabPkgOrComp = ElabPackage $ ElaboratedPackage {..}, - elabModuleShape = modShape - } - elab = elab1 { - elabInstallDirs = - computeInstallDirs storeDirLayout - defaultInstallDirs - elaboratedSharedConfig - elab1 - } - - modShape = case find (matchElabPkg (== (CLibName LMainLibName))) comps of - Nothing -> emptyModuleShape - Just e -> Ty.elabModuleShape e - - pkgInstalledId - | shouldBuildInplaceOnly pkg - = mkComponentId (prettyShow pkgid ++ "-inplace") - - | otherwise - = assert (isJust elabPkgSourceHash) $ - hashedInstalledPackageId - (packageHashInputs - elaboratedSharedConfig - elab) -- recursive use of elab - - -- Need to filter out internal dependencies, because they don't - -- correspond to anything real anymore. - isExt confid = confSrcId confid /= pkgid - filterExt = filter isExt - filterExt' = filter (isExt . fst) - - pkgLibDependencies - = buildComponentDeps (filterExt . compLibDependencies) - pkgExeDependencies - = buildComponentDeps (filterExt . compExeDependencies) - pkgExeDependencyPaths - = buildComponentDeps (filterExt' . compExeDependencyPaths) - -- TODO: Why is this flat? - pkgPkgConfigDependencies - = CD.flatDeps $ buildComponentDeps compPkgConfigDependencies - - pkgDependsOnSelfLib - = CD.fromList [ (CD.componentNameToComponent cn, [()]) - | Graph.N _ cn _ <- fromMaybe [] mb_closure ] - where - mb_closure = Graph.revClosure compGraph [ k | k <- Graph.keys compGraph, is_lib k ] - -- NB: the sublib case should not occur, because sub-libraries - -- are not supported without per-component builds - is_lib (CLibName _) = True - is_lib _ = False - - buildComponentDeps f - = CD.fromList [ (compSolverName comp, f comp) - | ElaboratedConfiguredPackage{ - elabPkgOrComp = ElabComponent comp - } <- comps - ] - - -- NB: This is not the final setting of 'pkgStanzasEnabled'. - -- See [Sticky enabled testsuites]; we may enable some extra - -- stanzas opportunistically when it is cheap to do so. - -- - -- However, we start off by enabling everything that was - -- requested, so that we can maintain an invariant that - -- pkgStanzasEnabled is a superset of elabStanzasRequested - pkgStanzasEnabled = optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested - - elaborateSolverToCommon :: SolverPackage UnresolvedPkgLoc - -> ElaboratedConfiguredPackage - elaborateSolverToCommon - pkg@(SolverPackage (SourcePackage pkgid gdesc srcloc descOverride) - flags stanzas deps0 _exe_deps0) = - elaboratedPackage - where - elaboratedPackage = ElaboratedConfiguredPackage {..} - - -- These get filled in later - elabUnitId = error "elaborateSolverToCommon: elabUnitId" - elabComponentId = error "elaborateSolverToCommon: elabComponentId" - elabInstantiatedWith = Map.empty - elabLinkedInstantiatedWith = error "elaborateSolverToCommon: elabLinkedInstantiatedWith" - elabPkgOrComp = error "elaborateSolverToCommon: elabPkgOrComp" - elabInstallDirs = error "elaborateSolverToCommon: elabInstallDirs" - elabModuleShape = error "elaborateSolverToCommon: elabModuleShape" - - elabIsCanonical = True - elabPkgSourceId = pkgid - elabPkgDescription = case PD.finalizePD - flags elabEnabledSpec (const True) - platform (compilerInfo compiler) - [] gdesc of - Right (desc, _) -> desc - Left _ -> error "Failed to finalizePD in elaborateSolverToCommon" - elabFlagAssignment = flags - elabFlagDefaults = PD.mkFlagAssignment - [ (Cabal.flagName flag, Cabal.flagDefault flag) - | flag <- PD.genPackageFlags gdesc ] - - elabEnabledSpec = enableStanzas stanzas - elabStanzasAvailable = stanzas - - elabStanzasRequested :: OptionalStanzaMap (Maybe Bool) - elabStanzasRequested = optStanzaTabulate $ \o -> case o of - -- NB: even if a package stanza is requested, if the package - -- doesn't actually have any of that stanza we omit it from - -- the request, to ensure that we don't decide that this - -- package needs to be rebuilt. (It needs to be done here, - -- because the ElaboratedConfiguredPackage is where we test - -- whether or not there have been changes.) - TestStanzas -> listToMaybe [ v | v <- maybeToList tests, _ <- PD.testSuites elabPkgDescription ] - BenchStanzas -> listToMaybe [ v | v <- maybeToList benchmarks, _ <- PD.benchmarks elabPkgDescription ] + let + executables :: [FilePath] + executables = + case elabPkgOrComp elab of + -- Monolithic mode: all exes of the package + ElabPackage _ -> + unUnqualComponentName . PD.exeName + <$> PD.executables (elabPkgDescription elab) + -- Per-component mode: just the selected exe + ElabComponent comp -> + case fmap + Cabal.componentNameString + (compComponentName comp) of + Just (Just n) -> [prettyShow n] + _ -> [""] + in + binDirectoryFor + distDirLayout + elaboratedSharedConfig + elab + <$> executables + + elaborateSolverToPackage + :: SolverPackage UnresolvedPkgLoc + -> ComponentsGraph + -> [ElaboratedConfiguredPackage] + -> ElaboratedConfiguredPackage + elaborateSolverToPackage + pkg@( SolverPackage + (SourcePackage pkgid _gpd _srcloc _descOverride) + _flags + _stanzas + _deps0 + _exe_deps0 + ) + compGraph + comps = + -- Knot tying: the final elab includes the + -- pkgInstalledId, which is calculated by hashing many + -- of the other fields of the elaboratedPackage. + elab where - tests, benchmarks :: Maybe Bool - tests = perPkgOptionMaybe pkgid packageConfigTests - benchmarks = perPkgOptionMaybe pkgid packageConfigBenchmarks - - -- This is a placeholder which will get updated by 'pruneInstallPlanPass1' - -- and 'pruneInstallPlanPass2'. We can't populate it here - -- because whether or not tests/benchmarks should be enabled - -- is heuristically calculated based on whether or not the - -- dependencies of the test suite have already been installed, - -- but this function doesn't know what is installed (since - -- we haven't improved the plan yet), so we do it in another pass. - -- Check the comments of those functions for more details. - elabConfigureTargets = [] - elabBuildTargets = [] - elabTestTargets = [] - elabBenchTargets = [] - elabReplTarget = Nothing - elabHaddockTargets = [] - - elabBuildHaddocks = - perPkgOptionFlag pkgid False packageConfigDocumentation - - elabPkgSourceLocation = srcloc - elabPkgSourceHash = Map.lookup pkgid sourcePackageHashes - elabLocalToProject = isLocalToProject pkg - elabBuildStyle = if shouldBuildInplaceOnly pkg - then BuildInplaceOnly else BuildAndInstall - elabPackageDbs = projectConfigPackageDBs sharedPackageConfig - elabBuildPackageDBStack = buildAndRegisterDbs - elabRegisterPackageDBStack = buildAndRegisterDbs - - elabSetupScriptStyle = packageSetupScriptStyle elabPkgDescription - elabSetupScriptCliVersion = - packageSetupScriptSpecVersion - elabSetupScriptStyle elabPkgDescription libDepGraph deps0 - elabSetupPackageDBStack = buildAndRegisterDbs - - elabInplaceBuildPackageDBStack = inplacePackageDbs - elabInplaceRegisterPackageDBStack = inplacePackageDbs - elabInplaceSetupPackageDBStack = inplacePackageDbs - - buildAndRegisterDbs - | shouldBuildInplaceOnly pkg = inplacePackageDbs - | otherwise = corePackageDbs - - elabPkgDescriptionOverride = descOverride - - elabVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib --TODO: [required feature]: also needs to be handled recursively - elabSharedLib = pkgid `Set.member` pkgsUseSharedLibrary - elabStaticLib = perPkgOptionFlag pkgid False packageConfigStaticLib - elabDynExe = perPkgOptionFlag pkgid False packageConfigDynExe - elabFullyStaticExe = perPkgOptionFlag pkgid False packageConfigFullyStaticExe - elabGHCiLib = perPkgOptionFlag pkgid False packageConfigGHCiLib --TODO: [required feature] needs to default to enabled on windows still - - elabProfExe = perPkgOptionFlag pkgid False packageConfigProf - elabProfLib = pkgid `Set.member` pkgsUseProfilingLibrary - - (elabProfExeDetail, - elabProfLibDetail) = perPkgOptionLibExeFlag pkgid ProfDetailDefault - packageConfigProfDetail - packageConfigProfLibDetail - elabCoverage = perPkgOptionFlag pkgid False packageConfigCoverage - - elabOptimization = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization - elabSplitObjs = perPkgOptionFlag pkgid False packageConfigSplitObjs - elabSplitSections = perPkgOptionFlag pkgid False packageConfigSplitSections - elabStripLibs = perPkgOptionFlag pkgid False packageConfigStripLibs - elabStripExes = perPkgOptionFlag pkgid False packageConfigStripExes - elabDebugInfo = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo - elabDumpBuildInfo = perPkgOptionFlag pkgid NoDumpBuildInfo packageConfigDumpBuildInfo - - -- Combine the configured compiler prog settings with the user-supplied - -- config. For the compiler progs any user-supplied config was taken - -- into account earlier when configuring the compiler so its ok that - -- our configured settings for the compiler override the user-supplied - -- config here. - elabProgramPaths = Map.fromList - [ (programId prog, programPath prog) - | prog <- configuredPrograms compilerprogdb ] - <> perPkgOptionMapLast pkgid packageConfigProgramPaths - elabProgramArgs = Map.fromList - [ (programId prog, args) - | prog <- configuredPrograms compilerprogdb - , let args = programOverrideArgs prog - , not (null args) - ] - <> perPkgOptionMapMappend pkgid packageConfigProgramArgs - elabProgramPathExtra = perPkgOptionNubList pkgid packageConfigProgramPathExtra - elabConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs - elabExtraLibDirs = perPkgOptionList pkgid packageConfigExtraLibDirs - elabExtraLibDirsStatic = perPkgOptionList pkgid packageConfigExtraLibDirsStatic - elabExtraFrameworkDirs = perPkgOptionList pkgid packageConfigExtraFrameworkDirs - elabExtraIncludeDirs = perPkgOptionList pkgid packageConfigExtraIncludeDirs - elabProgPrefix = perPkgOptionMaybe pkgid packageConfigProgPrefix - elabProgSuffix = perPkgOptionMaybe pkgid packageConfigProgSuffix - - - elabHaddockHoogle = perPkgOptionFlag pkgid False packageConfigHaddockHoogle - elabHaddockHtml = perPkgOptionFlag pkgid False packageConfigHaddockHtml - elabHaddockHtmlLocation = perPkgOptionMaybe pkgid packageConfigHaddockHtmlLocation - elabHaddockForeignLibs = perPkgOptionFlag pkgid False packageConfigHaddockForeignLibs - elabHaddockForHackage = perPkgOptionFlag pkgid Cabal.ForDevelopment packageConfigHaddockForHackage - elabHaddockExecutables = perPkgOptionFlag pkgid False packageConfigHaddockExecutables - elabHaddockTestSuites = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites - elabHaddockBenchmarks = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks - elabHaddockInternal = perPkgOptionFlag pkgid False packageConfigHaddockInternal - elabHaddockCss = perPkgOptionMaybe pkgid packageConfigHaddockCss - elabHaddockLinkedSource = perPkgOptionFlag pkgid False packageConfigHaddockLinkedSource - elabHaddockQuickJump = perPkgOptionFlag pkgid False packageConfigHaddockQuickJump - elabHaddockHscolourCss = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss - elabHaddockContents = perPkgOptionMaybe pkgid packageConfigHaddockContents - elabHaddockIndex = perPkgOptionMaybe pkgid packageConfigHaddockIndex - elabHaddockBaseUrl = perPkgOptionMaybe pkgid packageConfigHaddockBaseUrl - elabHaddockLib = perPkgOptionMaybe pkgid packageConfigHaddockLib - elabHaddockOutputDir = perPkgOptionMaybe pkgid packageConfigHaddockOutputDir - - elabTestMachineLog = perPkgOptionMaybe pkgid packageConfigTestMachineLog - elabTestHumanLog = perPkgOptionMaybe pkgid packageConfigTestHumanLog - elabTestShowDetails = perPkgOptionMaybe pkgid packageConfigTestShowDetails - elabTestKeepTix = perPkgOptionFlag pkgid False packageConfigTestKeepTix - elabTestWrapper = perPkgOptionMaybe pkgid packageConfigTestWrapper - elabTestFailWhenNoTestSuites = perPkgOptionFlag pkgid False packageConfigTestFailWhenNoTestSuites - elabTestTestOptions = perPkgOptionList pkgid packageConfigTestTestOptions - - elabBenchmarkOptions = perPkgOptionList pkgid packageConfigBenchmarkOptions - - perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a - perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a - perPkgOptionList :: PackageId -> (PackageConfig -> [a]) -> [a] - - perPkgOptionFlag pkgid def f = fromFlagOrDefault def (lookupPerPkgOption pkgid f) - perPkgOptionMaybe pkgid f = flagToMaybe (lookupPerPkgOption pkgid f) - perPkgOptionList pkgid f = lookupPerPkgOption pkgid f - perPkgOptionNubList pkgid f = fromNubList (lookupPerPkgOption pkgid f) - perPkgOptionMapLast pkgid f = getMapLast (lookupPerPkgOption pkgid f) - perPkgOptionMapMappend pkgid f = getMapMappend (lookupPerPkgOption pkgid f) - - perPkgOptionLibExeFlag pkgid def fboth flib = (exe, lib) - where - exe = fromFlagOrDefault def bothflag - lib = fromFlagOrDefault def (bothflag <> libflag) - - bothflag = lookupPerPkgOption pkgid fboth - libflag = lookupPerPkgOption pkgid flib + elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon pkg + elab1 = + elab0 + { elabUnitId = newSimpleUnitId pkgInstalledId + , elabComponentId = pkgInstalledId + , elabLinkedInstantiatedWith = Map.empty + , elabPkgOrComp = ElabPackage $ ElaboratedPackage{..} + , elabModuleShape = modShape + } + elab = + elab1 + { elabInstallDirs = + computeInstallDirs + storeDirLayout + defaultInstallDirs + elaboratedSharedConfig + elab1 + } - lookupPerPkgOption :: (Package pkg, Monoid m) - => pkg -> (PackageConfig -> m) -> m - lookupPerPkgOption pkg f = + modShape = case find (matchElabPkg (== (CLibName LMainLibName))) comps of + Nothing -> emptyModuleShape + Just e -> Ty.elabModuleShape e + + pkgInstalledId + | shouldBuildInplaceOnly pkg = + mkComponentId (prettyShow pkgid ++ "-inplace") + | otherwise = + assert (isJust elabPkgSourceHash) $ + hashedInstalledPackageId + ( packageHashInputs + elaboratedSharedConfig + elab -- recursive use of elab + ) + + -- Need to filter out internal dependencies, because they don't + -- correspond to anything real anymore. + isExt confid = confSrcId confid /= pkgid + filterExt = filter isExt + filterExt' = filter (isExt . fst) + + pkgLibDependencies = + buildComponentDeps (filterExt . compLibDependencies) + pkgExeDependencies = + buildComponentDeps (filterExt . compExeDependencies) + pkgExeDependencyPaths = + buildComponentDeps (filterExt' . compExeDependencyPaths) + -- TODO: Why is this flat? + pkgPkgConfigDependencies = + CD.flatDeps $ buildComponentDeps compPkgConfigDependencies + + pkgDependsOnSelfLib = + CD.fromList + [ (CD.componentNameToComponent cn, [()]) + | Graph.N _ cn _ <- fromMaybe [] mb_closure + ] + where + mb_closure = Graph.revClosure compGraph [k | k <- Graph.keys compGraph, is_lib k] + -- NB: the sublib case should not occur, because sub-libraries + -- are not supported without per-component builds + is_lib (CLibName _) = True + is_lib _ = False + + buildComponentDeps f = + CD.fromList + [ (compSolverName comp, f comp) + | ElaboratedConfiguredPackage + { elabPkgOrComp = ElabComponent comp + } <- + comps + ] + + -- NB: This is not the final setting of 'pkgStanzasEnabled'. + -- See [Sticky enabled testsuites]; we may enable some extra + -- stanzas opportunistically when it is cheap to do so. + -- + -- However, we start off by enabling everything that was + -- requested, so that we can maintain an invariant that + -- pkgStanzasEnabled is a superset of elabStanzasRequested + pkgStanzasEnabled = optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested + + elaborateSolverToCommon + :: SolverPackage UnresolvedPkgLoc + -> ElaboratedConfiguredPackage + elaborateSolverToCommon + pkg@( SolverPackage + (SourcePackage pkgid gdesc srcloc descOverride) + flags + stanzas + deps0 + _exe_deps0 + ) = + elaboratedPackage + where + elaboratedPackage = ElaboratedConfiguredPackage{..} + + -- These get filled in later + elabUnitId = error "elaborateSolverToCommon: elabUnitId" + elabComponentId = error "elaborateSolverToCommon: elabComponentId" + elabInstantiatedWith = Map.empty + elabLinkedInstantiatedWith = error "elaborateSolverToCommon: elabLinkedInstantiatedWith" + elabPkgOrComp = error "elaborateSolverToCommon: elabPkgOrComp" + elabInstallDirs = error "elaborateSolverToCommon: elabInstallDirs" + elabModuleShape = error "elaborateSolverToCommon: elabModuleShape" + + elabIsCanonical = True + elabPkgSourceId = pkgid + elabPkgDescription = case PD.finalizePD + flags + elabEnabledSpec + (const True) + platform + (compilerInfo compiler) + [] + gdesc of + Right (desc, _) -> desc + Left _ -> error "Failed to finalizePD in elaborateSolverToCommon" + elabFlagAssignment = flags + elabFlagDefaults = + PD.mkFlagAssignment + [ (Cabal.flagName flag, Cabal.flagDefault flag) + | flag <- PD.genPackageFlags gdesc + ] + + elabEnabledSpec = enableStanzas stanzas + elabStanzasAvailable = stanzas + + elabStanzasRequested :: OptionalStanzaMap (Maybe Bool) + elabStanzasRequested = optStanzaTabulate $ \o -> case o of + -- NB: even if a package stanza is requested, if the package + -- doesn't actually have any of that stanza we omit it from + -- the request, to ensure that we don't decide that this + -- package needs to be rebuilt. (It needs to be done here, + -- because the ElaboratedConfiguredPackage is where we test + -- whether or not there have been changes.) + TestStanzas -> listToMaybe [v | v <- maybeToList tests, _ <- PD.testSuites elabPkgDescription] + BenchStanzas -> listToMaybe [v | v <- maybeToList benchmarks, _ <- PD.benchmarks elabPkgDescription] + where + tests, benchmarks :: Maybe Bool + tests = perPkgOptionMaybe pkgid packageConfigTests + benchmarks = perPkgOptionMaybe pkgid packageConfigBenchmarks + + -- This is a placeholder which will get updated by 'pruneInstallPlanPass1' + -- and 'pruneInstallPlanPass2'. We can't populate it here + -- because whether or not tests/benchmarks should be enabled + -- is heuristically calculated based on whether or not the + -- dependencies of the test suite have already been installed, + -- but this function doesn't know what is installed (since + -- we haven't improved the plan yet), so we do it in another pass. + -- Check the comments of those functions for more details. + elabConfigureTargets = [] + elabBuildTargets = [] + elabTestTargets = [] + elabBenchTargets = [] + elabReplTarget = Nothing + elabHaddockTargets = [] + + elabBuildHaddocks = + perPkgOptionFlag pkgid False packageConfigDocumentation + + elabPkgSourceLocation = srcloc + elabPkgSourceHash = Map.lookup pkgid sourcePackageHashes + elabLocalToProject = isLocalToProject pkg + elabBuildStyle = + if shouldBuildInplaceOnly pkg + then BuildInplaceOnly + else BuildAndInstall + elabPackageDbs = projectConfigPackageDBs sharedPackageConfig + elabBuildPackageDBStack = buildAndRegisterDbs + elabRegisterPackageDBStack = buildAndRegisterDbs + + elabSetupScriptStyle = packageSetupScriptStyle elabPkgDescription + elabSetupScriptCliVersion = + packageSetupScriptSpecVersion + elabSetupScriptStyle + elabPkgDescription + libDepGraph + deps0 + elabSetupPackageDBStack = buildAndRegisterDbs + + elabInplaceBuildPackageDBStack = inplacePackageDbs + elabInplaceRegisterPackageDBStack = inplacePackageDbs + elabInplaceSetupPackageDBStack = inplacePackageDbs + + buildAndRegisterDbs + | shouldBuildInplaceOnly pkg = inplacePackageDbs + | otherwise = corePackageDbs + + elabPkgDescriptionOverride = descOverride + + elabVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib -- TODO: [required feature]: also needs to be handled recursively + elabSharedLib = pkgid `Set.member` pkgsUseSharedLibrary + elabStaticLib = perPkgOptionFlag pkgid False packageConfigStaticLib + elabDynExe = perPkgOptionFlag pkgid False packageConfigDynExe + elabFullyStaticExe = perPkgOptionFlag pkgid False packageConfigFullyStaticExe + elabGHCiLib = perPkgOptionFlag pkgid False packageConfigGHCiLib -- TODO: [required feature] needs to default to enabled on windows still + elabProfExe = perPkgOptionFlag pkgid False packageConfigProf + elabProfLib = pkgid `Set.member` pkgsUseProfilingLibrary + + ( elabProfExeDetail + , elabProfLibDetail + ) = + perPkgOptionLibExeFlag + pkgid + ProfDetailDefault + packageConfigProfDetail + packageConfigProfLibDetail + elabCoverage = perPkgOptionFlag pkgid False packageConfigCoverage + + elabOptimization = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization + elabSplitObjs = perPkgOptionFlag pkgid False packageConfigSplitObjs + elabSplitSections = perPkgOptionFlag pkgid False packageConfigSplitSections + elabStripLibs = perPkgOptionFlag pkgid False packageConfigStripLibs + elabStripExes = perPkgOptionFlag pkgid False packageConfigStripExes + elabDebugInfo = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo + elabDumpBuildInfo = perPkgOptionFlag pkgid NoDumpBuildInfo packageConfigDumpBuildInfo + + -- Combine the configured compiler prog settings with the user-supplied + -- config. For the compiler progs any user-supplied config was taken + -- into account earlier when configuring the compiler so its ok that + -- our configured settings for the compiler override the user-supplied + -- config here. + elabProgramPaths = + Map.fromList + [ (programId prog, programPath prog) + | prog <- configuredPrograms compilerprogdb + ] + <> perPkgOptionMapLast pkgid packageConfigProgramPaths + elabProgramArgs = + Map.fromList + [ (programId prog, args) + | prog <- configuredPrograms compilerprogdb + , let args = programOverrideArgs prog + , not (null args) + ] + <> perPkgOptionMapMappend pkgid packageConfigProgramArgs + elabProgramPathExtra = perPkgOptionNubList pkgid packageConfigProgramPathExtra + elabConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs + elabExtraLibDirs = perPkgOptionList pkgid packageConfigExtraLibDirs + elabExtraLibDirsStatic = perPkgOptionList pkgid packageConfigExtraLibDirsStatic + elabExtraFrameworkDirs = perPkgOptionList pkgid packageConfigExtraFrameworkDirs + elabExtraIncludeDirs = perPkgOptionList pkgid packageConfigExtraIncludeDirs + elabProgPrefix = perPkgOptionMaybe pkgid packageConfigProgPrefix + elabProgSuffix = perPkgOptionMaybe pkgid packageConfigProgSuffix + + elabHaddockHoogle = perPkgOptionFlag pkgid False packageConfigHaddockHoogle + elabHaddockHtml = perPkgOptionFlag pkgid False packageConfigHaddockHtml + elabHaddockHtmlLocation = perPkgOptionMaybe pkgid packageConfigHaddockHtmlLocation + elabHaddockForeignLibs = perPkgOptionFlag pkgid False packageConfigHaddockForeignLibs + elabHaddockForHackage = perPkgOptionFlag pkgid Cabal.ForDevelopment packageConfigHaddockForHackage + elabHaddockExecutables = perPkgOptionFlag pkgid False packageConfigHaddockExecutables + elabHaddockTestSuites = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites + elabHaddockBenchmarks = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks + elabHaddockInternal = perPkgOptionFlag pkgid False packageConfigHaddockInternal + elabHaddockCss = perPkgOptionMaybe pkgid packageConfigHaddockCss + elabHaddockLinkedSource = perPkgOptionFlag pkgid False packageConfigHaddockLinkedSource + elabHaddockQuickJump = perPkgOptionFlag pkgid False packageConfigHaddockQuickJump + elabHaddockHscolourCss = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss + elabHaddockContents = perPkgOptionMaybe pkgid packageConfigHaddockContents + elabHaddockIndex = perPkgOptionMaybe pkgid packageConfigHaddockIndex + elabHaddockBaseUrl = perPkgOptionMaybe pkgid packageConfigHaddockBaseUrl + elabHaddockLib = perPkgOptionMaybe pkgid packageConfigHaddockLib + elabHaddockOutputDir = perPkgOptionMaybe pkgid packageConfigHaddockOutputDir + + elabTestMachineLog = perPkgOptionMaybe pkgid packageConfigTestMachineLog + elabTestHumanLog = perPkgOptionMaybe pkgid packageConfigTestHumanLog + elabTestShowDetails = perPkgOptionMaybe pkgid packageConfigTestShowDetails + elabTestKeepTix = perPkgOptionFlag pkgid False packageConfigTestKeepTix + elabTestWrapper = perPkgOptionMaybe pkgid packageConfigTestWrapper + elabTestFailWhenNoTestSuites = perPkgOptionFlag pkgid False packageConfigTestFailWhenNoTestSuites + elabTestTestOptions = perPkgOptionList pkgid packageConfigTestTestOptions + + elabBenchmarkOptions = perPkgOptionList pkgid packageConfigBenchmarkOptions + + perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a + perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a + perPkgOptionList :: PackageId -> (PackageConfig -> [a]) -> [a] + + perPkgOptionFlag pkgid def f = fromFlagOrDefault def (lookupPerPkgOption pkgid f) + perPkgOptionMaybe pkgid f = flagToMaybe (lookupPerPkgOption pkgid f) + perPkgOptionList pkgid f = lookupPerPkgOption pkgid f + perPkgOptionNubList pkgid f = fromNubList (lookupPerPkgOption pkgid f) + perPkgOptionMapLast pkgid f = getMapLast (lookupPerPkgOption pkgid f) + perPkgOptionMapMappend pkgid f = getMapMappend (lookupPerPkgOption pkgid f) + + perPkgOptionLibExeFlag pkgid def fboth flib = (exe, lib) + where + exe = fromFlagOrDefault def bothflag + lib = fromFlagOrDefault def (bothflag <> libflag) + + bothflag = lookupPerPkgOption pkgid fboth + libflag = lookupPerPkgOption pkgid flib + + lookupPerPkgOption + :: (Package pkg, Monoid m) + => pkg + -> (PackageConfig -> m) + -> m + lookupPerPkgOption pkg f = -- This is where we merge the options from the project config that -- apply to all packages, all project local packages, and to specific -- named packages global `mappend` local `mappend` perpkg - where - global = f allPackagesConfig - local | isLocalToProject pkg - = f localPackagesConfig - | otherwise - = mempty - perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig) - - inplacePackageDbs = corePackageDbs - ++ [ distPackageDB (compilerId compiler) ] - - corePackageDbs = applyPackageDbFlags (storePackageDBStack (compilerId compiler)) - (projectConfigPackageDBs sharedPackageConfig) - - -- For this local build policy, every package that lives in a local source - -- dir (as opposed to a tarball), or depends on such a package, will be - -- built inplace into a shared dist dir. Tarball packages that depend on - -- source dir packages will also get unpacked locally. - shouldBuildInplaceOnly :: SolverPackage loc -> Bool - shouldBuildInplaceOnly pkg = Set.member (packageId pkg) - pkgsToBuildInplaceOnly - - pkgsToBuildInplaceOnly :: Set PackageId - pkgsToBuildInplaceOnly = - Set.fromList - $ map packageId - $ SolverInstallPlan.reverseDependencyClosure - solverPlan - (map PlannedId (Set.toList pkgsLocalToProject)) - - isLocalToProject :: Package pkg => pkg -> Bool - isLocalToProject pkg = Set.member (packageId pkg) - pkgsLocalToProject - - pkgsLocalToProject :: Set PackageId - pkgsLocalToProject = + where + global = f allPackagesConfig + local + | isLocalToProject pkg = + f localPackagesConfig + | otherwise = + mempty + perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig) + + inplacePackageDbs = + corePackageDbs + ++ [distPackageDB (compilerId compiler)] + + corePackageDbs = + applyPackageDbFlags + (storePackageDBStack (compilerId compiler)) + (projectConfigPackageDBs sharedPackageConfig) + + -- For this local build policy, every package that lives in a local source + -- dir (as opposed to a tarball), or depends on such a package, will be + -- built inplace into a shared dist dir. Tarball packages that depend on + -- source dir packages will also get unpacked locally. + shouldBuildInplaceOnly :: SolverPackage loc -> Bool + shouldBuildInplaceOnly pkg = + Set.member + (packageId pkg) + pkgsToBuildInplaceOnly + + pkgsToBuildInplaceOnly :: Set PackageId + pkgsToBuildInplaceOnly = + Set.fromList $ + map packageId $ + SolverInstallPlan.reverseDependencyClosure + solverPlan + (map PlannedId (Set.toList pkgsLocalToProject)) + + isLocalToProject :: Package pkg => pkg -> Bool + isLocalToProject pkg = + Set.member + (packageId pkg) + pkgsLocalToProject + + pkgsLocalToProject :: Set PackageId + pkgsLocalToProject = Set.fromList (catMaybes (map shouldBeLocal localPackages)) - --TODO: localPackages is a misnomer, it's all project packages - -- here is where we decide which ones will be local! + -- TODO: localPackages is a misnomer, it's all project packages + -- here is where we decide which ones will be local! - pkgsUseSharedLibrary :: Set PackageId - pkgsUseSharedLibrary = + pkgsUseSharedLibrary :: Set PackageId + pkgsUseSharedLibrary = packagesWithLibDepsDownwardClosedProperty needsSharedLib - where - needsSharedLib pkg = - fromMaybe compilerShouldUseSharedLibByDefault - (liftM2 (||) pkgSharedLib pkgDynExe) - where - pkgid = packageId pkg - pkgSharedLib = perPkgOptionMaybe pkgid packageConfigSharedLib - pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe - - --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 - GHCJS -> GHCJS.isDynamic compiler - _ -> False - - pkgsUseProfilingLibrary :: Set PackageId - pkgsUseProfilingLibrary = + where + needsSharedLib pkg = + fromMaybe + compilerShouldUseSharedLibByDefault + (liftM2 (||) pkgSharedLib pkgDynExe) + where + pkgid = packageId pkg + pkgSharedLib = perPkgOptionMaybe pkgid packageConfigSharedLib + pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe + + -- 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 + GHCJS -> GHCJS.isDynamic compiler + _ -> False + + pkgsUseProfilingLibrary :: Set PackageId + pkgsUseProfilingLibrary = packagesWithLibDepsDownwardClosedProperty needsProfilingLib - where - needsProfilingLib pkg = + where + needsProfilingLib pkg = fromFlagOrDefault False (profBothFlag <> profLibFlag) - where - pkgid = packageId pkg - profBothFlag = lookupPerPkgOption pkgid packageConfigProf - profLibFlag = lookupPerPkgOption pkgid packageConfigProfLib - --TODO: [code cleanup] unused: the old deprecated packageConfigProfExe - - libDepGraph = Graph.fromDistinctList $ - map NonSetupLibDepSolverPlanPackage - (SolverInstallPlan.toList solverPlan) - - packagesWithLibDepsDownwardClosedProperty property = + where + pkgid = packageId pkg + profBothFlag = lookupPerPkgOption pkgid packageConfigProf + profLibFlag = lookupPerPkgOption pkgid packageConfigProfLib + -- TODO: [code cleanup] unused: the old deprecated packageConfigProfExe + + libDepGraph = + Graph.fromDistinctList $ + map + NonSetupLibDepSolverPlanPackage + (SolverInstallPlan.toList solverPlan) + + packagesWithLibDepsDownwardClosedProperty property = Set.fromList - . map packageId - . fromMaybe [] - $ Graph.closure - libDepGraph - [ Graph.nodeKey pkg - | pkg <- SolverInstallPlan.toList solverPlan - , property 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 - -- package config validation/resolution pass. - - --TODO: [nice to have] config consistency checking: - -- + profiling libs & exes, exe needs lib, recursive - -- + shared libs & exes, exe needs lib, recursive - -- + vanilla libs & exes, exe needs lib, recursive - -- + ghci or shared lib needed by TH, recursive, ghc version dependent + . map packageId + . fromMaybe [] + $ Graph.closure + libDepGraph + [ Graph.nodeKey pkg + | pkg <- SolverInstallPlan.toList solverPlan + , property 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 + -- package config validation/resolution pass. + ] + +-- TODO: [nice to have] config consistency checking: +-- + profiling libs & exes, exe needs lib, recursive +-- + shared libs & exes, exe needs lib, recursive +-- + vanilla libs & exes, exe needs lib, recursive +-- + ghci or shared lib needed by TH, recursive, ghc version dependent -- TODO: Drop matchPlanPkg/matchElabPkg in favor of mkCCMapping shouldBeLocal :: PackageSpecifier (SourcePackage (PackageLocation loc)) -> Maybe PackageId -shouldBeLocal NamedPackage{} = Nothing +shouldBeLocal NamedPackage{} = Nothing shouldBeLocal (SpecificSourcePackage pkg) = case srcpkgSource pkg of - LocalUnpackedPackage _ -> Just (packageId pkg) - _ -> Nothing + LocalUnpackedPackage _ -> Just (packageId pkg) + _ -> Nothing -- | Given a 'ElaboratedPlanPackage', report if it matches a 'ComponentName'. matchPlanPkg :: (ComponentName -> Bool) -> ElaboratedPlanPackage -> Bool @@ -2140,69 +2429,84 @@ ipiComponentName = CLibName . IPI.sourceLibName -- 'ComponentName'. matchElabPkg :: (ComponentName -> Bool) -> ElaboratedConfiguredPackage -> Bool matchElabPkg p elab = - case elabPkgOrComp elab of - ElabComponent comp -> maybe False p (compComponentName comp) - ElabPackage _ -> - -- So, what should we do here? One possibility is to - -- unconditionally return 'True', because whatever it is - -- that we're looking for, it better be in this package. - -- But this is a bit dodgy if the package doesn't actually - -- have, e.g., a library. Fortunately, it's not possible - -- for the build of the library/executables to be toggled - -- by 'pkgStanzasEnabled', so the only thing we have to - -- test is if the component in question is *buildable.* - any (p . componentName) - (Cabal.pkgBuildableComponents (elabPkgDescription elab)) + case elabPkgOrComp elab of + ElabComponent comp -> maybe False p (compComponentName comp) + ElabPackage _ -> + -- So, what should we do here? One possibility is to + -- unconditionally return 'True', because whatever it is + -- that we're looking for, it better be in this package. + -- But this is a bit dodgy if the package doesn't actually + -- have, e.g., a library. Fortunately, it's not possible + -- for the build of the library/executables to be toggled + -- by 'pkgStanzasEnabled', so the only thing we have to + -- test is if the component in question is *buildable.* + any + (p . componentName) + (Cabal.pkgBuildableComponents (elabPkgDescription elab)) -- | Given an 'ElaboratedPlanPackage', generate the mapping from 'PackageName' -- and 'ComponentName' to the 'ComponentId' that should be used -- in this case. -mkCCMapping :: ElaboratedPlanPackage - -> (PackageName, Map ComponentName (AnnotatedId ComponentId)) +mkCCMapping + :: ElaboratedPlanPackage + -> (PackageName, Map ComponentName (AnnotatedId ComponentId)) mkCCMapping = - InstallPlan.foldPlanPackage - (\ipkg -> (packageName ipkg, - Map.singleton (ipiComponentName ipkg) - -- TODO: libify - (AnnotatedId { - ann_id = IPI.installedComponentId ipkg, - ann_pid = packageId ipkg, - ann_cname = IPI.sourceComponentName ipkg - }))) - $ \elab -> - let mk_aid cn = AnnotatedId { - ann_id = elabComponentId elab, - ann_pid = packageId elab, - ann_cname = cn - } - in (packageName elab, - case elabPkgOrComp elab of - ElabComponent comp -> - case compComponentName comp of - Nothing -> Map.empty - Just n -> Map.singleton n (mk_aid n) - ElabPackage _ -> - Map.fromList $ - map (\comp -> let cn = Cabal.componentName comp in (cn, mk_aid cn)) - (Cabal.pkgBuildableComponents (elabPkgDescription elab))) + InstallPlan.foldPlanPackage + ( \ipkg -> + ( packageName ipkg + , Map.singleton + (ipiComponentName ipkg) + -- TODO: libify + ( AnnotatedId + { ann_id = IPI.installedComponentId ipkg + , ann_pid = packageId ipkg + , ann_cname = IPI.sourceComponentName ipkg + } + ) + ) + ) + $ \elab -> + let mk_aid cn = + AnnotatedId + { ann_id = elabComponentId elab + , ann_pid = packageId elab + , ann_cname = cn + } + in ( packageName elab + , case elabPkgOrComp elab of + ElabComponent comp -> + case compComponentName comp of + Nothing -> Map.empty + Just n -> Map.singleton n (mk_aid n) + ElabPackage _ -> + Map.fromList $ + map + (\comp -> let cn = Cabal.componentName comp in (cn, mk_aid cn)) + (Cabal.pkgBuildableComponents (elabPkgDescription elab)) + ) -- | Given an 'ElaboratedPlanPackage', generate the mapping from 'ComponentId' -- to the shape of this package, as per mix-in linking. -mkShapeMapping :: ElaboratedPlanPackage - -> (ComponentId, (OpenUnitId, ModuleShape)) +mkShapeMapping + :: ElaboratedPlanPackage + -> (ComponentId, (OpenUnitId, ModuleShape)) mkShapeMapping dpkg = - (getComponentId dpkg, (indef_uid, shape)) + (getComponentId dpkg, (indef_uid, shape)) where (dcid, shape) = - InstallPlan.foldPlanPackage - -- Uses Monad (->) - (liftM2 (,) IPI.installedComponentId shapeInstalledPackage) - (liftM2 (,) elabComponentId elabModuleShape) - dpkg + InstallPlan.foldPlanPackage + -- Uses Monad (->) + (liftM2 (,) IPI.installedComponentId shapeInstalledPackage) + (liftM2 (,) elabComponentId elabModuleShape) + dpkg indef_uid = - IndefFullUnitId dcid - (Map.fromList [ (req, OpenModuleVar req) - | req <- Set.toList (modShapeRequires shape)]) + IndefFullUnitId + dcid + ( Map.fromList + [ (req, OpenModuleVar req) + | req <- Set.toList (modShapeRequires shape) + ] + ) -- | Get the bin\/ directories that a package's executables should reside in. -- @@ -2220,47 +2524,50 @@ binDirectories layout config package = case elabBuildStyle package of -- to put any executables in it, that will just clog up the PATH _ | noExecutables -> [] BuildAndInstall -> [installedBinDirectory package] - BuildInplaceOnly -> map (root) $ case elabPkgOrComp package of + BuildInplaceOnly -> map (root ) $ case elabPkgOrComp package of ElabComponent comp -> case compSolverName comp of CD.ComponentExe n -> [prettyShow n] _ -> [] - ElabPackage _ -> map (prettyShow . PD.exeName) - . PD.executables - . elabPkgDescription - $ package + ElabPackage _ -> + map (prettyShow . PD.exeName) + . PD.executables + . elabPkgDescription + $ package where - noExecutables = null . PD.executables . elabPkgDescription $ package - root = distBuildDirectory layout (elabDistDirParams config package) - "build" + noExecutables = null . PD.executables . elabPkgDescription $ package + root = + distBuildDirectory layout (elabDistDirParams config package) + "build" -- | A newtype for 'SolverInstallPlan.SolverPlanPackage' for which the -- dependency graph considers only dependencies on libraries which are -- NOT from setup dependencies. Used to compute the set -- of packages needed for profiling and dynamic libraries. -newtype NonSetupLibDepSolverPlanPackage - = NonSetupLibDepSolverPlanPackage - { unNonSetupLibDepSolverPlanPackage :: SolverInstallPlan.SolverPlanPackage } +newtype NonSetupLibDepSolverPlanPackage = NonSetupLibDepSolverPlanPackage + {unNonSetupLibDepSolverPlanPackage :: SolverInstallPlan.SolverPlanPackage} instance Package NonSetupLibDepSolverPlanPackage where - packageId = packageId . unNonSetupLibDepSolverPlanPackage + packageId = packageId . unNonSetupLibDepSolverPlanPackage instance IsNode NonSetupLibDepSolverPlanPackage where - type Key NonSetupLibDepSolverPlanPackage = SolverId - nodeKey = nodeKey . unNonSetupLibDepSolverPlanPackage - nodeNeighbors (NonSetupLibDepSolverPlanPackage spkg) - = ordNub $ CD.nonSetupDeps (resolverPackageLibDeps spkg) + type Key NonSetupLibDepSolverPlanPackage = SolverId + nodeKey = nodeKey . unNonSetupLibDepSolverPlanPackage + nodeNeighbors (NonSetupLibDepSolverPlanPackage spkg) = + ordNub $ CD.nonSetupDeps (resolverPackageLibDeps spkg) type InstS = Map UnitId ElaboratedPlanPackage type InstM a = State InstS a -getComponentId :: ElaboratedPlanPackage - -> ComponentId +getComponentId + :: ElaboratedPlanPackage + -> ComponentId getComponentId (InstallPlan.PreExisting dipkg) = IPI.installedComponentId dipkg getComponentId (InstallPlan.Configured elab) = elabComponentId elab getComponentId (InstallPlan.Installed elab) = elabComponentId elab -extractElabBuildStyle :: InstallPlan.GenericPlanPackage ipkg ElaboratedConfiguredPackage - -> BuildStyle +extractElabBuildStyle + :: InstallPlan.GenericPlanPackage ipkg ElaboratedConfiguredPackage + -> BuildStyle extractElabBuildStyle (InstallPlan.Configured elab) = elabBuildStyle elab extractElabBuildStyle _ = BuildAndInstall @@ -2310,25 +2617,30 @@ extractElabBuildStyle _ = BuildAndInstall -- instantiateInstallPlan :: StoreDirLayout -> InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedInstallPlan instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = - InstallPlan.new (IndependentGoals False) - (Graph.fromDistinctList (Map.elems ready_map)) + InstallPlan.new + (IndependentGoals False) + (Graph.fromDistinctList (Map.elems ready_map)) where pkgs = InstallPlan.toList plan - cmap = Map.fromList [ (getComponentId pkg, pkg) | pkg <- pkgs ] + cmap = Map.fromList [(getComponentId pkg, pkg) | pkg <- pkgs] - instantiateUnitId :: ComponentId -> Map ModuleName (Module, BuildStyle) - -> InstM (DefUnitId, BuildStyle) + instantiateUnitId + :: ComponentId + -> Map ModuleName (Module, BuildStyle) + -> InstM (DefUnitId, BuildStyle) instantiateUnitId cid insts = state $ \s -> - case Map.lookup uid s of - Nothing -> - -- Knot tied - -- TODO: I don't think the knot tying actually does - -- anything useful - let (r, s') = runState (instantiateComponent uid cid insts) - (Map.insert uid r s) - in ((def_uid, extractElabBuildStyle r), Map.insert uid r s') - Just r -> ((def_uid, extractElabBuildStyle r), s) + case Map.lookup uid s of + Nothing -> + -- Knot tied + -- TODO: I don't think the knot tying actually does + -- anything useful + let (r, s') = + runState + (instantiateComponent uid cid insts) + (Map.insert uid r s) + in ((def_uid, extractElabBuildStyle r), Map.insert uid r s') + Just r -> ((def_uid, extractElabBuildStyle r), s) where def_uid = mkDefUnitId cid (fmap fst insts) uid = unDefUnitId def_uid @@ -2336,133 +2648,156 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = -- No need to InplaceT; the inplace-ness is properly computed for -- the ElaboratedPlanPackage, so that will implicitly pass it on instantiateComponent - :: UnitId -> ComponentId -> Map ModuleName (Module, BuildStyle) - -> InstM ElaboratedPlanPackage + :: UnitId + -> ComponentId + -> Map ModuleName (Module, BuildStyle) + -> InstM ElaboratedPlanPackage instantiateComponent uid cid insts - | Just planpkg <- Map.lookup cid cmap - = case planpkg of - InstallPlan.Configured (elab0@ElaboratedConfiguredPackage - { elabPkgOrComp = ElabComponent comp }) -> do - deps <- - traverse (fmap fst . substUnitId insts) (compLinkedLibDependencies comp) - let build_style = fold (fmap snd insts) - let getDep (Module dep_uid _) = [dep_uid] - elab1 = fixupBuildStyle build_style $ elab0 { - elabUnitId = uid, - elabComponentId = cid, - elabInstantiatedWith = fmap fst insts, - elabIsCanonical = Map.null (fmap fst insts), - elabPkgOrComp = ElabComponent comp { - compOrderLibDependencies = - (if Map.null insts then [] else [newSimpleUnitId cid]) ++ - ordNub (map unDefUnitId - (deps ++ concatMap (getDep . fst) (Map.elems insts))) - } + | Just planpkg <- Map.lookup cid cmap = + case planpkg of + InstallPlan.Configured + ( elab0@ElaboratedConfiguredPackage + { elabPkgOrComp = ElabComponent comp } - elab = elab1 { - elabInstallDirs = computeInstallDirs storeDirLayout - defaultInstallDirs - elaboratedShared - elab1 - } - return $ InstallPlan.Configured elab - _ -> return planpkg + ) -> do + deps <- + traverse (fmap fst . substUnitId insts) (compLinkedLibDependencies comp) + let build_style = fold (fmap snd insts) + let getDep (Module dep_uid _) = [dep_uid] + elab1 = + fixupBuildStyle build_style $ + elab0 + { elabUnitId = uid + , elabComponentId = cid + , elabInstantiatedWith = fmap fst insts + , elabIsCanonical = Map.null (fmap fst insts) + , elabPkgOrComp = + ElabComponent + comp + { compOrderLibDependencies = + (if Map.null insts then [] else [newSimpleUnitId cid]) + ++ ordNub + ( map + unDefUnitId + (deps ++ concatMap (getDep . fst) (Map.elems insts)) + ) + } + } + elab = + elab1 + { elabInstallDirs = + computeInstallDirs + storeDirLayout + defaultInstallDirs + elaboratedShared + elab1 + } + return $ InstallPlan.Configured elab + _ -> return planpkg | otherwise = error ("instantiateComponent: " ++ prettyShow cid) substUnitId :: Map ModuleName (Module, BuildStyle) -> OpenUnitId -> InstM (DefUnitId, BuildStyle) substUnitId _ (DefiniteUnitId uid) = - -- This COULD actually, secretly, be an inplace package, but in - -- that case it doesn't matter as it's already been recorded - -- in the package that depends on this - return (uid, BuildAndInstall) + -- This COULD actually, secretly, be an inplace package, but in + -- that case it doesn't matter as it's already been recorded + -- in the package that depends on this + return (uid, BuildAndInstall) substUnitId subst (IndefFullUnitId cid insts) = do - insts' <- substSubst subst insts - instantiateUnitId cid insts' + insts' <- substSubst subst insts + instantiateUnitId cid insts' -- NB: NOT composition - substSubst :: Map ModuleName (Module, BuildStyle) - -> Map ModuleName OpenModule - -> InstM (Map ModuleName (Module, BuildStyle)) + substSubst + :: Map ModuleName (Module, BuildStyle) + -> Map ModuleName OpenModule + -> InstM (Map ModuleName (Module, BuildStyle)) substSubst subst insts = traverse (substModule subst) insts substModule :: Map ModuleName (Module, BuildStyle) -> OpenModule -> InstM (Module, BuildStyle) substModule subst (OpenModuleVar mod_name) - | Just m <- Map.lookup mod_name subst = return m - | otherwise = error "substModule: non-closing substitution" + | Just m <- Map.lookup mod_name subst = return m + | otherwise = error "substModule: non-closing substitution" substModule subst (OpenModule uid mod_name) = do - (uid', build_style) <- substUnitId subst uid - return (Module uid' mod_name, build_style) + (uid', build_style) <- substUnitId subst uid + return (Module uid' mod_name, build_style) indefiniteUnitId :: ComponentId -> InstM UnitId indefiniteUnitId cid = do - let uid = newSimpleUnitId cid - r <- indefiniteComponent uid cid - state $ \s -> (uid, Map.insert uid r s) + let uid = newSimpleUnitId cid + r <- indefiniteComponent uid cid + state $ \s -> (uid, Map.insert uid r s) indefiniteComponent :: UnitId -> ComponentId -> InstM ElaboratedPlanPackage indefiniteComponent _uid cid -- Only need Configured; this phase happens before improvement, so -- there shouldn't be any Installed packages here. | Just (InstallPlan.Configured epkg) <- Map.lookup cid cmap - , ElabComponent elab_comp <- elabPkgOrComp epkg - = do -- We need to do a little more processing of the includes: some - -- of them are fully definite even without substitution. We - -- want to build those too; see #5634. - -- - -- This code mimics similar code in Distribution.Backpack.ReadyComponent; - -- however, unlike the conversion from LinkedComponent to - -- ReadyComponent, this transformation is done *without* - -- changing the type in question; and what we are simply - -- doing is enforcing tighter invariants on the data - -- structure in question. The new invariant is that there - -- is no IndefFullUnitId in compLinkedLibDependencies that actually - -- has no holes. We couldn't specify this invariant when - -- we initially created the ElaboratedPlanPackage because - -- we have no way of actually reifying the UnitId into a - -- DefiniteUnitId (that's what substUnitId does!) - new_deps <- for (compLinkedLibDependencies elab_comp) $ \uid -> - if Set.null (openUnitIdFreeHoles uid) + , ElabComponent elab_comp <- elabPkgOrComp epkg = + do + -- We need to do a little more processing of the includes: some + -- of them are fully definite even without substitution. We + -- want to build those too; see #5634. + -- + -- This code mimics similar code in Distribution.Backpack.ReadyComponent; + -- however, unlike the conversion from LinkedComponent to + -- ReadyComponent, this transformation is done *without* + -- changing the type in question; and what we are simply + -- doing is enforcing tighter invariants on the data + -- structure in question. The new invariant is that there + -- is no IndefFullUnitId in compLinkedLibDependencies that actually + -- has no holes. We couldn't specify this invariant when + -- we initially created the ElaboratedPlanPackage because + -- we have no way of actually reifying the UnitId into a + -- DefiniteUnitId (that's what substUnitId does!) + new_deps <- for (compLinkedLibDependencies elab_comp) $ \uid -> + if Set.null (openUnitIdFreeHoles uid) then fmap (DefiniteUnitId . fst) (substUnitId Map.empty uid) else return uid - -- NB: no fixupBuildStyle needed here, as if the indefinite - -- component depends on any inplace packages, it itself must - -- be indefinite! There is no substitution here, we can't - -- post facto add inplace deps - return . InstallPlan.Configured $ epkg { - elabPkgOrComp = ElabComponent elab_comp { - compLinkedLibDependencies = new_deps, - -- I think this is right: any new definite unit ids we - -- minted in the phase above need to be built before us. - -- Add 'em in. This doesn't remove any old dependencies - -- on the indefinite package; they're harmless. - compOrderLibDependencies = - ordNub $ compOrderLibDependencies elab_comp ++ - [unDefUnitId d | DefiniteUnitId d <- new_deps] - } - } - | Just planpkg <- Map.lookup cid cmap - = return planpkg + -- NB: no fixupBuildStyle needed here, as if the indefinite + -- component depends on any inplace packages, it itself must + -- be indefinite! There is no substitution here, we can't + -- post facto add inplace deps + return . InstallPlan.Configured $ + epkg + { elabPkgOrComp = + ElabComponent + elab_comp + { compLinkedLibDependencies = new_deps + , -- I think this is right: any new definite unit ids we + -- minted in the phase above need to be built before us. + -- Add 'em in. This doesn't remove any old dependencies + -- on the indefinite package; they're harmless. + compOrderLibDependencies = + ordNub $ + compOrderLibDependencies elab_comp + ++ [unDefUnitId d | DefiniteUnitId d <- new_deps] + } + } + | Just planpkg <- Map.lookup cid cmap = + return planpkg | otherwise = error ("indefiniteComponent: " ++ prettyShow cid) fixupBuildStyle BuildAndInstall elab = elab - fixupBuildStyle _ (elab@ElaboratedConfiguredPackage { elabBuildStyle = BuildInplaceOnly }) = elab - fixupBuildStyle BuildInplaceOnly elab = elab { - elabBuildStyle = BuildInplaceOnly, - elabBuildPackageDBStack = elabInplaceBuildPackageDBStack elab, - elabRegisterPackageDBStack = elabInplaceRegisterPackageDBStack elab, - elabSetupPackageDBStack = elabInplaceSetupPackageDBStack elab - } + fixupBuildStyle _ (elab@ElaboratedConfiguredPackage{elabBuildStyle = BuildInplaceOnly}) = elab + fixupBuildStyle BuildInplaceOnly elab = + elab + { elabBuildStyle = BuildInplaceOnly + , elabBuildPackageDBStack = elabInplaceBuildPackageDBStack elab + , elabRegisterPackageDBStack = elabInplaceRegisterPackageDBStack elab + , elabSetupPackageDBStack = elabInplaceSetupPackageDBStack elab + } ready_map = execState work Map.empty work = for_ pkgs $ \pkg -> - case pkg of - InstallPlan.Configured elab - | not (Map.null (elabLinkedInstantiatedWith elab)) - -> indefiniteUnitId (elabComponentId elab) - >> return () - _ -> instantiateUnitId (getComponentId pkg) Map.empty - >> return () + case pkg of + InstallPlan.Configured elab + | not (Map.null (elabLinkedInstantiatedWith elab)) -> + indefiniteUnitId (elabComponentId elab) + >> return () + _ -> + instantiateUnitId (getComponentId pkg) Map.empty + >> return () --------------------------- -- Build targets @@ -2506,35 +2841,39 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = -- forcing them to return the @k@ value for the selected targets). -- In particular 'resolveTargets' makes use of this (with @k@ as -- @('UnitId', ComponentName')@) to identify the targets thus selected. --- -data AvailableTarget k = AvailableTarget { - availableTargetPackageId :: PackageId, - availableTargetComponentName :: ComponentName, - availableTargetStatus :: AvailableTargetStatus k, - availableTargetLocalToProject :: Bool - } +data AvailableTarget k = AvailableTarget + { availableTargetPackageId :: PackageId + , availableTargetComponentName :: ComponentName + , availableTargetStatus :: AvailableTargetStatus k + , availableTargetLocalToProject :: Bool + } deriving (Eq, Show, Functor) -- | The status of a an 'AvailableTarget' component. This tells us whether -- it's actually possible to select this component to be built, and if not -- why not. --- -data AvailableTargetStatus k = - TargetDisabledByUser -- ^ When the user does @tests: False@ - | TargetDisabledBySolver -- ^ When the solver could not enable tests - | TargetNotBuildable -- ^ When the component has @buildable: False@ - | TargetNotLocal -- ^ When the component is non-core in a non-local package - | TargetBuildable k TargetRequested -- ^ The target can or should be built +data AvailableTargetStatus k + = -- | When the user does @tests: False@ + TargetDisabledByUser + | -- | When the solver could not enable tests + TargetDisabledBySolver + | -- | When the component has @buildable: False@ + TargetNotBuildable + | -- | When the component is non-core in a non-local package + TargetNotLocal + | -- | The target can or should be built + TargetBuildable k TargetRequested deriving (Eq, Ord, Show, Functor) -- | This tells us whether a target ought to be built by default, or only if -- specifically requested. The policy is that components like libraries and -- executables are built by default by @build@, but test suites and benchmarks -- are not, unless this is overridden in the project configuration. --- -data TargetRequested = - TargetRequestedByDefault -- ^ To be built by default - | TargetNotRequestedByDefault -- ^ Not to be built by default +data TargetRequested + = -- | To be built by default + TargetRequestedByDefault + | -- | Not to be built by default + TargetNotRequestedByDefault deriving (Eq, Ord, Show) -- | Given the install plan, produce the set of 'AvailableTarget's for each @@ -2546,145 +2885,172 @@ data TargetRequested = -- had a plan that contained two instances of the same version of a package. -- This approach makes it relatively easy to select all instances\/variants -- of a component. --- -availableTargets :: ElaboratedInstallPlan - -> Map (PackageId, ComponentName) - [AvailableTarget (UnitId, ComponentName)] +availableTargets + :: ElaboratedInstallPlan + -> Map + (PackageId, ComponentName) + [AvailableTarget (UnitId, ComponentName)] availableTargets installPlan = - let rs = [ (pkgid, cname, fake, target) - | pkg <- InstallPlan.toList installPlan - , (pkgid, cname, fake, target) <- case pkg of - InstallPlan.PreExisting ipkg -> availableInstalledTargets ipkg - InstallPlan.Installed elab -> availableSourceTargets elab - InstallPlan.Configured elab -> availableSourceTargets elab - ] - in Map.union - (Map.fromListWith (++) + let rs = + [ (pkgid, cname, fake, target) + | pkg <- InstallPlan.toList installPlan + , (pkgid, cname, fake, target) <- case pkg of + InstallPlan.PreExisting ipkg -> availableInstalledTargets ipkg + InstallPlan.Installed elab -> availableSourceTargets elab + InstallPlan.Configured elab -> availableSourceTargets elab + ] + in Map.union + ( Map.fromListWith + (++) [ ((pkgid, cname), [target]) - | (pkgid, cname, fake, target) <- rs, not fake]) - (Map.fromList + | (pkgid, cname, fake, target) <- rs + , not fake + ] + ) + ( Map.fromList [ ((pkgid, cname), [target]) - | (pkgid, cname, fake, target) <- rs, fake]) - -- The normal targets mask the fake ones. We get all instances of the - -- normal ones and only one copy of the fake ones (as there are many - -- duplicates of the fake ones). See 'availableSourceTargets' below for - -- more details on this fake stuff is about. - -availableInstalledTargets :: IPI.InstalledPackageInfo - -> [(PackageId, ComponentName, Bool, - AvailableTarget (UnitId, ComponentName))] + | (pkgid, cname, fake, target) <- rs + , fake + ] + ) + +-- The normal targets mask the fake ones. We get all instances of the +-- normal ones and only one copy of the fake ones (as there are many +-- duplicates of the fake ones). See 'availableSourceTargets' below for +-- more details on this fake stuff is about. + +availableInstalledTargets + :: IPI.InstalledPackageInfo + -> [ ( PackageId + , ComponentName + , Bool + , AvailableTarget (UnitId, ComponentName) + ) + ] availableInstalledTargets ipkg = - let unitid = installedUnitId ipkg - cname = CLibName LMainLibName - status = TargetBuildable (unitid, cname) TargetRequestedByDefault - target = AvailableTarget (packageId ipkg) cname status False - fake = False - in [(packageId ipkg, cname, fake, target)] - -availableSourceTargets :: ElaboratedConfiguredPackage - -> [(PackageId, ComponentName, Bool, - AvailableTarget (UnitId, ComponentName))] + let unitid = installedUnitId ipkg + cname = CLibName LMainLibName + status = TargetBuildable (unitid, cname) TargetRequestedByDefault + target = AvailableTarget (packageId ipkg) cname status False + fake = False + in [(packageId ipkg, cname, fake, target)] + +availableSourceTargets + :: ElaboratedConfiguredPackage + -> [ ( PackageId + , ComponentName + , Bool + , AvailableTarget (UnitId, ComponentName) + ) + ] availableSourceTargets elab = - -- We have a somewhat awkward problem here. We need to know /all/ the - -- components from /all/ the packages because these are the things that - -- users could refer to. Unfortunately, at this stage the elaborated install - -- plan does /not/ contain all components: some components have already - -- been deleted because they cannot possibly be built. This is the case - -- for components that are marked @buildable: False@ in their .cabal files. - -- (It's not unreasonable that the unbuildable components have been pruned - -- as the plan invariant is considerably simpler if all nodes can be built) - -- - -- We can recover the missing components but it's not exactly elegant. For - -- a graph node corresponding to a component we still have the information - -- about the package that it came from, and this includes the names of - -- /all/ the other components in the package. So in principle this lets us - -- find the names of all components, plus full details of the buildable - -- components. - -- - -- Consider for example a package with 3 exe components: foo, bar and baz - -- where foo and bar are buildable, but baz is not. So the plan contains - -- nodes for the components foo and bar. Now we look at each of these two - -- nodes and look at the package they come from and the names of the - -- components in this package. This will give us the names foo, bar and - -- baz, twice (once for each of the two buildable components foo and bar). - -- - -- We refer to these reconstructed missing components as fake targets. - -- It is an invariant that they are not available to be built. - -- - -- To produce the final set of targets we put the fake targets in a finite - -- map (thus eliminating the duplicates) and then we overlay that map with - -- the normal buildable targets. (This is done above in 'availableTargets'.) - -- - [ (packageId elab, cname, fake, target) - | component <- pkgComponents (elabPkgDescription elab) - , let cname = componentName component - status = componentAvailableTargetStatus component - target = AvailableTarget { - availableTargetPackageId = packageId elab, - availableTargetComponentName = cname, - availableTargetStatus = status, - availableTargetLocalToProject = elabLocalToProject elab - } - fake = isFakeTarget cname - - -- TODO: The goal of this test is to exclude "instantiated" - -- packages as available targets. This means that you can't - -- ask for a particular instantiated component to be built; - -- it will only get built by a dependency. Perhaps the - -- correct way to implement this is to run selection - -- prior to instantiating packages. If you refactor - -- this, then you can delete this test. - , elabIsCanonical elab - - -- Filter out some bogus parts of the cross product that are never needed - , case status of - TargetBuildable{} | fake -> False - _ -> True - ] + -- We have a somewhat awkward problem here. We need to know /all/ the + -- components from /all/ the packages because these are the things that + -- users could refer to. Unfortunately, at this stage the elaborated install + -- plan does /not/ contain all components: some components have already + -- been deleted because they cannot possibly be built. This is the case + -- for components that are marked @buildable: False@ in their .cabal files. + -- (It's not unreasonable that the unbuildable components have been pruned + -- as the plan invariant is considerably simpler if all nodes can be built) + -- + -- We can recover the missing components but it's not exactly elegant. For + -- a graph node corresponding to a component we still have the information + -- about the package that it came from, and this includes the names of + -- /all/ the other components in the package. So in principle this lets us + -- find the names of all components, plus full details of the buildable + -- components. + -- + -- Consider for example a package with 3 exe components: foo, bar and baz + -- where foo and bar are buildable, but baz is not. So the plan contains + -- nodes for the components foo and bar. Now we look at each of these two + -- nodes and look at the package they come from and the names of the + -- components in this package. This will give us the names foo, bar and + -- baz, twice (once for each of the two buildable components foo and bar). + -- + -- We refer to these reconstructed missing components as fake targets. + -- It is an invariant that they are not available to be built. + -- + -- To produce the final set of targets we put the fake targets in a finite + -- map (thus eliminating the duplicates) and then we overlay that map with + -- the normal buildable targets. (This is done above in 'availableTargets'.) + -- + [ (packageId elab, cname, fake, target) + | component <- pkgComponents (elabPkgDescription elab) + , let cname = componentName component + status = componentAvailableTargetStatus component + target = + AvailableTarget + { availableTargetPackageId = packageId elab + , availableTargetComponentName = cname + , availableTargetStatus = status + , availableTargetLocalToProject = elabLocalToProject elab + } + fake = isFakeTarget cname + , -- TODO: The goal of this test is to exclude "instantiated" + -- packages as available targets. This means that you can't + -- ask for a particular instantiated component to be built; + -- it will only get built by a dependency. Perhaps the + -- correct way to implement this is to run selection + -- prior to instantiating packages. If you refactor + -- this, then you can delete this test. + elabIsCanonical elab + , -- Filter out some bogus parts of the cross product that are never needed + case status of + TargetBuildable{} | fake -> False + _ -> True + ] where isFakeTarget cname = case elabPkgOrComp elab of - ElabPackage _ -> False - ElabComponent elabComponent -> compComponentName elabComponent - /= Just cname + ElabPackage _ -> False + ElabComponent elabComponent -> + compComponentName elabComponent + /= Just cname componentAvailableTargetStatus :: Component -> AvailableTargetStatus (UnitId, ComponentName) componentAvailableTargetStatus component = - case componentOptionalStanza $ CD.componentNameToComponent cname of - -- it is not an optional stanza, so a library, exe or foreign lib - Nothing - | not buildable -> TargetNotBuildable - | otherwise -> TargetBuildable (elabUnitId elab, cname) - TargetRequestedByDefault - - -- it is not an optional stanza, so a testsuite or benchmark - Just stanza -> - case (optStanzaLookup stanza (elabStanzasRequested elab), -- TODO - optStanzaSetMember stanza (elabStanzasAvailable elab)) of - _ | not withinPlan -> TargetNotLocal - (Just False, _) -> TargetDisabledByUser - (Nothing, False) -> TargetDisabledBySolver - _ | not buildable -> TargetNotBuildable - (Just True, True) -> TargetBuildable (elabUnitId elab, cname) - TargetRequestedByDefault - (Nothing, True) -> TargetBuildable (elabUnitId elab, cname) - TargetNotRequestedByDefault - (Just True, False) -> - error $ "componentAvailableTargetStatus: impossible; cname=" ++ prettyShow cname + case componentOptionalStanza $ CD.componentNameToComponent cname of + -- it is not an optional stanza, so a library, exe or foreign lib + Nothing + | not buildable -> TargetNotBuildable + | otherwise -> + TargetBuildable + (elabUnitId elab, cname) + TargetRequestedByDefault + -- it is not an optional stanza, so a testsuite or benchmark + Just stanza -> + case ( optStanzaLookup stanza (elabStanzasRequested elab) -- TODO + , optStanzaSetMember stanza (elabStanzasAvailable elab) + ) of + _ | not withinPlan -> TargetNotLocal + (Just False, _) -> TargetDisabledByUser + (Nothing, False) -> TargetDisabledBySolver + _ | not buildable -> TargetNotBuildable + (Just True, True) -> + TargetBuildable + (elabUnitId elab, cname) + TargetRequestedByDefault + (Nothing, True) -> + TargetBuildable + (elabUnitId elab, cname) + TargetNotRequestedByDefault + (Just True, False) -> + error $ "componentAvailableTargetStatus: impossible; cname=" ++ prettyShow cname where - cname = componentName component - buildable = PD.buildable (componentBuildInfo component) - withinPlan = elabLocalToProject elab - || case elabPkgOrComp elab of - ElabComponent elabComponent -> - compComponentName elabComponent == Just cname - ElabPackage _ -> - case componentName component of - CLibName (LMainLibName) -> True - CExeName _ -> True - --TODO: what about sub-libs and foreign libs? - _ -> False + cname = componentName component + buildable = PD.buildable (componentBuildInfo component) + withinPlan = + elabLocalToProject elab + || case elabPkgOrComp elab of + ElabComponent elabComponent -> + compComponentName elabComponent == Just cname + ElabPackage _ -> + case componentName component of + CLibName (LMainLibName) -> True + CExeName _ -> True + -- TODO: what about sub-libs and foreign libs? + _ -> False -- | Merge component targets that overlap each other. Specially when we have -- multiple targets for the same component and one of them refers to the whole @@ -2693,78 +3059,80 @@ availableSourceTargets elab = -- -- We also allow for information associated with each component target, and -- whenever we targets subsume each other we aggregate their associated info. --- nubComponentTargets :: [(ComponentTarget, a)] -> [(ComponentTarget, NonEmpty a)] nubComponentTargets = - concatMap (wholeComponentOverrides . map snd) - . groupBy ((==) `on` fst) - . sortBy (compare `on` fst) - . map (\t@((ComponentTarget cname _, _)) -> (cname, t)) - . map compatSubComponentTargets + concatMap (wholeComponentOverrides . map snd) + . groupBy ((==) `on` fst) + . sortBy (compare `on` fst) + . map (\t@((ComponentTarget cname _, _)) -> (cname, t)) + . map compatSubComponentTargets where -- If we're building the whole component then that the only target all we -- need, otherwise we can have several targets within the component. - wholeComponentOverrides :: [(ComponentTarget, a )] - -> [(ComponentTarget, NonEmpty a)] + wholeComponentOverrides + :: [(ComponentTarget, a)] + -> [(ComponentTarget, NonEmpty a)] wholeComponentOverrides ts = - case [ ta | ta@(ComponentTarget _ WholeComponent, _) <- ts ] of - ((t, x):_) -> - let - -- Delete tuple (t, x) from original list to avoid duplicates. - -- Use 'deleteBy', to avoid additional Class constraint on 'nubComponentTargets'. - ts' = deleteBy (\(t1, _) (t2, _) -> t1 == t2) (t, x) ts - in - [ (t, x :| map snd ts') ] - [] -> [ (t, x :| []) | (t,x) <- ts ] + case [ta | ta@(ComponentTarget _ WholeComponent, _) <- ts] of + ((t, x) : _) -> + let + -- Delete tuple (t, x) from original list to avoid duplicates. + -- Use 'deleteBy', to avoid additional Class constraint on 'nubComponentTargets'. + ts' = deleteBy (\(t1, _) (t2, _) -> t1 == t2) (t, x) ts + in + [(t, x :| map snd ts')] + [] -> [(t, x :| []) | (t, x) <- ts] -- Not all Cabal Setup.hs versions support sub-component targets, so switch -- them over to the whole component compatSubComponentTargets :: (ComponentTarget, a) -> (ComponentTarget, a) compatSubComponentTargets target@(ComponentTarget cname _subtarget, x) - | not setupHsSupportsSubComponentTargets - = (ComponentTarget cname WholeComponent, x) + | not setupHsSupportsSubComponentTargets = + (ComponentTarget cname WholeComponent, x) | otherwise = target -- Actually the reality is that no current version of Cabal's Setup.hs -- build command actually support building specific files or modules. setupHsSupportsSubComponentTargets = False - -- TODO: when that changes, adjust this test, e.g. - -- | pkgSetupScriptCliVersion >= Version [x,y] [] + +-- TODO: when that changes, adjust this test, e.g. +-- \| pkgSetupScriptCliVersion >= Version [x,y] [] pkgHasEphemeralBuildTargets :: ElaboratedConfiguredPackage -> Bool pkgHasEphemeralBuildTargets elab = - isJust (elabReplTarget elab) - || (not . null) (elabTestTargets elab) - || (not . null) (elabBenchTargets elab) - || (not . null) (elabHaddockTargets elab) - || (not . null) [ () | ComponentTarget _ subtarget <- elabBuildTargets elab - , subtarget /= WholeComponent ] + isJust (elabReplTarget elab) + || (not . null) (elabTestTargets elab) + || (not . null) (elabBenchTargets elab) + || (not . null) (elabHaddockTargets elab) + || (not . null) + [ () | ComponentTarget _ subtarget <- elabBuildTargets elab, subtarget /= WholeComponent + ] -- | The components that we'll build all of, meaning that after they're built -- we can skip building them again (unlike with building just some modules or -- other files within a component). --- -elabBuildTargetWholeComponents :: ElaboratedConfiguredPackage - -> Set ComponentName +elabBuildTargetWholeComponents + :: ElaboratedConfiguredPackage + -> Set ComponentName elabBuildTargetWholeComponents elab = - Set.fromList - [ cname | ComponentTarget cname WholeComponent <- elabBuildTargets elab ] - - + Set.fromList + [cname | ComponentTarget cname WholeComponent <- elabBuildTargets elab] ------------------------------------------------------------------------------ + -- * Install plan pruning + ------------------------------------------------------------------------------ -- | How 'pruneInstallPlanToTargets' should interpret the per-package -- 'ComponentTarget's: as build, repl or haddock targets. --- -data TargetAction = TargetActionConfigure - | TargetActionBuild - | TargetActionRepl - | TargetActionTest - | TargetActionBench - | TargetActionHaddock +data TargetAction + = TargetActionConfigure + | TargetActionBuild + | TargetActionRepl + | TargetActionTest + | TargetActionBench + | TargetActionHaddock -- | Given a set of per-package\/per-component targets, take the subset of the -- install plan needed to build those targets. Also, update the package config @@ -2774,20 +3142,21 @@ data TargetAction = TargetActionConfigure -- NB: Pruning happens after improvement, which is important because we -- will prune differently depending on what is already installed (to -- implement "sticky" test suite enabling behavior). --- -pruneInstallPlanToTargets :: TargetAction - -> Map UnitId [ComponentTarget] - -> ElaboratedInstallPlan -> ElaboratedInstallPlan +pruneInstallPlanToTargets + :: TargetAction + -> Map UnitId [ComponentTarget] + -> ElaboratedInstallPlan + -> ElaboratedInstallPlan pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan = - InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan) - . Graph.fromDistinctList + InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan) + . Graph.fromDistinctList -- We have to do the pruning in two passes - . pruneInstallPlanPass2 - . pruneInstallPlanPass1 + . pruneInstallPlanPass2 + . pruneInstallPlanPass1 -- Set the targets that will be the roots for pruning - . setRootTargets targetActionType perPkgTargetsMap - . InstallPlan.toList - $ elaboratedPlan + . setRootTargets targetActionType perPkgTargetsMap + . InstallPlan.toList + $ elaboratedPlan -- | This is a temporary data type, where we temporarily -- override the graph dependencies of an 'ElaboratedPackage', @@ -2799,59 +3168,68 @@ pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan = data PrunedPackage = PrunedPackage ElaboratedConfiguredPackage [UnitId] instance Package PrunedPackage where - packageId (PrunedPackage elab _) = packageId elab + packageId (PrunedPackage elab _) = packageId elab instance HasUnitId PrunedPackage where - installedUnitId = nodeKey + installedUnitId = nodeKey instance IsNode PrunedPackage where - type Key PrunedPackage = UnitId - nodeKey (PrunedPackage elab _) = nodeKey elab - nodeNeighbors (PrunedPackage _ deps) = deps + type Key PrunedPackage = UnitId + nodeKey (PrunedPackage elab _) = nodeKey elab + nodeNeighbors (PrunedPackage _ deps) = deps fromPrunedPackage :: PrunedPackage -> ElaboratedConfiguredPackage fromPrunedPackage (PrunedPackage elab _) = elab -- | Set the build targets based on the user targets (but not rev deps yet). -- This is required before we can prune anything. --- -setRootTargets :: TargetAction - -> Map UnitId [ComponentTarget] - -> [ElaboratedPlanPackage] - -> [ElaboratedPlanPackage] +setRootTargets + :: TargetAction + -> Map UnitId [ComponentTarget] + -> [ElaboratedPlanPackage] + -> [ElaboratedPlanPackage] setRootTargets targetAction perPkgTargetsMap = - assert (not (Map.null perPkgTargetsMap)) $ + assert (not (Map.null perPkgTargetsMap)) $ assert (all (not . null) (Map.elems perPkgTargetsMap)) $ - - map (mapConfiguredPackage setElabBuildTargets) + map (mapConfiguredPackage setElabBuildTargets) where -- Set the targets we'll build for this package/component. This is just -- based on the root targets from the user, not targets implied by reverse -- dependencies. Those comes in the second pass once we know the rev deps. -- setElabBuildTargets elab = - case (Map.lookup (installedUnitId elab) perPkgTargetsMap, - targetAction) of - (Nothing, _) -> elab - (Just tgts, TargetActionConfigure) -> elab { elabConfigureTargets = tgts } - (Just tgts, TargetActionBuild) -> elab { elabBuildTargets = tgts } - (Just tgts, TargetActionTest) -> elab { elabTestTargets = tgts } - (Just tgts, TargetActionBench) -> elab { elabBenchTargets = tgts } - (Just [tgt], TargetActionRepl) -> elab { elabReplTarget = Just tgt - , elabBuildHaddocks = False } - (Just tgts, TargetActionHaddock) -> - foldr setElabHaddockTargets (elab { elabHaddockTargets = tgts - , elabBuildHaddocks = True }) tgts - (Just _, TargetActionRepl) -> + case ( Map.lookup (installedUnitId elab) perPkgTargetsMap + , targetAction + ) of + (Nothing, _) -> elab + (Just tgts, TargetActionConfigure) -> elab{elabConfigureTargets = tgts} + (Just tgts, TargetActionBuild) -> elab{elabBuildTargets = tgts} + (Just tgts, TargetActionTest) -> elab{elabTestTargets = tgts} + (Just tgts, TargetActionBench) -> elab{elabBenchTargets = tgts} + (Just [tgt], TargetActionRepl) -> + elab + { elabReplTarget = Just tgt + , elabBuildHaddocks = False + } + (Just tgts, TargetActionHaddock) -> + foldr + setElabHaddockTargets + ( elab + { elabHaddockTargets = tgts + , elabBuildHaddocks = True + } + ) + tgts + (Just _, TargetActionRepl) -> error "pruneInstallPlanToTargets: multiple repl targets" setElabHaddockTargets tgt elab - | isTestComponentTarget tgt = elab { elabHaddockTestSuites = True } - | isBenchComponentTarget tgt = elab { elabHaddockBenchmarks = True } - | isForeignLibComponentTarget tgt = elab { elabHaddockForeignLibs = True } - | isExeComponentTarget tgt = elab { elabHaddockExecutables = True } - | isSubLibComponentTarget tgt = elab { elabHaddockInternal = True } - | otherwise = elab + | isTestComponentTarget tgt = elab{elabHaddockTestSuites = True} + | isBenchComponentTarget tgt = elab{elabHaddockBenchmarks = True} + | isForeignLibComponentTarget tgt = elab{elabHaddockForeignLibs = True} + | isExeComponentTarget tgt = elab{elabHaddockExecutables = True} + | isSubLibComponentTarget tgt = elab{elabHaddockInternal = True} + | otherwise = elab -- | Assuming we have previously set the root build targets (i.e. the user -- targets but not rev deps yet), the first pruning pass does two things: @@ -2861,38 +3239,42 @@ setRootTargets targetAction perPkgTargetsMap = -- * Take the dependency closure using pruned dependencies. We prune deps that -- are used only by unneeded optional stanzas. These pruned deps are only -- used for the dependency closure and are not persisted in this pass. --- -pruneInstallPlanPass1 :: [ElaboratedPlanPackage] - -> [ElaboratedPlanPackage] +pruneInstallPlanPass1 + :: [ElaboratedPlanPackage] + -> [ElaboratedPlanPackage] pruneInstallPlanPass1 pkgs = - map (mapConfiguredPackage fromPrunedPackage) - (fromMaybe [] $ Graph.closure graph roots) + map + (mapConfiguredPackage fromPrunedPackage) + (fromMaybe [] $ Graph.closure graph roots) where pkgs' = map (mapConfiguredPackage prune) pkgs graph = Graph.fromDistinctList pkgs' roots = mapMaybe find_root pkgs' prune elab = PrunedPackage elab' (pruneOptionalDependencies elab') - where elab' = - setDocumentation - $ addOptionalStanzas elab + where + elab' = + setDocumentation $ + addOptionalStanzas elab is_root :: PrunedPackage -> Maybe UnitId is_root (PrunedPackage elab _) = - if not $ and [ null (elabConfigureTargets elab) - , null (elabBuildTargets elab) - , null (elabTestTargets elab) - , null (elabBenchTargets elab) - , isNothing (elabReplTarget elab) - , null (elabHaddockTargets elab) - ] - then Just (installedUnitId elab) - else Nothing + if not $ + and + [ null (elabConfigureTargets elab) + , null (elabBuildTargets elab) + , null (elabTestTargets elab) + , null (elabBenchTargets elab) + , isNothing (elabReplTarget elab) + , null (elabHaddockTargets elab) + ] + then Just (installedUnitId elab) + else Nothing find_root (InstallPlan.Configured pkg) = is_root pkg -- When using the extra-packages stanza we need to -- look at installed packages as well. - find_root (InstallPlan.Installed pkg) = is_root pkg + find_root (InstallPlan.Installed pkg) = is_root pkg find_root _ = Nothing -- Note [Sticky enabled testsuites] @@ -2914,46 +3296,45 @@ pruneInstallPlanPass1 pkgs = -- Decide whether or not to enable testsuites and benchmarks. -- See [Sticky enabled testsuites] addOptionalStanzas :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage - addOptionalStanzas elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } = - elab { - elabPkgOrComp = ElabPackage (pkg { pkgStanzasEnabled = stanzas }) + addOptionalStanzas elab@ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage pkg} = + elab + { elabPkgOrComp = ElabPackage (pkg{pkgStanzasEnabled = stanzas}) } where stanzas :: OptionalStanzaSet - -- By default, we enabled all stanzas requested by the user, - -- as per elabStanzasRequested, done in - -- 'elaborateSolverToPackage' - stanzas = pkgStanzasEnabled pkg - -- optionalStanzasRequiredByTargets has to be done at - -- prune-time because it depends on 'elabTestTargets' - -- et al, which is done by 'setRootTargets' at the - -- beginning of pruning. - <> optionalStanzasRequiredByTargets elab - -- optionalStanzasWithDepsAvailable has to be done at - -- prune-time because it depends on what packages are - -- installed, which is not known until after improvement - -- (pruning is done after improvement) - <> optionalStanzasWithDepsAvailable availablePkgs elab pkg + -- By default, we enabled all stanzas requested by the user, + -- as per elabStanzasRequested, done in + -- 'elaborateSolverToPackage' + stanzas = + pkgStanzasEnabled pkg + -- optionalStanzasRequiredByTargets has to be done at + -- prune-time because it depends on 'elabTestTargets' + -- et al, which is done by 'setRootTargets' at the + -- beginning of pruning. + <> optionalStanzasRequiredByTargets elab + -- optionalStanzasWithDepsAvailable has to be done at + -- prune-time because it depends on what packages are + -- installed, which is not known until after improvement + -- (pruning is done after improvement) + <> optionalStanzasWithDepsAvailable availablePkgs elab pkg addOptionalStanzas elab = elab setDocumentation :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage - setDocumentation elab@ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } = - elab { - elabBuildHaddocks = + setDocumentation elab@ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent comp} = + elab + { elabBuildHaddocks = elabBuildHaddocks elab && documentationEnabled (compSolverName comp) elab - } - + } where documentationEnabled c = case c of - CD.ComponentLib -> const True + CD.ComponentLib -> const True CD.ComponentSubLib _ -> elabHaddockInternal - CD.ComponentFLib _ -> elabHaddockForeignLibs - CD.ComponentExe _ -> elabHaddockExecutables - CD.ComponentTest _ -> elabHaddockTestSuites - CD.ComponentBench _ -> elabHaddockBenchmarks - CD.ComponentSetup -> const False - + CD.ComponentFLib _ -> elabHaddockForeignLibs + CD.ComponentExe _ -> elabHaddockExecutables + CD.ComponentTest _ -> elabHaddockTestSuites + CD.ComponentBench _ -> elabHaddockBenchmarks + CD.ComponentSetup -> const False setDocumentation elab = elab -- Calculate package dependencies but cut out those needed only by @@ -2963,35 +3344,39 @@ pruneInstallPlanPass1 pkgs = -- stanzas in the next pass. -- pruneOptionalDependencies :: ElaboratedConfiguredPackage -> [UnitId] - pruneOptionalDependencies elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabComponent _ } - = InstallPlan.depends elab -- no pruning - pruneOptionalDependencies ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } - = (CD.flatDeps . CD.filterDeps keepNeeded) (pkgOrderDependencies pkg) + pruneOptionalDependencies elab@ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent _} = + InstallPlan.depends elab -- no pruning + pruneOptionalDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage pkg} = + (CD.flatDeps . CD.filterDeps keepNeeded) (pkgOrderDependencies pkg) where - keepNeeded (CD.ComponentTest _) _ = TestStanzas `optStanzaSetMember` stanzas + keepNeeded (CD.ComponentTest _) _ = TestStanzas `optStanzaSetMember` stanzas keepNeeded (CD.ComponentBench _) _ = BenchStanzas `optStanzaSetMember` stanzas - keepNeeded _ _ = True + keepNeeded _ _ = True stanzas = pkgStanzasEnabled pkg - optionalStanzasRequiredByTargets :: ElaboratedConfiguredPackage - -> OptionalStanzaSet + optionalStanzasRequiredByTargets + :: ElaboratedConfiguredPackage + -> OptionalStanzaSet optionalStanzasRequiredByTargets pkg = optStanzaSetFromList [ stanza - | ComponentTarget cname _ <- elabBuildTargets pkg - ++ elabTestTargets pkg - ++ elabBenchTargets pkg - ++ maybeToList (elabReplTarget pkg) - ++ elabHaddockTargets pkg - , stanza <- maybeToList $ - componentOptionalStanza $ - CD.componentNameToComponent cname + | ComponentTarget cname _ <- + elabBuildTargets pkg + ++ elabTestTargets pkg + ++ elabBenchTargets pkg + ++ maybeToList (elabReplTarget pkg) + ++ elabHaddockTargets pkg + , stanza <- + maybeToList $ + componentOptionalStanza $ + CD.componentNameToComponent cname ] availablePkgs = Set.fromList [ installedUnitId pkg - | InstallPlan.PreExisting pkg <- pkgs ] + | InstallPlan.PreExisting pkg <- pkgs + ] -- | Given a set of already installed packages @availablePkgs@, -- determine the set of available optional stanzas from @pkg@ @@ -2999,32 +3384,38 @@ pruneInstallPlanPass1 pkgs = -- to implement "sticky" testsuites, where once we have installed -- all of the deps needed for the test suite, we go ahead and -- enable it always. -optionalStanzasWithDepsAvailable :: Set UnitId - -> ElaboratedConfiguredPackage - -> ElaboratedPackage - -> OptionalStanzaSet +optionalStanzasWithDepsAvailable + :: Set UnitId + -> ElaboratedConfiguredPackage + -> ElaboratedPackage + -> OptionalStanzaSet optionalStanzasWithDepsAvailable availablePkgs elab pkg = - optStanzaSetFromList - [ stanza - | stanza <- optStanzaSetToList (elabStanzasAvailable elab) - , let deps :: [UnitId] - deps = CD.select (optionalStanzaDeps stanza) - -- TODO: probably need to select other - -- dep types too eventually - (pkgOrderDependencies pkg) - , all (`Set.member` availablePkgs) deps - ] + optStanzaSetFromList + [ stanza + | stanza <- optStanzaSetToList (elabStanzasAvailable elab) + , let deps :: [UnitId] + deps = + CD.select + (optionalStanzaDeps stanza) + -- TODO: probably need to select other + -- dep types too eventually + (pkgOrderDependencies pkg) + , all (`Set.member` availablePkgs) deps + ] where - optionalStanzaDeps TestStanzas (CD.ComponentTest _) = True + optionalStanzaDeps TestStanzas (CD.ComponentTest _) = True optionalStanzaDeps BenchStanzas (CD.ComponentBench _) = True - optionalStanzaDeps _ _ = False - + optionalStanzaDeps _ _ = False -- The second pass does three things: -- + -- * A second go at deciding which optional stanzas to enable. + -- * Prune the dependencies based on the final choice of optional stanzas. + -- * Extend the targets within each package to build, now we know the reverse + -- dependencies, ie we know which libs are needed as deps by other packages. -- -- Achieving sticky behaviour with enabling\/disabling optional stanzas is @@ -3047,31 +3438,35 @@ optionalStanzasWithDepsAvailable availablePkgs elab pkg = -- first or second pass) doesn't mean that we build all (or even any) of them. -- That depends on which targets we picked in the first pass. -- -pruneInstallPlanPass2 :: [ElaboratedPlanPackage] - -> [ElaboratedPlanPackage] +pruneInstallPlanPass2 + :: [ElaboratedPlanPackage] + -> [ElaboratedPlanPackage] pruneInstallPlanPass2 pkgs = - map (mapConfiguredPackage setStanzasDepsAndTargets) pkgs + map (mapConfiguredPackage setStanzasDepsAndTargets) pkgs where setStanzasDepsAndTargets elab = - elab { - elabBuildTargets = ordNub - $ elabBuildTargets elab - ++ libTargetsRequiredForRevDeps - ++ exeTargetsRequiredForRevDeps, - elabPkgOrComp = + elab + { elabBuildTargets = + ordNub $ + elabBuildTargets elab + ++ libTargetsRequiredForRevDeps + ++ exeTargetsRequiredForRevDeps + , elabPkgOrComp = case elabPkgOrComp elab of ElabPackage pkg -> - let stanzas = pkgStanzasEnabled pkg - <> optionalStanzasWithDepsAvailable availablePkgs elab pkg - keepNeeded (CD.ComponentTest _) _ = TestStanzas `optStanzaSetMember` stanzas + let stanzas = + pkgStanzasEnabled pkg + <> optionalStanzasWithDepsAvailable availablePkgs elab pkg + keepNeeded (CD.ComponentTest _) _ = TestStanzas `optStanzaSetMember` stanzas keepNeeded (CD.ComponentBench _) _ = BenchStanzas `optStanzaSetMember` stanzas - keepNeeded _ _ = True - in ElabPackage $ pkg { - pkgStanzasEnabled = stanzas, - pkgLibDependencies = CD.filterDeps keepNeeded (pkgLibDependencies pkg), - pkgExeDependencies = CD.filterDeps keepNeeded (pkgExeDependencies pkg), - pkgExeDependencyPaths = CD.filterDeps keepNeeded (pkgExeDependencyPaths pkg) - } + keepNeeded _ _ = True + in ElabPackage $ + pkg + { pkgStanzasEnabled = stanzas + , pkgLibDependencies = CD.filterDeps keepNeeded (pkgLibDependencies pkg) + , pkgExeDependencies = CD.filterDeps keepNeeded (pkgExeDependencies pkg) + , pkgExeDependencyPaths = CD.filterDeps keepNeeded (pkgExeDependencyPaths pkg) + } r@(ElabComponent _) -> r } where @@ -3082,32 +3477,39 @@ pruneInstallPlanPass2 pkgs = exeTargetsRequiredForRevDeps = -- TODO: allow requesting executable with different name -- than package name - [ ComponentTarget (Cabal.CExeName - $ packageNameToUnqualComponentName - $ packageName $ elabPkgSourceId elab) - WholeComponent + [ ComponentTarget + ( Cabal.CExeName $ + packageNameToUnqualComponentName $ + packageName $ + elabPkgSourceId elab + ) + WholeComponent | installedUnitId elab `Set.member` hasReverseExeDeps ] - availablePkgs :: Set UnitId availablePkgs = Set.fromList (map installedUnitId pkgs) hasReverseLibDeps :: Set UnitId hasReverseLibDeps = - Set.fromList [ depid - | InstallPlan.Configured pkg <- pkgs - , depid <- elabOrderLibDependencies pkg ] + Set.fromList + [ depid + | InstallPlan.Configured pkg <- pkgs + , depid <- elabOrderLibDependencies pkg + ] hasReverseExeDeps :: Set UnitId hasReverseExeDeps = - Set.fromList [ depid - | InstallPlan.Configured pkg <- pkgs - , depid <- elabOrderExeDependencies pkg ] + Set.fromList + [ depid + | InstallPlan.Configured pkg <- pkgs + , depid <- elabOrderExeDependencies pkg + ] -mapConfiguredPackage :: (srcpkg -> srcpkg') - -> InstallPlan.GenericPlanPackage ipkg srcpkg - -> InstallPlan.GenericPlanPackage ipkg srcpkg' +mapConfiguredPackage + :: (srcpkg -> srcpkg') + -> InstallPlan.GenericPlanPackage ipkg srcpkg + -> InstallPlan.GenericPlanPackage ipkg srcpkg' mapConfiguredPackage f (InstallPlan.Configured pkg) = InstallPlan.Configured (f pkg) mapConfiguredPackage f (InstallPlan.Installed pkg) = @@ -3122,40 +3524,46 @@ mapConfiguredPackage _ (InstallPlan.PreExisting pkg) = -- | Try to remove the given targets from the install plan. -- -- This is not always possible. --- -pruneInstallPlanToDependencies :: Set UnitId - -> ElaboratedInstallPlan - -> Either CannotPruneDependencies - ElaboratedInstallPlan +pruneInstallPlanToDependencies + :: Set UnitId + -> ElaboratedInstallPlan + -> Either + CannotPruneDependencies + ElaboratedInstallPlan pruneInstallPlanToDependencies pkgTargets installPlan = - assert (all (isJust . InstallPlan.lookup installPlan) - (Set.toList pkgTargets)) $ - - fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan)) - . checkBrokenDeps - . Graph.fromDistinctList - . filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets) - . InstallPlan.toList - $ installPlan - where - -- Our strategy is to remove the packages we don't want and then check - -- if the remaining graph is broken or not, ie any packages with dangling - -- dependencies. If there are then we cannot prune the given targets. - checkBrokenDeps :: Graph.Graph ElaboratedPlanPackage - -> Either CannotPruneDependencies - (Graph.Graph ElaboratedPlanPackage) - checkBrokenDeps graph = - case Graph.broken graph of - [] -> Right graph - brokenPackages -> - Left $ CannotPruneDependencies - [ (pkg, missingDeps) - | (pkg, missingDepIds) <- brokenPackages - , let missingDeps = mapMaybe lookupDep missingDepIds - ] - where - -- lookup in the original unpruned graph - lookupDep = InstallPlan.lookup installPlan + assert + ( all + (isJust . InstallPlan.lookup installPlan) + (Set.toList pkgTargets) + ) + $ fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan)) + . checkBrokenDeps + . Graph.fromDistinctList + . filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets) + . InstallPlan.toList + $ installPlan + where + -- Our strategy is to remove the packages we don't want and then check + -- if the remaining graph is broken or not, ie any packages with dangling + -- dependencies. If there are then we cannot prune the given targets. + checkBrokenDeps + :: Graph.Graph ElaboratedPlanPackage + -> Either + CannotPruneDependencies + (Graph.Graph ElaboratedPlanPackage) + checkBrokenDeps graph = + case Graph.broken graph of + [] -> Right graph + brokenPackages -> + Left $ + CannotPruneDependencies + [ (pkg, missingDeps) + | (pkg, missingDepIds) <- brokenPackages + , let missingDeps = mapMaybe lookupDep missingDepIds + ] + where + -- lookup in the original unpruned graph + lookupDep = InstallPlan.lookup installPlan -- | It is not always possible to prune to only the dependencies of a set of -- targets. It may be the case that removing a package leaves something else @@ -3163,13 +3571,14 @@ pruneInstallPlanToDependencies pkgTargets installPlan = -- -- This lists all the packages that would be broken, and their dependencies -- that would be missing if we did prune. --- -newtype CannotPruneDependencies = - CannotPruneDependencies [(ElaboratedPlanPackage, - [ElaboratedPlanPackage])] +newtype CannotPruneDependencies + = CannotPruneDependencies + [ ( ElaboratedPlanPackage + , [ElaboratedPlanPackage] + ) + ] deriving (Show) - --------------------------- -- Setup.hs script policy -- @@ -3200,33 +3609,31 @@ newtype CannotPruneDependencies = -- data SetupScriptStyle = ... -- see ProjectPlanning.Types -- | Work out the 'SetupScriptStyle' given the package description. --- packageSetupScriptStyle :: PD.PackageDescription -> SetupScriptStyle packageSetupScriptStyle pkg | buildType == PD.Custom , Just setupbi <- PD.setupBuildInfo pkg -- does have a custom-setup stanza - , not (PD.defaultSetupDepends setupbi) -- but not one we added internally - = SetupCustomExplicitDeps - + , not (PD.defaultSetupDepends setupbi) -- but not one we added internally + = + SetupCustomExplicitDeps | buildType == PD.Custom , Just setupbi <- PD.setupBuildInfo pkg -- we get this case post-solver as - , PD.defaultSetupDepends setupbi -- the solver fills in the deps - = SetupCustomImplicitDeps - + , PD.defaultSetupDepends setupbi -- the solver fills in the deps + = + SetupCustomImplicitDeps | buildType == PD.Custom - , Nothing <- PD.setupBuildInfo pkg -- we get this case pre-solver - = SetupCustomImplicitDeps - + , Nothing <- PD.setupBuildInfo pkg -- we get this case pre-solver + = + SetupCustomImplicitDeps -- here we should fail. - | PD.specVersion pkg > cabalSpecLatest -- one cabal-install is built against - = SetupNonCustomExternalLib - - | otherwise - = SetupNonCustomInternalLib + | PD.specVersion pkg > cabalSpecLatest -- one cabal-install is built against + = + SetupNonCustomExternalLib + | otherwise = + SetupNonCustomInternalLib where buildType = PD.buildType pkg - -- | Part of our Setup.hs handling policy is implemented by getting the solver -- to work out setup dependencies for packages. The solver already handles -- packages that explicitly specify setup dependencies, but we can also tell @@ -3245,56 +3652,61 @@ packageSetupScriptStyle pkg -- Note in addition to adding default setup deps, we also use -- 'addSetupCabalMinVersionConstraint' (in 'planPackages') to require -- @Cabal >= 1.20@ for Setup scripts. --- -defaultSetupDeps :: Compiler -> Platform - -> PD.PackageDescription - -> Maybe [Dependency] +defaultSetupDeps + :: Compiler + -> Platform + -> PD.PackageDescription + -> Maybe [Dependency] defaultSetupDeps compiler platform pkg = - case packageSetupScriptStyle pkg of - - -- For packages with build type custom that do not specify explicit - -- setup dependencies, we add a dependency on Cabal and a number - -- of other packages. - SetupCustomImplicitDeps -> - Just $ + case packageSetupScriptStyle pkg of + -- For packages with build type custom that do not specify explicit + -- setup dependencies, we add a dependency on Cabal and a number + -- of other packages. + SetupCustomImplicitDeps -> + Just $ [ Dependency depPkgname anyVersion mainLibSet - | depPkgname <- legacyCustomSetupPkgs compiler platform ] ++ + | depPkgname <- legacyCustomSetupPkgs compiler platform + ] + ++ [ Dependency cabalPkgname cabalConstraint mainLibSet + | packageName pkg /= cabalPkgname + ] + where + -- The Cabal dep is slightly special: + -- \* We omit the dep for the Cabal lib itself, since it bootstraps. + -- \* We constrain it to be < 1.25 + -- + -- Note: we also add a global constraint to require Cabal >= 1.20 + -- for Setup scripts (see use addSetupCabalMinVersionConstraint). + -- + cabalConstraint = + orLaterVersion (csvToVersion (PD.specVersion pkg)) + `intersectVersionRanges` earlierVersion cabalCompatMaxVer + -- The idea here is that at some point we will make significant + -- breaking changes to the Cabal API that Setup.hs scripts use. + -- So for old custom Setup scripts that do not specify explicit + -- constraints, we constrain them to use a compatible Cabal version. + cabalCompatMaxVer = mkVersion [1, 25] + + -- 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. + SetupNonCustomExternalLib -> + Just [ Dependency cabalPkgname cabalConstraint mainLibSet - | packageName pkg /= cabalPkgname ] - where - -- The Cabal dep is slightly special: - -- * We omit the dep for the Cabal lib itself, since it bootstraps. - -- * We constrain it to be < 1.25 - -- - -- Note: we also add a global constraint to require Cabal >= 1.20 - -- for Setup scripts (see use addSetupCabalMinVersionConstraint). - -- - cabalConstraint = orLaterVersion (csvToVersion (PD.specVersion pkg)) - `intersectVersionRanges` - earlierVersion cabalCompatMaxVer - -- The idea here is that at some point we will make significant - -- breaking changes to the Cabal API that Setup.hs scripts use. - -- So for old custom Setup scripts that do not specify explicit - -- constraints, we constrain them to use a compatible Cabal version. - cabalCompatMaxVer = mkVersion [1,25] - - -- 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. - SetupNonCustomExternalLib -> - Just [ Dependency cabalPkgname cabalConstraint mainLibSet - , Dependency basePkgname anyVersion mainLibSet] - where - cabalConstraint = orLaterVersion (csvToVersion (PD.specVersion pkg)) - - -- The internal setup wrapper method has no deps at all. - SetupNonCustomInternalLib -> Just [] - - -- This case gets ruled out by the caller, planPackages, see the note - -- above in the SetupCustomImplicitDeps case. - SetupCustomExplicitDeps -> - error $ "defaultSetupDeps: called for a package with explicit " - ++ "setup deps: " ++ prettyShow (packageId pkg) + , Dependency basePkgname anyVersion mainLibSet + ] + where + cabalConstraint = orLaterVersion (csvToVersion (PD.specVersion pkg)) + + -- The internal setup wrapper method has no deps at all. + SetupNonCustomInternalLib -> Just [] + -- This case gets ruled out by the caller, planPackages, see the note + -- above in the SetupCustomImplicitDeps case. + SetupCustomExplicitDeps -> + error $ + "defaultSetupDeps: called for a package with explicit " + ++ "setup deps: " + ++ prettyShow (packageId pkg) where -- we require one less -- @@ -3308,58 +3720,65 @@ defaultSetupDeps compiler platform pkg = -- This depends somewhat on the 'SetupScriptStyle' but most cases are a result -- of what the solver picked for us, based on the explicit setup deps or the -- ones added implicitly by 'defaultSetupDeps'. --- -packageSetupScriptSpecVersion :: SetupScriptStyle - -> PD.PackageDescription - -> Graph.Graph NonSetupLibDepSolverPlanPackage - -> ComponentDeps [SolverId] - -> Version - +packageSetupScriptSpecVersion + :: SetupScriptStyle + -> PD.PackageDescription + -> Graph.Graph NonSetupLibDepSolverPlanPackage + -> ComponentDeps [SolverId] + -> Version -- We're going to be using the internal Cabal library, so the spec version of -- that is simply the version of the Cabal library that cabal-install has been -- built with. packageSetupScriptSpecVersion SetupNonCustomInternalLib _ _ _ = - cabalVersion - + cabalVersion -- If we happen to be building the Cabal lib itself then because that -- bootstraps itself then we use the version of the lib we're building. packageSetupScriptSpecVersion SetupCustomImplicitDeps pkg _ _ - | packageName pkg == cabalPkgname - = packageVersion pkg - + | packageName pkg == cabalPkgname = + packageVersion pkg -- In all other cases we have a look at what version of the Cabal lib the -- solver picked. Or if it didn't depend on Cabal at all (which is very rare) -- then we look at the .cabal file to see what spec version it declares. packageSetupScriptSpecVersion _ pkg libDepGraph deps = - case find ((cabalPkgname ==) . packageName) setupLibDeps of - Just dep -> packageVersion dep - Nothing -> mkVersion (cabalSpecMinimumLibraryVersion (PD.specVersion pkg)) + case find ((cabalPkgname ==) . packageName) setupLibDeps of + Just dep -> packageVersion dep + Nothing -> mkVersion (cabalSpecMinimumLibraryVersion (PD.specVersion pkg)) where - setupLibDeps = map packageId $ fromMaybe [] $ - Graph.closure libDepGraph (CD.setupDeps deps) - + setupLibDeps = + map packageId $ + fromMaybe [] $ + Graph.closure libDepGraph (CD.setupDeps deps) cabalPkgname, basePkgname :: PackageName cabalPkgname = mkPackageName "Cabal" -basePkgname = mkPackageName "base" - +basePkgname = mkPackageName "base" legacyCustomSetupPkgs :: Compiler -> Platform -> [PackageName] legacyCustomSetupPkgs compiler (Platform _ os) = - map mkPackageName $ - [ "array", "base", "binary", "bytestring", "containers" - , "deepseq", "directory", "filepath", "pretty" - , "process", "time", "transformers" ] - ++ [ "Win32" | os == Windows ] - ++ [ "unix" | os /= Windows ] - ++ [ "ghc-prim" | isGHC ] - ++ [ "template-haskell" | isGHC ] - ++ [ "old-time" | notGHC710 ] + map mkPackageName $ + [ "array" + , "base" + , "binary" + , "bytestring" + , "containers" + , "deepseq" + , "directory" + , "filepath" + , "pretty" + , "process" + , "time" + , "transformers" + ] + ++ ["Win32" | os == Windows] + ++ ["unix" | os /= Windows] + ++ ["ghc-prim" | isGHC] + ++ ["template-haskell" | isGHC] + ++ ["old-time" | notGHC710] where isGHC = compilerCompatFlavor GHC compiler notGHC710 = case compilerCompatVersion GHC compiler of - Nothing -> False - Just v -> v <= mkVersion [7,9] + Nothing -> False + Just v -> v <= mkVersion [7, 9] -- The other aspects of our Setup.hs policy lives here where we decide on -- the 'SetupScriptOptions'. @@ -3371,436 +3790,473 @@ legacyCustomSetupPkgs compiler (Platform _ os) = -- be tricky since we would have to allow the Setup access to all the packages -- in the store and local dbs. -setupHsScriptOptions :: ElaboratedReadyPackage - -> ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> DistDirLayout - -> FilePath - -> FilePath - -> Bool - -> Lock - -> SetupScriptOptions +setupHsScriptOptions + :: ElaboratedReadyPackage + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> DistDirLayout + -> FilePath + -> FilePath + -> Bool + -> Lock + -> SetupScriptOptions -- TODO: Fix this so custom is a separate component. Custom can ALWAYS -- be a separate component!!! -setupHsScriptOptions (ReadyPackage elab@ElaboratedConfiguredPackage{..}) - plan ElaboratedSharedConfig{..} distdir srcdir builddir - isParallelBuild cacheLock = - SetupScriptOptions { - useCabalVersion = thisVersion elabSetupScriptCliVersion, - useCabalSpecVersion = Just elabSetupScriptCliVersion, - useCompiler = Just pkgConfigCompiler, - usePlatform = Just pkgConfigPlatform, - usePackageDB = elabSetupPackageDBStack, - usePackageIndex = Nothing, - useDependencies = [ (uid, srcid) - | ConfiguredId srcid (Just (CLibName LMainLibName)) uid - <- elabSetupDependencies elab ], - useDependenciesExclusive = True, - useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps, - useProgramDb = pkgConfigCompilerProgs, - useDistPref = builddir, - useLoggingHandle = Nothing, -- this gets set later - useWorkingDir = Just srcdir, - useExtraPathEnv = elabExeDependencyPaths elab, - useExtraEnvOverrides = dataDirsEnvironmentForPlan distdir plan, - useWin32CleanHack = False, --TODO: [required eventually] - forceExternalSetupMethod = isParallelBuild, - setupCacheLock = Just cacheLock, - isInteractive = False - } - +setupHsScriptOptions + (ReadyPackage elab@ElaboratedConfiguredPackage{..}) + plan + ElaboratedSharedConfig{..} + distdir + srcdir + builddir + isParallelBuild + cacheLock = + SetupScriptOptions + { useCabalVersion = thisVersion elabSetupScriptCliVersion + , useCabalSpecVersion = Just elabSetupScriptCliVersion + , useCompiler = Just pkgConfigCompiler + , usePlatform = Just pkgConfigPlatform + , usePackageDB = elabSetupPackageDBStack + , usePackageIndex = Nothing + , useDependencies = + [ (uid, srcid) + | ConfiguredId srcid (Just (CLibName LMainLibName)) uid <- + elabSetupDependencies elab + ] + , useDependenciesExclusive = True + , useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps + , useProgramDb = pkgConfigCompilerProgs + , useDistPref = builddir + , useLoggingHandle = Nothing -- this gets set later + , useWorkingDir = Just srcdir + , useExtraPathEnv = elabExeDependencyPaths elab + , useExtraEnvOverrides = dataDirsEnvironmentForPlan distdir plan + , useWin32CleanHack = False -- TODO: [required eventually] + , forceExternalSetupMethod = isParallelBuild + , setupCacheLock = Just cacheLock + , isInteractive = False + } -- | To be used for the input for elaborateInstallPlan. -- -- TODO: [code cleanup] make InstallDirs.defaultInstallDirs pure. --- -userInstallDirTemplates :: Compiler - -> IO InstallDirs.InstallDirTemplates +userInstallDirTemplates + :: Compiler + -> IO InstallDirs.InstallDirTemplates userInstallDirTemplates compiler = do - InstallDirs.defaultInstallDirs - (compilerFlavor compiler) - True -- user install - False -- unused - -storePackageInstallDirs :: StoreDirLayout - -> CompilerId - -> InstalledPackageId - -> InstallDirs.InstallDirs FilePath + InstallDirs.defaultInstallDirs + (compilerFlavor compiler) + True -- user install + False -- unused + +storePackageInstallDirs + :: StoreDirLayout + -> CompilerId + -> InstalledPackageId + -> InstallDirs.InstallDirs FilePath storePackageInstallDirs storeDirLayout compid ipkgid = storePackageInstallDirs' storeDirLayout compid $ newSimpleUnitId ipkgid -storePackageInstallDirs' :: StoreDirLayout - -> CompilerId - -> UnitId - -> InstallDirs.InstallDirs FilePath -storePackageInstallDirs' StoreDirLayout{ storePackageDirectory - , storeDirectory } - compid unitid = - InstallDirs.InstallDirs {..} - where - store = storeDirectory compid - prefix = storePackageDirectory compid unitid - bindir = prefix "bin" - libdir = prefix "lib" - libsubdir = "" - -- Note: on macOS, we place libraries into - -- @store/lib@ to work around the load - -- command size limit of macOSs mach-o linker. - -- See also @PackageHash.hashedInstalledPackageIdVeryShort@ - dynlibdir | buildOS == OSX = store "lib" - | otherwise = libdir - flibdir = libdir - libexecdir = prefix "libexec" - libexecsubdir= "" - includedir = libdir "include" - datadir = prefix "share" - datasubdir = "" - docdir = datadir "doc" - mandir = datadir "man" - htmldir = docdir "html" - haddockdir = htmldir - sysconfdir = prefix "etc" - - -computeInstallDirs :: StoreDirLayout - -> InstallDirs.InstallDirTemplates - -> ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> InstallDirs.InstallDirs FilePath -computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab - | elabBuildStyle elab == BuildInplaceOnly - -- use the ordinary default install dirs - = (InstallDirs.absoluteInstallDirs - (elabPkgSourceId elab) - (elabUnitId elab) - (compilerInfo (pkgConfigCompiler elaboratedShared)) - InstallDirs.NoCopyDest - (pkgConfigPlatform elaboratedShared) - defaultInstallDirs) { - - -- absoluteInstallDirs sets these as 'undefined' but we have - -- to use them as "Setup.hs configure" args - InstallDirs.libsubdir = "", - InstallDirs.libexecsubdir = "", - InstallDirs.datasubdir = "" +storePackageInstallDirs' + :: StoreDirLayout + -> CompilerId + -> UnitId + -> InstallDirs.InstallDirs FilePath +storePackageInstallDirs' + StoreDirLayout + { storePackageDirectory + , storeDirectory } - - | otherwise - -- use special simplified install dirs - = storePackageInstallDirs' - storeDirLayout - (compilerId (pkgConfigCompiler elaboratedShared)) - (elabUnitId elab) - - ---TODO: [code cleanup] perhaps reorder this code + compid + unitid = + InstallDirs.InstallDirs{..} + where + store = storeDirectory compid + prefix = storePackageDirectory compid unitid + bindir = prefix "bin" + libdir = prefix "lib" + libsubdir = "" + -- Note: on macOS, we place libraries into + -- @store/lib@ to work around the load + -- command size limit of macOSs mach-o linker. + -- See also @PackageHash.hashedInstalledPackageIdVeryShort@ + dynlibdir + | buildOS == OSX = store "lib" + | otherwise = libdir + flibdir = libdir + libexecdir = prefix "libexec" + libexecsubdir = "" + includedir = libdir "include" + datadir = prefix "share" + datasubdir = "" + docdir = datadir "doc" + mandir = datadir "man" + htmldir = docdir "html" + haddockdir = htmldir + sysconfdir = prefix "etc" + +computeInstallDirs + :: StoreDirLayout + -> InstallDirs.InstallDirTemplates + -> ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> InstallDirs.InstallDirs FilePath +computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab + | elabBuildStyle elab == BuildInplaceOnly = + -- use the ordinary default install dirs + ( InstallDirs.absoluteInstallDirs + (elabPkgSourceId elab) + (elabUnitId elab) + (compilerInfo (pkgConfigCompiler elaboratedShared)) + InstallDirs.NoCopyDest + (pkgConfigPlatform elaboratedShared) + defaultInstallDirs + ) + { -- absoluteInstallDirs sets these as 'undefined' but we have + -- to use them as "Setup.hs configure" args + InstallDirs.libsubdir = "" + , InstallDirs.libexecsubdir = "" + , InstallDirs.datasubdir = "" + } + | otherwise = + -- use special simplified install dirs + storePackageInstallDirs' + storeDirLayout + (compilerId (pkgConfigCompiler elaboratedShared)) + (elabUnitId elab) + +-- TODO: [code cleanup] perhaps reorder this code -- based on the ElaboratedInstallPlan + ElaboratedSharedConfig, -- make the various Setup.hs {configure,build,copy} flags - -setupHsConfigureFlags :: ElaboratedReadyPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.ConfigFlags -setupHsConfigureFlags (ReadyPackage elab@ElaboratedConfiguredPackage{..}) - sharedConfig@ElaboratedSharedConfig{..} - verbosity builddir = - sanityCheckElaboratedConfiguredPackage sharedConfig elab - (Cabal.ConfigFlags {..}) - where - 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 - configIPID = case elabPkgOrComp of - ElabPackage pkg -> toFlag (prettyShow (pkgInstalledId pkg)) - ElabComponent _ -> mempty - configCID = case elabPkgOrComp of - ElabPackage _ -> mempty - ElabComponent _ -> toFlag elabComponentId - - configProgramPaths = Map.toList elabProgramPaths - configProgramArgs - | {- elabSetupScriptCliVersion < mkVersion [1,24,3] -} True - -- workaround for - -- - -- It turns out, that even with Cabal 2.0, there's still cases such as e.g. - -- custom Setup.hs scripts calling out to GHC even when going via - -- @runProgram ghcProgram@, as e.g. happy does in its - -- - -- (see also ) - -- - -- So for now, let's pass the rather harmless and idempotent - -- `-hide-all-packages` flag to all invocations (which has - -- the benefit that every GHC invocation starts with a - -- consistently well-defined clean slate) until we find a - -- better way. - = Map.toList $ - Map.insertWith (++) "ghc" ["-hide-all-packages"] - elabProgramArgs - configProgramPathExtra = toNubList elabProgramPathExtra - configHcFlavor = toFlag (compilerFlavor pkgConfigCompiler) - configHcPath = mempty -- we use configProgramPaths instead - configHcPkg = mempty -- we use configProgramPaths instead - - configVanillaLib = toFlag elabVanillaLib - configSharedLib = toFlag elabSharedLib - configStaticLib = toFlag elabStaticLib - - configDynExe = toFlag elabDynExe - configFullyStaticExe = toFlag elabFullyStaticExe - configGHCiLib = toFlag elabGHCiLib - configProfExe = mempty - configProfLib = toFlag elabProfLib - configProf = toFlag elabProfExe - - -- configProfDetail is for exe+lib, but overridden by configProfLibDetail - -- so we specify both so we can specify independently - configProfDetail = toFlag elabProfExeDetail - configProfLibDetail = toFlag elabProfLibDetail - - configCoverage = toFlag elabCoverage - configLibCoverage = mempty - - configOptimization = toFlag elabOptimization - configSplitSections = toFlag elabSplitSections - configSplitObjs = toFlag elabSplitObjs - configStripExes = toFlag elabStripExes - configStripLibs = toFlag elabStripLibs - configDebugInfo = toFlag elabDebugInfo - configDumpBuildInfo = toFlag elabDumpBuildInfo - - configConfigurationsFlags = elabFlagAssignment - configConfigureArgs = elabConfigureScriptArgs - configExtraLibDirs = elabExtraLibDirs - configExtraLibDirsStatic = elabExtraLibDirsStatic - configExtraFrameworkDirs = elabExtraFrameworkDirs - configExtraIncludeDirs = elabExtraIncludeDirs - configProgPrefix = maybe mempty toFlag elabProgPrefix - configProgSuffix = maybe mempty toFlag elabProgSuffix - - configInstallDirs = fmap (toFlag . InstallDirs.toPathTemplate) - elabInstallDirs - - -- we only use configDependencies, unless we're talking to an old Cabal - -- in which case we use configConstraints - -- NB: This does NOT use InstallPlan.depends, which includes executable - -- dependencies which should NOT be fed in here (also you don't have - -- enough info anyway) - configDependencies = [ GivenComponent - (packageName srcid) - ln - cid - | ConfiguredId srcid mb_cn cid <- elabLibDependencies elab - , let ln = case mb_cn - of Just (CLibName lname) -> lname - Just _ -> error "non-library dependency" - Nothing -> LMainLibName - ] - configConstraints = +setupHsConfigureFlags + :: ElaboratedReadyPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.ConfigFlags +setupHsConfigureFlags + (ReadyPackage elab@ElaboratedConfiguredPackage{..}) + sharedConfig@ElaboratedSharedConfig{..} + verbosity + builddir = + sanityCheckElaboratedConfiguredPackage + sharedConfig + elab + (Cabal.ConfigFlags{..}) + where + 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 + configIPID = case elabPkgOrComp of + ElabPackage pkg -> toFlag (prettyShow (pkgInstalledId pkg)) + ElabComponent _ -> mempty + configCID = case elabPkgOrComp of + ElabPackage _ -> mempty + ElabComponent _ -> toFlag elabComponentId + + configProgramPaths = Map.toList elabProgramPaths + configProgramArgs + | {- elabSetupScriptCliVersion < mkVersion [1,24,3] -} True = + -- workaround for + -- + -- It turns out, that even with Cabal 2.0, there's still cases such as e.g. + -- custom Setup.hs scripts calling out to GHC even when going via + -- @runProgram ghcProgram@, as e.g. happy does in its + -- + -- (see also ) + -- + -- So for now, let's pass the rather harmless and idempotent + -- `-hide-all-packages` flag to all invocations (which has + -- the benefit that every GHC invocation starts with a + -- consistently well-defined clean slate) until we find a + -- better way. + Map.toList $ + Map.insertWith + (++) + "ghc" + ["-hide-all-packages"] + elabProgramArgs + configProgramPathExtra = toNubList elabProgramPathExtra + configHcFlavor = toFlag (compilerFlavor pkgConfigCompiler) + configHcPath = mempty -- we use configProgramPaths instead + configHcPkg = mempty -- we use configProgramPaths instead + configVanillaLib = toFlag elabVanillaLib + configSharedLib = toFlag elabSharedLib + configStaticLib = toFlag elabStaticLib + + configDynExe = toFlag elabDynExe + configFullyStaticExe = toFlag elabFullyStaticExe + configGHCiLib = toFlag elabGHCiLib + configProfExe = mempty + configProfLib = toFlag elabProfLib + configProf = toFlag elabProfExe + + -- configProfDetail is for exe+lib, but overridden by configProfLibDetail + -- so we specify both so we can specify independently + configProfDetail = toFlag elabProfExeDetail + configProfLibDetail = toFlag elabProfLibDetail + + configCoverage = toFlag elabCoverage + configLibCoverage = mempty + + configOptimization = toFlag elabOptimization + configSplitSections = toFlag elabSplitSections + configSplitObjs = toFlag elabSplitObjs + configStripExes = toFlag elabStripExes + configStripLibs = toFlag elabStripLibs + configDebugInfo = toFlag elabDebugInfo + configDumpBuildInfo = toFlag elabDumpBuildInfo + + configConfigurationsFlags = elabFlagAssignment + configConfigureArgs = elabConfigureScriptArgs + configExtraLibDirs = elabExtraLibDirs + configExtraLibDirsStatic = elabExtraLibDirsStatic + configExtraFrameworkDirs = elabExtraFrameworkDirs + configExtraIncludeDirs = elabExtraIncludeDirs + configProgPrefix = maybe mempty toFlag elabProgPrefix + configProgSuffix = maybe mempty toFlag elabProgSuffix + + configInstallDirs = + fmap + (toFlag . InstallDirs.toPathTemplate) + elabInstallDirs + + -- we only use configDependencies, unless we're talking to an old Cabal + -- in which case we use configConstraints + -- NB: This does NOT use InstallPlan.depends, which includes executable + -- dependencies which should NOT be fed in here (also you don't have + -- enough info anyway) + configDependencies = + [ GivenComponent + (packageName srcid) + ln + cid + | ConfiguredId srcid mb_cn cid <- elabLibDependencies elab + , let ln = case mb_cn of + Just (CLibName lname) -> lname + Just _ -> error "non-library dependency" + Nothing -> LMainLibName + ] + configConstraints = case elabPkgOrComp of - ElabPackage _ -> - [ thisPackageVersionConstraint srcid - | ConfiguredId srcid _ _uid <- elabLibDependencies elab ] - 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 - configBenchmarks = case elabPkgOrComp of - ElabPackage pkg -> toFlag (BenchStanzas `optStanzaSetMember` pkgStanzasEnabled pkg) - ElabComponent _ -> mempty - - configExactConfiguration = toFlag True - configFlagError = mempty --TODO: [research required] appears not to be implemented - configRelocatable = mempty --TODO: [research required] ??? - configScratchDir = mempty -- never use - configUserInstall = mempty -- don't rely on defaults - configPrograms_ = mempty -- never use, shouldn't exist - configUseResponseFiles = mempty - configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported pkgConfigCompiler - -setupHsConfigureArgs :: ElaboratedConfiguredPackage - -> [String] -setupHsConfigureArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ }) = [] -setupHsConfigureArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp }) = - [showComponentTarget (packageId elab) (ComponentTarget cname WholeComponent)] + ElabPackage _ -> + [ thisPackageVersionConstraint srcid + | ConfiguredId srcid _ _uid <- elabLibDependencies elab + ] + 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 + configBenchmarks = case elabPkgOrComp of + ElabPackage pkg -> toFlag (BenchStanzas `optStanzaSetMember` pkgStanzasEnabled pkg) + ElabComponent _ -> mempty + + configExactConfiguration = toFlag True + configFlagError = mempty -- TODO: [research required] appears not to be implemented + configRelocatable = mempty -- TODO: [research required] ??? + configScratchDir = mempty -- never use + configUserInstall = mempty -- don't rely on defaults + configPrograms_ = mempty -- never use, shouldn't exist + configUseResponseFiles = mempty + configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported pkgConfigCompiler + +setupHsConfigureArgs + :: ElaboratedConfiguredPackage + -> [String] +setupHsConfigureArgs (ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage _}) = [] +setupHsConfigureArgs elab@(ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent comp}) = + [showComponentTarget (packageId elab) (ComponentTarget cname WholeComponent)] where - cname = fromMaybe (error "setupHsConfigureArgs: trying to configure setup") - (compComponentName comp) - -setupHsBuildFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.BuildFlags + cname = + fromMaybe + (error "setupHsConfigureArgs: trying to configure setup") + (compComponentName comp) + +setupHsBuildFlags + :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.BuildFlags setupHsBuildFlags _ _ verbosity builddir = - Cabal.BuildFlags { - 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), - buildArgs = mempty, -- unused, passed via args not flags - buildCabalFilePath= mempty + Cabal.BuildFlags + { 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), + , buildArgs = mempty -- unused, passed via args not flags + , buildCabalFilePath = mempty } - setupHsBuildArgs :: ElaboratedConfiguredPackage -> [String] -setupHsBuildArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ }) - -- Fix for #3335, don't pass build arguments if it's not supported - | elabSetupScriptCliVersion elab >= mkVersion [1,17] - = map (showComponentTarget (packageId elab)) (elabBuildTargets elab) - | otherwise - = [] -setupHsBuildArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent _ }) - = [] - - -setupHsTestFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.TestFlags -setupHsTestFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = Cabal.TestFlags - { testDistPref = toFlag builddir - , testVerbosity = toFlag verbosity - , testMachineLog = maybe mempty toFlag elabTestMachineLog - , testHumanLog = maybe mempty toFlag elabTestHumanLog +setupHsBuildArgs elab@(ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage _}) + -- Fix for #3335, don't pass build arguments if it's not supported + | elabSetupScriptCliVersion elab >= mkVersion [1, 17] = + map (showComponentTarget (packageId elab)) (elabBuildTargets elab) + | otherwise = + [] +setupHsBuildArgs (ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent _}) = + [] + +setupHsTestFlags + :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.TestFlags +setupHsTestFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = + Cabal.TestFlags + { testDistPref = toFlag builddir + , testVerbosity = toFlag verbosity + , testMachineLog = maybe mempty toFlag elabTestMachineLog + , testHumanLog = maybe mempty toFlag elabTestHumanLog , testShowDetails = maybe (Flag Cabal.Always) toFlag elabTestShowDetails - , testKeepTix = toFlag elabTestKeepTix - , testWrapper = maybe mempty toFlag elabTestWrapper + , testKeepTix = toFlag elabTestKeepTix + , testWrapper = maybe mempty toFlag elabTestWrapper , testFailWhenNoTestSuites = toFlag elabTestFailWhenNoTestSuites - , testOptions = elabTestTestOptions + , testOptions = elabTestTestOptions } setupHsTestArgs :: ElaboratedConfiguredPackage -> [String] -- TODO: Does the issue #3335 affects test as well setupHsTestArgs elab = - mapMaybe (showTestComponentTarget (packageId elab)) (elabTestTargets elab) - + mapMaybe (showTestComponentTarget (packageId elab)) (elabTestTargets elab) -setupHsBenchFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.BenchmarkFlags -setupHsBenchFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = Cabal.BenchmarkFlags - { benchmarkDistPref = toFlag builddir +setupHsBenchFlags + :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.BenchmarkFlags +setupHsBenchFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = + Cabal.BenchmarkFlags + { benchmarkDistPref = toFlag builddir , benchmarkVerbosity = toFlag verbosity - , benchmarkOptions = elabBenchmarkOptions + , benchmarkOptions = elabBenchmarkOptions } setupHsBenchArgs :: ElaboratedConfiguredPackage -> [String] setupHsBenchArgs elab = - mapMaybe (showBenchComponentTarget (packageId elab)) (elabBenchTargets elab) + mapMaybe (showBenchComponentTarget (packageId elab)) (elabBenchTargets elab) - -setupHsReplFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.ReplFlags +setupHsReplFlags + :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.ReplFlags setupHsReplFlags _ sharedConfig verbosity builddir = - Cabal.ReplFlags { - 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 + Cabal.ReplFlags + { 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 } - setupHsReplArgs :: ElaboratedConfiguredPackage -> [String] setupHsReplArgs elab = - maybe [] (\t -> [showComponentTarget (packageId elab) t]) (elabReplTarget elab) - --TODO: should be able to give multiple modules in one component + maybe [] (\t -> [showComponentTarget (packageId elab) t]) (elabReplTarget elab) +-- TODO: should be able to give multiple modules in one component -setupHsCopyFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> FilePath - -> Cabal.CopyFlags +setupHsCopyFlags + :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> FilePath + -> Cabal.CopyFlags setupHsCopyFlags _ _ verbosity builddir destdir = - Cabal.CopyFlags { - copyArgs = [], -- TODO: could use this to only copy what we enabled - copyDest = toFlag (InstallDirs.CopyTo destdir), - copyDistPref = toFlag builddir, - copyVerbosity = toFlag verbosity, - copyCabalFilePath = mempty + Cabal.CopyFlags + { copyArgs = [] -- TODO: could use this to only copy what we enabled + , copyDest = toFlag (InstallDirs.CopyTo destdir) + , copyDistPref = toFlag builddir + , copyVerbosity = toFlag verbosity + , copyCabalFilePath = mempty } -setupHsRegisterFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> FilePath - -> Cabal.RegisterFlags -setupHsRegisterFlags ElaboratedConfiguredPackage{..} _ - verbosity builddir pkgConfFile = - Cabal.RegisterFlags { - regPackageDB = mempty, -- misfeature - regGenScript = mempty, -- never use - regGenPkgConf = toFlag (Just pkgConfFile), - regInPlace = case elabBuildStyle of - BuildInplaceOnly -> toFlag True - _ -> toFlag False, - regPrintId = mempty, -- never use - regDistPref = toFlag builddir, - regArgs = [], - regVerbosity = toFlag verbosity, - regCabalFilePath = mempty - } +setupHsRegisterFlags + :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> FilePath + -> Cabal.RegisterFlags +setupHsRegisterFlags + ElaboratedConfiguredPackage{..} + _ + verbosity + builddir + pkgConfFile = + Cabal.RegisterFlags + { regPackageDB = mempty -- misfeature + , regGenScript = mempty -- never use + , regGenPkgConf = toFlag (Just pkgConfFile) + , regInPlace = case elabBuildStyle of + BuildInplaceOnly -> toFlag True + _ -> toFlag False + , regPrintId = mempty -- never use + , regDistPref = toFlag builddir + , regArgs = [] + , regVerbosity = toFlag verbosity + , regCabalFilePath = mempty + } -setupHsHaddockFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.HaddockFlags +setupHsHaddockFlags + :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.HaddockFlags setupHsHaddockFlags (ElaboratedConfiguredPackage{..}) (ElaboratedSharedConfig{..}) verbosity builddir = - Cabal.HaddockFlags { - haddockProgramPaths = + 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 + 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 } setupHsHaddockArgs :: ElaboratedConfiguredPackage -> [String] @@ -3820,7 +4276,9 @@ setupHsTestFlags _ _ verbosity builddir = -} ------------------------------------------------------------------------------ + -- * Sharing installed packages + ------------------------------------------------------------------------------ -- @@ -3861,103 +4319,112 @@ setupHsTestFlags _ _ verbosity builddir = -- TODO: [required eventually] for safety of concurrent installs, we must make sure we register but -- not replace installed packages with ghc-pkg. -packageHashInputs :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> PackageHashInputs packageHashInputs - pkgshared - elab@(ElaboratedConfiguredPackage { - elabPkgSourceHash = Just srchash - }) = - PackageHashInputs { - pkgHashPkgId = packageId elab, - pkgHashComponent = - case elabPkgOrComp elab of - ElabPackage _ -> Nothing - ElabComponent comp -> Just (compSolverName comp), - pkgHashSourceHash = srchash, - pkgHashPkgConfigDeps = Set.fromList (elabPkgConfigDependencies elab), - pkgHashDirectDeps = - case elabPkgOrComp elab of - ElabPackage (ElaboratedPackage{..}) -> - Set.fromList $ - [ confInstId dep - | dep <- CD.select relevantDeps pkgLibDependencies ] ++ - [ confInstId dep - | dep <- CD.select relevantDeps pkgExeDependencies ] - ElabComponent comp -> - Set.fromList (map confInstId (compLibDependencies comp - ++ compExeDependencies comp)), - pkgHashOtherConfig = packageHashConfigInputs pkgshared elab - } - where - -- Obviously the main deps are relevant - relevantDeps CD.ComponentLib = True - relevantDeps (CD.ComponentSubLib _) = True - relevantDeps (CD.ComponentFLib _) = True - relevantDeps (CD.ComponentExe _) = True - -- Setup deps can affect the Setup.hs behaviour and thus what is built - relevantDeps CD.ComponentSetup = True - -- However testsuites and benchmarks do not get installed and should not - -- affect the result, so we do not include them. - relevantDeps (CD.ComponentTest _) = False - relevantDeps (CD.ComponentBench _) = False - + :: ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> PackageHashInputs +packageHashInputs + pkgshared + elab@( ElaboratedConfiguredPackage + { elabPkgSourceHash = Just srchash + } + ) = + PackageHashInputs + { pkgHashPkgId = packageId elab + , pkgHashComponent = + case elabPkgOrComp elab of + ElabPackage _ -> Nothing + ElabComponent comp -> Just (compSolverName comp) + , pkgHashSourceHash = srchash + , pkgHashPkgConfigDeps = Set.fromList (elabPkgConfigDependencies elab) + , pkgHashDirectDeps = + case elabPkgOrComp elab of + ElabPackage (ElaboratedPackage{..}) -> + Set.fromList $ + [ confInstId dep + | dep <- CD.select relevantDeps pkgLibDependencies + ] + ++ [ confInstId dep + | dep <- CD.select relevantDeps pkgExeDependencies + ] + ElabComponent comp -> + Set.fromList + ( map + confInstId + ( compLibDependencies comp + ++ compExeDependencies comp + ) + ) + , pkgHashOtherConfig = packageHashConfigInputs pkgshared elab + } + where + -- Obviously the main deps are relevant + relevantDeps CD.ComponentLib = True + relevantDeps (CD.ComponentSubLib _) = True + relevantDeps (CD.ComponentFLib _) = True + relevantDeps (CD.ComponentExe _) = True + -- Setup deps can affect the Setup.hs behaviour and thus what is built + relevantDeps CD.ComponentSetup = True + -- However testsuites and benchmarks do not get installed and should not + -- affect the result, so we do not include them. + relevantDeps (CD.ComponentTest _) = False + relevantDeps (CD.ComponentBench _) = False packageHashInputs _ pkg = - error $ "packageHashInputs: only for packages with source hashes. " - ++ prettyShow (packageId pkg) + error $ + "packageHashInputs: only for packages with source hashes. " + ++ prettyShow (packageId pkg) -packageHashConfigInputs :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> PackageHashConfigInputs +packageHashConfigInputs + :: ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> PackageHashConfigInputs packageHashConfigInputs shared@ElaboratedSharedConfig{..} pkg = - PackageHashConfigInputs { - pkgHashCompilerId = compilerId pkgConfigCompiler, - pkgHashPlatform = pkgConfigPlatform, - pkgHashFlagAssignment = elabFlagAssignment, - pkgHashConfigureScriptArgs = elabConfigureScriptArgs, - pkgHashVanillaLib = elabVanillaLib, - pkgHashSharedLib = elabSharedLib, - pkgHashDynExe = elabDynExe, - pkgHashFullyStaticExe = elabFullyStaticExe, - pkgHashGHCiLib = elabGHCiLib, - pkgHashProfLib = elabProfLib, - pkgHashProfExe = elabProfExe, - pkgHashProfLibDetail = elabProfLibDetail, - pkgHashProfExeDetail = elabProfExeDetail, - pkgHashCoverage = elabCoverage, - pkgHashOptimization = elabOptimization, - pkgHashSplitSections = elabSplitSections, - pkgHashSplitObjs = elabSplitObjs, - pkgHashStripLibs = elabStripLibs, - pkgHashStripExes = elabStripExes, - pkgHashDebugInfo = elabDebugInfo, - pkgHashProgramArgs = elabProgramArgs, - pkgHashExtraLibDirs = elabExtraLibDirs, - pkgHashExtraLibDirsStatic = elabExtraLibDirsStatic, - pkgHashExtraFrameworkDirs = elabExtraFrameworkDirs, - pkgHashExtraIncludeDirs = elabExtraIncludeDirs, - pkgHashProgPrefix = elabProgPrefix, - pkgHashProgSuffix = elabProgSuffix, - pkgHashPackageDbs = elabPackageDbs, - - pkgHashDocumentation = elabBuildHaddocks, - pkgHashHaddockHoogle = elabHaddockHoogle, - pkgHashHaddockHtml = elabHaddockHtml, - pkgHashHaddockHtmlLocation = elabHaddockHtmlLocation, - pkgHashHaddockForeignLibs = elabHaddockForeignLibs, - pkgHashHaddockExecutables = elabHaddockExecutables, - pkgHashHaddockTestSuites = elabHaddockTestSuites, - pkgHashHaddockBenchmarks = elabHaddockBenchmarks, - pkgHashHaddockInternal = elabHaddockInternal, - pkgHashHaddockCss = elabHaddockCss, - pkgHashHaddockLinkedSource = elabHaddockLinkedSource, - pkgHashHaddockQuickJump = elabHaddockQuickJump, - pkgHashHaddockContents = elabHaddockContents, - pkgHashHaddockIndex = elabHaddockIndex, - pkgHashHaddockBaseUrl = elabHaddockBaseUrl, - pkgHashHaddockLib = elabHaddockLib, - pkgHashHaddockOutputDir = elabHaddockOutputDir + PackageHashConfigInputs + { pkgHashCompilerId = compilerId pkgConfigCompiler + , pkgHashPlatform = pkgConfigPlatform + , pkgHashFlagAssignment = elabFlagAssignment + , pkgHashConfigureScriptArgs = elabConfigureScriptArgs + , pkgHashVanillaLib = elabVanillaLib + , pkgHashSharedLib = elabSharedLib + , pkgHashDynExe = elabDynExe + , pkgHashFullyStaticExe = elabFullyStaticExe + , pkgHashGHCiLib = elabGHCiLib + , pkgHashProfLib = elabProfLib + , pkgHashProfExe = elabProfExe + , pkgHashProfLibDetail = elabProfLibDetail + , pkgHashProfExeDetail = elabProfExeDetail + , pkgHashCoverage = elabCoverage + , pkgHashOptimization = elabOptimization + , pkgHashSplitSections = elabSplitSections + , pkgHashSplitObjs = elabSplitObjs + , pkgHashStripLibs = elabStripLibs + , pkgHashStripExes = elabStripExes + , pkgHashDebugInfo = elabDebugInfo + , pkgHashProgramArgs = elabProgramArgs + , pkgHashExtraLibDirs = elabExtraLibDirs + , pkgHashExtraLibDirsStatic = elabExtraLibDirsStatic + , pkgHashExtraFrameworkDirs = elabExtraFrameworkDirs + , pkgHashExtraIncludeDirs = elabExtraIncludeDirs + , pkgHashProgPrefix = elabProgPrefix + , pkgHashProgSuffix = elabProgSuffix + , pkgHashPackageDbs = elabPackageDbs + , pkgHashDocumentation = elabBuildHaddocks + , pkgHashHaddockHoogle = elabHaddockHoogle + , pkgHashHaddockHtml = elabHaddockHtml + , pkgHashHaddockHtmlLocation = elabHaddockHtmlLocation + , pkgHashHaddockForeignLibs = elabHaddockForeignLibs + , pkgHashHaddockExecutables = elabHaddockExecutables + , pkgHashHaddockTestSuites = elabHaddockTestSuites + , pkgHashHaddockBenchmarks = elabHaddockBenchmarks + , pkgHashHaddockInternal = elabHaddockInternal + , pkgHashHaddockCss = elabHaddockCss + , pkgHashHaddockLinkedSource = elabHaddockLinkedSource + , pkgHashHaddockQuickJump = elabHaddockQuickJump + , pkgHashHaddockContents = elabHaddockContents + , pkgHashHaddockIndex = elabHaddockIndex + , pkgHashHaddockBaseUrl = elabHaddockBaseUrl + , pkgHashHaddockLib = elabHaddockLib + , pkgHashHaddockOutputDir = elabHaddockOutputDir } where ElaboratedConfiguredPackage{..} = normaliseConfiguredPackage shared pkg @@ -3965,22 +4432,22 @@ packageHashConfigInputs shared@ElaboratedSharedConfig{..} pkg = -- | Given the 'InstalledPackageIndex' for a nix-style package store, and an -- 'ElaboratedInstallPlan', replace configured source packages by installed -- packages from the store whenever they exist. --- -improveInstallPlanWithInstalledPackages :: Set UnitId - -> ElaboratedInstallPlan - -> ElaboratedInstallPlan +improveInstallPlanWithInstalledPackages + :: Set UnitId + -> ElaboratedInstallPlan + -> ElaboratedInstallPlan improveInstallPlanWithInstalledPackages installedPkgIdSet = - InstallPlan.installed canPackageBeImproved + InstallPlan.installed canPackageBeImproved where canPackageBeImproved pkg = installedUnitId pkg `Set.member` installedPkgIdSet - --TODO: sanity checks: - -- * the installed package must have the expected deps etc - -- * the installed package must not be broken, valid dep closure - --TODO: decide what to do if we encounter broken installed packages, - -- since overwriting is never safe. +-- TODO: sanity checks: +-- \* the installed package must have the expected deps etc +-- \* the installed package must not be broken, valid dep closure +-- TODO: decide what to do if we encounter broken installed packages, +-- since overwriting is never safe. -- Path construction ------ @@ -4012,6 +4479,6 @@ inplaceBinRoot -> ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> FilePath -inplaceBinRoot layout config package - = distBuildDirectory layout (elabDistDirParams config package) - "build" +inplaceBinRoot layout config package = + distBuildDirectory layout (elabDistDirParams config package) + "build" diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index 694b429c23a..7855a80683e 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -1,115 +1,118 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-} -- | Types used while planning how to build everything in a project. -- -- Primarily this is the 'ElaboratedInstallPlan'. --- -module Distribution.Client.ProjectPlanning.Types ( - SolverInstallPlan, +module Distribution.Client.ProjectPlanning.Types + ( SolverInstallPlan -- * Elaborated install plan types - ElaboratedInstallPlan, - normaliseConfiguredPackage, - ElaboratedConfiguredPackage(..), - - elabDistDirParams, - elabExeDependencyPaths, - elabLibDependencies, - elabOrderLibDependencies, - elabExeDependencies, - elabOrderExeDependencies, - elabSetupDependencies, - elabPkgConfigDependencies, - elabInplaceDependencyBuildCacheFiles, - elabRequiresRegistration, - dataDirsEnvironmentForPlan, - - elabPlanPackageName, - elabConfiguredName, - elabComponentName, - - ElaboratedPackageOrComponent(..), - ElaboratedComponent(..), - ElaboratedPackage(..), - pkgOrderDependencies, - ElaboratedPlanPackage, - ElaboratedSharedConfig(..), - ElaboratedReadyPackage, - BuildStyle(..), - CabalFileText, + , ElaboratedInstallPlan + , normaliseConfiguredPackage + , ElaboratedConfiguredPackage (..) + , elabDistDirParams + , elabExeDependencyPaths + , elabLibDependencies + , elabOrderLibDependencies + , elabExeDependencies + , elabOrderExeDependencies + , elabSetupDependencies + , elabPkgConfigDependencies + , elabInplaceDependencyBuildCacheFiles + , elabRequiresRegistration + , dataDirsEnvironmentForPlan + , elabPlanPackageName + , elabConfiguredName + , elabComponentName + , ElaboratedPackageOrComponent (..) + , ElaboratedComponent (..) + , ElaboratedPackage (..) + , pkgOrderDependencies + , ElaboratedPlanPackage + , ElaboratedSharedConfig (..) + , ElaboratedReadyPackage + , BuildStyle (..) + , CabalFileText -- * Build targets - ComponentTarget(..), - showComponentTarget, - showTestComponentTarget, - showBenchComponentTarget, - SubComponentTarget(..), - - isSubLibComponentTarget, - isForeignLibComponentTarget, - isExeComponentTarget, - isTestComponentTarget, - isBenchComponentTarget, - - componentOptionalStanza, + , ComponentTarget (..) + , showComponentTarget + , showTestComponentTarget + , showBenchComponentTarget + , SubComponentTarget (..) + , isSubLibComponentTarget + , isForeignLibComponentTarget + , isExeComponentTarget + , isTestComponentTarget + , isBenchComponentTarget + , componentOptionalStanza -- * Setup script - SetupScriptStyle(..), + , SetupScriptStyle (..) ) where -import Distribution.Client.Compat.Prelude -import Prelude () +import Distribution.Client.Compat.Prelude +import Prelude () -import Distribution.Client.TargetSelector - ( SubComponentTarget(..) ) -import Distribution.Client.PackageHash +import Distribution.Client.PackageHash +import Distribution.Client.TargetSelector + ( SubComponentTarget (..) + ) -import Distribution.Client.Types +import Distribution.Client.DistDirLayout +import Distribution.Client.InstallPlan + ( GenericInstallPlan + , GenericPlanPackage (..) + ) import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.InstallPlan - ( GenericInstallPlan, GenericPlanPackage(..) ) -import Distribution.Client.SolverInstallPlan - ( SolverInstallPlan ) -import Distribution.Client.DistDirLayout - -import Distribution.Backpack -import Distribution.Backpack.ModuleShape - -import Distribution.Verbosity (normal) -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.PkgconfigVersion -import Distribution.Types.PackageDescription (PackageDescription(..)) -import Distribution.Package -import Distribution.System +import Distribution.Client.SolverInstallPlan + ( SolverInstallPlan + ) +import Distribution.Client.Types + +import Distribution.Backpack +import Distribution.Backpack.ModuleShape + +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import Distribution.ModuleName (ModuleName) +import Distribution.Package import qualified Distribution.PackageDescription as Cabal -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import Distribution.Simple.Compiler -import Distribution.Simple.Build.PathsModule (pkgPathEnvVar) +import Distribution.Simple.Build.PathsModule (pkgPathEnvVar) import qualified Distribution.Simple.BuildTarget as Cabal -import Distribution.Simple.Program -import Distribution.ModuleName (ModuleName) -import Distribution.Simple.LocalBuildInfo - ( ComponentName(..), LibraryName(..) ) +import Distribution.Simple.Compiler +import Distribution.Simple.InstallDirs (PathTemplate) import qualified Distribution.Simple.InstallDirs as InstallDirs -import Distribution.Simple.InstallDirs (PathTemplate) -import Distribution.Simple.Setup - ( HaddockTarget, TestShowDetails, DumpBuildInfo (..), ReplOptions ) -import Distribution.Version - +import Distribution.Simple.LocalBuildInfo + ( ComponentName (..) + , LibraryName (..) + ) +import Distribution.Simple.Program +import Distribution.Simple.Setup + ( DumpBuildInfo (..) + , HaddockTarget + , ReplOptions + , TestShowDetails + ) +import Distribution.System +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.PackageDescription (PackageDescription (..)) +import Distribution.Types.PkgconfigVersion +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.ComponentDeps (ComponentDeps) -import Distribution.Solver.Types.OptionalStanza -import Distribution.Compat.Graph (IsNode(..)) -import Distribution.Simple.Utils (ordNub) +import Distribution.Solver.Types.OptionalStanza -import qualified Data.Map as Map import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map as Map import qualified Data.Monoid as Mon -import System.FilePath (()) - +import System.FilePath (()) -- | The combination of an elaborated install plan plus a -- 'ElaboratedSharedConfig' contains all the details necessary to be able @@ -117,234 +120,206 @@ import System.FilePath (()) -- -- It does not include dynamic elements such as resources (such as http -- connections). --- -type ElaboratedInstallPlan - = GenericInstallPlan InstalledPackageInfo - ElaboratedConfiguredPackage +type ElaboratedInstallPlan = + GenericInstallPlan + InstalledPackageInfo + ElaboratedConfiguredPackage -type ElaboratedPlanPackage - = GenericPlanPackage InstalledPackageInfo - ElaboratedConfiguredPackage +type ElaboratedPlanPackage = + GenericPlanPackage + InstalledPackageInfo + ElaboratedConfiguredPackage -- | User-friendly display string for an 'ElaboratedPlanPackage'. elabPlanPackageName :: Verbosity -> ElaboratedPlanPackage -> String elabPlanPackageName verbosity (PreExisting ipkg) - | verbosity <= normal = prettyShow (packageName ipkg) - | otherwise = prettyShow (installedUnitId ipkg) -elabPlanPackageName verbosity (Configured elab) - = elabConfiguredName verbosity elab -elabPlanPackageName verbosity (Installed elab) - = elabConfiguredName verbosity elab - ---TODO: [code cleanup] decide if we really need this, there's not much in it, and in principle + | verbosity <= normal = prettyShow (packageName ipkg) + | otherwise = prettyShow (installedUnitId ipkg) +elabPlanPackageName verbosity (Configured elab) = + elabConfiguredName verbosity elab +elabPlanPackageName verbosity (Installed elab) = + elabConfiguredName verbosity elab + +-- TODO: [code cleanup] decide if we really need this, there's not much in it, and in principle -- even platform and compiler could be different if we're building things -- like a server + client with ghc + ghcjs -data ElaboratedSharedConfig - = ElaboratedSharedConfig { - - pkgConfigPlatform :: Platform, - pkgConfigCompiler :: Compiler, --TODO: [code cleanup] replace with CompilerInfo - -- | The programs that the compiler configured (e.g. for GHC, the progs - -- ghc & ghc-pkg). Once constructed, only the 'configuredPrograms' are - -- used. - pkgConfigCompilerProgs :: ProgramDb, - pkgConfigReplOptions :: ReplOptions - } +data ElaboratedSharedConfig = ElaboratedSharedConfig + { pkgConfigPlatform :: Platform + , pkgConfigCompiler :: Compiler -- TODO: [code cleanup] replace with CompilerInfo + , pkgConfigCompilerProgs :: ProgramDb + -- ^ The programs that the compiler configured (e.g. for GHC, the progs + -- ghc & ghc-pkg). Once constructed, only the 'configuredPrograms' are + -- used. + , pkgConfigReplOptions :: ReplOptions + } deriving (Show, Generic, Typeable) - --TODO: [code cleanup] no Eq instance + +-- TODO: [code cleanup] no Eq instance instance Binary ElaboratedSharedConfig instance Structured ElaboratedSharedConfig -data ElaboratedConfiguredPackage - = ElaboratedConfiguredPackage { - -- | The 'UnitId' which uniquely identifies this item in a build plan - elabUnitId :: UnitId, - - elabComponentId :: ComponentId, - elabInstantiatedWith :: Map ModuleName Module, - elabLinkedInstantiatedWith :: Map ModuleName OpenModule, - - -- | This is true if this is an indefinite package, or this is a - -- package with no signatures. (Notably, it's not true for instantiated - -- packages.) The motivation for this is if you ask to build - -- @foo-indef@, this probably means that you want to typecheck - -- it, NOT that you want to rebuild all of the various - -- instantiations of it. - elabIsCanonical :: Bool, - - -- | The 'PackageId' of the originating package - elabPkgSourceId :: PackageId, - - -- | Shape of the package/component, for Backpack. - elabModuleShape :: ModuleShape, - - -- | A total flag assignment for the package. - -- TODO: Actually this can be per-component if we drop - -- all flags that don't affect a component. - elabFlagAssignment :: Cabal.FlagAssignment, - - -- | The original default flag assignment, used only for reporting. - elabFlagDefaults :: Cabal.FlagAssignment, - - elabPkgDescription :: Cabal.PackageDescription, - - -- | Where the package comes from, e.g. tarball, local dir etc. This - -- is not the same as where it may be unpacked to for the build. - elabPkgSourceLocation :: PackageLocation (Maybe FilePath), - - -- | The hash of the source, e.g. the tarball. We don't have this for - -- local source dir packages. - elabPkgSourceHash :: Maybe PackageSourceHash, - - -- | Is this package one of the ones specified by location in the - -- project file? (As opposed to a dependency, or a named package pulled - -- in) - elabLocalToProject :: Bool, - - -- | Are we going to build and install this package to the store, or are - -- we going to build it and register it locally. - elabBuildStyle :: BuildStyle, - - -- | Another way of phrasing 'pkgStanzasAvailable'. - elabEnabledSpec :: ComponentRequestedSpec, - - -- | Which optional stanzas (ie testsuites, benchmarks) can be built. - -- This means the solver produced a plan that has them available. - -- This doesn't necessary mean we build them by default. - elabStanzasAvailable :: OptionalStanzaSet, - - -- | Which optional stanzas the user explicitly asked to enable or - -- to disable. This tells us which ones we build by default, and - -- helps with error messages when the user asks to build something - -- they explicitly disabled. - -- - -- TODO: The 'Bool' here should be refined into an ADT with three - -- cases: NotRequested, ExplicitlyRequested and - -- ImplicitlyRequested. A stanza is explicitly requested if - -- the user asked, for this *specific* package, that the stanza - -- be enabled; it's implicitly requested if the user asked for - -- all global packages to have this stanza enabled. The - -- difference between an explicit and implicit request is - -- error reporting behavior: if a user asks for tests to be - -- enabled for a specific package that doesn't have any tests, - -- we should warn them about it, but we shouldn't complain - -- 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.) - elabStanzasRequested :: OptionalStanzaMap (Maybe Bool), - - elabPackageDbs :: [Maybe PackageDB], - elabSetupPackageDBStack :: PackageDBStack, - elabBuildPackageDBStack :: PackageDBStack, - elabRegisterPackageDBStack :: PackageDBStack, - - elabInplaceSetupPackageDBStack :: PackageDBStack, - elabInplaceBuildPackageDBStack :: PackageDBStack, - elabInplaceRegisterPackageDBStack :: PackageDBStack, - - elabPkgDescriptionOverride :: Maybe CabalFileText, - - -- TODO: make per-component variants of these flags - elabVanillaLib :: Bool, - elabSharedLib :: Bool, - elabStaticLib :: Bool, - elabDynExe :: Bool, - elabFullyStaticExe :: Bool, - elabGHCiLib :: Bool, - elabProfLib :: Bool, - elabProfExe :: Bool, - elabProfLibDetail :: ProfDetailLevel, - elabProfExeDetail :: ProfDetailLevel, - elabCoverage :: Bool, - elabOptimization :: OptimisationLevel, - elabSplitObjs :: Bool, - elabSplitSections :: Bool, - elabStripLibs :: Bool, - elabStripExes :: Bool, - elabDebugInfo :: DebugInfoLevel, - elabDumpBuildInfo :: DumpBuildInfo, - - elabProgramPaths :: Map String FilePath, - elabProgramArgs :: Map String [String], - elabProgramPathExtra :: [FilePath], - elabConfigureScriptArgs :: [String], - elabExtraLibDirs :: [FilePath], - elabExtraLibDirsStatic :: [FilePath], - elabExtraFrameworkDirs :: [FilePath], - elabExtraIncludeDirs :: [FilePath], - elabProgPrefix :: Maybe PathTemplate, - elabProgSuffix :: Maybe PathTemplate, - - elabInstallDirs :: InstallDirs.InstallDirs FilePath, - - elabHaddockHoogle :: Bool, - elabHaddockHtml :: Bool, - elabHaddockHtmlLocation :: Maybe String, - elabHaddockForeignLibs :: Bool, - elabHaddockForHackage :: HaddockTarget, - elabHaddockExecutables :: Bool, - elabHaddockTestSuites :: Bool, - elabHaddockBenchmarks :: Bool, - elabHaddockInternal :: Bool, - elabHaddockCss :: Maybe FilePath, - elabHaddockLinkedSource :: Bool, - elabHaddockQuickJump :: Bool, - elabHaddockHscolourCss :: Maybe FilePath, - elabHaddockContents :: Maybe PathTemplate, - elabHaddockIndex :: Maybe PathTemplate, - elabHaddockBaseUrl :: Maybe String, - elabHaddockLib :: Maybe String, - elabHaddockOutputDir :: Maybe FilePath, - - elabTestMachineLog :: Maybe PathTemplate, - elabTestHumanLog :: Maybe PathTemplate, - elabTestShowDetails :: Maybe TestShowDetails, - elabTestKeepTix :: Bool, - elabTestWrapper :: Maybe FilePath, - elabTestFailWhenNoTestSuites :: Bool, - elabTestTestOptions :: [PathTemplate], - - elabBenchmarkOptions :: [PathTemplate], - - -- Setup.hs related things: - - -- | One of four modes for how we build and interact with the Setup.hs - -- script, based on whether it's a build-type Custom, with or without - -- explicit deps and the cabal spec version the .cabal file needs. - elabSetupScriptStyle :: SetupScriptStyle, - - -- | The version of the Cabal command line interface that we are using - -- for this package. This is typically the version of the Cabal lib - -- that the Setup.hs is built against. - -- - -- TODO: We might want to turn this into a enum, - -- yet different enum than 'CabalSpecVersion'. - elabSetupScriptCliVersion :: Version, - - -- Build time related: - elabConfigureTargets :: [ComponentTarget], - elabBuildTargets :: [ComponentTarget], - elabTestTargets :: [ComponentTarget], - elabBenchTargets :: [ComponentTarget], - elabReplTarget :: Maybe ComponentTarget, - elabHaddockTargets :: [ComponentTarget], - - elabBuildHaddocks :: Bool, - - --pkgSourceDir ? -- currently passed in later because they can use temp locations - --pkgBuildDir ? -- but could in principle still have it here, with optional instr to use temp loc - - -- | Component/package specific information - elabPkgOrComp :: ElaboratedPackageOrComponent - } +data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage + { elabUnitId :: UnitId + -- ^ The 'UnitId' which uniquely identifies this item in a build plan + , elabComponentId :: ComponentId + , elabInstantiatedWith :: Map ModuleName Module + , elabLinkedInstantiatedWith :: Map ModuleName OpenModule + , elabIsCanonical :: Bool + -- ^ This is true if this is an indefinite package, or this is a + -- package with no signatures. (Notably, it's not true for instantiated + -- packages.) The motivation for this is if you ask to build + -- @foo-indef@, this probably means that you want to typecheck + -- it, NOT that you want to rebuild all of the various + -- instantiations of it. + , elabPkgSourceId :: PackageId + -- ^ The 'PackageId' of the originating package + , elabModuleShape :: ModuleShape + -- ^ Shape of the package/component, for Backpack. + , elabFlagAssignment :: Cabal.FlagAssignment + -- ^ A total flag assignment for the package. + -- TODO: Actually this can be per-component if we drop + -- all flags that don't affect a component. + , elabFlagDefaults :: Cabal.FlagAssignment + -- ^ The original default flag assignment, used only for reporting. + , elabPkgDescription :: Cabal.PackageDescription + , elabPkgSourceLocation :: PackageLocation (Maybe FilePath) + -- ^ Where the package comes from, e.g. tarball, local dir etc. This + -- is not the same as where it may be unpacked to for the build. + , elabPkgSourceHash :: Maybe PackageSourceHash + -- ^ The hash of the source, e.g. the tarball. We don't have this for + -- local source dir packages. + , elabLocalToProject :: Bool + -- ^ Is this package one of the ones specified by location in the + -- project file? (As opposed to a dependency, or a named package pulled + -- in) + , elabBuildStyle :: BuildStyle + -- ^ Are we going to build and install this package to the store, or are + -- we going to build it and register it locally. + , elabEnabledSpec :: ComponentRequestedSpec + -- ^ Another way of phrasing 'pkgStanzasAvailable'. + , elabStanzasAvailable :: OptionalStanzaSet + -- ^ Which optional stanzas (ie testsuites, benchmarks) can be built. + -- This means the solver produced a plan that has them available. + -- This doesn't necessary mean we build them by default. + , elabStanzasRequested :: OptionalStanzaMap (Maybe Bool) + -- ^ Which optional stanzas the user explicitly asked to enable or + -- to disable. This tells us which ones we build by default, and + -- helps with error messages when the user asks to build something + -- they explicitly disabled. + -- + -- TODO: The 'Bool' here should be refined into an ADT with three + -- cases: NotRequested, ExplicitlyRequested and + -- ImplicitlyRequested. A stanza is explicitly requested if + -- the user asked, for this *specific* package, that the stanza + -- be enabled; it's implicitly requested if the user asked for + -- all global packages to have this stanza enabled. The + -- difference between an explicit and implicit request is + -- error reporting behavior: if a user asks for tests to be + -- enabled for a specific package that doesn't have any tests, + -- we should warn them about it, but we shouldn't complain + -- 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 + , elabPkgDescriptionOverride :: Maybe CabalFileText + , -- TODO: make per-component variants of these flags + elabVanillaLib :: Bool + , elabSharedLib :: Bool + , elabStaticLib :: Bool + , elabDynExe :: Bool + , elabFullyStaticExe :: Bool + , elabGHCiLib :: Bool + , elabProfLib :: Bool + , elabProfExe :: Bool + , elabProfLibDetail :: ProfDetailLevel + , elabProfExeDetail :: ProfDetailLevel + , elabCoverage :: Bool + , elabOptimization :: OptimisationLevel + , elabSplitObjs :: Bool + , elabSplitSections :: Bool + , elabStripLibs :: Bool + , elabStripExes :: Bool + , elabDebugInfo :: DebugInfoLevel + , elabDumpBuildInfo :: DumpBuildInfo + , elabProgramPaths :: Map String FilePath + , elabProgramArgs :: Map String [String] + , elabProgramPathExtra :: [FilePath] + , elabConfigureScriptArgs :: [String] + , elabExtraLibDirs :: [FilePath] + , elabExtraLibDirsStatic :: [FilePath] + , elabExtraFrameworkDirs :: [FilePath] + , elabExtraIncludeDirs :: [FilePath] + , elabProgPrefix :: Maybe PathTemplate + , elabProgSuffix :: Maybe PathTemplate + , elabInstallDirs :: InstallDirs.InstallDirs FilePath + , elabHaddockHoogle :: Bool + , elabHaddockHtml :: Bool + , elabHaddockHtmlLocation :: Maybe String + , elabHaddockForeignLibs :: Bool + , elabHaddockForHackage :: HaddockTarget + , elabHaddockExecutables :: Bool + , elabHaddockTestSuites :: Bool + , elabHaddockBenchmarks :: Bool + , elabHaddockInternal :: Bool + , elabHaddockCss :: Maybe FilePath + , elabHaddockLinkedSource :: Bool + , elabHaddockQuickJump :: Bool + , elabHaddockHscolourCss :: Maybe FilePath + , elabHaddockContents :: Maybe PathTemplate + , elabHaddockIndex :: Maybe PathTemplate + , elabHaddockBaseUrl :: Maybe String + , elabHaddockLib :: Maybe String + , elabHaddockOutputDir :: Maybe FilePath + , elabTestMachineLog :: Maybe PathTemplate + , elabTestHumanLog :: Maybe PathTemplate + , elabTestShowDetails :: Maybe TestShowDetails + , elabTestKeepTix :: Bool + , elabTestWrapper :: Maybe FilePath + , elabTestFailWhenNoTestSuites :: Bool + , elabTestTestOptions :: [PathTemplate] + , elabBenchmarkOptions :: [PathTemplate] + , -- Setup.hs related things: + + elabSetupScriptStyle :: SetupScriptStyle + -- ^ One of four modes for how we build and interact with the Setup.hs + -- script, based on whether it's a build-type Custom, with or without + -- explicit deps and the cabal spec version the .cabal file needs. + , elabSetupScriptCliVersion :: Version + -- ^ The version of the Cabal command line interface that we are using + -- for this package. This is typically the version of the Cabal lib + -- that the Setup.hs is built against. + -- + -- TODO: We might want to turn this into a enum, + -- yet different enum than 'CabalSpecVersion'. + , -- Build time related: + elabConfigureTargets :: [ComponentTarget] + , elabBuildTargets :: [ComponentTarget] + , elabTestTargets :: [ComponentTarget] + , elabBenchTargets :: [ComponentTarget] + , elabReplTarget :: Maybe ComponentTarget + , elabHaddockTargets :: [ComponentTarget] + , elabBuildHaddocks :: Bool + , -- pkgSourceDir ? -- currently passed in later because they can use temp locations + -- pkgBuildDir ? -- but could in principle still have it here, with optional instr to use temp loc + + elabPkgOrComp :: ElaboratedPackageOrComponent + -- ^ Component/package specific information + } deriving (Eq, Show, Generic, Typeable) -normaliseConfiguredPackage :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> ElaboratedConfiguredPackage +normaliseConfiguredPackage + :: ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> ElaboratedConfiguredPackage normaliseConfiguredPackage ElaboratedSharedConfig{pkgConfigCompilerProgs} pkg = - pkg { elabProgramArgs = Map.mapMaybeWithKey lookupFilter (elabProgramArgs pkg) } + pkg{elabProgramArgs = Map.mapMaybeWithKey lookupFilter (elabProgramArgs pkg)} where knownProgramDb = addKnownPrograms builtinPrograms pkgConfigCompilerProgs @@ -357,8 +332,8 @@ normaliseConfiguredPackage ElaboratedSharedConfig{pkgConfigCompilerProgs} pkg = lookupFilter :: String -> [String] -> Maybe [String] lookupFilter n args = removeEmpty $ case lookupKnownProgram n knownProgramDb of - Just p -> programNormaliseArgs p (getVersion p) pkgDesc args - Nothing -> args + Just p -> programNormaliseArgs p (getVersion p) pkgDesc args + Nothing -> args getVersion :: Program -> Maybe Version getVersion p = lookupProgram p knownProgramDb >>= programVersion @@ -366,50 +341,57 @@ normaliseConfiguredPackage ElaboratedSharedConfig{pkgConfigCompilerProgs} pkg = -- | The package/component contains/is a library and so must be registered elabRequiresRegistration :: ElaboratedConfiguredPackage -> Bool elabRequiresRegistration elab = - case elabPkgOrComp elab of - ElabComponent comp -> - case compComponentName comp of - Just cn -> is_lib cn && build_target - _ -> False - ElabPackage pkg -> - -- Tricky! Not only do we have to test if the user selected - -- a library as a build target, we also have to test if - -- the library was TRANSITIVELY depended upon, since we will - -- also require a register in this case. - -- - -- NB: It would have been far nicer to just unconditionally - -- register in all cases, but some Custom Setups will fall - -- over if you try to do that, ESPECIALLY if there actually is - -- a library but they hadn't built it. - -- - -- However, as the case of `cpphs-1.20.8` has shown in - -- #5379, in cases when a monolithic package gets - -- installed due to its executable components - -- (i.e. exe:cpphs) into the store we *have* to register - -- if there's a buildable public library (i.e. lib:cpphs) - -- that was built and installed into the same store folder - -- as otherwise this will cause build failures once a - -- target actually depends on lib:cpphs. - build_target || (elabBuildStyle elab == BuildAndInstall && - Cabal.hasPublicLib (elabPkgDescription elab)) - -- the next sub-condition below is currently redundant - -- (see discussion in #5604 for more details), but it's - -- being kept intentionally here as a safeguard because if - -- internal libraries ever start working with - -- non-per-component builds this condition won't be - -- redundant anymore. - || any (depends_on_lib pkg) (elabBuildTargets elab) + case elabPkgOrComp elab of + ElabComponent comp -> + case compComponentName comp of + Just cn -> is_lib cn && build_target + _ -> False + ElabPackage pkg -> + -- Tricky! Not only do we have to test if the user selected + -- a library as a build target, we also have to test if + -- the library was TRANSITIVELY depended upon, since we will + -- also require a register in this case. + -- + -- NB: It would have been far nicer to just unconditionally + -- register in all cases, but some Custom Setups will fall + -- over if you try to do that, ESPECIALLY if there actually is + -- a library but they hadn't built it. + -- + -- However, as the case of `cpphs-1.20.8` has shown in + -- #5379, in cases when a monolithic package gets + -- installed due to its executable components + -- (i.e. exe:cpphs) into the store we *have* to register + -- if there's a buildable public library (i.e. lib:cpphs) + -- that was built and installed into the same store folder + -- as otherwise this will cause build failures once a + -- target actually depends on lib:cpphs. + build_target + || ( elabBuildStyle elab == BuildAndInstall + && Cabal.hasPublicLib (elabPkgDescription elab) + ) + -- the next sub-condition below is currently redundant + -- (see discussion in #5604 for more details), but it's + -- being kept intentionally here as a safeguard because if + -- internal libraries ever start working with + -- non-per-component builds this condition won't be + -- redundant anymore. + || any (depends_on_lib pkg) (elabBuildTargets elab) where depends_on_lib pkg (ComponentTarget cn _) = - not (null (CD.select (== CD.componentNameToComponent cn) - (pkgDependsOnSelfLib pkg))) + not + ( null + ( CD.select + (== CD.componentNameToComponent cn) + (pkgDependsOnSelfLib pkg) + ) + ) build_target = - if not (null (elabBuildTargets elab)) - then any is_lib_target (elabBuildTargets elab) - -- Empty build targets mean we build /everything/; - -- that means we have to look more carefully to see - -- if there is anything to register - else Cabal.hasLibs (elabPkgDescription elab) + if not (null (elabBuildTargets elab)) + then any is_lib_target (elabBuildTargets elab) + else -- Empty build targets mean we build /everything/; + -- that means we have to look more carefully to see + -- if there is anything to register + Cabal.hasLibs (elabPkgDescription elab) -- NB: this means we DO NOT reregister if you just built a -- single file is_lib_target (ComponentTarget cn WholeComponent) = is_lib cn @@ -420,14 +402,18 @@ elabRequiresRegistration elab = -- | Construct the environment needed for the data files to work. -- This consists of a separate @*_datadir@ variable for each -- inplace package in the plan. -dataDirsEnvironmentForPlan :: DistDirLayout - -> ElaboratedInstallPlan - -> [(String, Maybe FilePath)] -dataDirsEnvironmentForPlan distDirLayout = catMaybes - . fmap (InstallPlan.foldPlanPackage - (const Nothing) - (dataDirEnvVarForPackage distDirLayout)) - . InstallPlan.toList +dataDirsEnvironmentForPlan + :: DistDirLayout + -> ElaboratedInstallPlan + -> [(String, Maybe FilePath)] +dataDirsEnvironmentForPlan distDirLayout = + catMaybes + . fmap + ( InstallPlan.foldPlanPackage + (const Nothing) + (dataDirEnvVarForPackage distDirLayout) + ) + . InstallPlan.toList -- | Construct an environment variable that points -- the package's datadir to its correct location. @@ -436,16 +422,20 @@ dataDirsEnvironmentForPlan distDirLayout = catMaybes -- for inplace packages. -- * 'Nothing' for packages installed in the store (the path was -- already included in the package at install/build time). -dataDirEnvVarForPackage :: DistDirLayout - -> ElaboratedConfiguredPackage - -> Maybe (String, Maybe FilePath) +dataDirEnvVarForPackage + :: DistDirLayout + -> ElaboratedConfiguredPackage + -> Maybe (String, Maybe FilePath) dataDirEnvVarForPackage distDirLayout pkg = - case elabBuildStyle pkg - of BuildAndInstall -> Nothing - BuildInplaceOnly -> Just - ( pkgPathEnvVar (elabPkgDescription pkg) "datadir" - , Just $ srcPath (elabPkgSourceLocation pkg) - dataDir (elabPkgDescription pkg)) + case elabBuildStyle pkg of + BuildAndInstall -> Nothing + BuildInplaceOnly -> + Just + ( pkgPathEnvVar (elabPkgDescription pkg) "datadir" + , Just $ + srcPath (elabPkgSourceLocation pkg) + dataDir (elabPkgDescription pkg) + ) where srcPath (LocalUnpackedPackage path) = path srcPath (LocalTarballPackage _path) = unpackedPath @@ -453,8 +443,9 @@ dataDirEnvVarForPackage distDirLayout pkg = srcPath (RepoTarballPackage _repo _packageId _localTar) = unpackedPath srcPath (RemoteSourceRepoPackage _sourceRepo (Just localCheckout)) = localCheckout -- TODO: see https://github.com/haskell/cabal/wiki/Potential-Refactors#unresolvedpkgloc - srcPath (RemoteSourceRepoPackage _sourceRepo Nothing) = error - "calling dataDirEnvVarForPackage on a not-downloaded repo is an error" + srcPath (RemoteSourceRepoPackage _sourceRepo Nothing) = + error + "calling dataDirEnvVarForPackage on a not-downloaded repo is an error" unpackedPath = distUnpackedSrcDirectory distDirLayout $ elabPkgSourceId pkg @@ -469,16 +460,16 @@ instance HasUnitId ElaboratedConfiguredPackage where installedUnitId = elabUnitId instance IsNode ElaboratedConfiguredPackage where - type Key ElaboratedConfiguredPackage = UnitId - nodeKey = elabUnitId - nodeNeighbors = elabOrderDependencies + type Key ElaboratedConfiguredPackage = UnitId + nodeKey = elabUnitId + nodeNeighbors = elabOrderDependencies instance Binary ElaboratedConfiguredPackage instance Structured ElaboratedConfiguredPackage data ElaboratedPackageOrComponent - = ElabPackage ElaboratedPackage - | ElabComponent ElaboratedComponent + = ElabPackage ElaboratedPackage + | ElabComponent ElaboratedComponent deriving (Eq, Show, Generic) instance Binary ElaboratedPackageOrComponent @@ -486,36 +477,38 @@ instance Structured ElaboratedPackageOrComponent elabComponentName :: ElaboratedConfiguredPackage -> Maybe ComponentName elabComponentName elab = - case elabPkgOrComp elab of - ElabPackage _ -> Just $ CLibName LMainLibName -- there could be more, but default this - ElabComponent comp -> compComponentName comp + case elabPkgOrComp elab of + ElabPackage _ -> Just $ CLibName LMainLibName -- there could be more, but default this + ElabComponent comp -> compComponentName comp -- | A user-friendly descriptor for an 'ElaboratedConfiguredPackage'. elabConfiguredName :: Verbosity -> ElaboratedConfiguredPackage -> String elabConfiguredName verbosity elab - | verbosity <= normal - = (case elabPkgOrComp elab of - ElabPackage _ -> "" - ElabComponent comp -> + | verbosity <= normal = + ( case elabPkgOrComp elab of + ElabPackage _ -> "" + ElabComponent comp -> case compComponentName comp of - Nothing -> "setup from " - Just (CLibName LMainLibName) -> "" - Just cname -> prettyShow cname ++ " from ") - ++ prettyShow (packageId elab) - | otherwise - = prettyShow (elabUnitId elab) + Nothing -> "setup from " + Just (CLibName LMainLibName) -> "" + Just cname -> prettyShow cname ++ " from " + ) + ++ prettyShow (packageId elab) + | otherwise = + prettyShow (elabUnitId elab) elabDistDirParams :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> DistDirParams -elabDistDirParams shared elab = DistDirParams { - distParamUnitId = installedUnitId elab, - distParamComponentId = elabComponentId elab, - distParamPackageId = elabPkgSourceId elab, - distParamComponentName = case elabPkgOrComp elab of - ElabComponent comp -> compComponentName comp - ElabPackage _ -> Nothing, - distParamCompilerId = compilerId (pkgConfigCompiler shared), - distParamPlatform = pkgConfigPlatform shared, - distParamOptimization = elabOptimization elab +elabDistDirParams shared elab = + DistDirParams + { distParamUnitId = installedUnitId elab + , distParamComponentId = elabComponentId elab + , distParamPackageId = elabPkgSourceId elab + , distParamComponentName = case elabPkgOrComp elab of + ElabComponent comp -> compComponentName comp + ElabPackage _ -> Nothing + , distParamCompilerId = compilerId (pkgConfigCompiler shared) + , distParamPlatform = pkgConfigPlatform shared + , distParamOptimization = elabOptimization elab } -- | The full set of dependencies which dictate what order we @@ -529,44 +522,46 @@ elabDistDirParams shared elab = DistDirParams { -- NB: this method DOES include setup deps. elabOrderDependencies :: ElaboratedConfiguredPackage -> [UnitId] elabOrderDependencies elab = - case elabPkgOrComp elab of - -- Important not to have duplicates: otherwise InstallPlan gets - -- confused. - ElabPackage pkg -> ordNub (CD.flatDeps (pkgOrderDependencies pkg)) - ElabComponent comp -> compOrderDependencies comp + case elabPkgOrComp elab of + -- Important not to have duplicates: otherwise InstallPlan gets + -- confused. + ElabPackage pkg -> ordNub (CD.flatDeps (pkgOrderDependencies pkg)) + ElabComponent comp -> compOrderDependencies comp -- | Like 'elabOrderDependencies', but only returns dependencies on -- libraries. elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [UnitId] elabOrderLibDependencies elab = - case elabPkgOrComp elab of - ElabPackage pkg -> map (newSimpleUnitId . confInstId) $ - ordNub $ CD.flatDeps (pkgLibDependencies pkg) - ElabComponent comp -> compOrderLibDependencies comp + case elabPkgOrComp elab of + ElabPackage pkg -> + map (newSimpleUnitId . confInstId) $ + ordNub $ + CD.flatDeps (pkgLibDependencies pkg) + ElabComponent comp -> compOrderLibDependencies comp -- | The library dependencies (i.e., the libraries we depend on, NOT -- the dependencies of the library), NOT including setup dependencies. -- These are passed to the @Setup@ script via @--dependency@. elabLibDependencies :: ElaboratedConfiguredPackage -> [ConfiguredId] elabLibDependencies elab = - case elabPkgOrComp elab of - ElabPackage pkg -> ordNub (CD.nonSetupDeps (pkgLibDependencies pkg)) - ElabComponent comp -> compLibDependencies comp + case elabPkgOrComp elab of + ElabPackage pkg -> ordNub (CD.nonSetupDeps (pkgLibDependencies pkg)) + ElabComponent comp -> compLibDependencies comp -- | Like 'elabOrderDependencies', but only returns dependencies on -- executables. (This coincides with 'elabExeDependencies'.) elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [UnitId] elabOrderExeDependencies = - map newSimpleUnitId . elabExeDependencies + map newSimpleUnitId . elabExeDependencies -- | The executable dependencies (i.e., the executables we depend on); -- these are the executables we must add to the PATH before we invoke -- the setup script. elabExeDependencies :: ElaboratedConfiguredPackage -> [ComponentId] elabExeDependencies elab = map confInstId $ - case elabPkgOrComp elab of - ElabPackage pkg -> CD.nonSetupDeps (pkgExeDependencies pkg) - ElabComponent comp -> compExeDependencies comp + case elabPkgOrComp elab of + ElabPackage pkg -> CD.nonSetupDeps (pkgExeDependencies pkg) + ElabComponent comp -> compExeDependencies comp -- | This returns the paths of all the executables we depend on; we -- must add these paths to PATH before invoking the setup script. @@ -574,26 +569,26 @@ elabExeDependencies elab = map confInstId $ -- actually want to build something.) elabExeDependencyPaths :: ElaboratedConfiguredPackage -> [FilePath] elabExeDependencyPaths elab = - case elabPkgOrComp elab of - ElabPackage pkg -> map snd $ CD.nonSetupDeps (pkgExeDependencyPaths pkg) - ElabComponent comp -> map snd (compExeDependencyPaths comp) + case elabPkgOrComp elab of + ElabPackage pkg -> map snd $ CD.nonSetupDeps (pkgExeDependencyPaths pkg) + ElabComponent comp -> map snd (compExeDependencyPaths comp) -- | The setup dependencies (the library dependencies of the setup executable; -- note that it is not legal for setup scripts to have executable -- dependencies at the moment.) elabSetupDependencies :: ElaboratedConfiguredPackage -> [ConfiguredId] elabSetupDependencies elab = - case elabPkgOrComp elab of - ElabPackage pkg -> CD.setupDeps (pkgLibDependencies pkg) - -- TODO: Custom setups not supported for components yet. When - -- they are, need to do this differently - ElabComponent _ -> [] + case elabPkgOrComp elab of + ElabPackage pkg -> CD.setupDeps (pkgLibDependencies pkg) + -- TODO: Custom setups not supported for components yet. When + -- they are, need to do this differently + ElabComponent _ -> [] elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PkgconfigName, Maybe PkgconfigVersion)] -elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage pkg } - = pkgPkgConfigDependencies pkg -elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } - = compPkgConfigDependencies comp +elabPkgConfigDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage pkg} = + pkgPkgConfigDependencies pkg +elabPkgConfigDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent comp} = + compPkgConfigDependencies comp -- | The cache files of all our inplace dependencies which, -- when updated, require us to rebuild. See #4202 for @@ -616,17 +611,17 @@ elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabComp -- here will never work if we want to implement unchanging -- rebuilds. elabInplaceDependencyBuildCacheFiles - :: DistDirLayout - -> ElaboratedSharedConfig - -> ElaboratedInstallPlan - -> ElaboratedConfiguredPackage - -> [FilePath] + :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedConfiguredPackage + -> [FilePath] elabInplaceDependencyBuildCacheFiles layout sconf plan root_elab = - go =<< InstallPlan.directDeps plan (nodeKey root_elab) + go =<< InstallPlan.directDeps plan (nodeKey root_elab) where go = InstallPlan.foldPlanPackage (const []) $ \elab -> do - guard (elabBuildStyle elab == BuildInplaceOnly) - return $ distPackageCacheFile layout (elabDistDirParams sconf elab) "build" + guard (elabBuildStyle elab == BuildInplaceOnly) + return $ distPackageCacheFile layout (elabDistDirParams sconf elab) "build" -- | Some extra metadata associated with an -- 'ElaboratedConfiguredPackage' which indicates that the "package" @@ -635,42 +630,41 @@ elabInplaceDependencyBuildCacheFiles layout sconf plan root_elab = -- package work items and component work items, but I've structured -- it this way to minimize change to the existing code (which I -- don't feel qualified to rewrite.) -data ElaboratedComponent - = ElaboratedComponent { - -- | The name of the component to be built according to the solver - compSolverName :: CD.Component, - -- | The name of the component to be built. Nothing if - -- it's a setup dep. - compComponentName :: Maybe ComponentName, - -- | The *external* library dependencies of this component. We - -- pass this to the configure script. - compLibDependencies :: [ConfiguredId], - -- | In a component prior to instantiation, this list specifies - -- the 'OpenUnitId's which, after instantiation, are the - -- actual dependencies of this package. Note that this does - -- NOT include signature packages, which do not turn into real - -- ordering dependencies when we instantiate. This is intended to be - -- a purely temporary field, to carry some information to the - -- instantiation phase. It's more precise than - -- 'compLibDependencies', and also stores information about internal - -- dependencies. - compLinkedLibDependencies :: [OpenUnitId], - -- | The executable dependencies of this component (including - -- internal executables). - compExeDependencies :: [ConfiguredId], - -- | The @pkg-config@ dependencies of the component - compPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)], - -- | The paths all our executable dependencies will be installed - -- to once they are installed. - compExeDependencyPaths :: [(ConfiguredId, FilePath)], - -- | The UnitIds of the libraries (identifying elaborated packages/ - -- components) that must be built before this project. This - -- is used purely for ordering purposes. It can contain both - -- references to definite and indefinite packages; an indefinite - -- UnitId indicates that we must typecheck that indefinite package - -- before we can build this one. - compOrderLibDependencies :: [UnitId] - } +data ElaboratedComponent = ElaboratedComponent + { compSolverName :: CD.Component + -- ^ The name of the component to be built according to the solver + , compComponentName :: Maybe ComponentName + -- ^ The name of the component to be built. Nothing if + -- it's a setup dep. + , compLibDependencies :: [ConfiguredId] + -- ^ The *external* library dependencies of this component. We + -- pass this to the configure script. + , compLinkedLibDependencies :: [OpenUnitId] + -- ^ In a component prior to instantiation, this list specifies + -- the 'OpenUnitId's which, after instantiation, are the + -- actual dependencies of this package. Note that this does + -- NOT include signature packages, which do not turn into real + -- ordering dependencies when we instantiate. This is intended to be + -- a purely temporary field, to carry some information to the + -- instantiation phase. It's more precise than + -- 'compLibDependencies', and also stores information about internal + -- dependencies. + , compExeDependencies :: [ConfiguredId] + -- ^ The executable dependencies of this component (including + -- internal executables). + , compPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)] + -- ^ The @pkg-config@ dependencies of the component + , compExeDependencyPaths :: [(ConfiguredId, FilePath)] + -- ^ The paths all our executable dependencies will be installed + -- to once they are installed. + , compOrderLibDependencies :: [UnitId] + -- ^ The UnitIds of the libraries (identifying elaborated packages/ + -- components) that must be built before this project. This + -- is used purely for ordering purposes. It can contain both + -- references to definite and indefinite packages; an indefinite + -- UnitId indicates that we must typecheck that indefinite package + -- before we can build this one. + } deriving (Eq, Show, Generic) instance Binary ElaboratedComponent @@ -679,47 +673,35 @@ instance Structured ElaboratedComponent -- | See 'elabOrderDependencies'. compOrderDependencies :: ElaboratedComponent -> [UnitId] compOrderDependencies comp = - compOrderLibDependencies comp - ++ compOrderExeDependencies comp + compOrderLibDependencies comp + ++ compOrderExeDependencies comp -- | See 'elabOrderExeDependencies'. compOrderExeDependencies :: ElaboratedComponent -> [UnitId] compOrderExeDependencies = map (newSimpleUnitId . confInstId) . compExeDependencies -data ElaboratedPackage - = ElaboratedPackage { - pkgInstalledId :: InstalledPackageId, - - -- | The exact dependencies (on other plan packages) - -- - pkgLibDependencies :: ComponentDeps [ConfiguredId], - - -- | Components which depend (transitively) on an internally - -- defined library. These are used by 'elabRequiresRegistration', - -- to determine if a user-requested build is going to need - -- a library registration - -- - pkgDependsOnSelfLib :: ComponentDeps [()], - - -- | Dependencies on executable packages. - -- - pkgExeDependencies :: ComponentDeps [ConfiguredId], - - -- | Paths where executable dependencies live. - -- - pkgExeDependencyPaths :: ComponentDeps [(ConfiguredId, FilePath)], - - -- | Dependencies on @pkg-config@ packages. - -- NB: this is NOT per-component (although it could be) - -- because Cabal library does not track per-component - -- pkg-config depends; it always does them all at once. - -- - pkgPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)], - - -- | Which optional stanzas (ie testsuites, benchmarks) will actually - -- be enabled during the package configure step. - pkgStanzasEnabled :: OptionalStanzaSet - } +data ElaboratedPackage = ElaboratedPackage + { pkgInstalledId :: InstalledPackageId + , pkgLibDependencies :: ComponentDeps [ConfiguredId] + -- ^ The exact dependencies (on other plan packages) + , pkgDependsOnSelfLib :: ComponentDeps [()] + -- ^ Components which depend (transitively) on an internally + -- defined library. These are used by 'elabRequiresRegistration', + -- to determine if a user-requested build is going to need + -- a library registration + , pkgExeDependencies :: ComponentDeps [ConfiguredId] + -- ^ Dependencies on executable packages. + , pkgExeDependencyPaths :: ComponentDeps [(ConfiguredId, FilePath)] + -- ^ Paths where executable dependencies live. + , pkgPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)] + -- ^ Dependencies on @pkg-config@ packages. + -- NB: this is NOT per-component (although it could be) + -- because Cabal library does not track per-component + -- pkg-config depends; it always does them all at once. + , pkgStanzasEnabled :: OptionalStanzaSet + -- ^ Which optional stanzas (ie testsuites, benchmarks) will actually + -- be enabled during the package configure step. + } deriving (Eq, Show, Generic) instance Binary ElaboratedPackage @@ -729,53 +711,48 @@ instance Structured ElaboratedPackage -- which can be useful in some circumstances. pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [UnitId] pkgOrderDependencies pkg = - fmap (map (newSimpleUnitId . confInstId)) (pkgLibDependencies pkg) `Mon.mappend` - fmap (map (newSimpleUnitId . confInstId)) (pkgExeDependencies pkg) + fmap (map (newSimpleUnitId . confInstId)) (pkgLibDependencies pkg) + `Mon.mappend` fmap (map (newSimpleUnitId . confInstId)) (pkgExeDependencies pkg) -- | This is used in the install plan to indicate how the package will be -- built. --- -data BuildStyle = - -- | The classic approach where the package is built, then the files +data BuildStyle + = -- | The classic approach where the package is built, then the files -- installed into some location and the result registered in a package db. -- -- If the package came from a tarball then it's built in a temp dir and -- the results discarded. BuildAndInstall - - -- | The package is built, but the files are not installed anywhere, + | -- | The package is built, but the files are not installed anywhere, -- rather the build dir is kept and the package is registered inplace. -- -- Such packages can still subsequently be installed. -- -- Typically 'BuildAndInstall' packages will only depend on other -- 'BuildAndInstall' style packages and not on 'BuildInplaceOnly' ones. - -- - | BuildInplaceOnly + BuildInplaceOnly deriving (Eq, Show, Generic) instance Binary BuildStyle instance Structured BuildStyle instance Semigroup BuildStyle where - BuildInplaceOnly <> _ = BuildInplaceOnly - _ <> BuildInplaceOnly = BuildInplaceOnly - _ <> _ = BuildAndInstall + BuildInplaceOnly <> _ = BuildInplaceOnly + _ <> BuildInplaceOnly = BuildInplaceOnly + _ <> _ = BuildAndInstall instance Monoid BuildStyle where - mempty = BuildAndInstall - mappend = (<>) + mempty = BuildAndInstall + mappend = (<>) type CabalFileText = LBS.ByteString type ElaboratedReadyPackage = GenericReadyPackage ElaboratedConfiguredPackage - --------------------------- -- Build targets -- -- | Specific targets within a package or component to act on e.g. to build, -- haddock or open a repl. --- data ComponentTarget = ComponentTarget ComponentName SubComponentTarget deriving (Eq, Ord, Show, Generic) @@ -786,14 +763,14 @@ instance Structured ComponentTarget -- to a Cabal Setup script. showComponentTarget :: PackageId -> ComponentTarget -> String showComponentTarget pkgid = - Cabal.showBuildTarget pkgid . toBuildTarget + Cabal.showBuildTarget pkgid . toBuildTarget where toBuildTarget :: ComponentTarget -> Cabal.BuildTarget toBuildTarget (ComponentTarget cname subtarget) = case subtarget of - WholeComponent -> Cabal.BuildTargetComponent cname - ModuleTarget mname -> Cabal.BuildTargetModule cname mname - FileTarget fname -> Cabal.BuildTargetFile cname fname + WholeComponent -> Cabal.BuildTargetComponent cname + ModuleTarget mname -> Cabal.BuildTargetModule cname mname + FileTarget fname -> Cabal.BuildTargetFile cname fname showTestComponentTarget :: PackageId -> ComponentTarget -> Maybe String showTestComponentTarget _ (ComponentTarget (CTestName n) _) = Just $ prettyShow n @@ -801,7 +778,7 @@ showTestComponentTarget _ _ = Nothing isTestComponentTarget :: ComponentTarget -> Bool isTestComponentTarget (ComponentTarget (CTestName _) _) = True -isTestComponentTarget _ = False +isTestComponentTarget _ = False showBenchComponentTarget :: PackageId -> ComponentTarget -> Maybe String showBenchComponentTarget _ (ComponentTarget (CBenchName n) _) = Just $ prettyShow n @@ -809,24 +786,24 @@ showBenchComponentTarget _ _ = Nothing isBenchComponentTarget :: ComponentTarget -> Bool isBenchComponentTarget (ComponentTarget (CBenchName _) _) = True -isBenchComponentTarget _ = False +isBenchComponentTarget _ = False isForeignLibComponentTarget :: ComponentTarget -> Bool isForeignLibComponentTarget (ComponentTarget (CFLibName _) _) = True -isForeignLibComponentTarget _ = False +isForeignLibComponentTarget _ = False isExeComponentTarget :: ComponentTarget -> Bool -isExeComponentTarget (ComponentTarget (CExeName _) _ ) = True -isExeComponentTarget _ = False +isExeComponentTarget (ComponentTarget (CExeName _) _) = True +isExeComponentTarget _ = False isSubLibComponentTarget :: ComponentTarget -> Bool isSubLibComponentTarget (ComponentTarget (CLibName (LSubLibName _)) _) = True -isSubLibComponentTarget _ = False +isSubLibComponentTarget _ = False componentOptionalStanza :: CD.Component -> Maybe OptionalStanza -componentOptionalStanza (CD.ComponentTest _) = Just TestStanzas +componentOptionalStanza (CD.ComponentTest _) = Just TestStanzas componentOptionalStanza (CD.ComponentBench _) = Just BenchStanzas -componentOptionalStanza _ = Nothing +componentOptionalStanza _ = Nothing --------------------------- -- Setup.hs script policy @@ -848,11 +825,11 @@ componentOptionalStanza _ = Nothing -- while in case 4 we can use the internal library API. In case 3 we also have -- to build an external Setup.hs script because the package needs a later -- Cabal lib version than we can support internally. --- -data SetupScriptStyle = SetupCustomExplicitDeps - | SetupCustomImplicitDeps - | SetupNonCustomExternalLib - | SetupNonCustomInternalLib +data SetupScriptStyle + = SetupCustomExplicitDeps + | SetupCustomImplicitDeps + | SetupNonCustomExternalLib + | SetupNonCustomInternalLib deriving (Eq, Show, Generic, Typeable) instance Binary SetupScriptStyle diff --git a/cabal-install/src/Distribution/Client/RebuildMonad.hs b/cabal-install/src/Distribution/Client/RebuildMonad.hs index f7b169f418f..89378922d66 100644 --- a/cabal-install/src/Distribution/Client/RebuildMonad.hs +++ b/cabal-install/src/Distribution/Client/RebuildMonad.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | An abstraction for re-running actions if values or files have changed. -- @@ -7,56 +9,56 @@ -- -- It's a convenient interface to the "Distribution.Client.FileMonitor" -- functions. --- -module Distribution.Client.RebuildMonad ( - -- * Rebuild monad - Rebuild, - runRebuild, - execRebuild, - askRoot, +module Distribution.Client.RebuildMonad + ( -- * Rebuild monad + Rebuild + , runRebuild + , execRebuild + , askRoot -- * Setting up file monitoring - monitorFiles, - MonitorFilePath, - monitorFile, - monitorFileHashed, - monitorNonExistentFile, - monitorDirectory, - monitorNonExistentDirectory, - monitorDirectoryExistence, - monitorFileOrDirectory, - monitorFileSearchPath, - monitorFileHashedSearchPath, + , monitorFiles + , MonitorFilePath + , monitorFile + , monitorFileHashed + , monitorNonExistentFile + , monitorDirectory + , monitorNonExistentDirectory + , monitorDirectoryExistence + , monitorFileOrDirectory + , monitorFileSearchPath + , monitorFileHashedSearchPath + -- ** Monitoring file globs - monitorFileGlob, - monitorFileGlobExistence, - FilePathGlob(..), - FilePathRoot(..), - FilePathGlobRel(..), - GlobPiece(..), + , monitorFileGlob + , monitorFileGlobExistence + , FilePathGlob (..) + , FilePathRoot (..) + , FilePathGlobRel (..) + , GlobPiece (..) -- * Using a file monitor - FileMonitor(..), - newFileMonitor, - rerunIfChanged, + , FileMonitor (..) + , newFileMonitor + , rerunIfChanged -- * Utils - delayInitSharedResource, - delayInitSharedResources, - matchFileGlob, - getDirectoryContentsMonitored, - createDirectoryMonitored, - monitorDirectoryStatus, - doesFileExistMonitored, - need, - needIfExists, - findFileWithExtensionMonitored, - findFirstFileMonitored, - findFileMonitored, + , delayInitSharedResource + , delayInitSharedResources + , matchFileGlob + , getDirectoryContentsMonitored + , createDirectoryMonitored + , monitorDirectoryStatus + , doesFileExistMonitored + , need + , needIfExists + , findFileWithExtensionMonitored + , findFirstFileMonitored + , findFileMonitored ) where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () import Distribution.Client.FileMonitor import Distribution.Client.Glob hiding (matchFileGlob) @@ -64,18 +66,16 @@ import qualified Distribution.Client.Glob as Glob (matchFileGlob) import Distribution.Simple.Utils (debug) -import qualified Data.Map.Strict as Map -import Control.Monad.State as State +import Control.Concurrent.MVar (MVar, modifyMVar, newMVar) import Control.Monad.Reader as Reader -import Control.Concurrent.MVar (MVar, newMVar, modifyMVar) -import System.FilePath +import Control.Monad.State as State +import qualified Data.Map.Strict as Map import System.Directory - +import System.FilePath -- | A monad layered on top of 'IO' to help with re-running actions when the -- input files and values they depend on change. The crucial operations are -- 'rerunIfChanged' and 'monitorFiles'. --- newtype Rebuild a = Rebuild (ReaderT FilePath (StateT [MonitorFilePath] IO) a) deriving (Functor, Applicative, Monad, MonadIO) @@ -86,9 +86,8 @@ newtype Rebuild a = Rebuild (ReaderT FilePath (StateT [MonitorFilePath] IO) a) -- -- Relative paths are interpreted as relative to an implicit root, ultimately -- passed in to 'runRebuild'. --- monitorFiles :: [MonitorFilePath] -> Rebuild () -monitorFiles filespecs = Rebuild (State.modify (filespecs++)) +monitorFiles filespecs = Rebuild (State.modify (filespecs ++)) -- | Run a 'Rebuild' IO action. unRebuild :: FilePath -> Rebuild a -> IO (a, [MonitorFilePath]) @@ -114,40 +113,51 @@ askRoot = Rebuild Reader.ask -- The result is still in the 'Rebuild' monad, so these can be nested. -- -- Do not share 'FileMonitor's between different uses of 'rerunIfChanged'. --- -rerunIfChanged :: (Binary a, Structured a, Binary b, Structured b) - => Verbosity - -> FileMonitor a b - -> a - -> Rebuild b - -> Rebuild b +rerunIfChanged + :: (Binary a, Structured a, Binary b, Structured b) + => Verbosity + -> FileMonitor a b + -> a + -> Rebuild b + -> Rebuild b rerunIfChanged verbosity monitor key action = do - rootDir <- askRoot - changed <- liftIO $ checkFileMonitorChanged monitor rootDir key - case changed of - MonitorUnchanged result files -> do - liftIO $ debug verbosity $ "File monitor '" ++ monitorName - ++ "' unchanged." - monitorFiles files - return result - - MonitorChanged reason -> do - liftIO $ debug verbosity $ "File monitor '" ++ monitorName - ++ "' changed: " ++ showReason reason - startTime <- liftIO $ beginUpdateFileMonitor - (result, files) <- liftIO $ unRebuild rootDir action - liftIO $ updateFileMonitor monitor rootDir - (Just startTime) files key result - monitorFiles files - return result + rootDir <- askRoot + changed <- liftIO $ checkFileMonitorChanged monitor rootDir key + case changed of + MonitorUnchanged result files -> do + liftIO $ + debug verbosity $ + "File monitor '" + ++ monitorName + ++ "' unchanged." + monitorFiles files + return result + MonitorChanged reason -> do + liftIO $ + debug verbosity $ + "File monitor '" + ++ monitorName + ++ "' changed: " + ++ showReason reason + startTime <- liftIO $ beginUpdateFileMonitor + (result, files) <- liftIO $ unRebuild rootDir action + liftIO $ + updateFileMonitor + monitor + rootDir + (Just startTime) + files + key + result + monitorFiles files + return result where monitorName = takeFileName (fileMonitorCacheFile monitor) showReason (MonitoredFileChanged file) = "file " ++ file - showReason (MonitoredValueChanged _) = "monitor value changed" - showReason MonitorFirstRun = "first run" - showReason MonitorCorruptCache = "invalid cache file" - + showReason (MonitoredValueChanged _) = "monitor value changed" + showReason MonitorFirstRun = "first run" + showReason MonitorCorruptCache = "invalid cache file" -- | When using 'rerunIfChanged' for each element of a list of actions, it is -- sometimes the case that each action needs to make use of some resource. e.g. @@ -176,22 +186,20 @@ rerunIfChanged verbosity monitor key action = do -- > resource <- getResource -- > ... -- use the resource -- > | ... ] --- delayInitSharedResource :: forall a. IO a -> Rebuild (Rebuild a) delayInitSharedResource action = do - var <- liftIO (newMVar Nothing) - return (liftIO (getOrInitResource var)) + var <- liftIO (newMVar Nothing) + return (liftIO (getOrInitResource var)) where getOrInitResource :: MVar (Maybe a) -> IO a getOrInitResource var = modifyMVar var $ \mx -> case mx of - Just x -> return (Just x, x) + Just x -> return (Just x, x) Nothing -> do x <- action return (Just x, x) - -- | Much like 'delayInitSharedResource' but for a keyed set of resources. -- -- > getResource <- delayInitSharedResource mkResource @@ -200,69 +208,72 @@ delayInitSharedResource action = do -- > resource <- getResource key -- > ... -- use the resource -- > | ... ] --- -delayInitSharedResources :: forall k v. Ord k - => (k -> IO v) - -> Rebuild (k -> Rebuild v) +delayInitSharedResources + :: forall k v + . Ord k + => (k -> IO v) + -> Rebuild (k -> Rebuild v) delayInitSharedResources action = do - var <- liftIO (newMVar Map.empty) - return (liftIO . getOrInitResource var) + var <- liftIO (newMVar Map.empty) + return (liftIO . getOrInitResource var) where getOrInitResource :: MVar (Map k v) -> k -> IO v getOrInitResource var k = modifyMVar var $ \m -> case Map.lookup k m of - Just x -> return (m, x) + Just x -> return (m, x) Nothing -> do x <- action k let !m' = Map.insert k x m return (m', x) - -- | Utility to match a file glob against the file system, starting from a -- given root directory. The results are all relative to the given root. -- -- Since this operates in the 'Rebuild' monad, it also monitors the given glob -- for changes. --- matchFileGlob :: FilePathGlob -> Rebuild [FilePath] matchFileGlob glob = do - root <- askRoot - monitorFiles [monitorFileGlobExistence glob] - liftIO $ Glob.matchFileGlob root glob + root <- askRoot + monitorFiles [monitorFileGlobExistence glob] + liftIO $ Glob.matchFileGlob root glob getDirectoryContentsMonitored :: FilePath -> Rebuild [FilePath] getDirectoryContentsMonitored dir = do - exists <- monitorDirectoryStatus dir - if exists - then liftIO $ getDirectoryContents dir - else return [] + exists <- monitorDirectoryStatus dir + if exists + then liftIO $ getDirectoryContents dir + else return [] createDirectoryMonitored :: Bool -> FilePath -> Rebuild () createDirectoryMonitored createParents dir = do - monitorFiles [monitorDirectoryExistence dir] - liftIO $ createDirectoryIfMissing createParents dir + monitorFiles [monitorDirectoryExistence dir] + liftIO $ createDirectoryIfMissing createParents dir -- | Monitor a directory as in 'monitorDirectory' if it currently exists or -- as 'monitorNonExistentDirectory' if it does not. monitorDirectoryStatus :: FilePath -> Rebuild Bool monitorDirectoryStatus dir = do - exists <- liftIO $ doesDirectoryExist dir - monitorFiles [if exists - then monitorDirectory dir - else monitorNonExistentDirectory dir] - return exists + exists <- liftIO $ doesDirectoryExist dir + monitorFiles + [ if exists + then monitorDirectory dir + else monitorNonExistentDirectory dir + ] + return exists -- | Like 'doesFileExist', but in the 'Rebuild' monad. This does -- NOT track the contents of 'FilePath'; use 'need' in that case. doesFileExistMonitored :: FilePath -> Rebuild Bool doesFileExistMonitored f = do - root <- askRoot - exists <- liftIO $ doesFileExist (root f) - monitorFiles [if exists - then monitorFileExistence f - else monitorNonExistentFile f] - return exists + root <- askRoot + exists <- liftIO $ doesFileExist (root f) + monitorFiles + [ if exists + then monitorFileExistence f + else monitorNonExistentFile f + ] + return exists -- | Monitor a single file need :: FilePath -> Rebuild () @@ -275,37 +286,45 @@ need f = monitorFiles [monitorFileHashed f] -- need'ed a non-existent file). needIfExists :: FilePath -> Rebuild () needIfExists f = do - root <- askRoot - exists <- liftIO $ doesFileExist (root f) - monitorFiles [if exists - then monitorFileHashed f - else monitorNonExistentFile f] + root <- askRoot + exists <- liftIO $ doesFileExist (root f) + monitorFiles + [ if exists + then monitorFileHashed f + else monitorNonExistentFile f + ] -- | Like 'findFileWithExtension', but in the 'Rebuild' monad. findFileWithExtensionMonitored - :: [String] - -> [FilePath] - -> FilePath - -> Rebuild (Maybe FilePath) + :: [String] + -> [FilePath] + -> FilePath + -> Rebuild (Maybe FilePath) findFileWithExtensionMonitored extensions searchPath baseName = - findFirstFileMonitored id + findFirstFileMonitored + id [ path baseName <.> ext | path <- nub searchPath - , ext <- nub extensions ] + , ext <- nub extensions + ] -- | Like 'findFirstFile', but in the 'Rebuild' monad. findFirstFileMonitored :: forall a. (a -> FilePath) -> [a] -> Rebuild (Maybe a) findFirstFileMonitored file = findFirst - where findFirst :: [a] -> Rebuild (Maybe a) - findFirst [] = return Nothing - findFirst (x:xs) = do exists <- doesFileExistMonitored (file x) - if exists - then return (Just x) - else findFirst xs + where + findFirst :: [a] -> Rebuild (Maybe a) + findFirst [] = return Nothing + findFirst (x : xs) = do + exists <- doesFileExistMonitored (file x) + if exists + then return (Just x) + else findFirst xs -- | Like 'findFile', but in the 'Rebuild' monad. findFileMonitored :: [FilePath] -> FilePath -> Rebuild (Maybe FilePath) findFileMonitored searchPath fileName = - findFirstFileMonitored id + findFirstFileMonitored + id [ path fileName - | path <- nub searchPath] + | path <- nub searchPath + ] diff --git a/cabal-install/src/Distribution/Client/Reconfigure.hs b/cabal-install/src/Distribution/Client/Reconfigure.hs index 1c015274f4a..a5ba2a08533 100644 --- a/cabal-install/src/Distribution/Client/Reconfigure.hs +++ b/cabal-install/src/Distribution/Client/Reconfigure.hs @@ -1,31 +1,39 @@ -module Distribution.Client.Reconfigure ( Check(..), reconfigure ) where +module Distribution.Client.Reconfigure (Check (..), reconfigure) where import Distribution.Client.Compat.Prelude -import Data.Monoid ( Any(..) ) -import System.Directory ( doesFileExist ) +import Data.Monoid (Any (..)) +import System.Directory (doesFileExist) -import Distribution.Simple.Configure ( localBuildInfoFile ) -import Distribution.Simple.Setup ( Flag, flagToMaybe, toFlag ) +import Distribution.Simple.Configure (localBuildInfoFile) +import Distribution.Simple.Setup (Flag, flagToMaybe, toFlag) import Distribution.Simple.Utils - ( existsAndIsMoreRecentThan, defaultPackageDesc, info ) - -import Distribution.Client.Config ( SavedConfig(..) ) -import Distribution.Client.Configure ( readConfigFlags ) -import Distribution.Client.Nix ( findNixExpr, inNixShell, nixInstantiate ) -import Distribution.Client.Sandbox ( findSavedDistPref, updateInstallDirs ) + ( defaultPackageDesc + , existsAndIsMoreRecentThan + , info + ) + +import Distribution.Client.Config (SavedConfig (..)) +import Distribution.Client.Configure (readConfigFlags) +import Distribution.Client.Nix (findNixExpr, inNixShell, nixInstantiate) +import Distribution.Client.Sandbox (findSavedDistPref, updateInstallDirs) import Distribution.Client.Sandbox.PackageEnvironment - ( userPackageEnvironmentFile ) + ( userPackageEnvironmentFile + ) import Distribution.Client.Setup - ( ConfigFlags(..), ConfigExFlags, GlobalFlags(..) ) + ( ConfigExFlags + , ConfigFlags (..) + , GlobalFlags (..) + ) -- | @Check@ represents a function to check some condition on type @a@. The -- returned 'Any' is 'True' if any part of the condition failed. -newtype Check a = Check { - runCheck :: Any -- Did any previous check fail? - -> a -- value returned by previous checks - -> IO (Any, a) -- Did this check fail? What value is returned? -} +newtype Check a = Check + { runCheck + :: Any -- Did any previous check fail? + -> a -- value returned by previous checks + -> IO (Any, a) -- Did this check fail? What value is returned? + } instance Semigroup (Check a) where (<>) c d = Check $ \any0 a0 -> do @@ -37,7 +45,6 @@ instance Monoid (Check a) where mempty = Check $ \_ a -> return (mempty, a) mappend = (<>) - -- | Re-configure the package in the current directory if needed. Deciding -- when to reconfigure and with which options is convoluted: -- @@ -70,19 +77,21 @@ instance Monoid (Check a) where -- a previous configuration exists. reconfigure :: ((ConfigFlags, ConfigExFlags) -> [String] -> GlobalFlags -> IO ()) - -- ^ configure action + -- ^ configure action -> Verbosity - -- ^ Verbosity setting + -- ^ Verbosity setting -> FilePath - -- ^ \"dist\" prefix + -- ^ \"dist\" prefix -> Flag (Maybe Int) - -- ^ -j flag for reinstalling add-source deps. + -- ^ -j flag for reinstalling add-source deps. -> Check (ConfigFlags, ConfigExFlags) - -- ^ Check that the required flags are set. - -- If they are not set, provide a message explaining the - -- reason for reconfiguration. - -> [String] -- ^ Extra arguments - -> GlobalFlags -- ^ Global flags + -- ^ Check that the required flags are set. + -- If they are not set, provide a message explaining the + -- reason for reconfiguration. + -> [String] + -- ^ Extra arguments + -> GlobalFlags + -- ^ Global flags -> SavedConfig -> IO SavedConfig reconfigure @@ -93,97 +102,98 @@ reconfigure check extraArgs globalFlags - config - = do - - savedFlags@(_, _) <- readConfigFlags dist - - useNix <- fmap isJust (findNixExpr globalFlags config) - alreadyInNixShell <- inNixShell - - if useNix && not alreadyInNixShell - then do - - -- If we are using Nix, we must reinstantiate the derivation outside - -- the shell. Eventually, the caller will invoke 'nixShell' which will - -- rerun cabal inside the shell. That will bring us back to 'reconfigure', - -- but inside the shell we'll take the second branch, below. - - -- This seems to have a problem: won't 'configureAction' call 'nixShell' - -- yet again, spawning an infinite tree of subprocesses? - -- No, because 'nixShell' doesn't spawn a new process if it is already - -- running in a Nix shell. - - nixInstantiate verbosity dist False globalFlags config - return config - - else do - - let checks :: Check (ConfigFlags, ConfigExFlags) - checks = - checkVerb - <> checkDist - <> checkOutdated - <> check - (Any frc, flags@(configFlags, _)) <- runCheck checks mempty savedFlags - - let config' :: SavedConfig - config' = updateInstallDirs (configUserInstall configFlags) config - - when frc $ configureAction flags extraArgs globalFlags - return config' - - where - - -- 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} - return (mempty, (configFlags', configExFlags)) - - -- Reconfiguration is required if @--build-dir@ changes. - checkDist :: Check (ConfigFlags, b) - 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 distChanged :: Bool - distChanged = dist /= savedDist - when distChanged $ info verbosity "build directory changed" - let configFlags' :: ConfigFlags - configFlags' = configFlags { configDistPref = toFlag dist } - return (Any distChanged, (configFlags', configExFlags)) - - checkOutdated :: Check (ConfigFlags, b) - checkOutdated = Check $ \_ flags@(configFlags, _) -> do - let buildConfig :: FilePath - buildConfig = localBuildInfoFile dist - - -- Has the package ever been configured? If not, reconfiguration is - -- required. - configured <- doesFileExist buildConfig - unless configured $ info verbosity "package has never been configured" - - -- Is the @cabal.config@ file newer than @dist/setup.config@? Then we need - -- to force reconfigure. Note that it's possible to use @cabal.config@ - -- even without sandboxes. - userPackageEnvironmentFileModified <- - existsAndIsMoreRecentThan userPackageEnvironmentFile buildConfig - when userPackageEnvironmentFileModified $ - info verbosity ("user package environment file ('" - ++ userPackageEnvironmentFile ++ "') was modified") - - -- Is the configuration older than the package description? - descrFile <- maybe (defaultPackageDesc verbosity) return - (flagToMaybe (configCabalFilePath configFlags)) - outdated <- existsAndIsMoreRecentThan descrFile buildConfig - when outdated $ info verbosity (descrFile ++ " was changed") - - let failed :: Any - failed = - Any outdated - <> Any userPackageEnvironmentFileModified - <> Any (not configured) - return (failed, flags) + config = + do + savedFlags@(_, _) <- readConfigFlags dist + + useNix <- fmap isJust (findNixExpr globalFlags config) + alreadyInNixShell <- inNixShell + + if useNix && not alreadyInNixShell + then do + -- If we are using Nix, we must reinstantiate the derivation outside + -- the shell. Eventually, the caller will invoke 'nixShell' which will + -- rerun cabal inside the shell. That will bring us back to 'reconfigure', + -- but inside the shell we'll take the second branch, below. + + -- This seems to have a problem: won't 'configureAction' call 'nixShell' + -- yet again, spawning an infinite tree of subprocesses? + -- No, because 'nixShell' doesn't spawn a new process if it is already + -- running in a Nix shell. + + nixInstantiate verbosity dist False globalFlags config + return config + else do + let checks :: Check (ConfigFlags, ConfigExFlags) + checks = + checkVerb + <> checkDist + <> checkOutdated + <> check + (Any frc, flags@(configFlags, _)) <- runCheck checks mempty savedFlags + + let config' :: SavedConfig + config' = updateInstallDirs (configUserInstall configFlags) config + + when frc $ configureAction flags extraArgs globalFlags + return config' + where + -- 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} + return (mempty, (configFlags', configExFlags)) + + -- Reconfiguration is required if @--build-dir@ changes. + checkDist :: Check (ConfigFlags, b) + 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 distChanged :: Bool + distChanged = dist /= savedDist + when distChanged $ info verbosity "build directory changed" + let configFlags' :: ConfigFlags + configFlags' = configFlags{configDistPref = toFlag dist} + return (Any distChanged, (configFlags', configExFlags)) + + checkOutdated :: Check (ConfigFlags, b) + checkOutdated = Check $ \_ flags@(configFlags, _) -> do + let buildConfig :: FilePath + buildConfig = localBuildInfoFile dist + + -- Has the package ever been configured? If not, reconfiguration is + -- required. + configured <- doesFileExist buildConfig + unless configured $ info verbosity "package has never been configured" + + -- Is the @cabal.config@ file newer than @dist/setup.config@? Then we need + -- to force reconfigure. Note that it's possible to use @cabal.config@ + -- even without sandboxes. + userPackageEnvironmentFileModified <- + existsAndIsMoreRecentThan userPackageEnvironmentFile buildConfig + when userPackageEnvironmentFileModified $ + info + verbosity + ( "user package environment file ('" + ++ userPackageEnvironmentFile + ++ "') was modified" + ) + + -- Is the configuration older than the package description? + descrFile <- + maybe + (defaultPackageDesc verbosity) + return + (flagToMaybe (configCabalFilePath configFlags)) + outdated <- existsAndIsMoreRecentThan descrFile buildConfig + when outdated $ info verbosity (descrFile ++ " was changed") + + let failed :: Any + failed = + Any outdated + <> Any userPackageEnvironmentFileModified + <> Any (not configured) + return (failed, flags) diff --git a/cabal-install/src/Distribution/Client/Run.hs b/cabal-install/src/Distribution/Client/Run.hs index 47025ff849a..0da937dcf94 100644 --- a/cabal-install/src/Distribution/Client/Run.hs +++ b/cabal-install/src/Distribution/Client/Run.hs @@ -1,141 +1,172 @@ ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.Run -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- Implementation of the 'run' command. ------------------------------------------------------------------------------ - -module Distribution.Client.Run ( run, splitRunArgs ) - where +module Distribution.Client.Run (run, splitRunArgs) +where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () -import Distribution.Types.TargetInfo (targetCLBI) import Distribution.Types.LocalBuildInfo (componentNameTargets') +import Distribution.Types.TargetInfo (targetCLBI) -import Distribution.Client.Utils (tryCanonicalizePath) +import Distribution.Client.Utils (tryCanonicalizePath) -import Distribution.Types.UnqualComponentName -import Distribution.PackageDescription (Executable (..), - TestSuite(..), - Benchmark(..), - PackageDescription (..), - BuildInfo(buildable)) -import Distribution.Simple.Compiler (compilerFlavor, CompilerFlavor(..)) +import Distribution.PackageDescription + ( Benchmark (..) + , BuildInfo (buildable) + , Executable (..) + , PackageDescription (..) + , TestSuite (..) + ) import Distribution.Simple.Build.PathsModule (pkgPathEnvVar) -import Distribution.Simple.BuildPaths (exeExtension) -import Distribution.Simple.LocalBuildInfo (ComponentName (..), - LocalBuildInfo (..), - depLibraryPaths) -import Distribution.Simple.Utils (die', notice, warn, - rawSystemExitWithEnv, - addLibraryPath) -import Distribution.System (Platform (..)) +import Distribution.Simple.BuildPaths (exeExtension) +import Distribution.Simple.Compiler (CompilerFlavor (..), compilerFlavor) +import Distribution.Simple.LocalBuildInfo + ( ComponentName (..) + , LocalBuildInfo (..) + , depLibraryPaths + ) +import Distribution.Simple.Utils + ( addLibraryPath + , die' + , notice + , rawSystemExitWithEnv + , warn + ) +import Distribution.System (Platform (..)) +import Distribution.Types.UnqualComponentName import qualified Distribution.Simple.GHCJS as GHCJS -import System.Directory (getCurrentDirectory) -import Distribution.Compat.Environment (getEnvironment) -import System.FilePath ((<.>), ()) - +import Distribution.Compat.Environment (getEnvironment) +import System.Directory (getCurrentDirectory) +import System.FilePath ((<.>), ()) -- | Return the executable to run and any extra arguments that should be -- forwarded to it. Die in case of error. -splitRunArgs :: Verbosity -> LocalBuildInfo -> [String] - -> IO (Executable, [String]) +splitRunArgs + :: Verbosity + -> LocalBuildInfo + -> [String] + -> IO (Executable, [String]) splitRunArgs verbosity lbi args = case whichExecutable of -- Either err (wasManuallyChosen, exe, paramsRest) - Left err -> do + Left err -> do warn verbosity `traverse_` maybeWarning -- If there is a warning, print it. die' verbosity err - Right (True, exe, xs) -> return (exe, xs) + Right (True, exe, xs) -> return (exe, xs) Right (False, exe, xs) -> do - let addition = " Interpreting all parameters to `run` as a parameter to" - ++ " the default executable." + let addition = + " Interpreting all parameters to `run` as a parameter to" + ++ " the default executable." -- If there is a warning, print it together with the addition. - warn verbosity `traverse_` fmap (++addition) maybeWarning + warn verbosity `traverse_` fmap (++ addition) maybeWarning return (exe, xs) where pkg_descr = localPkgDescr lbi - whichExecutable :: Either String -- Error string. - ( Bool -- If it was manually chosen. - , Executable -- The executable. - , [String] -- The remaining parameters. - ) + whichExecutable + :: Either + String -- Error string. + ( Bool -- If it was manually chosen. + , Executable -- The executable. + , [String] -- The remaining parameters. + ) whichExecutable = case (enabledExes, args) of - ([] , _) -> Left "Couldn't find any enabled executables." - ([exe], []) -> return (False, exe, []) - ([exe], (x:xs)) + ([], _) -> Left "Couldn't find any enabled executables." + ([exe], []) -> return (False, exe, []) + ([exe], (x : xs)) | x == unUnqualComponentName (exeName exe) -> return (True, exe, xs) - | otherwise -> return (False, exe, args) - (_ , []) -> Left - $ "This package contains multiple executables. " - ++ "You must pass the executable name as the first argument " - ++ "to 'cabal run'." - (_ , (x:xs)) -> + | otherwise -> return (False, exe, args) + (_, []) -> + Left $ + "This package contains multiple executables. " + ++ "You must pass the executable name as the first argument " + ++ "to 'cabal run'." + (_, (x : xs)) -> case find (\exe -> unUnqualComponentName (exeName exe) == x) enabledExes of - Nothing -> Left $ "No executable named '" ++ x ++ "'." + Nothing -> Left $ "No executable named '" ++ x ++ "'." Just exe -> return (True, exe, xs) where enabledExes = filter (buildable . buildInfo) (executables pkg_descr) maybeWarning :: Maybe String maybeWarning = case args of - [] -> Nothing - (x:_) -> lookup (mkUnqualComponentName x) components + [] -> Nothing + (x : _) -> lookup (mkUnqualComponentName x) components where components :: [(UnqualComponentName, String)] -- Component name, message. components = [ (name, "The executable '" ++ prettyShow name ++ "' is disabled.") | e <- executables pkg_descr - , not . buildable . buildInfo $ e, let name = exeName e] - - ++ [ (name, "There is a test-suite '" ++ prettyShow name ++ "'," - ++ " but the `run` command is only for executables.") - | t <- testSuites pkg_descr - , let name = testName t] - - ++ [ (name, "There is a benchmark '" ++ prettyShow name ++ "'," - ++ " but the `run` command is only for executables.") - | b <- benchmarks pkg_descr - , let name = benchmarkName b] + , not . buildable . buildInfo $ e + , let name = exeName e + ] + ++ [ ( name + , "There is a test-suite '" + ++ prettyShow name + ++ "'," + ++ " but the `run` command is only for executables." + ) + | t <- testSuites pkg_descr + , let name = testName t + ] + ++ [ ( name + , "There is a benchmark '" + ++ prettyShow name + ++ "'," + ++ " but the `run` command is only for executables." + ) + | b <- benchmarks pkg_descr + , let name = benchmarkName b + ] -- | Run a given executable. run :: Verbosity -> LocalBuildInfo -> Executable -> [String] -> IO () run verbosity lbi exe exeArgs = do curDir <- getCurrentDirectory - let buildPref = buildDir lbi - pkg_descr = localPkgDescr lbi - dataDirEnvVar = (pkgPathEnvVar pkg_descr "datadir", - curDir dataDir pkg_descr) + let buildPref = buildDir lbi + pkg_descr = localPkgDescr lbi + dataDirEnvVar = + ( pkgPathEnvVar pkg_descr "datadir" + , curDir dataDir pkg_descr + ) (path, runArgs) <- let exeName' = prettyShow $ exeName exe - in case compilerFlavor (compiler lbi) of - GHCJS -> do - let (script, cmd, cmdArgs) = - GHCJS.runCmd (withPrograms lbi) - (buildPref exeName' exeName') - script' <- tryCanonicalizePath script - return (cmd, cmdArgs ++ [script']) - _ -> do - p <- tryCanonicalizePath $ - buildPref exeName' (exeName' <.> exeExtension (hostPlatform lbi)) - return (p, []) + in case compilerFlavor (compiler lbi) of + GHCJS -> do + let (script, cmd, cmdArgs) = + GHCJS.runCmd + (withPrograms lbi) + (buildPref exeName' exeName') + script' <- tryCanonicalizePath script + return (cmd, cmdArgs ++ [script']) + _ -> do + p <- + tryCanonicalizePath $ + buildPref exeName' (exeName' <.> exeExtension (hostPlatform lbi)) + return (p, []) - env <- (dataDirEnvVar:) <$> getEnvironment + env <- (dataDirEnvVar :) <$> getEnvironment -- Add (DY)LD_LIBRARY_PATH if needed - env' <- if withDynExe lbi - then do let (Platform _ os) = hostPlatform lbi - clbi <- case componentNameTargets' pkg_descr lbi (CExeName (exeName exe)) of - [target] -> return (targetCLBI target) - [] -> die' verbosity "run: Could not find executable in LocalBuildInfo" - _ -> die' verbosity "run: Found multiple matching exes in LocalBuildInfo" - paths <- depLibraryPaths True False lbi clbi - return (addLibraryPath os paths env) - else return env + env' <- + if withDynExe lbi + then do + let (Platform _ os) = hostPlatform lbi + clbi <- case componentNameTargets' pkg_descr lbi (CExeName (exeName exe)) of + [target] -> return (targetCLBI target) + [] -> die' verbosity "run: Could not find executable in LocalBuildInfo" + _ -> die' verbosity "run: Found multiple matching exes in LocalBuildInfo" + paths <- depLibraryPaths True False lbi clbi + return (addLibraryPath os paths env) + else return env notice verbosity $ "Running " ++ prettyShow (exeName exe) ++ "..." - rawSystemExitWithEnv verbosity path (runArgs++exeArgs) env' + rawSystemExitWithEnv verbosity path (runArgs ++ exeArgs) env' diff --git a/cabal-install/src/Distribution/Client/Sandbox.hs b/cabal-install/src/Distribution/Client/Sandbox.hs index df672aa1b8f..82e7492a02b 100644 --- a/cabal-install/src/Distribution/Client/Sandbox.hs +++ b/cabal-install/src/Distribution/Client/Sandbox.hs @@ -1,85 +1,105 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.Sandbox -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- UI for the sandboxing functionality. ------------------------------------------------------------------------------ - -module Distribution.Client.Sandbox ( - loadConfigOrSandboxConfig, - findSavedDistPref, - - updateInstallDirs, - - getPersistOrConfigCompiler +module Distribution.Client.Sandbox + ( loadConfigOrSandboxConfig + , findSavedDistPref + , updateInstallDirs + , getPersistOrConfigCompiler ) where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () -import Distribution.Client.Setup - ( ConfigFlags(..), GlobalFlags(..), configCompilerAux' ) import Distribution.Client.Config - ( SavedConfig(..), defaultUserInstall, loadConfig ) + ( SavedConfig (..) + , defaultUserInstall + , loadConfig + ) +import Distribution.Client.Setup + ( ConfigFlags (..) + , GlobalFlags (..) + , configCompilerAux' + ) import Distribution.Client.Sandbox.PackageEnvironment - ( PackageEnvironmentType(..) + ( PackageEnvironmentType (..) , classifyPackageEnvironment , loadUserConfig ) import Distribution.Client.SetupWrapper - ( SetupScriptOptions(..), defaultSetupScriptOptions ) -import Distribution.Simple.Compiler ( Compiler(..) ) -import Distribution.Simple.Configure ( maybeGetPersistBuildConfig - , findDistPrefOrDefault - , findDistPref ) + ( SetupScriptOptions (..) + , defaultSetupScriptOptions + ) +import Distribution.Simple.Compiler (Compiler (..)) +import Distribution.Simple.Configure + ( findDistPref + , findDistPrefOrDefault + , maybeGetPersistBuildConfig + ) import qualified Distribution.Simple.LocalBuildInfo as LocalBuildInfo -import Distribution.Simple.Program ( ProgramDb ) -import Distribution.Simple.Setup ( Flag(..) - , fromFlagOrDefault, flagToMaybe ) -import Distribution.System ( Platform ) - -import System.Directory ( getCurrentDirectory ) +import Distribution.Simple.Program (ProgramDb) +import Distribution.Simple.Setup + ( Flag (..) + , flagToMaybe + , fromFlagOrDefault + ) +import Distribution.System (Platform) +import System.Directory (getCurrentDirectory) -- * Basic sandbox functions. + -- updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig -updateInstallDirs userInstallFlag savedConfig = savedConfig - { savedConfigureFlags = configureFlags - { configInstallDirs = installDirs - } +updateInstallDirs userInstallFlag savedConfig = + savedConfig + { savedConfigureFlags = + configureFlags + { configInstallDirs = installDirs + } } where configureFlags = savedConfigureFlags savedConfig userInstallDirs = savedUserInstallDirs savedConfig globalInstallDirs = savedGlobalInstallDirs savedConfig - installDirs | userInstall = userInstallDirs - | otherwise = globalInstallDirs - userInstall = fromFlagOrDefault defaultUserInstall - (configUserInstall configureFlags `mappend` userInstallFlag) + installDirs + | userInstall = userInstallDirs + | otherwise = globalInstallDirs + userInstall = + fromFlagOrDefault + defaultUserInstall + (configUserInstall configureFlags `mappend` userInstallFlag) -- | Check which type of package environment we're in and return a -- correctly-initialised @SavedConfig@ and a @UseSandbox@ value that indicates -- whether we're working in a sandbox. -loadConfigOrSandboxConfig :: Verbosity - -> GlobalFlags -- ^ For @--config-file@ and - -- @--sandbox-config-file@. - -> IO SavedConfig +loadConfigOrSandboxConfig + :: Verbosity + -> GlobalFlags + -- ^ For @--config-file@ and + -- @--sandbox-config-file@. + -> IO SavedConfig loadConfigOrSandboxConfig verbosity globalFlags = do - let configFileFlag = globalConfigFile globalFlags + let configFileFlag = globalConfigFile globalFlags - pkgEnvDir <- getCurrentDirectory + pkgEnvDir <- getCurrentDirectory pkgEnvType <- classifyPackageEnvironment pkgEnvDir case pkgEnvType of -- Only @cabal.config@ is present. - UserPackageEnvironment -> do + UserPackageEnvironment -> do config <- loadConfig verbosity configFileFlag userConfig <- loadUserConfig verbosity pkgEnvDir Nothing let config' = config `mappend` userConfig @@ -98,10 +118,11 @@ loadConfigOrSandboxConfig verbosity globalFlags = do -- | Return the saved \"dist/\" prefix, or the default prefix. findSavedDistPref :: SavedConfig -> Flag FilePath -> IO FilePath findSavedDistPref config flagDistPref = do - let defDistPref = useDistPref defaultSetupScriptOptions - flagDistPref' = configDistPref (savedConfigureFlags config) - `mappend` flagDistPref - findDistPref defDistPref flagDistPref' + let defDistPref = useDistPref defaultSetupScriptOptions + flagDistPref' = + configDistPref (savedConfigureFlags config) + `mappend` flagDistPref + findDistPref defDistPref flagDistPref' -- Utils (transitionary) -- @@ -109,14 +130,17 @@ findSavedDistPref config flagDistPref = do -- | Try to read the most recently configured compiler from the -- 'localBuildInfoFile', falling back on 'configCompilerAuxEx' if it -- cannot be read. -getPersistOrConfigCompiler :: ConfigFlags - -> IO (Compiler, Platform, ProgramDb) +getPersistOrConfigCompiler + :: ConfigFlags + -> IO (Compiler, Platform, ProgramDb) getPersistOrConfigCompiler configFlags = do distPref <- findDistPrefOrDefault (configDistPref configFlags) mlbi <- maybeGetPersistBuildConfig distPref case mlbi of - Nothing -> do configCompilerAux' configFlags - Just lbi -> return ( LocalBuildInfo.compiler lbi - , LocalBuildInfo.hostPlatform lbi - , LocalBuildInfo.withPrograms lbi - ) + Nothing -> do configCompilerAux' configFlags + Just lbi -> + return + ( LocalBuildInfo.compiler lbi + , LocalBuildInfo.hostPlatform lbi + , LocalBuildInfo.withPrograms lbi + ) diff --git a/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs b/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs index 0d13cda1093..3033356493f 100644 --- a/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs +++ b/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs @@ -1,6 +1,9 @@ {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.Sandbox.PackageEnvironment -- Maintainer : cabal-devel@haskell.org @@ -8,63 +11,75 @@ -- -- Utilities for working with the package environment file. Patterned after -- Distribution.Client.Config. ------------------------------------------------------------------------------ - -module Distribution.Client.Sandbox.PackageEnvironment ( - PackageEnvironment(..) - , PackageEnvironmentType(..) +module Distribution.Client.Sandbox.PackageEnvironment + ( PackageEnvironment (..) + , PackageEnvironmentType (..) , classifyPackageEnvironment , readPackageEnvironmentFile , showPackageEnvironment , showPackageEnvironmentWithComments , loadUserConfig - , userPackageEnvironmentFile ) where import Distribution.Client.Compat.Prelude import Prelude () -import Distribution.Client.Config ( SavedConfig(..) - , configFieldDescriptions - , haddockFlagsFields - , installDirsFields, withProgramsFields - , withProgramOptionsFields - ) -import Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection ) -import Distribution.Client.Setup ( ConfigExFlags(..) - ) -import Distribution.Client.Targets ( userConstraintPackageName ) -import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate ) -import Distribution.Simple.Setup ( Flag(..) - , ConfigFlags(..), HaddockFlags(..) - ) -import Distribution.Simple.Utils ( warn, debug ) +import Distribution.Client.Config + ( SavedConfig (..) + , configFieldDescriptions + , haddockFlagsFields + , installDirsFields + , withProgramOptionsFields + , withProgramsFields + ) +import Distribution.Client.ParseUtils (parseFields, ppFields, ppSection) +import Distribution.Client.Setup + ( ConfigExFlags (..) + ) +import Distribution.Client.Targets (userConstraintPackageName) +import Distribution.Deprecated.ParseUtils + ( FieldDescr (..) + , ParseResult (..) + , commaListFieldParsec + , commaNewLineListFieldParsec + , liftField + , lineNo + , locatedErrorMsg + , readFields + , showPWarning + , syntaxError + , warning + ) +import Distribution.Simple.InstallDirs (InstallDirs (..), PathTemplate) +import Distribution.Simple.Setup + ( ConfigFlags (..) + , Flag (..) + , HaddockFlags (..) + ) +import Distribution.Simple.Utils (debug, warn) import Distribution.Solver.Types.ConstraintSource -import Distribution.Deprecated.ParseUtils ( FieldDescr(..), ParseResult(..) - , commaListFieldParsec, commaNewLineListFieldParsec - , liftField, lineNo, locatedErrorMsg - , readFields - , showPWarning - , syntaxError, warning ) -import System.Directory ( doesFileExist ) -import System.FilePath ( () ) -import System.IO.Error ( isDoesNotExistError ) -import Text.PrettyPrint ( ($+$) ) +import System.Directory (doesFileExist) +import System.FilePath (()) +import System.IO.Error (isDoesNotExistError) +import Text.PrettyPrint (($+$)) import qualified Data.ByteString as BS -import qualified Text.PrettyPrint as Disp -import qualified Distribution.Deprecated.ParseUtils as ParseUtils ( Field(..) ) +import qualified Distribution.Deprecated.ParseUtils as ParseUtils (Field (..)) +import qualified Text.PrettyPrint as Disp -- + -- * Configuration saved in the package environment file + -- -- TODO: would be nice to remove duplication between -- D.C.Sandbox.PackageEnvironment and D.C.Config. -data PackageEnvironment = PackageEnvironment { - pkgEnvSavedConfig :: SavedConfig -} deriving Generic +data PackageEnvironment = PackageEnvironment + { pkgEnvSavedConfig :: SavedConfig + } + deriving (Generic) instance Monoid PackageEnvironment where mempty = gmempty @@ -80,108 +95,144 @@ userPackageEnvironmentFile = "cabal.config" -- | Type of the current package environment. data PackageEnvironmentType - = UserPackageEnvironment -- ^ './cabal.config' - | AmbientPackageEnvironment -- ^ '~/.config/cabal/config' + = -- | './cabal.config' + UserPackageEnvironment + | -- | '~/.config/cabal/config' + AmbientPackageEnvironment -- | Is there a 'cabal.config' in this directory? classifyPackageEnvironment :: FilePath -> IO PackageEnvironmentType classifyPackageEnvironment pkgEnvDir = do - isUser <- configExists userPackageEnvironmentFile - return (classify isUser) + isUser <- configExists userPackageEnvironmentFile + return (classify isUser) where - configExists fname = doesFileExist (pkgEnvDir fname) + configExists fname = doesFileExist (pkgEnvDir fname) classify :: Bool -> PackageEnvironmentType - classify True = UserPackageEnvironment - classify False = AmbientPackageEnvironment - + classify True = UserPackageEnvironment + classify False = AmbientPackageEnvironment -- | Load the user package environment if it exists (the optional "cabal.config" -- file). If it does not exist locally, attempt to load an optional global one. -userPackageEnvironment :: Verbosity -> FilePath -> Maybe FilePath - -> IO PackageEnvironment +userPackageEnvironment + :: Verbosity + -> FilePath + -> Maybe FilePath + -> IO PackageEnvironment userPackageEnvironment verbosity pkgEnvDir globalConfigLocation = do - let path = pkgEnvDir userPackageEnvironmentFile - minp <- readPackageEnvironmentFile (ConstraintSourceUserConfig path) - mempty path - case (minp, globalConfigLocation) of - (Just parseRes, _) -> processConfigParse path parseRes - (_, Just globalLoc) -> do - minp' <- readPackageEnvironmentFile (ConstraintSourceUserConfig globalLoc) - mempty globalLoc - maybe (warn verbosity ("no constraints file found at " ++ globalLoc) - >> return mempty) - (processConfigParse globalLoc) - minp' - _ -> do - debug verbosity ("no user package environment file found at " ++ pkgEnvDir) - return mempty + let path = pkgEnvDir userPackageEnvironmentFile + minp <- + readPackageEnvironmentFile + (ConstraintSourceUserConfig path) + mempty + path + case (minp, globalConfigLocation) of + (Just parseRes, _) -> processConfigParse path parseRes + (_, Just globalLoc) -> do + minp' <- + readPackageEnvironmentFile + (ConstraintSourceUserConfig globalLoc) + mempty + globalLoc + maybe + ( warn verbosity ("no constraints file found at " ++ globalLoc) + >> return mempty + ) + (processConfigParse globalLoc) + minp' + _ -> do + debug verbosity ("no user package environment file found at " ++ pkgEnvDir) + return mempty where processConfigParse path (ParseOk warns parseResult) = do - unless (null warns) $ warn verbosity $ - unlines (map (showPWarning path) warns) + unless (null warns) $ + warn verbosity $ + unlines (map (showPWarning path) warns) return parseResult processConfigParse path (ParseFailed err) = do let (line, msg) = locatedErrorMsg err - warn verbosity $ "Error parsing package environment file " ++ path - ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg + warn verbosity $ + "Error parsing package environment file " + ++ path + ++ maybe "" (\n -> ":" ++ show n) line + ++ ":\n" + ++ msg return mempty -- | Same as @userPackageEnvironmentFile@, but returns a SavedConfig. loadUserConfig :: Verbosity -> FilePath -> Maybe FilePath -> IO SavedConfig loadUserConfig verbosity pkgEnvDir globalConfigLocation = - fmap pkgEnvSavedConfig $ + fmap pkgEnvSavedConfig $ userPackageEnvironment verbosity pkgEnvDir globalConfigLocation - - -- | Descriptions of all fields in the package environment file. pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment] pkgEnvFieldDescrs src = - [ commaNewLineListFieldParsec "constraints" - (pretty . fst) ((\pc -> (pc, src)) `fmap` parsec) - (sortConstraints . configExConstraints - . savedConfigureExFlags . pkgEnvSavedConfig) - (\v pkgEnv -> updateConfigureExFlags pkgEnv - (\flags -> flags { configExConstraints = v })) - - , commaListFieldParsec "preferences" - pretty parsec - (configPreferences . savedConfigureExFlags . pkgEnvSavedConfig) - (\v pkgEnv -> updateConfigureExFlags pkgEnv - (\flags -> flags { configPreferences = v })) + [ commaNewLineListFieldParsec + "constraints" + (pretty . fst) + ((\pc -> (pc, src)) `fmap` parsec) + ( sortConstraints + . configExConstraints + . savedConfigureExFlags + . pkgEnvSavedConfig + ) + ( \v pkgEnv -> + updateConfigureExFlags + pkgEnv + (\flags -> flags{configExConstraints = v}) + ) + , commaListFieldParsec + "preferences" + pretty + parsec + (configPreferences . savedConfigureExFlags . pkgEnvSavedConfig) + ( \v pkgEnv -> + updateConfigureExFlags + pkgEnv + (\flags -> flags{configPreferences = v}) + ) ] - ++ map toPkgEnv configFieldDescriptions' + ++ map toPkgEnv configFieldDescriptions' where configFieldDescriptions' :: [FieldDescr SavedConfig] - configFieldDescriptions' = filter - (\(FieldDescr name _ _) -> name /= "preference" && name /= "constraint") - (configFieldDescriptions src) + configFieldDescriptions' = + filter + (\(FieldDescr name _ _) -> name /= "preference" && name /= "constraint") + (configFieldDescriptions src) toPkgEnv :: FieldDescr SavedConfig -> FieldDescr PackageEnvironment toPkgEnv fieldDescr = - liftField pkgEnvSavedConfig - (\savedConfig pkgEnv -> pkgEnv { pkgEnvSavedConfig = savedConfig}) - fieldDescr - - updateConfigureExFlags :: PackageEnvironment - -> (ConfigExFlags -> ConfigExFlags) - -> PackageEnvironment - updateConfigureExFlags pkgEnv f = pkgEnv { - pkgEnvSavedConfig = (pkgEnvSavedConfig pkgEnv) { - savedConfigureExFlags = f . savedConfigureExFlags . pkgEnvSavedConfig - $ pkgEnv - } - } + liftField + pkgEnvSavedConfig + (\savedConfig pkgEnv -> pkgEnv{pkgEnvSavedConfig = savedConfig}) + fieldDescr + + updateConfigureExFlags + :: PackageEnvironment + -> (ConfigExFlags -> ConfigExFlags) + -> PackageEnvironment + updateConfigureExFlags pkgEnv f = + pkgEnv + { pkgEnvSavedConfig = + (pkgEnvSavedConfig pkgEnv) + { savedConfigureExFlags = + f . savedConfigureExFlags . pkgEnvSavedConfig $ + pkgEnv + } + } sortConstraints = sortBy (comparing $ userConstraintPackageName . fst) -- | Read the package environment file. -readPackageEnvironmentFile :: ConstraintSource -> PackageEnvironment -> FilePath - -> IO (Maybe (ParseResult PackageEnvironment)) +readPackageEnvironmentFile + :: ConstraintSource + -> PackageEnvironment + -> FilePath + -> IO (Maybe (ParseResult PackageEnvironment)) readPackageEnvironmentFile src initial file = handleNotExists $ - fmap (Just . parsePackageEnvironment src initial) (BS.readFile file) + fmap (Just . parsePackageEnvironment src initial) (BS.readFile file) where handleNotExists action = catchIO action $ \ioe -> if isDoesNotExistError ioe @@ -189,82 +240,102 @@ readPackageEnvironmentFile src initial file = else ioError ioe -- | Parse the package environment file. -parsePackageEnvironment :: ConstraintSource -> PackageEnvironment -> BS.ByteString - -> ParseResult PackageEnvironment +parsePackageEnvironment + :: ConstraintSource + -> PackageEnvironment + -> BS.ByteString + -> ParseResult PackageEnvironment parsePackageEnvironment src initial str = do fields <- readFields str let (knownSections, others) = partition isKnownSection fields pkgEnv <- parse others - let config = pkgEnvSavedConfig pkgEnv + let config = pkgEnvSavedConfig pkgEnv installDirs0 = savedUserInstallDirs config (haddockFlags, installDirs, paths, args) <- - foldM parseSections - (savedHaddockFlags config, installDirs0, [], []) - knownSections - return pkgEnv { - pkgEnvSavedConfig = config { - savedConfigureFlags = (savedConfigureFlags config) { - configProgramPaths = paths, - configProgramArgs = args - }, - savedHaddockFlags = haddockFlags, - savedUserInstallDirs = installDirs, - savedGlobalInstallDirs = installDirs - } - } - + foldM + parseSections + (savedHaddockFlags config, installDirs0, [], []) + knownSections + return + pkgEnv + { pkgEnvSavedConfig = + config + { savedConfigureFlags = + (savedConfigureFlags config) + { configProgramPaths = paths + , configProgramArgs = args + } + , savedHaddockFlags = haddockFlags + , savedUserInstallDirs = installDirs + , savedGlobalInstallDirs = installDirs + } + } where isKnownSection :: ParseUtils.Field -> Bool - isKnownSection (ParseUtils.Section _ "haddock" _ _) = True - isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True - isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True + isKnownSection (ParseUtils.Section _ "haddock" _ _) = True + isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True + isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True - isKnownSection _ = False + isKnownSection _ = False parse :: [ParseUtils.Field] -> ParseResult PackageEnvironment parse = parseFields (pkgEnvFieldDescrs src) initial - parseSections :: SectionsAccum -> ParseUtils.Field - -> ParseResult SectionsAccum - parseSections accum@(h,d,p,a) - (ParseUtils.Section _ "haddock" name fs) - | name == "" = do h' <- parseFields haddockFlagsFields h fs - return (h', d, p, a) - | otherwise = do - warning "The 'haddock' section should be unnamed" - return accum - parseSections (h,d,p,a) - (ParseUtils.Section line "install-dirs" name fs) - | name == "" = do d' <- parseFields installDirsFields d fs - return (h, d',p,a) - | otherwise = - syntaxError line $ - "Named 'install-dirs' section: '" ++ name - ++ "'. Note that named 'install-dirs' sections are not allowed in the '" - ++ userPackageEnvironmentFile ++ "' file." - parseSections accum@(h, d,p,a) - (ParseUtils.Section _ "program-locations" name fs) - | name == "" = do p' <- parseFields withProgramsFields p fs - return (h, d, p', a) - | otherwise = do - warning "The 'program-locations' section should be unnamed" - return accum - parseSections accum@(h, d, p, a) - (ParseUtils.Section _ "program-default-options" name fs) - | name == "" = do a' <- parseFields withProgramOptionsFields a fs - return (h, d, p, a') - | otherwise = do - warning "The 'program-default-options' section should be unnamed" - return accum + parseSections + :: SectionsAccum + -> ParseUtils.Field + -> ParseResult SectionsAccum + parseSections + accum@(h, d, p, a) + (ParseUtils.Section _ "haddock" name fs) + | name == "" = do + h' <- parseFields haddockFlagsFields h fs + return (h', d, p, a) + | otherwise = do + warning "The 'haddock' section should be unnamed" + return accum + parseSections + (h, d, p, a) + (ParseUtils.Section line "install-dirs" name fs) + | name == "" = do + d' <- parseFields installDirsFields d fs + return (h, d', p, a) + | otherwise = + syntaxError line $ + "Named 'install-dirs' section: '" + ++ name + ++ "'. Note that named 'install-dirs' sections are not allowed in the '" + ++ userPackageEnvironmentFile + ++ "' file." + parseSections + accum@(h, d, p, a) + (ParseUtils.Section _ "program-locations" name fs) + | name == "" = do + p' <- parseFields withProgramsFields p fs + return (h, d, p', a) + | otherwise = do + warning "The 'program-locations' section should be unnamed" + return accum + parseSections + accum@(h, d, p, a) + (ParseUtils.Section _ "program-default-options" name fs) + | name == "" = do + a' <- parseFields withProgramOptionsFields a fs + return (h, d, p, a') + | otherwise = do + warning "The 'program-default-options' section should be unnamed" + return accum parseSections accum f = do warning $ "Unrecognized stanza on line " ++ show (lineNo f) return accum -- | Accumulator type for 'parseSections'. -type SectionsAccum = (HaddockFlags, InstallDirs (Flag PathTemplate) - , [(String, FilePath)], [(String, [String])]) - - +type SectionsAccum = + ( HaddockFlags + , InstallDirs (Flag PathTemplate) + , [(String, FilePath)] + , [(String, [String])] + ) -- | Pretty-print the package environment. showPackageEnvironment :: PackageEnvironment -> String @@ -272,14 +343,22 @@ showPackageEnvironment pkgEnv = showPackageEnvironmentWithComments Nothing pkgEn -- | Pretty-print the package environment with default values for empty fields -- commented out (just like the default Cabal config file). -showPackageEnvironmentWithComments :: (Maybe PackageEnvironment) - -> PackageEnvironment - -> String -showPackageEnvironmentWithComments mdefPkgEnv pkgEnv = Disp.render $ - ppFields (pkgEnvFieldDescrs ConstraintSourceUnknown) - mdefPkgEnv pkgEnv - $+$ Disp.text "" - $+$ ppSection "install-dirs" "" installDirsFields - (fmap installDirsSection mdefPkgEnv) (installDirsSection pkgEnv) +showPackageEnvironmentWithComments + :: (Maybe PackageEnvironment) + -> PackageEnvironment + -> String +showPackageEnvironmentWithComments mdefPkgEnv pkgEnv = + Disp.render $ + ppFields + (pkgEnvFieldDescrs ConstraintSourceUnknown) + mdefPkgEnv + pkgEnv + $+$ Disp.text "" + $+$ ppSection + "install-dirs" + "" + installDirsFields + (fmap installDirsSection mdefPkgEnv) + (installDirsSection pkgEnv) where installDirsSection = savedUserInstallDirs . pkgEnvSavedConfig diff --git a/cabal-install/src/Distribution/Client/SavedFlags.hs b/cabal-install/src/Distribution/Client/SavedFlags.hs index 4b148360358..1a598a58fd7 100644 --- a/cabal-install/src/Distribution/Client/SavedFlags.hs +++ b/cabal-install/src/Distribution/Client/SavedFlags.hs @@ -1,30 +1,34 @@ {-# LANGUAGE DeriveDataTypeable #-} module Distribution.Client.SavedFlags - ( readCommandFlags, writeCommandFlags - , readSavedArgs, writeSavedArgs - ) where + ( readCommandFlags + , writeCommandFlags + , readSavedArgs + , writeSavedArgs + ) where import Distribution.Client.Compat.Prelude import Prelude () import Distribution.Simple.Command -import Distribution.Simple.UserHooks ( Args ) +import Distribution.Simple.UserHooks (Args) import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, unintersperse ) + ( createDirectoryIfMissingVerbose + , unintersperse + ) import Distribution.Verbosity -import System.Directory ( doesFileExist ) -import System.FilePath ( takeDirectory ) - +import System.Directory (doesFileExist) +import System.FilePath (takeDirectory) writeSavedArgs :: Verbosity -> FilePath -> [String] -> IO () writeSavedArgs verbosity path args = do createDirectoryIfMissingVerbose - (lessVerbose verbosity) True (takeDirectory path) + (lessVerbose verbosity) + True + (takeDirectory path) writeFile path (intercalate "\0" args) - -- | Write command-line flags to a file, separated by null characters. This -- format is also suitable for the @xargs -0@ command. Using the null -- character also avoids the problem of escaping newlines or spaces, @@ -34,15 +38,13 @@ writeCommandFlags :: Verbosity -> FilePath -> CommandUI flags -> flags -> IO () writeCommandFlags verbosity path command flags = writeSavedArgs verbosity path (commandShowOptions command flags) - readSavedArgs :: FilePath -> IO (Maybe [String]) readSavedArgs path = do exists <- doesFileExist path if exists - then fmap (Just . unintersperse '\0') (readFile path) + then fmap (Just . unintersperse '\0') (readFile path) else return Nothing - -- | Read command-line arguments, separated by null characters, from a file. -- Returns the default flags if the file does not exist. readCommandFlags :: FilePath -> CommandUI flags -> IO flags @@ -56,26 +58,29 @@ readCommandFlags path command = do return (mkFlags (commandDefaultFlags command)) -- ----------------------------------------------------------------------------- + -- * Exceptions + -- ----------------------------------------------------------------------------- data SavedArgsError - = SavedArgsErrorHelp Args - | SavedArgsErrorList Args - | SavedArgsErrorOther Args [String] + = SavedArgsErrorHelp Args + | SavedArgsErrorList Args + | SavedArgsErrorOther Args [String] deriving (Typeable) instance Show SavedArgsError where show (SavedArgsErrorHelp args) = "unexpected flag '--help', saved command line was:\n" - ++ intercalate " " args + ++ intercalate " " args show (SavedArgsErrorList args) = "unexpected flag '--list-options', saved command line was:\n" - ++ intercalate " " args + ++ intercalate " " args show (SavedArgsErrorOther args errs) = "saved command line was:\n" - ++ intercalate " " args ++ "\n" - ++ "encountered errors:\n" - ++ intercalate "\n" errs + ++ intercalate " " args + ++ "\n" + ++ "encountered errors:\n" + ++ intercalate "\n" errs instance Exception SavedArgsError diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs index db377c8f10a..849669e1102 100644 --- a/cabal-install/src/Distribution/Client/ScriptUtils.hs +++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs @@ -4,109 +4,183 @@ {-# LANGUAGE RecordWildCards #-} -- | Utilities to help commands with scripts --- -module Distribution.Client.ScriptUtils ( - getScriptHash, getScriptCacheDirectory, ensureScriptCacheDirectory, - withContextAndSelectors, AcceptNoTargets(..), TargetContext(..), - updateContextAndWriteProjectFile, updateContextAndWriteProjectFile', - fakeProjectSourcePackage, lSrcpkgDescription +module Distribution.Client.ScriptUtils + ( getScriptHash + , getScriptCacheDirectory + , ensureScriptCacheDirectory + , withContextAndSelectors + , AcceptNoTargets (..) + , TargetContext (..) + , updateContextAndWriteProjectFile + , updateContextAndWriteProjectFile' + , fakeProjectSourcePackage + , lSrcpkgDescription ) where -import Prelude () import Distribution.Client.Compat.Prelude hiding (toList) +import Prelude () import Distribution.Compat.Lens import qualified Distribution.Types.Lens as L import Distribution.CabalSpecVersion - ( CabalSpecVersion (..), cabalSpecLatest) -import Distribution.Client.ProjectOrchestration + ( CabalSpecVersion (..) + , cabalSpecLatest + ) import Distribution.Client.Config - ( defaultScriptBuildsDir ) + ( defaultScriptBuildsDir + ) import Distribution.Client.DistDirLayout - ( DistDirLayout(..) ) + ( DistDirLayout (..) + ) import Distribution.Client.HashValue - ( hashValue, showHashValue ) + ( hashValue + , showHashValue + ) import Distribution.Client.HttpUtils - ( HttpTransport, configureTransport ) + ( HttpTransport + , configureTransport + ) import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..) ) + ( NixStyleFlags (..) + ) import Distribution.Client.ProjectConfig - ( ProjectConfig(..), ProjectConfigShared(..) - , reportParseResult, withProjectOrGlobalConfig - , projectConfigHttpTransport ) + ( ProjectConfig (..) + , ProjectConfigShared (..) + , projectConfigHttpTransport + , reportParseResult + , withProjectOrGlobalConfig + ) import Distribution.Client.ProjectConfig.Legacy - ( ProjectConfigSkeleton - , parseProjectSkeleton, instantiateProjectConfigSkeletonFetchingCompiler ) + ( ProjectConfigSkeleton + , instantiateProjectConfigSkeletonFetchingCompiler + , parseProjectSkeleton + ) import Distribution.Client.ProjectFlags - ( flagIgnoreProject ) + ( flagIgnoreProject + ) +import Distribution.Client.ProjectOrchestration +import Distribution.Client.ProjectPlanning + ( configureCompiler + ) import Distribution.Client.RebuildMonad - ( runRebuild ) + ( runRebuild + ) import Distribution.Client.Setup - ( ConfigFlags(..), GlobalFlags(..) ) + ( ConfigFlags (..) + , GlobalFlags (..) + ) import Distribution.Client.TargetSelector - ( TargetSelectorProblem(..), TargetString(..) ) + ( TargetSelectorProblem (..) + , TargetString (..) + ) import Distribution.Client.Types - ( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage ) + ( PackageLocation (..) + , PackageSpecifier (..) + , UnresolvedSourcePackage + ) import Distribution.FieldGrammar - ( parseFieldGrammar, takeFields ) + ( parseFieldGrammar + , takeFields + ) import Distribution.Fields - ( ParseResult, parseFatalFailure, readFields ) + ( ParseResult + , parseFatalFailure + , readFields + ) import Distribution.PackageDescription - ( ignoreConditions ) + ( ignoreConditions + ) import Distribution.PackageDescription.FieldGrammar - ( executableFieldGrammar ) + ( executableFieldGrammar + ) import Distribution.PackageDescription.PrettyPrint - ( showGenericPackageDescription ) + ( showGenericPackageDescription + ) import Distribution.Parsec - ( Position(..) ) + ( Position (..) + ) +import qualified Distribution.SPDX.License as SPDX +import Distribution.Simple.Compiler + ( compilerInfo + ) import Distribution.Simple.Flag - ( fromFlagOrDefault, flagToMaybe ) + ( flagToMaybe + , fromFlagOrDefault + ) import Distribution.Simple.PackageDescription - ( parseString ) + ( parseString + ) import Distribution.Simple.Setup - ( Flag(..) ) -import Distribution.Simple.Compiler - ( compilerInfo ) + ( Flag (..) + ) import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, createTempDirectory, die', handleDoesNotExist, readUTF8File, warn, writeUTF8File ) -import qualified Distribution.SPDX.License as SPDX + ( createDirectoryIfMissingVerbose + , createTempDirectory + , die' + , handleDoesNotExist + , readUTF8File + , warn + , writeUTF8File + ) import Distribution.Solver.Types.SourcePackage as SP - ( SourcePackage(..) ) + ( SourcePackage (..) + ) import Distribution.System - ( Platform(..) ) + ( Platform (..) + ) import Distribution.Types.BuildInfo - ( BuildInfo(..) ) + ( BuildInfo (..) + ) import Distribution.Types.CondTree - ( CondTree(..) ) + ( CondTree (..) + ) import Distribution.Types.Executable - ( Executable(..) ) + ( Executable (..) + ) import Distribution.Types.GenericPackageDescription as GPD - ( GenericPackageDescription(..), emptyGenericPackageDescription ) + ( GenericPackageDescription (..) + , emptyGenericPackageDescription + ) import Distribution.Types.PackageDescription - ( PackageDescription(..), emptyPackageDescription ) + ( PackageDescription (..) + , emptyPackageDescription + ) import Distribution.Types.PackageName.Magic - ( fakePackageCabalFileName, fakePackageId ) + ( fakePackageCabalFileName + , fakePackageId + ) import Distribution.Utils.NubList - ( fromNubList ) -import Distribution.Client.ProjectPlanning - ( configureCompiler ) + ( fromNubList + ) import Distribution.Verbosity - ( normal ) + ( normal + ) import Language.Haskell.Extension - ( Language(..) ) + ( Language (..) + ) import Control.Concurrent.MVar - ( newEmptyMVar, putMVar, tryTakeMVar ) + ( newEmptyMVar + , putMVar + , tryTakeMVar + ) import Control.Exception - ( bracket ) + ( bracket + ) import qualified Data.ByteString.Char8 as BS import Data.ByteString.Lazy () import qualified Data.Set as S import System.Directory - ( canonicalizePath, doesFileExist, getTemporaryDirectory, removeDirectoryRecursive ) + ( canonicalizePath + , doesFileExist + , getTemporaryDirectory + , removeDirectoryRecursive + ) import System.FilePath - ( (), takeFileName ) + ( takeFileName + , () + ) import qualified Text.Parsec as P -- A note on multi-module script support #6787: @@ -146,17 +220,21 @@ ensureScriptCacheDirectory verbosity script = do -- | What your command should do when no targets are found. data AcceptNoTargets - = RejectNoTargets -- ^ die on 'TargetSelectorNoTargetsInProject' - | AcceptNoTargets -- ^ return a default 'TargetSelector' + = -- | die on 'TargetSelectorNoTargetsInProject' + RejectNoTargets + | -- | return a default 'TargetSelector' + AcceptNoTargets deriving (Eq, Show) -- | Information about the context in which we found the 'TargetSelector's. data TargetContext - = ProjectContext -- ^ The target selectors are part of a project. - | GlobalContext -- ^ The target selectors are from the global context. - | ScriptContext FilePath Executable - -- ^ The target selectors refer to a script. Contains the path to the script and - -- the executable metadata parsed from the script + = -- | The target selectors are part of a project. + ProjectContext + | -- | The target selectors are from the global context. + GlobalContext + | -- | The target selectors refer to a script. Contains the path to the script and + -- the executable metadata parsed from the script + ScriptContext FilePath Executable deriving (Eq, Show) -- | Determine whether the targets represent regular targets or a script @@ -166,40 +244,47 @@ data TargetContext -- In the case that the context refers to a temporary directory, -- delete it after the action finishes. withContextAndSelectors - :: AcceptNoTargets -- ^ What your command should do when no targets are found. - -> Maybe ComponentKind -- ^ A target filter - -> NixStyleFlags a -- ^ Command line flags - -> [String] -- ^ Target strings or a script and args. - -> GlobalFlags -- ^ Global flags. - -> CurrentCommand -- ^ Current Command (usually for error reporting). + :: AcceptNoTargets + -- ^ What your command should do when no targets are found. + -> Maybe ComponentKind + -- ^ A target filter + -> NixStyleFlags a + -- ^ Command line flags + -> [String] + -- ^ Target strings or a script and args. + -> GlobalFlags + -- ^ Global flags. + -> CurrentCommand + -- ^ Current Command (usually for error reporting). -> (TargetContext -> ProjectBaseContext -> [TargetSelector] -> IO b) -- ^ The body of your command action. -> IO b -withContextAndSelectors noTargets kind flags@NixStyleFlags {..} targetStrings globalFlags cmd act - = withTemporaryTempDirectory $ \mkTmpDir -> do +withContextAndSelectors noTargets kind flags@NixStyleFlags{..} targetStrings globalFlags cmd act = + withTemporaryTempDirectory $ \mkTmpDir -> do (tc, ctx) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with (without mkTmpDir) (tc', ctx', sels) <- case targetStrings of -- Only script targets may contain spaces and or end with ':'. -- Trying to readTargetSelectors such a target leads to a parse error. [target] | any (\c -> isSpace c) target || ":" `isSuffixOf` target -> do - scriptOrError target [TargetSelectorNoScript $ TargetString1 target] - _ -> do + scriptOrError target [TargetSelectorNoScript $ TargetString1 target] + _ -> do -- In the case where a selector is both a valid target and script, assume it is a target, -- because you can disambiguate the script with "./script" readTargetSelectors (localPackages ctx) kind targetStrings >>= \case - Left err@(TargetSelectorNoTargetsInProject:_) + Left err@(TargetSelectorNoTargetsInProject : _) | [] <- targetStrings - , AcceptNoTargets <- noTargets -> return (tc, ctx, defaultTarget) - | (script:_) <- targetStrings -> scriptOrError script err - Left err@(TargetSelectorNoSuch t _:_) - | TargetString1 script <- t -> scriptOrError script err - Left err@(TargetSelectorExpected t _ _:_) - | TargetString1 script <- t -> scriptOrError script err - Left err@(MatchingInternalError _ _ _:_) -- Handle ':' in middle of script name. - | [script] <- targetStrings -> scriptOrError script err - Left err -> reportTargetSelectorProblems verbosity err - Right sels -> return (tc, ctx, sels) + , AcceptNoTargets <- noTargets -> + return (tc, ctx, defaultTarget) + | (script : _) <- targetStrings -> scriptOrError script err + Left err@(TargetSelectorNoSuch t _ : _) + | TargetString1 script <- t -> scriptOrError script err + Left err@(TargetSelectorExpected t _ _ : _) + | TargetString1 script <- t -> scriptOrError script err + Left err@(MatchingInternalError _ _ _ : _) -- Handle ':' in middle of script name. + | [script] <- targetStrings -> scriptOrError script err + Left err -> reportTargetSelectorProblems verbosity err + Right sels -> return (tc, ctx, sels) act tc' ctx' sels where @@ -218,34 +303,36 @@ withContextAndSelectors noTargets kind flags@NixStyleFlags {..} targetStrings gl return (GlobalContext, ctx) scriptOrError script err = do exists <- doesFileExist script - if exists then do - -- In the script case we always want a dummy context even when ignoreProject is False - let mkCacheDir = ensureScriptCacheDirectory verbosity script - (_, ctx) <- withProjectOrGlobalConfig verbosity (Flag True) globalConfigFlag with (without mkCacheDir) - - let projectRoot = distProjectRootDirectory $ distDirLayout ctx - writeFile (projectRoot "scriptlocation") =<< canonicalizePath script + if exists + then do + -- In the script case we always want a dummy context even when ignoreProject is False + let mkCacheDir = ensureScriptCacheDirectory verbosity script + (_, ctx) <- withProjectOrGlobalConfig verbosity (Flag True) globalConfigFlag with (without mkCacheDir) - scriptContents <- BS.readFile script - executable <- readExecutableBlockFromScript verbosity scriptContents + let projectRoot = distProjectRootDirectory $ distDirLayout ctx + writeFile (projectRoot "scriptlocation") =<< canonicalizePath script + scriptContents <- BS.readFile script + executable <- readExecutableBlockFromScript verbosity scriptContents - httpTransport <- configureTransport verbosity - (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig) - (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig) + httpTransport <- + configureTransport + verbosity + (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig) + (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig) - projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout ctx) (takeFileName script) scriptContents + projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout ctx) (takeFileName script) scriptContents - let fetchCompiler = do - (compiler, Platform arch os, _) <- runRebuild (distProjectRootDirectory . distDirLayout $ ctx) $ configureCompiler verbosity (distDirLayout ctx) ((fst $ ignoreConditions projectCfgSkeleton) <> projectConfig ctx) - pure (os, arch, compilerInfo compiler) + let fetchCompiler = do + (compiler, Platform arch os, _) <- runRebuild (distProjectRootDirectory . distDirLayout $ ctx) $ configureCompiler verbosity (distDirLayout ctx) ((fst $ ignoreConditions projectCfgSkeleton) <> projectConfig ctx) + pure (os, arch, compilerInfo compiler) - projectCfg <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectCfgSkeleton + projectCfg <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectCfgSkeleton - let executable' = executable & L.buildInfo . L.defaultLanguage %~ maybe (Just Haskell2010) Just - ctx' = ctx & lProjectConfig %~ (<> projectCfg) - return (ScriptContext script executable', ctx', defaultTarget) - else reportTargetSelectorProblems verbosity err + let executable' = executable & L.buildInfo . L.defaultLanguage %~ maybe (Just Haskell2010) Just + ctx' = ctx & lProjectConfig %~ (<> projectCfg) + return (ScriptContext script executable', ctx', defaultTarget) + else reportTargetSelectorProblems verbosity err withTemporaryTempDirectory :: (IO FilePath -> IO a) -> IO a withTemporaryTempDirectory act = newEmptyMVar >>= \m -> bracket (getMkTmp m) (rmTmp m) act @@ -263,18 +350,20 @@ withTemporaryTempDirectory act = newEmptyMVar >>= \m -> bracket (getMkTmp m) (rm -- | Add the 'SourcePackage' to the context and use it to write a .cabal file. updateContextAndWriteProjectFile' :: ProjectBaseContext -> SourcePackage (PackageLocation (Maybe FilePath)) -> IO ProjectBaseContext updateContextAndWriteProjectFile' ctx srcPkg = do - let projectRoot = distProjectRootDirectory $ distDirLayout ctx - packageFile = projectRoot fakePackageCabalFileName - contents = showGenericPackageDescription (srcpkgDescription srcPkg) + let projectRoot = distProjectRootDirectory $ distDirLayout ctx + packageFile = projectRoot fakePackageCabalFileName + contents = showGenericPackageDescription (srcpkgDescription srcPkg) writePackageFile = writeUTF8File packageFile contents -- TODO This is here to prevent reconfiguration of cached repl packages. -- It's worth investigating why it's needed in the first place. packageFileExists <- doesFileExist packageFile - if packageFileExists then do - cached <- force <$> readUTF8File packageFile - when (cached /= contents) - writePackageFile - else writePackageFile + if packageFileExists + then do + cached <- force <$> readUTF8File packageFile + when + (cached /= contents) + writePackageFile + else writePackageFile return (ctx & lLocalPackages %~ (++ [SpecificSourcePackage srcPkg])) -- | Add add the executable metadata to the context and write a .cabal file. @@ -287,26 +376,30 @@ updateContextAndWriteProjectFile ctx scriptPath scriptExecutable = do -- Replace characters which aren't allowed in the executable component name with '_' -- Prefix with "cabal-script-" to make it clear to end users that the name may be mangled scriptExeName = "cabal-script-" ++ map censor (takeFileName scriptPath) - censor c | c `S.member` ccNamecore = c - | otherwise = '_' - - sourcePackage = fakeProjectSourcePackage projectRoot - & lSrcpkgDescription . L.condExecutables - .~ [(fromString scriptExeName, CondNode executable (targetBuildDepends $ buildInfo executable) [])] - executable = scriptExecutable - & L.modulePath .~ absScript + censor c + | c `S.member` ccNamecore = c + | otherwise = '_' + + sourcePackage = + fakeProjectSourcePackage projectRoot + & lSrcpkgDescription . L.condExecutables + .~ [(fromString scriptExeName, CondNode executable (targetBuildDepends $ buildInfo executable) [])] + executable = + scriptExecutable + & L.modulePath .~ absScript updateContextAndWriteProjectFile' ctx sourcePackage parseScriptBlock :: BS.ByteString -> ParseResult Executable parseScriptBlock str = - case readFields str of - Right fs -> do - let (fields, _) = takeFields fs - parseFieldGrammar cabalSpecLatest fields (executableFieldGrammar "script") - Left perr -> parseFatalFailure pos (show perr) where - ppos = P.errorPos perr - pos = Position (P.sourceLine ppos) (P.sourceColumn ppos) + case readFields str of + Right fs -> do + let (fields, _) = takeFields fs + parseFieldGrammar cabalSpecLatest fields (executableFieldGrammar "script") + Left perr -> parseFatalFailure pos (show perr) + where + ppos = P.errorPos perr + pos = Position (P.sourceLine ppos) (P.sourceColumn ppos) readScriptBlock :: Verbosity -> BS.ByteString -> IO Executable readScriptBlock verbosity = parseString parseScriptBlock verbosity "script block" @@ -321,11 +414,11 @@ readScriptBlock verbosity = parseString parseScriptBlock verbosity "script block -- Return the metadata. readExecutableBlockFromScript :: Verbosity -> BS.ByteString -> IO Executable readExecutableBlockFromScript verbosity str = do - str' <- case extractScriptBlock "cabal" str of - Left e -> die' verbosity $ "Failed extracting script block: " ++ e - Right x -> return x - when (BS.all isSpace str') $ warn verbosity "Empty script block" - readScriptBlock verbosity str' + str' <- case extractScriptBlock "cabal" str of + Left e -> die' verbosity $ "Failed extracting script block: " ++ e + Right x -> return x + when (BS.all isSpace str') $ warn verbosity "Empty script block" + readScriptBlock verbosity str' -- | Extract the first encountered project metadata block started and -- terminated by the below tokens. @@ -337,10 +430,11 @@ readExecutableBlockFromScript verbosity str = do -- Return the metadata. readProjectBlockFromScript :: Verbosity -> HttpTransport -> DistDirLayout -> String -> BS.ByteString -> IO ProjectConfigSkeleton readProjectBlockFromScript verbosity httpTransport DistDirLayout{distDownloadSrcDirectory} scriptName str = do - case extractScriptBlock "project" str of - Left _ -> return mempty - Right x -> reportParseResult verbosity "script" scriptName - =<< parseProjectSkeleton distDownloadSrcDirectory httpTransport verbosity [] scriptName x + case extractScriptBlock "project" str of + Left _ -> return mempty + Right x -> + reportParseResult verbosity "script" scriptName + =<< parseProjectSkeleton distDownloadSrcDirectory httpTransport verbosity [] scriptName x -- | Extract the first encountered script metadata block started end -- terminated by the tokens @@ -358,63 +452,68 @@ extractScriptBlock :: BS.ByteString -> BS.ByteString -> Either String BS.ByteStr extractScriptBlock header str = goPre (BS.lines str) where isStartMarker = (== startMarker) . stripTrailSpace - isEndMarker = (== endMarker) . stripTrailSpace + isEndMarker = (== endMarker) . stripTrailSpace stripTrailSpace = fst . BS.spanEnd isSpace -- before start marker goPre ls = case dropWhile (not . isStartMarker) ls of - [] -> Left $ "`" ++ BS.unpack startMarker ++ "` start marker not found" - (_:ls') -> goBody [] ls' + [] -> Left $ "`" ++ BS.unpack startMarker ++ "` start marker not found" + (_ : ls') -> goBody [] ls' goBody _ [] = Left $ "`" ++ BS.unpack endMarker ++ "` end marker not found" - goBody acc (l:ls) + goBody acc (l : ls) | isEndMarker l = Right $! BS.unlines $ reverse acc - | otherwise = goBody (l:acc) ls + | otherwise = goBody (l : acc) ls startMarker, endMarker :: BS.ByteString startMarker = "{- " <> header <> ":" - endMarker = "-}" + endMarker = "-}" -- | The base for making a 'SourcePackage' for a fake project. -- It needs a 'Distribution.Types.Library.Library' or 'Executable' depending on the command. fakeProjectSourcePackage :: FilePath -> SourcePackage (PackageLocation loc) fakeProjectSourcePackage projectRoot = sourcePackage where - sourcePackage = SourcePackage - { srcpkgPackageId = fakePackageId - , srcpkgDescription = genericPackageDescription - , srcpkgSource = LocalUnpackedPackage projectRoot - , srcpkgDescrOverride = Nothing - } - genericPackageDescription = emptyGenericPackageDescription - { GPD.packageDescription = packageDescription } - packageDescription = emptyPackageDescription - { package = fakePackageId - , specVersion = CabalSpecV2_2 - , licenseRaw = Left SPDX.NONE - } + sourcePackage = + SourcePackage + { srcpkgPackageId = fakePackageId + , srcpkgDescription = genericPackageDescription + , srcpkgSource = LocalUnpackedPackage projectRoot + , srcpkgDescrOverride = Nothing + } + genericPackageDescription = + emptyGenericPackageDescription + { GPD.packageDescription = packageDescription + } + packageDescription = + emptyPackageDescription + { package = fakePackageId + , specVersion = CabalSpecV2_2 + , licenseRaw = Left SPDX.NONE + } -- Lenses + -- | A lens for the 'srcpkgDescription' field of 'SourcePackage' lSrcpkgDescription :: Lens' (SourcePackage loc) GenericPackageDescription -lSrcpkgDescription f s = fmap (\x -> s { srcpkgDescription = x }) (f (srcpkgDescription s)) -{-# inline lSrcpkgDescription #-} +lSrcpkgDescription f s = fmap (\x -> s{srcpkgDescription = x}) (f (srcpkgDescription s)) +{-# INLINE lSrcpkgDescription #-} lLocalPackages :: Lens' ProjectBaseContext [PackageSpecifier UnresolvedSourcePackage] -lLocalPackages f s = fmap (\x -> s { localPackages = x }) (f (localPackages s)) -{-# inline lLocalPackages #-} +lLocalPackages f s = fmap (\x -> s{localPackages = x}) (f (localPackages s)) +{-# INLINE lLocalPackages #-} lProjectConfig :: Lens' ProjectBaseContext ProjectConfig -lProjectConfig f s = fmap (\x -> s { projectConfig = x }) (f (projectConfig s)) -{-# inline lProjectConfig #-} +lProjectConfig f s = fmap (\x -> s{projectConfig = x}) (f (projectConfig s)) +{-# INLINE lProjectConfig #-} -- Character classes -- Transcribed from "templates/Lexer.x" ccSpace, ccCtrlchar, ccPrintable, ccSymbol', ccParen, ccNamecore :: Set Char -ccSpace = S.fromList " " -ccCtrlchar = S.fromList $ [chr 0x0 .. chr 0x1f] ++ [chr 0x7f] +ccSpace = S.fromList " " +ccCtrlchar = S.fromList $ [chr 0x0 .. chr 0x1f] ++ [chr 0x7f] ccPrintable = S.fromList [chr 0x0 .. chr 0xff] S.\\ ccCtrlchar -ccSymbol' = S.fromList ",=<>+*&|!$%^@#?/\\~" -ccParen = S.fromList "()[]" -ccNamecore = ccPrintable S.\\ S.unions [ccSpace, S.fromList ":\"{}", ccParen, ccSymbol'] +ccSymbol' = S.fromList ",=<>+*&|!$%^@#?/\\~" +ccParen = S.fromList "()[]" +ccNamecore = ccPrintable S.\\ S.unions [ccSpace, S.fromList ":\"{}", ccParen, ccSymbol'] diff --git a/cabal-install/src/Distribution/Client/Security/DNS.hs b/cabal-install/src/Distribution/Client/Security/DNS.hs index 05f422636c6..b989a852451 100644 --- a/cabal-install/src/Distribution/Client/Security/DNS.hs +++ b/cabal-install/src/Distribution/Client/Security/DNS.hs @@ -1,14 +1,14 @@ {-# LANGUAGE CPP #-} module Distribution.Client.Security.DNS - ( queryBootstrapMirrors - ) where + ( queryBootstrapMirrors + ) where -import Prelude () -import Distribution.Client.Compat.Prelude -import Network.URI (URI(..), URIAuth(..), parseURI) import Control.Exception (try) +import Distribution.Client.Compat.Prelude import Distribution.Simple.Utils +import Network.URI (URI (..), URIAuth (..), parseURI) +import Prelude () #if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns) import Network.DNS (queryTXT, Name(..), CharStr(..)) @@ -42,7 +42,6 @@ import Distribution.Simple.Program -- @hackage.haskell.org@ DNS entry, so an the additional -- @_mirrors.hackage.haskell.org@ DNS entry in the same SOA doesn't -- constitute a significant new attack vector anyway. --- queryBootstrapMirrors :: Verbosity -> URI -> IO [URI] #if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns) @@ -176,17 +175,17 @@ isUrlBase s -- | Split a TXT string into key and value according to RFC1464. -- Returns 'Nothing' if parsing fails. -splitRfc1464 :: String -> Maybe (String,String) +splitRfc1464 :: String -> Maybe (String, String) splitRfc1464 = go "" where go _ [] = Nothing - go acc ('`':c:cs) = go (c:acc) cs - go acc ('=':cs) = go2 (reverse acc) "" cs - go acc (c:cs) + go acc ('`' : c : cs) = go (c : acc) cs + go acc ('=' : cs) = go2 (reverse acc) "" cs + go acc (c : cs) | isSpace c = go acc cs - | otherwise = go (c:acc) cs + | otherwise = go (c : acc) cs - go2 k acc [] = Just (k,reverse acc) - go2 _ _ ['`'] = Nothing - go2 k acc ('`':c:cs) = go2 k (c:acc) cs - go2 k acc (c:cs) = go2 k (c:acc) cs + go2 k acc [] = Just (k, reverse acc) + go2 _ _ ['`'] = Nothing + go2 k acc ('`' : c : cs) = go2 k (c : acc) cs + go2 k acc (c : cs) = go2 k (c : acc) cs diff --git a/cabal-install/src/Distribution/Client/Security/HTTP.hs b/cabal-install/src/Distribution/Client/Security/HTTP.hs index 27fef66b929..f433c61ab21 100644 --- a/cabal-install/src/Distribution/Client/Security/HTTP.hs +++ b/cabal-install/src/Distribution/Client/Security/HTTP.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} + -- | Implementation of 'HttpLib' using cabal-install's own 'HttpTransport' module Distribution.Client.Security.HTTP (HttpLib, transportAdapter) where @@ -12,24 +13,33 @@ import Distribution.Solver.Compat.Prelude import Prelude () -- stdlibs -import System.Directory - ( getTemporaryDirectory ) -import Network.URI - ( URI ) + import qualified Data.ByteString.Lazy as BS.L -import qualified Network.HTTP as HTTP +import qualified Network.HTTP as HTTP +import Network.URI + ( URI + ) +import System.Directory + ( getTemporaryDirectory + ) -- Cabal/cabal-install -import Distribution.Verbosity - ( Verbosity ) + import Distribution.Client.HttpUtils - ( HttpTransport(..), HttpCode ) + ( HttpCode + , HttpTransport (..) + ) import Distribution.Client.Utils - ( withTempFileName ) + ( withTempFileName + ) +import Distribution.Verbosity + ( Verbosity + ) -- hackage-security -import Hackage.Security.Client.Repository.HttpLib (HttpLib (..)) + import qualified Hackage.Security.Client as HC +import Hackage.Security.Client.Repository.HttpLib (HttpLib (..)) import qualified Hackage.Security.Client.Repository.HttpLib as HC import qualified Hackage.Security.Util.Checked as HC import qualified Hackage.Security.Util.Pretty as HC @@ -57,53 +67,61 @@ import qualified Hackage.Security.Util.Pretty as HC -- insist on a minimum download rate (potential security attack). -- Fixing it however would require changing the 'HttpTransport'. transportAdapter :: Verbosity -> IO HttpTransport -> HttpLib -transportAdapter verbosity getTransport = HttpLib{ - httpGet = \headers uri callback -> do - transport <- getTransport - httpGetImpl verbosity transport headers uri callback +transportAdapter verbosity getTransport = + HttpLib + { httpGet = \headers uri callback -> do + transport <- getTransport + httpGetImpl verbosity transport headers uri callback , httpGetRange = \headers uri range callback -> do - transport <- getTransport - getRange verbosity transport headers uri range callback + transport <- getTransport + getRange verbosity transport headers uri range callback } httpGetImpl - :: HC.Throws HC.SomeRemoteError - => Verbosity - -> HttpTransport - -> [HC.HttpRequestHeader] -> URI - -> ([HC.HttpResponseHeader] -> HC.BodyReader -> IO a) - -> IO a + :: HC.Throws HC.SomeRemoteError + => Verbosity + -> HttpTransport + -> [HC.HttpRequestHeader] + -> URI + -> ([HC.HttpResponseHeader] -> HC.BodyReader -> IO a) + -> IO a httpGetImpl verbosity transport reqHeaders uri callback = wrapCustomEx $ do get' verbosity transport reqHeaders uri Nothing $ \code respHeaders br -> case code of 200 -> callback respHeaders br - _ -> HC.throwChecked $ UnexpectedResponse uri code - -getRange :: HC.Throws HC.SomeRemoteError - => Verbosity - -> HttpTransport - -> [HC.HttpRequestHeader] -> URI -> (Int, Int) - -> (HC.HttpStatus -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a) - -> IO a + _ -> HC.throwChecked $ UnexpectedResponse uri code + +getRange + :: HC.Throws HC.SomeRemoteError + => Verbosity + -> HttpTransport + -> [HC.HttpRequestHeader] + -> URI + -> (Int, Int) + -> (HC.HttpStatus -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a) + -> IO a getRange verbosity transport reqHeaders uri range callback = wrapCustomEx $ do get' verbosity transport reqHeaders uri (Just range) $ \code respHeaders br -> case code of - 200 -> callback HC.HttpStatus200OK respHeaders br - 206 -> callback HC.HttpStatus206PartialContent respHeaders br - _ -> HC.throwChecked $ UnexpectedResponse uri code + 200 -> callback HC.HttpStatus200OK respHeaders br + 206 -> callback HC.HttpStatus206PartialContent respHeaders br + _ -> HC.throwChecked $ UnexpectedResponse uri code -- | Internal generalization of 'get' and 'getRange' -get' :: Verbosity - -> HttpTransport - -> [HC.HttpRequestHeader] -> URI -> Maybe (Int, Int) - -> (HttpCode -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a) - -> IO a +get' + :: Verbosity + -> HttpTransport + -> [HC.HttpRequestHeader] + -> URI + -> Maybe (Int, Int) + -> (HttpCode -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a) + -> IO a get' verbosity transport reqHeaders uri mRange callback = do - tempDir <- getTemporaryDirectory - withTempFileName tempDir "transportAdapterGet" $ \temp -> do - (code, _etag) <- getHttp transport verbosity uri Nothing temp reqHeaders' - br <- HC.bodyReaderFromBS =<< BS.L.readFile temp - callback code [HC.HttpResponseAcceptRangesBytes] br + tempDir <- getTemporaryDirectory + withTempFileName tempDir "transportAdapterGet" $ \temp -> do + (code, _etag) <- getHttp transport verbosity uri Nothing temp reqHeaders' + br <- HC.bodyReaderFromBS =<< BS.L.readFile temp + callback code [HC.HttpResponseAcceptRangesBytes] br where reqHeaders' = mkReqHeaders reqHeaders mRange @@ -119,22 +137,23 @@ mkRangeHeader from to = HTTP.Header HTTP.HdrRange rangeHeader rangeHeader = "bytes=" ++ show from ++ "-" ++ show (to - 1) mkReqHeaders :: [HC.HttpRequestHeader] -> Maybe (Int, Int) -> [HTTP.Header] -mkReqHeaders reqHeaders mRange' = concat [ - tr [] reqHeaders +mkReqHeaders reqHeaders mRange' = + concat + [ tr [] reqHeaders , [mkRangeHeader fr to | Just (fr, to) <- [mRange]] ] where -- guard against malformed range headers. mRange = case mRange' of - Just (fr, to) | fr >= to -> Nothing - _ -> mRange' + Just (fr, to) | fr >= to -> Nothing + _ -> mRange' tr :: [(HTTP.HeaderName, [String])] -> [HC.HttpRequestHeader] -> [HTTP.Header] tr acc [] = concatMap finalize acc - tr acc (HC.HttpRequestMaxAge0:os) = + tr acc (HC.HttpRequestMaxAge0 : os) = tr (insert HTTP.HdrCacheControl ["max-age=0"] acc) os - tr acc (HC.HttpRequestNoTransform:os) = + tr acc (HC.HttpRequestNoTransform : os) = tr (insert HTTP.HdrCacheControl ["no-transform"] acc) os -- Some headers are comma-separated, others need multiple headers for @@ -149,10 +168,12 @@ mkReqHeaders reqHeaders mRange' = concat [ -- modify the first matching element modifyAssocList :: Eq a => a -> (b -> b) -> [(a, b)] -> [(a, b)] - modifyAssocList a f = go where - go [] = [] - go (p@(a', b) : xs) | a == a' = (a', f b) : xs - | otherwise = p : go xs + modifyAssocList a f = go + where + go [] = [] + go (p@(a', b) : xs) + | a == a' = (a', f b) : xs + | otherwise = p : go xs {------------------------------------------------------------------------------- Custom exceptions @@ -162,8 +183,11 @@ data UnexpectedResponse = UnexpectedResponse URI Int deriving (Typeable) instance HC.Pretty UnexpectedResponse where - pretty (UnexpectedResponse uri code) = "Unexpected response " ++ show code - ++ " for " ++ show uri + pretty (UnexpectedResponse uri code) = + "Unexpected response " + ++ show code + ++ " for " + ++ show uri #if MIN_VERSION_base(4,8,0) deriving instance Show UnexpectedResponse @@ -173,12 +197,16 @@ instance Show UnexpectedResponse where show = HC.pretty instance Exception UnexpectedResponse #endif -wrapCustomEx :: ( ( HC.Throws UnexpectedResponse - , HC.Throws IOException - ) => IO a) - -> (HC.Throws HC.SomeRemoteError => IO a) -wrapCustomEx act = HC.handleChecked (\(ex :: UnexpectedResponse) -> go ex) - $ HC.handleChecked (\(ex :: IOException) -> go ex) - $ act +wrapCustomEx + :: ( ( HC.Throws UnexpectedResponse + , HC.Throws IOException + ) + => IO a + ) + -> (HC.Throws HC.SomeRemoteError => IO a) +wrapCustomEx act = + HC.handleChecked (\(ex :: UnexpectedResponse) -> go ex) $ + HC.handleChecked (\(ex :: IOException) -> go ex) $ + act where go ex = HC.throwChecked (HC.SomeRemoteError ex) diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index 0ef63452a40..f119b967d26 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -1,9 +1,13 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.Setup -- Copyright : (c) David Himmelstrup 2005 @@ -12,382 +16,521 @@ -- Maintainer : lemmih@gmail.com -- Stability : provisional -- Portability : portable --- --- ------------------------------------------------------------------------------ module Distribution.Client.Setup - ( globalCommand, GlobalFlags(..), defaultGlobalFlags - , RepoContext(..), withRepoContext - , configureCommand, ConfigFlags(..), configureOptions, filterConfigureFlags - , configPackageDB', configCompilerAux' - , configureExCommand, ConfigExFlags(..), defaultConfigExFlags - , buildCommand, BuildFlags(..) - , filterTestFlags - , replCommand, testCommand, benchmarkCommand, testOptions, benchmarkOptions - , configureExOptions, reconfigureCommand - , installCommand, InstallFlags(..), installOptions, defaultInstallFlags - , filterHaddockArgs, filterHaddockFlags, haddockOptions - , defaultSolver, defaultMaxBackjumps - , listCommand, ListFlags(..), listNeedsCompiler - ,UpdateFlags(..), defaultUpdateFlags - , infoCommand, InfoFlags(..) - , fetchCommand, FetchFlags(..) - , freezeCommand, FreezeFlags(..) - , genBoundsCommand - , getCommand, unpackCommand, GetFlags(..) - , checkCommand - , formatCommand - , uploadCommand, UploadFlags(..), IsCandidate(..) - , reportCommand, ReportFlags(..) - , runCommand - , initCommand, initOptions, IT.InitFlags(..) - , actAsSetupCommand, ActAsSetupFlags(..) - , userConfigCommand, UserConfigFlags(..) - , manpageCommand - , haddockCommand - , cleanCommand - , copyCommand - , registerCommand - - , liftOptions - , yesNoOpt - ) where + ( globalCommand + , GlobalFlags (..) + , defaultGlobalFlags + , RepoContext (..) + , withRepoContext + , configureCommand + , ConfigFlags (..) + , configureOptions + , filterConfigureFlags + , configPackageDB' + , configCompilerAux' + , configureExCommand + , ConfigExFlags (..) + , defaultConfigExFlags + , buildCommand + , BuildFlags (..) + , filterTestFlags + , replCommand + , testCommand + , benchmarkCommand + , testOptions + , benchmarkOptions + , configureExOptions + , reconfigureCommand + , installCommand + , InstallFlags (..) + , installOptions + , defaultInstallFlags + , filterHaddockArgs + , filterHaddockFlags + , haddockOptions + , defaultSolver + , defaultMaxBackjumps + , listCommand + , ListFlags (..) + , listNeedsCompiler + , UpdateFlags (..) + , defaultUpdateFlags + , infoCommand + , InfoFlags (..) + , fetchCommand + , FetchFlags (..) + , freezeCommand + , FreezeFlags (..) + , genBoundsCommand + , getCommand + , unpackCommand + , GetFlags (..) + , checkCommand + , formatCommand + , uploadCommand + , UploadFlags (..) + , IsCandidate (..) + , reportCommand + , ReportFlags (..) + , runCommand + , initCommand + , initOptions + , IT.InitFlags (..) + , actAsSetupCommand + , ActAsSetupFlags (..) + , userConfigCommand + , UserConfigFlags (..) + , manpageCommand + , haddockCommand + , cleanCommand + , copyCommand + , registerCommand + , liftOptions + , yesNoOpt + ) where -import Prelude () import Distribution.Client.Compat.Prelude hiding (get) +import Prelude () -import Distribution.Client.Types.Credentials (Username (..), Password (..)) -import Distribution.Client.Types.Repo (RemoteRepo(..), LocalRepo (..)) -import Distribution.Client.Types.AllowNewer (AllowNewer(..), AllowOlder(..), RelaxDeps(..)) +import Distribution.Client.Types.AllowNewer (AllowNewer (..), AllowOlder (..), RelaxDeps (..)) +import Distribution.Client.Types.Credentials (Password (..), Username (..)) +import Distribution.Client.Types.Repo (LocalRepo (..), RemoteRepo (..)) import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy import Distribution.Client.BuildReports.Types - ( ReportLevel(..) ) + ( ReportLevel (..) + ) import Distribution.Client.Dependency.Types - ( PreSolver(..) ) + ( PreSolver (..) + ) import Distribution.Client.IndexUtils.ActiveRepos - ( ActiveRepos ) + ( ActiveRepos + ) import Distribution.Client.IndexUtils.IndexState - ( TotalIndexState, headTotalIndexState ) -import qualified Distribution.Client.Init.Types as IT + ( TotalIndexState + , headTotalIndexState + ) import qualified Distribution.Client.Init.Defaults as IT +import qualified Distribution.Client.Init.Types as IT import Distribution.Client.Targets - ( UserConstraint, readUserConstraint ) + ( UserConstraint + , readUserConstraint + ) import Distribution.Utils.NubList - ( NubList, toNubList, fromNubList) + ( NubList + , fromNubList + , toNubList + ) import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.Settings -import Distribution.Simple.Compiler ( Compiler, PackageDB, PackageDBStack ) -import Distribution.Simple.Program (ProgramDb, defaultProgramDb) +import Distribution.Client.GlobalFlags + ( GlobalFlags (..) + , RepoContext (..) + , defaultGlobalFlags + , withRepoContext + ) +import Distribution.Client.ManpageFlags (ManpageFlags, defaultManpageFlags, manpageOptions) +import qualified Distribution.Compat.CharParsing as P +import Distribution.FieldGrammar.Newtypes (SpecVersion (..)) +import Distribution.PackageDescription + ( BuildType (..) + , Dependency + , LibraryName (..) + , RepoKind (..) + ) +import Distribution.Parsec + ( parsecCommaList + ) +import Distribution.ReadE + ( ReadE (..) + , parsecToReadE + , parsecToReadEErr + , succeedReadE + , unexpectMsgString + ) import Distribution.Simple.Command hiding (boolOpt, boolOpt') import qualified Distribution.Simple.Command as Command +import Distribution.Simple.Compiler (Compiler, PackageDB, PackageDBStack) import Distribution.Simple.Configure - ( configCompilerAuxEx, interpretPackageDbFlags, computeEffectiveProfiling ) -import qualified Distribution.Simple.Setup as Cabal + ( computeEffectiveProfiling + , configCompilerAuxEx + , interpretPackageDbFlags + ) import Distribution.Simple.Flag - ( Flag(..), toFlag, flagToMaybe, flagToList, maybeToFlag - , flagElim, fromFlagOrDefault - ) -import Distribution.Simple.Setup - ( ConfigFlags(..), BuildFlags(..), ReplFlags - , TestFlags, BenchmarkFlags - , HaddockFlags(..) - , CleanFlags(..) - , CopyFlags(..), RegisterFlags(..) - , readPackageDbList, showPackageDbList - , BooleanFlag(..), optionVerbosity - , boolOpt, boolOpt', trueArg, falseArg - , optionNumJobs ) + ( Flag (..) + , flagElim + , flagToList + , flagToMaybe + , fromFlagOrDefault + , maybeToFlag + , toFlag + ) import Distribution.Simple.InstallDirs - ( PathTemplate, InstallDirs(..) - , toPathTemplate, fromPathTemplate, combinePathTemplate ) -import Distribution.Version - ( Version, mkVersion ) + ( InstallDirs (..) + , PathTemplate + , combinePathTemplate + , fromPathTemplate + , toPathTemplate + ) +import Distribution.Simple.Program (ProgramDb, defaultProgramDb) +import Distribution.Simple.Setup + ( BenchmarkFlags + , BooleanFlag (..) + , BuildFlags (..) + , CleanFlags (..) + , ConfigFlags (..) + , CopyFlags (..) + , HaddockFlags (..) + , RegisterFlags (..) + , ReplFlags + , TestFlags + , boolOpt + , boolOpt' + , falseArg + , optionNumJobs + , optionVerbosity + , readPackageDbList + , showPackageDbList + , trueArg + ) +import qualified Distribution.Simple.Setup as Cabal +import Distribution.Simple.Utils + ( wrapText + ) +import Distribution.System (Platform) import Distribution.Types.GivenComponent - ( GivenComponent(..) ) + ( GivenComponent (..) + ) import Distribution.Types.PackageVersionConstraint - ( PackageVersionConstraint(..) ) + ( PackageVersionConstraint (..) + ) import Distribution.Types.UnqualComponentName - ( unqualComponentNameToPackageName ) -import Distribution.PackageDescription - ( BuildType(..), RepoKind(..), LibraryName(..), Dependency ) -import Distribution.System ( Platform ) -import Distribution.ReadE - ( ReadE(..), succeedReadE, parsecToReadE, parsecToReadEErr, unexpectMsgString ) -import qualified Distribution.Compat.CharParsing as P + ( unqualComponentNameToPackageName + ) import Distribution.Verbosity - ( lessVerbose, normal, verboseNoFlags, verboseNoTimestamp ) -import Distribution.Simple.Utils - ( wrapText ) -import Distribution.Client.GlobalFlags - ( GlobalFlags(..), defaultGlobalFlags - , RepoContext(..), withRepoContext - ) -import Distribution.Client.ManpageFlags (ManpageFlags, defaultManpageFlags, manpageOptions) -import Distribution.FieldGrammar.Newtypes (SpecVersion (..)) -import Distribution.Parsec - ( parsecCommaList ) + ( lessVerbose + , normal + , verboseNoFlags + , verboseNoTimestamp + ) +import Distribution.Version + ( Version + , mkVersion + ) import Data.List - ( deleteFirstsBy ) + ( deleteFirstsBy + ) import System.FilePath - ( () ) + ( () + ) globalCommand :: [Command action] -> CommandUI GlobalFlags -globalCommand commands = CommandUI { - commandName = "", - commandSynopsis = - "Command line interface to the Haskell Cabal infrastructure.", - commandUsage = \pname -> - "See http://www.haskell.org/cabal/ for more information.\n" - ++ "\n" - ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n", - commandDescription = Just $ \pname -> - let - commands' = commands ++ [commandAddAction helpCommandUI undefined] - cmdDescs = getNormalCommandDescriptions commands' - -- if new commands are added, we want them to appear even if they - -- are not included in the custom listing below. Thus, we calculate - -- the `otherCmds` list and append it under the `other` category. - -- Alternatively, a new testcase could be added that ensures that - -- the set of commands listed here is equal to the set of commands - -- that are actually available. - otherCmds = deleteFirstsBy (==) (map fst cmdDescs) - [ "help" - , "update" - , "install" - , "fetch" - , "list" - , "info" - , "user-config" - , "get" - , "unpack" - , "init" - , "configure" - , "build" - , "clean" - , "run" - , "repl" - , "test" - , "bench" - , "check" - , "sdist" - , "upload" - , "report" - , "freeze" - , "gen-bounds" - , "outdated" - , "haddock" - , "hscolour" - , "exec" - , "new-build" - , "new-configure" - , "new-repl" - , "new-freeze" - , "new-run" - , "new-test" - , "new-bench" - , "new-haddock" - , "new-exec" - , "new-update" - , "new-install" - , "new-clean" - , "new-sdist" - , "list-bin" - -- v1 commands, stateful style - , "v1-build" - , "v1-configure" - , "v1-repl" - , "v1-freeze" - , "v1-run" - , "v1-test" - , "v1-bench" - , "v1-haddock" - , "v1-exec" - , "v1-update" - , "v1-install" - , "v1-clean" - , "v1-sdist" - , "v1-doctest" - , "v1-copy" - , "v1-register" - , "v1-reconfigure" - -- v2 commands, nix-style - , "v2-build" - , "v2-configure" - , "v2-repl" - , "v2-freeze" - , "v2-run" - , "v2-test" - , "v2-bench" - , "v2-haddock" - , "v2-exec" - , "v2-update" - , "v2-install" - , "v2-clean" - , "v2-sdist" - ] - maxlen = maximum $ [length name | (name, _) <- cmdDescs] - align str = str ++ replicate (maxlen - length str) ' ' - startGroup n = " ["++n++"]" - par = "" - addCmd n = case lookup n cmdDescs of - Nothing -> "" - Just d -> " " ++ align n ++ " " ++ d - in - "Commands:\n" - ++ unlines ( - [ startGroup "global" - , addCmd "user-config" - , addCmd "help" - , par - , startGroup "package database" - , addCmd "update" - , addCmd "list" - , addCmd "info" - , par - , startGroup "initialization and download" - , addCmd "init" - , addCmd "fetch" - , addCmd "get" - , par - , startGroup "project configuration" - , addCmd "configure" - , addCmd "freeze" - , addCmd "gen-bounds" - , addCmd "outdated" - , par - , startGroup "project building and installing" - , addCmd "build" - , addCmd "install" - , addCmd "haddock" - , addCmd "haddock-project" - , addCmd "clean" - , par - , startGroup "running and testing" - , addCmd "list-bin" - , addCmd "repl" - , addCmd "run" - , addCmd "bench" - , addCmd "test" - , addCmd "exec" - , par - , startGroup "sanity checks and shipping" - , addCmd "check" - , addCmd "sdist" - , addCmd "upload" - , addCmd "report" - , par - , startGroup "deprecated" - , addCmd "unpack" - , addCmd "hscolour" - , par - , startGroup "new-style projects (forwards-compatible aliases)" - , addCmd "v2-build" - , addCmd "v2-configure" - , addCmd "v2-repl" - , addCmd "v2-run" - , addCmd "v2-test" - , addCmd "v2-bench" - , addCmd "v2-freeze" - , addCmd "v2-haddock" - , addCmd "v2-exec" - , addCmd "v2-update" - , addCmd "v2-install" - , addCmd "v2-clean" - , addCmd "v2-sdist" - , par - , startGroup "legacy command aliases" - , addCmd "v1-build" - , addCmd "v1-configure" - , addCmd "v1-repl" - , addCmd "v1-run" - , addCmd "v1-test" - , addCmd "v1-bench" - , addCmd "v1-freeze" - , addCmd "v1-haddock" - , addCmd "v1-install" - , addCmd "v1-clean" - , addCmd "v1-copy" - , addCmd "v1-register" - , addCmd "v1-reconfigure" - ] ++ if null otherCmds then [] else par - :startGroup "other" - :[addCmd n | n <- otherCmds]) - ++ "\n" - ++ "For more information about a command use:\n" - ++ " " ++ pname ++ " COMMAND --help\n" - ++ "or " ++ pname ++ " help COMMAND\n" - ++ "\n" - ++ "To install Cabal packages from hackage use:\n" - ++ " " ++ pname ++ " install foo [--dry-run]\n" - ++ "\n" - ++ "Occasionally you need to update the list of available packages:\n" - ++ " " ++ pname ++ " update\n", - commandNotes = Nothing, - commandDefaultFlags = mempty, - commandOptions = args - } +globalCommand commands = + CommandUI + { commandName = "" + , commandSynopsis = + "Command line interface to the Haskell Cabal infrastructure." + , commandUsage = \pname -> + "See http://www.haskell.org/cabal/ for more information.\n" + ++ "\n" + ++ "Usage: " + ++ pname + ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n" + , commandDescription = Just $ \pname -> + let + commands' = commands ++ [commandAddAction helpCommandUI undefined] + cmdDescs = getNormalCommandDescriptions commands' + -- if new commands are added, we want them to appear even if they + -- are not included in the custom listing below. Thus, we calculate + -- the `otherCmds` list and append it under the `other` category. + -- Alternatively, a new testcase could be added that ensures that + -- the set of commands listed here is equal to the set of commands + -- that are actually available. + otherCmds = + deleteFirstsBy + (==) + (map fst cmdDescs) + [ "help" + , "update" + , "install" + , "fetch" + , "list" + , "info" + , "user-config" + , "get" + , "unpack" + , "init" + , "configure" + , "build" + , "clean" + , "run" + , "repl" + , "test" + , "bench" + , "check" + , "sdist" + , "upload" + , "report" + , "freeze" + , "gen-bounds" + , "outdated" + , "haddock" + , "hscolour" + , "exec" + , "new-build" + , "new-configure" + , "new-repl" + , "new-freeze" + , "new-run" + , "new-test" + , "new-bench" + , "new-haddock" + , "new-exec" + , "new-update" + , "new-install" + , "new-clean" + , "new-sdist" + , "list-bin" + , -- v1 commands, stateful style + "v1-build" + , "v1-configure" + , "v1-repl" + , "v1-freeze" + , "v1-run" + , "v1-test" + , "v1-bench" + , "v1-haddock" + , "v1-exec" + , "v1-update" + , "v1-install" + , "v1-clean" + , "v1-sdist" + , "v1-doctest" + , "v1-copy" + , "v1-register" + , "v1-reconfigure" + , -- v2 commands, nix-style + "v2-build" + , "v2-configure" + , "v2-repl" + , "v2-freeze" + , "v2-run" + , "v2-test" + , "v2-bench" + , "v2-haddock" + , "v2-exec" + , "v2-update" + , "v2-install" + , "v2-clean" + , "v2-sdist" + ] + maxlen = maximum $ [length name | (name, _) <- cmdDescs] + align str = str ++ replicate (maxlen - length str) ' ' + startGroup n = " [" ++ n ++ "]" + par = "" + addCmd n = case lookup n cmdDescs of + Nothing -> "" + Just d -> " " ++ align n ++ " " ++ d + in + "Commands:\n" + ++ unlines + ( [ startGroup "global" + , addCmd "user-config" + , addCmd "help" + , par + , startGroup "package database" + , addCmd "update" + , addCmd "list" + , addCmd "info" + , par + , startGroup "initialization and download" + , addCmd "init" + , addCmd "fetch" + , addCmd "get" + , par + , startGroup "project configuration" + , addCmd "configure" + , addCmd "freeze" + , addCmd "gen-bounds" + , addCmd "outdated" + , par + , startGroup "project building and installing" + , addCmd "build" + , addCmd "install" + , addCmd "haddock" + , addCmd "haddock-project" + , addCmd "clean" + , par + , startGroup "running and testing" + , addCmd "list-bin" + , addCmd "repl" + , addCmd "run" + , addCmd "bench" + , addCmd "test" + , addCmd "exec" + , par + , startGroup "sanity checks and shipping" + , addCmd "check" + , addCmd "sdist" + , addCmd "upload" + , addCmd "report" + , par + , startGroup "deprecated" + , addCmd "unpack" + , addCmd "hscolour" + , par + , startGroup "new-style projects (forwards-compatible aliases)" + , addCmd "v2-build" + , addCmd "v2-configure" + , addCmd "v2-repl" + , addCmd "v2-run" + , addCmd "v2-test" + , addCmd "v2-bench" + , addCmd "v2-freeze" + , addCmd "v2-haddock" + , addCmd "v2-exec" + , addCmd "v2-update" + , addCmd "v2-install" + , addCmd "v2-clean" + , addCmd "v2-sdist" + , par + , startGroup "legacy command aliases" + , addCmd "v1-build" + , addCmd "v1-configure" + , addCmd "v1-repl" + , addCmd "v1-run" + , addCmd "v1-test" + , addCmd "v1-bench" + , addCmd "v1-freeze" + , addCmd "v1-haddock" + , addCmd "v1-install" + , addCmd "v1-clean" + , addCmd "v1-copy" + , addCmd "v1-register" + , addCmd "v1-reconfigure" + ] + ++ if null otherCmds + then [] + else + par + : startGroup "other" + : [addCmd n | n <- otherCmds] + ) + ++ "\n" + ++ "For more information about a command use:\n" + ++ " " + ++ pname + ++ " COMMAND --help\n" + ++ "or " + ++ pname + ++ " help COMMAND\n" + ++ "\n" + ++ "To install Cabal packages from hackage use:\n" + ++ " " + ++ pname + ++ " install foo [--dry-run]\n" + ++ "\n" + ++ "Occasionally you need to update the list of available packages:\n" + ++ " " + ++ pname + ++ " update\n" + , commandNotes = Nothing + , commandDefaultFlags = mempty + , commandOptions = args + } where args :: ShowOrParseArgs -> [OptionField GlobalFlags] - args ShowArgs = argsShown + args ShowArgs = argsShown args ParseArgs = argsShown ++ argsNotShown -- arguments we want to show in the help argsShown :: [OptionField GlobalFlags] - argsShown = [ - option ['V'] ["version"] - "Print version information" - globalVersion (\v flags -> flags { globalVersion = v }) - trueArg - - ,option [] ["numeric-version"] - "Print just the version number" - globalNumericVersion (\v flags -> flags { globalNumericVersion = v }) - trueArg - - ,option [] ["config-file"] - "Set an alternate location for the config file" - globalConfigFile (\v flags -> flags { globalConfigFile = v }) - (reqArgFlag "FILE") - - ,option [] ["ignore-expiry"] - "Ignore expiry dates on signed metadata (use only in exceptional circumstances)" - globalIgnoreExpiry (\v flags -> flags { globalIgnoreExpiry = v }) - trueArg - - ,option [] ["http-transport"] - "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')" - globalHttpTransport (\v flags -> flags { globalHttpTransport = v }) - (reqArgFlag "HttpTransport") - - ,multiOption "nix" - globalNix (\v flags -> flags { globalNix = v }) - [ - optArg' "(True or False)" (maybeToFlag . (readMaybe =<<)) (\case - Flag True -> [Just "enable"] - Flag False -> [Just "disable"] - NoFlag -> []) "" ["nix"] -- Must be empty because we need to return PP.empty from viewAsFieldDescr - "Nix integration: run commands through nix-shell if a 'shell.nix' file exists (default is False)", - noArg (Flag True) [] ["enable-nix"] - "Enable Nix integration: run commands through nix-shell if a 'shell.nix' file exists", - noArg (Flag False) [] ["disable-nix"] - "Disable Nix integration" - ] - - ,option [] ["store-dir", "storedir"] - "The location of the build store" - globalStoreDir (\v flags -> flags { globalStoreDir = v }) - (reqArgFlag "DIR") - - , option [] ["active-repositories"] - "The active package repositories (set to ':none' to disable all repositories)" - globalActiveRepos (\v flags -> flags { globalActiveRepos = v }) - (reqArg "REPOS" (parsecToReadE (\err -> "Error parsing active-repositories: " ++ err) - (toFlag `fmap` parsec)) - (map prettyShow . flagToList)) + argsShown = + [ option + ['V'] + ["version"] + "Print version information" + globalVersion + (\v flags -> flags{globalVersion = v}) + trueArg + , option + [] + ["numeric-version"] + "Print just the version number" + globalNumericVersion + (\v flags -> flags{globalNumericVersion = v}) + trueArg + , option + [] + ["config-file"] + "Set an alternate location for the config file" + globalConfigFile + (\v flags -> flags{globalConfigFile = v}) + (reqArgFlag "FILE") + , option + [] + ["ignore-expiry"] + "Ignore expiry dates on signed metadata (use only in exceptional circumstances)" + globalIgnoreExpiry + (\v flags -> flags{globalIgnoreExpiry = v}) + trueArg + , option + [] + ["http-transport"] + "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')" + globalHttpTransport + (\v flags -> flags{globalHttpTransport = v}) + (reqArgFlag "HttpTransport") + , multiOption + "nix" + globalNix + (\v flags -> flags{globalNix = v}) + [ optArg' + "(True or False)" + (maybeToFlag . (readMaybe =<<)) + ( \case + Flag True -> [Just "enable"] + Flag False -> [Just "disable"] + NoFlag -> [] + ) + "" + ["nix"] -- Must be empty because we need to return PP.empty from viewAsFieldDescr + "Nix integration: run commands through nix-shell if a 'shell.nix' file exists (default is False)" + , noArg + (Flag True) + [] + ["enable-nix"] + "Enable Nix integration: run commands through nix-shell if a 'shell.nix' file exists" + , noArg + (Flag False) + [] + ["disable-nix"] + "Disable Nix integration" + ] + , option + [] + ["store-dir", "storedir"] + "The location of the build store" + globalStoreDir + (\v flags -> flags{globalStoreDir = v}) + (reqArgFlag "DIR") + , option + [] + ["active-repositories"] + "The active package repositories (set to ':none' to disable all repositories)" + globalActiveRepos + (\v flags -> flags{globalActiveRepos = v}) + ( reqArg + "REPOS" + ( parsecToReadE + (\err -> "Error parsing active-repositories: " ++ err) + (toFlag `fmap` parsec) + ) + (map prettyShow . flagToList) + ) ] -- arguments we don't want shown in the help @@ -395,62 +538,81 @@ globalCommand commands = CommandUI { -- the global logs directory was only used in v1, while in v2 we have specific project config logs dirs -- default-user-config is support for a relatively obscure workflow for v1-freeze. argsNotShown :: [OptionField GlobalFlags] - argsNotShown = [ - option [] ["remote-repo"] - "The name and url for a remote repository" - globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v }) - (reqArg' "NAME:URL" (toNubList . maybeToList . readRemoteRepo) (map showRemoteRepo . fromNubList)) - - ,option [] ["local-no-index-repo"] - "The name and a path for a local no-index repository" - globalLocalNoIndexRepos (\v flags -> flags { globalLocalNoIndexRepos = v }) - (reqArg' "NAME:PATH" (toNubList . maybeToList . readLocalRepo) (map showLocalRepo . fromNubList)) - - ,option [] ["remote-repo-cache"] - "The location where downloads from all remote repos are cached" - globalCacheDir (\v flags -> flags { globalCacheDir = v }) - (reqArgFlag "DIR") - - ,option [] ["logs-dir", "logsdir"] - "The location to put log files" - globalLogsDir (\v flags -> flags { globalLogsDir = v }) - (reqArgFlag "DIR") - - ,option [] ["default-user-config"] - "Set a location for a cabal.config file for projects without their own cabal.config freeze file." - globalConstraintsFile (\v flags -> flags {globalConstraintsFile = v}) - (reqArgFlag "FILE") + argsNotShown = + [ option + [] + ["remote-repo"] + "The name and url for a remote repository" + globalRemoteRepos + (\v flags -> flags{globalRemoteRepos = v}) + (reqArg' "NAME:URL" (toNubList . maybeToList . readRemoteRepo) (map showRemoteRepo . fromNubList)) + , option + [] + ["local-no-index-repo"] + "The name and a path for a local no-index repository" + globalLocalNoIndexRepos + (\v flags -> flags{globalLocalNoIndexRepos = v}) + (reqArg' "NAME:PATH" (toNubList . maybeToList . readLocalRepo) (map showLocalRepo . fromNubList)) + , option + [] + ["remote-repo-cache"] + "The location where downloads from all remote repos are cached" + globalCacheDir + (\v flags -> flags{globalCacheDir = v}) + (reqArgFlag "DIR") + , option + [] + ["logs-dir", "logsdir"] + "The location to put log files" + globalLogsDir + (\v flags -> flags{globalLogsDir = v}) + (reqArgFlag "DIR") + , option + [] + ["default-user-config"] + "Set a location for a cabal.config file for projects without their own cabal.config freeze file." + globalConstraintsFile + (\v flags -> flags{globalConstraintsFile = v}) + (reqArgFlag "FILE") ] -- ------------------------------------------------------------ + -- * Config flags + -- ------------------------------------------------------------ configureCommand :: CommandUI ConfigFlags -configureCommand = c - { commandName = "configure" - , commandDefaultFlags = mempty - , commandDescription = Just $ \_ -> wrapText $ - "Configure how the package is built by setting " - ++ "package (and other) flags.\n" - ++ "\n" - ++ "The configuration affects several other commands, " - ++ "including v1-build, v1-test, v1-bench, v1-run, v1-repl.\n" - , commandUsage = \pname -> - "Usage: " ++ pname ++ " v1-configure [FLAGS]\n" - , commandNotes = Just $ \pname -> - (Cabal.programFlagsDescription defaultProgramDb ++ "\n") - ++ "Examples:\n" - ++ " " ++ pname ++ " v1-configure\n" - ++ " Configure with defaults;\n" - ++ " " ++ pname ++ " v1-configure --enable-tests -fcustomflag\n" - ++ " Configure building package including tests,\n" - ++ " with some package-specific flag.\n" - } - where - c = Cabal.configureCommand defaultProgramDb +configureCommand = + c + { commandName = "configure" + , commandDefaultFlags = mempty + , commandDescription = Just $ \_ -> + wrapText $ + "Configure how the package is built by setting " + ++ "package (and other) flags.\n" + ++ "\n" + ++ "The configuration affects several other commands, " + ++ "including v1-build, v1-test, v1-bench, v1-run, v1-repl.\n" + , commandUsage = \pname -> + "Usage: " ++ pname ++ " v1-configure [FLAGS]\n" + , commandNotes = Just $ \pname -> + (Cabal.programFlagsDescription defaultProgramDb ++ "\n") + ++ "Examples:\n" + ++ " " + ++ pname + ++ " v1-configure\n" + ++ " Configure with defaults;\n" + ++ " " + ++ pname + ++ " v1-configure --enable-tests -fcustomflag\n" + ++ " Configure building package including tests,\n" + ++ " with some package-specific flag.\n" + } + where + c = Cabal.configureCommand defaultProgramDb -configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] +configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] configureOptions = commandOptions configureCommand -- | Given some 'ConfigFlags' for the version of Cabal that @@ -465,285 +627,363 @@ 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,7,0] = flags_latest + | cabalLibVersion >= mkVersion [3, 7, 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 -- these flags work for; version of introduction is a more -- natural metric. - | cabalLibVersion < mkVersion [1,3,10] = flags_1_3_10 - | cabalLibVersion < mkVersion [1,10,0] = flags_1_10_0 - | cabalLibVersion < mkVersion [1,12,0] = flags_1_12_0 - | cabalLibVersion < mkVersion [1,14,0] = flags_1_14_0 - | cabalLibVersion < mkVersion [1,18,0] = flags_1_18_0 - | cabalLibVersion < mkVersion [1,19,1] = flags_1_19_1 - | cabalLibVersion < mkVersion [1,19,2] = flags_1_19_2 - | cabalLibVersion < mkVersion [1,21,1] = flags_1_21_1 - | cabalLibVersion < mkVersion [1,22,0] = flags_1_22_0 - | cabalLibVersion < mkVersion [1,22,1] = flags_1_22_1 - | cabalLibVersion < mkVersion [1,23,0] = flags_1_23_0 - | cabalLibVersion < mkVersion [1,25,0] = flags_1_25_0 - | cabalLibVersion < mkVersion [2,1,0] = flags_2_1_0 - | cabalLibVersion < mkVersion [2,5,0] = flags_2_5_0 - | cabalLibVersion < mkVersion [3,7,0] = flags_3_7_0 + | cabalLibVersion < mkVersion [1, 3, 10] = flags_1_3_10 + | cabalLibVersion < mkVersion [1, 10, 0] = flags_1_10_0 + | cabalLibVersion < mkVersion [1, 12, 0] = flags_1_12_0 + | cabalLibVersion < mkVersion [1, 14, 0] = flags_1_14_0 + | cabalLibVersion < mkVersion [1, 18, 0] = flags_1_18_0 + | cabalLibVersion < mkVersion [1, 19, 1] = flags_1_19_1 + | cabalLibVersion < mkVersion [1, 19, 2] = flags_1_19_2 + | cabalLibVersion < mkVersion [1, 21, 1] = flags_1_21_1 + | cabalLibVersion < mkVersion [1, 22, 0] = flags_1_22_0 + | cabalLibVersion < mkVersion [1, 22, 1] = flags_1_22_1 + | cabalLibVersion < mkVersion [1, 23, 0] = flags_1_23_0 + | cabalLibVersion < mkVersion [1, 25, 0] = flags_1_25_0 + | cabalLibVersion < mkVersion [2, 1, 0] = flags_2_1_0 + | cabalLibVersion < mkVersion [2, 5, 0] = flags_2_5_0 + | cabalLibVersion < mkVersion [3, 7, 0] = flags_3_7_0 | otherwise = error "the impossible just happened" -- see first guard where - flags_latest = flags { - -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'. - -- Note: this is not in the wrong place. configConstraints gets - -- repopulated in flags_1_19_1 but it needs to be set to empty for - -- newer versions first. - configConstraints = [] - } - - flags_3_7_0 = flags_latest { - -- Cabal < 3.7 does not know about --extra-lib-dirs-static - configExtraLibDirsStatic = [], - - -- Cabal < 3.7 does not understand '--enable-build-info' or '--disable-build-info' - configDumpBuildInfo = NoFlag - } - - flags_2_5_0 = flags_3_7_0 { - -- Cabal < 2.5 does not understand --dependency=pkg:component=cid - -- (public sublibraries), so we convert it to the legacy - -- --dependency=pkg_or_internal_component=cid - configDependencies = - let convertToLegacyInternalDep (GivenComponent _ (LSubLibName cn) cid) = - Just $ GivenComponent - (unqualComponentNameToPackageName cn) - LMainLibName - cid - convertToLegacyInternalDep (GivenComponent pn LMainLibName cid) = - Just $ GivenComponent pn LMainLibName cid - in catMaybes $ convertToLegacyInternalDep <$> configDependencies flags - -- Cabal < 2.5 doesn't know about '--allow-depending-on-private-libs'. - , configAllowDependingOnPrivateLibs = NoFlag - -- Cabal < 2.5 doesn't know about '--enable/disable-executable-static'. - , configFullyStaticExe = NoFlag - } - - 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 - , configStaticLib = NoFlag - , configSplitSections = NoFlag - } - - flags_1_25_0 = 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 - } - configInstallDirs_1_25_0 = let dirs = configInstallDirs flags in - dirs { dynlibdir = NoFlag - , libexecsubdir = NoFlag - , libexecdir = maybeToFlag $ - combinePathTemplate <$> flagToMaybe (libexecdir dirs) - <*> flagToMaybe (libexecsubdir dirs) - } + flags_latest = + flags + { -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'. + -- Note: this is not in the wrong place. configConstraints gets + -- repopulated in flags_1_19_1 but it needs to be set to empty for + -- newer versions first. + configConstraints = [] + } + + flags_3_7_0 = + flags_latest + { -- Cabal < 3.7 does not know about --extra-lib-dirs-static + configExtraLibDirsStatic = [] + , -- Cabal < 3.7 does not understand '--enable-build-info' or '--disable-build-info' + configDumpBuildInfo = NoFlag + } + + flags_2_5_0 = + flags_3_7_0 + { -- Cabal < 2.5 does not understand --dependency=pkg:component=cid + -- (public sublibraries), so we convert it to the legacy + -- --dependency=pkg_or_internal_component=cid + configDependencies = + let convertToLegacyInternalDep (GivenComponent _ (LSubLibName cn) cid) = + Just $ + GivenComponent + (unqualComponentNameToPackageName cn) + LMainLibName + cid + convertToLegacyInternalDep (GivenComponent pn LMainLibName cid) = + Just $ GivenComponent pn LMainLibName cid + in catMaybes $ convertToLegacyInternalDep <$> configDependencies flags + , -- Cabal < 2.5 doesn't know about '--allow-depending-on-private-libs'. + configAllowDependingOnPrivateLibs = NoFlag + , -- Cabal < 2.5 doesn't know about '--enable/disable-executable-static'. + configFullyStaticExe = NoFlag + } + + 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 + configStaticLib = NoFlag + , configSplitSections = NoFlag + } + + flags_1_25_0 = + 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 + } + configInstallDirs_1_25_0 = + let dirs = configInstallDirs flags + in dirs + { dynlibdir = NoFlag + , libexecsubdir = NoFlag + , libexecdir = + maybeToFlag $ + combinePathTemplate + <$> flagToMaybe (libexecdir dirs) + <*> flagToMaybe (libexecsubdir dirs) + } -- 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 - flags_1_23_0 = flags_1_25_0 { configProfDetail = NoFlag - , configProfLibDetail = NoFlag - , configIPID = NoFlag - , configProf = NoFlag - , configProfExe = Flag tryExeProfiling - , configProfLib = Flag tryLibProfiling - } + flags_1_23_0 = + flags_1_25_0 + { configProfDetail = NoFlag + , configProfLibDetail = NoFlag + , configIPID = NoFlag + , configProf = NoFlag + , configProfExe = Flag tryExeProfiling + , configProfLib = Flag tryLibProfiling + } -- Cabal == 1.22.0.* had a discontinuity (see #5946 or e9a8d48a3adce34d) -- due to temporary amnesia of the --*-executable-profiling flags - flags_1_22_1 = flags_1_23_0 { configDebugInfo = NoFlag - , configProfExe = NoFlag - } + flags_1_22_1 = + flags_1_23_0 + { configDebugInfo = NoFlag + , configProfExe = NoFlag + } -- Cabal < 1.22 doesn't know about '--disable-debug-info'. - flags_1_22_0 = flags_1_23_0 { configDebugInfo = NoFlag } + flags_1_22_0 = flags_1_23_0{configDebugInfo = NoFlag} -- Cabal < 1.21.1 doesn't know about 'disable-relocatable' -- Cabal < 1.21.1 doesn't know about 'enable-profiling' -- (but we already dealt with it in flags_1_23_0) flags_1_21_1 = - flags_1_22_0 { configRelocatable = NoFlag - , configCoverage = NoFlag - , configLibCoverage = configCoverage flags - } + flags_1_22_0 + { configRelocatable = NoFlag + , configCoverage = NoFlag + , configLibCoverage = configCoverage flags + } -- Cabal < 1.19.2 doesn't know about '--exact-configuration' and -- '--enable-library-stripping'. - flags_1_19_2 = flags_1_21_1 { configExactConfiguration = NoFlag - , configStripLibs = NoFlag } + flags_1_19_2 = + flags_1_21_1 + { configExactConfiguration = NoFlag + , configStripLibs = NoFlag + } -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'. - flags_1_19_1 = flags_1_19_2 { configDependencies = [] - , configConstraints = configConstraints flags } + flags_1_19_1 = + flags_1_19_2 + { configDependencies = [] + , configConstraints = configConstraints flags + } -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir. - flags_1_18_0 = flags_1_19_1 { configProgramPathExtra = toNubList [] - , configInstallDirs = configInstallDirs_1_18_0} - configInstallDirs_1_18_0 = (configInstallDirs flags_1_19_1) { sysconfdir = NoFlag } + flags_1_18_0 = + flags_1_19_1 + { configProgramPathExtra = toNubList [] + , configInstallDirs = configInstallDirs_1_18_0 + } + configInstallDirs_1_18_0 = (configInstallDirs flags_1_19_1){sysconfdir = NoFlag} -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'. - flags_1_14_0 = flags_1_18_0 { configBenchmarks = NoFlag } + flags_1_14_0 = flags_1_18_0{configBenchmarks = NoFlag} -- Cabal < 1.12.0 doesn't know about '--enable/disable-executable-dynamic' -- and '--enable/disable-library-coverage'. - flags_1_12_0 = flags_1_14_0 { configLibCoverage = NoFlag - , configDynExe = NoFlag } + flags_1_12_0 = + flags_1_14_0 + { configLibCoverage = NoFlag + , configDynExe = NoFlag + } -- Cabal < 1.10.0 doesn't know about '--disable-tests'. - flags_1_10_0 = flags_1_12_0 { configTests = NoFlag } + flags_1_10_0 = flags_1_12_0{configTests = NoFlag} -- Cabal < 1.3.10 does not grok the '--constraints' flag. - flags_1_3_10 = flags_1_10_0 { configConstraints = [] } + flags_1_3_10 = flags_1_10_0{configConstraints = []} -- | Get the package database settings from 'ConfigFlags', accounting for -- @--package-db@ and @--user@ flags. configPackageDB' :: ConfigFlags -> PackageDBStack configPackageDB' cfg = - interpretPackageDbFlags userInstall (configPackageDBs cfg) + interpretPackageDbFlags userInstall (configPackageDBs cfg) where userInstall = Cabal.fromFlagOrDefault True (configUserInstall cfg) -- | Configure the compiler, but reduce verbosity during this step. configCompilerAux' :: ConfigFlags -> IO (Compiler, Platform, ProgramDb) configCompilerAux' configFlags = - configCompilerAuxEx configFlags - --FIXME: make configCompilerAux use a sensible verbosity - { configVerbosity = fmap lessVerbose (configVerbosity configFlags) } + configCompilerAuxEx + configFlags + { -- FIXME: make configCompilerAux use a sensible verbosity + configVerbosity = fmap lessVerbose (configVerbosity configFlags) + } -- ------------------------------------------------------------ + -- * Config extra flags + -- ------------------------------------------------------------ -- | cabal configure takes some extra flags beyond runghc Setup configure --- -data ConfigExFlags = ConfigExFlags { - configCabalVersion :: Flag Version, - configAppend :: Flag Bool, - configBackup :: Flag Bool, - configExConstraints :: [(UserConstraint, ConstraintSource)], - configPreferences :: [PackageVersionConstraint], - configSolver :: Flag PreSolver, - configAllowNewer :: Maybe AllowNewer, - configAllowOlder :: Maybe AllowOlder, - configWriteGhcEnvironmentFilesPolicy +data ConfigExFlags = ConfigExFlags + { configCabalVersion :: Flag Version + , configAppend :: Flag Bool + , configBackup :: Flag Bool + , configExConstraints :: [(UserConstraint, ConstraintSource)] + , configPreferences :: [PackageVersionConstraint] + , configSolver :: Flag PreSolver + , configAllowNewer :: Maybe AllowNewer + , configAllowOlder :: Maybe AllowOlder + , configWriteGhcEnvironmentFilesPolicy :: Flag WriteGhcEnvironmentFilesPolicy } deriving (Eq, Show, Generic) defaultConfigExFlags :: ConfigExFlags -defaultConfigExFlags = mempty { configSolver = Flag defaultSolver } +defaultConfigExFlags = mempty{configSolver = Flag defaultSolver} configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags) -configureExCommand = configureCommand { - commandDefaultFlags = (mempty, defaultConfigExFlags), - commandOptions = \showOrParseArgs -> - liftOptions fst setFst - (filter ((`notElem` ["constraint", "dependency", "exact-configuration"]) - . optionName) $ configureOptions showOrParseArgs) - ++ liftOptions snd setSnd - (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag) - } +configureExCommand = + configureCommand + { commandDefaultFlags = (mempty, defaultConfigExFlags) + , commandOptions = \showOrParseArgs -> + liftOptions + fst + setFst + ( filter + ( (`notElem` ["constraint", "dependency", "exact-configuration"]) + . optionName + ) + $ configureOptions showOrParseArgs + ) + ++ liftOptions + snd + setSnd + (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag) + } where - setFst a (_,b) = (a,b) - setSnd b (a,_) = (a,b) + setFst a (_, b) = (a, b) + setSnd b (a, _) = (a, b) -configureExOptions :: ShowOrParseArgs - -> ConstraintSource - -> [OptionField ConfigExFlags] +configureExOptions + :: ShowOrParseArgs + -> ConstraintSource + -> [OptionField ConfigExFlags] configureExOptions _showOrParseArgs src = - [ option [] ["cabal-lib-version"] - ("Select which version of the Cabal lib to use to build packages " - ++ "(useful for testing).") - configCabalVersion (\v flags -> flags { configCabalVersion = v }) - (reqArg "VERSION" (parsecToReadE ("Cannot parse cabal lib version: "++) - (fmap toFlag parsec)) - (map prettyShow. flagToList)) - , option "" ["append"] + [ option + [] + ["cabal-lib-version"] + ( "Select which version of the Cabal lib to use to build packages " + ++ "(useful for testing)." + ) + configCabalVersion + (\v flags -> flags{configCabalVersion = v}) + ( reqArg + "VERSION" + ( parsecToReadE + ("Cannot parse cabal lib version: " ++) + (fmap toFlag parsec) + ) + (map prettyShow . flagToList) + ) + , option + "" + ["append"] "appending the new config to the old config file" - configAppend (\v flags -> flags { configAppend = v }) + configAppend + (\v flags -> flags{configAppend = v}) (boolOpt [] []) - , option "" ["backup"] + , option + "" + ["backup"] "the backup of the config file before any alterations" - configBackup (\v flags -> flags { configBackup = v }) + configBackup + (\v flags -> flags{configBackup = v}) (boolOpt [] []) - , option "c" ["constraint"] + , option + "c" + ["constraint"] "Specify constraints on a package (version, installed/source, flags)" - configExConstraints (\v flags -> flags { configExConstraints = v }) - (reqArg "CONSTRAINT" - ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint) - (map $ prettyShow . fst)) - - , option [] ["preference"] + configExConstraints + (\v flags -> flags{configExConstraints = v}) + ( reqArg + "CONSTRAINT" + ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint) + (map $ prettyShow . fst) + ) + , option + [] + ["preference"] "Specify preferences (soft constraints) on the version of a package" - configPreferences (\v flags -> flags { configPreferences = v }) - (reqArg "CONSTRAINT" - (parsecToReadE (const "dependency expected") - (fmap (\x -> [x]) parsec)) - (map prettyShow)) - - , optionSolver configSolver (\v flags -> flags { configSolver = v }) - - , option [] ["allow-older"] - ("Ignore lower bounds in all dependencies or DEPS") - (fmap unAllowOlder . configAllowOlder) - (\v flags -> flags { configAllowOlder = fmap AllowOlder v}) - (optArg "DEPS" - (parsecToReadEErr unexpectMsgString relaxDepsParser) - (Just RelaxDepsAll) relaxDepsPrinter) - - , option [] ["allow-newer"] - ("Ignore upper bounds in all dependencies or DEPS") - (fmap unAllowNewer . configAllowNewer) - (\v flags -> flags { configAllowNewer = fmap AllowNewer v}) - (optArg "DEPS" - (parsecToReadEErr unexpectMsgString relaxDepsParser) - (Just RelaxDepsAll) relaxDepsPrinter) - - , option [] ["write-ghc-environment-files"] - ("Whether to create a .ghc.environment file after a successful build" - ++ " (v2-build only)") - configWriteGhcEnvironmentFilesPolicy - (\v flags -> flags { configWriteGhcEnvironmentFilesPolicy = v}) - (reqArg "always|never|ghc8.4.4+" - writeGhcEnvironmentFilesPolicyParser - writeGhcEnvironmentFilesPolicyPrinter) + configPreferences + (\v flags -> flags{configPreferences = v}) + ( reqArg + "CONSTRAINT" + ( parsecToReadE + (const "dependency expected") + (fmap (\x -> [x]) parsec) + ) + (map prettyShow) + ) + , optionSolver configSolver (\v flags -> flags{configSolver = v}) + , option + [] + ["allow-older"] + ("Ignore lower bounds in all dependencies or DEPS") + (fmap unAllowOlder . configAllowOlder) + (\v flags -> flags{configAllowOlder = fmap AllowOlder v}) + ( optArg + "DEPS" + (parsecToReadEErr unexpectMsgString relaxDepsParser) + (Just RelaxDepsAll) + relaxDepsPrinter + ) + , option + [] + ["allow-newer"] + ("Ignore upper bounds in all dependencies or DEPS") + (fmap unAllowNewer . configAllowNewer) + (\v flags -> flags{configAllowNewer = fmap AllowNewer v}) + ( optArg + "DEPS" + (parsecToReadEErr unexpectMsgString relaxDepsParser) + (Just RelaxDepsAll) + relaxDepsPrinter + ) + , option + [] + ["write-ghc-environment-files"] + ( "Whether to create a .ghc.environment file after a successful build" + ++ " (v2-build only)" + ) + configWriteGhcEnvironmentFilesPolicy + (\v flags -> flags{configWriteGhcEnvironmentFilesPolicy = v}) + ( reqArg + "always|never|ghc8.4.4+" + writeGhcEnvironmentFilesPolicyParser + writeGhcEnvironmentFilesPolicyPrinter + ) ] - writeGhcEnvironmentFilesPolicyParser :: ReadE (Flag WriteGhcEnvironmentFilesPolicy) writeGhcEnvironmentFilesPolicyParser = ReadE $ \case - "always" -> Right $ Flag AlwaysWriteGhcEnvironmentFiles - "never" -> Right $ Flag NeverWriteGhcEnvironmentFiles + "always" -> Right $ Flag AlwaysWriteGhcEnvironmentFiles + "never" -> Right $ Flag NeverWriteGhcEnvironmentFiles "ghc8.4.4+" -> Right $ Flag WriteGhcEnvironmentFilesOnlyForGhc844AndNewer - policy -> Left $ "Cannot parse the GHC environment file write policy '" - <> policy <> "'" + policy -> + Left $ + "Cannot parse the GHC environment file write policy '" + <> policy + <> "'" writeGhcEnvironmentFilesPolicyPrinter :: Flag WriteGhcEnvironmentFilesPolicy -> [String] writeGhcEnvironmentFilesPolicyPrinter = \case - (Flag AlwaysWriteGhcEnvironmentFiles) -> ["always"] - (Flag NeverWriteGhcEnvironmentFiles) -> ["never"] + (Flag AlwaysWriteGhcEnvironmentFiles) -> ["always"] + (Flag NeverWriteGhcEnvironmentFiles) -> ["never"] (Flag WriteGhcEnvironmentFilesOnlyForGhc844AndNewer) -> ["ghc8.4.4+"] - NoFlag -> [] - + NoFlag -> [] relaxDepsParser :: CabalParsing m => m (Maybe RelaxDeps) relaxDepsParser = do rs <- P.sepBy parsec (P.char ',') if null rs - then fail $ "empty argument list is not allowed. " - ++ "Note: use --allow-newer without the equals sign to permit all " - ++ "packages to use newer versions." + then + fail $ + "empty argument list is not allowed. " + ++ "Note: use --allow-newer without the equals sign to permit all " + ++ "packages to use newer versions." else return . Just . RelaxDepsSome . toList $ rs relaxDepsPrinter :: (Maybe RelaxDeps) -> [Maybe String] -relaxDepsPrinter Nothing = [] -relaxDepsPrinter (Just RelaxDepsAll) = [Nothing] +relaxDepsPrinter Nothing = [] +relaxDepsPrinter (Just RelaxDepsAll) = [Nothing] relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . prettyShow) $ pkgs - instance Monoid ConfigExFlags where mempty = gmempty mappend = (<>) @@ -752,55 +992,73 @@ instance Semigroup ConfigExFlags where (<>) = gmappend reconfigureCommand :: CommandUI (ConfigFlags, ConfigExFlags) -reconfigureCommand - = configureExCommand - { commandName = "reconfigure" - , commandSynopsis = "Reconfigure the package if necessary." - , commandDescription = Just $ \pname -> wrapText $ - "Run `configure` with the most recently used flags, or append FLAGS " - ++ "to the most recently used configuration. " - ++ "Accepts the same flags as `" ++ pname ++ " v1-configure'. " - ++ "If the package has never been configured, the default flags are " - ++ "used." - , commandNotes = Just $ \pname -> +reconfigureCommand = + configureExCommand + { commandName = "reconfigure" + , commandSynopsis = "Reconfigure the package if necessary." + , commandDescription = Just $ \pname -> + wrapText $ + "Run `configure` with the most recently used flags, or append FLAGS " + ++ "to the most recently used configuration. " + ++ "Accepts the same flags as `" + ++ pname + ++ " v1-configure'. " + ++ "If the package has never been configured, the default flags are " + ++ "used." + , commandNotes = Just $ \pname -> "Examples:\n" - ++ " " ++ pname ++ " v1-reconfigure\n" - ++ " Configure with the most recently used flags.\n" - ++ " " ++ pname ++ " v1-reconfigure -w PATH\n" - ++ " Reconfigure with the most recently used flags,\n" - ++ " but use the compiler at PATH.\n\n" - , commandUsage = usageAlternatives "v1-reconfigure" [ "[FLAGS]" ] + ++ " " + ++ pname + ++ " v1-reconfigure\n" + ++ " Configure with the most recently used flags.\n" + ++ " " + ++ pname + ++ " v1-reconfigure -w PATH\n" + ++ " Reconfigure with the most recently used flags,\n" + ++ " but use the compiler at PATH.\n\n" + , commandUsage = usageAlternatives "v1-reconfigure" ["[FLAGS]"] , commandDefaultFlags = mempty } -- ------------------------------------------------------------ + -- * Build flags + -- ------------------------------------------------------------ buildCommand :: CommandUI BuildFlags -buildCommand = parent { - commandName = "build", - commandDescription = Just $ \_ -> wrapText $ - "Components encompass executables, tests, and benchmarks.\n" - ++ "\n" - ++ "Affected by configuration options, see `v1-configure`.\n", - commandDefaultFlags = commandDefaultFlags parent, - commandUsage = usageAlternatives "v1-build" $ - [ "[FLAGS]", "COMPONENTS [FLAGS]" ], - commandOptions = commandOptions parent - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v1-build " - ++ " All the components in the package\n" - ++ " " ++ pname ++ " v1-build foo " - ++ " A component (i.e. lib, exe, test suite)\n\n" - ++ Cabal.programFlagsDescription defaultProgramDb - } +buildCommand = + parent + { commandName = "build" + , commandDescription = Just $ \_ -> + wrapText $ + "Components encompass executables, tests, and benchmarks.\n" + ++ "\n" + ++ "Affected by configuration options, see `v1-configure`.\n" + , commandDefaultFlags = commandDefaultFlags parent + , commandUsage = + usageAlternatives "v1-build" $ + ["[FLAGS]", "COMPONENTS [FLAGS]"] + , commandOptions = commandOptions parent + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " + ++ pname + ++ " v1-build " + ++ " All the components in the package\n" + ++ " " + ++ pname + ++ " v1-build foo " + ++ " A component (i.e. lib, exe, test suite)\n\n" + ++ Cabal.programFlagsDescription defaultProgramDb + } where parent = Cabal.buildCommand defaultProgramDb -- ------------------------------------------------------------ + -- * Test flags + -- ------------------------------------------------------------ -- | Given some 'TestFlags' for the version of Cabal that @@ -815,491 +1073,617 @@ 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 + | cabalLibVersion >= mkVersion [3, 0, 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 -- these flags work for; version of introduction is a more -- natural metric. - | cabalLibVersion < mkVersion [3,0,0] = flags_3_0_0 + | cabalLibVersion < mkVersion [3, 0, 0] = flags_3_0_0 | otherwise = error "the impossible just happened" -- see first guard where flags_latest = flags - flags_3_0_0 = flags_latest { - -- Cabal < 3.0 doesn't know about --test-wrapper - Cabal.testWrapper = NoFlag - } + flags_3_0_0 = + flags_latest + { -- Cabal < 3.0 doesn't know about --test-wrapper + Cabal.testWrapper = NoFlag + } -- ------------------------------------------------------------ + -- * Repl command + -- ------------------------------------------------------------ replCommand :: CommandUI ReplFlags -replCommand = parent { - commandName = "repl", - commandDescription = Just $ \pname -> wrapText $ - "If the current directory contains no package, ignores COMPONENT " - ++ "parameters and opens an interactive interpreter session;\n" - ++ "\n" - ++ "Otherwise, (re)configures with the given or default flags, and " - ++ "loads the interpreter with the relevant modules. For executables, " - ++ "tests and benchmarks, loads the main module (and its " - ++ "dependencies); for libraries all exposed/other modules.\n" - ++ "\n" - ++ "The default component is the library itself, or the executable " - ++ "if that is the only component.\n" - ++ "\n" - ++ "Support for loading specific modules is planned but not " - ++ "implemented yet. For certain scenarios, `" ++ pname - ++ " v1-exec -- ghci :l Foo` may be used instead. Note that `v1-exec` will " - ++ "not (re)configure and you will have to specify the location of " - ++ "other modules, if required.\n", - commandUsage = \pname -> "Usage: " ++ pname ++ " v1-repl [COMPONENT] [FLAGS]\n", - commandDefaultFlags = commandDefaultFlags parent, - commandOptions = commandOptions parent, - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v1-repl " - ++ " The first component in the package\n" - ++ " " ++ pname ++ " v1-repl foo " - ++ " A named component (i.e. lib, exe, test suite)\n" - ++ " " ++ pname ++ " v1-repl --ghc-options=\"-lstdc++\"" - ++ " Specifying flags for interpreter\n" - } +replCommand = + parent + { commandName = "repl" + , commandDescription = Just $ \pname -> + wrapText $ + "If the current directory contains no package, ignores COMPONENT " + ++ "parameters and opens an interactive interpreter session;\n" + ++ "\n" + ++ "Otherwise, (re)configures with the given or default flags, and " + ++ "loads the interpreter with the relevant modules. For executables, " + ++ "tests and benchmarks, loads the main module (and its " + ++ "dependencies); for libraries all exposed/other modules.\n" + ++ "\n" + ++ "The default component is the library itself, or the executable " + ++ "if that is the only component.\n" + ++ "\n" + ++ "Support for loading specific modules is planned but not " + ++ "implemented yet. For certain scenarios, `" + ++ pname + ++ " v1-exec -- ghci :l Foo` may be used instead. Note that `v1-exec` will " + ++ "not (re)configure and you will have to specify the location of " + ++ "other modules, if required.\n" + , commandUsage = \pname -> "Usage: " ++ pname ++ " v1-repl [COMPONENT] [FLAGS]\n" + , commandDefaultFlags = commandDefaultFlags parent + , commandOptions = commandOptions parent + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " + ++ pname + ++ " v1-repl " + ++ " The first component in the package\n" + ++ " " + ++ pname + ++ " v1-repl foo " + ++ " A named component (i.e. lib, exe, test suite)\n" + ++ " " + ++ pname + ++ " v1-repl --ghc-options=\"-lstdc++\"" + ++ " Specifying flags for interpreter\n" + } where parent = Cabal.replCommand defaultProgramDb -- ------------------------------------------------------------ + -- * Test command + -- ------------------------------------------------------------ testCommand :: CommandUI (BuildFlags, TestFlags) -testCommand = parent { - commandName = "test", - commandDescription = Just $ \pname -> wrapText $ - "If necessary (re)configures with `--enable-tests` flag and builds" - ++ " the test suite.\n" - ++ "\n" - ++ "Remember that the tests' dependencies must be installed if there" - ++ " are additional ones; e.g. with `" ++ pname - ++ " v1-install --only-dependencies --enable-tests`.\n" - ++ "\n" - ++ "By defining UserHooks in a custom Setup.hs, the package can" - ++ " define actions to be executed before and after running tests.\n", - commandUsage = usageAlternatives "v1-test" - [ "[FLAGS]", "TESTCOMPONENTS [FLAGS]" ], - commandDefaultFlags = (Cabal.defaultBuildFlags, commandDefaultFlags parent), - commandOptions = - \showOrParseArgs -> liftOptions get1 set1 - (Cabal.buildOptions progDb showOrParseArgs) - ++ - liftOptions get2 set2 - (commandOptions parent showOrParseArgs) - } +testCommand = + parent + { commandName = "test" + , commandDescription = Just $ \pname -> + wrapText $ + "If necessary (re)configures with `--enable-tests` flag and builds" + ++ " the test suite.\n" + ++ "\n" + ++ "Remember that the tests' dependencies must be installed if there" + ++ " are additional ones; e.g. with `" + ++ pname + ++ " v1-install --only-dependencies --enable-tests`.\n" + ++ "\n" + ++ "By defining UserHooks in a custom Setup.hs, the package can" + ++ " define actions to be executed before and after running tests.\n" + , commandUsage = + usageAlternatives + "v1-test" + ["[FLAGS]", "TESTCOMPONENTS [FLAGS]"] + , commandDefaultFlags = (Cabal.defaultBuildFlags, commandDefaultFlags parent) + , commandOptions = + \showOrParseArgs -> + liftOptions + get1 + set1 + (Cabal.buildOptions progDb showOrParseArgs) + ++ liftOptions + get2 + set2 + (commandOptions parent showOrParseArgs) + } where - get1 (a,_) = a; set1 a (_,b) = (a,b) - get2 (_,b) = b; set2 b (a,_) = (a,b) + get1 (a, _) = a + set1 a (_, b) = (a, b) + get2 (_, b) = b + set2 b (a, _) = (a, b) parent = Cabal.testCommand progDb = defaultProgramDb -- ------------------------------------------------------------ + -- * Bench command + -- ------------------------------------------------------------ benchmarkCommand :: CommandUI (BuildFlags, BenchmarkFlags) -benchmarkCommand = parent { - commandName = "bench", - commandUsage = usageAlternatives "v1-bench" - [ "[FLAGS]", "BENCHCOMPONENTS [FLAGS]" ], - commandDescription = Just $ \pname -> wrapText $ - "If necessary (re)configures with `--enable-benchmarks` flag and" - ++ " builds the benchmarks.\n" - ++ "\n" - ++ "Remember that the benchmarks' dependencies must be installed if" - ++ " there are additional ones; e.g. with `" ++ pname - ++ " v1-install --only-dependencies --enable-benchmarks`.\n" - ++ "\n" - ++ "By defining UserHooks in a custom Setup.hs, the package can" - ++ " define actions to be executed before and after running" - ++ " benchmarks.\n", - commandDefaultFlags = (Cabal.defaultBuildFlags, commandDefaultFlags parent), - commandOptions = - \showOrParseArgs -> liftOptions get1 set1 - (Cabal.buildOptions progDb showOrParseArgs) - ++ - liftOptions get2 set2 - (commandOptions parent showOrParseArgs) - } +benchmarkCommand = + parent + { commandName = "bench" + , commandUsage = + usageAlternatives + "v1-bench" + ["[FLAGS]", "BENCHCOMPONENTS [FLAGS]"] + , commandDescription = Just $ \pname -> + wrapText $ + "If necessary (re)configures with `--enable-benchmarks` flag and" + ++ " builds the benchmarks.\n" + ++ "\n" + ++ "Remember that the benchmarks' dependencies must be installed if" + ++ " there are additional ones; e.g. with `" + ++ pname + ++ " v1-install --only-dependencies --enable-benchmarks`.\n" + ++ "\n" + ++ "By defining UserHooks in a custom Setup.hs, the package can" + ++ " define actions to be executed before and after running" + ++ " benchmarks.\n" + , commandDefaultFlags = (Cabal.defaultBuildFlags, commandDefaultFlags parent) + , commandOptions = + \showOrParseArgs -> + liftOptions + get1 + set1 + (Cabal.buildOptions progDb showOrParseArgs) + ++ liftOptions + get2 + set2 + (commandOptions parent showOrParseArgs) + } where - get1 (a,_) = a; set1 a (_,b) = (a,b) - get2 (_,b) = b; set2 b (a,_) = (a,b) + get1 (a, _) = a + set1 a (_, b) = (a, b) + get2 (_, b) = b + set2 b (a, _) = (a, b) parent = Cabal.benchmarkCommand progDb = defaultProgramDb -- ------------------------------------------------------------ + -- * Fetch command + -- ------------------------------------------------------------ -data FetchFlags = FetchFlags { --- fetchOutput :: Flag FilePath, - fetchDeps :: Flag Bool, - fetchDryRun :: Flag Bool, - fetchSolver :: Flag PreSolver, - fetchMaxBackjumps :: Flag Int, - fetchReorderGoals :: Flag ReorderGoals, - fetchCountConflicts :: Flag CountConflicts, - fetchFineGrainedConflicts :: Flag FineGrainedConflicts, - fetchMinimizeConflictSet :: Flag MinimizeConflictSet, - fetchIndependentGoals :: Flag IndependentGoals, - fetchPreferOldest :: Flag PreferOldest, - fetchShadowPkgs :: Flag ShadowPkgs, - fetchStrongFlags :: Flag StrongFlags, - fetchAllowBootLibInstalls :: Flag AllowBootLibInstalls, - fetchOnlyConstrained :: Flag OnlyConstrained, - fetchTests :: Flag Bool, - fetchBenchmarks :: Flag Bool, - fetchVerbosity :: Flag Verbosity - } +data FetchFlags = FetchFlags + { -- fetchOutput :: Flag FilePath, + fetchDeps :: Flag Bool + , fetchDryRun :: Flag Bool + , fetchSolver :: Flag PreSolver + , fetchMaxBackjumps :: Flag Int + , fetchReorderGoals :: Flag ReorderGoals + , fetchCountConflicts :: Flag CountConflicts + , fetchFineGrainedConflicts :: Flag FineGrainedConflicts + , fetchMinimizeConflictSet :: Flag MinimizeConflictSet + , fetchIndependentGoals :: Flag IndependentGoals + , fetchPreferOldest :: Flag PreferOldest + , fetchShadowPkgs :: Flag ShadowPkgs + , fetchStrongFlags :: Flag StrongFlags + , fetchAllowBootLibInstalls :: Flag AllowBootLibInstalls + , fetchOnlyConstrained :: Flag OnlyConstrained + , fetchTests :: Flag Bool + , fetchBenchmarks :: Flag Bool + , fetchVerbosity :: Flag Verbosity + } defaultFetchFlags :: FetchFlags -defaultFetchFlags = FetchFlags { --- fetchOutput = mempty, - fetchDeps = toFlag True, - fetchDryRun = toFlag False, - fetchSolver = Flag defaultSolver, - fetchMaxBackjumps = Flag defaultMaxBackjumps, - fetchReorderGoals = Flag (ReorderGoals False), - fetchCountConflicts = Flag (CountConflicts True), - fetchFineGrainedConflicts = Flag (FineGrainedConflicts True), - fetchMinimizeConflictSet = Flag (MinimizeConflictSet False), - fetchIndependentGoals = Flag (IndependentGoals False), - fetchPreferOldest = Flag (PreferOldest False), - fetchShadowPkgs = Flag (ShadowPkgs False), - fetchStrongFlags = Flag (StrongFlags False), - fetchAllowBootLibInstalls = Flag (AllowBootLibInstalls False), - fetchOnlyConstrained = Flag OnlyConstrainedNone, - fetchTests = toFlag False, - fetchBenchmarks = toFlag False, - fetchVerbosity = toFlag normal - } +defaultFetchFlags = + FetchFlags + { -- fetchOutput = mempty, + fetchDeps = toFlag True + , fetchDryRun = toFlag False + , fetchSolver = Flag defaultSolver + , fetchMaxBackjumps = Flag defaultMaxBackjumps + , fetchReorderGoals = Flag (ReorderGoals False) + , fetchCountConflicts = Flag (CountConflicts True) + , fetchFineGrainedConflicts = Flag (FineGrainedConflicts True) + , fetchMinimizeConflictSet = Flag (MinimizeConflictSet False) + , fetchIndependentGoals = Flag (IndependentGoals False) + , fetchPreferOldest = Flag (PreferOldest False) + , fetchShadowPkgs = Flag (ShadowPkgs False) + , fetchStrongFlags = Flag (StrongFlags False) + , fetchAllowBootLibInstalls = Flag (AllowBootLibInstalls False) + , fetchOnlyConstrained = Flag OnlyConstrainedNone + , fetchTests = toFlag False + , fetchBenchmarks = toFlag False + , fetchVerbosity = toFlag normal + } fetchCommand :: CommandUI FetchFlags -fetchCommand = CommandUI { - commandName = "fetch", - commandSynopsis = "Downloads packages for later installation.", - commandUsage = usageAlternatives "fetch" [ "[FLAGS] PACKAGES" - ], - commandDescription = Just $ \_ -> - "Note that it currently is not possible to fetch the dependencies for a\n" - ++ "package in the current directory.\n", - commandNotes = Nothing, - commandDefaultFlags = defaultFetchFlags, - commandOptions = \ showOrParseArgs -> [ - optionVerbosity fetchVerbosity (\v flags -> flags { fetchVerbosity = v }) - --- , option "o" ["output"] --- "Put the package(s) somewhere specific rather than the usual cache." --- fetchOutput (\v flags -> flags { fetchOutput = v }) --- (reqArgFlag "PATH") - - , option [] ["dependencies", "deps"] - "Resolve and fetch dependencies (default)" - fetchDeps (\v flags -> flags { fetchDeps = v }) - trueArg - - , option [] ["no-dependencies", "no-deps"] - "Ignore dependencies" - fetchDeps (\v flags -> flags { fetchDeps = v }) - falseArg - - , option [] ["dry-run"] - "Do not install anything, only print what would be installed." - fetchDryRun (\v flags -> flags { fetchDryRun = v }) - trueArg - - , option "" ["tests"] - "dependency checking and compilation for test suites listed in the package description file." - fetchTests (\v flags -> flags { fetchTests = v }) - (boolOpt [] []) - - , option "" ["benchmarks"] - "dependency checking and compilation for benchmarks listed in the package description file." - fetchBenchmarks (\v flags -> flags { fetchBenchmarks = v }) - (boolOpt [] []) - - ] ++ - - optionSolver fetchSolver (\v flags -> flags { fetchSolver = v }) : - optionSolverFlags showOrParseArgs - fetchMaxBackjumps (\v flags -> flags { fetchMaxBackjumps = v }) - fetchReorderGoals (\v flags -> flags { fetchReorderGoals = v }) - fetchCountConflicts (\v flags -> flags { fetchCountConflicts = v }) - fetchFineGrainedConflicts (\v flags -> flags { fetchFineGrainedConflicts = v }) - fetchMinimizeConflictSet (\v flags -> flags { fetchMinimizeConflictSet = v }) - fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v }) - fetchPreferOldest (\v flags -> flags { fetchPreferOldest = v }) - fetchShadowPkgs (\v flags -> flags { fetchShadowPkgs = v }) - fetchStrongFlags (\v flags -> flags { fetchStrongFlags = v }) - fetchAllowBootLibInstalls (\v flags -> flags { fetchAllowBootLibInstalls = v }) - fetchOnlyConstrained (\v flags -> flags { fetchOnlyConstrained = v }) - - } +fetchCommand = + CommandUI + { commandName = "fetch" + , commandSynopsis = "Downloads packages for later installation." + , commandUsage = + usageAlternatives + "fetch" + [ "[FLAGS] PACKAGES" + ] + , commandDescription = Just $ \_ -> + "Note that it currently is not possible to fetch the dependencies for a\n" + ++ "package in the current directory.\n" + , commandNotes = Nothing + , commandDefaultFlags = defaultFetchFlags + , commandOptions = \showOrParseArgs -> + [ optionVerbosity fetchVerbosity (\v flags -> flags{fetchVerbosity = v}) + , -- , option "o" ["output"] + -- "Put the package(s) somewhere specific rather than the usual cache." + -- fetchOutput (\v flags -> flags { fetchOutput = v }) + -- (reqArgFlag "PATH") + + option + [] + ["dependencies", "deps"] + "Resolve and fetch dependencies (default)" + fetchDeps + (\v flags -> flags{fetchDeps = v}) + trueArg + , option + [] + ["no-dependencies", "no-deps"] + "Ignore dependencies" + fetchDeps + (\v flags -> flags{fetchDeps = v}) + falseArg + , option + [] + ["dry-run"] + "Do not install anything, only print what would be installed." + fetchDryRun + (\v flags -> flags{fetchDryRun = v}) + trueArg + , option + "" + ["tests"] + "dependency checking and compilation for test suites listed in the package description file." + fetchTests + (\v flags -> flags{fetchTests = v}) + (boolOpt [] []) + , option + "" + ["benchmarks"] + "dependency checking and compilation for benchmarks listed in the package description file." + fetchBenchmarks + (\v flags -> flags{fetchBenchmarks = v}) + (boolOpt [] []) + ] + ++ optionSolver fetchSolver (\v flags -> flags{fetchSolver = v}) + : optionSolverFlags + showOrParseArgs + fetchMaxBackjumps + (\v flags -> flags{fetchMaxBackjumps = v}) + fetchReorderGoals + (\v flags -> flags{fetchReorderGoals = v}) + fetchCountConflicts + (\v flags -> flags{fetchCountConflicts = v}) + fetchFineGrainedConflicts + (\v flags -> flags{fetchFineGrainedConflicts = v}) + fetchMinimizeConflictSet + (\v flags -> flags{fetchMinimizeConflictSet = v}) + fetchIndependentGoals + (\v flags -> flags{fetchIndependentGoals = v}) + fetchPreferOldest + (\v flags -> flags{fetchPreferOldest = v}) + fetchShadowPkgs + (\v flags -> flags{fetchShadowPkgs = v}) + fetchStrongFlags + (\v flags -> flags{fetchStrongFlags = v}) + fetchAllowBootLibInstalls + (\v flags -> flags{fetchAllowBootLibInstalls = v}) + fetchOnlyConstrained + (\v flags -> flags{fetchOnlyConstrained = v}) + } -- ------------------------------------------------------------ + -- * Freeze command + -- ------------------------------------------------------------ -data FreezeFlags = FreezeFlags { - freezeDryRun :: Flag Bool, - freezeTests :: Flag Bool, - freezeBenchmarks :: Flag Bool, - freezeSolver :: Flag PreSolver, - freezeMaxBackjumps :: Flag Int, - freezeReorderGoals :: Flag ReorderGoals, - freezeCountConflicts :: Flag CountConflicts, - freezeFineGrainedConflicts :: Flag FineGrainedConflicts, - freezeMinimizeConflictSet :: Flag MinimizeConflictSet, - freezeIndependentGoals :: Flag IndependentGoals, - freezePreferOldest :: Flag PreferOldest, - freezeShadowPkgs :: Flag ShadowPkgs, - freezeStrongFlags :: Flag StrongFlags, - freezeAllowBootLibInstalls :: Flag AllowBootLibInstalls, - freezeOnlyConstrained :: Flag OnlyConstrained, - freezeVerbosity :: Flag Verbosity - } +data FreezeFlags = FreezeFlags + { freezeDryRun :: Flag Bool + , freezeTests :: Flag Bool + , freezeBenchmarks :: Flag Bool + , freezeSolver :: Flag PreSolver + , freezeMaxBackjumps :: Flag Int + , freezeReorderGoals :: Flag ReorderGoals + , freezeCountConflicts :: Flag CountConflicts + , freezeFineGrainedConflicts :: Flag FineGrainedConflicts + , freezeMinimizeConflictSet :: Flag MinimizeConflictSet + , freezeIndependentGoals :: Flag IndependentGoals + , freezePreferOldest :: Flag PreferOldest + , freezeShadowPkgs :: Flag ShadowPkgs + , freezeStrongFlags :: Flag StrongFlags + , freezeAllowBootLibInstalls :: Flag AllowBootLibInstalls + , freezeOnlyConstrained :: Flag OnlyConstrained + , freezeVerbosity :: Flag Verbosity + } defaultFreezeFlags :: FreezeFlags -defaultFreezeFlags = FreezeFlags { - freezeDryRun = toFlag False, - freezeTests = toFlag False, - freezeBenchmarks = toFlag False, - freezeSolver = Flag defaultSolver, - freezeMaxBackjumps = Flag defaultMaxBackjumps, - freezeReorderGoals = Flag (ReorderGoals False), - freezeCountConflicts = Flag (CountConflicts True), - freezeFineGrainedConflicts = Flag (FineGrainedConflicts True), - freezeMinimizeConflictSet = Flag (MinimizeConflictSet False), - freezeIndependentGoals = Flag (IndependentGoals False), - freezePreferOldest = Flag (PreferOldest False), - freezeShadowPkgs = Flag (ShadowPkgs False), - freezeStrongFlags = Flag (StrongFlags False), - freezeAllowBootLibInstalls = Flag (AllowBootLibInstalls False), - freezeOnlyConstrained = Flag OnlyConstrainedNone, - freezeVerbosity = toFlag normal - } +defaultFreezeFlags = + FreezeFlags + { freezeDryRun = toFlag False + , freezeTests = toFlag False + , freezeBenchmarks = toFlag False + , freezeSolver = Flag defaultSolver + , freezeMaxBackjumps = Flag defaultMaxBackjumps + , freezeReorderGoals = Flag (ReorderGoals False) + , freezeCountConflicts = Flag (CountConflicts True) + , freezeFineGrainedConflicts = Flag (FineGrainedConflicts True) + , freezeMinimizeConflictSet = Flag (MinimizeConflictSet False) + , freezeIndependentGoals = Flag (IndependentGoals False) + , freezePreferOldest = Flag (PreferOldest False) + , freezeShadowPkgs = Flag (ShadowPkgs False) + , freezeStrongFlags = Flag (StrongFlags False) + , freezeAllowBootLibInstalls = Flag (AllowBootLibInstalls False) + , freezeOnlyConstrained = Flag OnlyConstrainedNone + , freezeVerbosity = toFlag normal + } freezeCommand :: CommandUI FreezeFlags -freezeCommand = CommandUI { - commandName = "freeze", - commandSynopsis = "Freeze dependencies.", - commandDescription = Just $ \_ -> wrapText $ - "Calculates a valid set of dependencies and their exact versions. " - ++ "If successful, saves the result to the file `cabal.config`.\n" - ++ "\n" - ++ "The package versions specified in `cabal.config` will be used for " - ++ "any future installs.\n" - ++ "\n" - ++ "An existing `cabal.config` is ignored and overwritten.\n", - commandNotes = Nothing, - commandUsage = usageFlags "freeze", - commandDefaultFlags = defaultFreezeFlags, - commandOptions = \ showOrParseArgs -> [ - optionVerbosity freezeVerbosity - (\v flags -> flags { freezeVerbosity = v }) - - , option [] ["dry-run"] - "Do not freeze anything, only print what would be frozen" - freezeDryRun (\v flags -> flags { freezeDryRun = v }) - trueArg - - , option [] ["tests"] - ("freezing of the dependencies of any tests suites " - ++ "in the package description file.") - freezeTests (\v flags -> flags { freezeTests = v }) - (boolOpt [] []) - - , option [] ["benchmarks"] - ("freezing of the dependencies of any benchmarks suites " - ++ "in the package description file.") - freezeBenchmarks (\v flags -> flags { freezeBenchmarks = v }) - (boolOpt [] []) - - ] ++ - - optionSolver - freezeSolver (\v flags -> flags { freezeSolver = v }): - optionSolverFlags showOrParseArgs - freezeMaxBackjumps (\v flags -> flags { freezeMaxBackjumps = v }) - freezeReorderGoals (\v flags -> flags { freezeReorderGoals = v }) - freezeCountConflicts (\v flags -> flags { freezeCountConflicts = v }) - freezeFineGrainedConflicts (\v flags -> flags { freezeFineGrainedConflicts = v }) - freezeMinimizeConflictSet (\v flags -> flags { freezeMinimizeConflictSet = v }) - freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v }) - freezePreferOldest (\v flags -> flags { freezePreferOldest = v }) - freezeShadowPkgs (\v flags -> flags { freezeShadowPkgs = v }) - freezeStrongFlags (\v flags -> flags { freezeStrongFlags = v }) - freezeAllowBootLibInstalls (\v flags -> flags { freezeAllowBootLibInstalls = v }) - freezeOnlyConstrained (\v flags -> flags { freezeOnlyConstrained = v }) - - } +freezeCommand = + CommandUI + { commandName = "freeze" + , commandSynopsis = "Freeze dependencies." + , commandDescription = Just $ \_ -> + wrapText $ + "Calculates a valid set of dependencies and their exact versions. " + ++ "If successful, saves the result to the file `cabal.config`.\n" + ++ "\n" + ++ "The package versions specified in `cabal.config` will be used for " + ++ "any future installs.\n" + ++ "\n" + ++ "An existing `cabal.config` is ignored and overwritten.\n" + , commandNotes = Nothing + , commandUsage = usageFlags "freeze" + , commandDefaultFlags = defaultFreezeFlags + , commandOptions = \showOrParseArgs -> + [ optionVerbosity + freezeVerbosity + (\v flags -> flags{freezeVerbosity = v}) + , option + [] + ["dry-run"] + "Do not freeze anything, only print what would be frozen" + freezeDryRun + (\v flags -> flags{freezeDryRun = v}) + trueArg + , option + [] + ["tests"] + ( "freezing of the dependencies of any tests suites " + ++ "in the package description file." + ) + freezeTests + (\v flags -> flags{freezeTests = v}) + (boolOpt [] []) + , option + [] + ["benchmarks"] + ( "freezing of the dependencies of any benchmarks suites " + ++ "in the package description file." + ) + freezeBenchmarks + (\v flags -> flags{freezeBenchmarks = v}) + (boolOpt [] []) + ] + ++ optionSolver + freezeSolver + (\v flags -> flags{freezeSolver = v}) + : optionSolverFlags + showOrParseArgs + freezeMaxBackjumps + (\v flags -> flags{freezeMaxBackjumps = v}) + freezeReorderGoals + (\v flags -> flags{freezeReorderGoals = v}) + freezeCountConflicts + (\v flags -> flags{freezeCountConflicts = v}) + freezeFineGrainedConflicts + (\v flags -> flags{freezeFineGrainedConflicts = v}) + freezeMinimizeConflictSet + (\v flags -> flags{freezeMinimizeConflictSet = v}) + freezeIndependentGoals + (\v flags -> flags{freezeIndependentGoals = v}) + freezePreferOldest + (\v flags -> flags{freezePreferOldest = v}) + freezeShadowPkgs + (\v flags -> flags{freezeShadowPkgs = v}) + freezeStrongFlags + (\v flags -> flags{freezeStrongFlags = v}) + freezeAllowBootLibInstalls + (\v flags -> flags{freezeAllowBootLibInstalls = v}) + freezeOnlyConstrained + (\v flags -> flags{freezeOnlyConstrained = v}) + } -- ------------------------------------------------------------ + -- * 'gen-bounds' command + -- ------------------------------------------------------------ genBoundsCommand :: CommandUI FreezeFlags -genBoundsCommand = CommandUI { - commandName = "gen-bounds", - commandSynopsis = "Generate dependency bounds.", - commandDescription = Just $ \_ -> wrapText $ - "Generates bounds for all dependencies that do not currently have them. " - ++ "Generated bounds are printed to stdout. " - ++ "You can then paste them into your .cabal file.\n" - ++ "\n", - commandNotes = Nothing, - commandUsage = usageFlags "gen-bounds", - commandDefaultFlags = defaultFreezeFlags, - commandOptions = \ _ -> [ - optionVerbosity freezeVerbosity (\v flags -> flags { freezeVerbosity = v }) - ] - } +genBoundsCommand = + CommandUI + { commandName = "gen-bounds" + , commandSynopsis = "Generate dependency bounds." + , commandDescription = Just $ \_ -> + wrapText $ + "Generates bounds for all dependencies that do not currently have them. " + ++ "Generated bounds are printed to stdout. " + ++ "You can then paste them into your .cabal file.\n" + ++ "\n" + , commandNotes = Nothing + , commandUsage = usageFlags "gen-bounds" + , commandDefaultFlags = defaultFreezeFlags + , commandOptions = \_ -> + [ optionVerbosity freezeVerbosity (\v flags -> flags{freezeVerbosity = v}) + ] + } -- ------------------------------------------------------------ + -- * Update command + -- ------------------------------------------------------------ -data UpdateFlags - = UpdateFlags { - updateVerbosity :: Flag Verbosity, - updateIndexState :: Flag TotalIndexState - } deriving Generic +data UpdateFlags = UpdateFlags + { updateVerbosity :: Flag Verbosity + , updateIndexState :: Flag TotalIndexState + } + deriving (Generic) defaultUpdateFlags :: UpdateFlags -defaultUpdateFlags - = UpdateFlags { - updateVerbosity = toFlag normal, - updateIndexState = toFlag headTotalIndexState +defaultUpdateFlags = + UpdateFlags + { updateVerbosity = toFlag normal + , updateIndexState = toFlag headTotalIndexState } -- ------------------------------------------------------------ + -- * Other commands + -- ------------------------------------------------------------ cleanCommand :: CommandUI CleanFlags -cleanCommand = Cabal.cleanCommand - { commandUsage = \pname -> - "Usage: " ++ pname ++ " v1-clean [FLAGS]\n" - } +cleanCommand = + Cabal.cleanCommand + { commandUsage = \pname -> + "Usage: " ++ pname ++ " v1-clean [FLAGS]\n" + } -checkCommand :: CommandUI (Flag Verbosity) -checkCommand = CommandUI { - commandName = "check", - commandSynopsis = "Check the package for common mistakes.", - commandDescription = Just $ \_ -> wrapText $ - "Expects a .cabal package file in the current directory.\n" - ++ "\n" - ++ "The checks correspond to the requirements to packages on Hackage. " - ++ "If no errors and warnings are reported, Hackage should accept the " - ++ "package. If errors are present, `check` exits with 1 and Hackage " - ++ "will refuse the package.\n", - commandNotes = Nothing, - commandUsage = usageFlags "check", - commandDefaultFlags = toFlag normal, - commandOptions = \_ -> [optionVerbosity id const] - } +checkCommand :: CommandUI (Flag Verbosity) +checkCommand = + CommandUI + { commandName = "check" + , commandSynopsis = "Check the package for common mistakes." + , commandDescription = Just $ \_ -> + wrapText $ + "Expects a .cabal package file in the current directory.\n" + ++ "\n" + ++ "The checks correspond to the requirements to packages on Hackage. " + ++ "If no errors and warnings are reported, Hackage should accept the " + ++ "package. If errors are present, `check` exits with 1 and Hackage " + ++ "will refuse the package.\n" + , commandNotes = Nothing + , commandUsage = usageFlags "check" + , commandDefaultFlags = toFlag normal + , commandOptions = \_ -> [optionVerbosity id const] + } -formatCommand :: CommandUI (Flag Verbosity) -formatCommand = CommandUI { - commandName = "format", - commandSynopsis = "Reformat the .cabal file using the standard style.", - commandDescription = Nothing, - commandNotes = Nothing, - commandUsage = usageAlternatives "format" ["[FILE]"], - commandDefaultFlags = toFlag normal, - commandOptions = \_ -> [] - } +formatCommand :: CommandUI (Flag Verbosity) +formatCommand = + CommandUI + { commandName = "format" + , commandSynopsis = "Reformat the .cabal file using the standard style." + , commandDescription = Nothing + , commandNotes = Nothing + , commandUsage = usageAlternatives "format" ["[FILE]"] + , commandDefaultFlags = toFlag normal + , commandOptions = \_ -> [] + } manpageCommand :: CommandUI ManpageFlags -manpageCommand = CommandUI { - commandName = "man", - commandSynopsis = "Outputs manpage source.", - commandDescription = Just $ \_ -> - "Output manpage source to STDOUT.\n", - commandNotes = Nothing, - commandUsage = usageFlags "man", - commandDefaultFlags = defaultManpageFlags, - commandOptions = manpageOptions - } +manpageCommand = + CommandUI + { commandName = "man" + , commandSynopsis = "Outputs manpage source." + , commandDescription = Just $ \_ -> + "Output manpage source to STDOUT.\n" + , commandNotes = Nothing + , commandUsage = usageFlags "man" + , commandDefaultFlags = defaultManpageFlags + , commandOptions = manpageOptions + } runCommand :: CommandUI BuildFlags -runCommand = CommandUI { - commandName = "run", - commandSynopsis = "Builds and runs an executable.", - commandDescription = Just $ \pname -> wrapText $ - "Builds and then runs the specified executable. If no executable is " - ++ "specified, but the package contains just one executable, that one " - ++ "is built and executed.\n" - ++ "\n" - ++ "Use `" ++ pname ++ " v1-test --show-details=streaming` to run a " - ++ "test-suite and get its full output.\n", - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v1-run\n" - ++ " Run the only executable in the current package;\n" - ++ " " ++ pname ++ " v1-run foo -- --fooflag\n" - ++ " Works similar to `./foo --fooflag`.\n", - commandUsage = usageAlternatives "v1-run" - ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"], - commandDefaultFlags = mempty, - commandOptions = commandOptions parent - } +runCommand = + CommandUI + { commandName = "run" + , commandSynopsis = "Builds and runs an executable." + , commandDescription = Just $ \pname -> + wrapText $ + "Builds and then runs the specified executable. If no executable is " + ++ "specified, but the package contains just one executable, that one " + ++ "is built and executed.\n" + ++ "\n" + ++ "Use `" + ++ pname + ++ " v1-test --show-details=streaming` to run a " + ++ "test-suite and get its full output.\n" + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " + ++ pname + ++ " v1-run\n" + ++ " Run the only executable in the current package;\n" + ++ " " + ++ pname + ++ " v1-run foo -- --fooflag\n" + ++ " Works similar to `./foo --fooflag`.\n" + , commandUsage = + usageAlternatives + "v1-run" + ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"] + , commandDefaultFlags = mempty + , commandOptions = commandOptions parent + } where parent = Cabal.buildCommand defaultProgramDb -- ------------------------------------------------------------ + -- * Report flags + -- ------------------------------------------------------------ -data ReportFlags = ReportFlags { - reportUsername :: Flag Username, - reportPassword :: Flag Password, - reportVerbosity :: Flag Verbosity - } deriving Generic +data ReportFlags = ReportFlags + { reportUsername :: Flag Username + , reportPassword :: Flag Password + , reportVerbosity :: Flag Verbosity + } + deriving (Generic) defaultReportFlags :: ReportFlags -defaultReportFlags = ReportFlags { - reportUsername = mempty, - reportPassword = mempty, - reportVerbosity = toFlag normal - } +defaultReportFlags = + ReportFlags + { reportUsername = mempty + , reportPassword = mempty + , reportVerbosity = toFlag normal + } reportCommand :: CommandUI ReportFlags -reportCommand = CommandUI { - commandName = "report", - commandSynopsis = "Upload build reports to a remote server.", - commandDescription = Nothing, - commandNotes = Just $ \_ -> - "You can store your Hackage login in the ~/.config/cabal/config file\n", - commandUsage = usageAlternatives "report" ["[FLAGS]"], - commandDefaultFlags = defaultReportFlags, - commandOptions = \_ -> - [optionVerbosity reportVerbosity (\v flags -> flags { reportVerbosity = v }) - - ,option ['u'] ["username"] - "Hackage username." - reportUsername (\v flags -> flags { reportUsername = v }) - (reqArg' "USERNAME" (toFlag . Username) - (flagToList . fmap unUsername)) - - ,option ['p'] ["password"] - "Hackage password." - reportPassword (\v flags -> flags { reportPassword = v }) - (reqArg' "PASSWORD" (toFlag . Password) - (flagToList . fmap unPassword)) - ] - } +reportCommand = + CommandUI + { commandName = "report" + , commandSynopsis = "Upload build reports to a remote server." + , commandDescription = Nothing + , commandNotes = Just $ \_ -> + "You can store your Hackage login in the ~/.config/cabal/config file\n" + , commandUsage = usageAlternatives "report" ["[FLAGS]"] + , commandDefaultFlags = defaultReportFlags + , commandOptions = \_ -> + [ optionVerbosity reportVerbosity (\v flags -> flags{reportVerbosity = v}) + , option + ['u'] + ["username"] + "Hackage username." + reportUsername + (\v flags -> flags{reportUsername = v}) + ( reqArg' + "USERNAME" + (toFlag . Username) + (flagToList . fmap unUsername) + ) + , option + ['p'] + ["password"] + "Hackage password." + reportPassword + (\v flags -> flags{reportPassword = v}) + ( reqArg' + "PASSWORD" + (toFlag . Password) + (flagToList . fmap unPassword) + ) + ] + } instance Monoid ReportFlags where mempty = gmempty @@ -1309,85 +1693,116 @@ instance Semigroup ReportFlags where (<>) = gmappend -- ------------------------------------------------------------ + -- * Get flags + -- ------------------------------------------------------------ -data GetFlags = GetFlags { - getDestDir :: Flag FilePath, - getOnlyPkgDescr :: Flag Bool, - getPristine :: Flag Bool, - getIndexState :: Flag TotalIndexState, - getActiveRepos :: Flag ActiveRepos, - getSourceRepository :: Flag (Maybe RepoKind), - getVerbosity :: Flag Verbosity - } deriving Generic +data GetFlags = GetFlags + { getDestDir :: Flag FilePath + , getOnlyPkgDescr :: Flag Bool + , getPristine :: Flag Bool + , getIndexState :: Flag TotalIndexState + , getActiveRepos :: Flag ActiveRepos + , getSourceRepository :: Flag (Maybe RepoKind) + , getVerbosity :: Flag Verbosity + } + deriving (Generic) defaultGetFlags :: GetFlags -defaultGetFlags = GetFlags { - getDestDir = mempty, - getOnlyPkgDescr = mempty, - getPristine = mempty, - getIndexState = mempty, - getActiveRepos = mempty, - getSourceRepository = mempty, - getVerbosity = toFlag normal - } +defaultGetFlags = + GetFlags + { getDestDir = mempty + , getOnlyPkgDescr = mempty + , getPristine = mempty + , getIndexState = mempty + , getActiveRepos = mempty + , getSourceRepository = mempty + , getVerbosity = toFlag normal + } getCommand :: CommandUI GetFlags -getCommand = CommandUI { - commandName = "get", - commandSynopsis = "Download/Extract a package's source code (repository).", - commandDescription = Just $ \_ -> wrapText $ unlines descriptionOfGetCommand, - commandNotes = Just $ \pname -> unlines $ notesOfGetCommand "get" pname, - commandUsage = usagePackages "get", - commandDefaultFlags = defaultGetFlags, - commandOptions = \_ -> [ - optionVerbosity getVerbosity (\v flags -> flags { getVerbosity = v }) - - ,option "d" ["destdir"] - "Where to place the package source, defaults to the current directory." - getDestDir (\v flags -> flags { getDestDir = v }) - (reqArgFlag "PATH") - - ,option "s" ["source-repository"] - "Copy the package's source repository (ie git clone, darcs get, etc as appropriate)." - getSourceRepository (\v flags -> flags { getSourceRepository = v }) - (optArg "[head|this|...]" (parsecToReadE (const "invalid source-repository") - (fmap (toFlag . Just) parsec)) - (Flag Nothing) - (map (fmap show) . flagToList)) - - , option [] ["index-state"] - ("Use source package index state as it existed at a previous time. " ++ - "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++ - "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD'). " ++ - "This determines which package versions are available as well as " ++ - ".cabal file revision is selected (unless --pristine is used).") - getIndexState (\v flags -> flags { getIndexState = v }) - (reqArg "STATE" (parsecToReadE (const $ "index-state must be a " ++ - "unix-timestamps (e.g. '@1474732068'), " ++ - "a ISO8601 UTC timestamp " ++ - "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'") - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - - , option [] ["only-package-description"] - "Unpack only the package description file." - getOnlyPkgDescr (\v flags -> flags { getOnlyPkgDescr = v }) - trueArg - - , option [] ["package-description-only"] - "A synonym for --only-package-description." - getOnlyPkgDescr (\v flags -> flags { getOnlyPkgDescr = v }) - trueArg - - , option [] ["pristine"] - ("Unpack the original pristine tarball, rather than updating the " - ++ ".cabal file with the latest revision from the package archive.") - getPristine (\v flags -> flags { getPristine = v }) - trueArg - ] - } +getCommand = + CommandUI + { commandName = "get" + , commandSynopsis = "Download/Extract a package's source code (repository)." + , commandDescription = Just $ \_ -> wrapText $ unlines descriptionOfGetCommand + , commandNotes = Just $ \pname -> unlines $ notesOfGetCommand "get" pname + , commandUsage = usagePackages "get" + , commandDefaultFlags = defaultGetFlags + , commandOptions = \_ -> + [ optionVerbosity getVerbosity (\v flags -> flags{getVerbosity = v}) + , option + "d" + ["destdir"] + "Where to place the package source, defaults to the current directory." + getDestDir + (\v flags -> flags{getDestDir = v}) + (reqArgFlag "PATH") + , option + "s" + ["source-repository"] + "Copy the package's source repository (ie git clone, darcs get, etc as appropriate)." + getSourceRepository + (\v flags -> flags{getSourceRepository = v}) + ( optArg + "[head|this|...]" + ( parsecToReadE + (const "invalid source-repository") + (fmap (toFlag . Just) parsec) + ) + (Flag Nothing) + (map (fmap show) . flagToList) + ) + , option + [] + ["index-state"] + ( "Use source package index state as it existed at a previous time. " + ++ "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " + ++ "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD'). " + ++ "This determines which package versions are available as well as " + ++ ".cabal file revision is selected (unless --pristine is used)." + ) + getIndexState + (\v flags -> flags{getIndexState = v}) + ( reqArg + "STATE" + ( parsecToReadE + ( const $ + "index-state must be a " + ++ "unix-timestamps (e.g. '@1474732068'), " + ++ "a ISO8601 UTC timestamp " + ++ "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'" + ) + (toFlag `fmap` parsec) + ) + (flagToList . fmap prettyShow) + ) + , option + [] + ["only-package-description"] + "Unpack only the package description file." + getOnlyPkgDescr + (\v flags -> flags{getOnlyPkgDescr = v}) + trueArg + , option + [] + ["package-description-only"] + "A synonym for --only-package-description." + getOnlyPkgDescr + (\v flags -> flags{getOnlyPkgDescr = v}) + trueArg + , option + [] + ["pristine"] + ( "Unpack the original pristine tarball, rather than updating the " + ++ ".cabal file with the latest revision from the package archive." + ) + getPristine + (\v flags -> flags{getPristine = v}) + trueArg + ] + } -- | List of lines describing command @get@. descriptionOfGetCommand :: [String] @@ -1399,28 +1814,33 @@ descriptionOfGetCommand = -- | Notes for the command @get@. notesOfGetCommand - :: String -- ^ Either @"get"@ or @"unpack"@. - -> String -- ^ E.g. @"cabal"@. - -> [String] -- ^ List of lines. + :: String + -- ^ Either @"get"@ or @"unpack"@. + -> String + -- ^ E.g. @"cabal"@. + -> [String] + -- ^ List of lines. notesOfGetCommand cmd pname = [ "Examples:" - , " " ++ unwords [ pname, cmd, "hlint" ] + , " " ++ unwords [pname, cmd, "hlint"] , " Download the latest stable version of hlint;" - , " " ++ unwords [ pname, cmd, "lens --source-repository=head" ] + , " " ++ unwords [pname, cmd, "lens --source-repository=head"] , " Download the source repository of lens (i.e. git clone from github)." ] -- 'cabal unpack' is a deprecated alias for 'cabal get'. unpackCommand :: CommandUI GetFlags -unpackCommand = getCommand - { commandName = "unpack" - , commandSynopsis = synopsis - , commandNotes = Just $ \ pname -> unlines $ - notesOfGetCommand "unpack" pname - , commandUsage = usagePackages "unpack" - } +unpackCommand = + getCommand + { commandName = "unpack" + , commandSynopsis = synopsis + , commandNotes = Just $ \pname -> + unlines $ + notesOfGetCommand "unpack" pname + , commandUsage = usagePackages "unpack" + } where - synopsis = "Deprecated alias for 'get'." + synopsis = "Deprecated alias for 'get'." instance Monoid GetFlags where mempty = gmempty @@ -1430,86 +1850,109 @@ instance Semigroup GetFlags where (<>) = gmappend -- ------------------------------------------------------------ + -- * List flags + -- ------------------------------------------------------------ data ListFlags = ListFlags - { listInstalled :: Flag Bool - , listSimpleOutput :: Flag Bool - , listCaseInsensitive :: Flag Bool - , listVerbosity :: Flag Verbosity - , listPackageDBs :: [Maybe PackageDB] - , listHcPath :: Flag FilePath - } - deriving Generic + { listInstalled :: Flag Bool + , listSimpleOutput :: Flag Bool + , listCaseInsensitive :: Flag Bool + , listVerbosity :: Flag Verbosity + , listPackageDBs :: [Maybe PackageDB] + , listHcPath :: Flag FilePath + } + deriving (Generic) defaultListFlags :: ListFlags -defaultListFlags = ListFlags - { listInstalled = Flag False - , listSimpleOutput = Flag False +defaultListFlags = + ListFlags + { listInstalled = Flag False + , listSimpleOutput = Flag False , listCaseInsensitive = Flag True - , listVerbosity = toFlag normal - , listPackageDBs = [] - , listHcPath = mempty + , listVerbosity = toFlag normal + , listPackageDBs = [] + , listHcPath = mempty } -listCommand :: CommandUI ListFlags -listCommand = CommandUI { - commandName = "list", - commandSynopsis = "List packages matching a search string.", - commandDescription = Just $ \_ -> wrapText $ - "List all packages, or all packages matching one of the search" - ++ " strings.\n" - ++ "\n" - ++ "Use the package database specified with --package-db. " - ++ "If not specified, use the user package database.\n", - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " list pandoc\n" - ++ " Will find pandoc, pandoc-citeproc, pandoc-lens, ...\n", - commandUsage = usageAlternatives "list" [ "[FLAGS]" - , "[FLAGS] STRINGS"], - commandDefaultFlags = defaultListFlags, - commandOptions = const listOptions - } +listCommand :: CommandUI ListFlags +listCommand = + CommandUI + { commandName = "list" + , commandSynopsis = "List packages matching a search string." + , commandDescription = Just $ \_ -> + wrapText $ + "List all packages, or all packages matching one of the search" + ++ " strings.\n" + ++ "\n" + ++ "Use the package database specified with --package-db. " + ++ "If not specified, use the user package database.\n" + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " + ++ pname + ++ " list pandoc\n" + ++ " Will find pandoc, pandoc-citeproc, pandoc-lens, ...\n" + , commandUsage = + usageAlternatives + "list" + [ "[FLAGS]" + , "[FLAGS] STRINGS" + ] + , commandDefaultFlags = defaultListFlags + , commandOptions = const listOptions + } listOptions :: [OptionField ListFlags] listOptions = - [ optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v }) - - , option [] ["installed"] - "Only print installed packages" - listInstalled (\v flags -> flags { listInstalled = v }) - trueArg - - , option [] ["simple-output"] - "Print in a easy-to-parse format" - listSimpleOutput (\v flags -> flags { listSimpleOutput = v }) - trueArg - , option ['i'] ["ignore-case"] - "Ignore case distinctions" - listCaseInsensitive (\v flags -> flags { listCaseInsensitive = v }) - (boolOpt' (['i'], ["ignore-case"]) (['I'], ["strict-case"])) - - , option "" ["package-db"] - ( "Append the given package database to the list of package" - ++ " databases used (to satisfy dependencies and register into)." - ++ " May be a specific file, 'global' or 'user'. The initial list" - ++ " is ['global'], ['global', 'user']," - ++ " depending on context. Use 'clear' to reset the list to empty." - ++ " See the user guide for details.") - listPackageDBs (\v flags -> flags { listPackageDBs = v }) + [ optionVerbosity listVerbosity (\v flags -> flags{listVerbosity = v}) + , option + [] + ["installed"] + "Only print installed packages" + listInstalled + (\v flags -> flags{listInstalled = v}) + trueArg + , option + [] + ["simple-output"] + "Print in a easy-to-parse format" + listSimpleOutput + (\v flags -> flags{listSimpleOutput = v}) + trueArg + , option + ['i'] + ["ignore-case"] + "Ignore case distinctions" + listCaseInsensitive + (\v flags -> flags{listCaseInsensitive = v}) + (boolOpt' (['i'], ["ignore-case"]) (['I'], ["strict-case"])) + , option + "" + ["package-db"] + ( "Append the given package database to the list of package" + ++ " databases used (to satisfy dependencies and register into)." + ++ " May be a specific file, 'global' or 'user'. The initial list" + ++ " is ['global'], ['global', 'user']," + ++ " depending on context. Use 'clear' to reset the list to empty." + ++ " See the user guide for details." + ) + listPackageDBs + (\v flags -> flags{listPackageDBs = v}) (reqArg' "DB" readPackageDbList showPackageDbList) - - , option "w" ["with-compiler"] + , option + "w" + ["with-compiler"] "give the path to a particular compiler" - listHcPath (\v flags -> flags { listHcPath = v }) + listHcPath + (\v flags -> flags{listHcPath = v}) (reqArgFlag "PATH") - ] + ] listNeedsCompiler :: ListFlags -> Bool listNeedsCompiler f = - flagElim False (const True) (listHcPath f) + flagElim False (const True) (listHcPath f) || fromFlagOrDefault False (listInstalled f) instance Monoid ListFlags where @@ -1520,45 +1963,53 @@ instance Semigroup ListFlags where (<>) = gmappend -- ------------------------------------------------------------ + -- * Info flags --- ------------------------------------------------------------ -data InfoFlags = InfoFlags { - infoVerbosity :: Flag Verbosity, - infoPackageDBs :: [Maybe PackageDB] - } deriving Generic +-- ------------------------------------------------------------ -defaultInfoFlags :: InfoFlags -defaultInfoFlags = InfoFlags { - infoVerbosity = toFlag normal, - infoPackageDBs = [] +data InfoFlags = InfoFlags + { infoVerbosity :: Flag Verbosity + , infoPackageDBs :: [Maybe PackageDB] } + deriving (Generic) -infoCommand :: CommandUI InfoFlags -infoCommand = CommandUI { - commandName = "info", - commandSynopsis = "Display detailed information about a particular package.", - commandDescription = Just $ \_ -> wrapText $ - "Use the package database specified with --package-db. " - ++ "If not specified, use the user package database.\n", - commandNotes = Nothing, - commandUsage = usageAlternatives "info" ["[FLAGS] PACKAGES"], - commandDefaultFlags = defaultInfoFlags, - commandOptions = \_ -> [ - optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v }) - - , option "" ["package-db"] - ( "Append the given package database to the list of package" - ++ " databases used (to satisfy dependencies and register into)." - ++ " May be a specific file, 'global' or 'user'. The initial list" - ++ " is ['global'], ['global', 'user']," - ++ " depending on context. Use 'clear' to reset the list to empty." - ++ " See the user guide for details.") - infoPackageDBs (\v flags -> flags { infoPackageDBs = v }) - (reqArg' "DB" readPackageDbList showPackageDbList) +defaultInfoFlags :: InfoFlags +defaultInfoFlags = + InfoFlags + { infoVerbosity = toFlag normal + , infoPackageDBs = [] + } +infoCommand :: CommandUI InfoFlags +infoCommand = + CommandUI + { commandName = "info" + , commandSynopsis = "Display detailed information about a particular package." + , commandDescription = Just $ \_ -> + wrapText $ + "Use the package database specified with --package-db. " + ++ "If not specified, use the user package database.\n" + , commandNotes = Nothing + , commandUsage = usageAlternatives "info" ["[FLAGS] PACKAGES"] + , commandDefaultFlags = defaultInfoFlags + , commandOptions = \_ -> + [ optionVerbosity infoVerbosity (\v flags -> flags{infoVerbosity = v}) + , option + "" + ["package-db"] + ( "Append the given package database to the list of package" + ++ " databases used (to satisfy dependencies and register into)." + ++ " May be a specific file, 'global' or 'user'. The initial list" + ++ " is ['global'], ['global', 'user']," + ++ " depending on context. Use 'clear' to reset the list to empty." + ++ " See the user guide for details." + ) + infoPackageDBs + (\v flags -> flags{infoPackageDBs = v}) + (reqArg' "DB" readPackageDbList showPackageDbList) ] - } + } instance Monoid InfoFlags where mempty = gmempty @@ -1568,93 +2019,100 @@ instance Semigroup InfoFlags where (<>) = gmappend -- ------------------------------------------------------------ + -- * Install flags + -- ------------------------------------------------------------ -- | Install takes the same flags as configure along with a few extras. --- -data InstallFlags = InstallFlags { - installDocumentation :: Flag Bool, - installHaddockIndex :: Flag PathTemplate, - installDest :: Flag Cabal.CopyDest, - installDryRun :: Flag Bool, - installOnlyDownload :: Flag Bool, - installMaxBackjumps :: Flag Int, - installReorderGoals :: Flag ReorderGoals, - installCountConflicts :: Flag CountConflicts, - installFineGrainedConflicts :: Flag FineGrainedConflicts, - installMinimizeConflictSet :: Flag MinimizeConflictSet, - installIndependentGoals :: Flag IndependentGoals, - installPreferOldest :: Flag PreferOldest, - installShadowPkgs :: Flag ShadowPkgs, - installStrongFlags :: Flag StrongFlags, - installAllowBootLibInstalls :: Flag AllowBootLibInstalls, - installOnlyConstrained :: Flag OnlyConstrained, - installReinstall :: Flag Bool, - installAvoidReinstalls :: Flag AvoidReinstalls, - installOverrideReinstall :: Flag Bool, - installUpgradeDeps :: Flag Bool, - installOnly :: Flag Bool, - installOnlyDeps :: Flag Bool, - installIndexState :: Flag TotalIndexState, - installRootCmd :: Flag String, - installSummaryFile :: NubList PathTemplate, - installLogFile :: Flag PathTemplate, - installBuildReports :: Flag ReportLevel, - installReportPlanningFailure :: Flag Bool, - -- Note: symlink-bindir is no longer used by v2-install and can be removed +data InstallFlags = InstallFlags + { installDocumentation :: Flag Bool + , installHaddockIndex :: Flag PathTemplate + , installDest :: Flag Cabal.CopyDest + , installDryRun :: Flag Bool + , installOnlyDownload :: Flag Bool + , installMaxBackjumps :: Flag Int + , installReorderGoals :: Flag ReorderGoals + , installCountConflicts :: Flag CountConflicts + , installFineGrainedConflicts :: Flag FineGrainedConflicts + , installMinimizeConflictSet :: Flag MinimizeConflictSet + , installIndependentGoals :: Flag IndependentGoals + , installPreferOldest :: Flag PreferOldest + , installShadowPkgs :: Flag ShadowPkgs + , installStrongFlags :: Flag StrongFlags + , installAllowBootLibInstalls :: Flag AllowBootLibInstalls + , installOnlyConstrained :: Flag OnlyConstrained + , installReinstall :: Flag Bool + , installAvoidReinstalls :: Flag AvoidReinstalls + , installOverrideReinstall :: Flag Bool + , installUpgradeDeps :: Flag Bool + , installOnly :: Flag Bool + , installOnlyDeps :: Flag Bool + , installIndexState :: Flag TotalIndexState + , installRootCmd :: Flag String + , installSummaryFile :: NubList PathTemplate + , installLogFile :: Flag PathTemplate + , installBuildReports :: Flag ReportLevel + , installReportPlanningFailure :: Flag Bool + , -- Note: symlink-bindir is no longer used by v2-install and can be removed -- when removing v1 commands - installSymlinkBinDir :: Flag FilePath, - installPerComponent :: Flag Bool, - installNumJobs :: Flag (Maybe Int), - installKeepGoing :: Flag Bool, - installRunTests :: Flag Bool, - installOfflineMode :: Flag Bool + installSymlinkBinDir :: Flag FilePath + , installPerComponent :: Flag Bool + , installNumJobs :: Flag (Maybe Int) + , installKeepGoing :: Flag Bool + , installRunTests :: Flag Bool + , installOfflineMode :: Flag Bool } deriving (Eq, Show, Generic) instance Binary InstallFlags defaultInstallFlags :: InstallFlags -defaultInstallFlags = InstallFlags { - installDocumentation = Flag False, - installHaddockIndex = Flag docIndexFile, - installDest = Flag Cabal.NoCopyDest, - installDryRun = Flag False, - installOnlyDownload = Flag False, - installMaxBackjumps = Flag defaultMaxBackjumps, - installReorderGoals = Flag (ReorderGoals False), - installCountConflicts = Flag (CountConflicts True), - installFineGrainedConflicts = Flag (FineGrainedConflicts True), - installMinimizeConflictSet = Flag (MinimizeConflictSet False), - installIndependentGoals= Flag (IndependentGoals False), - installPreferOldest = Flag (PreferOldest False), - installShadowPkgs = Flag (ShadowPkgs False), - installStrongFlags = Flag (StrongFlags False), - installAllowBootLibInstalls = Flag (AllowBootLibInstalls False), - installOnlyConstrained = Flag OnlyConstrainedNone, - installReinstall = Flag False, - installAvoidReinstalls = Flag (AvoidReinstalls False), - installOverrideReinstall = Flag False, - installUpgradeDeps = Flag False, - installOnly = Flag False, - installOnlyDeps = Flag False, - installIndexState = mempty, - installRootCmd = mempty, - installSummaryFile = mempty, - installLogFile = mempty, - installBuildReports = Flag NoReports, - installReportPlanningFailure = Flag False, - installSymlinkBinDir = mempty, - installPerComponent = Flag True, - installNumJobs = mempty, - installKeepGoing = Flag False, - installRunTests = mempty, - installOfflineMode = Flag False - } +defaultInstallFlags = + InstallFlags + { installDocumentation = Flag False + , installHaddockIndex = Flag docIndexFile + , installDest = Flag Cabal.NoCopyDest + , installDryRun = Flag False + , installOnlyDownload = Flag False + , installMaxBackjumps = Flag defaultMaxBackjumps + , installReorderGoals = Flag (ReorderGoals False) + , installCountConflicts = Flag (CountConflicts True) + , installFineGrainedConflicts = Flag (FineGrainedConflicts True) + , installMinimizeConflictSet = Flag (MinimizeConflictSet False) + , installIndependentGoals = Flag (IndependentGoals False) + , installPreferOldest = Flag (PreferOldest False) + , installShadowPkgs = Flag (ShadowPkgs False) + , installStrongFlags = Flag (StrongFlags False) + , installAllowBootLibInstalls = Flag (AllowBootLibInstalls False) + , installOnlyConstrained = Flag OnlyConstrainedNone + , installReinstall = Flag False + , installAvoidReinstalls = Flag (AvoidReinstalls False) + , installOverrideReinstall = Flag False + , installUpgradeDeps = Flag False + , installOnly = Flag False + , installOnlyDeps = Flag False + , installIndexState = mempty + , installRootCmd = mempty + , installSummaryFile = mempty + , installLogFile = mempty + , installBuildReports = Flag NoReports + , installReportPlanningFailure = Flag False + , installSymlinkBinDir = mempty + , installPerComponent = Flag True + , installNumJobs = mempty + , installKeepGoing = Flag False + , installRunTests = mempty + , installOfflineMode = Flag False + } where - docIndexFile = toPathTemplate ("$datadir" "doc" - "$arch-$os-$compiler" "index.html") + docIndexFile = + toPathTemplate + ( "$datadir" + "doc" + "$arch-$os-$compiler" + "index.html" + ) defaultMaxBackjumps :: Int defaultMaxBackjumps = 4000 @@ -1665,91 +2123,135 @@ defaultSolver = AlwaysModular allSolvers :: String allSolvers = intercalate ", " (map prettyShow ([minBound .. maxBound] :: [PreSolver])) -installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags - , HaddockFlags, TestFlags, BenchmarkFlags - ) -installCommand = CommandUI { - commandName = "install", - commandSynopsis = "Install packages.", - commandUsage = usageAlternatives "v1-install" [ "[FLAGS]" - , "[FLAGS] PACKAGES" - ], - commandDescription = Just $ \_ -> wrapText $ - "Installs one or more packages. By default, the installed package" - ++ " will be registered in the user's package database." - ++ "\n" - ++ "If PACKAGES are specified, downloads and installs those packages." - ++ " Otherwise, install the package in the current directory (and/or its" - ++ " dependencies) (there must be exactly one .cabal file in the current" - ++ " directory).\n" - ++ "\n" - ++ "The flags to `v1-install` are saved and" - ++ " affect future commands such as `v1-build` and `v1-repl`. See the help for" - ++ " `v1-configure` for a list of commands being affected.\n" - ++ "\n" - ++ "Installed executables will by default" - ++ " be put into `~/.local/bin/`." - ++ " If you want installed executable to be available globally, make" - ++ " sure that the PATH environment variable contains that directory.\n" - ++ "\n", - commandNotes = Just $ \pname -> - ( case commandNotes - $ Cabal.configureCommand defaultProgramDb - of Just desc -> desc pname ++ "\n" - Nothing -> "" +installCommand + :: CommandUI + ( ConfigFlags + , ConfigExFlags + , InstallFlags + , HaddockFlags + , TestFlags + , BenchmarkFlags + ) +installCommand = + CommandUI + { commandName = "install" + , commandSynopsis = "Install packages." + , commandUsage = + usageAlternatives + "v1-install" + [ "[FLAGS]" + , "[FLAGS] PACKAGES" + ] + , commandDescription = Just $ \_ -> + wrapText $ + "Installs one or more packages. By default, the installed package" + ++ " will be registered in the user's package database." + ++ "\n" + ++ "If PACKAGES are specified, downloads and installs those packages." + ++ " Otherwise, install the package in the current directory (and/or its" + ++ " dependencies) (there must be exactly one .cabal file in the current" + ++ " directory).\n" + ++ "\n" + ++ "The flags to `v1-install` are saved and" + ++ " affect future commands such as `v1-build` and `v1-repl`. See the help for" + ++ " `v1-configure` for a list of commands being affected.\n" + ++ "\n" + ++ "Installed executables will by default" + ++ " be put into `~/.local/bin/`." + ++ " If you want installed executable to be available globally, make" + ++ " sure that the PATH environment variable contains that directory.\n" + ++ "\n" + , commandNotes = Just $ \pname -> + ( case commandNotes $ + Cabal.configureCommand defaultProgramDb of + Just desc -> desc pname ++ "\n" + Nothing -> "" ) - ++ "Examples:\n" - ++ " " ++ pname ++ " v1-install " - ++ " Package in the current directory\n" - ++ " " ++ pname ++ " v1-install foo " - ++ " Package from the hackage server\n" - ++ " " ++ pname ++ " v1-install foo-1.0 " - ++ " Specific version of a package\n" - ++ " " ++ pname ++ " v1-install 'foo < 2' " - ++ " Constrained package version\n" - ++ " " ++ pname ++ " v1-install haddock --bindir=$HOME/hask-bin/ --datadir=$HOME/hask-data/\n" - ++ " " ++ (map (const ' ') pname) - ++ " " - ++ " Change installation destination\n", - commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, mempty), - commandOptions = \showOrParseArgs -> - liftOptions get1 set1 - -- Note: [Hidden Flags] - -- hide "constraint", "dependency", and - -- "exact-configuration" from the configure options. - (filter ((`notElem` ["constraint", "dependency" - , "exact-configuration"]) - . optionName) $ - configureOptions showOrParseArgs) - ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag) - ++ liftOptions get3 set3 - -- hide "target-package-db" flag from the - -- install options. - (filter ((`notElem` ["target-package-db"]) - . optionName) $ - installOptions showOrParseArgs) - ++ liftOptions get4 set4 (haddockOptions showOrParseArgs) - ++ liftOptions get5 set5 (testOptions showOrParseArgs) - ++ liftOptions get6 set6 (benchmarkOptions showOrParseArgs) - } + ++ "Examples:\n" + ++ " " + ++ pname + ++ " v1-install " + ++ " Package in the current directory\n" + ++ " " + ++ pname + ++ " v1-install foo " + ++ " Package from the hackage server\n" + ++ " " + ++ pname + ++ " v1-install foo-1.0 " + ++ " Specific version of a package\n" + ++ " " + ++ pname + ++ " v1-install 'foo < 2' " + ++ " Constrained package version\n" + ++ " " + ++ pname + ++ " v1-install haddock --bindir=$HOME/hask-bin/ --datadir=$HOME/hask-data/\n" + ++ " " + ++ (map (const ' ') pname) + ++ " " + ++ " Change installation destination\n" + , commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, mempty) + , commandOptions = \showOrParseArgs -> + liftOptions + get1 + set1 + -- Note: [Hidden Flags] + -- hide "constraint", "dependency", and + -- "exact-configuration" from the configure options. + ( filter + ( ( `notElem` + [ "constraint" + , "dependency" + , "exact-configuration" + ] + ) + . optionName + ) + $ configureOptions showOrParseArgs + ) + ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag) + ++ liftOptions + get3 + set3 + -- hide "target-package-db" flag from the + -- install options. + ( filter + ( (`notElem` ["target-package-db"]) + . optionName + ) + $ installOptions showOrParseArgs + ) + ++ liftOptions get4 set4 (haddockOptions showOrParseArgs) + ++ liftOptions get5 set5 (testOptions showOrParseArgs) + ++ liftOptions get6 set6 (benchmarkOptions showOrParseArgs) + } where - get1 (a,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f) = (a,b,c,d,e,f) - get2 (_,b,_,_,_,_) = b; set2 b (a,_,c,d,e,f) = (a,b,c,d,e,f) - get3 (_,_,c,_,_,_) = c; set3 c (a,b,_,d,e,f) = (a,b,c,d,e,f) - get4 (_,_,_,d,_,_) = d; set4 d (a,b,c,_,e,f) = (a,b,c,d,e,f) - get5 (_,_,_,_,e,_) = e; set5 e (a,b,c,d,_,f) = (a,b,c,d,e,f) - get6 (_,_,_,_,_,f) = f; set6 f (a,b,c,d,e,_) = (a,b,c,d,e,f) + get1 (a, _, _, _, _, _) = a + set1 a (_, b, c, d, e, f) = (a, b, c, d, e, f) + get2 (_, b, _, _, _, _) = b + set2 b (a, _, c, d, e, f) = (a, b, c, d, e, f) + get3 (_, _, c, _, _, _) = c + set3 c (a, b, _, d, e, f) = (a, b, c, d, e, f) + get4 (_, _, _, d, _, _) = d + set4 d (a, b, c, _, e, f) = (a, b, c, d, e, f) + get5 (_, _, _, _, e, _) = e + set5 e (a, b, c, d, _, f) = (a, b, c, d, e, f) + get6 (_, _, _, _, _, f) = f + set6 f (a, b, c, d, e, _) = (a, b, c, d, e, f) haddockCommand :: CommandUI HaddockFlags -haddockCommand = Cabal.haddockCommand - { commandUsage = usageAlternatives "v1-haddock" $ - [ "[FLAGS]", "COMPONENTS [FLAGS]" ] - } +haddockCommand = + Cabal.haddockCommand + { commandUsage = + usageAlternatives "v1-haddock" $ + ["[FLAGS]", "COMPONENTS [FLAGS]"] + } filterHaddockArgs :: [String] -> Version -> [String] filterHaddockArgs args cabalLibVersion - | cabalLibVersion >= mkVersion [2,3,0] = args_latest - | cabalLibVersion < mkVersion [2,3,0] = args_2_3_0 + | cabalLibVersion >= mkVersion [2, 3, 0] = args_latest + | cabalLibVersion < mkVersion [2, 3, 0] = args_2_3_0 | otherwise = args_latest where args_latest = args @@ -1759,216 +2261,336 @@ filterHaddockArgs args cabalLibVersion filterHaddockFlags :: HaddockFlags -> Version -> HaddockFlags filterHaddockFlags flags cabalLibVersion - | cabalLibVersion >= mkVersion [2,3,0] = flags_latest - | cabalLibVersion < mkVersion [2,3,0] = flags_2_3_0 + | cabalLibVersion >= mkVersion [2, 3, 0] = flags_latest + | cabalLibVersion < mkVersion [2, 3, 0] = flags_2_3_0 | otherwise = flags_latest where flags_latest = flags - flags_2_3_0 = flags_latest { - -- Cabal < 2.3 doesn't know about per-component haddock - haddockArgs = [] - } + flags_2_3_0 = + flags_latest + { -- Cabal < 2.3 doesn't know about per-component haddock + haddockArgs = [] + } haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags] -haddockOptions showOrParseArgs - = [ opt { optionName = "haddock-" ++ name, - optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map ("haddock-" ++) lflags)) descr - | descr <- optionDescr opt] } - | opt <- commandOptions Cabal.haddockCommand showOrParseArgs - , let name = optionName opt - , name `elem` ["hoogle", "html", "html-location" - ,"executables", "tests", "benchmarks", "all", "internal", "css" - ,"hyperlink-source", "quickjump", "hscolour-css" - ,"contents-location", "use-index", "for-hackage", "base-url", "lib", "output-dir"] - ] +haddockOptions showOrParseArgs = + [ opt + { optionName = "haddock-" ++ name + , optionDescr = + [ fmapOptFlags (\(_, lflags) -> ([], map ("haddock-" ++) lflags)) descr + | descr <- optionDescr opt + ] + } + | opt <- commandOptions Cabal.haddockCommand showOrParseArgs + , let name = optionName opt + , name + `elem` [ "hoogle" + , "html" + , "html-location" + , "executables" + , "tests" + , "benchmarks" + , "all" + , "internal" + , "css" + , "hyperlink-source" + , "quickjump" + , "hscolour-css" + , "contents-location" + , "use-index" + , "for-hackage" + , "base-url" + , "lib" + , "output-dir" + ] + ] testOptions :: ShowOrParseArgs -> [OptionField TestFlags] -testOptions showOrParseArgs - = [ opt { optionName = prefixTest name, - optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map prefixTest lflags)) descr - | descr <- optionDescr opt] } - | opt <- commandOptions Cabal.testCommand showOrParseArgs - , let name = optionName opt - , name `elem` ["log", "machine-log", "show-details", "keep-tix-files" - ,"fail-when-no-test-suites", "test-options", "test-option" - ,"test-wrapper"] - ] +testOptions showOrParseArgs = + [ opt + { optionName = prefixTest name + , optionDescr = + [ fmapOptFlags (\(_, lflags) -> ([], map prefixTest lflags)) descr + | descr <- optionDescr opt + ] + } + | opt <- commandOptions Cabal.testCommand showOrParseArgs + , let name = optionName opt + , name + `elem` [ "log" + , "machine-log" + , "show-details" + , "keep-tix-files" + , "fail-when-no-test-suites" + , "test-options" + , "test-option" + , "test-wrapper" + ] + ] where - prefixTest name | "test-" `isPrefixOf` name = name - | otherwise = "test-" ++ name + prefixTest name + | "test-" `isPrefixOf` name = name + | otherwise = "test-" ++ name benchmarkOptions :: ShowOrParseArgs -> [OptionField BenchmarkFlags] -benchmarkOptions showOrParseArgs - = [ opt { optionName = prefixBenchmark name, - optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map prefixBenchmark lflags)) descr - | descr <- optionDescr opt] } - | opt <- commandOptions Cabal.benchmarkCommand showOrParseArgs - , let name = optionName opt - , name `elem` ["benchmark-options", "benchmark-option"] - ] +benchmarkOptions showOrParseArgs = + [ opt + { optionName = prefixBenchmark name + , optionDescr = + [ fmapOptFlags (\(_, lflags) -> ([], map prefixBenchmark lflags)) descr + | descr <- optionDescr opt + ] + } + | opt <- commandOptions Cabal.benchmarkCommand showOrParseArgs + , let name = optionName opt + , name `elem` ["benchmark-options", "benchmark-option"] + ] where - prefixBenchmark name | "benchmark-" `isPrefixOf` name = name - | otherwise = "benchmark-" ++ name + prefixBenchmark name + | "benchmark-" `isPrefixOf` name = name + | otherwise = "benchmark-" ++ name fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a -fmapOptFlags modify (ReqArg d f p r w) = ReqArg d (modify f) p r w -fmapOptFlags modify (OptArg d f p r i w) = OptArg d (modify f) p r i w -fmapOptFlags modify (ChoiceOpt xs) = ChoiceOpt [(d, modify f, i, w) | (d, f, i, w) <- xs] +fmapOptFlags modify (ReqArg d f p r w) = ReqArg d (modify f) p r w +fmapOptFlags modify (OptArg d f p r i w) = OptArg d (modify f) p r i w +fmapOptFlags modify (ChoiceOpt xs) = ChoiceOpt [(d, modify f, i, w) | (d, f, i, w) <- xs] fmapOptFlags modify (BoolOpt d f1 f2 r w) = BoolOpt d (modify f1) (modify f2) r w -installOptions :: ShowOrParseArgs -> [OptionField InstallFlags] +installOptions :: ShowOrParseArgs -> [OptionField InstallFlags] installOptions showOrParseArgs = - [ option "" ["documentation"] - "building of documentation" - installDocumentation (\v flags -> flags { installDocumentation = v }) - (boolOpt [] []) - - , option [] ["doc-index-file"] - "A central index of haddock API documentation (template cannot use $pkgid)" - installHaddockIndex (\v flags -> flags { installHaddockIndex = v }) - (reqArg' "TEMPLATE" (toFlag.toPathTemplate) - (flagToList . fmap fromPathTemplate)) - - , option [] ["dry-run"] - "Do not install anything, only print what would be installed." - installDryRun (\v flags -> flags { installDryRun = v }) - trueArg - - , option [] ["only-download"] - "Do not build anything, only fetch the packages." - installOnlyDownload (\v flags -> flags { installOnlyDownload = v }) - trueArg - - , option "" ["target-package-db"] - "package database to install into. Required when using ${pkgroot} prefix." - installDest (\v flags -> flags { installDest = v }) - (reqArg "DATABASE" (succeedReadE (Flag . Cabal.CopyToDb)) - (\f -> case f of Flag (Cabal.CopyToDb p) -> [p]; _ -> [])) - ] ++ - - optionSolverFlags showOrParseArgs - installMaxBackjumps (\v flags -> flags { installMaxBackjumps = v }) - installReorderGoals (\v flags -> flags { installReorderGoals = v }) - installCountConflicts (\v flags -> flags { installCountConflicts = v }) - installFineGrainedConflicts (\v flags -> flags { installFineGrainedConflicts = v }) - installMinimizeConflictSet (\v flags -> flags { installMinimizeConflictSet = v }) - installIndependentGoals (\v flags -> flags { installIndependentGoals = v }) - installPreferOldest (\v flags -> flags { installPreferOldest = v }) - installShadowPkgs (\v flags -> flags { installShadowPkgs = v }) - installStrongFlags (\v flags -> flags { installStrongFlags = v }) - installAllowBootLibInstalls (\v flags -> flags { installAllowBootLibInstalls = v }) - installOnlyConstrained (\v flags -> flags { installOnlyConstrained = v }) ++ - - [ option [] ["reinstall"] + [ option + "" + ["documentation"] + "building of documentation" + installDocumentation + (\v flags -> flags{installDocumentation = v}) + (boolOpt [] []) + , option + [] + ["doc-index-file"] + "A central index of haddock API documentation (template cannot use $pkgid)" + installHaddockIndex + (\v flags -> flags{installHaddockIndex = v}) + ( reqArg' + "TEMPLATE" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate) + ) + , option + [] + ["dry-run"] + "Do not install anything, only print what would be installed." + installDryRun + (\v flags -> flags{installDryRun = v}) + trueArg + , option + [] + ["only-download"] + "Do not build anything, only fetch the packages." + installOnlyDownload + (\v flags -> flags{installOnlyDownload = v}) + trueArg + , option + "" + ["target-package-db"] + "package database to install into. Required when using ${pkgroot} prefix." + installDest + (\v flags -> flags{installDest = v}) + ( reqArg + "DATABASE" + (succeedReadE (Flag . Cabal.CopyToDb)) + (\f -> case f of Flag (Cabal.CopyToDb p) -> [p]; _ -> []) + ) + ] + ++ optionSolverFlags + showOrParseArgs + installMaxBackjumps + (\v flags -> flags{installMaxBackjumps = v}) + installReorderGoals + (\v flags -> flags{installReorderGoals = v}) + installCountConflicts + (\v flags -> flags{installCountConflicts = v}) + installFineGrainedConflicts + (\v flags -> flags{installFineGrainedConflicts = v}) + installMinimizeConflictSet + (\v flags -> flags{installMinimizeConflictSet = v}) + installIndependentGoals + (\v flags -> flags{installIndependentGoals = v}) + installPreferOldest + (\v flags -> flags{installPreferOldest = v}) + installShadowPkgs + (\v flags -> flags{installShadowPkgs = v}) + installStrongFlags + (\v flags -> flags{installStrongFlags = v}) + installAllowBootLibInstalls + (\v flags -> flags{installAllowBootLibInstalls = v}) + installOnlyConstrained + (\v flags -> flags{installOnlyConstrained = v}) + ++ [ option + [] + ["reinstall"] "Install even if it means installing the same version again." - installReinstall (\v flags -> flags { installReinstall = v }) + installReinstall + (\v flags -> flags{installReinstall = v}) (yesNoOpt showOrParseArgs) - - , option [] ["avoid-reinstalls"] + , option + [] + ["avoid-reinstalls"] "Do not select versions that would destructively overwrite installed packages." (fmap asBool . installAvoidReinstalls) - (\v flags -> flags { installAvoidReinstalls = fmap AvoidReinstalls v }) + (\v flags -> flags{installAvoidReinstalls = fmap AvoidReinstalls v}) (yesNoOpt showOrParseArgs) - - , option [] ["force-reinstalls"] + , option + [] + ["force-reinstalls"] "Reinstall packages even if they will most likely break other installed packages." - installOverrideReinstall (\v flags -> flags { installOverrideReinstall = v }) + installOverrideReinstall + (\v flags -> flags{installOverrideReinstall = v}) (yesNoOpt showOrParseArgs) - - , option [] ["upgrade-dependencies"] + , option + [] + ["upgrade-dependencies"] "Pick the latest version for all dependencies, rather than trying to pick an installed version." - installUpgradeDeps (\v flags -> flags { installUpgradeDeps = v }) + installUpgradeDeps + (\v flags -> flags{installUpgradeDeps = v}) (yesNoOpt showOrParseArgs) - - , option [] ["only-dependencies"] + , option + [] + ["only-dependencies"] "Install only the dependencies necessary to build the given packages" - installOnlyDeps (\v flags -> flags { installOnlyDeps = v }) + installOnlyDeps + (\v flags -> flags{installOnlyDeps = v}) (yesNoOpt showOrParseArgs) - - , option [] ["dependencies-only"] + , option + [] + ["dependencies-only"] "A synonym for --only-dependencies" - installOnlyDeps (\v flags -> flags { installOnlyDeps = v }) + installOnlyDeps + (\v flags -> flags{installOnlyDeps = v}) (yesNoOpt showOrParseArgs) - - , option [] ["index-state"] - ("Use source package index state as it existed at a previous time. " ++ - "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++ - "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD').") - installIndexState (\v flags -> flags { installIndexState = v }) - (reqArg "STATE" (parsecToReadE (const $ "index-state must be a " ++ - "unix-timestamps (e.g. '@1474732068'), " ++ - "a ISO8601 UTC timestamp " ++ - "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'") - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - - , option [] ["root-cmd"] + , option + [] + ["index-state"] + ( "Use source package index state as it existed at a previous time. " + ++ "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " + ++ "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD')." + ) + installIndexState + (\v flags -> flags{installIndexState = v}) + ( reqArg + "STATE" + ( parsecToReadE + ( const $ + "index-state must be a " + ++ "unix-timestamps (e.g. '@1474732068'), " + ++ "a ISO8601 UTC timestamp " + ++ "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'" + ) + (toFlag `fmap` parsec) + ) + (flagToList . fmap prettyShow) + ) + , option + [] + ["root-cmd"] "(No longer supported, do not use.)" - installRootCmd (\v flags -> flags { installRootCmd = v }) + installRootCmd + (\v flags -> flags{installRootCmd = v}) (reqArg' "COMMAND" toFlag flagToList) - - , option [] ["symlink-bindir"] + , option + [] + ["symlink-bindir"] "Add symlinks to installed executables into this directory." - installSymlinkBinDir (\v flags -> flags { installSymlinkBinDir = v }) - (reqArgFlag "DIR") - - , option [] ["build-summary"] + installSymlinkBinDir + (\v flags -> flags{installSymlinkBinDir = v}) + (reqArgFlag "DIR") + , option + [] + ["build-summary"] "Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)" - installSummaryFile (\v flags -> flags { installSummaryFile = v }) + installSummaryFile + (\v flags -> flags{installSummaryFile = v}) (reqArg' "TEMPLATE" (\x -> toNubList [toPathTemplate x]) (map fromPathTemplate . fromNubList)) - - , option [] ["build-log"] + , option + [] + ["build-log"] "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)" - installLogFile (\v flags -> flags { installLogFile = v }) - (reqArg' "TEMPLATE" (toFlag.toPathTemplate) - (flagToList . fmap fromPathTemplate)) - - , option [] ["remote-build-reporting"] + installLogFile + (\v flags -> flags{installLogFile = v}) + ( reqArg' + "TEMPLATE" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate) + ) + , option + [] + ["remote-build-reporting"] "Generate build reports to send to a remote server (none, anonymous or detailed)." - installBuildReports (\v flags -> flags { installBuildReports = v }) - (reqArg "LEVEL" (parsecToReadE (const $ "report level must be 'none', " - ++ "'anonymous' or 'detailed'") - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - - , option [] ["report-planning-failure"] + installBuildReports + (\v flags -> flags{installBuildReports = v}) + ( reqArg + "LEVEL" + ( parsecToReadE + ( const $ + "report level must be 'none', " + ++ "'anonymous' or 'detailed'" + ) + (toFlag `fmap` parsec) + ) + (flagToList . fmap prettyShow) + ) + , option + [] + ["report-planning-failure"] "Generate build reports when the dependency solver fails. This is used by the Hackage build bot." - installReportPlanningFailure (\v flags -> flags { installReportPlanningFailure = v }) + installReportPlanningFailure + (\v flags -> flags{installReportPlanningFailure = v}) trueArg - - , option "" ["per-component"] + , option + "" + ["per-component"] "Per-component builds when possible" - installPerComponent (\v flags -> flags { installPerComponent = v }) + installPerComponent + (\v flags -> flags{installPerComponent = v}) (boolOpt [] []) - - , option [] ["run-tests"] + , option + [] + ["run-tests"] "Run package test suites during installation." - installRunTests (\v flags -> flags { installRunTests = v }) + installRunTests + (\v flags -> flags{installRunTests = v}) trueArg - - , optionNumJobs - installNumJobs (\v flags -> flags { installNumJobs = v }) - - , option [] ["keep-going"] + , optionNumJobs + installNumJobs + (\v flags -> flags{installNumJobs = v}) + , option + [] + ["keep-going"] "After a build failure, continue to build other unaffected packages." - installKeepGoing (\v flags -> flags { installKeepGoing = v }) + installKeepGoing + (\v flags -> flags{installKeepGoing = v}) trueArg - - , option [] ["offline"] + , option + [] + ["offline"] "Don't download packages from the Internet." - installOfflineMode (\v flags -> flags { installOfflineMode = v }) + installOfflineMode + (\v flags -> flags{installOfflineMode = v}) (yesNoOpt showOrParseArgs) - - ] ++ case showOrParseArgs of -- TODO: remove when "cabal install" - -- avoids - ParseArgs -> - [ option [] ["only"] - "Only installs the package in the current directory." - installOnly (\v flags -> flags { installOnly = v }) - trueArg ] - _ -> [] - + ] + ++ case showOrParseArgs of -- TODO: remove when "cabal install" + -- avoids + ParseArgs -> + [ option + [] + ["only"] + "Only installs the package in the current directory." + installOnly + (\v flags -> flags{installOnly = v}) + trueArg + ] + _ -> [] instance Monoid InstallFlags where mempty = gmempty @@ -1978,78 +2600,101 @@ instance Semigroup InstallFlags where (<>) = gmappend -- ------------------------------------------------------------ + -- * Upload flags + -- ------------------------------------------------------------ -- | Is this a candidate package or a package to be published? data IsCandidate = IsCandidate | IsPublished - deriving Eq - -data UploadFlags = UploadFlags { - uploadCandidate :: Flag IsCandidate, - uploadDoc :: Flag Bool, - uploadUsername :: Flag Username, - uploadPassword :: Flag Password, - uploadPasswordCmd :: Flag [String], - uploadVerbosity :: Flag Verbosity - } deriving Generic + deriving (Eq) + +data UploadFlags = UploadFlags + { uploadCandidate :: Flag IsCandidate + , uploadDoc :: Flag Bool + , uploadUsername :: Flag Username + , uploadPassword :: Flag Password + , uploadPasswordCmd :: Flag [String] + , uploadVerbosity :: Flag Verbosity + } + deriving (Generic) defaultUploadFlags :: UploadFlags -defaultUploadFlags = UploadFlags { - uploadCandidate = toFlag IsCandidate, - uploadDoc = toFlag False, - uploadUsername = mempty, - uploadPassword = mempty, - uploadPasswordCmd = mempty, - uploadVerbosity = toFlag normal - } +defaultUploadFlags = + UploadFlags + { uploadCandidate = toFlag IsCandidate + , uploadDoc = toFlag False + , uploadUsername = mempty + , uploadPassword = mempty + , uploadPasswordCmd = mempty + , uploadVerbosity = toFlag normal + } uploadCommand :: CommandUI UploadFlags -uploadCommand = CommandUI { - commandName = "upload", - commandSynopsis = "Uploads source packages or documentation to Hackage.", - commandDescription = Nothing, - commandNotes = Just $ \_ -> - "You can store your Hackage login in the ~/.config/cabal/config file\n" - ++ relevantConfigValuesText ["username", "password", "password-command"], - commandUsage = \pname -> - "Usage: " ++ pname ++ " upload [FLAGS] TARFILES\n", - commandDefaultFlags = defaultUploadFlags, - commandOptions = \_ -> - [optionVerbosity uploadVerbosity - (\v flags -> flags { uploadVerbosity = v }) - - ,option [] ["publish"] - "Publish the package instead of uploading it as a candidate." - uploadCandidate (\v flags -> flags { uploadCandidate = v }) - (noArg (Flag IsPublished)) - - ,option ['d'] ["documentation"] - ("Upload documentation instead of a source package. " - ++ "By default, this uploads documentation for a package candidate. " - ++ "To upload documentation for " - ++ "a published package, combine with --publish.") - uploadDoc (\v flags -> flags { uploadDoc = v }) - trueArg - - ,option ['u'] ["username"] - "Hackage username." - uploadUsername (\v flags -> flags { uploadUsername = v }) - (reqArg' "USERNAME" (toFlag . Username) - (flagToList . fmap unUsername)) - - ,option ['p'] ["password"] - "Hackage password." - uploadPassword (\v flags -> flags { uploadPassword = v }) - (reqArg' "PASSWORD" (toFlag . Password) - (flagToList . fmap unPassword)) - - ,option ['P'] ["password-command"] - "Command to get Hackage password." - uploadPasswordCmd (\v flags -> flags { uploadPasswordCmd = v }) - (reqArg' "PASSWORD" (Flag . words) (fromMaybe [] . flagToMaybe)) - ] - } +uploadCommand = + CommandUI + { commandName = "upload" + , commandSynopsis = "Uploads source packages or documentation to Hackage." + , commandDescription = Nothing + , commandNotes = Just $ \_ -> + "You can store your Hackage login in the ~/.config/cabal/config file\n" + ++ relevantConfigValuesText ["username", "password", "password-command"] + , commandUsage = \pname -> + "Usage: " ++ pname ++ " upload [FLAGS] TARFILES\n" + , commandDefaultFlags = defaultUploadFlags + , commandOptions = \_ -> + [ optionVerbosity + uploadVerbosity + (\v flags -> flags{uploadVerbosity = v}) + , option + [] + ["publish"] + "Publish the package instead of uploading it as a candidate." + uploadCandidate + (\v flags -> flags{uploadCandidate = v}) + (noArg (Flag IsPublished)) + , option + ['d'] + ["documentation"] + ( "Upload documentation instead of a source package. " + ++ "By default, this uploads documentation for a package candidate. " + ++ "To upload documentation for " + ++ "a published package, combine with --publish." + ) + uploadDoc + (\v flags -> flags{uploadDoc = v}) + trueArg + , option + ['u'] + ["username"] + "Hackage username." + uploadUsername + (\v flags -> flags{uploadUsername = v}) + ( reqArg' + "USERNAME" + (toFlag . Username) + (flagToList . fmap unUsername) + ) + , option + ['p'] + ["password"] + "Hackage password." + uploadPassword + (\v flags -> flags{uploadPassword = v}) + ( reqArg' + "PASSWORD" + (toFlag . Password) + (flagToList . fmap unPassword) + ) + , option + ['P'] + ["password-command"] + "Command to get Hackage password." + uploadPasswordCmd + (\v flags -> flags{uploadPasswordCmd = v}) + (reqArg' "PASSWORD" (Flag . words) (fromMaybe [] . flagToMaybe)) + ] + } instance Monoid UploadFlags where mempty = gmempty @@ -2059,230 +2704,366 @@ instance Semigroup UploadFlags where (<>) = gmappend -- ------------------------------------------------------------ + -- * Init flags + -- ------------------------------------------------------------ initCommand :: CommandUI IT.InitFlags -initCommand = CommandUI { - commandName = "init", - commandSynopsis = "Create a new cabal package.", - commandDescription = Just $ \_ -> wrapText $ - "Create a .cabal, CHANGELOG.md, minimal initial Haskell code and optionally a LICENSE file.\n" - ++ "\n" - ++ "Calling init with no arguments runs interactive mode, " - ++ "which will try to guess as much as possible and prompt you for the rest.\n" - ++ "Non-interactive mode can be invoked by the -n/--non-interactive flag, " - ++ "which will let you specify the options via flags and will use the defaults for the rest.\n" - ++ "It is also possible to call init with a single argument, which denotes the project's desired " - ++ "root directory.\n", - commandNotes = Nothing, - commandUsage = \pname -> - "Usage: " ++ pname ++ " init [PROJECT ROOT] [FLAGS]\n", - commandDefaultFlags = IT.defaultInitFlags, - commandOptions = initOptions - } +initCommand = + CommandUI + { commandName = "init" + , commandSynopsis = "Create a new cabal package." + , commandDescription = Just $ \_ -> + wrapText $ + "Create a .cabal, CHANGELOG.md, minimal initial Haskell code and optionally a LICENSE file.\n" + ++ "\n" + ++ "Calling init with no arguments runs interactive mode, " + ++ "which will try to guess as much as possible and prompt you for the rest.\n" + ++ "Non-interactive mode can be invoked by the -n/--non-interactive flag, " + ++ "which will let you specify the options via flags and will use the defaults for the rest.\n" + ++ "It is also possible to call init with a single argument, which denotes the project's desired " + ++ "root directory.\n" + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " init [PROJECT ROOT] [FLAGS]\n" + , commandDefaultFlags = IT.defaultInitFlags + , commandOptions = initOptions + } initOptions :: ShowOrParseArgs -> [OptionField IT.InitFlags] initOptions _ = - [ option ['i'] ["interactive"] - "interactive mode." - IT.interactive (\v flags -> flags { IT.interactive = v }) - (boolOpt' (['i'], ["interactive"]) (['n'], ["non-interactive"])) - - , option ['q'] ["quiet"] - "Do not generate log messages to stdout." - IT.quiet (\v flags -> flags { IT.quiet = v }) - trueArg - - , option [] ["no-comments"] - "Do not generate explanatory comments in the .cabal file." - IT.noComments (\v flags -> flags { IT.noComments = v }) - trueArg - - , option ['m'] ["minimal"] - "Generate a minimal .cabal file, that is, do not include extra empty fields. Also implies --no-comments." - IT.minimal (\v flags -> flags { IT.minimal = v }) - trueArg - - , option [] ["overwrite"] - "Overwrite any existing .cabal, LICENSE, or Setup.hs files without warning." - IT.overwrite (\v flags -> flags { IT.overwrite = v }) - trueArg - - , option [] ["package-dir", "packagedir"] - "Root directory of the package (default = current directory)." - IT.packageDir (\v flags -> flags { IT.packageDir = v }) - (reqArgFlag "DIRECTORY") - - , option ['p'] ["package-name"] - "Name of the Cabal package to create." - IT.packageName (\v flags -> flags { IT.packageName = v }) - (reqArg "PACKAGE" (parsecToReadE ("Cannot parse package name: "++) - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - - , option [] ["version"] - "Initial version of the package." - IT.version (\v flags -> flags { IT.version = v }) - (reqArg "VERSION" (parsecToReadE ("Cannot parse package version: "++) - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - - , option [] ["cabal-version"] - "Version of the Cabal specification." - IT.cabalVersion (\v flags -> flags { IT.cabalVersion = v }) - (reqArg "CABALSPECVERSION" (parsecToReadE ("Cannot parse Cabal specification version: "++) - (fmap (toFlag . getSpecVersion) parsec)) - (flagToList . fmap (prettyShow . SpecVersion))) - - , option ['l'] ["license"] - "Project license." - IT.license (\v flags -> flags { IT.license = v }) - (reqArg "LICENSE" (parsecToReadE ("Cannot parse license: "++) - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - - , option ['a'] ["author"] - "Name of the project's author." - IT.author (\v flags -> flags { IT.author = v }) - (reqArgFlag "NAME") - - , option ['e'] ["email"] - "Email address of the maintainer." - IT.email (\v flags -> flags { IT.email = v }) - (reqArgFlag "EMAIL") - - , option ['u'] ["homepage"] - "Project homepage and/or repository." - IT.homepage (\v flags -> flags { IT.homepage = v }) - (reqArgFlag "URL") - - , option ['s'] ["synopsis"] - "Short project synopsis." - IT.synopsis (\v flags -> flags { IT.synopsis = v }) - (reqArgFlag "TEXT") - - , option ['c'] ["category"] - "Project category." - IT.category (\v flags -> flags { IT.category = v }) - (reqArgFlag "CATEGORY") - - , option ['x'] ["extra-source-file"] - "Extra source file to be distributed with tarball." - IT.extraSrc - (\v flags -> flags { IT.extraSrc = mergeListFlag (IT.extraSrc flags) v }) - (reqArg' "FILE" (Flag . (:[])) - (fromFlagOrDefault [])) - , option [] ["extra-doc-file"] - "Extra doc file to be distributed with tarball." - IT.extraDoc - (\v flags -> flags { IT.extraDoc = mergeListFlag (IT.extraDoc flags) v }) - (reqArg' "FILE" (Flag . (:[])) (fromFlagOrDefault [])) - - , option [] ["lib", "is-library"] - "Build a library." - IT.packageType (\v flags -> flags { IT.packageType = v }) - (noArg (Flag IT.Library)) - - , option [] ["exe", "is-executable"] - "Build an executable." - IT.packageType - (\v flags -> flags { IT.packageType = v }) - (noArg (Flag IT.Executable)) - - , option [] ["libandexe", "is-libandexe"] - "Build a library and an executable." - IT.packageType - (\v flags -> flags { IT.packageType = v }) - (noArg (Flag IT.LibraryAndExecutable)) - - , option [] ["tests"] - "Generate a test suite, standalone or for a library." - IT.initializeTestSuite - (\v flags -> flags { IT.initializeTestSuite = v }) - trueArg - - , option [] ["test-dir"] - "Directory containing tests." - IT.testDirs (\v flags -> - flags { IT.testDirs = mergeListFlag (IT.testDirs flags) v }) - (reqArg' "DIR" (Flag . (:[])) - (fromFlagOrDefault [])) - - , option [] ["simple"] - "Create a simple project with sensible defaults." - IT.simpleProject - (\v flags -> flags { IT.simpleProject = v }) - trueArg - - , option [] ["main-is"] - "Specify the main module." - IT.mainIs - (\v flags -> flags { IT.mainIs = v }) - (reqArgFlag "FILE") - - , option [] ["language"] - "Specify the default language." - IT.language - (\v flags -> flags { IT.language = v }) - (reqArg "LANGUAGE" (parsecToReadE ("Cannot parse language: "++) - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - - , option ['o'] ["expose-module"] - "Export a module from the package." - IT.exposedModules - (\v flags -> flags { IT.exposedModules = - mergeListFlag (IT.exposedModules flags) v}) - (reqArg "MODULE" (parsecToReadE ("Cannot parse module name: "++) - (Flag . (:[]) <$> parsec)) - (flagElim [] (fmap prettyShow))) - - , option [] ["extension"] - "Use a LANGUAGE extension (in the other-extensions field)." - IT.otherExts - (\v flags -> flags { IT.otherExts = - mergeListFlag (IT.otherExts flags) v }) - (reqArg "EXTENSION" (parsecToReadE ("Cannot parse extension: "++) - (Flag . (:[]) <$> parsec)) - (flagElim [] (fmap prettyShow))) - - , option ['d'] ["dependency"] - "Package dependencies. Permits comma separated list of dependencies." - IT.dependencies - (\v flags -> flags { IT.dependencies = - mergeListFlag (IT.dependencies flags) v }) - (reqArg "DEPENDENCIES" (fmap Flag dependenciesReadE) - (fmap prettyShow . fromFlagOrDefault [])) - - , option [] ["application-dir"] - "Directory containing package application executable." - IT.applicationDirs (\v flags -> flags { IT.applicationDirs = - mergeListFlag (IT.applicationDirs flags) v}) - (reqArg' "DIR" (Flag . (:[])) - (fromFlagOrDefault [])) - - , option [] ["source-dir", "sourcedir"] - "Directory containing package library source." - IT.sourceDirs (\v flags -> flags { IT.sourceDirs = - mergeListFlag (IT.sourceDirs flags) v }) - (reqArg' "DIR" (Flag. (:[])) - (fromFlagOrDefault [])) - - , option [] ["build-tool"] - "Required external build tool." - IT.buildTools (\v flags -> flags { IT.buildTools = - mergeListFlag (IT.buildTools flags) v }) - (reqArg' "TOOL" (Flag . (:[])) - (fromFlagOrDefault [])) - - , option "w" ["with-compiler"] - "give the path to a particular compiler. For 'init', this flag is used \ - \to set the bounds inferred for the 'base' package." - IT.initHcPath (\v flags -> flags { IT.initHcPath = v }) - (reqArgFlag "PATH") - - , optionVerbosity IT.initVerbosity (\v flags -> flags { IT.initVerbosity = v }) + [ option + ['i'] + ["interactive"] + "interactive mode." + IT.interactive + (\v flags -> flags{IT.interactive = v}) + (boolOpt' (['i'], ["interactive"]) (['n'], ["non-interactive"])) + , option + ['q'] + ["quiet"] + "Do not generate log messages to stdout." + IT.quiet + (\v flags -> flags{IT.quiet = v}) + trueArg + , option + [] + ["no-comments"] + "Do not generate explanatory comments in the .cabal file." + IT.noComments + (\v flags -> flags{IT.noComments = v}) + trueArg + , option + ['m'] + ["minimal"] + "Generate a minimal .cabal file, that is, do not include extra empty fields. Also implies --no-comments." + IT.minimal + (\v flags -> flags{IT.minimal = v}) + trueArg + , option + [] + ["overwrite"] + "Overwrite any existing .cabal, LICENSE, or Setup.hs files without warning." + IT.overwrite + (\v flags -> flags{IT.overwrite = v}) + trueArg + , option + [] + ["package-dir", "packagedir"] + "Root directory of the package (default = current directory)." + IT.packageDir + (\v flags -> flags{IT.packageDir = v}) + (reqArgFlag "DIRECTORY") + , option + ['p'] + ["package-name"] + "Name of the Cabal package to create." + IT.packageName + (\v flags -> flags{IT.packageName = v}) + ( reqArg + "PACKAGE" + ( parsecToReadE + ("Cannot parse package name: " ++) + (toFlag `fmap` parsec) + ) + (flagToList . fmap prettyShow) + ) + , option + [] + ["version"] + "Initial version of the package." + IT.version + (\v flags -> flags{IT.version = v}) + ( reqArg + "VERSION" + ( parsecToReadE + ("Cannot parse package version: " ++) + (toFlag `fmap` parsec) + ) + (flagToList . fmap prettyShow) + ) + , option + [] + ["cabal-version"] + "Version of the Cabal specification." + IT.cabalVersion + (\v flags -> flags{IT.cabalVersion = v}) + ( reqArg + "CABALSPECVERSION" + ( parsecToReadE + ("Cannot parse Cabal specification version: " ++) + (fmap (toFlag . getSpecVersion) parsec) + ) + (flagToList . fmap (prettyShow . SpecVersion)) + ) + , option + ['l'] + ["license"] + "Project license." + IT.license + (\v flags -> flags{IT.license = v}) + ( reqArg + "LICENSE" + ( parsecToReadE + ("Cannot parse license: " ++) + (toFlag `fmap` parsec) + ) + (flagToList . fmap prettyShow) + ) + , option + ['a'] + ["author"] + "Name of the project's author." + IT.author + (\v flags -> flags{IT.author = v}) + (reqArgFlag "NAME") + , option + ['e'] + ["email"] + "Email address of the maintainer." + IT.email + (\v flags -> flags{IT.email = v}) + (reqArgFlag "EMAIL") + , option + ['u'] + ["homepage"] + "Project homepage and/or repository." + IT.homepage + (\v flags -> flags{IT.homepage = v}) + (reqArgFlag "URL") + , option + ['s'] + ["synopsis"] + "Short project synopsis." + IT.synopsis + (\v flags -> flags{IT.synopsis = v}) + (reqArgFlag "TEXT") + , option + ['c'] + ["category"] + "Project category." + IT.category + (\v flags -> flags{IT.category = v}) + (reqArgFlag "CATEGORY") + , option + ['x'] + ["extra-source-file"] + "Extra source file to be distributed with tarball." + IT.extraSrc + (\v flags -> flags{IT.extraSrc = mergeListFlag (IT.extraSrc flags) v}) + ( reqArg' + "FILE" + (Flag . (: [])) + (fromFlagOrDefault []) + ) + , option + [] + ["extra-doc-file"] + "Extra doc file to be distributed with tarball." + IT.extraDoc + (\v flags -> flags{IT.extraDoc = mergeListFlag (IT.extraDoc flags) v}) + (reqArg' "FILE" (Flag . (: [])) (fromFlagOrDefault [])) + , option + [] + ["lib", "is-library"] + "Build a library." + IT.packageType + (\v flags -> flags{IT.packageType = v}) + (noArg (Flag IT.Library)) + , option + [] + ["exe", "is-executable"] + "Build an executable." + IT.packageType + (\v flags -> flags{IT.packageType = v}) + (noArg (Flag IT.Executable)) + , option + [] + ["libandexe", "is-libandexe"] + "Build a library and an executable." + IT.packageType + (\v flags -> flags{IT.packageType = v}) + (noArg (Flag IT.LibraryAndExecutable)) + , option + [] + ["tests"] + "Generate a test suite, standalone or for a library." + IT.initializeTestSuite + (\v flags -> flags{IT.initializeTestSuite = v}) + trueArg + , option + [] + ["test-dir"] + "Directory containing tests." + IT.testDirs + ( \v flags -> + flags{IT.testDirs = mergeListFlag (IT.testDirs flags) v} + ) + ( reqArg' + "DIR" + (Flag . (: [])) + (fromFlagOrDefault []) + ) + , option + [] + ["simple"] + "Create a simple project with sensible defaults." + IT.simpleProject + (\v flags -> flags{IT.simpleProject = v}) + trueArg + , option + [] + ["main-is"] + "Specify the main module." + IT.mainIs + (\v flags -> flags{IT.mainIs = v}) + (reqArgFlag "FILE") + , option + [] + ["language"] + "Specify the default language." + IT.language + (\v flags -> flags{IT.language = v}) + ( reqArg + "LANGUAGE" + ( parsecToReadE + ("Cannot parse language: " ++) + (toFlag `fmap` parsec) + ) + (flagToList . fmap prettyShow) + ) + , option + ['o'] + ["expose-module"] + "Export a module from the package." + IT.exposedModules + ( \v flags -> + flags + { IT.exposedModules = + mergeListFlag (IT.exposedModules flags) v + } + ) + ( reqArg + "MODULE" + ( parsecToReadE + ("Cannot parse module name: " ++) + (Flag . (: []) <$> parsec) + ) + (flagElim [] (fmap prettyShow)) + ) + , option + [] + ["extension"] + "Use a LANGUAGE extension (in the other-extensions field)." + IT.otherExts + ( \v flags -> + flags + { IT.otherExts = + mergeListFlag (IT.otherExts flags) v + } + ) + ( reqArg + "EXTENSION" + ( parsecToReadE + ("Cannot parse extension: " ++) + (Flag . (: []) <$> parsec) + ) + (flagElim [] (fmap prettyShow)) + ) + , option + ['d'] + ["dependency"] + "Package dependencies. Permits comma separated list of dependencies." + IT.dependencies + ( \v flags -> + flags + { IT.dependencies = + mergeListFlag (IT.dependencies flags) v + } + ) + ( reqArg + "DEPENDENCIES" + (fmap Flag dependenciesReadE) + (fmap prettyShow . fromFlagOrDefault []) + ) + , option + [] + ["application-dir"] + "Directory containing package application executable." + IT.applicationDirs + ( \v flags -> + flags + { IT.applicationDirs = + mergeListFlag (IT.applicationDirs flags) v + } + ) + ( reqArg' + "DIR" + (Flag . (: [])) + (fromFlagOrDefault []) + ) + , option + [] + ["source-dir", "sourcedir"] + "Directory containing package library source." + IT.sourceDirs + ( \v flags -> + flags + { IT.sourceDirs = + mergeListFlag (IT.sourceDirs flags) v + } + ) + ( reqArg' + "DIR" + (Flag . (: [])) + (fromFlagOrDefault []) + ) + , option + [] + ["build-tool"] + "Required external build tool." + IT.buildTools + ( \v flags -> + flags + { IT.buildTools = + mergeListFlag (IT.buildTools flags) v + } + ) + ( reqArg' + "TOOL" + (Flag . (: [])) + (fromFlagOrDefault []) + ) + , option + "w" + ["with-compiler"] + "give the path to a particular compiler. For 'init', this flag is used \ + \to set the bounds inferred for the 'base' package." + IT.initHcPath + (\v flags -> flags{IT.initHcPath = v}) + (reqArgFlag "PATH") + , optionVerbosity IT.initVerbosity (\v flags -> flags{IT.initVerbosity = v}) ] where dependenciesReadE :: ReadE [Dependency] @@ -2296,58 +3077,81 @@ initOptions _ = Flag $ concat (flagToList currentFlags ++ flagToList v) -- ------------------------------------------------------------ + -- * Copy and Register + -- ------------------------------------------------------------ copyCommand :: CommandUI CopyFlags -copyCommand = Cabal.copyCommand - { commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v1-copy " - ++ " All the components in the package\n" - ++ " " ++ pname ++ " v1-copy foo " - ++ " A component (i.e. lib, exe, test suite)" - , commandUsage = usageAlternatives "v1-copy" $ - [ "[FLAGS]" - , "COMPONENTS [FLAGS]" - ] - } +copyCommand = + Cabal.copyCommand + { commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " + ++ pname + ++ " v1-copy " + ++ " All the components in the package\n" + ++ " " + ++ pname + ++ " v1-copy foo " + ++ " A component (i.e. lib, exe, test suite)" + , commandUsage = + usageAlternatives "v1-copy" $ + [ "[FLAGS]" + , "COMPONENTS [FLAGS]" + ] + } registerCommand :: CommandUI RegisterFlags -registerCommand = Cabal.registerCommand - { commandUsage = \pname -> "Usage: " ++ pname ++ " v1-register [FLAGS]\n" } +registerCommand = + Cabal.registerCommand + { commandUsage = \pname -> "Usage: " ++ pname ++ " v1-register [FLAGS]\n" + } -- ------------------------------------------------------------ + -- * ActAsSetup flags + -- ------------------------------------------------------------ -data ActAsSetupFlags = ActAsSetupFlags { - actAsSetupBuildType :: Flag BuildType -} deriving Generic +data ActAsSetupFlags = ActAsSetupFlags + { actAsSetupBuildType :: Flag BuildType + } + deriving (Generic) defaultActAsSetupFlags :: ActAsSetupFlags -defaultActAsSetupFlags = ActAsSetupFlags { - actAsSetupBuildType = toFlag Simple -} +defaultActAsSetupFlags = + ActAsSetupFlags + { actAsSetupBuildType = toFlag Simple + } actAsSetupCommand :: CommandUI ActAsSetupFlags -actAsSetupCommand = CommandUI { - commandName = "act-as-setup", - commandSynopsis = "Run as-if this was a Setup.hs", - commandDescription = Nothing, - commandNotes = Nothing, - commandUsage = \pname -> - "Usage: " ++ pname ++ " act-as-setup\n", - commandDefaultFlags = defaultActAsSetupFlags, - commandOptions = \_ -> - [option "" ["build-type"] - "Use the given build type." - actAsSetupBuildType (\v flags -> flags { actAsSetupBuildType = v }) - (reqArg "BUILD-TYPE" (parsecToReadE ("Cannot parse build type: "++) - (fmap toFlag parsec)) - (map prettyShow . flagToList)) - ] -} +actAsSetupCommand = + CommandUI + { commandName = "act-as-setup" + , commandSynopsis = "Run as-if this was a Setup.hs" + , commandDescription = Nothing + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " act-as-setup\n" + , commandDefaultFlags = defaultActAsSetupFlags + , commandOptions = \_ -> + [ option + "" + ["build-type"] + "Use the given build type." + actAsSetupBuildType + (\v flags -> flags{actAsSetupBuildType = v}) + ( reqArg + "BUILD-TYPE" + ( parsecToReadE + ("Cannot parse build type: " ++) + (fmap toFlag parsec) + ) + (map prettyShow . flagToList) + ) + ] + } instance Monoid ActAsSetupFlags where mempty = gmempty @@ -2357,182 +3161,274 @@ instance Semigroup ActAsSetupFlags where (<>) = gmappend -- ------------------------------------------------------------ + -- * UserConfig flags + -- ------------------------------------------------------------ -data UserConfigFlags = UserConfigFlags { - userConfigVerbosity :: Flag Verbosity, - userConfigForce :: Flag Bool, - userConfigAppendLines :: Flag [String] - } deriving Generic +data UserConfigFlags = UserConfigFlags + { userConfigVerbosity :: Flag Verbosity + , userConfigForce :: Flag Bool + , userConfigAppendLines :: Flag [String] + } + deriving (Generic) instance Monoid UserConfigFlags where - mempty = UserConfigFlags { - userConfigVerbosity = toFlag normal, - userConfigForce = toFlag False, - userConfigAppendLines = toFlag [] - } + mempty = + UserConfigFlags + { userConfigVerbosity = toFlag normal + , userConfigForce = toFlag False + , userConfigAppendLines = toFlag [] + } mappend = (<>) instance Semigroup UserConfigFlags where (<>) = gmappend userConfigCommand :: CommandUI UserConfigFlags -userConfigCommand = CommandUI { - commandName = "user-config", - commandSynopsis = "Display and update the user's global cabal configuration.", - commandDescription = Just $ \_ -> wrapText $ - "When upgrading cabal, the set of configuration keys and their default" - ++ " values may change. This command provides means to merge the existing" - ++ " config in ~/.config/cabal/config" - ++ " (i.e. all bindings that are actually defined and not commented out)" - ++ " and the default config of the new version.\n" - ++ "\n" - ++ "init: Creates a new config file at either ~/.config/cabal/config or as" - ++ " specified by --config-file, if given. An existing file won't be " - ++ " overwritten unless -f or --force is given.\n" - ++ "diff: Shows a pseudo-diff of the user's ~/.config/cabal/config file and" - ++ " the default configuration that would be created by cabal if the" - ++ " config file did not exist.\n" - ++ "update: Applies the pseudo-diff to the configuration that would be" - ++ " created by default, and write the result back to ~/.config/cabal/config.", - - commandNotes = Nothing, - commandUsage = usageAlternatives "user-config" ["init", "diff", "update"], - commandDefaultFlags = mempty, - commandOptions = \ _ -> [ - optionVerbosity userConfigVerbosity (\v flags -> flags { userConfigVerbosity = v }) - , option ['f'] ["force"] - "Overwrite the config file if it already exists." - userConfigForce (\v flags -> flags { userConfigForce = v }) - trueArg - , option ['a'] ["augment"] - "Additional setting to augment the config file (replacing a previous setting if it existed)." - userConfigAppendLines (\v flags -> flags - {userConfigAppendLines = - Flag $ concat (flagToList (userConfigAppendLines flags) ++ flagToList v)}) - (reqArg' "CONFIGLINE" (Flag . (:[])) (fromMaybe [] . flagToMaybe)) - ] - } - +userConfigCommand = + CommandUI + { commandName = "user-config" + , commandSynopsis = "Display and update the user's global cabal configuration." + , commandDescription = Just $ \_ -> + wrapText $ + "When upgrading cabal, the set of configuration keys and their default" + ++ " values may change. This command provides means to merge the existing" + ++ " config in ~/.config/cabal/config" + ++ " (i.e. all bindings that are actually defined and not commented out)" + ++ " and the default config of the new version.\n" + ++ "\n" + ++ "init: Creates a new config file at either ~/.config/cabal/config or as" + ++ " specified by --config-file, if given. An existing file won't be " + ++ " overwritten unless -f or --force is given.\n" + ++ "diff: Shows a pseudo-diff of the user's ~/.config/cabal/config file and" + ++ " the default configuration that would be created by cabal if the" + ++ " config file did not exist.\n" + ++ "update: Applies the pseudo-diff to the configuration that would be" + ++ " created by default, and write the result back to ~/.config/cabal/config." + , commandNotes = Nothing + , commandUsage = usageAlternatives "user-config" ["init", "diff", "update"] + , commandDefaultFlags = mempty + , commandOptions = \_ -> + [ optionVerbosity userConfigVerbosity (\v flags -> flags{userConfigVerbosity = v}) + , option + ['f'] + ["force"] + "Overwrite the config file if it already exists." + userConfigForce + (\v flags -> flags{userConfigForce = v}) + trueArg + , option + ['a'] + ["augment"] + "Additional setting to augment the config file (replacing a previous setting if it existed)." + userConfigAppendLines + ( \v flags -> + flags + { userConfigAppendLines = + Flag $ concat (flagToList (userConfigAppendLines flags) ++ flagToList v) + } + ) + (reqArg' "CONFIGLINE" (Flag . (: [])) (fromMaybe [] . flagToMaybe)) + ] + } -- ------------------------------------------------------------ + -- * GetOpt Utils + -- ------------------------------------------------------------ -reqArgFlag :: ArgPlaceHolder -> - MkOptDescr (b -> Flag String) (Flag String -> b -> b) b +reqArgFlag + :: ArgPlaceHolder + -> MkOptDescr (b -> Flag String) (Flag String -> b -> b) b reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList -liftOptions :: (b -> a) -> (a -> b -> b) - -> [OptionField a] -> [OptionField b] +liftOptions + :: (b -> a) + -> (a -> b -> b) + -> [OptionField a] + -> [OptionField b] liftOptions get set = map (liftOption get set) yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b yesNoOpt ShowArgs sf lf = trueArg sf lf -yesNoOpt _ sf lf = Command.boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf +yesNoOpt _ sf lf = Command.boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf -optionSolver :: (flags -> Flag PreSolver) - -> (Flag PreSolver -> flags -> flags) - -> OptionField flags +optionSolver + :: (flags -> Flag PreSolver) + -> (Flag PreSolver -> flags -> flags) + -> OptionField flags optionSolver get set = - option [] ["solver"] + option + [] + ["solver"] ("Select dependency solver to use (default: " ++ prettyShow defaultSolver ++ "). Choices: " ++ allSolvers ++ ".") - get set - (reqArg "SOLVER" (parsecToReadE (const $ "solver must be one of: " ++ allSolvers) - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - -optionSolverFlags :: ShowOrParseArgs - -> (flags -> Flag Int ) -> (Flag Int -> flags -> flags) - -> (flags -> Flag ReorderGoals) -> (Flag ReorderGoals -> flags -> flags) - -> (flags -> Flag CountConflicts) -> (Flag CountConflicts -> flags -> flags) - -> (flags -> Flag FineGrainedConflicts) -> (Flag FineGrainedConflicts -> flags -> flags) - -> (flags -> Flag MinimizeConflictSet) -> (Flag MinimizeConflictSet -> flags -> flags) - -> (flags -> Flag IndependentGoals) -> (Flag IndependentGoals -> flags -> flags) - -> (flags -> Flag PreferOldest) -> (Flag PreferOldest -> flags -> flags) - -> (flags -> Flag ShadowPkgs) -> (Flag ShadowPkgs -> flags -> flags) - -> (flags -> Flag StrongFlags) -> (Flag StrongFlags -> flags -> flags) - -> (flags -> Flag AllowBootLibInstalls) -> (Flag AllowBootLibInstalls -> flags -> flags) - -> (flags -> Flag OnlyConstrained) -> (Flag OnlyConstrained -> flags -> flags) - -> [OptionField flags] -optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc - getfgc setfgc getmc setmc getig setig getpo setpo getsip setsip - getstrfl setstrfl getib setib getoc setoc = - [ option [] ["max-backjumps"] - ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.") - getmbj setmbj - (reqArg "NUM" (parsecToReadE ("Cannot parse number: "++) (fmap toFlag P.signedIntegral)) - (map show . flagToList)) - , option [] ["reorder-goals"] - "Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages." - (fmap asBool . getrg) - (setrg . fmap ReorderGoals) - (yesNoOpt showOrParseArgs) - , option [] ["count-conflicts"] - "Try to speed up solving by preferring goals that are involved in a lot of conflicts (default)." - (fmap asBool . getcc) - (setcc . fmap CountConflicts) - (yesNoOpt showOrParseArgs) - , option [] ["fine-grained-conflicts"] - "Skip a version of a package if it does not resolve the conflicts encountered in the last version, as a solver optimization (default)." - (fmap asBool . getfgc) - (setfgc . fmap FineGrainedConflicts) - (yesNoOpt showOrParseArgs) - , option [] ["minimize-conflict-set"] - ("When there is no solution, try to improve the error message by finding " - ++ "a minimal conflict set (default: false). May increase run time " - ++ "significantly.") - (fmap asBool . getmc) - (setmc . fmap MinimizeConflictSet) - (yesNoOpt showOrParseArgs) - , option [] ["independent-goals"] - "Treat several goals on the command line as independent. If several goals depend on the same package, different versions can be chosen." - (fmap asBool . getig) - (setig . fmap IndependentGoals) - (yesNoOpt showOrParseArgs) - , option [] ["prefer-oldest"] - "Prefer the oldest (instead of the latest) versions of packages available. Useful to determine lower bounds in the build-depends section." - (fmap asBool . getpo) - (setpo . fmap PreferOldest) - (yesNoOpt showOrParseArgs) - , option [] ["shadow-installed-packages"] - "If multiple package instances of the same version are installed, treat all but one as shadowed." - (fmap asBool . getsip) - (setsip . fmap ShadowPkgs) - (yesNoOpt showOrParseArgs) - , option [] ["strong-flags"] - "Do not defer flag choices (this used to be the default in cabal-install <= 1.20)." - (fmap asBool . getstrfl) - (setstrfl . fmap StrongFlags) - (yesNoOpt showOrParseArgs) - , option [] ["allow-boot-library-installs"] - "Allow cabal to install base, ghc-prim, integer-simple, integer-gmp, and template-haskell." - (fmap asBool . getib) - (setib . fmap AllowBootLibInstalls) - (yesNoOpt showOrParseArgs) - , option [] ["reject-unconstrained-dependencies"] - "Require these packages to have constraints on them if they are to be selected (default: none)." - getoc - setoc - (reqArg "none|all" - (parsecToReadE - (const "reject-unconstrained-dependencies must be 'none' or 'all'") - (toFlag `fmap` parsec)) - (flagToList . fmap prettyShow)) - - ] + get + set + ( reqArg + "SOLVER" + ( parsecToReadE + (const $ "solver must be one of: " ++ allSolvers) + (toFlag `fmap` parsec) + ) + (flagToList . fmap prettyShow) + ) + +optionSolverFlags + :: ShowOrParseArgs + -> (flags -> Flag Int) + -> (Flag Int -> flags -> flags) + -> (flags -> Flag ReorderGoals) + -> (Flag ReorderGoals -> flags -> flags) + -> (flags -> Flag CountConflicts) + -> (Flag CountConflicts -> flags -> flags) + -> (flags -> Flag FineGrainedConflicts) + -> (Flag FineGrainedConflicts -> flags -> flags) + -> (flags -> Flag MinimizeConflictSet) + -> (Flag MinimizeConflictSet -> flags -> flags) + -> (flags -> Flag IndependentGoals) + -> (Flag IndependentGoals -> flags -> flags) + -> (flags -> Flag PreferOldest) + -> (Flag PreferOldest -> flags -> flags) + -> (flags -> Flag ShadowPkgs) + -> (Flag ShadowPkgs -> flags -> flags) + -> (flags -> Flag StrongFlags) + -> (Flag StrongFlags -> flags -> flags) + -> (flags -> Flag AllowBootLibInstalls) + -> (Flag AllowBootLibInstalls -> flags -> flags) + -> (flags -> Flag OnlyConstrained) + -> (Flag OnlyConstrained -> flags -> flags) + -> [OptionField flags] +optionSolverFlags + showOrParseArgs + getmbj + setmbj + getrg + setrg + getcc + setcc + getfgc + setfgc + getmc + setmc + getig + setig + getpo + setpo + getsip + setsip + getstrfl + setstrfl + getib + setib + getoc + setoc = + [ option + [] + ["max-backjumps"] + ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.") + getmbj + setmbj + ( reqArg + "NUM" + (parsecToReadE ("Cannot parse number: " ++) (fmap toFlag P.signedIntegral)) + (map show . flagToList) + ) + , option + [] + ["reorder-goals"] + "Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages." + (fmap asBool . getrg) + (setrg . fmap ReorderGoals) + (yesNoOpt showOrParseArgs) + , option + [] + ["count-conflicts"] + "Try to speed up solving by preferring goals that are involved in a lot of conflicts (default)." + (fmap asBool . getcc) + (setcc . fmap CountConflicts) + (yesNoOpt showOrParseArgs) + , option + [] + ["fine-grained-conflicts"] + "Skip a version of a package if it does not resolve the conflicts encountered in the last version, as a solver optimization (default)." + (fmap asBool . getfgc) + (setfgc . fmap FineGrainedConflicts) + (yesNoOpt showOrParseArgs) + , option + [] + ["minimize-conflict-set"] + ( "When there is no solution, try to improve the error message by finding " + ++ "a minimal conflict set (default: false). May increase run time " + ++ "significantly." + ) + (fmap asBool . getmc) + (setmc . fmap MinimizeConflictSet) + (yesNoOpt showOrParseArgs) + , option + [] + ["independent-goals"] + "Treat several goals on the command line as independent. If several goals depend on the same package, different versions can be chosen." + (fmap asBool . getig) + (setig . fmap IndependentGoals) + (yesNoOpt showOrParseArgs) + , option + [] + ["prefer-oldest"] + "Prefer the oldest (instead of the latest) versions of packages available. Useful to determine lower bounds in the build-depends section." + (fmap asBool . getpo) + (setpo . fmap PreferOldest) + (yesNoOpt showOrParseArgs) + , option + [] + ["shadow-installed-packages"] + "If multiple package instances of the same version are installed, treat all but one as shadowed." + (fmap asBool . getsip) + (setsip . fmap ShadowPkgs) + (yesNoOpt showOrParseArgs) + , option + [] + ["strong-flags"] + "Do not defer flag choices (this used to be the default in cabal-install <= 1.20)." + (fmap asBool . getstrfl) + (setstrfl . fmap StrongFlags) + (yesNoOpt showOrParseArgs) + , option + [] + ["allow-boot-library-installs"] + "Allow cabal to install base, ghc-prim, integer-simple, integer-gmp, and template-haskell." + (fmap asBool . getib) + (setib . fmap AllowBootLibInstalls) + (yesNoOpt showOrParseArgs) + , option + [] + ["reject-unconstrained-dependencies"] + "Require these packages to have constraints on them if they are to be selected (default: none)." + getoc + setoc + ( reqArg + "none|all" + ( parsecToReadE + (const "reject-unconstrained-dependencies must be 'none' or 'all'") + (toFlag `fmap` parsec) + ) + (flagToList . fmap prettyShow) + ) + ] usagePackages :: String -> String -> String usagePackages name pname = - "Usage: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n" + "Usage: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n" usageFlags :: String -> String -> String usageFlags name pname = "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n" -- ------------------------------------------------------------ + -- * Repo helpers + -- ------------------------------------------------------------ showRemoteRepo :: RemoteRepo -> String @@ -2548,10 +3444,12 @@ readLocalRepo :: String -> Maybe LocalRepo readLocalRepo = simpleParsec -- ------------------------------------------------------------ + -- * Helpers for Documentation + -- ------------------------------------------------------------ relevantConfigValuesText :: [String] -> String relevantConfigValuesText vs = - "Relevant global configuration keys:\n" - ++ concat [" " ++ v ++ "\n" |v <- vs] + "Relevant global configuration keys:\n" + ++ concat [" " ++ v ++ "\n" | v <- vs] diff --git a/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs index e4885ed07c6..f48f37ae50b 100644 --- a/cabal-install/src/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/src/Distribution/Client/SetupWrapper.hs @@ -1,7 +1,10 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{- FOURMOLU_DISABLE -} + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.SetupWrapper -- Copyright : (c) The University of Glasgow 2006, @@ -16,104 +19,168 @@ -- 'Custom', and the current version of Cabal is acceptable, this performs -- setup actions directly. Otherwise it builds the setup script and -- runs it with the given arguments. - -module Distribution.Client.SetupWrapper ( - getSetup, runSetup, runSetupCommand, setupWrapper, - SetupScriptOptions(..), - defaultSetupScriptOptions, +module Distribution.Client.SetupWrapper + ( getSetup + , runSetup + , runSetupCommand + , setupWrapper + , SetupScriptOptions (..) + , defaultSetupScriptOptions ) where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () +import qualified Distribution.Backpack as Backpack import Distribution.CabalSpecVersion (cabalSpecMinimumLibraryVersion) +import Distribution.Compiler + ( CompilerFlavor (GHC, GHCJS) + , buildCompilerId + ) import qualified Distribution.Make as Make -import qualified Distribution.Simple as Simple -import Distribution.Version - ( Version, mkVersion, versionNumbers, VersionRange, anyVersion - , intersectVersionRanges, orLaterVersion - , withinRange ) -import qualified Distribution.Backpack as Backpack import Distribution.Package - ( newSimpleUnitId, unsafeMkDefUnitId, ComponentId - , PackageId, mkPackageName - , PackageIdentifier(..), packageVersion, packageName ) + ( ComponentId + , PackageId + , PackageIdentifier (..) + , mkPackageName + , newSimpleUnitId + , packageName + , packageVersion + , unsafeMkDefUnitId + ) import Distribution.PackageDescription - ( GenericPackageDescription(packageDescription) - , PackageDescription(..), specVersion, buildType - , BuildType(..) ) -import Distribution.Types.ModuleRenaming (defaultRenaming) -import Distribution.Simple.Configure - ( configCompilerEx ) -import Distribution.Compiler - ( buildCompilerId, CompilerFlavor(GHC, GHCJS) ) + ( BuildType (..) + , GenericPackageDescription (packageDescription) + , PackageDescription (..) + , buildType + , specVersion + ) +import qualified Distribution.Simple as Simple +import Distribution.Simple.Build.Macros + ( generatePackageVersionMacros + ) +import Distribution.Simple.BuildPaths + ( defaultDistPref + , exeExtension + ) import Distribution.Simple.Compiler - ( Compiler(compilerId), compilerFlavor, PackageDB(..), PackageDBStack ) + ( Compiler (compilerId) + , PackageDB (..) + , PackageDBStack + , compilerFlavor + ) +import Distribution.Simple.Configure + ( configCompilerEx + ) import Distribution.Simple.PackageDescription - ( readGenericPackageDescription ) + ( readGenericPackageDescription + ) import Distribution.Simple.PreProcess - ( runSimplePreProcessor, ppUnlit ) -import Distribution.Simple.Build.Macros - ( generatePackageVersionMacros ) + ( ppUnlit + , runSimplePreProcessor + ) import Distribution.Simple.Program - ( ProgramDb, emptyProgramDb - , getProgramSearchPath, getDbProgramOutput, runDbProgram, ghcProgram - , ghcjsProgram ) + ( ProgramDb + , emptyProgramDb + , getDbProgramOutput + , getProgramSearchPath + , ghcProgram + , ghcjsProgram + , runDbProgram + ) import Distribution.Simple.Program.Find - ( programSearchPathAsPATHVar - , ProgramSearchPathEntry(ProgramSearchPathDir) ) + ( ProgramSearchPathEntry (ProgramSearchPathDir) + , programSearchPathAsPATHVar + ) import Distribution.Simple.Program.Run - ( getEffectiveEnvironment ) + ( getEffectiveEnvironment + ) import qualified Distribution.Simple.Program.Strip as Strip -import Distribution.Simple.BuildPaths - ( defaultDistPref, exeExtension ) +import Distribution.Types.ModuleRenaming (defaultRenaming) +import Distribution.Version + ( Version + , VersionRange + , anyVersion + , intersectVersionRanges + , mkVersion + , orLaterVersion + , versionNumbers + , withinRange + ) -import Distribution.Simple.Command - ( CommandUI(..), commandShowOptions ) -import Distribution.Simple.Program.GHC - ( GhcMode(..), GhcOptions(..), renderGhcOptions ) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.Client.Types import Distribution.Client.Config - ( defaultCacheDir ) + ( defaultCacheDir + ) import Distribution.Client.IndexUtils - ( getInstalledPackages ) + ( getInstalledPackages + ) import Distribution.Client.JobControl - ( Lock, criticalSection ) -import Distribution.Simple.Setup - ( Flag(..) ) -import Distribution.Utils.Generic - ( safeHead ) -import Distribution.Simple.Utils - ( die', debug, info, infoNoWrap, maybeExit - , cabalVersion, tryFindPackageDesc, rawSystemProc - , createDirectoryIfMissingVerbose, installExecutableFile - , copyFileVerbose, rewriteFileEx, rewriteFileLBS ) + ( Lock + , criticalSection + ) +import Distribution.Client.Types import Distribution.Client.Utils - ( inDir, tryCanonicalizePath, withExtraPathEnv - , existsAndIsMoreRecentThan, moreRecentFile, withEnv, withEnvOverrides + ( existsAndIsMoreRecentThan + , inDir #ifdef mingw32_HOST_OS - , canonicalizePathNoThrow + , canonicalizePathNoThrow #endif - ) + , moreRecentFile + , tryCanonicalizePath + , withEnv + , withEnvOverrides + , withExtraPathEnv + ) +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.Simple.Command + ( CommandUI (..) + , commandShowOptions + ) +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.Program.GHC + ( GhcMode (..) + , GhcOptions (..) + , renderGhcOptions + ) +import Distribution.Simple.Setup + ( Flag (..) + ) +import Distribution.Simple.Utils + ( cabalVersion + , copyFileVerbose + , createDirectoryIfMissingVerbose + , debug + , die' + , info + , infoNoWrap + , installExecutableFile + , maybeExit + , rawSystemProc + , rewriteFileEx + , rewriteFileLBS + , tryFindPackageDesc + ) +import Distribution.Utils.Generic + ( safeHead + ) +import Distribution.Compat.Stack import Distribution.ReadE -import Distribution.System ( Platform(..), buildPlatform ) +import Distribution.System (Platform (..), buildPlatform) import Distribution.Utils.NubList - ( toNubListR ) + ( toNubListR + ) import Distribution.Verbosity -import Distribution.Compat.Stack -import System.Directory ( doesFileExist ) -import System.FilePath ( (), (<.>) ) -import System.IO ( Handle, hPutStr ) +import Data.List (foldl1') +import Distribution.Client.Compat.ExecutablePath (getExecutablePath) import Distribution.Compat.Process (proc) -import System.Process ( StdStream(..) ) +import System.Directory (doesFileExist) +import System.FilePath ((<.>), ()) +import System.IO (Handle, hPutStr) +import System.Process (StdStream (..)) import qualified System.Process as Process -import Data.List ( foldl1' ) -import Distribution.Client.Compat.ExecutablePath ( getExecutablePath ) import qualified Data.ByteString.Lazy as BS @@ -129,22 +196,24 @@ import qualified System.Win32 as Win32 -- | @Setup@ encapsulates the outcome of configuring a setup method to build a -- particular package. -data Setup = Setup { setupMethod :: SetupMethod - , setupScriptOptions :: SetupScriptOptions - , setupVersion :: Version - , setupBuildType :: BuildType - , setupPackage :: PackageDescription - } +data Setup = Setup + { setupMethod :: SetupMethod + , setupScriptOptions :: SetupScriptOptions + , setupVersion :: Version + , setupBuildType :: BuildType + , setupPackage :: PackageDescription + } -- | @SetupMethod@ represents one of the methods used to run Cabal commands. -data SetupMethod = InternalMethod - -- ^ run Cabal commands through \"cabal\" in the - -- current process - | SelfExecMethod - -- ^ run Cabal commands through \"cabal\" as a - -- child process - | ExternalMethod FilePath - -- ^ run Cabal commands through a custom \"Setup\" executable +data SetupMethod + = -- | run Cabal commands through \"cabal\" in the + -- current process + InternalMethod + | -- | run Cabal commands through \"cabal\" as a + -- child process + SelfExecMethod + | -- | run Cabal commands through a custom \"Setup\" executable + ExternalMethod FilePath -- TODO: The 'setupWrapper' and 'SetupScriptOptions' should be split into two -- parts: one that has no policy and just does as it's told with all the @@ -157,71 +226,63 @@ data SetupMethod = InternalMethod -- | @SetupScriptOptions@ are options used to configure and run 'Setup', as -- opposed to options given to the Cabal command at runtime. -data SetupScriptOptions = SetupScriptOptions { - -- | The version of the Cabal library to use (if 'useDependenciesExclusive' - -- is not set). A suitable version of the Cabal library must be installed - -- (or for some build-types be the one cabal-install was built with). - -- - -- The version found also determines the version of the Cabal specification - -- that we us for talking to the Setup.hs, unless overridden by - -- 'useCabalSpecVersion'. - -- - useCabalVersion :: VersionRange, - - -- | This is the version of the Cabal specification that we believe that - -- this package uses. This affects the semantics and in particular the - -- Setup command line interface. - -- - -- This is similar to 'useCabalVersion' but instead of probing the system - -- for a version of the /Cabal library/ you just say exactly which version - -- of the /spec/ we will use. Using this also avoid adding the Cabal - -- library as an additional dependency, so add it to 'useDependencies' - -- if needed. - -- - useCabalSpecVersion :: Maybe Version, - useCompiler :: Maybe Compiler, - usePlatform :: Maybe Platform, - usePackageDB :: PackageDBStack, - usePackageIndex :: Maybe InstalledPackageIndex, - useProgramDb :: ProgramDb, - useDistPref :: FilePath, - useLoggingHandle :: Maybe Handle, - useWorkingDir :: Maybe FilePath, - -- | Extra things to add to PATH when invoking the setup script. - useExtraPathEnv :: [FilePath], - -- | Extra environment variables paired with overrides, where - -- - -- * @'Just' v@ means \"set the environment variable's value to @v@\". - -- * 'Nothing' means \"unset the environment variable\". - useExtraEnvOverrides :: [(String, Maybe FilePath)], - forceExternalSetupMethod :: Bool, - - -- | List of dependencies to use when building Setup.hs. - useDependencies :: [(ComponentId, PackageId)], - - -- | Is the list of setup dependencies exclusive? - -- - -- When this is @False@, if we compile the Setup.hs script we do so with the - -- list in 'useDependencies' but all other packages in the environment are - -- also visible. A suitable version of @Cabal@ library (see - -- 'useCabalVersion') is also added to the list of dependencies, unless - -- 'useDependencies' already contains a Cabal dependency. - -- - -- When @True@, only the 'useDependencies' packages are used, with other - -- packages in the environment hidden. - -- - -- This feature is here to support the setup stanza in .cabal files that - -- specifies explicit (and exclusive) dependencies, as well as the old - -- style with no dependencies. - useDependenciesExclusive :: Bool, - - -- | Should we build the Setup.hs with CPP version macros available? - -- We turn this on when we have a setup stanza in .cabal that declares - -- explicit setup dependencies. - -- - useVersionMacros :: Bool, - - -- Used only by 'cabal clean' on Windows. +data SetupScriptOptions = SetupScriptOptions + { useCabalVersion :: VersionRange + -- ^ The version of the Cabal library to use (if 'useDependenciesExclusive' + -- is not set). A suitable version of the Cabal library must be installed + -- (or for some build-types be the one cabal-install was built with). + -- + -- The version found also determines the version of the Cabal specification + -- that we us for talking to the Setup.hs, unless overridden by + -- 'useCabalSpecVersion'. + , useCabalSpecVersion :: Maybe Version + -- ^ This is the version of the Cabal specification that we believe that + -- this package uses. This affects the semantics and in particular the + -- Setup command line interface. + -- + -- This is similar to 'useCabalVersion' but instead of probing the system + -- for a version of the /Cabal library/ you just say exactly which version + -- of the /spec/ we will use. Using this also avoid adding the Cabal + -- library as an additional dependency, so add it to 'useDependencies' + -- if needed. + , useCompiler :: Maybe Compiler + , usePlatform :: Maybe Platform + , usePackageDB :: PackageDBStack + , usePackageIndex :: Maybe InstalledPackageIndex + , useProgramDb :: ProgramDb + , useDistPref :: FilePath + , useLoggingHandle :: Maybe Handle + , useWorkingDir :: Maybe FilePath + , useExtraPathEnv :: [FilePath] + -- ^ Extra things to add to PATH when invoking the setup script. + , useExtraEnvOverrides :: [(String, Maybe FilePath)] + -- ^ Extra environment variables paired with overrides, where + -- + -- * @'Just' v@ means \"set the environment variable's value to @v@\". + -- * 'Nothing' means \"unset the environment variable\". + , forceExternalSetupMethod :: Bool + , useDependencies :: [(ComponentId, PackageId)] + -- ^ List of dependencies to use when building Setup.hs. + , useDependenciesExclusive :: Bool + -- ^ Is the list of setup dependencies exclusive? + -- + -- When this is @False@, if we compile the Setup.hs script we do so with the + -- list in 'useDependencies' but all other packages in the environment are + -- also visible. A suitable version of @Cabal@ library (see + -- 'useCabalVersion') is also added to the list of dependencies, unless + -- 'useDependencies' already contains a Cabal dependency. + -- + -- When @True@, only the 'useDependencies' packages are used, with other + -- packages in the environment hidden. + -- + -- This feature is here to support the setup stanza in .cabal files that + -- specifies explicit (and exclusive) dependencies, as well as the old + -- style with no dependencies. + , useVersionMacros :: Bool + -- ^ Should we build the Setup.hs with CPP version macros available? + -- We turn this on when we have a setup stanza in .cabal that declares + -- explicit setup dependencies. + , -- Used only by 'cabal clean' on Windows. -- -- Note: win32 clean hack ------------------------- @@ -230,9 +291,8 @@ data SetupScriptOptions = SetupScriptOptions { -- unlike on Linux). So we have to move the setup exe out of the way first -- and then delete it manually. This applies only to the external setup -- method. - useWin32CleanHack :: Bool, - - -- Used only when calling setupWrapper from parallel code to serialise + useWin32CleanHack :: Bool + , -- Used only when calling setupWrapper from parallel code to serialise -- access to the setup cache; should be Nothing otherwise. -- -- Note: setup exe cache @@ -244,96 +304,105 @@ data SetupScriptOptions = SetupScriptOptions { -- version) combination the cache holds a compiled setup script -- executable. This only affects the Simple build type; for the Custom, -- Configure and Make build types we always compile the setup script anew. - setupCacheLock :: Maybe Lock, - - -- | Is the task we are going to run an interactive foreground task, - -- or an non-interactive background task? Based on this flag we - -- decide whether or not to delegate ctrl+c to the spawned task - isInteractive :: Bool + setupCacheLock :: Maybe Lock + , isInteractive :: Bool + -- ^ Is the task we are going to run an interactive foreground task, + -- or an non-interactive background task? Based on this flag we + -- decide whether or not to delegate ctrl+c to the spawned task } defaultSetupScriptOptions :: SetupScriptOptions -defaultSetupScriptOptions = SetupScriptOptions { - useCabalVersion = anyVersion, - useCabalSpecVersion = Nothing, - useCompiler = Nothing, - usePlatform = Nothing, - usePackageDB = [GlobalPackageDB, UserPackageDB], - usePackageIndex = Nothing, - useDependencies = [], - useDependenciesExclusive = False, - useVersionMacros = False, - useProgramDb = emptyProgramDb, - useDistPref = defaultDistPref, - useLoggingHandle = Nothing, - useWorkingDir = Nothing, - useExtraPathEnv = [], - useExtraEnvOverrides = [], - useWin32CleanHack = False, - forceExternalSetupMethod = False, - setupCacheLock = Nothing, - isInteractive = False - } +defaultSetupScriptOptions = + SetupScriptOptions + { useCabalVersion = anyVersion + , useCabalSpecVersion = Nothing + , useCompiler = Nothing + , usePlatform = Nothing + , usePackageDB = [GlobalPackageDB, UserPackageDB] + , usePackageIndex = Nothing + , useDependencies = [] + , useDependenciesExclusive = False + , useVersionMacros = False + , useProgramDb = emptyProgramDb + , useDistPref = defaultDistPref + , useLoggingHandle = Nothing + , useWorkingDir = Nothing + , useExtraPathEnv = [] + , useExtraEnvOverrides = [] + , useWin32CleanHack = False + , forceExternalSetupMethod = False + , setupCacheLock = Nothing + , isInteractive = False + } workingDir :: SetupScriptOptions -> FilePath workingDir options = case fromMaybe "" (useWorkingDir options) of - [] -> "." + [] -> "." dir -> dir -- | A @SetupRunner@ implements a 'SetupMethod'. -type SetupRunner = Verbosity - -> SetupScriptOptions - -> BuildType - -> [String] - -> IO () +type SetupRunner = + Verbosity + -> SetupScriptOptions + -> BuildType + -> [String] + -> IO () -- | Prepare to build a package by configuring a 'SetupMethod'. The returned -- 'Setup' object identifies the method. The 'SetupScriptOptions' may be changed -- during the configuration process; the final values are given by -- 'setupScriptOptions'. -getSetup :: Verbosity - -> SetupScriptOptions - -> Maybe PackageDescription - -> IO Setup +getSetup + :: Verbosity + -> SetupScriptOptions + -> Maybe PackageDescription + -> IO Setup getSetup verbosity options mpkg = do pkg <- maybe getPkg return mpkg - let options' = options { - useCabalVersion = intersectVersionRanges - (useCabalVersion options) - (orLaterVersion (mkVersion (cabalSpecMinimumLibraryVersion (specVersion pkg)))) - } - buildType' = buildType pkg + let options' = + options + { useCabalVersion = + intersectVersionRanges + (useCabalVersion options) + (orLaterVersion (mkVersion (cabalSpecMinimumLibraryVersion (specVersion pkg)))) + } + buildType' = buildType pkg (version, method, options'') <- getSetupMethod verbosity options' pkg buildType' - return Setup { setupMethod = method - , setupScriptOptions = options'' - , setupVersion = version - , setupBuildType = buildType' - , setupPackage = pkg - } + return + Setup + { setupMethod = method + , setupScriptOptions = options'' + , setupVersion = version + , setupBuildType = buildType' + , setupPackage = pkg + } where - getPkg = tryFindPackageDesc verbosity (fromMaybe "." (useWorkingDir options)) - >>= readGenericPackageDescription verbosity - >>= return . packageDescription + getPkg = + tryFindPackageDesc verbosity (fromMaybe "." (useWorkingDir options)) + >>= readGenericPackageDescription verbosity + >>= return . packageDescription -- | Decide if we're going to be able to do a direct internal call to the -- entry point in the Cabal library or if we're going to have to compile -- and execute an external Setup.hs script. --- getSetupMethod - :: Verbosity -> SetupScriptOptions -> PackageDescription -> BuildType + :: Verbosity + -> SetupScriptOptions + -> PackageDescription + -> BuildType -> IO (Version, SetupMethod, SetupScriptOptions) getSetupMethod verbosity options pkg buildType' | buildType' == Custom - || maybe False (cabalVersion /=) (useCabalSpecVersion options) - || not (cabalVersion `withinRange` useCabalVersion options) = - getExternalSetupMethod verbosity options pkg buildType' + || maybe False (cabalVersion /=) (useCabalSpecVersion options) + || not (cabalVersion `withinRange` useCabalVersion options) = + getExternalSetupMethod verbosity options pkg buildType' | isJust (useLoggingHandle options) - -- Forcing is done to use an external process e.g. due to parallel - -- build concerns. - || forceExternalSetupMethod options = - return (cabalVersion, SelfExecMethod, options) + -- Forcing is done to use an external process e.g. due to parallel + -- build concerns. + || forceExternalSetupMethod options = + return (cabalVersion, SelfExecMethod, options) | otherwise = return (cabalVersion, InternalMethod, options) runSetupMethod :: WithCallStack (SetupMethod -> SetupRunner) @@ -342,9 +411,12 @@ runSetupMethod (ExternalMethod path) = externalSetupMethod path runSetupMethod SelfExecMethod = selfExecSetupMethod -- | Run a configured 'Setup' with specific arguments. -runSetup :: Verbosity -> Setup - -> [String] -- ^ command-line arguments - -> IO () +runSetup + :: Verbosity + -> Setup + -> [String] + -- ^ command-line arguments + -> IO () runSetup verbosity setup args0 = do let method = setupMethod setup options = setupScriptOptions setup @@ -352,9 +424,13 @@ runSetup verbosity setup args0 = do args = verbosityHack (setupVersion setup) args0 when (verbosity >= deafening {- avoid test if not debug -} && args /= args0) $ infoNoWrap verbose $ - "Applied verbosity hack:\n" ++ - " Before: " ++ show args0 ++ "\n" ++ - " After: " ++ show args ++ "\n" + "Applied verbosity hack:\n" + ++ " Before: " + ++ show args0 + ++ "\n" + ++ " After: " + ++ show args + ++ "\n" runSetupMethod method verbosity options bt args -- | This is a horrible hack to make sure passing fancy verbosity @@ -363,66 +439,82 @@ runSetup verbosity setup args0 = do -- verbosity applies to ALL commands. verbosityHack :: Version -> [String] -> [String] verbosityHack ver args0 - | ver >= mkVersion [2,1] = args0 - | otherwise = go args0 + | ver >= mkVersion [2, 1] = args0 + | otherwise = go args0 where - go (('-':'v':rest) : args) - | Just rest' <- munch rest = ("-v" ++ rest') : go args - go (('-':'-':'v':'e':'r':'b':'o':'s':'e':'=':rest) : args) - | Just rest' <- munch rest = ("--verbose=" ++ rest') : go args + go (('-' : 'v' : rest) : args) + | Just rest' <- munch rest = ("-v" ++ rest') : go args + go (('-' : '-' : 'v' : 'e' : 'r' : 'b' : 'o' : 's' : 'e' : '=' : rest) : args) + | Just rest' <- munch rest = ("--verbose=" ++ rest') : go args go ("--verbose" : rest : args) - | Just rest' <- munch rest = "--verbose" : rest' : go args + | Just rest' <- munch rest = "--verbose" : rest' : go args go rest@("--" : _) = rest - go (arg:args) = arg : go args + go (arg : args) = arg : go args go [] = [] munch rest = - case runReadE flagToVerbosity rest of - Right v - | ver < mkVersion [2,0], verboseHasFlags v + case runReadE flagToVerbosity rest of + Right v + | ver < mkVersion [2, 0] + , verboseHasFlags v -> -- We could preserve the prefix, but since we're assuming -- it's Cabal's verbosity flag, we can assume that -- any format is OK - -> Just (showForCabal (verboseNoFlags v)) - | ver < mkVersion [2,1], isVerboseTimestamp v + Just (showForCabal (verboseNoFlags v)) + | ver < mkVersion [2, 1] + , isVerboseTimestamp v -> -- +timestamp wasn't yet available in Cabal-2.0.0 - -> Just (showForCabal (verboseNoTimestamp v)) - _ -> Nothing + Just (showForCabal (verboseNoTimestamp v)) + _ -> Nothing -- | Run a command through a configured 'Setup'. -runSetupCommand :: Verbosity -> Setup - -> CommandUI flags -- ^ command definition - -> flags -- ^ command flags - -> [String] -- ^ extra command-line arguments - -> IO () +runSetupCommand + :: Verbosity + -> Setup + -> CommandUI flags + -- ^ command definition + -> 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 -- | Configure a 'Setup' and run a command in one step. The command flags -- may depend on the Cabal library version in use. -setupWrapper :: Verbosity - -> SetupScriptOptions - -> Maybe PackageDescription - -> CommandUI flags - -> (Version -> flags) - -- ^ produce command flags given the Cabal library version - -> (Version -> [String]) - -> IO () +setupWrapper + :: Verbosity + -> SetupScriptOptions + -> Maybe PackageDescription + -> CommandUI flags + -> (Version -> flags) + -- ^ produce command flags given the Cabal library version + -> (Version -> [String]) + -> IO () setupWrapper verbosity options mpkg cmd flags extraArgs = do setup <- getSetup verbosity options mpkg - runSetupCommand verbosity setup - cmd (flags $ setupVersion setup) - (extraArgs $ setupVersion setup) + runSetupCommand + verbosity + setup + cmd + (flags $ setupVersion setup) + (extraArgs $ setupVersion setup) -- ------------------------------------------------------------ + -- * Internal SetupMethod + -- ------------------------------------------------------------ internalSetupMethod :: SetupRunner internalSetupMethod verbosity options bt args = do - info verbosity $ "Using internal setup method with build-type " ++ show bt - ++ " and args:\n " ++ show args + info verbosity $ + "Using internal setup method with build-type " + ++ show bt + ++ " and args:\n " + ++ show args inDir (useWorkingDir options) $ do withEnv "HASKELL_DIST_DIR" (useDistPref options) $ withExtraPathEnv (useExtraPathEnv options) $ @@ -430,65 +522,86 @@ internalSetupMethod verbosity options bt args = do buildTypeAction bt args buildTypeAction :: BuildType -> ([String] -> IO ()) -buildTypeAction Simple = Simple.defaultMainArgs -buildTypeAction Configure = Simple.defaultMainWithHooksArgs - Simple.autoconfUserHooks -buildTypeAction Make = Make.defaultMainArgs -buildTypeAction Custom = error "buildTypeAction Custom" +buildTypeAction Simple = Simple.defaultMainArgs +buildTypeAction Configure = + Simple.defaultMainWithHooksArgs + Simple.autoconfUserHooks +buildTypeAction Make = Make.defaultMainArgs +buildTypeAction Custom = error "buildTypeAction Custom" invoke :: Verbosity -> FilePath -> [String] -> SetupScriptOptions -> IO () invoke verbosity path args options = do info verbosity $ unwords (path : args) case useLoggingHandle options of - Nothing -> return () + Nothing -> return () Just logHandle -> info verbosity $ "Redirecting build log to " ++ show logHandle - searchpath <- programSearchPathAsPATHVar - (map ProgramSearchPathDir (useExtraPathEnv options) ++ - getProgramSearchPath (useProgramDb options)) - env <- getEffectiveEnvironment $ - [ ("PATH", Just searchpath) - , ("HASKELL_DIST_DIR", Just (useDistPref options)) - ] ++ useExtraEnvOverrides options + searchpath <- + programSearchPathAsPATHVar + ( map ProgramSearchPathDir (useExtraPathEnv options) + ++ getProgramSearchPath (useProgramDb options) + ) + env <- + getEffectiveEnvironment $ + [ ("PATH", Just searchpath) + , ("HASKELL_DIST_DIR", Just (useDistPref options)) + ] + ++ useExtraEnvOverrides options let loggingHandle = case useLoggingHandle options of - Nothing -> Inherit - Just hdl -> UseHandle hdl - cp = (proc path args) { Process.cwd = useWorkingDir options - , Process.env = env - , Process.std_out = loggingHandle - , Process.std_err = loggingHandle - , Process.delegate_ctlc = isInteractive options - } + Nothing -> Inherit + Just hdl -> UseHandle hdl + cp = + (proc path args) + { Process.cwd = useWorkingDir options + , Process.env = env + , Process.std_out = loggingHandle + , Process.std_err = loggingHandle + , Process.delegate_ctlc = isInteractive options + } maybeExit $ rawSystemProc verbosity cp -- ------------------------------------------------------------ + -- * Self-Exec SetupMethod + -- ------------------------------------------------------------ selfExecSetupMethod :: SetupRunner selfExecSetupMethod verbosity options bt args0 = do - let args = ["act-as-setup", - "--build-type=" ++ prettyShow bt, - "--"] ++ args0 - info verbosity $ "Using self-exec internal setup method with build-type " - ++ show bt ++ " and args:\n " ++ show args + let args = + [ "act-as-setup" + , "--build-type=" ++ prettyShow bt + , "--" + ] + ++ args0 + info verbosity $ + "Using self-exec internal setup method with build-type " + ++ show bt + ++ " and args:\n " + ++ show args path <- getExecutablePath invoke verbosity path args options -- ------------------------------------------------------------ + -- * External SetupMethod + -- ------------------------------------------------------------ externalSetupMethod :: WithCallStack (FilePath -> SetupRunner) externalSetupMethod path verbosity options _ args = #ifndef mingw32_HOST_OS - invoke verbosity path args options + invoke + verbosity + path + args + options #else - -- See 'Note: win32 clean hack' above. - if useWin32CleanHack options - then invokeWithWin32CleanHack path - else invoke' path + -- See 'Note: win32 clean hack' above. + if useWin32CleanHack options + then invokeWithWin32CleanHack path + else invoke' path where invoke' p = invoke verbosity p args options @@ -496,9 +609,10 @@ externalSetupMethod path verbosity options _ args = info verbosity $ "Using the Win32 clean hack." -- Recursively removes the temp dir on exit. withTempDirectory verbosity (workingDir options) "cabal-tmp" $ \tmpDir -> - bracket (moveOutOfTheWay tmpDir origPath) - (\tmpPath -> maybeRestore origPath tmpPath) - (\tmpPath -> invoke' tmpPath) + bracket + (moveOutOfTheWay tmpDir origPath) + (\tmpPath -> maybeRestore origPath tmpPath) + (\tmpPath -> invoke' tmpPath) moveOutOfTheWay tmpDir origPath = do let tmpPath = tmpDir "setup" <.> exeExtension buildPlatform @@ -511,23 +625,36 @@ externalSetupMethod path verbosity options _ args = -- 'setup clean' didn't complete, 'dist/setup' still exists. when origPathDirExists $ Win32.moveFile tmpPath origPath + #endif getExternalSetupMethod - :: Verbosity -> SetupScriptOptions -> PackageDescription -> BuildType + :: Verbosity + -> SetupScriptOptions + -> PackageDescription + -> BuildType -> IO (Version, SetupMethod, SetupScriptOptions) getExternalSetupMethod verbosity options pkg bt = do debug verbosity $ "Using external setup method with build-type " ++ show bt - debug verbosity $ "Using explicit dependencies: " - ++ show (useDependenciesExclusive options) + debug verbosity $ + "Using explicit dependencies: " + ++ show (useDependenciesExclusive options) createDirectoryIfMissingVerbose verbosity True setupDir (cabalLibVersion, mCabalLibInstalledPkgId, options') <- cabalLibVersionToUse debug verbosity $ "Using Cabal library version " ++ prettyShow cabalLibVersion - path <- if useCachedSetupExecutable - then getCachedSetupExecutable options' - cabalLibVersion mCabalLibInstalledPkgId - else compileSetupExecutable options' - cabalLibVersion mCabalLibInstalledPkgId False + path <- + if useCachedSetupExecutable + then + getCachedSetupExecutable + options' + cabalLibVersion + mCabalLibInstalledPkgId + else + compileSetupExecutable + options' + cabalLibVersion + mCabalLibInstalledPkgId + False -- Since useWorkingDir can change the relative path, the path argument must -- be turned into an absolute path. On some systems, runProcess' will take @@ -539,337 +666,431 @@ getExternalSetupMethod verbosity options pkg bt = do #ifdef mingw32_HOST_OS -- setupProgFile may not exist if we're using a cached program setupProgFile' <- canonicalizePathNoThrow setupProgFile - let win32CleanHackNeeded = (useWin32CleanHack options) - -- Skip when a cached setup script is used. - && setupProgFile' `equalFilePath` path' + let win32CleanHackNeeded = + (useWin32CleanHack options) + -- Skip when a cached setup script is used. + && setupProgFile' `equalFilePath` path' #else let win32CleanHackNeeded = False #endif - let options'' = options' { useWin32CleanHack = win32CleanHackNeeded } + let options'' = options'{useWin32CleanHack = win32CleanHackNeeded} 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 - platform = fromMaybe buildPlatform (usePlatform options) - - useCachedSetupExecutable = (bt == Simple || bt == Configure || bt == Make) - - maybeGetInstalledPackages :: SetupScriptOptions -> Compiler - -> ProgramDb -> IO InstalledPackageIndex - maybeGetInstalledPackages options' comp progdb = - case usePackageIndex options' of - Just index -> return index - Nothing -> getInstalledPackages verbosity - comp (usePackageDB options') progdb - - -- Choose the version of Cabal to use if the setup script has a dependency on - -- Cabal, and possibly update the setup script options. The version also - -- determines how to filter the flags to Setup. - -- - -- We first check whether the dependency solver has specified a Cabal version. - -- If it has, we use the solver's version without looking at the installed - -- package index (See issue #3436). Otherwise, we pick the Cabal version by - -- checking 'useCabalSpecVersion', then the saved version, and finally the - -- versions available in the index. - -- - -- The version chosen here must match the one used in 'compileSetupExecutable' - -- (See issue #3433). - cabalLibVersionToUse :: IO (Version, Maybe ComponentId - ,SetupScriptOptions) - cabalLibVersionToUse = - case find (isCabalPkgId . snd) (useDependencies options) of - Just (unitId, pkgId) -> do - let version = pkgVersion pkgId - updateSetupScript version bt - writeSetupVersionFile version - return (version, Just unitId, options) - Nothing -> - case useCabalSpecVersion options of - Just version -> do - updateSetupScript version bt - writeSetupVersionFile version - return (version, Nothing, options) - Nothing -> do - savedVer <- savedVersion - case savedVer of - Just version | version `withinRange` useCabalVersion options - -> do updateSetupScript version bt - -- Does the previously compiled setup executable - -- still exist and is it up-to date? - useExisting <- canUseExistingSetup version - if useExisting - then return (version, Nothing, options) - else installedVersion - _ -> installedVersion - where - -- This check duplicates the checks in 'getCachedSetupExecutable' / - -- 'compileSetupExecutable'. Unfortunately, we have to perform it twice - -- because the selected Cabal version may change as a result of this - -- check. - canUseExistingSetup :: Version -> IO Bool - canUseExistingSetup version = - if useCachedSetupExecutable - then do - (_, cachedSetupProgFile) <- cachedSetupDirAndProg options version - doesFileExist cachedSetupProgFile - else - (&&) <$> setupProgFile `existsAndIsMoreRecentThan` setupHs - <*> setupProgFile `existsAndIsMoreRecentThan` setupVersionFile - - writeSetupVersionFile :: Version -> IO () - writeSetupVersionFile version = + setupDir = workingDir options useDistPref options "setup" + setupVersionFile = setupDir "setup" <.> "version" + setupHs = setupDir "setup" <.> "hs" + setupProgFile = setupDir "setup" <.> exeExtension buildPlatform + platform = fromMaybe buildPlatform (usePlatform options) + + useCachedSetupExecutable = (bt == Simple || bt == Configure || bt == Make) + + maybeGetInstalledPackages + :: SetupScriptOptions + -> Compiler + -> ProgramDb + -> IO InstalledPackageIndex + maybeGetInstalledPackages options' comp progdb = + case usePackageIndex options' of + Just index -> return index + Nothing -> + getInstalledPackages + verbosity + comp + (usePackageDB options') + progdb + + -- Choose the version of Cabal to use if the setup script has a dependency on + -- Cabal, and possibly update the setup script options. The version also + -- determines how to filter the flags to Setup. + -- + -- We first check whether the dependency solver has specified a Cabal version. + -- If it has, we use the solver's version without looking at the installed + -- package index (See issue #3436). Otherwise, we pick the Cabal version by + -- checking 'useCabalSpecVersion', then the saved version, and finally the + -- versions available in the index. + -- + -- The version chosen here must match the one used in 'compileSetupExecutable' + -- (See issue #3433). + cabalLibVersionToUse + :: IO + ( Version + , Maybe ComponentId + , SetupScriptOptions + ) + cabalLibVersionToUse = + case find (isCabalPkgId . snd) (useDependencies options) of + Just (unitId, pkgId) -> do + let version = pkgVersion pkgId + updateSetupScript version bt + writeSetupVersionFile version + return (version, Just unitId, options) + Nothing -> + case useCabalSpecVersion options of + Just version -> do + updateSetupScript version bt + writeSetupVersionFile version + return (version, Nothing, options) + Nothing -> do + savedVer <- savedVersion + case savedVer of + Just version | version `withinRange` useCabalVersion options -> + do + updateSetupScript version bt + -- Does the previously compiled setup executable + -- still exist and is it up-to date? + useExisting <- canUseExistingSetup version + if useExisting + then return (version, Nothing, options) + else installedVersion + _ -> installedVersion + where + -- This check duplicates the checks in 'getCachedSetupExecutable' / + -- 'compileSetupExecutable'. Unfortunately, we have to perform it twice + -- because the selected Cabal version may change as a result of this + -- check. + canUseExistingSetup :: Version -> IO Bool + canUseExistingSetup version = + if useCachedSetupExecutable + then do + (_, cachedSetupProgFile) <- cachedSetupDirAndProg options version + doesFileExist cachedSetupProgFile + else + (&&) + <$> setupProgFile `existsAndIsMoreRecentThan` setupHs + <*> setupProgFile `existsAndIsMoreRecentThan` setupVersionFile + + writeSetupVersionFile :: Version -> IO () + writeSetupVersionFile version = writeFile setupVersionFile (show version ++ "\n") - installedVersion :: IO (Version, Maybe InstalledPackageId - ,SetupScriptOptions) - installedVersion = do - (comp, progdb, options') <- configureCompiler options - (version, mipkgid, options'') <- installedCabalVersion options' - comp progdb - updateSetupScript version bt - writeSetupVersionFile version - return (version, mipkgid, options'') - - savedVersion :: IO (Maybe Version) - savedVersion = do - versionString <- readFile setupVersionFile `catchIO` \_ -> return "" - case reads versionString of - [(version,s)] | all isSpace s -> return (Just version) - _ -> return Nothing - - -- | Update a Setup.hs script, creating it if necessary. - updateSetupScript :: Version -> BuildType -> IO () - updateSetupScript _ Custom = do - useHs <- doesFileExist customSetupHs - useLhs <- doesFileExist customSetupLhs - unless (useHs || useLhs) $ die' verbosity - "Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script." - let src = (if useHs then customSetupHs else customSetupLhs) - srcNewer <- src `moreRecentFile` setupHs - when srcNewer $ if useHs - then copyFileVerbose verbosity src setupHs - else runSimplePreProcessor ppUnlit src setupHs verbosity - where - customSetupHs = workingDir options "Setup.hs" - customSetupLhs = workingDir options "Setup.lhs" - - updateSetupScript cabalLibVersion _ = - rewriteFileLBS verbosity setupHs (buildTypeScript cabalLibVersion) - - buildTypeScript :: Version -> BS.ByteString - buildTypeScript cabalLibVersion = 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" - Make -> "import Distribution.Make; main = defaultMain\n" - Custom -> error "buildTypeScript Custom" - - installedCabalVersion :: SetupScriptOptions -> Compiler -> ProgramDb - -> IO (Version, Maybe InstalledPackageId - ,SetupScriptOptions) - installedCabalVersion options' _ _ | packageName pkg == mkPackageName "Cabal" - && bt == Custom = - return (packageVersion pkg, Nothing, options') - installedCabalVersion options' compiler progdb = do - index <- maybeGetInstalledPackages options' compiler progdb - let cabalDepName = mkPackageName "Cabal" - cabalDepVersion = useCabalVersion options' - options'' = options' { usePackageIndex = Just index } - case PackageIndex.lookupDependency index cabalDepName cabalDepVersion of - [] -> die' verbosity $ "The package '" ++ prettyShow (packageName pkg) - ++ "' requires Cabal library version " - ++ prettyShow (useCabalVersion options) - ++ " but no suitable version is installed." - pkgs -> let ipkginfo = fromMaybe err $ safeHead . snd . bestVersion fst $ pkgs - err = error "Distribution.Client.installedCabalVersion: empty version list" - in return (packageVersion ipkginfo - ,Just . IPI.installedComponentId $ ipkginfo, options'') - - bestVersion :: (a -> Version) -> [a] -> a - bestVersion f = firstMaximumBy (comparing (preference . f)) - where - -- Like maximumBy, but picks the first maximum element instead of the - -- last. In general, we expect the preferred version to go first in the - -- list. For the default case, this has the effect of choosing the version - -- installed in the user package DB instead of the global one. See #1463. - -- - -- Note: firstMaximumBy could be written as just - -- `maximumBy cmp . reverse`, but the problem is that the behaviour of - -- maximumBy is not fully specified in the case when there is not a single - -- greatest element. - firstMaximumBy :: (a -> a -> Ordering) -> [a] -> a - firstMaximumBy _ [] = - error "Distribution.Client.firstMaximumBy: empty list" - firstMaximumBy cmp xs = foldl1' maxBy xs - where - maxBy x y = case cmp x y of { GT -> x; EQ -> x; LT -> y; } - - preference version = (sameVersion, sameMajorVersion - ,stableVersion, latestVersion) - where - sameVersion = version == cabalVersion - sameMajorVersion = majorVersion version == majorVersion cabalVersion - majorVersion = take 2 . versionNumbers - stableVersion = case versionNumbers version of - (_:x:_) -> even x - _ -> False - latestVersion = version - - configureCompiler :: SetupScriptOptions - -> IO (Compiler, ProgramDb, SetupScriptOptions) - configureCompiler options' = do - (comp, progdb) <- case useCompiler options' of - Just comp -> return (comp, useProgramDb options') - Nothing -> do (comp, _, progdb) <- - configCompilerEx (Just GHC) Nothing Nothing - (useProgramDb options') verbosity - return (comp, progdb) - -- Whenever we need to call configureCompiler, we also need to access the - -- package index, so let's cache it in SetupScriptOptions. - index <- maybeGetInstalledPackages options' comp progdb - return (comp, progdb, options' { useCompiler = Just comp, - usePackageIndex = Just index, - useProgramDb = progdb }) - - -- | Path to the setup exe cache directory and path to the cached setup - -- executable. - cachedSetupDirAndProg :: SetupScriptOptions -> Version - -> IO (FilePath, FilePath) - cachedSetupDirAndProg options' cabalLibVersion = do - cacheDir <- defaultCacheDir - let setupCacheDir = cacheDir "setup-exe-cache" - cachedSetupProgFile = setupCacheDir - ("setup-" ++ buildTypeString ++ "-" - ++ cabalVersionString ++ "-" - ++ platformString ++ "-" - ++ compilerVersionString) - <.> exeExtension buildPlatform - return (setupCacheDir, cachedSetupProgFile) + installedVersion + :: IO + ( Version + , Maybe InstalledPackageId + , SetupScriptOptions + ) + installedVersion = do + (comp, progdb, options') <- configureCompiler options + (version, mipkgid, options'') <- + installedCabalVersion + options' + comp + progdb + updateSetupScript version bt + writeSetupVersionFile version + return (version, mipkgid, options'') + + savedVersion :: IO (Maybe Version) + savedVersion = do + versionString <- readFile setupVersionFile `catchIO` \_ -> return "" + case reads versionString of + [(version, s)] | all isSpace s -> return (Just version) + _ -> return Nothing + + -- \| Update a Setup.hs script, creating it if necessary. + updateSetupScript :: Version -> BuildType -> IO () + updateSetupScript _ Custom = do + useHs <- doesFileExist customSetupHs + useLhs <- doesFileExist customSetupLhs + unless (useHs || useLhs) $ + die' + verbosity + "Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script." + let src = (if useHs then customSetupHs else customSetupLhs) + srcNewer <- src `moreRecentFile` setupHs + when srcNewer $ + if useHs + then copyFileVerbose verbosity src setupHs + else runSimplePreProcessor ppUnlit src setupHs verbosity where - buildTypeString = show bt - cabalVersionString = "Cabal-" ++ prettyShow cabalLibVersion - compilerVersionString = prettyShow $ - maybe buildCompilerId compilerId - $ useCompiler options' - platformString = prettyShow platform - - -- | Look up the setup executable in the cache; update the cache if the setup - -- executable is not found. - getCachedSetupExecutable :: SetupScriptOptions - -> Version -> Maybe InstalledPackageId - -> IO FilePath - getCachedSetupExecutable options' cabalLibVersion - maybeCabalLibInstalledPkgId = do - (setupCacheDir, cachedSetupProgFile) <- - cachedSetupDirAndProg options' cabalLibVersion - cachedSetupExists <- doesFileExist cachedSetupProgFile - if cachedSetupExists - then debug verbosity $ - "Found cached setup executable: " ++ cachedSetupProgFile - else criticalSection' $ do - -- The cache may have been populated while we were waiting. - cachedSetupExists' <- doesFileExist cachedSetupProgFile - if cachedSetupExists' - then debug verbosity $ - "Found cached setup executable: " ++ cachedSetupProgFile - else do - debug verbosity $ "Setup executable not found in the cache." - src <- compileSetupExecutable options' - cabalLibVersion maybeCabalLibInstalledPkgId True - createDirectoryIfMissingVerbose verbosity True setupCacheDir - installExecutableFile verbosity src cachedSetupProgFile - -- Do not strip if we're using GHCJS, since the result may be a script - when (maybe True ((/=GHCJS).compilerFlavor) $ useCompiler options') $ - Strip.stripExe verbosity platform (useProgramDb options') - cachedSetupProgFile - return cachedSetupProgFile + customSetupHs = workingDir options "Setup.hs" + customSetupLhs = workingDir options "Setup.lhs" + updateSetupScript cabalLibVersion _ = + rewriteFileLBS verbosity setupHs (buildTypeScript cabalLibVersion) + + buildTypeScript :: Version -> BS.ByteString + buildTypeScript cabalLibVersion = 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" + Make -> "import Distribution.Make; main = defaultMain\n" + Custom -> error "buildTypeScript Custom" + + installedCabalVersion + :: SetupScriptOptions + -> Compiler + -> ProgramDb + -> IO + ( Version + , Maybe InstalledPackageId + , SetupScriptOptions + ) + installedCabalVersion options' _ _ + | packageName pkg == mkPackageName "Cabal" + && bt == Custom = + return (packageVersion pkg, Nothing, options') + installedCabalVersion options' compiler progdb = do + index <- maybeGetInstalledPackages options' compiler progdb + let cabalDepName = mkPackageName "Cabal" + cabalDepVersion = useCabalVersion options' + options'' = options'{usePackageIndex = Just index} + case PackageIndex.lookupDependency index cabalDepName cabalDepVersion of + [] -> + die' verbosity $ + "The package '" + ++ prettyShow (packageName pkg) + ++ "' requires Cabal library version " + ++ prettyShow (useCabalVersion options) + ++ " but no suitable version is installed." + pkgs -> + let ipkginfo = fromMaybe err $ safeHead . snd . bestVersion fst $ pkgs + err = error "Distribution.Client.installedCabalVersion: empty version list" + in return + ( packageVersion ipkginfo + , Just . IPI.installedComponentId $ ipkginfo + , options'' + ) + + bestVersion :: (a -> Version) -> [a] -> a + bestVersion f = firstMaximumBy (comparing (preference . f)) where - criticalSection' = maybe id criticalSection $ setupCacheLock options' - - -- | If the Setup.hs is out of date wrt the executable then recompile it. - -- Currently this is GHC/GHCJS only. It should really be generalised. - -- - compileSetupExecutable :: SetupScriptOptions - -> Version -> Maybe ComponentId -> Bool - -> IO FilePath - compileSetupExecutable options' cabalLibVersion maybeCabalLibInstalledPkgId - forceCompile = do - setupHsNewer <- setupHs `moreRecentFile` setupProgFile - cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile - let outOfDate = setupHsNewer || cabalVersionNewer - when (outOfDate || forceCompile) $ do - debug verbosity "Setup executable needs to be updated, compiling..." - (compiler, progdb, options'') <- configureCompiler options' - let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion - (program, extraOpts) - = case compilerFlavor compiler of - GHCJS -> (ghcjsProgram, ["-build-runner"]) - _ -> (ghcProgram, ["-threaded"]) - cabalDep = maybe [] (\ipkgid -> [(ipkgid, cabalPkgid)]) - maybeCabalLibInstalledPkgId - - -- With 'useDependenciesExclusive' 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. - -- - selectedDeps | useDependenciesExclusive options' - = useDependencies options' - | otherwise = useDependencies options' ++ - if any (isCabalPkgId . snd) - (useDependencies options') - then [] - else cabalDep - addRenaming (ipid, _) = - -- Assert 'DefUnitId' invariant - (Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid)) - ,defaultRenaming) - cppMacrosFile = setupDir "setup_macros.h" - ghcOptions = mempty { - -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use - -- --ghc-option=-v instead! - ghcOptVerbosity = Flag (min verbosity normal) - , ghcOptMode = Flag GhcModeMake - , ghcOptInputFiles = toNubListR [setupHs] - , ghcOptOutputFile = Flag setupProgFile - , ghcOptObjDir = Flag setupDir - , ghcOptHiDir = Flag setupDir - , ghcOptSourcePathClear = Flag True - , ghcOptSourcePath = case bt of - Custom -> toNubListR [workingDir options'] - _ -> mempty - , ghcOptPackageDBs = usePackageDB options'' - , ghcOptHideAllPackages = Flag (useDependenciesExclusive options') - , ghcOptCabal = Flag (useDependenciesExclusive options') - , ghcOptPackages = toNubListR $ map addRenaming selectedDeps - , ghcOptCppIncludes = toNubListR [ cppMacrosFile - | useVersionMacros options' ] - , ghcOptExtra = extraOpts + -- Like maximumBy, but picks the first maximum element instead of the + -- last. In general, we expect the preferred version to go first in the + -- list. For the default case, this has the effect of choosing the version + -- installed in the user package DB instead of the global one. See #1463. + -- + -- Note: firstMaximumBy could be written as just + -- `maximumBy cmp . reverse`, but the problem is that the behaviour of + -- maximumBy is not fully specified in the case when there is not a single + -- greatest element. + firstMaximumBy :: (a -> a -> Ordering) -> [a] -> a + firstMaximumBy _ [] = + error "Distribution.Client.firstMaximumBy: empty list" + firstMaximumBy cmp xs = foldl1' maxBy xs + where + maxBy x y = case cmp x y of GT -> x; EQ -> x; LT -> y + + preference version = + ( sameVersion + , sameMajorVersion + , stableVersion + , latestVersion + ) + where + sameVersion = version == cabalVersion + sameMajorVersion = majorVersion version == majorVersion cabalVersion + majorVersion = take 2 . versionNumbers + stableVersion = case versionNumbers version of + (_ : x : _) -> even x + _ -> False + latestVersion = version + + configureCompiler + :: SetupScriptOptions + -> IO (Compiler, ProgramDb, SetupScriptOptions) + configureCompiler options' = do + (comp, progdb) <- case useCompiler options' of + Just comp -> return (comp, useProgramDb options') + Nothing -> do + (comp, _, progdb) <- + configCompilerEx + (Just GHC) + Nothing + Nothing + (useProgramDb options') + verbosity + return (comp, progdb) + -- Whenever we need to call configureCompiler, we also need to access the + -- package index, so let's cache it in SetupScriptOptions. + index <- maybeGetInstalledPackages options' comp progdb + return + ( comp + , progdb + , options' + { useCompiler = Just comp + , usePackageIndex = Just index + , useProgramDb = progdb } - let ghcCmdLine = renderGhcOptions compiler platform ghcOptions - when (useVersionMacros options') $ - rewriteFileEx verbosity cppMacrosFile - $ generatePackageVersionMacros (pkgVersion $ package pkg) (map snd selectedDeps) - case useLoggingHandle options of - Nothing -> runDbProgram verbosity program progdb ghcCmdLine - - -- If build logging is enabled, redirect compiler output to - -- the log file. - (Just logHandle) -> do output <- getDbProgramOutput verbosity program - progdb ghcCmdLine - hPutStr logHandle output - return setupProgFile - + ) + + -- \| Path to the setup exe cache directory and path to the cached setup + -- executable. + cachedSetupDirAndProg + :: SetupScriptOptions + -> Version + -> IO (FilePath, FilePath) + cachedSetupDirAndProg options' cabalLibVersion = do + cacheDir <- defaultCacheDir + let setupCacheDir = cacheDir "setup-exe-cache" + cachedSetupProgFile = + setupCacheDir + ( "setup-" + ++ buildTypeString + ++ "-" + ++ cabalVersionString + ++ "-" + ++ platformString + ++ "-" + ++ compilerVersionString + ) + <.> exeExtension buildPlatform + return (setupCacheDir, cachedSetupProgFile) + where + buildTypeString = show bt + cabalVersionString = "Cabal-" ++ prettyShow cabalLibVersion + compilerVersionString = + prettyShow $ + maybe buildCompilerId compilerId $ + useCompiler options' + platformString = prettyShow platform + + -- \| Look up the setup executable in the cache; update the cache if the setup + -- executable is not found. + getCachedSetupExecutable + :: SetupScriptOptions + -> Version + -> Maybe InstalledPackageId + -> IO FilePath + getCachedSetupExecutable + options' + cabalLibVersion + maybeCabalLibInstalledPkgId = do + (setupCacheDir, cachedSetupProgFile) <- + cachedSetupDirAndProg options' cabalLibVersion + cachedSetupExists <- doesFileExist cachedSetupProgFile + if cachedSetupExists + then + debug verbosity $ + "Found cached setup executable: " ++ cachedSetupProgFile + else criticalSection' $ do + -- The cache may have been populated while we were waiting. + cachedSetupExists' <- doesFileExist cachedSetupProgFile + if cachedSetupExists' + then + debug verbosity $ + "Found cached setup executable: " ++ cachedSetupProgFile + else do + debug verbosity $ "Setup executable not found in the cache." + src <- + compileSetupExecutable + options' + cabalLibVersion + maybeCabalLibInstalledPkgId + True + createDirectoryIfMissingVerbose verbosity True setupCacheDir + installExecutableFile verbosity src cachedSetupProgFile + -- Do not strip if we're using GHCJS, since the result may be a script + when (maybe True ((/= GHCJS) . compilerFlavor) $ useCompiler options') $ + Strip.stripExe + verbosity + platform + (useProgramDb options') + cachedSetupProgFile + return cachedSetupProgFile + where + criticalSection' = maybe id criticalSection $ setupCacheLock options' + + -- \| If the Setup.hs is out of date wrt the executable then recompile it. + -- Currently this is GHC/GHCJS only. It should really be generalised. + compileSetupExecutable + :: SetupScriptOptions + -> Version + -> Maybe ComponentId + -> Bool + -> IO FilePath + compileSetupExecutable + options' + cabalLibVersion + maybeCabalLibInstalledPkgId + forceCompile = do + setupHsNewer <- setupHs `moreRecentFile` setupProgFile + cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile + let outOfDate = setupHsNewer || cabalVersionNewer + when (outOfDate || forceCompile) $ do + debug verbosity "Setup executable needs to be updated, compiling..." + (compiler, progdb, options'') <- configureCompiler options' + let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion + (program, extraOpts) = + case compilerFlavor compiler of + GHCJS -> (ghcjsProgram, ["-build-runner"]) + _ -> (ghcProgram, ["-threaded"]) + cabalDep = + maybe + [] + (\ipkgid -> [(ipkgid, cabalPkgid)]) + maybeCabalLibInstalledPkgId + + -- With 'useDependenciesExclusive' 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. + -- + selectedDeps + | useDependenciesExclusive options' = + useDependencies options' + | otherwise = + useDependencies options' + ++ if any + (isCabalPkgId . snd) + (useDependencies options') + then [] + else cabalDep + addRenaming (ipid, _) = + -- Assert 'DefUnitId' invariant + ( Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid)) + , defaultRenaming + ) + cppMacrosFile = setupDir "setup_macros.h" + ghcOptions = + mempty + { -- Respect -v0, but don't crank up verbosity on GHC if + -- Cabal verbosity is requested. For that, use + -- --ghc-option=-v instead! + ghcOptVerbosity = Flag (min verbosity normal) + , ghcOptMode = Flag GhcModeMake + , ghcOptInputFiles = toNubListR [setupHs] + , ghcOptOutputFile = Flag setupProgFile + , ghcOptObjDir = Flag setupDir + , ghcOptHiDir = Flag setupDir + , ghcOptSourcePathClear = Flag True + , ghcOptSourcePath = case bt of + Custom -> toNubListR [workingDir options'] + _ -> mempty + , ghcOptPackageDBs = usePackageDB options'' + , ghcOptHideAllPackages = Flag (useDependenciesExclusive options') + , ghcOptCabal = Flag (useDependenciesExclusive options') + , ghcOptPackages = toNubListR $ map addRenaming selectedDeps + , ghcOptCppIncludes = + toNubListR + [ cppMacrosFile + | useVersionMacros options' + ] + , ghcOptExtra = extraOpts + } + let ghcCmdLine = renderGhcOptions compiler platform ghcOptions + when (useVersionMacros options') $ + rewriteFileEx verbosity cppMacrosFile $ + generatePackageVersionMacros (pkgVersion $ package pkg) (map snd selectedDeps) + case useLoggingHandle options of + Nothing -> runDbProgram verbosity program progdb ghcCmdLine + -- If build logging is enabled, redirect compiler output to + -- the log file. + (Just logHandle) -> do + output <- + getDbProgramOutput + verbosity + program + progdb + ghcCmdLine + hPutStr logHandle output + return setupProgFile isCabalPkgId :: PackageIdentifier -> Bool isCabalPkgId (PackageIdentifier pname _) = pname == mkPackageName "Cabal" diff --git a/cabal-install/src/Distribution/Client/Signal.hs b/cabal-install/src/Distribution/Client/Signal.hs index 726fd8cbcc3..c009d805cd4 100644 --- a/cabal-install/src/Distribution/Client/Signal.hs +++ b/cabal-install/src/Distribution/Client/Signal.hs @@ -1,7 +1,8 @@ {-# LANGUAGE CPP #-} + module Distribution.Client.Signal ( installTerminationHandler - , Terminated(..) + , Terminated (..) ) where @@ -30,7 +31,6 @@ instance Show Terminated where -- called from the main thread. -- -- It is a noop on Windows. --- installTerminationHandler :: IO () #ifdef mingw32_HOST_OS diff --git a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs index 02ac3973218..f4422080a4b 100644 --- a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs +++ b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs @@ -1,7 +1,11 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} + ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.SolverInstallPlan -- Copyright : (c) Duncan Coutts 2008 @@ -16,74 +20,78 @@ -- things are going to be installed. To put it another way: the -- dependency solver produces a 'SolverInstallPlan', which is then -- consumed by various other parts of Cabal. --- ------------------------------------------------------------------------------ -module Distribution.Client.SolverInstallPlan( - SolverInstallPlan(..), - SolverPlanPackage, - ResolverPackage(..), - - -- * Operations on 'SolverInstallPlan's - new, - toList, - toMap, - - remove, - - showPlanIndex, - showInstallPlan, - - -- * Checking validity of plans - valid, - closed, - consistent, - acyclic, - - -- ** Details on invalid plans - SolverPlanProblem(..), - showPlanProblem, - problems, - - -- ** Querying the install plan - dependencyClosure, - reverseDependencyClosure, - topologicalOrder, - reverseTopologicalOrder, -) where +module Distribution.Client.SolverInstallPlan + ( SolverInstallPlan (..) + , SolverPlanPackage + , ResolverPackage (..) + + -- * Operations on 'SolverInstallPlan's + , new + , toList + , toMap + , remove + , showPlanIndex + , showInstallPlan + + -- * Checking validity of plans + , valid + , closed + , consistent + , acyclic + + -- ** Details on invalid plans + , SolverPlanProblem (..) + , showPlanProblem + , problems + + -- ** Querying the install plan + , dependencyClosure + , reverseDependencyClosure + , topologicalOrder + , reverseTopologicalOrder + ) where import Distribution.Client.Compat.Prelude hiding (toList) import Prelude () import Distribution.Package - ( PackageIdentifier(..), Package(..), PackageName - , HasUnitId(..), PackageId, packageVersion, packageName ) -import Distribution.Types.Flag (nullFlagAssignment) + ( HasUnitId (..) + , Package (..) + , PackageId + , PackageIdentifier (..) + , PackageName + , packageName + , packageVersion + ) import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Types.Flag (nullFlagAssignment) import Distribution.Client.Types - ( UnresolvedPkgLoc ) + ( UnresolvedPkgLoc + ) import Distribution.Version - ( Version ) + ( Version + ) -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.ResolverPackage -import Distribution.Solver.Types.SolverId -import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.ResolverPackage +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.SolverPackage -import Distribution.Compat.Graph (Graph, IsNode(..)) +import Data.Array ((!)) import qualified Data.Foldable as Foldable import qualified Data.Graph as OldGraph -import qualified Distribution.Compat.Graph as Graph import qualified Data.Map as Map -import Data.Array ((!)) +import Distribution.Compat.Graph (Graph, IsNode (..)) +import qualified Distribution.Compat.Graph as Graph type SolverPlanPackage = ResolverPackage UnresolvedPkgLoc type SolverPlanIndex = Graph SolverPlanPackage -data SolverInstallPlan = SolverInstallPlan { - planIndex :: !SolverPlanIndex, - planIndepGoals :: !IndependentGoals +data SolverInstallPlan = SolverInstallPlan + { planIndex :: !SolverPlanIndex + , planIndepGoals :: !IndependentGoals } deriving (Typeable, Generic) @@ -99,8 +107,6 @@ planPkgOf plan v = Nothing -> error "InstallPlan: internal error: planPkgOf lookup failed" -} - - instance Binary SolverInstallPlan instance Structured SolverInstallPlan @@ -111,33 +117,38 @@ showInstallPlan :: SolverInstallPlan -> String showInstallPlan = showPlanIndex . toList showPlanPackage :: SolverPlanPackage -> String -showPlanPackage (PreExisting ipkg) = "PreExisting " ++ prettyShow (packageId ipkg) - ++ " (" ++ prettyShow (installedUnitId ipkg) - ++ ")" -showPlanPackage (Configured spkg) = - "Configured " ++ prettyShow (packageId spkg) ++ flags ++ comps +showPlanPackage (PreExisting ipkg) = + "PreExisting " + ++ prettyShow (packageId ipkg) + ++ " (" + ++ prettyShow (installedUnitId ipkg) + ++ ")" +showPlanPackage (Configured spkg) = + "Configured " ++ prettyShow (packageId spkg) ++ flags ++ comps where flags - | nullFlagAssignment fa = "" - | otherwise = " " ++ prettyShow (solverPkgFlags spkg) + | nullFlagAssignment fa = "" + | otherwise = " " ++ prettyShow (solverPkgFlags spkg) where fa = solverPkgFlags spkg - comps | null deps = "" - | otherwise = " " ++ unwords (map prettyShow $ Foldable.toList deps) + comps + | null deps = "" + | otherwise = " " ++ unwords (map prettyShow $ Foldable.toList deps) where deps :: Set CD.Component - deps = CD.components (solverPkgLibDeps spkg) - <> CD.components (solverPkgExeDeps spkg) + deps = + CD.components (solverPkgLibDeps spkg) + <> CD.components (solverPkgExeDeps spkg) -- | Build an installation plan from a valid set of resolved packages. --- -new :: IndependentGoals - -> SolverPlanIndex - -> Either [SolverPlanProblem] SolverInstallPlan +new + :: IndependentGoals + -> SolverPlanIndex + -> Either [SolverPlanProblem] SolverInstallPlan new indepGoals index = case problems indepGoals index of - [] -> Right (SolverInstallPlan index indepGoals) + [] -> Right (SolverInstallPlan index indepGoals) probs -> Left probs toList :: SolverInstallPlan -> [SolverPlanPackage] @@ -151,19 +162,23 @@ toMap = Graph.toMap . planIndex -- package. This is primarily useful for obtaining an install plan for -- the dependencies of a package or set of packages without actually -- installing the package itself, as when doing development. --- -remove :: (SolverPlanPackage -> Bool) - -> SolverInstallPlan - -> Either [SolverPlanProblem] - (SolverInstallPlan) +remove + :: (SolverPlanPackage -> Bool) + -> SolverInstallPlan + -> Either + [SolverPlanProblem] + (SolverInstallPlan) remove shouldRemove plan = - new (planIndepGoals plan) newIndex + new (planIndepGoals plan) newIndex where - newIndex = Graph.fromDistinctList $ - filter (not . shouldRemove) (toList plan) + newIndex = + Graph.fromDistinctList $ + filter (not . shouldRemove) (toList plan) -- ------------------------------------------------------------ + -- * Checking validity of plans + -- ------------------------------------------------------------ -- | A valid installation plan is a set of packages that is 'acyclic', @@ -171,76 +186,87 @@ remove shouldRemove plan = -- plan has to have a valid configuration (see 'configuredPackageValid'). -- -- * if the result is @False@ use 'problems' to get a detailed list. --- -valid :: IndependentGoals - -> SolverPlanIndex - -> Bool +valid + :: IndependentGoals + -> SolverPlanIndex + -> Bool valid indepGoals index = - null $ problems indepGoals index + null $ problems indepGoals index -data SolverPlanProblem = - PackageMissingDeps SolverPlanPackage - [PackageIdentifier] - | PackageCycle [SolverPlanPackage] - | PackageInconsistency PackageName [(PackageIdentifier, Version)] - | PackageStateInvalid SolverPlanPackage SolverPlanPackage +data SolverPlanProblem + = PackageMissingDeps + SolverPlanPackage + [PackageIdentifier] + | PackageCycle [SolverPlanPackage] + | PackageInconsistency PackageName [(PackageIdentifier, Version)] + | PackageStateInvalid SolverPlanPackage SolverPlanPackage showPlanProblem :: SolverPlanProblem -> String showPlanProblem (PackageMissingDeps pkg missingDeps) = - "Package " ++ prettyShow (packageId pkg) - ++ " depends on the following packages which are missing from the plan: " - ++ intercalate ", " (map prettyShow missingDeps) - + "Package " + ++ prettyShow (packageId pkg) + ++ " depends on the following packages which are missing from the plan: " + ++ intercalate ", " (map prettyShow missingDeps) showPlanProblem (PackageCycle cycleGroup) = - "The following packages are involved in a dependency cycle " - ++ intercalate ", " (map (prettyShow.packageId) cycleGroup) - + "The following packages are involved in a dependency cycle " + ++ intercalate ", " (map (prettyShow . packageId) cycleGroup) showPlanProblem (PackageInconsistency name inconsistencies) = - "Package " ++ prettyShow name - ++ " is required by several packages," - ++ " but they require inconsistent versions:\n" - ++ unlines [ " package " ++ prettyShow pkg ++ " requires " - ++ prettyShow (PackageIdentifier name ver) - | (pkg, ver) <- inconsistencies ] - + "Package " + ++ prettyShow name + ++ " is required by several packages," + ++ " but they require inconsistent versions:\n" + ++ unlines + [ " package " + ++ prettyShow pkg + ++ " requires " + ++ prettyShow (PackageIdentifier name ver) + | (pkg, ver) <- inconsistencies + ] showPlanProblem (PackageStateInvalid pkg pkg') = - "Package " ++ prettyShow (packageId pkg) - ++ " is in the " ++ showPlanState pkg - ++ " state but it depends on package " ++ prettyShow (packageId pkg') - ++ " which is in the " ++ showPlanState pkg' - ++ " state" + "Package " + ++ prettyShow (packageId pkg) + ++ " is in the " + ++ showPlanState pkg + ++ " state but it depends on package " + ++ prettyShow (packageId pkg') + ++ " which is in the " + ++ showPlanState pkg' + ++ " state" where showPlanState (PreExisting _) = "pre-existing" - showPlanState (Configured _) = "configured" + showPlanState (Configured _) = "configured" -- | For an invalid plan, produce a detailed list of problems as human readable -- error messages. This is mainly intended for debugging purposes. -- Use 'showPlanProblem' for a human readable explanation. --- -problems :: IndependentGoals - -> SolverPlanIndex - -> [SolverPlanProblem] +problems + :: IndependentGoals + -> SolverPlanIndex + -> [SolverPlanProblem] problems indepGoals index = - - [ PackageMissingDeps pkg - (mapMaybe - (fmap packageId . flip Graph.lookup index) - missingDeps) - | (pkg, missingDeps) <- Graph.broken index ] - - ++ [ PackageCycle cycleGroup - | cycleGroup <- Graph.cycles index ] - - ++ [ PackageInconsistency name inconsistencies - | (name, inconsistencies) <- - dependencyInconsistencies indepGoals index ] - - ++ [ PackageStateInvalid pkg pkg' - | pkg <- Foldable.toList index - , Just pkg' <- map (flip Graph.lookup index) - (nodeNeighbors pkg) - , not (stateDependencyRelation pkg pkg') ] - + [ PackageMissingDeps + pkg + ( mapMaybe + (fmap packageId . flip Graph.lookup index) + missingDeps + ) + | (pkg, missingDeps) <- Graph.broken index + ] + ++ [ PackageCycle cycleGroup + | cycleGroup <- Graph.cycles index + ] + ++ [ PackageInconsistency name inconsistencies + | (name, inconsistencies) <- + dependencyInconsistencies indepGoals index + ] + ++ [ PackageStateInvalid pkg pkg' + | pkg <- Foldable.toList index + , Just pkg' <- + map + (flip Graph.lookup index) + (nodeNeighbors pkg) + , not (stateDependencyRelation pkg pkg') + ] -- | Compute all roots of the install plan, and verify that the transitive -- plans from those roots are all consistent. @@ -249,16 +275,19 @@ problems indepGoals index = -- may be absent from the subplans even if the larger plan contains a dependency -- cycle. Such cycles may or may not be an issue; either way, we don't check -- for them here. -dependencyInconsistencies :: IndependentGoals - -> SolverPlanIndex - -> [(PackageName, [(PackageIdentifier, Version)])] -dependencyInconsistencies indepGoals index = - concatMap dependencyInconsistencies' subplans +dependencyInconsistencies + :: IndependentGoals + -> SolverPlanIndex + -> [(PackageName, [(PackageIdentifier, Version)])] +dependencyInconsistencies indepGoals index = + concatMap dependencyInconsistencies' subplans where subplans :: [SolverPlanIndex] - subplans = -- Not Graph.closure!! - map (nonSetupClosure index) - (rootSets indepGoals index) + subplans = + -- Not Graph.closure!! + map + (nonSetupClosure index) + (rootSets indepGoals index) -- NB: When we check for inconsistencies, packages from the setup -- scripts don't count as part of the closure (this way, we @@ -267,22 +296,24 @@ dependencyInconsistencies indepGoals index = -- -- This is a best effort function that swallows any non-existent -- SolverIds. -nonSetupClosure :: SolverPlanIndex - -> [SolverId] - -> SolverPlanIndex +nonSetupClosure + :: SolverPlanIndex + -> [SolverId] + -> SolverPlanIndex nonSetupClosure index pkgids0 = closure Graph.empty pkgids0 - where + where closure :: Graph SolverPlanPackage -> [SolverId] -> SolverPlanIndex - closure completed [] = completed - closure completed (pkgid:pkgids) = + closure completed [] = completed + closure completed (pkgid : pkgids) = case Graph.lookup pkgid index of - Nothing -> closure completed pkgids - Just pkg -> + Nothing -> closure completed pkgids + Just pkg -> case Graph.lookup (nodeKey pkg) completed of - Just _ -> closure completed pkgids + Just _ -> closure completed pkgids Nothing -> closure completed' pkgids' - where completed' = Graph.insert pkg completed - pkgids' = CD.nonSetupDeps (resolverPackageLibDeps pkg) ++ pkgids + where + completed' = Graph.insert pkg completed + pkgids' = CD.nonSetupDeps (resolverPackageLibDeps pkg) ++ pkgids -- | Compute the root sets of a plan -- @@ -292,8 +323,11 @@ nonSetupClosure index pkgids0 = closure Graph.empty pkgids0 -- with all setup dependencies of all packages. rootSets :: IndependentGoals -> SolverPlanIndex -> [[SolverId]] rootSets (IndependentGoals indepGoals) index = - if indepGoals then map (:[]) libRoots else [libRoots] - ++ setupRoots index + if indepGoals + then map (: []) libRoots + else + [libRoots] + ++ setupRoots index where libRoots :: [SolverId] libRoots = libraryRoots index @@ -304,18 +338,19 @@ rootSets (IndependentGoals indepGoals) index = -- (no reverse library dependencies but also no reverse setup dependencies). libraryRoots :: SolverPlanIndex -> [SolverId] libraryRoots index = - map (nodeKey . toPkgId) roots + map (nodeKey . toPkgId) roots where (graph, toPkgId, _) = Graph.toGraph index indegree = OldGraph.indegree graph - roots = filter isRoot (OldGraph.vertices graph) + roots = filter isRoot (OldGraph.vertices graph) isRoot v = indegree ! v == 0 -- | The setup dependencies of each package in the plan setupRoots :: SolverPlanIndex -> [[SolverId]] -setupRoots = filter (not . null) - . map (CD.setupDeps . resolverPackageLibDeps) - . Foldable.toList +setupRoots = + filter (not . null) + . map (CD.setupDeps . resolverPackageLibDeps) + . Foldable.toList -- | Given a package index where we assume we want to use all the packages -- (use 'dependencyClosure' if you need to get such a index subset) find out @@ -326,30 +361,32 @@ setupRoots = filter (not . null) -- Each element in the result is a package name along with the packages that -- depend on it and the versions they require. These are guaranteed to be -- distinct. --- -dependencyInconsistencies' :: SolverPlanIndex - -> [(PackageName, [(PackageIdentifier, Version)])] +dependencyInconsistencies' + :: SolverPlanIndex + -> [(PackageName, [(PackageIdentifier, Version)])] dependencyInconsistencies' index = - [ (name, [ (pid, packageVersion dep) | (dep,pids) <- uses, pid <- pids]) - | (name, ipid_map) <- Map.toList inverseIndex - , let uses = Map.elems ipid_map - , reallyIsInconsistent (map fst uses) - ] + [ (name, [(pid, packageVersion dep) | (dep, pids) <- uses, pid <- pids]) + | (name, ipid_map) <- Map.toList inverseIndex + , let uses = Map.elems ipid_map + , reallyIsInconsistent (map fst uses) + ] where -- For each package name (of a dependency, somewhere) -- and each installed ID of that package -- the associated package instance -- and a list of reverse dependencies (as source IDs) inverseIndex :: Map PackageName (Map SolverId (SolverPlanPackage, [PackageId])) - inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b'))) - [ (packageName dep, Map.fromList [(sid,(dep,[packageId pkg]))]) - | -- For each package @pkg@ + inverseIndex = + Map.fromListWith + (Map.unionWith (\(a, b) (_, b') -> (a, b ++ b'))) + [ (packageName dep, Map.fromList [(sid, (dep, [packageId pkg]))]) + | -- For each package @pkg@ pkg <- Foldable.toList index - -- Find out which @sid@ @pkg@ depends on - , sid <- CD.nonSetupDeps (resolverPackageLibDeps pkg) - -- And look up those @sid@ (i.e., @sid@ is the ID of @dep@) - , Just dep <- [Graph.lookup sid index] - ] + , -- Find out which @sid@ @pkg@ depends on + sid <- CD.nonSetupDeps (resolverPackageLibDeps pkg) + , -- And look up those @sid@ (i.e., @sid@ is the ID of @dep@) + Just dep <- [Graph.lookup sid index] + ] -- If, in a single install plan, we depend on more than one version of a -- package, then this is ONLY okay in the (rather special) case that we @@ -357,21 +394,19 @@ dependencyInconsistencies' index = -- depends on the other. This is necessary for example for the base where -- we have base-3 depending on base-4. reallyIsInconsistent :: [SolverPlanPackage] -> Bool - reallyIsInconsistent [] = False - reallyIsInconsistent [_p] = False + reallyIsInconsistent [] = False + reallyIsInconsistent [_p] = False reallyIsInconsistent [p1, p2] = let pid1 = nodeKey p1 pid2 = nodeKey p2 - in pid1 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p2) - && pid2 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p1) + in pid1 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p2) + && pid2 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p1) reallyIsInconsistent _ = True - -- | The graph of packages (nodes) and dependencies (edges) must be acyclic. -- -- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out -- which packages are involved in dependency cycles. --- acyclic :: SolverPlanIndex -> Bool acyclic = null . Graph.cycles @@ -381,7 +416,6 @@ acyclic = null . Graph.cycles -- -- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out -- which packages depend on packages not in the index. --- closed :: SolverPlanIndex -> Bool closed = null . Graph.broken @@ -400,44 +434,40 @@ closed = null . Graph.broken -- -- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to -- find out which packages are. --- consistent :: SolverPlanIndex -> Bool consistent = null . dependencyInconsistencies (IndependentGoals False) -- | The states of packages have that depend on each other must respect -- this relation. That is for very case where package @a@ depends on -- package @b@ we require that @dependencyStatesOk a b = True@. --- -stateDependencyRelation :: SolverPlanPackage - -> SolverPlanPackage - -> Bool -stateDependencyRelation PreExisting{} PreExisting{} = True - -stateDependencyRelation (Configured _) PreExisting{} = True -stateDependencyRelation (Configured _) (Configured _) = True - -stateDependencyRelation _ _ = False - +stateDependencyRelation + :: SolverPlanPackage + -> SolverPlanPackage + -> Bool +stateDependencyRelation PreExisting{} PreExisting{} = True +stateDependencyRelation (Configured _) PreExisting{} = True +stateDependencyRelation (Configured _) (Configured _) = True +stateDependencyRelation _ _ = False -- | Compute the dependency closure of a package in a install plan --- -dependencyClosure :: SolverInstallPlan - -> [SolverId] - -> [SolverPlanPackage] +dependencyClosure + :: SolverInstallPlan + -> [SolverId] + -> [SolverPlanPackage] dependencyClosure plan = fromMaybe [] . Graph.closure (planIndex plan) - -reverseDependencyClosure :: SolverInstallPlan - -> [SolverId] - -> [SolverPlanPackage] +reverseDependencyClosure + :: SolverInstallPlan + -> [SolverId] + -> [SolverPlanPackage] reverseDependencyClosure plan = fromMaybe [] . Graph.revClosure (planIndex plan) - -topologicalOrder :: SolverInstallPlan - -> [SolverPlanPackage] +topologicalOrder + :: SolverInstallPlan + -> [SolverPlanPackage] topologicalOrder plan = Graph.topSort (planIndex plan) - -reverseTopologicalOrder :: SolverInstallPlan - -> [SolverPlanPackage] +reverseTopologicalOrder + :: SolverInstallPlan + -> [SolverPlanPackage] reverseTopologicalOrder plan = Graph.revTopSort (planIndex plan) diff --git a/cabal-install/src/Distribution/Client/SourceFiles.hs b/cabal-install/src/Distribution/Client/SourceFiles.hs index 669f30a35b9..ddff8dad99f 100644 --- a/cabal-install/src/Distribution/Client/SourceFiles.hs +++ b/cabal-install/src/Distribution/Client/SourceFiles.hs @@ -22,36 +22,36 @@ import Distribution.Solver.Types.OptionalStanza import Distribution.Simple.Glob (matchDirFileGlobWithDie) import Distribution.Simple.PreProcess -import Distribution.Types.PackageDescription +import Distribution.Types.Benchmark +import Distribution.Types.BenchmarkInterface +import Distribution.Types.BuildInfo import Distribution.Types.Component import Distribution.Types.ComponentRequestedSpec (ComponentRequestedSpec) -import Distribution.Types.Library import Distribution.Types.Executable -import Distribution.Types.Benchmark -import Distribution.Types.BenchmarkInterface +import Distribution.Types.ForeignLib +import Distribution.Types.Library +import Distribution.Types.PackageDescription import Distribution.Types.TestSuite import Distribution.Types.TestSuiteInterface -import Distribution.Types.BuildInfo -import Distribution.Types.ForeignLib import Distribution.Utils.Path import Distribution.ModuleName -import Prelude () import Distribution.Client.Compat.Prelude import Distribution.Verbosity (normal) +import Prelude () import System.FilePath needElaboratedConfiguredPackage :: ElaboratedConfiguredPackage -> Rebuild () needElaboratedConfiguredPackage elab = - case elabPkgOrComp elab of - ElabComponent ecomp -> needElaboratedComponent elab ecomp - ElabPackage epkg -> needElaboratedPackage elab epkg + case elabPkgOrComp elab of + ElabComponent ecomp -> needElaboratedComponent elab ecomp + ElabPackage epkg -> needElaboratedPackage elab epkg needElaboratedPackage :: ElaboratedConfiguredPackage -> ElaboratedPackage -> Rebuild () needElaboratedPackage elab epkg = - traverse_ (needComponent pkg_descr) (enabledComponents pkg_descr enabled) + traverse_ (needComponent pkg_descr) (enabledComponents pkg_descr enabled) where pkg_descr :: PackageDescription pkg_descr = elabPkgDescription elab @@ -62,116 +62,137 @@ needElaboratedPackage elab epkg = needElaboratedComponent :: ElaboratedConfiguredPackage -> ElaboratedComponent -> Rebuild () needElaboratedComponent elab ecomp = - case mb_comp of - Nothing -> needSetup - Just comp -> needComponent pkg_descr comp + case mb_comp of + Nothing -> needSetup + Just comp -> needComponent pkg_descr comp where pkg_descr :: PackageDescription pkg_descr = elabPkgDescription elab - mb_comp :: Maybe Component - mb_comp = fmap (getComponent pkg_descr) (compComponentName ecomp) + mb_comp :: Maybe Component + mb_comp = fmap (getComponent pkg_descr) (compComponentName ecomp) needComponent :: PackageDescription -> Component -> Rebuild () needComponent pkg_descr comp = - case comp of - CLib lib -> needLibrary pkg_descr lib - CFLib flib -> needForeignLib pkg_descr flib - CExe exe -> needExecutable pkg_descr exe - CTest test -> needTestSuite pkg_descr test - CBench bench -> needBenchmark pkg_descr bench + case comp of + CLib lib -> needLibrary pkg_descr lib + CFLib flib -> needForeignLib pkg_descr flib + CExe exe -> needExecutable pkg_descr exe + CTest test -> needTestSuite pkg_descr test + CBench bench -> needBenchmark pkg_descr bench needSetup :: Rebuild () needSetup = findFirstFileMonitored id ["Setup.hs", "Setup.lhs"] >> return () needLibrary :: PackageDescription -> Library -> Rebuild () -needLibrary pkg_descr (Library { exposedModules = modules - , signatures = sigs - , libBuildInfo = bi }) - = needBuildInfo pkg_descr bi (modules ++ sigs) +needLibrary + pkg_descr + ( Library + { exposedModules = modules + , signatures = sigs + , libBuildInfo = bi + } + ) = + needBuildInfo pkg_descr bi (modules ++ sigs) needForeignLib :: PackageDescription -> ForeignLib -> Rebuild () -needForeignLib pkg_descr (ForeignLib { foreignLibModDefFile = fs - , foreignLibBuildInfo = bi }) - = do traverse_ needIfExists fs - needBuildInfo pkg_descr bi [] +needForeignLib + pkg_descr + ( ForeignLib + { foreignLibModDefFile = fs + , foreignLibBuildInfo = bi + } + ) = + do + traverse_ needIfExists fs + needBuildInfo pkg_descr bi [] needExecutable :: PackageDescription -> Executable -> Rebuild () -needExecutable pkg_descr (Executable { modulePath = mainPath - , buildInfo = bi }) - = do needBuildInfo pkg_descr bi [] - needMainFile bi mainPath +needExecutable + pkg_descr + ( Executable + { modulePath = mainPath + , buildInfo = bi + } + ) = + do + needBuildInfo pkg_descr bi [] + needMainFile bi mainPath needTestSuite :: PackageDescription -> TestSuite -> Rebuild () -needTestSuite pkg_descr t - = case testInterface t of - TestSuiteExeV10 _ mainPath -> do - needBuildInfo pkg_descr bi [] - needMainFile bi mainPath - TestSuiteLibV09 _ m -> - needBuildInfo pkg_descr bi [m] - TestSuiteUnsupported _ -> return () -- soft fail - where - bi :: BuildInfo - bi = testBuildInfo t +needTestSuite pkg_descr t = + case testInterface t of + TestSuiteExeV10 _ mainPath -> do + needBuildInfo pkg_descr bi [] + needMainFile bi mainPath + TestSuiteLibV09 _ m -> + needBuildInfo pkg_descr bi [m] + TestSuiteUnsupported _ -> return () -- soft fail + where + bi :: BuildInfo + bi = testBuildInfo t needMainFile :: BuildInfo -> FilePath -> Rebuild () needMainFile bi mainPath = do - -- The matter here is subtle. It might *seem* that we - -- should just search for mainPath, but as per - -- b61cb051f63ed5869b8f4a6af996ff7e833e4b39 'main-is' - -- will actually be the source file AFTER preprocessing, - -- whereas we need to get the file *prior* to preprocessing. - ppFile <- findFileWithExtensionMonitored - (ppSuffixes knownSuffixHandlers) - (map getSymbolicPath (hsSourceDirs bi)) - (dropExtension mainPath) - case ppFile of - -- But check the original path in the end, because - -- maybe it's a non-preprocessed file with a non-traditional - -- extension. - Nothing -> findFileMonitored (map getSymbolicPath (hsSourceDirs bi)) mainPath - >>= maybe (return ()) need - Just pp -> need pp + -- The matter here is subtle. It might *seem* that we + -- should just search for mainPath, but as per + -- b61cb051f63ed5869b8f4a6af996ff7e833e4b39 'main-is' + -- will actually be the source file AFTER preprocessing, + -- whereas we need to get the file *prior* to preprocessing. + ppFile <- + findFileWithExtensionMonitored + (ppSuffixes knownSuffixHandlers) + (map getSymbolicPath (hsSourceDirs bi)) + (dropExtension mainPath) + case ppFile of + -- But check the original path in the end, because + -- maybe it's a non-preprocessed file with a non-traditional + -- extension. + Nothing -> + findFileMonitored (map getSymbolicPath (hsSourceDirs bi)) mainPath + >>= maybe (return ()) need + Just pp -> need pp needBenchmark :: PackageDescription -> Benchmark -> Rebuild () -needBenchmark pkg_descr bm - = case benchmarkInterface bm of - BenchmarkExeV10 _ mainPath -> do - needBuildInfo pkg_descr bi [] - needMainFile bi mainPath - BenchmarkUnsupported _ -> return () -- soft fail - where - bi :: BuildInfo - bi = benchmarkBuildInfo bm +needBenchmark pkg_descr bm = + case benchmarkInterface bm of + BenchmarkExeV10 _ mainPath -> do + needBuildInfo pkg_descr bi [] + needMainFile bi mainPath + BenchmarkUnsupported _ -> return () -- soft fail + where + bi :: BuildInfo + bi = benchmarkBuildInfo bm needBuildInfo :: PackageDescription -> BuildInfo -> [ModuleName] -> Rebuild () needBuildInfo pkg_descr bi modules = do - -- NB: These are separate because there may be both A.hs and - -- A.hs-boot; need to track both. - findNeededModules ["hs", "lhs", "hsig", "lhsig"] - findNeededModules ["hs-boot", "lhs-boot"] - root <- askRoot - expandedExtraSrcFiles <- liftIO $ fmap concat . for (extraSrcFiles pkg_descr) $ \fpath -> matchDirFileGlobWithDie normal (\ _ _ -> return []) (specVersion pkg_descr) root fpath - traverse_ needIfExists $ concat - [ cSources bi - , cxxSources bi - , jsSources bi - , cmmSources bi - , asmSources bi - , expandedExtraSrcFiles - ] - for_ (installIncludes bi) $ \f -> - findFileMonitored ("." : includeDirs bi) f - >>= maybe (return ()) need + -- NB: These are separate because there may be both A.hs and + -- A.hs-boot; need to track both. + findNeededModules ["hs", "lhs", "hsig", "lhsig"] + findNeededModules ["hs-boot", "lhs-boot"] + root <- askRoot + expandedExtraSrcFiles <- liftIO $ fmap concat . for (extraSrcFiles pkg_descr) $ \fpath -> matchDirFileGlobWithDie normal (\_ _ -> return []) (specVersion pkg_descr) root fpath + traverse_ needIfExists $ + concat + [ cSources bi + , cxxSources bi + , jsSources bi + , cmmSources bi + , asmSources bi + , expandedExtraSrcFiles + ] + for_ (installIncludes bi) $ \f -> + findFileMonitored ("." : includeDirs bi) f + >>= maybe (return ()) need where findNeededModules :: [String] -> Rebuild () - findNeededModules exts = traverse_ + findNeededModules exts = + traverse_ (findNeededModule exts) (modules ++ otherModules bi) findNeededModule :: [String] -> ModuleName -> Rebuild () findNeededModule exts m = - findFileWithExtensionMonitored - (ppSuffixes knownSuffixHandlers ++ exts) - (map getSymbolicPath (hsSourceDirs bi)) - (toFilePath m) - >>= maybe (return ()) need + findFileWithExtensionMonitored + (ppSuffixes knownSuffixHandlers ++ exts) + (map getSymbolicPath (hsSourceDirs bi)) + (toFilePath m) + >>= maybe (return ()) need diff --git a/cabal-install/src/Distribution/Client/SrcDist.hs b/cabal-install/src/Distribution/Client/SrcDist.hs index b418733c645..72a740bc7c0 100644 --- a/cabal-install/src/Distribution/Client/SrcDist.hs +++ b/cabal-install/src/Distribution/Client/SrcDist.hs @@ -1,40 +1,40 @@ {-# LANGUAGE OverloadedStrings #-} + -- | Utilities to implement cabal @v2-sdist@. -module Distribution.Client.SrcDist ( - allPackageSourceFiles, - packageDirToSdist, -) where +module Distribution.Client.SrcDist + ( allPackageSourceFiles + , packageDirToSdist + ) where import Distribution.Client.Compat.Prelude import Prelude () -import Control.Monad.State.Lazy (StateT, evalStateT, gets, modify) -import Control.Monad.Trans (liftIO) +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 System.FilePath (normalise, takeDirectory, ()) -import Distribution.Client.Utils (tryFindAddSourcePackageDesc) -import Distribution.Package (Package (packageId)) +import Distribution.Client.Utils (tryFindAddSourcePackageDesc) +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 (die') -import Distribution.Types.GenericPackageDescription (GenericPackageDescription) +import Distribution.Simple.PackageDescription (readGenericPackageDescription) +import Distribution.Simple.PreProcess (knownSuffixHandlers) +import Distribution.Simple.SrcDist (listPackageSourcesWithDie) +import Distribution.Simple.Utils (die') +import Distribution.Types.GenericPackageDescription (GenericPackageDescription) -import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar -import qualified Codec.Compression.GZip as GZip -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL -import qualified Data.Set as Set +import qualified Codec.Compression.GZip as GZip +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Set as Set -- | 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). -- -- Used in sandbox and projectbuilding. -- TODO: when sandboxes are removed, move to ProjectBuilding. --- allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath] allPackageSourceFiles verbosity packageDir = do pd <- do @@ -46,52 +46,56 @@ allPackageSourceFiles verbosity packageDir = do -- | Create a tarball for a package in a directory packageDirToSdist - :: Verbosity - -> GenericPackageDescription -- ^ read in GPD - -> FilePath -- ^ directory containing that GPD - -> IO BSL.ByteString -- ^ resulting sdist tarball + :: Verbosity + -> GenericPackageDescription + -- ^ read in GPD + -> FilePath + -- ^ directory containing that GPD + -> IO BSL.ByteString + -- ^ resulting sdist tarball packageDirToSdist verbosity gpd dir = do - let thisDie :: Verbosity -> String -> IO a - thisDie v s = die' v $ "sdist of " <> prettyShow (packageId gpd) ++ ": " ++ s + let thisDie :: Verbosity -> String -> IO a + thisDie v s = die' v $ "sdist of " <> prettyShow (packageId gpd) ++ ": " ++ s - files' <- listPackageSourcesWithDie verbosity thisDie dir (flattenPackageDescription gpd) knownSuffixHandlers - let files :: [FilePath] - files = nub $ sort $ map normalise files' + files' <- listPackageSourcesWithDie verbosity thisDie dir (flattenPackageDescription gpd) knownSuffixHandlers + let files :: [FilePath] + files = nub $ sort $ map normalise files' - let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) () - entriesM = do - let prefix = prettyShow (packageId gpd) - modify (Set.insert prefix) - case Tar.toTarPath True prefix of - Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) - Right path -> tell [Tar.directoryEntry path] + let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) () + entriesM = do + let prefix = prettyShow (packageId gpd) + modify (Set.insert prefix) + case Tar.toTarPath True prefix of + Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) + Right path -> tell [Tar.directoryEntry path] - for_ files $ \file -> do - let fileDir = takeDirectory (prefix file) - needsEntry <- gets (Set.notMember fileDir) + for_ files $ \file -> do + let fileDir = takeDirectory (prefix file) + needsEntry <- gets (Set.notMember fileDir) - when needsEntry $ do - modify (Set.insert fileDir) - case Tar.toTarPath True fileDir of - Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) - Right path -> tell [Tar.directoryEntry path] + when needsEntry $ do + modify (Set.insert fileDir) + case Tar.toTarPath True fileDir of + Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) + Right path -> tell [Tar.directoryEntry path] - contents <- liftIO . fmap BSL.fromStrict . BS.readFile $ dir file - case Tar.toTarPath False (prefix file) of - Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) - Right path -> tell [(Tar.fileEntry path contents) { Tar.entryPermissions = Tar.ordinaryFilePermissions }] + contents <- liftIO . fmap BSL.fromStrict . BS.readFile $ dir file + case Tar.toTarPath False (prefix file) of + Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) + Right path -> tell [(Tar.fileEntry path contents){Tar.entryPermissions = Tar.ordinaryFilePermissions}] - entries <- execWriterT (evalStateT entriesM mempty) - let -- Pretend our GZip file is made on Unix. - normalize bs = BSL.concat [pfx, "\x03", rest'] - where - (pfx, rest) = BSL.splitAt 9 bs - rest' = BSL.tail rest - -- The Unix epoch, which is the default value, is - -- unsuitable because it causes unpacking problems on - -- Windows; we need a post-1980 date. One gigasecond - -- after the epoch is during 2001-09-09, so that does - -- nicely. See #5596. - setModTime :: Tar.Entry -> Tar.Entry - setModTime entry = entry { Tar.entryTime = 1000000000 } - return . normalize . GZip.compress . Tar.write $ fmap setModTime entries + entries <- execWriterT (evalStateT entriesM mempty) + let + -- Pretend our GZip file is made on Unix. + normalize bs = BSL.concat [pfx, "\x03", rest'] + where + (pfx, rest) = BSL.splitAt 9 bs + rest' = BSL.tail rest + -- The Unix epoch, which is the default value, is + -- unsuitable because it causes unpacking problems on + -- Windows; we need a post-1980 date. One gigasecond + -- after the epoch is during 2001-09-09, so that does + -- nicely. See #5596. + setModTime :: Tar.Entry -> Tar.Entry + setModTime entry = entry{Tar.entryTime = 1000000000} + return . normalize . GZip.compress . Tar.write $ fmap setModTime entries diff --git a/cabal-install/src/Distribution/Client/Store.hs b/cabal-install/src/Distribution/Client/Store.hs index d78fb3dcc92..d678e137090 100644 --- a/cabal-install/src/Distribution/Client/Store.hs +++ b/cabal-install/src/Distribution/Client/Store.hs @@ -1,44 +1,47 @@ -{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns #-} - +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} -- | Management for the installed package store. --- -module Distribution.Client.Store ( - - -- * The store layout - StoreDirLayout(..), - defaultStoreDirLayout, +module Distribution.Client.Store + ( -- * The store layout + StoreDirLayout (..) + , defaultStoreDirLayout -- * Reading store entries - getStoreEntries, - doesStoreEntryExist, + , getStoreEntries + , doesStoreEntryExist -- * Creating store entries - newStoreEntry, - NewStoreEntryOutcome(..), + , newStoreEntry + , NewStoreEntryOutcome (..) -- * Concurrency strategy -- $concurrency ) where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () -import Distribution.Client.DistDirLayout -import Distribution.Client.RebuildMonad +import Distribution.Client.DistDirLayout +import Distribution.Client.RebuildMonad -import Distribution.Package (UnitId, mkUnitId) -import Distribution.Compiler (CompilerId) +import Distribution.Compiler (CompilerId) +import Distribution.Package (UnitId, mkUnitId) -import Distribution.Simple.Utils - ( withTempDirectory, debug, info ) -import Distribution.Verbosity - ( silent ) +import Distribution.Simple.Utils + ( debug + , info + , withTempDirectory + ) +import Distribution.Verbosity + ( silent + ) +import Control.Exception import qualified Data.Set as Set -import Control.Exception -import System.FilePath -import System.Directory +import System.Directory +import System.FilePath #ifdef MIN_VERSION_lukko import Lukko @@ -125,37 +128,33 @@ import GHC.IO.Handle.Lock (hUnlock) -- for cabal. It does mean however that the package db update should be insert -- or replace, i.e. not failing if the db entry already exists. - -- | Check if a particular 'UnitId' exists in the store. --- doesStoreEntryExist :: StoreDirLayout -> CompilerId -> UnitId -> IO Bool doesStoreEntryExist StoreDirLayout{storePackageDirectory} compid unitid = - doesDirectoryExist (storePackageDirectory compid unitid) - + doesDirectoryExist (storePackageDirectory compid unitid) -- | Return the 'UnitId's of all packages\/components already installed in the -- store. --- getStoreEntries :: StoreDirLayout -> CompilerId -> Rebuild (Set UnitId) getStoreEntries StoreDirLayout{storeDirectory} compid = do - paths <- getDirectoryContentsMonitored (storeDirectory compid) - return $! mkEntries paths + paths <- getDirectoryContentsMonitored (storeDirectory compid) + return $! mkEntries paths where - mkEntries = Set.delete (mkUnitId "package.db") - . Set.delete (mkUnitId "incoming") - . Set.fromList - . map mkUnitId - . filter valid - valid ('.':_) = False - valid _ = True - + mkEntries = + Set.delete (mkUnitId "package.db") + . Set.delete (mkUnitId "incoming") + . Set.fromList + . map mkUnitId + . filter valid + valid ('.' : _) = False + valid _ = True -- | The outcome of 'newStoreEntry': either the store entry was newly created -- or it existed already. The latter case happens if there was a race between -- two builds of the same store entry. --- -data NewStoreEntryOutcome = UseNewStoreEntry - | UseExistingStoreEntry +data NewStoreEntryOutcome + = UseNewStoreEntry + | UseExistingStoreEntry deriving (Eq, Show) -- | Place a new entry into the store. See the concurrency strategy description @@ -172,42 +171,46 @@ data NewStoreEntryOutcome = UseNewStoreEntry -- /must/ check the 'NewStoreEntryOutcome' and if it's'UseExistingStoreEntry' -- then you must read the existing registration information (unless your -- registration information is constructed fully deterministically). --- -newStoreEntry :: Verbosity - -> StoreDirLayout - -> CompilerId - -> UnitId - -> (FilePath -> IO (FilePath, [FilePath])) -- ^ Action to place files. - -> IO () -- ^ Register action, if necessary. - -> IO NewStoreEntryOutcome -newStoreEntry verbosity storeDirLayout@StoreDirLayout{..} - compid unitid - copyFiles register = +newStoreEntry + :: Verbosity + -> StoreDirLayout + -> CompilerId + -> UnitId + -> (FilePath -> IO (FilePath, [FilePath])) + -- ^ Action to place files. + -> IO () + -- ^ Register action, if necessary. + -> IO NewStoreEntryOutcome +newStoreEntry + verbosity + storeDirLayout@StoreDirLayout{..} + compid + unitid + copyFiles + register = -- See $concurrency above for an explanation of the concurrency protocol withTempIncomingDir storeDirLayout compid $ \incomingTmpDir -> do - -- Write all store entry files within the temp dir and return the prefix. (incomingEntryDir, otherFiles) <- copyFiles incomingTmpDir -- Take a lock named after the 'UnitId' in question. withIncomingUnitIdLock verbosity storeDirLayout compid unitid $ do - -- Check for the existence of the final store entry directory. exists <- doesStoreEntryExist storeDirLayout compid unitid if exists - -- If the entry exists then we lost the race and we must abandon, + then -- If the entry exists then we lost the race and we must abandon, -- unlock and re-use the existing store entry. - then do + do info verbosity $ - "Concurrent build race: abandoning build in favour of existing " - ++ "store entry " ++ prettyShow compid prettyShow unitid + "Concurrent build race: abandoning build in favour of existing " + ++ "store entry " + ++ prettyShow compid + prettyShow unitid return UseExistingStoreEntry - - -- If the entry does not exist then we won the race and can proceed. - else do - + else -- If the entry does not exist then we won the race and can proceed. + do -- Register the package into the package db (if appropriate). register @@ -221,26 +224,35 @@ newStoreEntry verbosity storeDirLayout@StoreDirLayout{..} debug verbosity $ "Installed store entry " ++ prettyShow compid prettyShow unitid return UseNewStoreEntry - where - finalEntryDir = storePackageDirectory compid unitid - - -withTempIncomingDir :: StoreDirLayout -> CompilerId - -> (FilePath -> IO a) -> IO a + where + finalEntryDir = storePackageDirectory compid unitid + +withTempIncomingDir + :: StoreDirLayout + -> CompilerId + -> (FilePath -> IO a) + -> IO a withTempIncomingDir StoreDirLayout{storeIncomingDirectory} compid action = do - createDirectoryIfMissing True incomingDir - withTempDirectory silent incomingDir "new" action + createDirectoryIfMissing True incomingDir + withTempDirectory silent incomingDir "new" action where incomingDir = storeIncomingDirectory compid - -withIncomingUnitIdLock :: Verbosity -> StoreDirLayout - -> CompilerId -> UnitId - -> IO a -> IO a -withIncomingUnitIdLock verbosity StoreDirLayout{storeIncomingLock} - compid unitid action = +withIncomingUnitIdLock + :: Verbosity + -> StoreDirLayout + -> CompilerId + -> UnitId + -> IO a + -> IO a +withIncomingUnitIdLock + verbosity + StoreDirLayout{storeIncomingLock} + compid + unitid + action = bracket takeLock releaseLock (\_hnd -> action) - where + where #ifdef MIN_VERSION_lukko takeLock | fileLockingSupported = do diff --git a/cabal-install/src/Distribution/Client/Tar.hs b/cabal-install/src/Distribution/Client/Tar.hs index d59dcf8160a..313821a6b1a 100644 --- a/cabal-install/src/Distribution/Client/Tar.hs +++ b/cabal-install/src/Distribution/Client/Tar.hs @@ -1,6 +1,10 @@ {-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.Tar -- Copyright : (c) 2007 Bjorn Bringert, @@ -12,65 +16,75 @@ -- Portability : portable -- -- Reading, writing and manipulating \"@.tar@\" archive files. --- ------------------------------------------------------------------------------ -module Distribution.Client.Tar ( - -- * @tar.gz@ operations - createTarGzFile, - extractTarGzFile, - - -- * Other local utils - buildTreeRefTypeCode, - buildTreeSnapshotTypeCode, - isBuildTreeRefTypeCode, - filterEntries, - filterEntriesM, - entriesToList, +module Distribution.Client.Tar + ( -- * @tar.gz@ operations + createTarGzFile + , extractTarGzFile + + -- * Other local utils + , buildTreeRefTypeCode + , buildTreeSnapshotTypeCode + , isBuildTreeRefTypeCode + , filterEntries + , filterEntriesM + , entriesToList ) where import Distribution.Client.Compat.Prelude import Prelude () -import qualified Data.ByteString.Lazy as BS -import qualified Codec.Archive.Tar as Tar -import qualified Codec.Archive.Tar.Entry as Tar +import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Check as Tar -import qualified Codec.Compression.GZip as GZip +import qualified Codec.Archive.Tar.Entry as Tar +import qualified Codec.Compression.GZip as GZip +import qualified Data.ByteString.Lazy as BS import qualified Distribution.Client.GZipUtils as GZipUtils -- for foldEntries... import Control.Exception (throw) -- + -- * High level operations + -- -createTarGzFile :: FilePath -- ^ Full Tarball path - -> FilePath -- ^ Base directory - -> FilePath -- ^ Directory to archive, relative to base dir - -> IO () +createTarGzFile + :: FilePath + -- ^ Full Tarball path + -> FilePath + -- ^ Base directory + -> FilePath + -- ^ Directory to archive, relative to base dir + -> IO () createTarGzFile tar base dir = BS.writeFile tar . GZip.compress . Tar.write =<< Tar.pack base [dir] -extractTarGzFile :: FilePath -- ^ Destination directory - -> FilePath -- ^ Expected subdir (to check for tarbombs) - -> FilePath -- ^ Tarball - -> IO () +extractTarGzFile + :: FilePath + -- ^ Destination directory + -> FilePath + -- ^ Expected subdir (to check for tarbombs) + -> FilePath + -- ^ Tarball + -> IO () extractTarGzFile dir expected tar = - Tar.unpack dir . Tar.checkTarbomb expected . Tar.read - . GZipUtils.maybeDecompress =<< BS.readFile tar + Tar.unpack dir + . Tar.checkTarbomb expected + . Tar.read + . GZipUtils.maybeDecompress + =<< BS.readFile tar instance (Exception a, Exception b) => Exception (Either a b) where - toException (Left e) = toException e + toException (Left e) = toException e toException (Right e) = toException e fromException e = case fromException e of Just e' -> Just (Left e') Nothing -> case fromException e of - Just e' -> Just (Right e') - Nothing -> Nothing - + Just e' -> Just (Right e') + Nothing -> Nothing -- | Type code for the local build tree reference entry type. We don't use the -- symbolic link entry type because it allows only 100 ASCII characters for the @@ -85,9 +99,11 @@ buildTreeSnapshotTypeCode = 'S' -- | Is this a type code for a build tree reference? isBuildTreeRefTypeCode :: Tar.TypeCode -> Bool isBuildTreeRefTypeCode typeCode - | (typeCode == buildTreeRefTypeCode - || typeCode == buildTreeSnapshotTypeCode) = True - | otherwise = False + | ( typeCode == buildTreeRefTypeCode + || typeCode == buildTreeSnapshotTypeCode + ) = + True + | otherwise = False filterEntries :: (Tar.Entry -> Bool) -> Tar.Entries e -> Tar.Entries e filterEntries p = @@ -96,19 +112,22 @@ filterEntries p = Tar.Done Tar.Fail -filterEntriesM :: Monad m => (Tar.Entry -> m Bool) - -> Tar.Entries e -> m (Tar.Entries e) +filterEntriesM + :: Monad m + => (Tar.Entry -> m Bool) + -> Tar.Entries e + -> m (Tar.Entries e) filterEntriesM p = Tar.foldEntries - (\entry rest -> do - keep <- p entry - xs <- rest - if keep - then return (Tar.Next entry xs) - else return xs) + ( \entry rest -> do + keep <- p entry + xs <- rest + if keep + then return (Tar.Next entry xs) + else return xs + ) (return Tar.Done) (return . Tar.Fail) entriesToList :: Exception e => Tar.Entries e -> [Tar.Entry] entriesToList = Tar.foldEntries (:) [] throw - diff --git a/cabal-install/src/Distribution/Client/TargetProblem.hs b/cabal-install/src/Distribution/Client/TargetProblem.hs index 14004d50abd..680250273c0 100644 --- a/cabal-install/src/Distribution/Client/TargetProblem.hs +++ b/cabal-install/src/Distribution/Client/TargetProblem.hs @@ -1,52 +1,53 @@ {-# LANGUAGE DeriveFunctor #-} -module Distribution.Client.TargetProblem ( - TargetProblem(..), - TargetProblem', -) where + +module Distribution.Client.TargetProblem + ( TargetProblem (..) + , TargetProblem' + ) where import Distribution.Client.Compat.Prelude import Prelude () -import Distribution.Client.ProjectPlanning (AvailableTarget) -import Distribution.Client.TargetSelector (SubComponentTarget, TargetSelector) -import Distribution.Package (PackageId, PackageName) -import Distribution.Simple.LocalBuildInfo (ComponentName (..)) +import Distribution.Client.ProjectPlanning (AvailableTarget) +import Distribution.Client.TargetSelector (SubComponentTarget, TargetSelector) +import Distribution.Package (PackageId, PackageName) +import Distribution.Simple.LocalBuildInfo (ComponentName (..)) import Distribution.Types.UnqualComponentName (UnqualComponentName) -- | Target problems that occur during project orchestration. data TargetProblem a - = TargetNotInProject PackageName - | TargetAvailableInIndex PackageName - - | TargetComponentNotProjectLocal - PackageId ComponentName SubComponentTarget - - | TargetComponentNotBuildable - PackageId ComponentName SubComponentTarget - - | TargetOptionalStanzaDisabledByUser - PackageId ComponentName SubComponentTarget - - | TargetOptionalStanzaDisabledBySolver - PackageId ComponentName SubComponentTarget - - | TargetProblemUnknownComponent - PackageName (Either UnqualComponentName ComponentName) - - | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] - -- ^ The 'TargetSelector' matches component (test/benchmark/...) but none are buildable - - | TargetProblemNoTargets TargetSelector - -- ^ There are no targets at all - - -- The target matching stuff only returns packages local to the project, + = TargetNotInProject PackageName + | TargetAvailableInIndex PackageName + | TargetComponentNotProjectLocal + PackageId + ComponentName + SubComponentTarget + | TargetComponentNotBuildable + PackageId + ComponentName + SubComponentTarget + | TargetOptionalStanzaDisabledByUser + PackageId + ComponentName + SubComponentTarget + | TargetOptionalStanzaDisabledBySolver + PackageId + ComponentName + SubComponentTarget + | TargetProblemUnknownComponent + PackageName + (Either UnqualComponentName ComponentName) + | -- | The 'TargetSelector' matches component (test/benchmark/...) but none are buildable + TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] + | -- | There are no targets at all + TargetProblemNoTargets TargetSelector + | -- The target matching stuff only returns packages local to the project, -- so these lookups should never fail, but if 'resolveTargets' is called -- directly then of course it can. - | TargetProblemNoSuchPackage PackageId - | TargetProblemNoSuchComponent PackageId ComponentName - - -- | A custom target problem - | CustomTargetProblem a + TargetProblemNoSuchPackage PackageId + | TargetProblemNoSuchComponent PackageId ComponentName + | -- | A custom target problem + CustomTargetProblem a deriving (Eq, Show, Functor) -- | Type alias for a 'TargetProblem' with no user-defined problems/errors. diff --git a/cabal-install/src/Distribution/Client/TargetSelector.hs b/cabal-install/src/Distribution/Client/TargetSelector.hs index 498d53a7e0d..342a8f09d2e 100644 --- a/cabal-install/src/Distribution/Client/TargetSelector.hs +++ b/cabal-install/src/Distribution/Client/TargetSelector.hs @@ -1,10 +1,16 @@ -{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor, - RecordWildCards, NamedFieldPuns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} - -- TODO {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.TargetSelector -- Copyright : (c) Duncan Coutts 2012, 2015, 2016 @@ -13,96 +19,145 @@ -- Maintainer : duncan@community.haskell.org -- -- Handling for user-specified target selectors. --- ------------------------------------------------------------------------------ -module Distribution.Client.TargetSelector ( - - -- * Target selectors - TargetSelector(..), - TargetImplicitCwd(..), - ComponentKind(..), - ComponentKindFilter, - SubComponentTarget(..), - QualLevel(..), - componentKind, +module Distribution.Client.TargetSelector + ( -- * Target selectors + TargetSelector (..) + , TargetImplicitCwd (..) + , ComponentKind (..) + , ComponentKindFilter + , SubComponentTarget (..) + , QualLevel (..) + , componentKind -- * Reading target selectors - readTargetSelectors, - TargetSelectorProblem(..), - reportTargetSelectorProblems, - showTargetSelector, - TargetString(..), - showTargetString, - parseTargetString, + , readTargetSelectors + , TargetSelectorProblem (..) + , reportTargetSelectorProblems + , showTargetSelector + , TargetString (..) + , showTargetString + , parseTargetString + -- ** non-IO - readTargetSelectorsWith, - DirActions(..), - defaultDirActions, + , readTargetSelectorsWith + , DirActions (..) + , defaultDirActions ) where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () +import Distribution.Client.Types + ( PackageLocation (..) + , PackageSpecifier (..) + ) import Distribution.Package - ( Package(..), PackageId, PackageName, packageName ) + ( Package (..) + , PackageId + , PackageName + , packageName + ) import Distribution.Types.UnqualComponentName - ( UnqualComponentName, mkUnqualComponentName, unUnqualComponentName - , packageNameToUnqualComponentName ) -import Distribution.Client.Types - ( PackageLocation(..), PackageSpecifier(..) ) + ( UnqualComponentName + , mkUnqualComponentName + , packageNameToUnqualComponentName + , unUnqualComponentName + ) +import Distribution.ModuleName + ( ModuleName + , toFilePath + ) import Distribution.PackageDescription - ( PackageDescription - , Executable(..) - , TestSuite(..), TestSuiteInterface(..), testModules - , Benchmark(..), BenchmarkInterface(..), benchmarkModules - , BuildInfo(..), explicitLibModules, exeModules ) + ( Benchmark (..) + , BenchmarkInterface (..) + , BuildInfo (..) + , Executable (..) + , PackageDescription + , TestSuite (..) + , TestSuiteInterface (..) + , benchmarkModules + , exeModules + , explicitLibModules + , testModules + ) import Distribution.PackageDescription.Configuration - ( flattenPackageDescription ) -import Distribution.Solver.Types.SourcePackage - ( SourcePackage(..) ) -import Distribution.ModuleName - ( ModuleName, toFilePath ) + ( flattenPackageDescription + ) import Distribution.Simple.LocalBuildInfo - ( Component(..), ComponentName(..), LibraryName(..) - , pkgComponents, componentName, componentBuildInfo ) + ( Component (..) + , ComponentName (..) + , LibraryName (..) + , componentBuildInfo + , componentName + , pkgComponents + ) +import Distribution.Solver.Types.SourcePackage + ( SourcePackage (..) + ) import Distribution.Types.ForeignLib -import Distribution.Simple.Utils - ( die', lowercase, ordNub ) import Distribution.Client.Utils - ( makeRelativeCanonical ) + ( makeRelativeCanonical + ) +import Distribution.Simple.Utils + ( die' + , lowercase + , ordNub + ) +import Control.Arrow ((&&&)) +import Control.Monad hiding + ( mfilter + ) import Data.List - ( stripPrefix, groupBy ) + ( groupBy + , stripPrefix + ) import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Lazy as Map.Lazy +import qualified Data.Map.Lazy as Map.Lazy import qualified Data.Map.Strict as Map import qualified Data.Set as Set -import Control.Arrow ((&&&)) -import Control.Monad - hiding ( mfilter ) -import qualified Distribution.Deprecated.ReadP as Parse -import Distribution.Deprecated.ReadP - ( (+++), (<++) ) import Distribution.Deprecated.ParseUtils - ( readPToMaybe ) -import System.FilePath as FilePath - ( takeExtension, dropExtension - , splitDirectories, joinPath, splitPath ) + ( readPToMaybe + ) +import Distribution.Deprecated.ReadP + ( (+++) + , (<++) + ) +import qualified Distribution.Deprecated.ReadP as Parse +import Distribution.Utils.Path import qualified System.Directory as IO - ( doesFileExist, doesDirectoryExist, canonicalizePath - , getCurrentDirectory ) + ( canonicalizePath + , doesDirectoryExist + , doesFileExist + , getCurrentDirectory + ) import System.FilePath - ( (), (<.>), normalise, dropTrailingPathSeparator, equalFilePath ) + ( dropTrailingPathSeparator + , equalFilePath + , normalise + , (<.>) + , () + ) +import System.FilePath as FilePath + ( dropExtension + , joinPath + , splitDirectories + , splitPath + , takeExtension + ) import Text.EditDistance - ( defaultEditCosts, restrictedDamerauLevenshteinDistance ) -import Distribution.Utils.Path + ( defaultEditCosts + , restrictedDamerauLevenshteinDistance + ) import qualified Prelude (foldr1) -- ------------------------------------------------------------ + -- * Target selector terms + -- ------------------------------------------------------------ -- | A target selector is expression selecting a set of components (as targets @@ -124,46 +179,35 @@ import qualified Prelude (foldr1) -- > [ package name | package dir | package .cabal file ] -- > [ [lib:|exe:] component name ] -- > [ module name | source file ] --- -data TargetSelector = - - -- | One (or more) packages as a whole, or all the components of a - -- particular kind within the package(s). - -- - -- These are always packages that are local to the project. In the case - -- that there is more than one, they all share the same directory location. - -- - TargetPackage TargetImplicitCwd [PackageId] (Maybe ComponentKindFilter) - - -- | A package specified by name. This may refer to @extra-packages@ from - -- the @cabal.project@ file, or a dependency of a known project package or - -- could refer to a package from a hackage archive. It needs further - -- context to resolve to a specific package. - -- - | TargetPackageNamed PackageName (Maybe ComponentKindFilter) - - -- | All packages, or all components of a particular kind in all packages. - -- - | TargetAllPackages (Maybe ComponentKindFilter) - - -- | A specific component in a package within the project. - -- - | TargetComponent PackageId ComponentName SubComponentTarget - - -- | A component in a package, but where it cannot be verified that the - -- package has such a component, or because the package is itself not - -- known. - -- - | TargetComponentUnknown PackageName - (Either UnqualComponentName ComponentName) - SubComponentTarget +data TargetSelector + = -- | One (or more) packages as a whole, or all the components of a + -- particular kind within the package(s). + -- + -- These are always packages that are local to the project. In the case + -- that there is more than one, they all share the same directory location. + TargetPackage TargetImplicitCwd [PackageId] (Maybe ComponentKindFilter) + | -- | A package specified by name. This may refer to @extra-packages@ from + -- the @cabal.project@ file, or a dependency of a known project package or + -- could refer to a package from a hackage archive. It needs further + -- context to resolve to a specific package. + TargetPackageNamed PackageName (Maybe ComponentKindFilter) + | -- | All packages, or all components of a particular kind in all packages. + TargetAllPackages (Maybe ComponentKindFilter) + | -- | A specific component in a package within the project. + TargetComponent PackageId ComponentName SubComponentTarget + | -- | A component in a package, but where it cannot be verified that the + -- package has such a component, or because the package is itself not + -- known. + TargetComponentUnknown + PackageName + (Either UnqualComponentName ComponentName) + SubComponentTarget deriving (Eq, Ord, Show, Generic) -- | Does this 'TargetPackage' selector arise from syntax referring to a -- package in the current directory (e.g. @tests@ or no giving no explicit -- target at all) or does it come from syntax referring to a package name -- or location. --- data TargetImplicitCwd = TargetImplicitCwd | TargetExplicitNamed deriving (Eq, Ord, Show, Generic) @@ -174,84 +218,82 @@ type ComponentKindFilter = ComponentKind -- | Either the component as a whole or detail about a file or module target -- within a component. --- -data SubComponentTarget = - - -- | The component as a whole - WholeComponent - - -- | A specific module within a component. - | ModuleTarget ModuleName - - -- | A specific file within a component. Note that this does not carry the - -- file extension. - | FileTarget FilePath +data SubComponentTarget + = -- | The component as a whole + WholeComponent + | -- | A specific module within a component. + ModuleTarget ModuleName + | -- | A specific file within a component. Note that this does not carry the + -- file extension. + FileTarget FilePath deriving (Eq, Ord, Show, Generic) instance Binary SubComponentTarget instance Structured SubComponentTarget - -- ------------------------------------------------------------ + -- * Top level, do everything --- ------------------------------------------------------------ +-- ------------------------------------------------------------ -- | Parse a bunch of command line args as 'TargetSelector's, failing with an -- error if any are unrecognised. The possible target selectors are based on -- the available packages (and their locations). --- -readTargetSelectors :: [PackageSpecifier (SourcePackage (PackageLocation a))] - -> Maybe ComponentKindFilter - -- ^ This parameter is used when there are ambiguous selectors. - -- If it is 'Just', then we attempt to resolve ambiguity - -- by applying it, since otherwise there is no way to allow - -- contextually valid yet syntactically ambiguous selectors. - -- (#4676, #5461) - -> [String] - -> IO (Either [TargetSelectorProblem] [TargetSelector]) +readTargetSelectors + :: [PackageSpecifier (SourcePackage (PackageLocation a))] + -> Maybe ComponentKindFilter + -- ^ This parameter is used when there are ambiguous selectors. + -- If it is 'Just', then we attempt to resolve ambiguity + -- by applying it, since otherwise there is no way to allow + -- contextually valid yet syntactically ambiguous selectors. + -- (#4676, #5461) + -> [String] + -> IO (Either [TargetSelectorProblem] [TargetSelector]) readTargetSelectors = readTargetSelectorsWith defaultDirActions -readTargetSelectorsWith :: (Applicative m, Monad m) => DirActions m - -> [PackageSpecifier (SourcePackage (PackageLocation a))] - -> Maybe ComponentKindFilter - -> [String] - -> m (Either [TargetSelectorProblem] [TargetSelector]) +readTargetSelectorsWith + :: (Applicative m, Monad m) + => DirActions m + -> [PackageSpecifier (SourcePackage (PackageLocation a))] + -> Maybe ComponentKindFilter + -> [String] + -> m (Either [TargetSelectorProblem] [TargetSelector]) readTargetSelectorsWith dirActions@DirActions{} pkgs mfilter targetStrs = - case parseTargetStrings targetStrs of - ([], usertargets) -> do - usertargets' <- traverse (getTargetStringFileStatus dirActions) usertargets - knowntargets <- getKnownTargets dirActions pkgs - case resolveTargetSelectors knowntargets usertargets' mfilter of - ([], btargets) -> return (Right btargets) - (problems, _) -> return (Left problems) - (strs, _) -> return (Left (map TargetSelectorUnrecognised strs)) - - -data DirActions m = DirActions { - doesFileExist :: FilePath -> m Bool, - doesDirectoryExist :: FilePath -> m Bool, - canonicalizePath :: FilePath -> m FilePath, - getCurrentDirectory :: m FilePath - } + case parseTargetStrings targetStrs of + ([], usertargets) -> do + usertargets' <- traverse (getTargetStringFileStatus dirActions) usertargets + knowntargets <- getKnownTargets dirActions pkgs + case resolveTargetSelectors knowntargets usertargets' mfilter of + ([], btargets) -> return (Right btargets) + (problems, _) -> return (Left problems) + (strs, _) -> return (Left (map TargetSelectorUnrecognised strs)) + +data DirActions m = DirActions + { doesFileExist :: FilePath -> m Bool + , doesDirectoryExist :: FilePath -> m Bool + , canonicalizePath :: FilePath -> m FilePath + , getCurrentDirectory :: m FilePath + } defaultDirActions :: DirActions IO defaultDirActions = - DirActions { - doesFileExist = IO.doesFileExist, - doesDirectoryExist = IO.doesDirectoryExist, - -- Workaround for - canonicalizePath = IO.canonicalizePath . dropTrailingPathSeparator, - getCurrentDirectory = IO.getCurrentDirectory + DirActions + { doesFileExist = IO.doesFileExist + , doesDirectoryExist = IO.doesDirectoryExist + , -- Workaround for + canonicalizePath = IO.canonicalizePath . dropTrailingPathSeparator + , getCurrentDirectory = IO.getCurrentDirectory } makeRelativeToCwd :: Applicative m => DirActions m -> FilePath -> m FilePath makeRelativeToCwd DirActions{..} path = - makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory - + makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory -- ------------------------------------------------------------ + -- * Parsing target strings + -- ------------------------------------------------------------ -- | The outline parse of a target selector. It takes one of the forms: @@ -260,257 +302,278 @@ makeRelativeToCwd DirActions{..} path = -- > str1:str2 -- > str1:str2:str3 -- > str1:str2:str3:str4 --- -data TargetString = - TargetString1 String - | TargetString2 String String - | TargetString3 String String String - | TargetString4 String String String String - | TargetString5 String String String String String - | TargetString7 String String String String String String String +data TargetString + = TargetString1 String + | TargetString2 String String + | TargetString3 String String String + | TargetString4 String String String String + | TargetString5 String String String String String + | TargetString7 String String String String String String String deriving (Show, Eq) -- | Parse a bunch of 'TargetString's (purely without throwing exceptions). --- parseTargetStrings :: [String] -> ([String], [TargetString]) parseTargetStrings = - partitionEithers - . map (\str -> maybe (Left str) Right (parseTargetString str)) + partitionEithers + . map (\str -> maybe (Left str) Right (parseTargetString str)) parseTargetString :: String -> Maybe TargetString parseTargetString = - readPToMaybe parseTargetApprox + readPToMaybe parseTargetApprox where parseTargetApprox :: Parse.ReadP r TargetString parseTargetApprox = - (do a <- tokenQ - return (TargetString1 a)) - +++ (do a <- tokenQ0 - _ <- Parse.char ':' - b <- tokenQ - return (TargetString2 a b)) - +++ (do a <- tokenQ0 - _ <- Parse.char ':' - b <- tokenQ - _ <- Parse.char ':' - c <- tokenQ - return (TargetString3 a b c)) - +++ (do a <- tokenQ0 - _ <- Parse.char ':' - b <- token - _ <- Parse.char ':' - c <- tokenQ - _ <- Parse.char ':' - d <- tokenQ - return (TargetString4 a b c d)) - +++ (do a <- tokenQ0 - _ <- Parse.char ':' - b <- token - _ <- Parse.char ':' - c <- tokenQ - _ <- Parse.char ':' - d <- tokenQ - _ <- Parse.char ':' - e <- tokenQ - return (TargetString5 a b c d e)) - +++ (do a <- tokenQ0 - _ <- Parse.char ':' - b <- token - _ <- Parse.char ':' - c <- tokenQ - _ <- Parse.char ':' - d <- tokenQ - _ <- Parse.char ':' - e <- tokenQ - _ <- Parse.char ':' - f <- tokenQ - _ <- Parse.char ':' - g <- tokenQ - return (TargetString7 a b c d e f g)) - - token = Parse.munch1 (\x -> not (isSpace x) && x /= ':') + ( do + a <- tokenQ + return (TargetString1 a) + ) + +++ ( do + a <- tokenQ0 + _ <- Parse.char ':' + b <- tokenQ + return (TargetString2 a b) + ) + +++ ( do + a <- tokenQ0 + _ <- Parse.char ':' + b <- tokenQ + _ <- Parse.char ':' + c <- tokenQ + return (TargetString3 a b c) + ) + +++ ( do + a <- tokenQ0 + _ <- Parse.char ':' + b <- token + _ <- Parse.char ':' + c <- tokenQ + _ <- Parse.char ':' + d <- tokenQ + return (TargetString4 a b c d) + ) + +++ ( do + a <- tokenQ0 + _ <- Parse.char ':' + b <- token + _ <- Parse.char ':' + c <- tokenQ + _ <- Parse.char ':' + d <- tokenQ + _ <- Parse.char ':' + e <- tokenQ + return (TargetString5 a b c d e) + ) + +++ ( do + a <- tokenQ0 + _ <- Parse.char ':' + b <- token + _ <- Parse.char ':' + c <- tokenQ + _ <- Parse.char ':' + d <- tokenQ + _ <- Parse.char ':' + e <- tokenQ + _ <- Parse.char ':' + f <- tokenQ + _ <- Parse.char ':' + g <- tokenQ + return (TargetString7 a b c d e f g) + ) + + token = Parse.munch1 (\x -> not (isSpace x) && x /= ':') tokenQ = parseHaskellString <++ token token0 = Parse.munch (\x -> not (isSpace x) && x /= ':') - tokenQ0= parseHaskellString <++ token0 + tokenQ0 = parseHaskellString <++ token0 parseHaskellString :: Parse.ReadP r String parseHaskellString = Parse.readS_to_P reads - -- | Render a 'TargetString' back as the external syntax. This is mainly for -- error messages. --- showTargetString :: TargetString -> String showTargetString = intercalate ":" . components where - components (TargetString1 s1) = [s1] - components (TargetString2 s1 s2) = [s1,s2] - components (TargetString3 s1 s2 s3) = [s1,s2,s3] - components (TargetString4 s1 s2 s3 s4) = [s1,s2,s3,s4] - components (TargetString5 s1 s2 s3 s4 s5) = [s1,s2,s3,s4,s5] - components (TargetString7 s1 s2 s3 s4 s5 s6 s7) = [s1,s2,s3,s4,s5,s6,s7] + components (TargetString1 s1) = [s1] + components (TargetString2 s1 s2) = [s1, s2] + components (TargetString3 s1 s2 s3) = [s1, s2, s3] + components (TargetString4 s1 s2 s3 s4) = [s1, s2, s3, s4] + components (TargetString5 s1 s2 s3 s4 s5) = [s1, s2, s3, s4, s5] + components (TargetString7 s1 s2 s3 s4 s5 s6 s7) = [s1, s2, s3, s4, s5, s6, s7] showTargetSelector :: TargetSelector -> String showTargetSelector ts = - case [ t | ql <- [QL1 .. QLFull] - , t <- renderTargetSelector ql ts ] - of (t':_) -> showTargetString (forgetFileStatus t') - [] -> "" + case [ t | ql <- [QL1 .. QLFull], t <- renderTargetSelector ql ts + ] of + (t' : _) -> showTargetString (forgetFileStatus t') + [] -> "" showTargetSelectorKind :: TargetSelector -> String showTargetSelectorKind bt = case bt of - TargetPackage TargetExplicitNamed _ Nothing -> "package" + TargetPackage TargetExplicitNamed _ Nothing -> "package" TargetPackage TargetExplicitNamed _ (Just _) -> "package:filter" - TargetPackage TargetImplicitCwd _ Nothing -> "cwd-package" - TargetPackage TargetImplicitCwd _ (Just _) -> "cwd-package:filter" - TargetPackageNamed _ Nothing -> "named-package" - TargetPackageNamed _ (Just _) -> "named-package:filter" - TargetAllPackages Nothing -> "package *" - TargetAllPackages (Just _) -> "package *:filter" - TargetComponent _ _ WholeComponent -> "component" - TargetComponent _ _ ModuleTarget{} -> "module" - TargetComponent _ _ FileTarget{} -> "file" - TargetComponentUnknown _ _ WholeComponent -> "unknown-component" - TargetComponentUnknown _ _ ModuleTarget{} -> "unknown-module" - TargetComponentUnknown _ _ FileTarget{} -> "unknown-file" - + TargetPackage TargetImplicitCwd _ Nothing -> "cwd-package" + TargetPackage TargetImplicitCwd _ (Just _) -> "cwd-package:filter" + TargetPackageNamed _ Nothing -> "named-package" + TargetPackageNamed _ (Just _) -> "named-package:filter" + TargetAllPackages Nothing -> "package *" + TargetAllPackages (Just _) -> "package *:filter" + TargetComponent _ _ WholeComponent -> "component" + TargetComponent _ _ ModuleTarget{} -> "module" + TargetComponent _ _ FileTarget{} -> "file" + TargetComponentUnknown _ _ WholeComponent -> "unknown-component" + TargetComponentUnknown _ _ ModuleTarget{} -> "unknown-module" + TargetComponentUnknown _ _ FileTarget{} -> "unknown-file" -- ------------------------------------------------------------ + -- * Checking if targets exist as files + -- ------------------------------------------------------------ -data TargetStringFileStatus = - TargetStringFileStatus1 String FileStatus - | TargetStringFileStatus2 String FileStatus String - | TargetStringFileStatus3 String FileStatus String String - | TargetStringFileStatus4 String String String String - | TargetStringFileStatus5 String String String String String - | TargetStringFileStatus7 String String String String String String String +data TargetStringFileStatus + = TargetStringFileStatus1 String FileStatus + | TargetStringFileStatus2 String FileStatus String + | TargetStringFileStatus3 String FileStatus String String + | TargetStringFileStatus4 String String String String + | TargetStringFileStatus5 String String String String String + | TargetStringFileStatus7 String String String String String String String deriving (Eq, Ord, Show) -data FileStatus = FileStatusExistsFile FilePath -- the canonicalised filepath - | FileStatusExistsDir FilePath -- the canonicalised filepath - | FileStatusNotExists Bool -- does the parent dir exist even? +data FileStatus + = FileStatusExistsFile FilePath -- the canonicalised filepath + | FileStatusExistsDir FilePath -- the canonicalised filepath + | FileStatusNotExists Bool -- does the parent dir exist even? deriving (Eq, Ord, Show) noFileStatus :: FileStatus noFileStatus = FileStatusNotExists False -getTargetStringFileStatus :: (Applicative m, Monad m) => DirActions m - -> TargetString -> m TargetStringFileStatus +getTargetStringFileStatus + :: (Applicative m, Monad m) + => DirActions m + -> TargetString + -> m TargetStringFileStatus getTargetStringFileStatus DirActions{..} t = - case t of - TargetString1 s1 -> - (\f1 -> TargetStringFileStatus1 s1 f1) <$> fileStatus s1 - TargetString2 s1 s2 -> - (\f1 -> TargetStringFileStatus2 s1 f1 s2) <$> fileStatus s1 - TargetString3 s1 s2 s3 -> - (\f1 -> TargetStringFileStatus3 s1 f1 s2 s3) <$> fileStatus s1 - TargetString4 s1 s2 s3 s4 -> - return (TargetStringFileStatus4 s1 s2 s3 s4) - TargetString5 s1 s2 s3 s4 s5 -> - return (TargetStringFileStatus5 s1 s2 s3 s4 s5) - TargetString7 s1 s2 s3 s4 s5 s6 s7 -> - return (TargetStringFileStatus7 s1 s2 s3 s4 s5 s6 s7) + case t of + TargetString1 s1 -> + (\f1 -> TargetStringFileStatus1 s1 f1) <$> fileStatus s1 + TargetString2 s1 s2 -> + (\f1 -> TargetStringFileStatus2 s1 f1 s2) <$> fileStatus s1 + TargetString3 s1 s2 s3 -> + (\f1 -> TargetStringFileStatus3 s1 f1 s2 s3) <$> fileStatus s1 + TargetString4 s1 s2 s3 s4 -> + return (TargetStringFileStatus4 s1 s2 s3 s4) + TargetString5 s1 s2 s3 s4 s5 -> + return (TargetStringFileStatus5 s1 s2 s3 s4 s5) + TargetString7 s1 s2 s3 s4 s5 s6 s7 -> + return (TargetStringFileStatus7 s1 s2 s3 s4 s5 s6 s7) where fileStatus f = do fexists <- doesFileExist f dexists <- doesDirectoryExist f case splitPath f of - _ | fexists -> FileStatusExistsFile <$> canonicalizePath f - | dexists -> FileStatusExistsDir <$> canonicalizePath f - (d:_) -> FileStatusNotExists <$> doesDirectoryExist d - _ -> pure (FileStatusNotExists False) + _ + | fexists -> FileStatusExistsFile <$> canonicalizePath f + | dexists -> FileStatusExistsDir <$> canonicalizePath f + (d : _) -> FileStatusNotExists <$> doesDirectoryExist d + _ -> pure (FileStatusNotExists False) forgetFileStatus :: TargetStringFileStatus -> TargetString forgetFileStatus t = case t of - TargetStringFileStatus1 s1 _ -> TargetString1 s1 - TargetStringFileStatus2 s1 _ s2 -> TargetString2 s1 s2 - TargetStringFileStatus3 s1 _ s2 s3 -> TargetString3 s1 s2 s3 - TargetStringFileStatus4 s1 s2 s3 s4 -> TargetString4 s1 s2 s3 s4 - TargetStringFileStatus5 s1 s2 s3 s4 - s5 -> TargetString5 s1 s2 s3 s4 s5 - TargetStringFileStatus7 s1 s2 s3 s4 - s5 s6 s7 -> TargetString7 s1 s2 s3 s4 s5 s6 s7 + TargetStringFileStatus1 s1 _ -> TargetString1 s1 + TargetStringFileStatus2 s1 _ s2 -> TargetString2 s1 s2 + TargetStringFileStatus3 s1 _ s2 s3 -> TargetString3 s1 s2 s3 + TargetStringFileStatus4 s1 s2 s3 s4 -> TargetString4 s1 s2 s3 s4 + TargetStringFileStatus5 + s1 + s2 + s3 + s4 + s5 -> TargetString5 s1 s2 s3 s4 s5 + TargetStringFileStatus7 + s1 + s2 + s3 + s4 + s5 + s6 + s7 -> TargetString7 s1 s2 s3 s4 s5 s6 s7 getFileStatus :: TargetStringFileStatus -> Maybe FileStatus -getFileStatus (TargetStringFileStatus1 _ f) = Just f -getFileStatus (TargetStringFileStatus2 _ f _) = Just f +getFileStatus (TargetStringFileStatus1 _ f) = Just f +getFileStatus (TargetStringFileStatus2 _ f _) = Just f getFileStatus (TargetStringFileStatus3 _ f _ _) = Just f -getFileStatus _ = Nothing +getFileStatus _ = Nothing setFileStatus :: FileStatus -> TargetStringFileStatus -> TargetStringFileStatus -setFileStatus f (TargetStringFileStatus1 s1 _) = TargetStringFileStatus1 s1 f -setFileStatus f (TargetStringFileStatus2 s1 _ s2) = TargetStringFileStatus2 s1 f s2 +setFileStatus f (TargetStringFileStatus1 s1 _) = TargetStringFileStatus1 s1 f +setFileStatus f (TargetStringFileStatus2 s1 _ s2) = TargetStringFileStatus2 s1 f s2 setFileStatus f (TargetStringFileStatus3 s1 _ s2 s3) = TargetStringFileStatus3 s1 f s2 s3 -setFileStatus _ t = t +setFileStatus _ t = t copyFileStatus :: TargetStringFileStatus -> TargetStringFileStatus -> TargetStringFileStatus copyFileStatus src dst = - case getFileStatus src of - Just f -> setFileStatus f dst - Nothing -> dst + case getFileStatus src of + Just f -> setFileStatus f dst + Nothing -> dst -- ------------------------------------------------------------ + -- * Resolving target strings to target selectors --- ------------------------------------------------------------ +-- ------------------------------------------------------------ -- | Given a bunch of user-specified targets, try to resolve what it is they -- refer to. --- -resolveTargetSelectors :: KnownTargets - -> [TargetStringFileStatus] - -> Maybe ComponentKindFilter - -> ([TargetSelectorProblem], - [TargetSelector]) +resolveTargetSelectors + :: KnownTargets + -> [TargetStringFileStatus] + -> Maybe ComponentKindFilter + -> ( [TargetSelectorProblem] + , [TargetSelector] + ) -- default local dir target if there's no given target: resolveTargetSelectors (KnownTargets{knownPackagesAll = []}) [] _ = - ([TargetSelectorNoTargetsInProject], []) - + ([TargetSelectorNoTargetsInProject], []) -- if the component kind filter is just exes, we don't want to suggest "all" as a target. resolveTargetSelectors (KnownTargets{knownPackagesPrimary = []}) [] ckf = - ([TargetSelectorNoTargetsInCwd (ckf /= Just ExeKind) ], []) - + ([TargetSelectorNoTargetsInCwd (ckf /= Just ExeKind)], []) resolveTargetSelectors (KnownTargets{knownPackagesPrimary}) [] _ = - ([], [TargetPackage TargetImplicitCwd pkgids Nothing]) + ([], [TargetPackage TargetImplicitCwd pkgids Nothing]) where - pkgids = [ pinfoId | KnownPackage{pinfoId} <- knownPackagesPrimary ] - + pkgids = [pinfoId | KnownPackage{pinfoId} <- knownPackagesPrimary] resolveTargetSelectors knowntargets targetStrs mfilter = - partitionEithers - . map (resolveTargetSelector knowntargets mfilter) - $ targetStrs - -resolveTargetSelector :: KnownTargets - -> Maybe ComponentKindFilter - -> TargetStringFileStatus - -> Either TargetSelectorProblem TargetSelector + partitionEithers + . map (resolveTargetSelector knowntargets mfilter) + $ targetStrs + +resolveTargetSelector + :: KnownTargets + -> Maybe ComponentKindFilter + -> TargetStringFileStatus + -> Either TargetSelectorProblem TargetSelector resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus = - case findMatch (matcher targetStrStatus) of - - Unambiguous _ - | projectIsEmpty -> Left TargetSelectorNoTargetsInProject - - Unambiguous (TargetPackage TargetImplicitCwd [] _) - -> Left (TargetSelectorNoCurrentPackage targetStr) - - Unambiguous target -> Right target - - None errs - | projectIsEmpty -> Left TargetSelectorNoTargetsInProject - | otherwise -> Left (classifyMatchErrors errs) - - Ambiguous _ targets - | Just kfilter <- mfilter - , [target] <- applyKindFilter kfilter targets -> Right target - - Ambiguous exactMatch targets -> - case disambiguateTargetSelectors - matcher targetStrStatus exactMatch - targets of - Right targets' -> Left (TargetSelectorAmbiguous targetStr targets') - Left ((m, ms):_) -> Left (MatchingInternalError targetStr m ms) - Left [] -> internalError "resolveTargetSelector" + case findMatch (matcher targetStrStatus) of + Unambiguous _ + | projectIsEmpty -> Left TargetSelectorNoTargetsInProject + Unambiguous (TargetPackage TargetImplicitCwd [] _) -> + Left (TargetSelectorNoCurrentPackage targetStr) + Unambiguous target -> Right target + None errs + | projectIsEmpty -> Left TargetSelectorNoTargetsInProject + | otherwise -> Left (classifyMatchErrors errs) + Ambiguous _ targets + | Just kfilter <- mfilter + , [target] <- applyKindFilter kfilter targets -> + Right target + Ambiguous exactMatch targets -> + case disambiguateTargetSelectors + matcher + targetStrStatus + exactMatch + targets of + Right targets' -> Left (TargetSelectorAmbiguous targetStr targets') + Left ((m, ms) : _) -> Left (MatchingInternalError targetStr m ms) + Left [] -> internalError "resolveTargetSelector" where matcher = matchTargetSelector knowntargets @@ -519,105 +582,120 @@ resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus = projectIsEmpty = null knownPackagesAll classifyMatchErrors errs - | Just expectedNE <- NE.nonEmpty expected - = let (things, got:|_) = NE.unzip expectedNE in - TargetSelectorExpected targetStr (NE.toList things) got - - | not (null nosuch) - = TargetSelectorNoSuch targetStr nosuch - - | otherwise - = internalError $ "classifyMatchErrors: " ++ show errs + | Just expectedNE <- NE.nonEmpty expected = + let (things, got :| _) = NE.unzip expectedNE + in TargetSelectorExpected targetStr (NE.toList things) got + | not (null nosuch) = + TargetSelectorNoSuch targetStr nosuch + | otherwise = + internalError $ "classifyMatchErrors: " ++ show errs where - expected = [ (thing, got) - | (_, MatchErrorExpected thing got) - <- map (innerErr Nothing) errs ] + expected = + [ (thing, got) + | (_, MatchErrorExpected thing got) <- + map (innerErr Nothing) errs + ] -- Trim the list of alternatives by dropping duplicates and -- retaining only at most three most similar (by edit distance) ones. - nosuch = Map.foldrWithKey genResults [] $ Map.fromListWith Set.union $ - [ ((inside, thing, got), Set.fromList alts) - | (inside, MatchErrorNoSuch thing got alts) - <- map (innerErr Nothing) errs - ] + nosuch = + Map.foldrWithKey genResults [] $ + Map.fromListWith Set.union $ + [ ((inside, thing, got), Set.fromList alts) + | (inside, MatchErrorNoSuch thing got alts) <- + map (innerErr Nothing) errs + ] - genResults (inside, thing, got) alts acc = ( - inside + genResults (inside, thing, got) alts acc = + ( inside , thing , got - , take maxResults - $ map fst - $ takeWhile distanceLow - $ sortBy (comparing snd) - $ map addLevDist - $ Set.toList alts - ) : acc + , take maxResults $ + map fst $ + takeWhile distanceLow $ + sortBy (comparing snd) $ + map addLevDist $ + Set.toList alts + ) + : acc where - addLevDist = id &&& restrictedDamerauLevenshteinDistance - defaultEditCosts got + addLevDist = + id + &&& restrictedDamerauLevenshteinDistance + defaultEditCosts + got distanceLow (_, dist) = dist < length got `div` 2 maxResults = 3 - innerErr _ (MatchErrorIn kind thing m) - = innerErr (Just (kind,thing)) m - innerErr c m = (c,m) + innerErr _ (MatchErrorIn kind thing m) = + innerErr (Just (kind, thing)) m + innerErr c m = (c, m) applyKindFilter :: ComponentKindFilter -> [TargetSelector] -> [TargetSelector] applyKindFilter kfilter = filter go where - go (TargetPackage _ _ (Just filter')) = kfilter == filter' - go (TargetPackageNamed _ (Just filter')) = kfilter == filter' - go (TargetAllPackages (Just filter')) = kfilter == filter' + go (TargetPackage _ _ (Just filter')) = kfilter == filter' + go (TargetPackageNamed _ (Just filter')) = kfilter == filter' + go (TargetAllPackages (Just filter')) = kfilter == filter' go (TargetComponent _ cname _) - | CLibName _ <- cname = kfilter == LibKind - | CFLibName _ <- cname = kfilter == FLibKind - | CExeName _ <- cname = kfilter == ExeKind - | CTestName _ <- cname = kfilter == TestKind - | CBenchName _ <- cname = kfilter == BenchKind - go _ = True + | CLibName _ <- cname = kfilter == LibKind + | CFLibName _ <- cname = kfilter == FLibKind + | CExeName _ <- cname = kfilter == ExeKind + | CTestName _ <- cname = kfilter == TestKind + | CBenchName _ <- cname = kfilter == BenchKind + go _ = True -- | The various ways that trying to resolve a 'TargetString' to a -- 'TargetSelector' can fail. --- data TargetSelectorProblem - = TargetSelectorExpected TargetString [String] String - -- ^ [expected thing] (actually got) - | TargetSelectorNoSuch TargetString - [(Maybe (String, String), String, String, [String])] - -- ^ [([in thing], no such thing, actually got, alternatives)] - | TargetSelectorAmbiguous TargetString - [(TargetString, TargetSelector)] - - | MatchingInternalError TargetString TargetSelector - [(TargetString, [TargetSelector])] - | TargetSelectorUnrecognised String - -- ^ Syntax error when trying to parse a target string. - | TargetSelectorNoCurrentPackage TargetString - | TargetSelectorNoTargetsInCwd Bool - -- ^ bool that flags when it is acceptable to suggest "all" as a target - | TargetSelectorNoTargetsInProject - | TargetSelectorNoScript TargetString + = -- | [expected thing] (actually got) + TargetSelectorExpected TargetString [String] String + | -- | [([in thing], no such thing, actually got, alternatives)] + TargetSelectorNoSuch + TargetString + [(Maybe (String, String), String, String, [String])] + | TargetSelectorAmbiguous + TargetString + [(TargetString, TargetSelector)] + | MatchingInternalError + TargetString + TargetSelector + [(TargetString, [TargetSelector])] + | -- | Syntax error when trying to parse a target string. + TargetSelectorUnrecognised String + | TargetSelectorNoCurrentPackage TargetString + | -- | bool that flags when it is acceptable to suggest "all" as a target + TargetSelectorNoTargetsInCwd Bool + | TargetSelectorNoTargetsInProject + | TargetSelectorNoScript TargetString deriving (Show, Eq) -- | Qualification levels. -- Given the filepath src/F, executable component A, and package foo: -data QualLevel = QL1 -- ^ @src/F@ - | QL2 -- ^ @foo:src/F | A:src/F@ - | QL3 -- ^ @foo:A:src/F | exe:A:src/F@ - | QLFull -- ^ @pkg:foo:exe:A:file:src/F@ +data QualLevel + = -- | @src/F@ + QL1 + | -- | @foo:src/F | A:src/F@ + QL2 + | -- | @foo:A:src/F | exe:A:src/F@ + QL3 + | -- | @pkg:foo:exe:A:file:src/F@ + QLFull deriving (Eq, Enum, Show) disambiguateTargetSelectors :: (TargetStringFileStatus -> Match TargetSelector) - -> TargetStringFileStatus -> MatchClass + -> TargetStringFileStatus + -> MatchClass -> [TargetSelector] - -> Either [(TargetSelector, [(TargetString, [TargetSelector])])] - [(TargetString, TargetSelector)] + -> Either + [(TargetSelector, [(TargetString, [TargetSelector])])] + [(TargetString, TargetSelector)] disambiguateTargetSelectors matcher matchInput exactMatch matchResults = - case partitionEithers results of - (errs@(_:_), _) -> Left errs - ([], ok) -> Right ok + case partitionEithers results of + (errs@(_ : _), _) -> Left errs + ([], ok) -> Right ok where -- So, here's the strategy. We take the original match results, and make a -- table of all their renderings at all qualification levels. @@ -636,7 +714,8 @@ disambiguateTargetSelectors matcher matchInput exactMatch matchResults = , let matchRenderings = [ copyFileStatus matchInput rendering | ql <- [QL1 .. QLFull] - , rendering <- renderTargetSelector ql matchResult ] + , rendering <- renderTargetSelector ql matchResult + ] ] -- Of course the point is that we're looking for renderings that are @@ -646,251 +725,314 @@ disambiguateTargetSelectors matcher matchInput exactMatch matchResults = memoisedMatches :: Map TargetStringFileStatus (Match TargetSelector) memoisedMatches = - -- avoid recomputing the main one if it was an exact match - (if exactMatch == Exact - then Map.insert matchInput (Match Exact 0 matchResults) - else id) - $ Map.Lazy.fromList - -- (matcher rendering) should *always* be a Match! Otherwise we will hit - -- the internal error later on. + -- avoid recomputing the main one if it was an exact match + ( if exactMatch == Exact + then Map.insert matchInput (Match Exact 0 matchResults) + else id + ) + $ Map.Lazy.fromList + -- (matcher rendering) should *always* be a Match! Otherwise we will hit + -- the internal error later on. [ (rendering, matcher rendering) - | rendering <- concatMap snd matchResultsRenderings ] + | rendering <- concatMap snd matchResultsRenderings + ] -- Finally, for each of the match results, we go through all their -- possible renderings (in order of qualification level, though remember -- there can be multiple renderings per level), and find the first one -- that has an unambiguous match. - results :: [Either (TargetSelector, [(TargetString, [TargetSelector])]) - (TargetString, TargetSelector)] + results + :: [ Either + (TargetSelector, [(TargetString, [TargetSelector])]) + (TargetString, TargetSelector) + ] results = [ case findUnambiguous originalMatch matchRenderings of - Just unambiguousRendering -> - Right ( forgetFileStatus unambiguousRendering - , originalMatch) - - -- This case is an internal error, but we bubble it up and report it - Nothing -> - Left ( originalMatch - , [ (forgetFileStatus rendering, matches) - | rendering <- matchRenderings - , let Match m _ matches = - memoisedMatches Map.! rendering - , m /= Inexact - ] ) - - | (originalMatch, matchRenderings) <- matchResultsRenderings ] - - findUnambiguous :: TargetSelector - -> [TargetStringFileStatus] - -> Maybe TargetStringFileStatus - findUnambiguous _ [] = Nothing - findUnambiguous t (r:rs) = + Just unambiguousRendering -> + Right + ( forgetFileStatus unambiguousRendering + , originalMatch + ) + -- This case is an internal error, but we bubble it up and report it + Nothing -> + Left + ( originalMatch + , [ (forgetFileStatus rendering, matches) + | rendering <- matchRenderings + , let Match m _ matches = + memoisedMatches Map.! rendering + , m /= Inexact + ] + ) + | (originalMatch, matchRenderings) <- matchResultsRenderings + ] + + findUnambiguous + :: TargetSelector + -> [TargetStringFileStatus] + -> Maybe TargetStringFileStatus + findUnambiguous _ [] = Nothing + findUnambiguous t (r : rs) = case memoisedMatches Map.! r of - Match Exact _ [t'] | t == t' - -> Just r - Match Exact _ _ -> findUnambiguous t rs + Match Exact _ [t'] + | t == t' -> + Just r + Match Exact _ _ -> findUnambiguous t rs Match Unknown _ _ -> findUnambiguous t rs Match Inexact _ _ -> internalError "Match Inexact" - NoMatch _ _ -> internalError "NoMatch" + NoMatch _ _ -> internalError "NoMatch" internalError :: String -> a internalError msg = error $ "TargetSelector: internal error: " ++ msg - -- | Throw an exception with a formatted message if there are any problems. --- reportTargetSelectorProblems :: Verbosity -> [TargetSelectorProblem] -> IO a reportTargetSelectorProblems verbosity problems = do - - case [ str | TargetSelectorUnrecognised str <- problems ] of - [] -> return () - targets -> - die' verbosity $ unlines + case [str | TargetSelectorUnrecognised str <- problems] of + [] -> return () + targets -> + die' verbosity $ + unlines [ "Unrecognised target syntax for '" ++ name ++ "'." - | name <- targets ] - - case [ (t, m, ms) | MatchingInternalError t m ms <- problems ] of - [] -> return () - ((target, originalMatch, renderingsAndMatches):_) -> - die' verbosity $ "Internal error in target matching: could not make an " - ++ "unambiguous fully qualified target selector for '" - ++ showTargetString target ++ "'.\n" - ++ "We made the target '" ++ showTargetSelector originalMatch ++ "' (" - ++ showTargetSelectorKind originalMatch ++ ") that was expected to " - ++ "be unambiguous but matches the following targets:\n" - ++ unlines - [ "'" ++ showTargetString rendering ++ "', matching:" - ++ concatMap ("\n - " ++) - [ showTargetSelector match ++ - " (" ++ showTargetSelectorKind match ++ ")" - | match <- matches ] - | (rendering, matches) <- renderingsAndMatches ] - ++ "\nNote: Cabal expects to be able to make a single fully " - ++ "qualified name for a target or provide a more specific error. " - ++ "Our failure to do so is a bug in cabal. " - ++ "Tracking issue: https://github.com/haskell/cabal/issues/8684" - ++ "\n\nHint: this may be caused by trying to build a package that " - ++ "exists in the project directory but is missing from " - ++ "the 'packages' stanza in your cabal project file." - - case [ (t, e, g) | TargetSelectorExpected t e g <- problems ] of - [] -> return () - targets -> - die' verbosity $ unlines - [ "Unrecognised target '" ++ showTargetString target - ++ "'.\n" - ++ "Expected a " ++ intercalate " or " expected - ++ ", rather than '" ++ got ++ "'." - | (target, expected, got) <- targets ] - - case [ (t, e) | TargetSelectorNoSuch t e <- problems ] of - [] -> return () - targets -> - die' verbosity $ unlines - [ "Unknown target '" ++ showTargetString target ++ - "'.\n" ++ unlines - [ (case inside of - Just (kind, "") - -> "The " ++ kind ++ " has no " - Just (kind, thing) - -> "The " ++ kind ++ " " ++ thing ++ " has no " - Nothing -> "There is no ") - ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'" - | (thing, got, _alts) <- nosuch' ] ++ "." - ++ if null alternatives then "" else - "\nPerhaps you meant " ++ intercalate ";\nor " - [ "the " ++ thing ++ " '" ++ intercalate "' or '" alts ++ "'?" - | (thing, alts) <- alternatives ] - | (inside, nosuch') <- groupByContainer nosuch - , let alternatives = - [ (thing, alts) - | (thing,_got,alts@(_:_)) <- nosuch' ] + | name <- targets + ] + + case [(t, m, ms) | MatchingInternalError t m ms <- problems] of + [] -> return () + ((target, originalMatch, renderingsAndMatches) : _) -> + die' verbosity $ + "Internal error in target matching: could not make an " + ++ "unambiguous fully qualified target selector for '" + ++ showTargetString target + ++ "'.\n" + ++ "We made the target '" + ++ showTargetSelector originalMatch + ++ "' (" + ++ showTargetSelectorKind originalMatch + ++ ") that was expected to " + ++ "be unambiguous but matches the following targets:\n" + ++ unlines + [ "'" + ++ showTargetString rendering + ++ "', matching:" + ++ concatMap + ("\n - " ++) + [ showTargetSelector match + ++ " (" + ++ showTargetSelectorKind match + ++ ")" + | match <- matches + ] + | (rendering, matches) <- renderingsAndMatches ] + ++ "\nNote: Cabal expects to be able to make a single fully " + ++ "qualified name for a target or provide a more specific error. " + ++ "Our failure to do so is a bug in cabal. " + ++ "Tracking issue: https://github.com/haskell/cabal/issues/8684" + ++ "\n\nHint: this may be caused by trying to build a package that " + ++ "exists in the project directory but is missing from " + ++ "the 'packages' stanza in your cabal project file." + + case [(t, e, g) | TargetSelectorExpected t e g <- problems] of + [] -> return () + targets -> + die' verbosity $ + unlines + [ "Unrecognised target '" + ++ showTargetString target + ++ "'.\n" + ++ "Expected a " + ++ intercalate " or " expected + ++ ", rather than '" + ++ got + ++ "'." + | (target, expected, got) <- targets + ] + + case [(t, e) | TargetSelectorNoSuch t e <- problems] of + [] -> return () + targets -> + die' verbosity $ + unlines + [ "Unknown target '" + ++ showTargetString target + ++ "'.\n" + ++ unlines + [ ( case inside of + Just (kind, "") -> + "The " ++ kind ++ " has no " + Just (kind, thing) -> + "The " ++ kind ++ " " ++ thing ++ " has no " + Nothing -> "There is no " + ) + ++ intercalate + " or " + [ mungeThing thing ++ " '" ++ got ++ "'" + | (thing, got, _alts) <- nosuch' + ] + ++ "." + ++ if null alternatives + then "" + else + "\nPerhaps you meant " + ++ intercalate + ";\nor " + [ "the " ++ thing ++ " '" ++ intercalate "' or '" alts ++ "'?" + | (thing, alts) <- alternatives + ] + | (inside, nosuch') <- groupByContainer nosuch + , let alternatives = + [ (thing, alts) + | (thing, _got, alts@(_ : _)) <- nosuch' + ] + ] | (target, nosuch) <- targets , let groupByContainer = - map (\g@((inside,_,_,_):_) -> - (inside, [ (thing,got,alts) - | (_,thing,got,alts) <- g ])) - . groupBy ((==) `on` (\(x,_,_,_) -> x)) - . sortBy (compare `on` (\(x,_,_,_) -> x)) + map + ( \g@((inside, _, _, _) : _) -> + ( inside + , [ (thing, got, alts) + | (_, thing, got, alts) <- g + ] + ) + ) + . groupBy ((==) `on` (\(x, _, _, _) -> x)) + . sortBy (compare `on` (\(x, _, _, _) -> x)) ] - where - mungeThing "file" = "file target" - mungeThing thing = thing - - case [ (t, ts) | TargetSelectorAmbiguous t ts <- problems ] of - [] -> return () - targets -> - die' verbosity $ unlines - [ "Ambiguous target '" ++ showTargetString target + where + mungeThing "file" = "file target" + mungeThing thing = thing + + case [(t, ts) | TargetSelectorAmbiguous t ts <- problems] of + [] -> return () + targets -> + die' verbosity $ + unlines + [ "Ambiguous target '" + ++ showTargetString target ++ "'. It could be:\n " - ++ unlines [ " "++ showTargetString ut ++ - " (" ++ showTargetSelectorKind bt ++ ")" - | (ut, bt) <- amb ] - | (target, amb) <- targets ] - - case [ t | TargetSelectorNoCurrentPackage t <- problems ] of - [] -> return () - target:_ -> - die' verbosity $ - "The target '" ++ showTargetString target ++ "' refers to the " - ++ "components in the package in the current directory, but there " - ++ "is no package in the current directory (or at least not listed " - ++ "as part of the project)." - --TODO: report a different error if there is a .cabal file but it's - -- not a member of the project - - case [ () | TargetSelectorNoTargetsInCwd True <- problems ] of - [] -> return () - _:_ -> - die' verbosity $ - "No targets given and there is no package in the current " - ++ "directory. Use the target 'all' for all packages in the " - ++ "project or specify packages or components by name or location. " - ++ "See 'cabal build --help' for more details on target options." - - case [ () | TargetSelectorNoTargetsInCwd False <- problems ] of - [] -> return () - _:_ -> - die' verbosity $ - "No targets given and there is no package in the current " - ++ "directory. Specify packages or components by name or location. " - ++ "See 'cabal build --help' for more details on target options." - - case [ () | TargetSelectorNoTargetsInProject <- problems ] of - [] -> return () - _:_ -> - die' verbosity $ - "There is no .cabal package file or cabal.project file. " - ++ "To build packages locally you need at minimum a .cabal " - ++ "file. You can use 'cabal init' to create one.\n" - ++ "\n" - ++ "For non-trivial projects you will also want a cabal.project " - ++ "file in the root directory of your project. This file lists the " - ++ "packages in your project and all other build configuration. " - ++ "See the Cabal user guide for full details." - - case [ t | TargetSelectorNoScript t <- problems ] of - [] -> return () - target:_ -> - die' verbosity $ - "The script '" ++ showTargetString target ++ "' does not exist, " - ++ "and only script targets may contain whitespace characters or end " - ++ "with ':'" - - fail "reportTargetSelectorProblems: internal error" + ++ unlines + [ " " + ++ showTargetString ut + ++ " (" + ++ showTargetSelectorKind bt + ++ ")" + | (ut, bt) <- amb + ] + | (target, amb) <- targets + ] + case [t | TargetSelectorNoCurrentPackage t <- problems] of + [] -> return () + target : _ -> + die' verbosity $ + "The target '" + ++ showTargetString target + ++ "' refers to the " + ++ "components in the package in the current directory, but there " + ++ "is no package in the current directory (or at least not listed " + ++ "as part of the project)." + -- TODO: report a different error if there is a .cabal file but it's + -- not a member of the project + + case [() | TargetSelectorNoTargetsInCwd True <- problems] of + [] -> return () + _ : _ -> + die' verbosity $ + "No targets given and there is no package in the current " + ++ "directory. Use the target 'all' for all packages in the " + ++ "project or specify packages or components by name or location. " + ++ "See 'cabal build --help' for more details on target options." + + case [() | TargetSelectorNoTargetsInCwd False <- problems] of + [] -> return () + _ : _ -> + die' verbosity $ + "No targets given and there is no package in the current " + ++ "directory. Specify packages or components by name or location. " + ++ "See 'cabal build --help' for more details on target options." + + case [() | TargetSelectorNoTargetsInProject <- problems] of + [] -> return () + _ : _ -> + die' verbosity $ + "There is no .cabal package file or cabal.project file. " + ++ "To build packages locally you need at minimum a .cabal " + ++ "file. You can use 'cabal init' to create one.\n" + ++ "\n" + ++ "For non-trivial projects you will also want a cabal.project " + ++ "file in the root directory of your project. This file lists the " + ++ "packages in your project and all other build configuration. " + ++ "See the Cabal user guide for full details." + + case [t | TargetSelectorNoScript t <- problems] of + [] -> return () + target : _ -> + die' verbosity $ + "The script '" + ++ showTargetString target + ++ "' does not exist, " + ++ "and only script targets may contain whitespace characters or end " + ++ "with ':'" + + fail "reportTargetSelectorProblems: internal error" ---------------------------------- -- Syntax type -- -- | Syntax for the 'TargetSelector': the matcher and renderer --- -data Syntax = Syntax QualLevel Matcher Renderer - | AmbiguousAlternatives Syntax Syntax - | ShadowingAlternatives Syntax Syntax +data Syntax + = Syntax QualLevel Matcher Renderer + | AmbiguousAlternatives Syntax Syntax + | ShadowingAlternatives Syntax Syntax -type Matcher = TargetStringFileStatus -> Match TargetSelector +type Matcher = TargetStringFileStatus -> Match TargetSelector type Renderer = TargetSelector -> [TargetStringFileStatus] -foldSyntax :: (a -> a -> a) -> (a -> a -> a) - -> (QualLevel -> Matcher -> Renderer -> a) - -> (Syntax -> a) +foldSyntax + :: (a -> a -> a) + -> (a -> a -> a) + -> (QualLevel -> Matcher -> Renderer -> a) + -> (Syntax -> a) foldSyntax ambiguous unambiguous syntax = go where - go (Syntax ql match render) = syntax ql match render - go (AmbiguousAlternatives a b) = ambiguous (go a) (go b) + go (Syntax ql match render) = syntax ql match render + go (AmbiguousAlternatives a b) = ambiguous (go a) (go b) go (ShadowingAlternatives a b) = unambiguous (go a) (go b) - ---------------------------------- -- Top level renderer and matcher -- -renderTargetSelector :: QualLevel -> TargetSelector - -> [TargetStringFileStatus] +renderTargetSelector + :: QualLevel + -> TargetSelector + -> [TargetStringFileStatus] renderTargetSelector ql ts = - foldSyntax - (++) (++) - (\ql' _ render -> guard (ql == ql') >> render ts) - syntax + foldSyntax + (++) + (++) + (\ql' _ render -> guard (ql == ql') >> render ts) + syntax where syntax = syntaxForms emptyKnownTargets - -- don't need known targets for rendering -matchTargetSelector :: KnownTargets - -> TargetStringFileStatus - -> Match TargetSelector -matchTargetSelector knowntargets = \usertarget -> - nubMatchesBy (==) $ +-- don't need known targets for rendering - let ql = targetQualLevel usertarget in - foldSyntax - (<|>) () - (\ql' match _ -> guard (ql == ql') >> match usertarget) - syntax +matchTargetSelector + :: KnownTargets + -> TargetStringFileStatus + -> Match TargetSelector +matchTargetSelector knowntargets = \usertarget -> + nubMatchesBy (==) $ + let ql = targetQualLevel usertarget + in foldSyntax + (<|>) + () + (\ql' match _ -> guard (ql == ql') >> match usertarget) + syntax where syntax = syntaxForms knowntargets @@ -901,21 +1043,20 @@ matchTargetSelector knowntargets = \usertarget -> targetQualLevel TargetStringFileStatus5{} = QLFull targetQualLevel TargetStringFileStatus7{} = QLFull - ---------------------------------- -- Syntax forms -- -- | All the forms of syntax for 'TargetSelector'. --- syntaxForms :: KnownTargets -> Syntax -syntaxForms KnownTargets { - knownPackagesAll = pinfo, - knownPackagesPrimary = ppinfo, - knownComponentsAll = cinfo, - knownComponentsPrimary = pcinfo, - knownComponentsOther = ocinfo - } = +syntaxForms + KnownTargets + { knownPackagesAll = pinfo + , knownPackagesPrimary = ppinfo + , knownComponentsAll = cinfo + , knownComponentsPrimary = pcinfo + , knownComponentsOther = ocinfo + } = -- The various forms of syntax here are ambiguous in many cases. -- Our policy is by default we expose that ambiguity and report -- ambiguous matches. In certain cases we override the ambiguity @@ -927,72 +1068,65 @@ syntaxForms KnownTargets { -- not ambiguous like "Q" vs "Q.hs" or "Data.Q" vs "Data/Q". ambiguousAlternatives - -- convenient single-component forms + -- convenient single-component forms [ shadowingAlternatives [ ambiguousAlternatives [ syntaxForm1All - , syntaxForm1Filter ppinfo + , syntaxForm1Filter ppinfo , shadowingAlternatives [ syntaxForm1Component pcinfo - , syntaxForm1Package pinfo + , syntaxForm1Package pinfo ] ] , syntaxForm1Component ocinfo - , syntaxForm1Module cinfo - , syntaxForm1File pinfo + , syntaxForm1Module cinfo + , syntaxForm1File pinfo ] - - -- two-component partially qualified forms + , -- two-component partially qualified forms -- fully qualified form for 'all' - , syntaxForm2MetaAll + syntaxForm2MetaAll , syntaxForm2AllFilter , syntaxForm2NamespacePackage pinfo , syntaxForm2PackageComponent pinfo - , syntaxForm2PackageFilter pinfo - , syntaxForm2KindComponent cinfo + , syntaxForm2PackageFilter pinfo + , syntaxForm2KindComponent cinfo , shadowingAlternatives - [ syntaxForm2PackageModule pinfo - , syntaxForm2PackageFile pinfo + [ syntaxForm2PackageModule pinfo + , syntaxForm2PackageFile pinfo ] , shadowingAlternatives [ syntaxForm2ComponentModule cinfo - , syntaxForm2ComponentFile cinfo + , syntaxForm2ComponentFile cinfo ] - - -- rarely used partially qualified forms - , syntaxForm3PackageKindComponent pinfo + , -- rarely used partially qualified forms + syntaxForm3PackageKindComponent pinfo , shadowingAlternatives [ syntaxForm3PackageComponentModule pinfo - , syntaxForm3PackageComponentFile pinfo + , syntaxForm3PackageComponentFile pinfo ] , shadowingAlternatives - [ syntaxForm3KindComponentModule cinfo - , syntaxForm3KindComponentFile cinfo + [ syntaxForm3KindComponentModule cinfo + , syntaxForm3KindComponentFile cinfo ] , syntaxForm3NamespacePackageFilter pinfo - - -- fully-qualified forms for all and cwd with filter - , syntaxForm3MetaAllFilter + , -- fully-qualified forms for all and cwd with filter + syntaxForm3MetaAllFilter , syntaxForm3MetaCwdFilter ppinfo - - -- fully-qualified form for package and package with filter - , syntaxForm3MetaNamespacePackage pinfo + , -- fully-qualified form for package and package with filter + syntaxForm3MetaNamespacePackage pinfo , syntaxForm4MetaNamespacePackageFilter pinfo - - -- fully-qualified forms for component, module and file - , syntaxForm5MetaNamespacePackageKindComponent pinfo + , -- fully-qualified forms for component, module and file + syntaxForm5MetaNamespacePackageKindComponent pinfo , syntaxForm7MetaNamespacePackageKindComponentNamespaceModule pinfo - , syntaxForm7MetaNamespacePackageKindComponentNamespaceFile pinfo + , syntaxForm7MetaNamespacePackageKindComponentNamespaceFile pinfo ] - where - ambiguousAlternatives = Prelude.foldr1 AmbiguousAlternatives - shadowingAlternatives = Prelude.foldr1 ShadowingAlternatives - + where + ambiguousAlternatives = Prelude.foldr1 AmbiguousAlternatives + shadowingAlternatives = Prelude.foldr1 ShadowingAlternatives -- | Syntax: "all" to select all packages in the project -- -- > cabal build all --- syntaxForm1All :: Syntax syntaxForm1All = syntaxForm1 render $ \str1 _fstatus1 -> do @@ -1006,28 +1140,25 @@ syntaxForm1All = -- | Syntax: filter -- -- > cabal build tests --- syntaxForm1Filter :: [KnownPackage] -> Syntax syntaxForm1Filter ps = syntaxForm1 render $ \str1 _fstatus1 -> do kfilter <- matchComponentKindFilter str1 return (TargetPackage TargetImplicitCwd pids (Just kfilter)) where - pids = [ pinfoId | KnownPackage{pinfoId} <- ps ] + pids = [pinfoId | KnownPackage{pinfoId} <- ps] render (TargetPackage TargetImplicitCwd _ (Just kfilter)) = [TargetStringFileStatus1 (dispF kfilter) noFileStatus] render _ = [] - -- | Syntax: package (name, dir or file) -- -- > cabal build foo -- > cabal build ../bar ../bar/bar.cabal --- syntaxForm1Package :: [KnownPackage] -> Syntax syntaxForm1Package pinfo = syntaxForm1 render $ \str1 fstatus1 -> do - guardPackage str1 fstatus1 + guardPackage str1 fstatus1 p <- matchPackage pinfo str1 fstatus1 case p of KnownPackage{pinfoId} -> @@ -1044,7 +1175,6 @@ syntaxForm1Package pinfo = -- | Syntax: component -- -- > cabal build foo --- syntaxForm1Component :: [KnownComponent] -> Syntax syntaxForm1Component cs = syntaxForm1 render $ \str1 _fstatus1 -> do @@ -1059,13 +1189,12 @@ syntaxForm1Component cs = -- | Syntax: module -- -- > cabal build Data.Foo --- syntaxForm1Module :: [KnownComponent] -> Syntax syntaxForm1Module cs = - syntaxForm1 render $ \str1 _fstatus1 -> do + syntaxForm1 render $ \str1 _fstatus1 -> do guardModuleName str1 - let ms = [ (m,c) | c <- cs, m <- cinfoModules c ] - (m,c) <- matchModuleNameAnd ms str1 + let ms = [(m, c) | c <- cs, m <- cinfoModules c] + (m, c) <- matchModuleNameAnd ms str1 return (TargetComponent (cinfoPackageId c) (cinfoName c) (ModuleTarget m)) where render (TargetComponent _p _c (ModuleTarget m)) = @@ -1075,21 +1204,20 @@ syntaxForm1Module cs = -- | Syntax: file name -- -- > cabal build Data/Foo.hs bar/Main.hsc --- syntaxForm1File :: [KnownPackage] -> Syntax syntaxForm1File ps = - -- Note there's a bit of an inconsistency here vs the other syntax forms - -- for files. For the single-part syntax the target has to point to a file - -- that exists (due to our use of matchPackageDirectoryPrefix), whereas for - -- all the other forms we don't require that. + -- Note there's a bit of an inconsistency here vs the other syntax forms + -- for files. For the single-part syntax the target has to point to a file + -- that exists (due to our use of matchPackageDirectoryPrefix), whereas for + -- all the other forms we don't require that. syntaxForm1 render $ \str1 fstatus1 -> expecting "file" str1 $ do - (pkgfile, ~KnownPackage{pinfoId, pinfoComponents}) - -- always returns the KnownPackage case - <- matchPackageDirectoryPrefix ps fstatus1 - orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do - (filepath, c) <- matchComponentFile pinfoComponents pkgfile - return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) + (pkgfile, ~KnownPackage{pinfoId, pinfoComponents}) <- + -- always returns the KnownPackage case + matchPackageDirectoryPrefix ps fstatus1 + orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do + (filepath, c) <- matchComponentFile pinfoComponents pkgfile + return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) where render (TargetComponent _p _c (FileTarget f)) = [TargetStringFileStatus1 f noFileStatus] @@ -1100,7 +1228,6 @@ syntaxForm1File ps = -- | Syntax: :all -- -- > cabal build :all --- syntaxForm2MetaAll :: Syntax syntaxForm2MetaAll = syntaxForm2 render $ \str1 _fstatus1 str2 -> do @@ -1115,7 +1242,6 @@ syntaxForm2MetaAll = -- | Syntax: all : filer -- -- > cabal build all:tests --- syntaxForm2AllFilter :: Syntax syntaxForm2AllFilter = syntaxForm2 render $ \str1 _fstatus1 str2 -> do @@ -1130,11 +1256,10 @@ syntaxForm2AllFilter = -- | Syntax: package : filer -- -- > cabal build foo:tests --- syntaxForm2PackageFilter :: [KnownPackage] -> Syntax syntaxForm2PackageFilter ps = syntaxForm2 render $ \str1 fstatus1 str2 -> do - guardPackage str1 fstatus1 + guardPackage str1 fstatus1 p <- matchPackage ps str1 fstatus1 kfilter <- matchComponentKindFilter str2 case p of @@ -1152,12 +1277,11 @@ syntaxForm2PackageFilter ps = -- | Syntax: pkg : package name -- -- > cabal build pkg:foo --- syntaxForm2NamespacePackage :: [KnownPackage] -> Syntax syntaxForm2NamespacePackage pinfo = syntaxForm2 render $ \str1 _fstatus1 str2 -> do - guardNamespacePackage str1 - guardPackageName str2 + guardNamespacePackage str1 + guardPackageName str2 p <- matchPackage pinfo str2 noFileStatus case p of KnownPackage{pinfoId} -> @@ -1176,23 +1300,22 @@ syntaxForm2NamespacePackage pinfo = -- > cabal build foo:foo -- > cabal build ./foo:foo -- > cabal build ./foo.cabal:foo --- syntaxForm2PackageComponent :: [KnownPackage] -> Syntax syntaxForm2PackageComponent ps = syntaxForm2 render $ \str1 fstatus1 str2 -> do - guardPackage str1 fstatus1 - guardComponentName str2 + guardPackage str1 fstatus1 + guardComponentName str2 p <- matchPackage ps str1 fstatus1 case p of KnownPackage{pinfoId, pinfoComponents} -> orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do c <- matchComponentName pinfoComponents str2 return (TargetComponent pinfoId (cinfoName c) WholeComponent) - --TODO: the error here ought to say there's no component by that name in - -- this package, and name the package + -- TODO: the error here ought to say there's no component by that name in + -- this package, and name the package KnownPackageName pn -> - let cn = mkUnqualComponentName str2 in - return (TargetComponentUnknown pn (Left cn) WholeComponent) + let cn = mkUnqualComponentName str2 + in return (TargetComponentUnknown pn (Left cn) WholeComponent) where render (TargetComponent p c WholeComponent) = [TargetStringFileStatus2 (dispP p) noFileStatus (dispC p c)] @@ -1203,7 +1326,6 @@ syntaxForm2PackageComponent ps = -- | Syntax: namespace : component -- -- > cabal build lib:foo exe:foo --- syntaxForm2KindComponent :: [KnownComponent] -> Syntax syntaxForm2KindComponent cs = syntaxForm2 render $ \str1 _fstatus1 str2 -> do @@ -1221,18 +1343,17 @@ syntaxForm2KindComponent cs = -- > cabal build foo:Data.Foo -- > cabal build ./foo:Data.Foo -- > cabal build ./foo.cabal:Data.Foo --- syntaxForm2PackageModule :: [KnownPackage] -> Syntax syntaxForm2PackageModule ps = syntaxForm2 render $ \str1 fstatus1 str2 -> do - guardPackage str1 fstatus1 - guardModuleName str2 + guardPackage str1 fstatus1 + guardModuleName str2 p <- matchPackage ps str1 fstatus1 case p of KnownPackage{pinfoId, pinfoComponents} -> orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do - let ms = [ (m,c) | c <- pinfoComponents, m <- cinfoModules c ] - (m,c) <- matchModuleNameAnd ms str2 + let ms = [(m, c) | c <- pinfoComponents, m <- cinfoModules c] + (m, c) <- matchModuleNameAnd ms str2 return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) KnownPackageName pn -> do m <- matchModuleNameUnknown str2 @@ -1246,18 +1367,21 @@ syntaxForm2PackageModule ps = -- | Syntax: component : module -- -- > cabal build foo:Data.Foo --- syntaxForm2ComponentModule :: [KnownComponent] -> Syntax syntaxForm2ComponentModule cs = syntaxForm2 render $ \str1 _fstatus1 str2 -> do guardComponentName str1 - guardModuleName str2 + guardModuleName str2 c <- matchComponentName cs str1 orNoThingIn "component" (cinfoStrName c) $ do let ms = cinfoModules c m <- matchModuleName ms str2 - return (TargetComponent (cinfoPackageId c) (cinfoName c) - (ModuleTarget m)) + return + ( TargetComponent + (cinfoPackageId c) + (cinfoName c) + (ModuleTarget m) + ) where render (TargetComponent p c (ModuleTarget m)) = [TargetStringFileStatus2 (dispC p c) noFileStatus (dispM m)] @@ -1268,11 +1392,10 @@ syntaxForm2ComponentModule cs = -- > cabal build foo:Data/Foo.hs -- > cabal build ./foo:Data/Foo.hs -- > cabal build ./foo.cabal:Data/Foo.hs --- syntaxForm2PackageFile :: [KnownPackage] -> Syntax syntaxForm2PackageFile ps = syntaxForm2 render $ \str1 fstatus1 str2 -> do - guardPackage str1 fstatus1 + guardPackage str1 fstatus1 p <- matchPackage ps str1 fstatus1 case p of KnownPackage{pinfoId, pinfoComponents} -> @@ -1280,9 +1403,9 @@ syntaxForm2PackageFile ps = (filepath, c) <- matchComponentFile pinfoComponents str2 return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) KnownPackageName pn -> - let filepath = str2 in - -- We assume the primary library component of the package: - return (TargetComponentUnknown pn (Right $ CLibName LMainLibName) (FileTarget filepath)) + let filepath = str2 + in -- We assume the primary library component of the package: + return (TargetComponentUnknown pn (Right $ CLibName LMainLibName) (FileTarget filepath)) where render (TargetComponent p _c (FileTarget f)) = [TargetStringFileStatus2 (dispP p) noFileStatus f] @@ -1291,7 +1414,6 @@ syntaxForm2PackageFile ps = -- | Syntax: component : filename -- -- > cabal build foo:Data/Foo.hs --- syntaxForm2ComponentFile :: [KnownComponent] -> Syntax syntaxForm2ComponentFile cs = syntaxForm2 render $ \str1 _fstatus1 str2 -> do @@ -1299,8 +1421,12 @@ syntaxForm2ComponentFile cs = c <- matchComponentName cs str1 orNoThingIn "component" (cinfoStrName c) $ do (filepath, _) <- matchComponentFile [c] str2 - return (TargetComponent (cinfoPackageId c) (cinfoName c) - (FileTarget filepath)) + return + ( TargetComponent + (cinfoPackageId c) + (cinfoName c) + (FileTarget filepath) + ) where render (TargetComponent p c (FileTarget f)) = [TargetStringFileStatus2 (dispC p c) noFileStatus f] @@ -1311,7 +1437,6 @@ syntaxForm2ComponentFile cs = -- | Syntax: :all : filter -- -- > cabal build :all:tests --- syntaxForm3MetaAllFilter :: Syntax syntaxForm3MetaAllFilter = syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do @@ -1332,7 +1457,7 @@ syntaxForm3MetaCwdFilter ps = kfilter <- matchComponentKindFilter str3 return (TargetPackage TargetImplicitCwd pids (Just kfilter)) where - pids = [ pinfoId | KnownPackage{pinfoId} <- ps ] + pids = [pinfoId | KnownPackage{pinfoId} <- ps] render (TargetPackage TargetImplicitCwd _ (Just kfilter)) = [TargetStringFileStatus3 "" noFileStatus "cwd" (dispF kfilter)] render _ = [] @@ -1340,13 +1465,12 @@ syntaxForm3MetaCwdFilter ps = -- | Syntax: :pkg : package name -- -- > cabal build :pkg:foo --- syntaxForm3MetaNamespacePackage :: [KnownPackage] -> Syntax syntaxForm3MetaNamespacePackage pinfo = syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do - guardNamespaceMeta str1 - guardNamespacePackage str2 - guardPackageName str3 + guardNamespaceMeta str1 + guardNamespacePackage str2 + guardPackageName str3 p <- matchPackage pinfo str3 noFileStatus case p of KnownPackage{pinfoId} -> @@ -1365,13 +1489,12 @@ syntaxForm3MetaNamespacePackage pinfo = -- > cabal build foo:lib:foo -- > cabal build foo/:lib:foo -- > cabal build foo.cabal:lib:foo --- syntaxForm3PackageKindComponent :: [KnownPackage] -> Syntax syntaxForm3PackageKindComponent ps = syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do - guardPackage str1 fstatus1 + guardPackage str1 fstatus1 ckind <- matchComponentKind str2 - guardComponentName str3 + guardComponentName str3 p <- matchPackage ps str1 fstatus1 case p of KnownPackage{pinfoId, pinfoComponents} -> @@ -1379,8 +1502,8 @@ syntaxForm3PackageKindComponent ps = c <- matchComponentKindAndName pinfoComponents ckind str3 return (TargetComponent pinfoId (cinfoName c) WholeComponent) KnownPackageName pn -> - let cn = mkComponentName pn ckind (mkUnqualComponentName str3) in - return (TargetComponentUnknown pn (Right cn) WholeComponent) + let cn = mkComponentName pn ckind (mkUnqualComponentName str3) + in return (TargetComponentUnknown pn (Right cn) WholeComponent) where render (TargetComponent p c WholeComponent) = [TargetStringFileStatus3 (dispP p) noFileStatus (dispCK c) (dispC p c)] @@ -1393,13 +1516,12 @@ syntaxForm3PackageKindComponent ps = -- > cabal build foo:foo:Data.Foo -- > cabal build foo/:foo:Data.Foo -- > cabal build foo.cabal:foo:Data.Foo --- syntaxForm3PackageComponentModule :: [KnownPackage] -> Syntax syntaxForm3PackageComponentModule ps = syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do guardPackage str1 fstatus1 guardComponentName str2 - guardModuleName str3 + guardModuleName str3 p <- matchPackage ps str1 fstatus1 case p of KnownPackage{pinfoId, pinfoComponents} -> @@ -1410,8 +1532,8 @@ syntaxForm3PackageComponentModule ps = m <- matchModuleName ms str3 return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) KnownPackageName pn -> do - let cn = mkUnqualComponentName str2 - m <- matchModuleNameUnknown str3 + let cn = mkUnqualComponentName str2 + m <- matchModuleNameUnknown str3 return (TargetComponentUnknown pn (Left cn) (ModuleTarget m)) where render (TargetComponent p c (ModuleTarget m)) = @@ -1423,19 +1545,22 @@ syntaxForm3PackageComponentModule ps = -- | Syntax: namespace : component : module -- -- > cabal build lib:foo:Data.Foo --- syntaxForm3KindComponentModule :: [KnownComponent] -> Syntax syntaxForm3KindComponentModule cs = syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do ckind <- matchComponentKind str1 guardComponentName str2 - guardModuleName str3 + guardModuleName str3 c <- matchComponentKindAndName cs ckind str2 orNoThingIn "component" (cinfoStrName c) $ do let ms = cinfoModules c m <- matchModuleName ms str3 - return (TargetComponent (cinfoPackageId c) (cinfoName c) - (ModuleTarget m)) + return + ( TargetComponent + (cinfoPackageId c) + (cinfoName c) + (ModuleTarget m) + ) where render (TargetComponent p c (ModuleTarget m)) = [TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) (dispM m)] @@ -1446,12 +1571,11 @@ syntaxForm3KindComponentModule cs = -- > cabal build foo:foo:Data/Foo.hs -- > cabal build foo/:foo:Data/Foo.hs -- > cabal build foo.cabal:foo:Data/Foo.hs --- syntaxForm3PackageComponentFile :: [KnownPackage] -> Syntax syntaxForm3PackageComponentFile ps = syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do - guardPackage str1 fstatus1 - guardComponentName str2 + guardPackage str1 fstatus1 + guardComponentName str2 p <- matchPackage ps str1 fstatus1 case p of KnownPackage{pinfoId, pinfoComponents} -> @@ -1462,8 +1586,8 @@ syntaxForm3PackageComponentFile ps = return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) KnownPackageName pn -> let cn = mkUnqualComponentName str2 - filepath = str3 in - return (TargetComponentUnknown pn (Left cn) (FileTarget filepath)) + filepath = str3 + in return (TargetComponentUnknown pn (Left cn) (FileTarget filepath)) where render (TargetComponent p c (FileTarget f)) = [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) f] @@ -1474,7 +1598,6 @@ syntaxForm3PackageComponentFile ps = -- | Syntax: namespace : component : filename -- -- > cabal build lib:foo:Data/Foo.hs --- syntaxForm3KindComponentFile :: [KnownComponent] -> Syntax syntaxForm3KindComponentFile cs = syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do @@ -1483,8 +1606,12 @@ syntaxForm3KindComponentFile cs = c <- matchComponentKindAndName cs ckind str2 orNoThingIn "component" (cinfoStrName c) $ do (filepath, _) <- matchComponentFile [c] str3 - return (TargetComponent (cinfoPackageId c) (cinfoName c) - (FileTarget filepath)) + return + ( TargetComponent + (cinfoPackageId c) + (cinfoName c) + (FileTarget filepath) + ) where render (TargetComponent p c (FileTarget f)) = [TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) f] @@ -1494,8 +1621,8 @@ syntaxForm3NamespacePackageFilter :: [KnownPackage] -> Syntax syntaxForm3NamespacePackageFilter ps = syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do guardNamespacePackage str1 - guardPackageName str2 - p <- matchPackage ps str2 noFileStatus + guardPackageName str2 + p <- matchPackage ps str2 noFileStatus kfilter <- matchComponentKindFilter str3 case p of KnownPackage{pinfoId} -> @@ -1514,10 +1641,10 @@ syntaxForm3NamespacePackageFilter ps = syntaxForm4MetaNamespacePackageFilter :: [KnownPackage] -> Syntax syntaxForm4MetaNamespacePackageFilter ps = syntaxForm4 render $ \str1 str2 str3 str4 -> do - guardNamespaceMeta str1 + guardNamespaceMeta str1 guardNamespacePackage str2 - guardPackageName str3 - p <- matchPackage ps str3 noFileStatus + guardPackageName str3 + p <- matchPackage ps str3 noFileStatus kfilter <- matchComponentKindFilter str4 case p of KnownPackage{pinfoId} -> @@ -1534,24 +1661,23 @@ syntaxForm4MetaNamespacePackageFilter ps = -- | Syntax: :pkg : package : namespace : component -- -- > cabal build :pkg:foo:lib:foo --- syntaxForm5MetaNamespacePackageKindComponent :: [KnownPackage] -> Syntax syntaxForm5MetaNamespacePackageKindComponent ps = syntaxForm5 render $ \str1 str2 str3 str4 str5 -> do - guardNamespaceMeta str1 + guardNamespaceMeta str1 guardNamespacePackage str2 - guardPackageName str3 + guardPackageName str3 ckind <- matchComponentKind str4 - guardComponentName str5 - p <- matchPackage ps str3 noFileStatus + guardComponentName str5 + p <- matchPackage ps str3 noFileStatus case p of KnownPackage{pinfoId, pinfoComponents} -> orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do c <- matchComponentKindAndName pinfoComponents ckind str5 return (TargetComponent pinfoId (cinfoName c) WholeComponent) KnownPackageName pn -> - let cn = mkComponentName pn ckind (mkUnqualComponentName str5) in - return (TargetComponentUnknown pn (Right cn) WholeComponent) + let cn = mkComponentName pn ckind (mkUnqualComponentName str5) + in return (TargetComponentUnknown pn (Right cn) WholeComponent) where render (TargetComponent p c WholeComponent) = [TargetStringFileStatus5 "" "pkg" (dispP p) (dispCK c) (dispC p c)] @@ -1562,18 +1688,17 @@ syntaxForm5MetaNamespacePackageKindComponent ps = -- | Syntax: :pkg : package : namespace : component : module : module -- -- > cabal build :pkg:foo:lib:foo:module:Data.Foo --- syntaxForm7MetaNamespacePackageKindComponentNamespaceModule :: [KnownPackage] -> Syntax syntaxForm7MetaNamespacePackageKindComponentNamespaceModule ps = syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do - guardNamespaceMeta str1 + guardNamespaceMeta str1 guardNamespacePackage str2 - guardPackageName str3 + guardPackageName str3 ckind <- matchComponentKind str4 - guardComponentName str5 - guardNamespaceModule str6 - p <- matchPackage ps str3 noFileStatus + guardComponentName str5 + guardNamespaceModule str6 + p <- matchPackage ps str3 noFileStatus case p of KnownPackage{pinfoId, pinfoComponents} -> orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do @@ -1588,68 +1713,113 @@ syntaxForm7MetaNamespacePackageKindComponentNamespaceModule ps = return (TargetComponentUnknown pn (Right cn) (ModuleTarget m)) where render (TargetComponent p c (ModuleTarget m)) = - [TargetStringFileStatus7 "" "pkg" (dispP p) - (dispCK c) (dispC p c) - "module" (dispM m)] + [ TargetStringFileStatus7 + "" + "pkg" + (dispP p) + (dispCK c) + (dispC p c) + "module" + (dispM m) + ] render (TargetComponentUnknown pn (Right c) (ModuleTarget m)) = - [TargetStringFileStatus7 "" "pkg" (dispPN pn) - (dispCK c) (dispC' pn c) - "module" (dispM m)] + [ TargetStringFileStatus7 + "" + "pkg" + (dispPN pn) + (dispCK c) + (dispC' pn c) + "module" + (dispM m) + ] render _ = [] -- | Syntax: :pkg : package : namespace : component : file : filename -- -- > cabal build :pkg:foo:lib:foo:file:Data/Foo.hs --- syntaxForm7MetaNamespacePackageKindComponentNamespaceFile :: [KnownPackage] -> Syntax syntaxForm7MetaNamespacePackageKindComponentNamespaceFile ps = syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do - guardNamespaceMeta str1 + guardNamespaceMeta str1 guardNamespacePackage str2 - guardPackageName str3 + guardPackageName str3 ckind <- matchComponentKind str4 - guardComponentName str5 - guardNamespaceFile str6 - p <- matchPackage ps str3 noFileStatus + guardComponentName str5 + guardNamespaceFile str6 + p <- matchPackage ps str3 noFileStatus case p of KnownPackage{pinfoId, pinfoComponents} -> orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do c <- matchComponentKindAndName pinfoComponents ckind str5 orNoThingIn "component" (cinfoStrName c) $ do - (filepath,_) <- matchComponentFile [c] str7 + (filepath, _) <- matchComponentFile [c] str7 return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) KnownPackageName pn -> - let cn = mkComponentName pn ckind (mkUnqualComponentName str5) - filepath = str7 in - return (TargetComponentUnknown pn (Right cn) (FileTarget filepath)) + let cn = mkComponentName pn ckind (mkUnqualComponentName str5) + filepath = str7 + in return (TargetComponentUnknown pn (Right cn) (FileTarget filepath)) where render (TargetComponent p c (FileTarget f)) = - [TargetStringFileStatus7 "" "pkg" (dispP p) - (dispCK c) (dispC p c) - "file" f] + [ TargetStringFileStatus7 + "" + "pkg" + (dispP p) + (dispCK c) + (dispC p c) + "file" + f + ] render (TargetComponentUnknown pn (Right c) (FileTarget f)) = - [TargetStringFileStatus7 "" "pkg" (dispPN pn) - (dispCK c) (dispC' pn c) - "file" f] + [ TargetStringFileStatus7 + "" + "pkg" + (dispPN pn) + (dispCK c) + (dispC' pn c) + "file" + f + ] render _ = [] - --------------------------------------- -- Syntax utils -- type Match1 = String -> FileStatus -> Match TargetSelector -type Match2 = String -> FileStatus -> String - -> Match TargetSelector -type Match3 = String -> FileStatus -> String -> String - -> Match TargetSelector -type Match4 = String -> String -> String -> String - -> Match TargetSelector -type Match5 = String -> String -> String -> String -> String - -> Match TargetSelector -type Match7 = String -> String -> String -> String -> String -> String -> String - -> Match TargetSelector +type Match2 = + String + -> FileStatus + -> String + -> Match TargetSelector +type Match3 = + String + -> FileStatus + -> String + -> String + -> Match TargetSelector +type Match4 = + String + -> String + -> String + -> String + -> Match TargetSelector +type Match5 = + String + -> String + -> String + -> String + -> String + -> Match TargetSelector +type Match7 = + String + -> String + -> String + -> String + -> String + -> String + -> String + -> Match TargetSelector syntaxForm1 :: Renderer -> Match1 -> Syntax syntaxForm2 :: Renderer -> Match2 -> Syntax @@ -1657,44 +1827,43 @@ syntaxForm3 :: Renderer -> Match3 -> Syntax syntaxForm4 :: Renderer -> Match4 -> Syntax syntaxForm5 :: Renderer -> Match5 -> Syntax syntaxForm7 :: Renderer -> Match7 -> Syntax - syntaxForm1 render f = - Syntax QL1 match render + Syntax QL1 match render where match = \(TargetStringFileStatus1 str1 fstatus1) -> - f str1 fstatus1 + f str1 fstatus1 syntaxForm2 render f = - Syntax QL2 match render + Syntax QL2 match render where match = \(TargetStringFileStatus2 str1 fstatus1 str2) -> - f str1 fstatus1 str2 + f str1 fstatus1 str2 syntaxForm3 render f = - Syntax QL3 match render + Syntax QL3 match render where match = \(TargetStringFileStatus3 str1 fstatus1 str2 str3) -> - f str1 fstatus1 str2 str3 + f str1 fstatus1 str2 str3 syntaxForm4 render f = - Syntax QLFull match render + Syntax QLFull match render where - match (TargetStringFileStatus4 str1 str2 str3 str4) - = f str1 str2 str3 str4 + match (TargetStringFileStatus4 str1 str2 str3 str4) = + f str1 str2 str3 str4 match _ = mzero syntaxForm5 render f = - Syntax QLFull match render + Syntax QLFull match render where - match (TargetStringFileStatus5 str1 str2 str3 str4 str5) - = f str1 str2 str3 str4 str5 + match (TargetStringFileStatus5 str1 str2 str3 str4 str5) = + f str1 str2 str3 str4 str5 match _ = mzero syntaxForm7 render f = - Syntax QLFull match render + Syntax QLFull match render where - match (TargetStringFileStatus7 str1 str2 str3 str4 str5 str6 str7) - = f str1 str2 str3 str4 str5 str6 str7 + match (TargetStringFileStatus7 str1 str2 str3 str4 str5 str6 str7) = + f str1 str2 str3 str4 str5 str6 str7 match _ = mzero dispP :: Package p => p -> String @@ -1724,166 +1893,179 @@ dispF = showComponentKindFilterShort dispM :: ModuleName -> String dispM = prettyShow - ------------------------------- -- Package and component info -- -data KnownTargets = KnownTargets { - knownPackagesAll :: [KnownPackage], - knownPackagesPrimary :: [KnownPackage], - knownPackagesOther :: [KnownPackage], - knownComponentsAll :: [KnownComponent], - knownComponentsPrimary :: [KnownComponent], - knownComponentsOther :: [KnownComponent] - } - deriving Show - -data KnownPackage = - KnownPackage { - pinfoId :: PackageId, - pinfoDirectory :: Maybe (FilePath, FilePath), - pinfoPackageFile :: Maybe (FilePath, FilePath), - pinfoComponents :: [KnownComponent] - } - | KnownPackageName { - pinfoName :: PackageName - } - deriving Show - -data KnownComponent = KnownComponent { - cinfoName :: ComponentName, - cinfoStrName :: ComponentStringName, - cinfoPackageId :: PackageId, - cinfoSrcDirs :: [FilePath], - cinfoModules :: [ModuleName], - cinfoHsFiles :: [FilePath], -- other hs files (like main.hs) - cinfoCFiles :: [FilePath], - cinfoJsFiles :: [FilePath] - } - deriving Show +data KnownTargets = KnownTargets + { knownPackagesAll :: [KnownPackage] + , knownPackagesPrimary :: [KnownPackage] + , knownPackagesOther :: [KnownPackage] + , knownComponentsAll :: [KnownComponent] + , knownComponentsPrimary :: [KnownComponent] + , knownComponentsOther :: [KnownComponent] + } + deriving (Show) + +data KnownPackage + = KnownPackage + { pinfoId :: PackageId + , pinfoDirectory :: Maybe (FilePath, FilePath) + , pinfoPackageFile :: Maybe (FilePath, FilePath) + , pinfoComponents :: [KnownComponent] + } + | KnownPackageName + { pinfoName :: PackageName + } + deriving (Show) + +data KnownComponent = KnownComponent + { cinfoName :: ComponentName + , cinfoStrName :: ComponentStringName + , cinfoPackageId :: PackageId + , cinfoSrcDirs :: [FilePath] + , cinfoModules :: [ModuleName] + , cinfoHsFiles :: [FilePath] -- other hs files (like main.hs) + , cinfoCFiles :: [FilePath] + , cinfoJsFiles :: [FilePath] + } + deriving (Show) type ComponentStringName = String knownPackageName :: KnownPackage -> PackageName -knownPackageName KnownPackage{pinfoId} = packageName pinfoId +knownPackageName KnownPackage{pinfoId} = packageName pinfoId knownPackageName KnownPackageName{pinfoName} = pinfoName emptyKnownTargets :: KnownTargets emptyKnownTargets = KnownTargets [] [] [] [] [] [] -getKnownTargets :: forall m a. (Applicative m, Monad m) - => DirActions m - -> [PackageSpecifier (SourcePackage (PackageLocation a))] - -> m KnownTargets +getKnownTargets + :: forall m a + . (Applicative m, Monad m) + => DirActions m + -> [PackageSpecifier (SourcePackage (PackageLocation a))] + -> m KnownTargets getKnownTargets dirActions@DirActions{..} pkgs = do - pinfo <- traverse (collectKnownPackageInfo dirActions) pkgs - cwd <- getCurrentDirectory - (ppinfo, opinfo) <- selectPrimaryPackage cwd pinfo - return KnownTargets { - knownPackagesAll = pinfo, - knownPackagesPrimary = ppinfo, - knownPackagesOther = opinfo, - knownComponentsAll = allComponentsIn pinfo, - knownComponentsPrimary = allComponentsIn ppinfo, - knownComponentsOther = allComponentsIn opinfo - } + pinfo <- traverse (collectKnownPackageInfo dirActions) pkgs + cwd <- getCurrentDirectory + (ppinfo, opinfo) <- selectPrimaryPackage cwd pinfo + return + KnownTargets + { knownPackagesAll = pinfo + , knownPackagesPrimary = ppinfo + , knownPackagesOther = opinfo + , knownComponentsAll = allComponentsIn pinfo + , knownComponentsPrimary = allComponentsIn ppinfo + , knownComponentsOther = allComponentsIn opinfo + } where mPkgDir :: KnownPackage -> Maybe FilePath - mPkgDir KnownPackage { pinfoDirectory = Just (dir,_) } = Just dir + mPkgDir KnownPackage{pinfoDirectory = Just (dir, _)} = Just dir mPkgDir _ = Nothing - selectPrimaryPackage :: FilePath - -> [KnownPackage] - -> m ([KnownPackage], [KnownPackage]) - selectPrimaryPackage _ [] = return ([] , []) + selectPrimaryPackage + :: FilePath + -> [KnownPackage] + -> m ([KnownPackage], [KnownPackage]) + selectPrimaryPackage _ [] = return ([], []) selectPrimaryPackage cwd (pkg : packages) = do (ppinfo, opinfo) <- selectPrimaryPackage cwd packages isPkgDirCwd <- maybe (pure False) (compareFilePath dirActions cwd) (mPkgDir pkg) return (if isPkgDirCwd then (pkg : ppinfo, opinfo) else (ppinfo, pkg : opinfo)) allComponentsIn ps = - [ c | KnownPackage{pinfoComponents} <- ps, c <- pinfoComponents ] + [c | KnownPackage{pinfoComponents} <- ps, c <- pinfoComponents] - -collectKnownPackageInfo :: (Applicative m, Monad m) => DirActions m - -> PackageSpecifier (SourcePackage (PackageLocation a)) - -> m KnownPackage +collectKnownPackageInfo + :: (Applicative m, Monad m) + => DirActions m + -> PackageSpecifier (SourcePackage (PackageLocation a)) + -> m KnownPackage collectKnownPackageInfo _ (NamedPackage pkgname _props) = - return (KnownPackageName pkgname) -collectKnownPackageInfo dirActions@DirActions{..} - (SpecificSourcePackage SourcePackage { - srcpkgDescription = pkg, - srcpkgSource = loc - }) = do + return (KnownPackageName pkgname) +collectKnownPackageInfo + dirActions@DirActions{..} + ( SpecificSourcePackage + SourcePackage + { srcpkgDescription = pkg + , srcpkgSource = loc + } + ) = do (pkgdir, pkgfile) <- case loc of - --TODO: local tarballs, remote tarballs etc + -- TODO: local tarballs, remote tarballs etc LocalUnpackedPackage dir -> do dirabs <- canonicalizePath dir dirrel <- makeRelativeToCwd dirActions dirabs - --TODO: ought to get this earlier in project reading + -- TODO: ought to get this earlier in project reading let fileabs = dirabs prettyShow (packageName pkg) <.> "cabal" filerel = dirrel prettyShow (packageName pkg) <.> "cabal" exists <- doesFileExist fileabs - return ( Just (dirabs, dirrel) - , if exists then Just (fileabs, filerel) else Nothing - ) + return + ( Just (dirabs, dirrel) + , if exists then Just (fileabs, filerel) else Nothing + ) _ -> return (Nothing, Nothing) let pinfo = - KnownPackage { - pinfoId = packageId pkg, - pinfoDirectory = pkgdir, - pinfoPackageFile = pkgfile, - pinfoComponents = collectKnownComponentInfo - (flattenPackageDescription pkg) - } + KnownPackage + { pinfoId = packageId pkg + , pinfoDirectory = pkgdir + , pinfoPackageFile = pkgfile + , pinfoComponents = + collectKnownComponentInfo + (flattenPackageDescription pkg) + } return pinfo - collectKnownComponentInfo :: PackageDescription -> [KnownComponent] collectKnownComponentInfo pkg = - [ KnownComponent { - cinfoName = componentName c, - cinfoStrName = componentStringName (packageName pkg) (componentName c), - cinfoPackageId = packageId pkg, - cinfoSrcDirs = ordNub (map getSymbolicPath (hsSourceDirs bi)), - cinfoModules = ordNub (componentModules c), - cinfoHsFiles = ordNub (componentHsFiles c), - cinfoCFiles = ordNub (cSources bi), - cinfoJsFiles = ordNub (jsSources bi) - } - | c <- pkgComponents pkg - , let bi = componentBuildInfo c ] - + [ KnownComponent + { cinfoName = componentName c + , cinfoStrName = componentStringName (packageName pkg) (componentName c) + , cinfoPackageId = packageId pkg + , cinfoSrcDirs = ordNub (map getSymbolicPath (hsSourceDirs bi)) + , cinfoModules = ordNub (componentModules c) + , cinfoHsFiles = ordNub (componentHsFiles c) + , cinfoCFiles = ordNub (cSources bi) + , cinfoJsFiles = ordNub (jsSources bi) + } + | c <- pkgComponents pkg + , let bi = componentBuildInfo c + ] componentStringName :: PackageName -> ComponentName -> ComponentStringName componentStringName pkgname (CLibName LMainLibName) = prettyShow pkgname componentStringName _ (CLibName (LSubLibName name)) = unUnqualComponentName name -componentStringName _ (CFLibName name) = unUnqualComponentName name -componentStringName _ (CExeName name) = unUnqualComponentName name -componentStringName _ (CTestName name) = unUnqualComponentName name +componentStringName _ (CFLibName name) = unUnqualComponentName name +componentStringName _ (CExeName name) = unUnqualComponentName name +componentStringName _ (CTestName name) = unUnqualComponentName name componentStringName _ (CBenchName name) = unUnqualComponentName name componentModules :: Component -> [ModuleName] -- I think it's unlikely users will ask to build a requirement -- which is not mentioned locally. -componentModules (CLib lib) = explicitLibModules lib -componentModules (CFLib flib) = foreignLibModules flib -componentModules (CExe exe) = exeModules exe -componentModules (CTest test) = testModules test +componentModules (CLib lib) = explicitLibModules lib +componentModules (CFLib flib) = foreignLibModules flib +componentModules (CExe exe) = exeModules exe +componentModules (CTest test) = testModules test componentModules (CBench bench) = benchmarkModules bench componentHsFiles :: Component -> [FilePath] componentHsFiles (CExe exe) = [modulePath exe] -componentHsFiles (CTest TestSuite { - testInterface = TestSuiteExeV10 _ mainfile - }) = [mainfile] -componentHsFiles (CBench Benchmark { - benchmarkInterface = BenchmarkExeV10 _ mainfile - }) = [mainfile] -componentHsFiles _ = [] - +componentHsFiles + ( CTest + TestSuite + { testInterface = TestSuiteExeV10 _ mainfile + } + ) = [mainfile] +componentHsFiles + ( CBench + Benchmark + { benchmarkInterface = BenchmarkExeV10 _ mainfile + } + ) = [mainfile] +componentHsFiles _ = [] ------------------------------ -- Matching meta targets @@ -1910,18 +2092,17 @@ guardNamespaceFile = guardToken ["file"] "'file' namespace" guardToken :: [String] -> String -> String -> Match () guardToken tokens msg s | caseFold s `elem` tokens = increaseConfidence - | otherwise = matchErrorExpected msg s - + | otherwise = matchErrorExpected msg s ------------------------------ -- Matching component kinds -- componentKind :: ComponentName -> ComponentKind -componentKind (CLibName _) = LibKind -componentKind (CFLibName _) = FLibKind -componentKind (CExeName _) = ExeKind -componentKind (CTestName _) = TestKind +componentKind (CLibName _) = LibKind +componentKind (CFLibName _) = FLibKind +componentKind (CExeName _) = ExeKind +componentKind (CTestName _) = TestKind componentKind (CBenchName _) = BenchKind cinfoKind :: KnownComponent -> ComponentKind @@ -1929,186 +2110,195 @@ cinfoKind = componentKind . cinfoName matchComponentKind :: String -> Match ComponentKind matchComponentKind s - | s' `elem` liblabels = increaseConfidence >> return LibKind - | s' `elem` fliblabels = increaseConfidence >> return FLibKind - | s' `elem` exelabels = increaseConfidence >> return ExeKind - | s' `elem` testlabels = increaseConfidence >> return TestKind + | s' `elem` liblabels = increaseConfidence >> return LibKind + | s' `elem` fliblabels = increaseConfidence >> return FLibKind + | s' `elem` exelabels = increaseConfidence >> return ExeKind + | s' `elem` testlabels = increaseConfidence >> return TestKind | s' `elem` benchlabels = increaseConfidence >> return BenchKind - | otherwise = matchErrorExpected "component kind" s + | otherwise = matchErrorExpected "component kind" s where - s' = caseFold s - liblabels = ["lib", "library"] - fliblabels = ["flib", "foreign-library"] - exelabels = ["exe", "executable"] - testlabels = ["tst", "test", "test-suite"] + s' = caseFold s + liblabels = ["lib", "library"] + fliblabels = ["flib", "foreign-library"] + exelabels = ["exe", "executable"] + testlabels = ["tst", "test", "test-suite"] benchlabels = ["bench", "benchmark"] matchComponentKindFilter :: String -> Match ComponentKind matchComponentKindFilter s - | s' `elem` liblabels = increaseConfidence >> return LibKind - | s' `elem` fliblabels = increaseConfidence >> return FLibKind - | s' `elem` exelabels = increaseConfidence >> return ExeKind - | s' `elem` testlabels = increaseConfidence >> return TestKind + | s' `elem` liblabels = increaseConfidence >> return LibKind + | s' `elem` fliblabels = increaseConfidence >> return FLibKind + | s' `elem` exelabels = increaseConfidence >> return ExeKind + | s' `elem` testlabels = increaseConfidence >> return TestKind | s' `elem` benchlabels = increaseConfidence >> return BenchKind - | otherwise = matchErrorExpected "component kind filter" s + | otherwise = matchErrorExpected "component kind filter" s where - s' = caseFold s - liblabels = ["libs", "libraries"] - fliblabels = ["flibs", "foreign-libraries"] - exelabels = ["exes", "executables"] - testlabels = ["tests", "test-suites"] + s' = caseFold s + liblabels = ["libs", "libraries"] + fliblabels = ["flibs", "foreign-libraries"] + exelabels = ["exes", "executables"] + testlabels = ["tests", "test-suites"] benchlabels = ["benches", "benchmarks"] showComponentKind :: ComponentKind -> String -showComponentKind LibKind = "library" -showComponentKind FLibKind = "foreign library" -showComponentKind ExeKind = "executable" -showComponentKind TestKind = "test-suite" +showComponentKind LibKind = "library" +showComponentKind FLibKind = "foreign library" +showComponentKind ExeKind = "executable" +showComponentKind TestKind = "test-suite" showComponentKind BenchKind = "benchmark" showComponentKindShort :: ComponentKind -> String -showComponentKindShort LibKind = "lib" -showComponentKindShort FLibKind = "flib" -showComponentKindShort ExeKind = "exe" -showComponentKindShort TestKind = "test" +showComponentKindShort LibKind = "lib" +showComponentKindShort FLibKind = "flib" +showComponentKindShort ExeKind = "exe" +showComponentKindShort TestKind = "test" showComponentKindShort BenchKind = "bench" showComponentKindFilterShort :: ComponentKind -> String -showComponentKindFilterShort LibKind = "libs" -showComponentKindFilterShort FLibKind = "flibs" -showComponentKindFilterShort ExeKind = "exes" -showComponentKindFilterShort TestKind = "tests" +showComponentKindFilterShort LibKind = "libs" +showComponentKindFilterShort FLibKind = "flibs" +showComponentKindFilterShort ExeKind = "exes" +showComponentKindFilterShort TestKind = "tests" showComponentKindFilterShort BenchKind = "benchmarks" - ------------------------------ -- Matching package targets -- guardPackage :: String -> FileStatus -> Match () guardPackage str fstatus = - guardPackageName str - <|> guardPackageDir str fstatus - <|> guardPackageFile str fstatus - + guardPackageName str + <|> guardPackageDir str fstatus + <|> guardPackageFile str fstatus guardPackageName :: String -> Match () guardPackageName s | validPackageName s = increaseConfidence - | otherwise = matchErrorExpected "package name" s + | otherwise = matchErrorExpected "package name" s validPackageName :: String -> Bool validPackageName s = - all validPackageNameChar s + all validPackageNameChar s && not (null s) where validPackageNameChar c = isAlphaNum c || c == '-' - guardPackageDir :: String -> FileStatus -> Match () guardPackageDir _ (FileStatusExistsDir _) = increaseConfidence guardPackageDir str _ = matchErrorExpected "package directory" str - guardPackageFile :: String -> FileStatus -> Match () guardPackageFile _ (FileStatusExistsFile file) - | takeExtension file == ".cabal" - = increaseConfidence + | takeExtension file == ".cabal" = + increaseConfidence guardPackageFile str _ = matchErrorExpected "package .cabal file" str - matchPackage :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage matchPackage pinfo = \str fstatus -> - orNoThingIn "project" "" $ - matchPackageName pinfo str - (matchPackageNameUnknown str - <|> matchPackageDir pinfo str fstatus - <|> matchPackageFile pinfo str fstatus) - + orNoThingIn "project" "" $ + matchPackageName pinfo str + ( matchPackageNameUnknown str + <|> matchPackageDir pinfo str fstatus + <|> matchPackageFile pinfo str fstatus + ) matchPackageName :: [KnownPackage] -> String -> Match KnownPackage matchPackageName ps = \str -> do - guard (validPackageName str) - orNoSuchThing "package" str - (map (prettyShow . knownPackageName) ps) $ - increaseConfidenceFor $ - matchInexactly caseFold (prettyShow . knownPackageName) ps str - + guard (validPackageName str) + orNoSuchThing + "package" + str + (map (prettyShow . knownPackageName) ps) + $ increaseConfidenceFor + $ matchInexactly caseFold (prettyShow . knownPackageName) ps str matchPackageNameUnknown :: String -> Match KnownPackage matchPackageNameUnknown str = do - pn <- matchParse str - unknownMatch (KnownPackageName pn) - - -matchPackageDir :: [KnownPackage] - -> String -> FileStatus -> Match KnownPackage + pn <- matchParse str + unknownMatch (KnownPackageName pn) + +matchPackageDir + :: [KnownPackage] + -> String + -> FileStatus + -> Match KnownPackage matchPackageDir ps = \str fstatus -> - case fstatus of - FileStatusExistsDir canondir -> - orNoSuchThing "package directory" str (map (snd . fst) dirs) $ - increaseConfidenceFor $ - fmap snd $ matchExactly (fst . fst) dirs canondir - _ -> mzero + case fstatus of + FileStatusExistsDir canondir -> + orNoSuchThing "package directory" str (map (snd . fst) dirs) $ + increaseConfidenceFor $ + fmap snd $ + matchExactly (fst . fst) dirs canondir + _ -> mzero where - dirs = [ ((dabs,drel),p) - | p@KnownPackage{ pinfoDirectory = Just (dabs,drel) } <- ps ] - + dirs = + [ ((dabs, drel), p) + | p@KnownPackage{pinfoDirectory = Just (dabs, drel)} <- ps + ] matchPackageFile :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage matchPackageFile ps = \str fstatus -> do - case fstatus of - FileStatusExistsFile canonfile -> - orNoSuchThing "package .cabal file" str (map (snd . fst) files) $ - increaseConfidenceFor $ - fmap snd $ matchExactly (fst . fst) files canonfile - _ -> mzero + case fstatus of + FileStatusExistsFile canonfile -> + orNoSuchThing "package .cabal file" str (map (snd . fst) files) $ + increaseConfidenceFor $ + fmap snd $ + matchExactly (fst . fst) files canonfile + _ -> mzero where - files = [ ((fabs,frel),p) - | p@KnownPackage{ pinfoPackageFile = Just (fabs,frel) } <- ps ] + files = + [ ((fabs, frel), p) + | p@KnownPackage{pinfoPackageFile = Just (fabs, frel)} <- ps + ] ---TODO: test outcome when dir exists but doesn't match any known one +-- TODO: test outcome when dir exists but doesn't match any known one ---TODO: perhaps need another distinction, vs no such thing, point is the +-- TODO: perhaps need another distinction, vs no such thing, point is the -- thing is not known, within the project, but could be outside project - ------------------------------ -- Matching component targets -- - guardComponentName :: String -> Match () guardComponentName s | all validComponentChar s - && not (null s) = increaseConfidence - | otherwise = matchErrorExpected "component name" s + && not (null s) = + increaseConfidence + | otherwise = matchErrorExpected "component name" s where - validComponentChar c = isAlphaNum c || c == '.' - || c == '_' || c == '-' || c == '\'' - + validComponentChar c = + isAlphaNum c + || c == '.' + || c == '_' + || c == '-' + || c == '\'' matchComponentName :: [KnownComponent] -> String -> Match KnownComponent matchComponentName cs str = - orNoSuchThing "component" str (map cinfoStrName cs) - $ increaseConfidenceFor - $ matchInexactly caseFold cinfoStrName cs str - + orNoSuchThing "component" str (map cinfoStrName cs) $ + increaseConfidenceFor $ + matchInexactly caseFold cinfoStrName cs str -matchComponentKindAndName :: [KnownComponent] -> ComponentKind -> String - -> Match KnownComponent +matchComponentKindAndName + :: [KnownComponent] + -> ComponentKind + -> String + -> Match KnownComponent matchComponentKindAndName cs ckind str = - orNoSuchThing (showComponentKind ckind ++ " component") str - (map render cs) - $ increaseConfidenceFor - $ matchInexactly (\(ck, cn) -> (ck, caseFold cn)) - (\c -> (cinfoKind c, cinfoStrName c)) - cs - (ckind, str) + orNoSuchThing + (showComponentKind ckind ++ " component") + str + (map render cs) + $ increaseConfidenceFor + $ matchInexactly + (\(ck, cn) -> (ck, caseFold cn)) + (\c -> (cinfoKind c, cinfoStrName c)) + cs + (ckind, str) where render c = showComponentKindShort (cinfoKind c) ++ ":" ++ cinfoStrName c - ------------------------------ -- Matching module targets -- @@ -2116,109 +2306,119 @@ matchComponentKindAndName cs ckind str = guardModuleName :: String -> Match () guardModuleName s = case simpleParsec s :: Maybe ModuleName of - Just _ -> increaseConfidence - _ | all validModuleChar s - && not (null s) -> return () - | otherwise -> matchErrorExpected "module name" s - where - validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\'' - + Just _ -> increaseConfidence + _ + | all validModuleChar s + && not (null s) -> + return () + | otherwise -> matchErrorExpected "module name" s + where + validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\'' matchModuleName :: [ModuleName] -> String -> Match ModuleName matchModuleName ms str = - orNoSuchThing "module" str (map prettyShow ms) - $ increaseConfidenceFor - $ matchInexactly caseFold prettyShow ms str - + orNoSuchThing "module" str (map prettyShow ms) $ + increaseConfidenceFor $ + matchInexactly caseFold prettyShow ms str matchModuleNameAnd :: [(ModuleName, a)] -> String -> Match (ModuleName, a) matchModuleNameAnd ms str = - orNoSuchThing "module" str (map (prettyShow . fst) ms) - $ increaseConfidenceFor - $ matchInexactly caseFold (prettyShow . fst) ms str - + orNoSuchThing "module" str (map (prettyShow . fst) ms) $ + increaseConfidenceFor $ + matchInexactly caseFold (prettyShow . fst) ms str matchModuleNameUnknown :: String -> Match ModuleName matchModuleNameUnknown str = - expecting "module" str - $ increaseConfidenceFor - $ matchParse str - + expecting "module" str $ + increaseConfidenceFor $ + matchParse str ------------------------------ -- Matching file targets -- -matchPackageDirectoryPrefix :: [KnownPackage] -> FileStatus - -> Match (FilePath, KnownPackage) +matchPackageDirectoryPrefix + :: [KnownPackage] + -> FileStatus + -> Match (FilePath, KnownPackage) matchPackageDirectoryPrefix ps (FileStatusExistsFile filepath) = - increaseConfidenceFor $ - matchDirectoryPrefix pkgdirs filepath + increaseConfidenceFor $ + matchDirectoryPrefix pkgdirs filepath where - pkgdirs = [ (dir, p) - | p@KnownPackage { pinfoDirectory = Just (dir,_) } <- ps ] + pkgdirs = + [ (dir, p) + | p@KnownPackage{pinfoDirectory = Just (dir, _)} <- ps + ] matchPackageDirectoryPrefix _ _ = mzero - -matchComponentFile :: [KnownComponent] -> String - -> Match (FilePath, KnownComponent) +matchComponentFile + :: [KnownComponent] + -> String + -> Match (FilePath, KnownComponent) matchComponentFile cs str = - orNoSuchThing "file" str [] $ - matchComponentModuleFile cs str - <|> matchComponentOtherFile cs str - - -matchComponentOtherFile :: [KnownComponent] -> String - -> Match (FilePath, KnownComponent) + orNoSuchThing "file" str [] $ + matchComponentModuleFile cs str + <|> matchComponentOtherFile cs str + +matchComponentOtherFile + :: [KnownComponent] + -> String + -> Match (FilePath, KnownComponent) matchComponentOtherFile cs = - matchFile - [ (normalise (srcdir file), c) - | c <- cs - , srcdir <- cinfoSrcDirs c - , file <- cinfoHsFiles c - ++ cinfoCFiles c - ++ cinfoJsFiles c - ] - . normalise - - -matchComponentModuleFile :: [KnownComponent] -> String - -> Match (FilePath, KnownComponent) + matchFile + [ (normalise (srcdir file), c) + | c <- cs + , srcdir <- cinfoSrcDirs c + , file <- + cinfoHsFiles c + ++ cinfoCFiles c + ++ cinfoJsFiles c + ] + . normalise + +matchComponentModuleFile + :: [KnownComponent] + -> String + -> Match (FilePath, KnownComponent) matchComponentModuleFile cs str = do - matchFile - [ (normalise (d toFilePath m), c) - | c <- cs - , d <- cinfoSrcDirs c - , m <- cinfoModules c - ] - (dropExtension (normalise str)) -- Drop the extension because FileTarget - -- is stored without the extension + matchFile + [ (normalise (d toFilePath m), c) + | c <- cs + , d <- cinfoSrcDirs c + , m <- cinfoModules c + ] + (dropExtension (normalise str)) -- Drop the extension because FileTarget + -- is stored without the extension -- utils -- | Compare two filepaths for equality using DirActions' canonicalizePath -- to normalize AND canonicalize filepaths before comparison. -compareFilePath :: (Applicative m, Monad m) => DirActions m - -> FilePath -> FilePath -> m Bool +compareFilePath + :: (Applicative m, Monad m) + => DirActions m + -> FilePath + -> FilePath + -> m Bool compareFilePath DirActions{..} fp1 fp2 | equalFilePath fp1 fp2 = pure True -- avoid unnecessary IO if we can match earlier | otherwise = do - c1 <- canonicalizePath fp1 - c2 <- canonicalizePath fp2 - pure $ equalFilePath c1 c2 - + c1 <- canonicalizePath fp1 + c2 <- canonicalizePath fp2 + pure $ equalFilePath c1 c2 matchFile :: [(FilePath, a)] -> FilePath -> Match (FilePath, a) matchFile fs = - increaseConfidenceFor + increaseConfidenceFor . matchInexactly caseFold fst fs matchDirectoryPrefix :: [(FilePath, a)] -> FilePath -> Match (FilePath, a) matchDirectoryPrefix dirs filepath = - tryEach $ - [ (file, x) - | (dir,x) <- dirs - , file <- maybeToList (stripDirectory dir) ] + tryEach $ + [ (file, x) + | (dir, x) <- dirs + , file <- maybeToList (stripDirectory dir) + ] where stripDirectory :: FilePath -> Maybe FilePath stripDirectory dir = @@ -2226,7 +2426,6 @@ matchDirectoryPrefix dirs filepath = filepathsplit = splitDirectories filepath - ------------------------------ -- Matching monad -- @@ -2237,61 +2436,65 @@ matchDirectoryPrefix dirs filepath = -- There are various matcher primitives ('matchExactly', 'matchInexactly'), -- ways to combine matchers ('matchPlus', 'matchPlusShadowing') and finally we -- can run a matcher against an input using 'findMatch'. --- -data Match a = NoMatch !Confidence [MatchError] - | Match !MatchClass !Confidence [a] - deriving Show +data Match a + = NoMatch !Confidence [MatchError] + | Match !MatchClass !Confidence [a] + deriving (Show) -- | The kind of match, inexact or exact. We keep track of this so we can -- prefer exact over inexact matches. The 'Ord' here is important: we try -- to maximise this, so 'Exact' is the top value and 'Inexact' the bottom. --- -data MatchClass = Unknown -- ^ Matches an unknown thing e.g. parses as a package - -- name without it being a specific known package - | Inexact -- ^ Matches a known thing inexactly - -- e.g. matches a known package case insensitively - | Exact -- ^ Exactly matches a known thing, - -- e.g. matches a known package case sensitively +data MatchClass + = -- | Matches an unknown thing e.g. parses as a package + -- name without it being a specific known package + Unknown + | -- | Matches a known thing inexactly + -- e.g. matches a known package case insensitively + Inexact + | -- | Exactly matches a known thing, + -- e.g. matches a known package case sensitively + Exact deriving (Show, Eq, Ord) type Confidence = Int -data MatchError = MatchErrorExpected String String -- thing got - | MatchErrorNoSuch String String [String] -- thing got alts - | MatchErrorIn String String MatchError -- kind thing +data MatchError + = MatchErrorExpected String String -- thing got + | MatchErrorNoSuch String String [String] -- thing got alts + | MatchErrorIn String String MatchError -- kind thing deriving (Show, Eq) - instance Functor Match where - fmap _ (NoMatch d ms) = NoMatch d ms - fmap f (Match m d xs) = Match m d (fmap f xs) + fmap _ (NoMatch d ms) = NoMatch d ms + fmap f (Match m d xs) = Match m d (fmap f xs) instance Applicative Match where - pure a = Match Exact 0 [a] - (<*>) = ap + pure a = Match Exact 0 [a] + (<*>) = ap instance Alternative Match where - empty = NoMatch 0 [] - (<|>) = matchPlus + empty = NoMatch 0 [] + (<|>) = matchPlus instance Monad Match where - return = pure - NoMatch d ms >>= _ = NoMatch d ms - Match m d xs >>= f = - -- To understand this, it needs to be read in context with the - -- implementation of 'matchPlus' below - case msum (map f xs) of - Match m' d' xs' -> Match (min m m') (d + d') xs' - -- The minimum match class is the one we keep. The match depth is - -- tracked but not used in the Match case. - - NoMatch d' ms -> NoMatch (d + d') ms - -- Here is where we transfer the depth we were keeping track of in - -- the Match case over to the NoMatch case where it finally gets used. + return = pure + NoMatch d ms >>= _ = NoMatch d ms + Match m d xs >>= f = + -- To understand this, it needs to be read in context with the + -- implementation of 'matchPlus' below + case msum (map f xs) of + Match m' d' xs' -> Match (min m m') (d + d') xs' + -- The minimum match class is the one we keep. The match depth is + -- tracked but not used in the Match case. + + NoMatch d' ms -> NoMatch (d + d') ms + +-- Here is where we transfer the depth we were keeping track of in +-- the Match case over to the NoMatch case where it finally gets used. instance MonadPlus Match where - mzero = empty - mplus = matchPlus + mzero = empty + mplus = matchPlus () :: Match a -> Match a -> Match a () = matchPlusShadowing @@ -2303,17 +2506,16 @@ infixl 3 -- ambiguous matches. -- -- This operator is associative, has unit 'mzero' and is also commutative. --- matchPlus :: Match a -> Match a -> Match a -matchPlus a@(Match _ _ _ ) (NoMatch _ _) = a -matchPlus (NoMatch _ _ ) b@(Match _ _ _) = b +matchPlus a@(Match _ _ _) (NoMatch _ _) = a +matchPlus (NoMatch _ _) b@(Match _ _ _) = b matchPlus a@(NoMatch d_a ms_a) b@(NoMatch d_b ms_b) - | d_a > d_b = a -- We only really make use of the depth in the NoMatch case. + | d_a > d_b = a -- We only really make use of the depth in the NoMatch case. | d_a < d_b = b | otherwise = NoMatch d_a (ms_a ++ ms_b) matchPlus a@(Match m_a d_a xs_a) b@(Match m_b d_b xs_b) - | m_a > m_b = a -- exact over inexact - | m_a < m_b = b -- exact over inexact + | m_a > m_b = a -- exact over inexact + | m_a < m_b = b -- exact over inexact | otherwise = Match m_a (max d_a d_b) (xs_a ++ xs_b) -- | Combine two matchers. This is similar to 'matchPlus' with the @@ -2321,33 +2523,31 @@ matchPlus a@(Match m_a d_a xs_a) b@(Match m_b d_b xs_b) -- match on the right. Inexact matches are still collected however. -- -- This operator is associative, has unit 'mzero' and is not commutative. --- matchPlusShadowing :: Match a -> Match a -> Match a matchPlusShadowing a@(Match Exact _ _) _ = a -matchPlusShadowing a b = matchPlus a b - +matchPlusShadowing a b = matchPlus a b ------------------------------ -- Various match primitives -- matchErrorExpected :: String -> String -> Match a -matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got] +matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got] matchErrorNoSuch :: String -> String -> [String] -> Match a matchErrorNoSuch thing got alts = NoMatch 0 [MatchErrorNoSuch thing got alts] expecting :: String -> String -> Match a -> Match a expecting thing got (NoMatch 0 _) = matchErrorExpected thing got -expecting _ _ m = m +expecting _ _ m = m orNoSuchThing :: String -> String -> [String] -> Match a -> Match a orNoSuchThing thing got alts (NoMatch 0 _) = matchErrorNoSuch thing got alts -orNoSuchThing _ _ _ m = m +orNoSuchThing _ _ _ m = m orNoThingIn :: String -> String -> Match a -> Match a orNoThingIn kind name (NoMatch n ms) = - NoMatch n [ MatchErrorIn kind name m | m <- ms ] + NoMatch n [MatchErrorIn kind name m | m <- ms] orNoThingIn _ _ m = m increaseConfidence :: Match () @@ -2357,16 +2557,13 @@ increaseConfidenceFor :: Match a -> Match a increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r nubMatchesBy :: (a -> a -> Bool) -> Match a -> Match a -nubMatchesBy _ (NoMatch d msgs) = NoMatch d msgs -nubMatchesBy eq (Match m d xs) = Match m d (nubBy eq xs) +nubMatchesBy _ (NoMatch d msgs) = NoMatch d msgs +nubMatchesBy eq (Match m d xs) = Match m d (nubBy eq xs) -- | Lift a list of matches to an exact match. --- exactMatches, inexactMatches :: [a] -> Match a - exactMatches [] = mzero exactMatches xs = Match Exact 0 xs - inexactMatches [] = mzero inexactMatches xs = Match Inexact 0 xs @@ -2376,7 +2573,6 @@ unknownMatch x = Match Unknown 0 [x] tryEach :: [a] -> Match a tryEach = exactMatches - ------------------------------ -- Top level match runner -- @@ -2384,23 +2580,23 @@ tryEach = exactMatches -- | Given a matcher and a key to look up, use the matcher to find all the -- possible matches. There may be 'None', a single 'Unambiguous' match or -- you may have an 'Ambiguous' match with several possibilities. --- findMatch :: Match a -> MaybeAmbiguous a findMatch match = case match of NoMatch _ msgs -> None msgs - Match _ _ [x] -> Unambiguous x - Match m d [] -> error $ "findMatch: impossible: " ++ show match' - where match' = Match m d [] :: Match () - -- TODO: Maybe use Data.List.NonEmpty inside - -- Match so that this case would be correct - -- by construction? - Match m _ xs -> Ambiguous m xs - -data MaybeAmbiguous a = None [MatchError] - | Unambiguous a - | Ambiguous MatchClass [a] - deriving Show - + Match _ _ [x] -> Unambiguous x + Match m d [] -> error $ "findMatch: impossible: " ++ show match' + where + match' = Match m d [] :: Match () + -- TODO: Maybe use Data.List.NonEmpty inside + -- Match so that this case would be correct + -- by construction? + Match m _ xs -> Ambiguous m xs + +data MaybeAmbiguous a + = None [MatchError] + | Unambiguous a + | Ambiguous MatchClass [a] + deriving (Show) ------------------------------ -- Basic matchers @@ -2408,14 +2604,13 @@ data MaybeAmbiguous a = None [MatchError] -- | A primitive matcher that looks up a value in a finite 'Map'. The -- value must match exactly. --- matchExactly :: Ord k => (a -> k) -> [a] -> (k -> Match a) matchExactly key xs = - \k -> case Map.lookup k m of - Nothing -> mzero - Just ys -> exactMatches ys + \k -> case Map.lookup k m of + Nothing -> mzero + Just ys -> exactMatches ys where - m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ] + m = Map.fromListWith (++) [(key x, [x]) | x <- xs] -- | A primitive matcher that looks up a value in a finite 'Map'. It checks -- for an exact or inexact match. We get an inexact match if the match @@ -2425,17 +2620,20 @@ matchExactly key xs = -- So for example if we used string case fold as the canonicalisation -- function, then we would get case insensitive matching (but it will still -- report an exact match when the case matches too). --- -matchInexactly :: (Ord k, Ord k') => (k -> k') -> (a -> k) - -> [a] -> (k -> Match a) +matchInexactly + :: (Ord k, Ord k') + => (k -> k') + -> (a -> k) + -> [a] + -> (k -> Match a) matchInexactly cannonicalise key xs = - \k -> case Map.lookup k m of - Just ys -> exactMatches ys - Nothing -> case Map.lookup (cannonicalise k) m' of - Just ys -> inexactMatches ys - Nothing -> mzero + \k -> case Map.lookup k m of + Just ys -> exactMatches ys + Nothing -> case Map.lookup (cannonicalise k) m' of + Just ys -> inexactMatches ys + Nothing -> mzero where - m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ] + m = Map.fromListWith (++) [(key x, [x]) | x <- xs] -- the map of canonicalised keys to groups of inexact matches m' = Map.mapKeysWith (++) cannonicalise m @@ -2443,7 +2641,6 @@ matchInexactly cannonicalise key xs = matchParse :: Parsec a => String -> Match a matchParse = maybe mzero return . simpleParsec - ------------------------------ -- Utils -- @@ -2454,22 +2651,21 @@ caseFold = lowercase -- | Make a 'ComponentName' given an 'UnqualComponentName' and knowing the -- 'ComponentKind'. We also need the 'PackageName' to distinguish the package's -- primary library from named private libraries. --- -mkComponentName :: PackageName - -> ComponentKind - -> UnqualComponentName - -> ComponentName +mkComponentName + :: PackageName + -> ComponentKind + -> UnqualComponentName + -> ComponentName mkComponentName pkgname ckind ucname = case ckind of LibKind - | packageNameToUnqualComponentName pkgname == ucname - -> CLibName LMainLibName + | packageNameToUnqualComponentName pkgname == ucname -> + CLibName LMainLibName | otherwise -> CLibName $ LSubLibName ucname - FLibKind -> CFLibName ucname - ExeKind -> CExeName ucname - TestKind -> CTestName ucname - BenchKind -> CBenchName ucname - + FLibKind -> CFLibName ucname + ExeKind -> CExeName ucname + TestKind -> CTestName ucname + BenchKind -> CBenchName ucname ------------------------------ -- Example inputs diff --git a/cabal-install/src/Distribution/Client/Targets.hs b/cabal-install/src/Distribution/Client/Targets.hs index 8c6d866d14c..71ee03d8bca 100644 --- a/cabal-install/src/Distribution/Client/Targets.hs +++ b/cabal-install/src/Distribution/Client/Targets.hs @@ -1,9 +1,14 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.Targets -- Copyright : (c) Duncan Coutts 2011 @@ -12,540 +17,590 @@ -- Maintainer : duncan@community.haskell.org -- -- Handling for user-specified targets ------------------------------------------------------------------------------ -module Distribution.Client.Targets ( - -- * User targets - UserTarget(..), - readUserTargets, - - -- * Resolving user targets to package specifiers - resolveUserTargets, - - -- ** Detailed interface - UserTargetProblem(..), - readUserTarget, - reportUserTargetProblems, - expandUserTarget, - - PackageTarget(..), - fetchPackageTarget, - readPackageTarget, - - PackageTargetProblem(..), - reportPackageTargetProblems, - - disambiguatePackageTargets, - disambiguatePackageName, - - -- * User constraints - UserQualifier(..), - UserConstraintScope(..), - UserConstraint(..), - userConstraintPackageName, - readUserConstraint, - userToPackageConstraint, - +module Distribution.Client.Targets + ( -- * User targets + UserTarget (..) + , readUserTargets + + -- * Resolving user targets to package specifiers + , resolveUserTargets + + -- ** Detailed interface + , UserTargetProblem (..) + , readUserTarget + , reportUserTargetProblems + , expandUserTarget + , PackageTarget (..) + , fetchPackageTarget + , readPackageTarget + , PackageTargetProblem (..) + , reportPackageTargetProblems + , disambiguatePackageTargets + , disambiguatePackageName + + -- * User constraints + , UserQualifier (..) + , UserConstraintScope (..) + , UserConstraint (..) + , userConstraintPackageName + , readUserConstraint + , userToPackageConstraint ) where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () -import Distribution.Package - ( Package(..), PackageName, unPackageName, mkPackageName - , packageName ) import Distribution.Client.Types - ( PackageLocation(..), ResolvedPkgLoc, UnresolvedSourcePackage - , PackageSpecifier(..) ) - -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackageConstraint -import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.PackageIndex (PackageIndex) + ( PackageLocation (..) + , PackageSpecifier (..) + , ResolvedPkgLoc + , UnresolvedSourcePackage + ) +import Distribution.Package + ( Package (..) + , PackageName + , mkPackageName + , packageName + , unPackageName + ) + +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.PackageIndex (PackageIndex) import qualified Distribution.Solver.Types.PackageIndex as PackageIndex -import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.SourcePackage -import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar -import qualified Distribution.Client.Tar as Tar import Distribution.Client.FetchUtils -import Distribution.Client.Utils ( tryFindPackageDesc ) import Distribution.Client.GlobalFlags - ( RepoContext(..) ) + ( RepoContext (..) + ) +import qualified Distribution.Client.Tar as Tar +import Distribution.Client.Utils (tryFindPackageDesc) import Distribution.Types.PackageVersionConstraint - ( PackageVersionConstraint (..) ) + ( PackageVersionConstraint (..) + ) import Distribution.PackageDescription - ( GenericPackageDescription ) + ( GenericPackageDescription + ) +import Distribution.Simple.Utils + ( die' + , lowercase + ) import Distribution.Types.Flag - ( parsecFlagAssignmentNonEmpty ) + ( parsecFlagAssignmentNonEmpty + ) import Distribution.Version - ( isAnyVersion ) -import Distribution.Simple.Utils - ( die', lowercase ) + ( isAnyVersion + ) import Distribution.PackageDescription.Parsec - ( parseGenericPackageDescriptionMaybe ) + ( parseGenericPackageDescriptionMaybe + ) import Distribution.Simple.PackageDescription - ( readGenericPackageDescription ) + ( readGenericPackageDescription + ) -import qualified Data.Map as Map import qualified Data.ByteString.Lazy as BS +import qualified Data.Map as Map import qualified Distribution.Client.GZipUtils as GZipUtils import qualified Distribution.Compat.CharParsing as P -import System.FilePath - ( takeExtension, dropExtension, takeDirectory, splitPath ) -import System.Directory - ( doesFileExist, doesDirectoryExist ) import Network.URI - ( URI(..), URIAuth(..), parseAbsoluteURI ) + ( URI (..) + , URIAuth (..) + , parseAbsoluteURI + ) +import System.Directory + ( doesDirectoryExist + , doesFileExist + ) +import System.FilePath + ( dropExtension + , splitPath + , takeDirectory + , takeExtension + ) -- ------------------------------------------------------------ + -- * User targets + -- ------------------------------------------------------------ -- | Various ways that a user may specify a package or package collection. --- -data UserTarget = - - -- | A partially specified package, identified by name and possibly with - -- an exact version or a version constraint. - -- - -- > cabal install foo - -- > cabal install foo-1.0 - -- > cabal install 'foo < 2' - -- - UserTargetNamed PackageVersionConstraint - - -- | A specific package that is unpacked in a local directory, often the - -- current directory. - -- - -- > cabal install . - -- > cabal install ../lib/other - -- - -- * Note: in future, if multiple @.cabal@ files are allowed in a single - -- directory then this will refer to the collection of packages. - -- - | UserTargetLocalDir FilePath - - -- | A specific local unpacked package, identified by its @.cabal@ file. - -- - -- > cabal install foo.cabal - -- > cabal install ../lib/other/bar.cabal - -- - | UserTargetLocalCabalFile FilePath - - -- | A specific package that is available as a local tarball file - -- - -- > cabal install dist/foo-1.0.tar.gz - -- > cabal install ../build/baz-1.0.tar.gz - -- - | UserTargetLocalTarball FilePath - - -- | A specific package that is available as a remote tarball file - -- - -- > cabal install http://code.haskell.org/~user/foo/foo-0.9.tar.gz - -- - | UserTargetRemoteTarball URI - deriving (Show,Eq) - +data UserTarget + = -- | A partially specified package, identified by name and possibly with + -- an exact version or a version constraint. + -- + -- > cabal install foo + -- > cabal install foo-1.0 + -- > cabal install 'foo < 2' + UserTargetNamed PackageVersionConstraint + | -- | A specific package that is unpacked in a local directory, often the + -- current directory. + -- + -- > cabal install . + -- > cabal install ../lib/other + -- + -- * Note: in future, if multiple @.cabal@ files are allowed in a single + -- directory then this will refer to the collection of packages. + UserTargetLocalDir FilePath + | -- | A specific local unpacked package, identified by its @.cabal@ file. + -- + -- > cabal install foo.cabal + -- > cabal install ../lib/other/bar.cabal + UserTargetLocalCabalFile FilePath + | -- | A specific package that is available as a local tarball file + -- + -- > cabal install dist/foo-1.0.tar.gz + -- > cabal install ../build/baz-1.0.tar.gz + UserTargetLocalTarball FilePath + | -- | A specific package that is available as a remote tarball file + -- + -- > cabal install http://code.haskell.org/~user/foo/foo-0.9.tar.gz + UserTargetRemoteTarball URI + deriving (Show, Eq) -- ------------------------------------------------------------ + -- * Parsing and checking user targets + -- ------------------------------------------------------------ readUserTargets :: Verbosity -> [String] -> IO [UserTarget] readUserTargets verbosity targetStrs = do - (problems, targets) <- liftM partitionEithers - (traverse readUserTarget targetStrs) - reportUserTargetProblems verbosity problems - return targets - + (problems, targets) <- + liftM + partitionEithers + (traverse readUserTarget targetStrs) + reportUserTargetProblems verbosity problems + return targets data UserTargetProblem - = UserTargetUnexpectedFile String - | UserTargetNonexistantFile String - | UserTargetUnexpectedUriScheme String - | UserTargetUnrecognisedUri String - | UserTargetUnrecognised String - deriving Show + = UserTargetUnexpectedFile String + | UserTargetNonexistantFile String + | UserTargetUnexpectedUriScheme String + | UserTargetUnrecognisedUri String + | UserTargetUnrecognised String + deriving (Show) readUserTarget :: String -> IO (Either UserTargetProblem UserTarget) readUserTarget targetstr = - case eitherParsec targetstr of - Right dep -> return (Right (UserTargetNamed dep)) - Left _err -> do - fileTarget <- testFileTargets targetstr - case fileTarget of - Just target -> return target - Nothing -> - case testUriTargets targetstr of - Just target -> return target - Nothing -> return (Left (UserTargetUnrecognised targetstr)) + case eitherParsec targetstr of + Right dep -> return (Right (UserTargetNamed dep)) + Left _err -> do + fileTarget <- testFileTargets targetstr + case fileTarget of + Just target -> return target + Nothing -> + case testUriTargets targetstr of + Just target -> return target + Nothing -> return (Left (UserTargetUnrecognised targetstr)) where testFileTargets :: FilePath -> IO (Maybe (Either UserTargetProblem UserTarget)) testFileTargets filename = do - isDir <- doesDirectoryExist filename + isDir <- doesDirectoryExist filename isFile <- doesFileExist filename parentDirExists <- case takeDirectory filename of - [] -> return False - dir -> doesDirectoryExist dir + [] -> return False + dir -> doesDirectoryExist dir let result :: Maybe (Either UserTargetProblem UserTarget) result - | isDir - = Just (Right (UserTargetLocalDir filename)) - - | isFile && extensionIsTarGz filename - = Just (Right (UserTargetLocalTarball filename)) - - | isFile && takeExtension filename == ".cabal" - = Just (Right (UserTargetLocalCabalFile filename)) - - | isFile - = Just (Left (UserTargetUnexpectedFile filename)) - - | parentDirExists - = Just (Left (UserTargetNonexistantFile filename)) - - | otherwise - = Nothing + | isDir = + Just (Right (UserTargetLocalDir filename)) + | isFile && extensionIsTarGz filename = + Just (Right (UserTargetLocalTarball filename)) + | isFile && takeExtension filename == ".cabal" = + Just (Right (UserTargetLocalCabalFile filename)) + | isFile = + Just (Left (UserTargetUnexpectedFile filename)) + | parentDirExists = + Just (Left (UserTargetNonexistantFile filename)) + | otherwise = + Nothing return result testUriTargets :: String -> Maybe (Either UserTargetProblem UserTarget) testUriTargets str = case parseAbsoluteURI str of - Just uri@URI { - uriScheme = scheme, - uriAuthority = Just URIAuth { uriRegName = host } - } - | scheme /= "http:" && scheme /= "https:" -> - Just (Left (UserTargetUnexpectedUriScheme targetstr)) - - | null host -> - Just (Left (UserTargetUnrecognisedUri targetstr)) - - | otherwise -> - Just (Right (UserTargetRemoteTarball uri)) + Just + uri@URI + { uriScheme = scheme + , uriAuthority = Just URIAuth{uriRegName = host} + } + | scheme /= "http:" && scheme /= "https:" -> + Just (Left (UserTargetUnexpectedUriScheme targetstr)) + | null host -> + Just (Left (UserTargetUnrecognisedUri targetstr)) + | otherwise -> + Just (Right (UserTargetRemoteTarball uri)) _ -> Nothing extensionIsTarGz :: FilePath -> Bool - extensionIsTarGz f = takeExtension f == ".gz" - && takeExtension (dropExtension f) == ".tar" + extensionIsTarGz f = + takeExtension f == ".gz" + && takeExtension (dropExtension f) == ".tar" reportUserTargetProblems :: Verbosity -> [UserTargetProblem] -> IO () reportUserTargetProblems verbosity problems = do - case [ target | UserTargetUnrecognised target <- problems ] of - [] -> return () - target -> die' verbosity - $ unlines - [ "Unrecognised target '" ++ name ++ "'." - | name <- target ] - ++ "Targets can be:\n" - ++ " - package names, e.g. 'pkgname', 'pkgname-1.0.1', 'pkgname < 2.0'\n" - ++ " - cabal files 'pkgname.cabal' or package directories 'pkgname/'\n" - ++ " - package tarballs 'pkgname.tar.gz' or 'http://example.com/pkgname.tar.gz'" - - case [ target | UserTargetNonexistantFile target <- problems ] of - [] -> return () - target -> die' verbosity - $ unlines - [ "The file does not exist '" ++ name ++ "'." - | name <- target ] - - case [ target | UserTargetUnexpectedFile target <- problems ] of - [] -> return () - target -> die' verbosity - $ unlines - [ "Unrecognised file target '" ++ name ++ "'." - | name <- target ] - ++ "File targets can be either package tarballs 'pkgname.tar.gz' " - ++ "or cabal files 'pkgname.cabal'." - - case [ target | UserTargetUnexpectedUriScheme target <- problems ] of - [] -> return () - target -> die' verbosity - $ unlines - [ "URL target not supported '" ++ name ++ "'." - | name <- target ] - ++ "Only 'http://' and 'https://' URLs are supported." - - case [ target | UserTargetUnrecognisedUri target <- problems ] of - [] -> return () - target -> die' verbosity - $ unlines - [ "Unrecognise URL target '" ++ name ++ "'." - | name <- target ] - + case [target | UserTargetUnrecognised target <- problems] of + [] -> return () + target -> + die' verbosity $ + unlines + [ "Unrecognised target '" ++ name ++ "'." + | name <- target + ] + ++ "Targets can be:\n" + ++ " - package names, e.g. 'pkgname', 'pkgname-1.0.1', 'pkgname < 2.0'\n" + ++ " - cabal files 'pkgname.cabal' or package directories 'pkgname/'\n" + ++ " - package tarballs 'pkgname.tar.gz' or 'http://example.com/pkgname.tar.gz'" + + case [target | UserTargetNonexistantFile target <- problems] of + [] -> return () + target -> + die' verbosity $ + unlines + [ "The file does not exist '" ++ name ++ "'." + | name <- target + ] + + case [target | UserTargetUnexpectedFile target <- problems] of + [] -> return () + target -> + die' verbosity $ + unlines + [ "Unrecognised file target '" ++ name ++ "'." + | name <- target + ] + ++ "File targets can be either package tarballs 'pkgname.tar.gz' " + ++ "or cabal files 'pkgname.cabal'." + + case [target | UserTargetUnexpectedUriScheme target <- problems] of + [] -> return () + target -> + die' verbosity $ + unlines + [ "URL target not supported '" ++ name ++ "'." + | name <- target + ] + ++ "Only 'http://' and 'https://' URLs are supported." + + case [target | UserTargetUnrecognisedUri target <- problems] of + [] -> return () + target -> + die' verbosity $ + unlines + [ "Unrecognise URL target '" ++ name ++ "'." + | name <- target + ] -- ------------------------------------------------------------ + -- * Resolving user targets to package specifiers + -- ------------------------------------------------------------ -- | Given a bunch of user-specified targets, try to resolve what it is they -- refer to. They can either be specific packages (local dirs, tarballs etc) -- or they can be named packages (with or without version info). --- -resolveUserTargets :: Package pkg - => Verbosity - -> RepoContext - -> PackageIndex pkg - -> [UserTarget] - -> IO [PackageSpecifier UnresolvedSourcePackage] +resolveUserTargets + :: Package pkg + => Verbosity + -> RepoContext + -> PackageIndex pkg + -> [UserTarget] + -> IO [PackageSpecifier UnresolvedSourcePackage] resolveUserTargets verbosity repoCtxt available userTargets = do + -- given the user targets, get a list of fully or partially resolved + -- package references + packageTargets <- + traverse (readPackageTarget verbosity) + =<< traverse (fetchPackageTarget verbosity repoCtxt) . concat + =<< traverse (expandUserTarget verbosity) userTargets - -- given the user targets, get a list of fully or partially resolved - -- package references - packageTargets <- traverse (readPackageTarget verbosity) - =<< traverse (fetchPackageTarget verbosity repoCtxt) . concat - =<< traverse (expandUserTarget verbosity) userTargets - - -- users are allowed to give package names case-insensitively, so we must - -- disambiguate named package references - let (problems, packageSpecifiers) :: ([PackageTargetProblem], [PackageSpecifier UnresolvedSourcePackage]) = - disambiguatePackageTargets available availableExtra packageTargets - - -- use any extra specific available packages to help us disambiguate - availableExtra :: [PackageName] - availableExtra = [ packageName pkg - | PackageTargetLocation pkg <- packageTargets ] + -- users are allowed to give package names case-insensitively, so we must + -- disambiguate named package references + let (problems, packageSpecifiers) :: ([PackageTargetProblem], [PackageSpecifier UnresolvedSourcePackage]) = + disambiguatePackageTargets available availableExtra packageTargets - reportPackageTargetProblems verbosity problems + -- use any extra specific available packages to help us disambiguate + availableExtra :: [PackageName] + availableExtra = + [ packageName pkg + | PackageTargetLocation pkg <- packageTargets + ] - return packageSpecifiers + reportPackageTargetProblems verbosity problems + return packageSpecifiers -- ------------------------------------------------------------ + -- * Package targets + -- ------------------------------------------------------------ -- | An intermediate between a 'UserTarget' and a resolved 'PackageSpecifier'. -- Unlike a 'UserTarget', a 'PackageTarget' refers only to a single package. --- -data PackageTarget pkg = - PackageTargetNamed PackageName [PackageProperty] UserTarget - - -- | A package identified by name, but case insensitively, so it needs - -- to be resolved to the right case-sensitive name. - | PackageTargetNamedFuzzy PackageName [PackageProperty] UserTarget - | PackageTargetLocation pkg +data PackageTarget pkg + = PackageTargetNamed PackageName [PackageProperty] UserTarget + | -- | A package identified by name, but case insensitively, so it needs + -- to be resolved to the right case-sensitive name. + PackageTargetNamedFuzzy PackageName [PackageProperty] UserTarget + | PackageTargetLocation pkg deriving (Show, Functor, Foldable, Traversable) - -- ------------------------------------------------------------ + -- * Converting user targets to package targets + -- ------------------------------------------------------------ -- | Given a user-specified target, expand it to a bunch of package targets -- (each of which refers to only one package). --- -expandUserTarget :: Verbosity - -> UserTarget - -> IO [PackageTarget (PackageLocation ())] +expandUserTarget + :: Verbosity + -> UserTarget + -> IO [PackageTarget (PackageLocation ())] expandUserTarget verbosity userTarget = case userTarget of - - UserTargetNamed (PackageVersionConstraint name vrange) -> - let props = [ PackagePropertyVersion vrange - | not (isAnyVersion vrange) ] - in return [PackageTargetNamedFuzzy name props userTarget] - - UserTargetLocalDir dir -> - return [ PackageTargetLocation (LocalUnpackedPackage dir) ] - - UserTargetLocalCabalFile file -> do - let dir = takeDirectory file - _ <- tryFindPackageDesc verbosity dir (localPackageError dir) -- just as a check - return [ PackageTargetLocation (LocalUnpackedPackage dir) ] - - UserTargetLocalTarball tarballFile -> - return [ PackageTargetLocation (LocalTarballPackage tarballFile) ] - - UserTargetRemoteTarball tarballURL -> - return [ PackageTargetLocation (RemoteTarballPackage tarballURL ()) ] + UserTargetNamed (PackageVersionConstraint name vrange) -> + let props = + [ PackagePropertyVersion vrange + | not (isAnyVersion vrange) + ] + in return [PackageTargetNamedFuzzy name props userTarget] + UserTargetLocalDir dir -> + return [PackageTargetLocation (LocalUnpackedPackage dir)] + UserTargetLocalCabalFile file -> do + let dir = takeDirectory file + _ <- tryFindPackageDesc verbosity dir (localPackageError dir) -- just as a check + return [PackageTargetLocation (LocalUnpackedPackage dir)] + UserTargetLocalTarball tarballFile -> + return [PackageTargetLocation (LocalTarballPackage tarballFile)] + UserTargetRemoteTarball tarballURL -> + return [PackageTargetLocation (RemoteTarballPackage tarballURL ())] localPackageError :: FilePath -> String localPackageError dir = - "Error reading local package.\nCouldn't find .cabal file in: " ++ dir + "Error reading local package.\nCouldn't find .cabal file in: " ++ dir -- ------------------------------------------------------------ + -- * Fetching and reading package targets --- ------------------------------------------------------------ +-- ------------------------------------------------------------ -- | Fetch any remote targets so that they can be read. --- -fetchPackageTarget :: Verbosity - -> RepoContext - -> PackageTarget (PackageLocation ()) - -> IO (PackageTarget ResolvedPkgLoc) -fetchPackageTarget verbosity repoCtxt = traverse $ - fetchPackage verbosity repoCtxt . fmap (const Nothing) - +fetchPackageTarget + :: Verbosity + -> RepoContext + -> PackageTarget (PackageLocation ()) + -> IO (PackageTarget ResolvedPkgLoc) +fetchPackageTarget verbosity repoCtxt = + traverse $ + fetchPackage verbosity repoCtxt . fmap (const Nothing) -- | Given a package target that has been fetched, read the .cabal file. -- -- This only affects targets given by location, named targets are unaffected. --- -readPackageTarget :: Verbosity - -> PackageTarget ResolvedPkgLoc - -> IO (PackageTarget UnresolvedSourcePackage) +readPackageTarget + :: Verbosity + -> PackageTarget ResolvedPkgLoc + -> IO (PackageTarget UnresolvedSourcePackage) readPackageTarget verbosity = traverse modifyLocation where modifyLocation :: ResolvedPkgLoc -> IO UnresolvedSourcePackage modifyLocation location = case location of - LocalUnpackedPackage dir -> do - pkg <- tryFindPackageDesc verbosity dir (localPackageError dir) >>= - readGenericPackageDescription verbosity - return SourcePackage - { srcpkgPackageId = packageId pkg - , srcpkgDescription = pkg - , srcpkgSource = fmap Just location - , srcpkgDescrOverride = Nothing - } - + pkg <- + tryFindPackageDesc verbosity dir (localPackageError dir) + >>= readGenericPackageDescription verbosity + return + SourcePackage + { srcpkgPackageId = packageId pkg + , srcpkgDescription = pkg + , srcpkgSource = fmap Just location + , srcpkgDescrOverride = Nothing + } LocalTarballPackage tarballFile -> readTarballPackageTarget location tarballFile tarballFile - RemoteTarballPackage tarballURL tarballFile -> readTarballPackageTarget location tarballFile (show tarballURL) - RepoTarballPackage _repo _pkgid _ -> error "TODO: readPackageTarget RepoTarballPackage" - -- For repo tarballs this info should be obtained from the index. + -- For repo tarballs this info should be obtained from the index. RemoteSourceRepoPackage _srcRepo _ -> error "TODO: readPackageTarget RemoteSourceRepoPackage" - -- This can't happen, because it would have errored out already - -- in fetchPackage, via fetchPackageTarget before it gets to this - -- function. - -- - -- When that is corrected, this will also need to be fixed. + -- This can't happen, because it would have errored out already + -- in fetchPackage, via fetchPackageTarget before it gets to this + -- function. + -- + -- When that is corrected, this will also need to be fixed. readTarballPackageTarget :: ResolvedPkgLoc -> FilePath -> FilePath -> IO UnresolvedSourcePackage readTarballPackageTarget location tarballFile tarballOriginalLoc = do - (filename, content) <- extractTarballPackageCabalFile - tarballFile tarballOriginalLoc + (filename, content) <- + extractTarballPackageCabalFile + tarballFile + tarballOriginalLoc case parsePackageDescription' content of - Nothing -> die' verbosity $ "Could not parse the cabal file " - ++ filename ++ " in " ++ tarballFile + Nothing -> + die' verbosity $ + "Could not parse the cabal file " + ++ filename + ++ " in " + ++ tarballFile Just pkg -> - return SourcePackage - { srcpkgPackageId = packageId pkg - , srcpkgDescription = pkg - , srcpkgSource = fmap Just location - , srcpkgDescrOverride = Nothing - } - - extractTarballPackageCabalFile :: FilePath -> String - -> IO (FilePath, BS.ByteString) + return + SourcePackage + { srcpkgPackageId = packageId pkg + , srcpkgDescription = pkg + , srcpkgSource = fmap Just location + , srcpkgDescrOverride = Nothing + } + + extractTarballPackageCabalFile + :: FilePath + -> String + -> IO (FilePath, BS.ByteString) extractTarballPackageCabalFile tarballFile tarballOriginalLoc = - either (die' verbosity . formatErr) return + either (die' verbosity . formatErr) return . check . accumEntryMap . Tar.filterEntries isCabalFile . Tar.read . GZipUtils.maybeDecompress - =<< BS.readFile tarballFile + =<< BS.readFile tarballFile where formatErr msg = "Error reading " ++ tarballOriginalLoc ++ ": " ++ msg - accumEntryMap :: Tar.Entries Tar.FormatError - -> Either (Tar.FormatError, Map Tar.TarPath Tar.Entry) (Map Tar.TarPath Tar.Entry) - accumEntryMap = Tar.foldlEntries - (\m e -> Map.insert (Tar.entryTarPath e) e m) - Map.empty + accumEntryMap + :: Tar.Entries Tar.FormatError + -> Either (Tar.FormatError, Map Tar.TarPath Tar.Entry) (Map Tar.TarPath Tar.Entry) + accumEntryMap = + Tar.foldlEntries + (\m e -> Map.insert (Tar.entryTarPath e) e m) + Map.empty - check (Left e) = Left (show e) + check (Left e) = Left (show e) check (Right m) = case Map.elems m of - [] -> Left noCabalFile - [file] -> case Tar.entryContent file of - Tar.NormalFile content _ -> Right (Tar.entryPath file, content) - _ -> Left noCabalFile - _files -> Left multipleCabalFiles + [] -> Left noCabalFile + [file] -> case Tar.entryContent file of + Tar.NormalFile content _ -> Right (Tar.entryPath file, content) + _ -> Left noCabalFile + _files -> Left multipleCabalFiles where - noCabalFile = "No cabal file found" + noCabalFile = "No cabal file found" multipleCabalFiles = "Multiple cabal files found" isCabalFile :: Tar.Entry -> Bool isCabalFile e = case splitPath (Tar.entryPath e) of - [ _dir, file] -> takeExtension file == ".cabal" + [_dir, file] -> takeExtension file == ".cabal" [".", _dir, file] -> takeExtension file == ".cabal" - _ -> False + _ -> False parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription parsePackageDescription' bs = - parseGenericPackageDescriptionMaybe (BS.toStrict bs) + parseGenericPackageDescriptionMaybe (BS.toStrict bs) -- ------------------------------------------------------------ + -- * Checking package targets + -- ------------------------------------------------------------ data PackageTargetProblem - = PackageNameUnknown PackageName UserTarget - | PackageNameAmbiguous PackageName [PackageName] UserTarget - deriving Show - + = PackageNameUnknown PackageName UserTarget + | PackageNameAmbiguous PackageName [PackageName] UserTarget + deriving (Show) -- | Users are allowed to give package names case-insensitively, so we must -- disambiguate named package references. --- -disambiguatePackageTargets :: Package pkg' - => PackageIndex pkg' - -> [PackageName] - -> [PackageTarget pkg] - -> ( [PackageTargetProblem] - , [PackageSpecifier pkg] ) +disambiguatePackageTargets + :: Package pkg' + => PackageIndex pkg' + -> [PackageName] + -> [PackageTarget pkg] + -> ( [PackageTargetProblem] + , [PackageSpecifier pkg] + ) disambiguatePackageTargets availablePkgIndex availableExtra targets = - partitionEithers (map disambiguatePackageTarget targets) + partitionEithers (map disambiguatePackageTarget targets) where disambiguatePackageTarget packageTarget = case packageTarget of PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg) - PackageTargetNamed pkgname props userTarget - | null (PackageIndex.lookupPackageName availablePkgIndex pkgname) - -> Left (PackageNameUnknown pkgname userTarget) + | null (PackageIndex.lookupPackageName availablePkgIndex pkgname) -> + Left (PackageNameUnknown pkgname userTarget) | otherwise -> Right (NamedPackage pkgname props) - PackageTargetNamedFuzzy pkgname props userTarget -> case disambiguatePackageName packageNameEnv pkgname of - None -> Left (PackageNameUnknown - pkgname userTarget) - Ambiguous pkgnames -> Left (PackageNameAmbiguous - pkgname pkgnames userTarget) + None -> + Left + ( PackageNameUnknown + pkgname + userTarget + ) + Ambiguous pkgnames -> + Left + ( PackageNameAmbiguous + pkgname + pkgnames + userTarget + ) Unambiguous pkgname' -> Right (NamedPackage pkgname' props) -- use any extra specific available packages to help us disambiguate packageNameEnv :: PackageNameEnv - packageNameEnv = mappend (indexPackageNameEnv availablePkgIndex) - (extraPackageNameEnv availableExtra) - + packageNameEnv = + mappend + (indexPackageNameEnv availablePkgIndex) + (extraPackageNameEnv availableExtra) -- | Report problems to the user. That is, if there are any problems -- then raise an exception. -reportPackageTargetProblems :: Verbosity - -> [PackageTargetProblem] -> IO () +reportPackageTargetProblems + :: Verbosity + -> [PackageTargetProblem] + -> IO () reportPackageTargetProblems verbosity problems = do - case [ pkg | PackageNameUnknown pkg _ <- problems ] of - [] -> return () - pkgs -> die' verbosity $ unlines - [ "There is no package named '" ++ prettyShow name ++ "'. " - | name <- pkgs ] - ++ "You may need to run 'cabal update' to get the latest " - ++ "list of available packages." - - case [ (pkg, matches) | PackageNameAmbiguous pkg matches _ <- problems ] of - [] -> return () - ambiguities -> die' verbosity $ unlines - [ "There is no package named '" ++ prettyShow name ++ "'. " - ++ (if length matches > 1 - then "However, the following package names exist: " - else "However, the following package name exists: ") - ++ intercalate ", " [ "'" ++ prettyShow m ++ "'" | m <- matches] - ++ "." - | (name, matches) <- ambiguities ] - + case [pkg | PackageNameUnknown pkg _ <- problems] of + [] -> return () + pkgs -> + die' verbosity $ + unlines + [ "There is no package named '" ++ prettyShow name ++ "'. " + | name <- pkgs + ] + ++ "You may need to run 'cabal update' to get the latest " + ++ "list of available packages." + + case [(pkg, matches) | PackageNameAmbiguous pkg matches _ <- problems] of + [] -> return () + ambiguities -> + die' verbosity $ + unlines + [ "There is no package named '" + ++ prettyShow name + ++ "'. " + ++ ( if length matches > 1 + then "However, the following package names exist: " + else "However, the following package name exists: " + ) + ++ intercalate ", " ["'" ++ prettyShow m ++ "'" | m <- matches] + ++ "." + | (name, matches) <- ambiguities + ] -- ------------------------------------------------------------ + -- * Disambiguating package names + -- ------------------------------------------------------------ data MaybeAmbiguous a = None | Unambiguous a | Ambiguous [a] @@ -559,17 +614,16 @@ data MaybeAmbiguous a = None | Unambiguous a | Ambiguous [a] -- -- Note: Before cabal 2.2, when only a single package matched -- case-insensitively it would be considered 'Unambiguous'. --- -disambiguatePackageName :: PackageNameEnv - -> PackageName - -> MaybeAmbiguous PackageName +disambiguatePackageName + :: PackageNameEnv + -> PackageName + -> MaybeAmbiguous PackageName disambiguatePackageName (PackageNameEnv pkgNameLookup) name = - case nub (pkgNameLookup name) of - [] -> None - names -> case find (name==) names of - Just name' -> Unambiguous name' - Nothing -> Ambiguous names - + case nub (pkgNameLookup name) of + [] -> None + names -> case find (name ==) names of + Just name' -> Unambiguous name' + Nothing -> Ambiguous names newtype PackageNameEnv = PackageNameEnv (PackageName -> [PackageName]) @@ -594,24 +648,24 @@ extraPackageNameEnv names = PackageNameEnv pkgNameLookup [ pname' | let lname = lowercase (unPackageName pname) , pname' <- names - , lowercase (unPackageName pname') == lname ] - + , lowercase (unPackageName pname') == lname + ] -- ------------------------------------------------------------ + -- * Package constraints + -- ------------------------------------------------------------ -- | Version of 'Qualifier' that a user may specify on the -- command line. -data UserQualifier = - -- | Top-level dependency. - UserQualToplevel - - -- | Setup dependency. - | UserQualSetup PackageName - - -- | Executable dependency. - | UserQualExe PackageName PackageName +data UserQualifier + = -- | Top-level dependency. + UserQualToplevel + | -- | Setup dependency. + UserQualSetup PackageName + | -- | Executable dependency. + UserQualExe PackageName PackageName deriving (Eq, Show, Generic) instance Binary UserQualifier @@ -619,15 +673,13 @@ instance Structured UserQualifier -- | Version of 'ConstraintScope' that a user may specify on the -- command line. -data UserConstraintScope = - -- | Scope that applies to the package when it has the specified qualifier. - UserQualified UserQualifier PackageName - - -- | Scope that applies to the package when it has a setup qualifier. - | UserAnySetupQualifier PackageName - - -- | Scope that applies to the package when it has any qualifier. - | UserAnyQualifier PackageName +data UserConstraintScope + = -- | Scope that applies to the package when it has the specified qualifier. + UserQualified UserQualifier PackageName + | -- | Scope that applies to the package when it has a setup qualifier. + UserAnySetupQualifier PackageName + | -- | Scope that applies to the package when it has any qualifier. + UserAnyQualifier PackageName deriving (Eq, Show, Generic) instance Binary UserConstraintScope @@ -640,14 +692,14 @@ fromUserQualifier (UserQualExe name1 name2) = QualExe name1 name2 fromUserConstraintScope :: UserConstraintScope -> ConstraintScope fromUserConstraintScope (UserQualified q pn) = - ScopeQualified (fromUserQualifier q) pn + ScopeQualified (fromUserQualifier q) pn fromUserConstraintScope (UserAnySetupQualifier pn) = ScopeAnySetupQualifier pn fromUserConstraintScope (UserAnyQualifier pn) = ScopeAnyQualifier pn -- | Version of 'PackageConstraint' that the user can specify on -- the command line. -data UserConstraint = - UserConstraint UserConstraintScope PackageProperty +data UserConstraint + = UserConstraint UserConstraintScope PackageProperty deriving (Eq, Show, Generic) instance Binary UserConstraint @@ -666,50 +718,51 @@ userToPackageConstraint (UserConstraint scope prop) = readUserConstraint :: String -> Either String UserConstraint readUserConstraint str = - case explicitEitherParsec parsec str of - Left err -> Left $ msgCannotParse ++ err - Right c -> Right c + case explicitEitherParsec parsec str of + Left err -> Left $ msgCannotParse ++ err + Right c -> Right c where msgCannotParse = - "expected a (possibly qualified) package name followed by a " ++ - "constraint, which is either a version range, 'installed', " ++ - "'source', 'test', 'bench', or flags. " + "expected a (possibly qualified) package name followed by a " + ++ "constraint, which is either a version range, 'installed', " + ++ "'source', 'test', 'bench', or flags. " instance Pretty UserConstraint where pretty (UserConstraint scope prop) = dispPackageConstraint $ PackageConstraint (fromUserConstraintScope scope) prop instance Parsec UserConstraint where - parsec = do - scope <- parseConstraintScope - P.spaces - prop <- P.choice - [ PackagePropertyFlags <$> parsecFlagAssignmentNonEmpty -- headed by "+-" - , PackagePropertyVersion <$> parsec -- headed by "<=>" (will be) - , PackagePropertyInstalled <$ P.string "installed" - , PackagePropertySource <$ P.string "source" - , PackagePropertyStanzas [TestStanzas] <$ P.string "test" - , PackagePropertyStanzas [BenchStanzas] <$ P.string "bench" - ] - return (UserConstraint scope prop) - - where - parseConstraintScope :: forall m. CabalParsing m => m UserConstraintScope - parseConstraintScope = do - pn <- parsec - P.choice - [ P.char '.' *> withDot pn - , P.char ':' *> withColon pn - , return (UserQualified UserQualToplevel pn) - ] - where - withDot :: PackageName -> m UserConstraintScope - withDot pn - | pn == mkPackageName "any" = UserAnyQualifier <$> parsec - | pn == mkPackageName "setup" = UserAnySetupQualifier <$> parsec - | otherwise = P.unexpected $ "constraint scope: " ++ unPackageName pn - - withColon :: PackageName -> m UserConstraintScope - withColon pn = UserQualified (UserQualSetup pn) - <$ P.string "setup." - <*> parsec + parsec = do + scope <- parseConstraintScope + P.spaces + prop <- + P.choice + [ PackagePropertyFlags <$> parsecFlagAssignmentNonEmpty -- headed by "+-" + , PackagePropertyVersion <$> parsec -- headed by "<=>" (will be) + , PackagePropertyInstalled <$ P.string "installed" + , PackagePropertySource <$ P.string "source" + , PackagePropertyStanzas [TestStanzas] <$ P.string "test" + , PackagePropertyStanzas [BenchStanzas] <$ P.string "bench" + ] + return (UserConstraint scope prop) + where + parseConstraintScope :: forall m. CabalParsing m => m UserConstraintScope + parseConstraintScope = do + pn <- parsec + P.choice + [ P.char '.' *> withDot pn + , P.char ':' *> withColon pn + , return (UserQualified UserQualToplevel pn) + ] + where + withDot :: PackageName -> m UserConstraintScope + withDot pn + | pn == mkPackageName "any" = UserAnyQualifier <$> parsec + | pn == mkPackageName "setup" = UserAnySetupQualifier <$> parsec + | otherwise = P.unexpected $ "constraint scope: " ++ unPackageName pn + + withColon :: PackageName -> m UserConstraintScope + withColon pn = + UserQualified (UserQualSetup pn) + <$ P.string "setup." + <*> parsec diff --git a/cabal-install/src/Distribution/Client/Types.hs b/cabal-install/src/Distribution/Client/Types.hs index fe5710d9477..710960ee939 100644 --- a/cabal-install/src/Distribution/Client/Types.hs +++ b/cabal-install/src/Distribution/Client/Types.hs @@ -1,10 +1,14 @@ -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.Types -- Copyright : (c) David Himmelstrup 2005 @@ -16,21 +20,19 @@ -- Portability : portable -- -- Various common data types for the entire cabal-install system ------------------------------------------------------------------------------ -module Distribution.Client.Types ( - module Distribution.Client.Types.AllowNewer, - module Distribution.Client.Types.ConfiguredId, - module Distribution.Client.Types.ConfiguredPackage, - module Distribution.Client.Types.BuildResults, - module Distribution.Client.Types.PackageLocation, - module Distribution.Client.Types.PackageSpecifier, - module Distribution.Client.Types.ReadyPackage, - module Distribution.Client.Types.Repo, - module Distribution.Client.Types.RepoName, - module Distribution.Client.Types.SourcePackageDb, - module Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy, -) where - +module Distribution.Client.Types + ( module Distribution.Client.Types.AllowNewer + , module Distribution.Client.Types.ConfiguredId + , module Distribution.Client.Types.ConfiguredPackage + , module Distribution.Client.Types.BuildResults + , module Distribution.Client.Types.PackageLocation + , module Distribution.Client.Types.PackageSpecifier + , module Distribution.Client.Types.ReadyPackage + , module Distribution.Client.Types.Repo + , module Distribution.Client.Types.RepoName + , module Distribution.Client.Types.SourcePackageDb + , module Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy + ) where import Distribution.Client.Types.AllowNewer import Distribution.Client.Types.BuildResults @@ -38,8 +40,8 @@ import Distribution.Client.Types.ConfiguredId import Distribution.Client.Types.ConfiguredPackage import Distribution.Client.Types.PackageLocation import Distribution.Client.Types.PackageSpecifier +import Distribution.Client.Types.ReadyPackage import Distribution.Client.Types.Repo import Distribution.Client.Types.RepoName -import Distribution.Client.Types.ReadyPackage import Distribution.Client.Types.SourcePackageDb import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy diff --git a/cabal-install/src/Distribution/Client/Types/AllowNewer.hs b/cabal-install/src/Distribution/Client/Types/AllowNewer.hs index 809f9f690be..0a5700174b8 100644 --- a/cabal-install/src/Distribution/Client/Types/AllowNewer.hs +++ b/cabal-install/src/Distribution/Client/Types/AllowNewer.hs @@ -1,26 +1,27 @@ {-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.AllowNewer ( - AllowNewer (..), - AllowOlder (..), - RelaxDeps (..), - mkRelaxDepSome, - RelaxDepMod (..), - RelaxDepScope (..), - RelaxDepSubject (..), - RelaxedDep (..), - isRelaxDeps, -) where + +module Distribution.Client.Types.AllowNewer + ( AllowNewer (..) + , AllowOlder (..) + , RelaxDeps (..) + , mkRelaxDepSome + , RelaxDepMod (..) + , RelaxDepScope (..) + , RelaxDepSubject (..) + , RelaxedDep (..) + , isRelaxDeps + ) where import Distribution.Client.Compat.Prelude import Prelude () -import Distribution.Parsec (parsecLeadingCommaNonEmpty) -import Distribution.Types.PackageId (PackageId, PackageIdentifier (..)) +import Distribution.Parsec (parsecLeadingCommaNonEmpty) +import Distribution.Types.PackageId (PackageId, PackageIdentifier (..)) import Distribution.Types.PackageName (PackageName, mkPackageName) -import Distribution.Types.Version (nullVersion) +import Distribution.Types.Version (nullVersion) import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp +import qualified Text.PrettyPrint as Disp -- $setup -- >>> import Distribution.Parsec @@ -30,116 +31,120 @@ import qualified Text.PrettyPrint as Disp -- module -- | 'RelaxDeps' in the context of upper bounds (i.e. for @--allow-newer@ flag) -newtype AllowNewer = AllowNewer { unAllowNewer :: RelaxDeps } - deriving (Eq, Read, Show, Generic) +newtype AllowNewer = AllowNewer {unAllowNewer :: RelaxDeps} + deriving (Eq, Read, Show, Generic) -- | 'RelaxDeps' in the context of lower bounds (i.e. for @--allow-older@ flag) -newtype AllowOlder = AllowOlder { unAllowOlder :: RelaxDeps } - deriving (Eq, Read, Show, Generic) +newtype AllowOlder = AllowOlder {unAllowOlder :: RelaxDeps} + deriving (Eq, Read, Show, Generic) -- | Generic data type for policy when relaxing bounds in dependencies. -- Don't use this directly: use 'AllowOlder' or 'AllowNewer' depending -- on whether or not you are relaxing an lower or upper bound -- (respectively). -data RelaxDeps = - - -- | Ignore upper (resp. lower) bounds in some (or no) dependencies on the given packages. - -- - -- @RelaxDepsSome []@ is the default, i.e. honor the bounds in all - -- dependencies, never choose versions newer (resp. older) than allowed. +data RelaxDeps + = -- | Ignore upper (resp. lower) bounds in some (or no) dependencies on the given packages. + -- + -- @RelaxDepsSome []@ is the default, i.e. honor the bounds in all + -- dependencies, never choose versions newer (resp. older) than allowed. RelaxDepsSome [RelaxedDep] - - -- | Ignore upper (resp. lower) bounds in dependencies on all packages. - -- - -- __Note__: This is should be semantically equivalent to - -- - -- > RelaxDepsSome [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll] - -- - -- (TODO: consider normalising 'RelaxDeps' and/or 'RelaxedDep') - | RelaxDepsAll + | -- | Ignore upper (resp. lower) bounds in dependencies on all packages. + -- + -- __Note__: This is should be semantically equivalent to + -- + -- > RelaxDepsSome [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll] + -- + -- (TODO: consider normalising 'RelaxDeps' and/or 'RelaxedDep') + RelaxDepsAll deriving (Eq, Read, Show, Generic) -- | Dependencies can be relaxed either for all packages in the install plan, or -- only for some packages. data RelaxedDep = RelaxedDep !RelaxDepScope !RelaxDepMod !RelaxDepSubject - deriving (Eq, Read, Show, Generic) + deriving (Eq, Read, Show, Generic) -- | Specify the scope of a relaxation, i.e. limit which depending -- packages are allowed to have their version constraints relaxed. -data RelaxDepScope = RelaxDepScopeAll - -- ^ Apply relaxation in any package - | RelaxDepScopePackage !PackageName - -- ^ Apply relaxation to in all versions of a package - | RelaxDepScopePackageId !PackageId - -- ^ Apply relaxation to a specific version of a package only - deriving (Eq, Read, Show, Generic) +data RelaxDepScope + = -- | Apply relaxation in any package + RelaxDepScopeAll + | -- | Apply relaxation to in all versions of a package + RelaxDepScopePackage !PackageName + | -- | Apply relaxation to a specific version of a package only + RelaxDepScopePackageId !PackageId + deriving (Eq, Read, Show, Generic) -- | Modifier for dependency relaxation -data RelaxDepMod = RelaxDepModNone -- ^ Default semantics - | RelaxDepModCaret -- ^ Apply relaxation only to @^>=@ constraints - deriving (Eq, Read, Show, Generic) +data RelaxDepMod + = -- | Default semantics + RelaxDepModNone + | -- | Apply relaxation only to @^>=@ constraints + RelaxDepModCaret + deriving (Eq, Read, Show, Generic) -- | Express whether to relax bounds /on/ @all@ packages, or a single package -data RelaxDepSubject = RelaxDepSubjectAll - | RelaxDepSubjectPkg !PackageName - deriving (Eq, Ord, Read, Show, Generic) +data RelaxDepSubject + = RelaxDepSubjectAll + | RelaxDepSubjectPkg !PackageName + deriving (Eq, Ord, Read, Show, Generic) instance Pretty RelaxedDep where pretty (RelaxedDep scope rdmod subj) = case scope of - RelaxDepScopeAll -> Disp.text "*:" Disp.<> modDep - RelaxDepScopePackage p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep - RelaxDepScopePackageId p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep + RelaxDepScopeAll -> Disp.text "*:" Disp.<> modDep + RelaxDepScopePackage p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep + RelaxDepScopePackageId p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep where modDep = case rdmod of - RelaxDepModNone -> pretty subj - RelaxDepModCaret -> Disp.char '^' Disp.<> pretty subj + RelaxDepModNone -> pretty subj + RelaxDepModCaret -> Disp.char '^' Disp.<> pretty subj instance Parsec RelaxedDep where - parsec = P.char '*' *> relaxedDepStarP <|> (parsec >>= relaxedDepPkgidP) + parsec = P.char '*' *> relaxedDepStarP <|> (parsec >>= relaxedDepPkgidP) -- continuation after * relaxedDepStarP :: CabalParsing m => m RelaxedDep relaxedDepStarP = - RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec + RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) -- continuation after package identifier relaxedDepPkgidP :: CabalParsing m => PackageIdentifier -> m RelaxedDep relaxedDepPkgidP pid@(PackageIdentifier pn v) - | pn == mkPackageName "all" - , v == nullVersion - = RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec - <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) - - | v == nullVersion - = RelaxedDep (RelaxDepScopePackage pn) <$ P.char ':' <*> modP <*> parsec - <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn)) - - | otherwise - = RelaxedDep (RelaxDepScopePackageId pid) <$ P.char ':' <*> modP <*> parsec + | pn == mkPackageName "all" + , v == nullVersion = + RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec + <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) + | v == nullVersion = + RelaxedDep (RelaxDepScopePackage pn) <$ P.char ':' <*> modP <*> parsec + <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn)) + | otherwise = + RelaxedDep (RelaxDepScopePackageId pid) <$ P.char ':' <*> modP <*> parsec modP :: P.CharParsing m => m RelaxDepMod modP = RelaxDepModCaret <$ P.char '^' <|> pure RelaxDepModNone instance Pretty RelaxDepSubject where - pretty RelaxDepSubjectAll = Disp.text "*" + pretty RelaxDepSubjectAll = Disp.text "*" pretty (RelaxDepSubjectPkg pn) = pretty pn instance Parsec RelaxDepSubject where parsec = RelaxDepSubjectAll <$ P.char '*' <|> pkgn where pkgn = do - pn <- parsec - pure $ if pn == mkPackageName "all" - then RelaxDepSubjectAll - else RelaxDepSubjectPkg pn + pn <- parsec + pure $ + if pn == mkPackageName "all" + then RelaxDepSubjectAll + else RelaxDepSubjectPkg pn instance Pretty RelaxDeps where pretty rd | not (isRelaxDeps rd) = Disp.text "none" - pretty (RelaxDepsSome pkgs) = Disp.fsep . - Disp.punctuate Disp.comma . - map pretty $ pkgs - pretty RelaxDepsAll = Disp.text "all" + pretty (RelaxDepsSome pkgs) = + Disp.fsep + . Disp.punctuate Disp.comma + . map pretty + $ pkgs + pretty RelaxDepsAll = Disp.text "all" -- | -- @@ -165,17 +170,16 @@ instance Pretty RelaxDeps where -- -- >>> simpleParsec "" :: Maybe RelaxDeps -- Nothing --- instance Parsec RelaxDeps where - parsec = do - xs <- parsecLeadingCommaNonEmpty parsec - pure $ case toList xs of - [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll] - -> RelaxDepsAll - [RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn)] - | pn == mkPackageName "none" - -> mempty - xs' -> mkRelaxDepSome xs' + parsec = do + xs <- parsecLeadingCommaNonEmpty parsec + pure $ case toList xs of + [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll] -> + RelaxDepsAll + [RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn)] + | pn == mkPackageName "none" -> + mempty + xs' -> mkRelaxDepSome xs' instance Binary RelaxDeps instance Binary RelaxDepMod @@ -197,33 +201,32 @@ instance Structured AllowOlder -- -- Equivalent to @isRelaxDeps = (/= 'mempty')@ isRelaxDeps :: RelaxDeps -> Bool -isRelaxDeps (RelaxDepsSome []) = False -isRelaxDeps (RelaxDepsSome (_:_)) = True -isRelaxDeps RelaxDepsAll = True +isRelaxDeps (RelaxDepsSome []) = False +isRelaxDeps (RelaxDepsSome (_ : _)) = True +isRelaxDeps RelaxDepsAll = True -- | A smarter 'RelaxedDepsSome', @*:*@ is the same as @all@. mkRelaxDepSome :: [RelaxedDep] -> RelaxDeps mkRelaxDepSome xs - | any (== RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) xs - = RelaxDepsAll - - | otherwise - = RelaxDepsSome xs + | any (== RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) xs = + RelaxDepsAll + | otherwise = + RelaxDepsSome xs -- | 'RelaxDepsAll' is the /absorbing element/ instance Semigroup RelaxDeps where - -- identity element - RelaxDepsSome [] <> r = r - l@(RelaxDepsSome _) <> RelaxDepsSome [] = l - -- absorbing element - l@RelaxDepsAll <> _ = l - (RelaxDepsSome _) <> r@RelaxDepsAll = r - -- combining non-{identity,absorbing} elements - (RelaxDepsSome a) <> (RelaxDepsSome b) = RelaxDepsSome (a ++ b) + -- identity element + RelaxDepsSome [] <> r = r + l@(RelaxDepsSome _) <> RelaxDepsSome [] = l + -- absorbing element + l@RelaxDepsAll <> _ = l + (RelaxDepsSome _) <> r@RelaxDepsAll = r + -- combining non-{identity,absorbing} elements + (RelaxDepsSome a) <> (RelaxDepsSome b) = RelaxDepsSome (a ++ b) -- | @'RelaxDepsSome' []@ is the /identity element/ instance Monoid RelaxDeps where - mempty = RelaxDepsSome [] + mempty = RelaxDepsSome [] mappend = (<>) instance Semigroup AllowNewer where @@ -233,9 +236,9 @@ instance Semigroup AllowOlder where AllowOlder x <> AllowOlder y = AllowOlder (x <> y) instance Monoid AllowNewer where - mempty = AllowNewer mempty + mempty = AllowNewer mempty mappend = (<>) instance Monoid AllowOlder where - mempty = AllowOlder mempty + mempty = AllowOlder mempty mappend = (<>) diff --git a/cabal-install/src/Distribution/Client/Types/BuildResults.hs b/cabal-install/src/Distribution/Client/Types/BuildResults.hs index 55cf42de9c6..55c01534620 100644 --- a/cabal-install/src/Distribution/Client/Types/BuildResults.hs +++ b/cabal-install/src/Distribution/Client/Types/BuildResults.hs @@ -1,37 +1,37 @@ {-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.BuildResults ( - BuildOutcome, - BuildOutcomes, - BuildFailure (..), - BuildResult (..), - TestsResult (..), - DocsResult (..), -) where + +module Distribution.Client.Types.BuildResults + ( BuildOutcome + , BuildOutcomes + , BuildFailure (..) + , BuildResult (..) + , TestsResult (..) + , DocsResult (..) + ) where import Distribution.Client.Compat.Prelude import Prelude () import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo) -import Distribution.Types.PackageId (PackageId) -import Distribution.Types.UnitId (UnitId) +import Distribution.Types.PackageId (PackageId) +import Distribution.Types.UnitId (UnitId) -- | A summary of the outcome for building a single package. --- type BuildOutcome = Either BuildFailure BuildResult -- | A summary of the outcome for building a whole set of packages. --- type BuildOutcomes = Map UnitId BuildOutcome -data BuildFailure = PlanningFailed - | DependentFailed PackageId - | GracefulFailure String - | DownloadFailed SomeException - | UnpackFailed SomeException - | ConfigureFailed SomeException - | BuildFailed SomeException - | TestsFailed SomeException - | InstallFailed SomeException +data BuildFailure + = PlanningFailed + | DependentFailed PackageId + | GracefulFailure String + | DownloadFailed SomeException + | UnpackFailed SomeException + | ConfigureFailed SomeException + | BuildFailed SomeException + | TestsFailed SomeException + | InstallFailed SomeException deriving (Show, Typeable, Generic) instance Exception BuildFailure @@ -40,11 +40,14 @@ instance Exception BuildFailure -- the public library's 'InstalledPackageInfo' is stored here, even if -- there were 'InstalledPackageInfo' from internal libraries. This -- 'InstalledPackageInfo' is not used anyway, so it makes no difference. -data BuildResult = BuildResult DocsResult TestsResult - (Maybe InstalledPackageInfo) +data BuildResult + = BuildResult + DocsResult + TestsResult + (Maybe InstalledPackageInfo) deriving (Show, Generic) -data DocsResult = DocsNotTried | DocsFailed | DocsOk +data DocsResult = DocsNotTried | DocsFailed | DocsOk deriving (Show, Generic, Typeable) data TestsResult = TestsNotTried | TestsOk deriving (Show, Generic, Typeable) diff --git a/cabal-install/src/Distribution/Client/Types/ConfiguredId.hs b/cabal-install/src/Distribution/Client/Types/ConfiguredId.hs index 6b545333677..04f80ff97cf 100644 --- a/cabal-install/src/Distribution/Client/Types/ConfiguredId.hs +++ b/cabal-install/src/Distribution/Client/Types/ConfiguredId.hs @@ -1,20 +1,21 @@ {-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.ConfiguredId ( - InstalledPackageId, - ConfiguredId (..), - annotatedIdToConfiguredId, - HasConfiguredId (..), -) where + +module Distribution.Client.Types.ConfiguredId + ( InstalledPackageId + , ConfiguredId (..) + , annotatedIdToConfiguredId + , HasConfiguredId (..) + ) where import Distribution.Client.Compat.Prelude import Prelude () -import Distribution.InstalledPackageInfo (InstalledPackageInfo, sourceComponentName, installedComponentId) -import Distribution.Package (Package (..)) -import Distribution.Types.AnnotatedId (AnnotatedId (..)) -import Distribution.Types.ComponentId (ComponentId) -import Distribution.Types.ComponentName (ComponentName) -import Distribution.Types.PackageId (PackageId) +import Distribution.InstalledPackageInfo (InstalledPackageInfo, installedComponentId, sourceComponentName) +import Distribution.Package (Package (..)) +import Distribution.Types.AnnotatedId (AnnotatedId (..)) +import Distribution.Types.ComponentId (ComponentId) +import Distribution.Types.ComponentName (ComponentName) +import Distribution.Types.PackageId (PackageId) ------------------------------------------------------------------------------- -- InstalledPackageId @@ -30,7 +31,6 @@ import Distribution.Types.PackageId (PackageId) -- their primary library, which is a unit id. In future this may change -- slightly and we may distinguish these two types and have an explicit -- conversion when we register units with the compiler. --- type InstalledPackageId = ComponentId ------------------------------------------------------------------------------- @@ -45,18 +45,19 @@ type InstalledPackageId = ComponentId -- -- An already installed package of course is also "configured" (all its -- configuration parameters and dependencies have been specified). -data ConfiguredId = ConfiguredId { - confSrcId :: PackageId +data ConfiguredId = ConfiguredId + { confSrcId :: PackageId , confCompName :: Maybe ComponentName , confInstId :: ComponentId } deriving (Eq, Ord, Generic) annotatedIdToConfiguredId :: AnnotatedId ComponentId -> ConfiguredId -annotatedIdToConfiguredId aid = ConfiguredId { - confSrcId = ann_pid aid, - confCompName = Just (ann_cname aid), - confInstId = ann_id aid +annotatedIdToConfiguredId aid = + ConfiguredId + { confSrcId = ann_pid aid + , confCompName = Just (ann_cname aid) + , confInstId = ann_id aid } instance Binary ConfiguredId @@ -73,11 +74,13 @@ instance Package ConfiguredId where ------------------------------------------------------------------------------- class HasConfiguredId a where - configuredId :: a -> ConfiguredId + configuredId :: a -> ConfiguredId -- NB: This instance is slightly dangerous, in that you'll lose -- information about the specific UnitId you depended on. instance HasConfiguredId InstalledPackageInfo where - configuredId ipkg = ConfiguredId (packageId ipkg) - (Just (sourceComponentName ipkg)) - (installedComponentId ipkg) + configuredId ipkg = + ConfiguredId + (packageId ipkg) + (Just (sourceComponentName ipkg)) + (installedComponentId ipkg) diff --git a/cabal-install/src/Distribution/Client/Types/ConfiguredPackage.hs b/cabal-install/src/Distribution/Client/Types/ConfiguredPackage.hs index 62b8f3360b8..0b7d62e7e77 100644 --- a/cabal-install/src/Distribution/Client/Types/ConfiguredPackage.hs +++ b/cabal-install/src/Distribution/Client/Types/ConfiguredPackage.hs @@ -1,24 +1,25 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} -module Distribution.Client.Types.ConfiguredPackage ( - ConfiguredPackage (..), -) where +{-# LANGUAGE TypeFamilies #-} + +module Distribution.Client.Types.ConfiguredPackage + ( ConfiguredPackage (..) + ) where import Distribution.Client.Compat.Prelude import Prelude () import Distribution.Compat.Graph (IsNode (..)) -import Distribution.Package (newSimpleUnitId, HasMungedPackageId (..), HasUnitId (..), Package (..), PackageInstalled (..), UnitId) -import Distribution.Types.Flag (FlagAssignment) +import Distribution.Package (HasMungedPackageId (..), HasUnitId (..), Package (..), PackageInstalled (..), UnitId, newSimpleUnitId) +import Distribution.Simple.Utils (ordNub) import Distribution.Types.ComponentName +import Distribution.Types.Flag (FlagAssignment) import Distribution.Types.LibraryName (LibraryName (..)) import Distribution.Types.MungedPackageId (computeCompatPackageId) -import Distribution.Simple.Utils (ordNub) import Distribution.Client.Types.ConfiguredId -import Distribution.Solver.Types.OptionalStanza (OptionalStanzaSet) +import Distribution.Solver.Types.OptionalStanza (OptionalStanzaSet) import Distribution.Solver.Types.PackageFixedDeps -import Distribution.Solver.Types.SourcePackage (SourcePackage) +import Distribution.Solver.Types.SourcePackage (SourcePackage) import qualified Distribution.Solver.Types.ComponentDeps as CD @@ -29,45 +30,44 @@ import qualified Distribution.Solver.Types.ComponentDeps as CD -- -- 'ConfiguredPackage' is assumed to not support Backpack. Only the -- @v2-build@ codepath supports Backpack. --- data ConfiguredPackage loc = ConfiguredPackage - { confPkgId :: InstalledPackageId - , confPkgSource :: SourcePackage loc -- ^ package info, including repo - , confPkgFlags :: FlagAssignment -- ^ complete flag assignment for the package - , confPkgStanzas :: OptionalStanzaSet -- ^ list of enabled optional stanzas for the package - , confPkgDeps :: CD.ComponentDeps [ConfiguredId] - -- ^ set of exact dependencies (installed or source). - -- - -- These must be consistent with the 'buildDepends' - -- in the 'PackageDescription' that you'd get by - -- applying the flag assignment and optional stanzas. - } + { confPkgId :: InstalledPackageId + , confPkgSource :: SourcePackage loc + -- ^ package info, including repo + , confPkgFlags :: FlagAssignment + -- ^ complete flag assignment for the package + , confPkgStanzas :: OptionalStanzaSet + -- ^ list of enabled optional stanzas for the package + , confPkgDeps :: CD.ComponentDeps [ConfiguredId] + -- ^ set of exact dependencies (installed or source). + -- + -- These must be consistent with the 'buildDepends' + -- in the 'PackageDescription' that you'd get by + -- applying the flag assignment and optional stanzas. + } deriving (Eq, Show, Generic) -- | 'HasConfiguredId' indicates data types which have a 'ConfiguredId'. -- This type class is mostly used to conveniently finesse between -- 'ElaboratedPackage' and 'ElaboratedComponent'. --- instance HasConfiguredId (ConfiguredPackage loc) where - configuredId pkg = ConfiguredId (packageId pkg) (Just (CLibName LMainLibName)) (confPkgId pkg) + configuredId pkg = ConfiguredId (packageId pkg) (Just (CLibName LMainLibName)) (confPkgId pkg) -- 'ConfiguredPackage' is the legacy codepath, we are guaranteed -- to never have a nontrivial 'UnitId' instance PackageFixedDeps (ConfiguredPackage loc) where - depends = fmap (map (newSimpleUnitId . confInstId)) . confPkgDeps + depends = fmap (map (newSimpleUnitId . confInstId)) . confPkgDeps instance IsNode (ConfiguredPackage loc) where - type Key (ConfiguredPackage loc) = UnitId - nodeKey = newSimpleUnitId . confPkgId - -- TODO: if we update ConfiguredPackage to support order-only - -- dependencies, need to include those here. - -- NB: have to deduplicate, otherwise the planner gets confused - nodeNeighbors = ordNub . CD.flatDeps . depends - -instance (Binary loc) => Binary (ConfiguredPackage loc) - + type Key (ConfiguredPackage loc) = UnitId + nodeKey = newSimpleUnitId . confPkgId + -- TODO: if we update ConfiguredPackage to support order-only + -- dependencies, need to include those here. + -- NB: have to deduplicate, otherwise the planner gets confused + nodeNeighbors = ordNub . CD.flatDeps . depends +instance Binary loc => Binary (ConfiguredPackage loc) instance Package (ConfiguredPackage loc) where packageId cpkg = packageId (confPkgSource cpkg) @@ -81,4 +81,3 @@ instance HasUnitId (ConfiguredPackage loc) where instance PackageInstalled (ConfiguredPackage loc) where installedDepends = CD.flatDeps . depends - diff --git a/cabal-install/src/Distribution/Client/Types/Credentials.hs b/cabal-install/src/Distribution/Client/Types/Credentials.hs index 1b555718b85..da208111c1f 100644 --- a/cabal-install/src/Distribution/Client/Types/Credentials.hs +++ b/cabal-install/src/Distribution/Client/Types/Credentials.hs @@ -1,9 +1,9 @@ -module Distribution.Client.Types.Credentials ( - Username (..), - Password (..), -) where +module Distribution.Client.Types.Credentials + ( Username (..) + , Password (..) + ) where import Prelude (String) -newtype Username = Username { unUsername :: String } -newtype Password = Password { unPassword :: String } +newtype Username = Username {unUsername :: String} +newtype Password = Password {unPassword :: String} diff --git a/cabal-install/src/Distribution/Client/Types/InstallMethod.hs b/cabal-install/src/Distribution/Client/Types/InstallMethod.hs index c850b66f411..b7b24aecf08 100644 --- a/cabal-install/src/Distribution/Client/Types/InstallMethod.hs +++ b/cabal-install/src/Distribution/Client/Types/InstallMethod.hs @@ -1,15 +1,16 @@ {-# LANGUAGE DeriveGeneric #-} + module Distribution.Client.Types.InstallMethod where import Distribution.Client.Compat.Prelude import Prelude () import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as PP +import qualified Text.PrettyPrint as PP data InstallMethod - = InstallMethodCopy - | InstallMethodSymlink + = InstallMethodCopy + | InstallMethodSymlink deriving (Eq, Show, Generic, Bounded, Enum) instance Binary InstallMethod @@ -17,16 +18,16 @@ instance Structured InstallMethod -- | Last instance Semigroup InstallMethod where - _ <> x = x + _ <> x = x instance Parsec InstallMethod where - parsec = do - name <- P.munch1 isAlpha - case name of - "copy" -> pure InstallMethodCopy - "symlink" -> pure InstallMethodSymlink - _ -> P.unexpected $ "InstallMethod: " ++ name + parsec = do + name <- P.munch1 isAlpha + case name of + "copy" -> pure InstallMethodCopy + "symlink" -> pure InstallMethodSymlink + _ -> P.unexpected $ "InstallMethod: " ++ name instance Pretty InstallMethod where - pretty InstallMethodCopy = PP.text "copy" - pretty InstallMethodSymlink = PP.text "symlink" + pretty InstallMethodCopy = PP.text "copy" + pretty InstallMethodSymlink = PP.text "symlink" diff --git a/cabal-install/src/Distribution/Client/Types/OverwritePolicy.hs b/cabal-install/src/Distribution/Client/Types/OverwritePolicy.hs index d6f8c8b5547..e992224243a 100644 --- a/cabal-install/src/Distribution/Client/Types/OverwritePolicy.hs +++ b/cabal-install/src/Distribution/Client/Types/OverwritePolicy.hs @@ -1,31 +1,32 @@ {-# LANGUAGE DeriveGeneric #-} + module Distribution.Client.Types.OverwritePolicy where import Distribution.Client.Compat.Prelude import Prelude () import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as PP +import qualified Text.PrettyPrint as PP data OverwritePolicy - = NeverOverwrite - | AlwaysOverwrite - | PromptOverwrite + = NeverOverwrite + | AlwaysOverwrite + | PromptOverwrite deriving (Show, Eq, Generic, Bounded, Enum) instance Binary OverwritePolicy instance Structured OverwritePolicy instance Parsec OverwritePolicy where - parsec = do - name <- P.munch1 isAlpha - case name of - "always" -> pure AlwaysOverwrite - "never" -> pure NeverOverwrite - "prompt" -> pure PromptOverwrite - _ -> P.unexpected $ "OverwritePolicy: " ++ name + parsec = do + name <- P.munch1 isAlpha + case name of + "always" -> pure AlwaysOverwrite + "never" -> pure NeverOverwrite + "prompt" -> pure PromptOverwrite + _ -> P.unexpected $ "OverwritePolicy: " ++ name instance Pretty OverwritePolicy where - pretty NeverOverwrite = PP.text "never" - pretty AlwaysOverwrite = PP.text "always" - pretty PromptOverwrite = PP.text "prompt" + pretty NeverOverwrite = PP.text "never" + pretty AlwaysOverwrite = PP.text "always" + pretty PromptOverwrite = PP.text "prompt" diff --git a/cabal-install/src/Distribution/Client/Types/PackageLocation.hs b/cabal-install/src/Distribution/Client/Types/PackageLocation.hs index 2038781bbba..2f4993e22bd 100644 --- a/cabal-install/src/Distribution/Client/Types/PackageLocation.hs +++ b/cabal-install/src/Distribution/Client/Types/PackageLocation.hs @@ -1,11 +1,12 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.PackageLocation ( - PackageLocation (..), - UnresolvedPkgLoc, - ResolvedPkgLoc, - UnresolvedSourcePackage, -) where + +module Distribution.Client.Types.PackageLocation + ( PackageLocation (..) + , UnresolvedPkgLoc + , ResolvedPkgLoc + , UnresolvedSourcePackage + ) where import Distribution.Client.Compat.Prelude import Prelude () @@ -15,32 +16,27 @@ import Network.URI (URI) import Distribution.Types.PackageId (PackageId) import Distribution.Client.Types.Repo -import Distribution.Client.Types.SourceRepo (SourceRepoMaybe) +import Distribution.Client.Types.SourceRepo (SourceRepoMaybe) import Distribution.Solver.Types.SourcePackage (SourcePackage) type UnresolvedPkgLoc = PackageLocation (Maybe FilePath) type ResolvedPkgLoc = PackageLocation FilePath -data PackageLocation local = - - -- | An unpacked package in the given dir, or current dir +data PackageLocation local + = -- | An unpacked package in the given dir, or current dir LocalUnpackedPackage FilePath - - -- | A package as a tarball that's available as a local tarball - | LocalTarballPackage FilePath - - -- | A package as a tarball from a remote URI - | RemoteTarballPackage URI local - - -- | A package available as a tarball from a repository. + | -- | A package as a tarball that's available as a local tarball + LocalTarballPackage FilePath + | -- | A package as a tarball from a remote URI + RemoteTarballPackage URI local + | -- | A package available as a tarball from a repository. -- -- It may be from a local repository or from a remote repository, with a -- locally cached copy. ie a package available from hackage - | RepoTarballPackage Repo PackageId local - - -- | A package available from a version control system source repository - | RemoteSourceRepoPackage SourceRepoMaybe local + RepoTarballPackage Repo PackageId local + | -- | A package available from a version control system source repository + RemoteSourceRepoPackage SourceRepoMaybe local deriving (Show, Functor, Eq, Ord, Generic, Typeable) instance Binary local => Binary (PackageLocation local) diff --git a/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs b/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs index 3fbe0265d4f..5f25be4aa77 100644 --- a/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs +++ b/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs @@ -1,55 +1,55 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.PackageSpecifier ( - PackageSpecifier (..), - pkgSpecifierTarget, - pkgSpecifierConstraints, -) where + +module Distribution.Client.Types.PackageSpecifier + ( PackageSpecifier (..) + , pkgSpecifierTarget + , pkgSpecifierConstraints + ) where import Distribution.Client.Compat.Prelude import Prelude () -import Distribution.Package (Package (..), packageName, packageVersion) +import Distribution.Package (Package (..), packageName, packageVersion) import Distribution.Types.PackageName (PackageName) -import Distribution.Version (thisVersion) +import Distribution.Version (thisVersion) import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.PackageConstraint -- | A fully or partially resolved reference to a package. --- -data PackageSpecifier pkg = - - -- | A partially specified reference to a package (either source or - -- installed). It is specified by package name and optionally some - -- required properties. Use a dependency resolver to pick a specific - -- package satisfying these properties. - -- - NamedPackage PackageName [PackageProperty] - - -- | A fully specified source package. - -- - | SpecificSourcePackage pkg +data PackageSpecifier pkg + = -- | A partially specified reference to a package (either source or + -- installed). It is specified by package name and optionally some + -- required properties. Use a dependency resolver to pick a specific + -- package satisfying these properties. + NamedPackage PackageName [PackageProperty] + | -- | A fully specified source package. + SpecificSourcePackage pkg deriving (Eq, Show, Functor, Generic) instance Binary pkg => Binary (PackageSpecifier pkg) instance Structured pkg => Structured (PackageSpecifier pkg) pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName -pkgSpecifierTarget (NamedPackage name _) = name +pkgSpecifierTarget (NamedPackage name _) = name pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg -pkgSpecifierConstraints :: Package pkg - => PackageSpecifier pkg -> [LabeledPackageConstraint] +pkgSpecifierConstraints + :: Package pkg + => PackageSpecifier pkg + -> [LabeledPackageConstraint] pkgSpecifierConstraints (NamedPackage name props) = map toLpc props where - toLpc prop = LabeledPackageConstraint - (PackageConstraint (scopeToplevel name) prop) - ConstraintSourceUserTarget -pkgSpecifierConstraints (SpecificSourcePackage pkg) = - [LabeledPackageConstraint pc ConstraintSourceUserTarget] + toLpc prop = + LabeledPackageConstraint + (PackageConstraint (scopeToplevel name) prop) + ConstraintSourceUserTarget +pkgSpecifierConstraints (SpecificSourcePackage pkg) = + [LabeledPackageConstraint pc ConstraintSourceUserTarget] where - pc = PackageConstraint - (ScopeTarget $ packageName pkg) - (PackagePropertyVersion $ thisVersion (packageVersion pkg)) + pc = + PackageConstraint + (ScopeTarget $ packageName pkg) + (PackagePropertyVersion $ thisVersion (packageVersion pkg)) diff --git a/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs b/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs index 8a526a24817..e04b5af79c8 100644 --- a/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs +++ b/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs @@ -1,31 +1,41 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Distribution.Client.Types.ReadyPackage ( - GenericReadyPackage (..), - ReadyPackage, -) where +{-# LANGUAGE TypeFamilies #-} + +module Distribution.Client.Types.ReadyPackage + ( GenericReadyPackage (..) + , ReadyPackage + ) where import Distribution.Client.Compat.Prelude import Prelude () import Distribution.Compat.Graph (IsNode (..)) -import Distribution.Package (HasMungedPackageId, HasUnitId, Package, PackageInstalled) +import Distribution.Package (HasMungedPackageId, HasUnitId, Package, PackageInstalled) import Distribution.Client.Types.ConfiguredPackage (ConfiguredPackage) -import Distribution.Client.Types.PackageLocation (UnresolvedPkgLoc) +import Distribution.Client.Types.PackageLocation (UnresolvedPkgLoc) import Distribution.Solver.Types.PackageFixedDeps -- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be -- installed already, hence itself ready to be installed. newtype GenericReadyPackage srcpkg = ReadyPackage srcpkg -- see 'ConfiguredPackage'. - deriving (Eq, Show, Generic, Package, PackageFixedDeps, - HasMungedPackageId, HasUnitId, PackageInstalled, Binary) + deriving + ( Eq + , Show + , Generic + , Package + , PackageFixedDeps + , HasMungedPackageId + , HasUnitId + , PackageInstalled + , Binary + ) -- Can't newtype derive this instance IsNode srcpkg => IsNode (GenericReadyPackage srcpkg) where - type Key (GenericReadyPackage srcpkg) = Key srcpkg - nodeKey (ReadyPackage spkg) = nodeKey spkg - nodeNeighbors (ReadyPackage spkg) = nodeNeighbors spkg + type Key (GenericReadyPackage srcpkg) = Key srcpkg + nodeKey (ReadyPackage spkg) = nodeKey spkg + nodeNeighbors (ReadyPackage spkg) = nodeNeighbors spkg type ReadyPackage = GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc) diff --git a/cabal-install/src/Distribution/Client/Types/Repo.hs b/cabal-install/src/Distribution/Client/Types/Repo.hs index 7804c1f3c5f..b5606725432 100644 --- a/cabal-install/src/Distribution/Client/Types/Repo.hs +++ b/cabal-install/src/Distribution/Client/Types/Repo.hs @@ -1,18 +1,21 @@ {-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.Repo ( - -- * Remote repository - RemoteRepo (..), - emptyRemoteRepo, + +module Distribution.Client.Types.Repo + ( -- * Remote repository + RemoteRepo (..) + , emptyRemoteRepo + -- * Local repository (no-index) - LocalRepo (..), - emptyLocalRepo, - localRepoCacheKey, + , LocalRepo (..) + , emptyLocalRepo + , localRepoCacheKey + -- * Repository - Repo (..), - repoName, - isRepoRemote, - maybeRepoRemote, -) where + , Repo (..) + , repoName + , isRepoRemote + , maybeRepoRemote + ) where import Distribution.Client.Compat.Prelude import Prelude () @@ -23,9 +26,9 @@ import Distribution.Simple.Utils (toUTF8BS) import Distribution.Client.HashValue (hashValue, showHashValue, truncateHash) -import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp +import qualified Text.PrettyPrint as Disp import Distribution.Client.Types.RepoName @@ -33,59 +36,55 @@ import Distribution.Client.Types.RepoName -- Remote repository ------------------------------------------------------------------------------- -data RemoteRepo = - RemoteRepo { - remoteRepoName :: RepoName, - remoteRepoURI :: URI, - - -- | Enable secure access? - -- - -- 'Nothing' here represents "whatever the default is"; this is important - -- to allow for a smooth transition from opt-in to opt-out security - -- (once we switch to opt-out, all access to the central Hackage - -- repository should be secure by default) - remoteRepoSecure :: Maybe Bool, - - -- | Root key IDs (for bootstrapping) - remoteRepoRootKeys :: [String], - - -- | Threshold for verification during bootstrapping - remoteRepoKeyThreshold :: Int, - - -- | Normally a repo just specifies an HTTP or HTTPS URI, but as a - -- special case we may know a repo supports both and want to try HTTPS - -- if we can, but still allow falling back to HTTP. - -- - -- This field is not currently stored in the config file, but is filled - -- in automagically for known repos. - remoteRepoShouldTryHttps :: Bool - } - +data RemoteRepo = RemoteRepo + { remoteRepoName :: RepoName + , remoteRepoURI :: URI + , remoteRepoSecure :: Maybe Bool + -- ^ Enable secure access? + -- + -- 'Nothing' here represents "whatever the default is"; this is important + -- to allow for a smooth transition from opt-in to opt-out security + -- (once we switch to opt-out, all access to the central Hackage + -- repository should be secure by default) + , remoteRepoRootKeys :: [String] + -- ^ Root key IDs (for bootstrapping) + , remoteRepoKeyThreshold :: Int + -- ^ Threshold for verification during bootstrapping + , remoteRepoShouldTryHttps :: Bool + -- ^ Normally a repo just specifies an HTTP or HTTPS URI, but as a + -- special case we may know a repo supports both and want to try HTTPS + -- if we can, but still allow falling back to HTTP. + -- + -- This field is not currently stored in the config file, but is filled + -- in automagically for known repos. + } deriving (Show, Eq, Ord, Generic) instance Binary RemoteRepo instance Structured RemoteRepo instance Pretty RemoteRepo where - pretty r = - pretty (remoteRepoName r) <<>> Disp.colon <<>> - Disp.text (uriToString id (remoteRepoURI r) []) + pretty r = + pretty (remoteRepoName r) + <<>> Disp.colon + <<>> Disp.text (uriToString id (remoteRepoURI r) []) -- | Note: serialised format represents 'RemoteRepo' only partially. instance Parsec RemoteRepo where - parsec = do - name <- parsec - _ <- P.char ':' - uriStr <- P.munch1 (\c -> isAlphaNum c || c `elem` ("+-=._/*()@'$:;&!?~" :: String)) - uri <- maybe (fail $ "Cannot parse URI:" ++ uriStr) return (parseAbsoluteURI uriStr) - return RemoteRepo - { remoteRepoName = name - , remoteRepoURI = uri - , remoteRepoSecure = Nothing - , remoteRepoRootKeys = [] - , remoteRepoKeyThreshold = 0 - , remoteRepoShouldTryHttps = False - } + parsec = do + name <- parsec + _ <- P.char ':' + uriStr <- P.munch1 (\c -> isAlphaNum c || c `elem` ("+-=._/*()@'$:;&!?~" :: String)) + uri <- maybe (fail $ "Cannot parse URI:" ++ uriStr) return (parseAbsoluteURI uriStr) + return + RemoteRepo + { remoteRepoName = name + , remoteRepoURI = uri + , remoteRepoSecure = Nothing + , remoteRepoRootKeys = [] + , remoteRepoKeyThreshold = 0 + , remoteRepoShouldTryHttps = False + } -- | Construct a partial 'RemoteRepo' value to fold the field parser list over. emptyRemoteRepo :: RepoName -> RemoteRepo @@ -99,10 +98,10 @@ emptyRemoteRepo name = RemoteRepo name nullURI Nothing [] 0 False -- -- https://github.com/haskell/cabal/issues/6359 data LocalRepo = LocalRepo - { localRepoName :: RepoName - , localRepoPath :: FilePath - , localRepoSharedCache :: Bool - } + { localRepoName :: RepoName + , localRepoPath :: FilePath + , localRepoSharedCache :: Bool + } deriving (Show, Eq, Ord, Generic) instance Binary LocalRepo @@ -110,14 +109,14 @@ instance Structured LocalRepo -- | Note: doesn't parse 'localRepoSharedCache' field. instance Parsec LocalRepo where - parsec = do - n <- parsec - _ <- P.char ':' - p <- P.munch1 (const True) -- restrict what can be a path? - return (LocalRepo n p False) + parsec = do + n <- parsec + _ <- P.char ':' + p <- P.munch1 (const True) -- restrict what can be a path? + return (LocalRepo n p False) instance Pretty LocalRepo where - pretty (LocalRepo n p _) = pretty n <<>> Disp.colon <<>> Disp.text p + pretty (LocalRepo n p _) = pretty n <<>> Disp.colon <<>> Disp.text p -- | Construct a partial 'LocalRepo' value to fold the field parser list over. emptyLocalRepo :: RepoName -> LocalRepo @@ -129,10 +128,15 @@ emptyLocalRepo name = LocalRepo name "" False -- all be named "local", so we add a bit of `localRepoPath` into the -- mix. localRepoCacheKey :: LocalRepo -> String -localRepoCacheKey local = unRepoName (localRepoName local) ++ "-" ++ hashPart where - hashPart - = showHashValue $ truncateHash 8 $ hashValue - $ LBS.fromStrict $ toUTF8BS $ localRepoPath local +localRepoCacheKey local = unRepoName (localRepoName local) ++ "-" ++ hashPart + where + hashPart = + showHashValue $ + truncateHash 8 $ + hashValue $ + LBS.fromStrict $ + toUTF8BS $ + localRepoPath local ------------------------------------------------------------------------------- -- Any repository @@ -142,21 +146,19 @@ localRepoCacheKey local = unRepoName (localRepoName local) ++ "-" ++ hashPart wh -- -- NOTE: It is important that this type remains serializable. data Repo - -- | Local repository, without index. + = -- | Local repository, without index. -- -- https://github.com/haskell/cabal/issues/6359 - = RepoLocalNoIndex - { repoLocal :: LocalRepo + RepoLocalNoIndex + { repoLocal :: LocalRepo , repoLocalDir :: FilePath } - - -- | Standard (unsecured) remote repositories - | RepoRemote { - repoRemote :: RemoteRepo + | -- | Standard (unsecured) remote repositories + RepoRemote + { repoRemote :: RemoteRepo , repoLocalDir :: FilePath } - - -- | Secure repositories + | -- | Secure repositories -- -- Although this contains the same fields as 'RepoRemote', we use a separate -- constructor to avoid confusing the two. @@ -164,8 +166,8 @@ data Repo -- Not all access to a secure repo goes through the hackage-security -- library currently; code paths that do not still make use of the -- 'repoRemote' and 'repoLocalDir' fields directly. - | RepoSecure { - repoRemote :: RemoteRepo + RepoSecure + { repoRemote :: RemoteRepo , repoLocalDir :: FilePath } deriving (Show, Eq, Ord, Generic) @@ -176,15 +178,15 @@ instance Structured Repo -- | Check if this is a remote repo isRepoRemote :: Repo -> Bool isRepoRemote RepoLocalNoIndex{} = False -isRepoRemote _ = True +isRepoRemote _ = True -- | Extract @RemoteRepo@ from @Repo@ if remote. maybeRepoRemote :: Repo -> Maybe RemoteRepo maybeRepoRemote (RepoLocalNoIndex _ _localDir) = Nothing -maybeRepoRemote (RepoRemote r _localDir) = Just r -maybeRepoRemote (RepoSecure r _localDir) = Just r +maybeRepoRemote (RepoRemote r _localDir) = Just r +maybeRepoRemote (RepoSecure r _localDir) = Just r repoName :: Repo -> RepoName repoName (RepoLocalNoIndex r _) = localRepoName r -repoName (RepoRemote r _) = remoteRepoName r -repoName (RepoSecure r _) = remoteRepoName r +repoName (RepoRemote r _) = remoteRepoName r +repoName (RepoSecure r _) = remoteRepoName r diff --git a/cabal-install/src/Distribution/Client/Types/RepoName.hs b/cabal-install/src/Distribution/Client/Types/RepoName.hs index 37da5a638e4..2eb2fb15fc8 100644 --- a/cabal-install/src/Distribution/Client/Types/RepoName.hs +++ b/cabal-install/src/Distribution/Client/Types/RepoName.hs @@ -1,13 +1,14 @@ {-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.RepoName ( - RepoName (..), -) where + +module Distribution.Client.Types.RepoName + ( RepoName (..) + ) where import Distribution.Client.Compat.Prelude import Prelude () import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp +import qualified Text.PrettyPrint as Disp -- $setup -- >>> import Distribution.Parsec @@ -15,8 +16,7 @@ import qualified Text.PrettyPrint as Disp -- | Repository name. -- -- May be used as path segment. --- -newtype RepoName = RepoName { unRepoName :: String } +newtype RepoName = RepoName {unRepoName :: String} deriving (Show, Eq, Ord, Generic) instance Binary RepoName @@ -24,7 +24,7 @@ instance Structured RepoName instance NFData RepoName instance Pretty RepoName where - pretty = Disp.text . unRepoName + pretty = Disp.text . unRepoName -- | -- @@ -33,9 +33,9 @@ instance Pretty RepoName where -- -- >>> simpleParsec "0123" :: Maybe RepoName -- Nothing --- instance Parsec RepoName where - parsec = RepoName <$> parser where - parser = (:) <$> lead <*> rest - lead = P.satisfy (\c -> isAlpha c || c == '_' || c == '-' || c == '.') - rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-' || c == '.') + parsec = RepoName <$> parser + where + parser = (:) <$> lead <*> rest + lead = P.satisfy (\c -> isAlpha c || c == '_' || c == '-' || c == '.') + rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-' || c == '.') diff --git a/cabal-install/src/Distribution/Client/Types/SourcePackageDb.hs b/cabal-install/src/Distribution/Client/Types/SourcePackageDb.hs index 79604250a3f..d24d88a01b4 100644 --- a/cabal-install/src/Distribution/Client/Types/SourcePackageDb.hs +++ b/cabal-install/src/Distribution/Client/Types/SourcePackageDb.hs @@ -1,29 +1,29 @@ {-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.SourcePackageDb ( - SourcePackageDb (..), - lookupDependency, - lookupPackageName, -) where + +module Distribution.Client.Types.SourcePackageDb + ( SourcePackageDb (..) + , lookupDependency + , lookupPackageName + ) where import Distribution.Client.Compat.Prelude import Prelude () -import Distribution.Types.PackageName (PackageName) +import Distribution.Package (packageVersion) +import Distribution.Types.PackageName (PackageName) import Distribution.Types.VersionRange (VersionRange, withinRange) -import Distribution.Package (packageVersion) import Distribution.Client.Types.PackageLocation (UnresolvedSourcePackage) +import Distribution.Solver.Types.PackageIndex (PackageIndex) import qualified Distribution.Solver.Types.PackageIndex as PackageIndex -import Distribution.Solver.Types.PackageIndex (PackageIndex) import qualified Data.Map as Map -- | This is the information we get from a @00-index.tar.gz@ hackage index. --- data SourcePackageDb = SourcePackageDb - { packageIndex :: PackageIndex UnresolvedSourcePackage - , packagePreferences :: Map PackageName VersionRange - } + { packageIndex :: PackageIndex UnresolvedSourcePackage + , packagePreferences :: Map PackageName VersionRange + } deriving (Eq, Generic) instance Binary SourcePackageDb @@ -42,7 +42,6 @@ lookupDependency sourceDb pname version = where pref = Map.lookup pname (packagePreferences sourceDb) - -- | Does a case-sensitive search by package name. -- -- Additionally, `preferred-versions` (such as version deprecation) are diff --git a/cabal-install/src/Distribution/Client/Types/SourceRepo.hs b/cabal-install/src/Distribution/Client/Types/SourceRepo.hs index 751c6c97266..05449d1887b 100644 --- a/cabal-install/src/Distribution/Client/Types/SourceRepo.hs +++ b/cabal-install/src/Distribution/Client/Types/SourceRepo.hs @@ -1,49 +1,49 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -module Distribution.Client.Types.SourceRepo ( - SourceRepositoryPackage (..), - SourceRepoList, - SourceRepoMaybe, - SourceRepoProxy, - srpHoist, - srpToProxy, - srpFanOut, - sourceRepositoryPackageGrammar, -) where + +module Distribution.Client.Types.SourceRepo + ( SourceRepositoryPackage (..) + , SourceRepoList + , SourceRepoMaybe + , SourceRepoProxy + , srpHoist + , srpToProxy + , srpFanOut + , sourceRepositoryPackageGrammar + ) where import Distribution.Client.Compat.Prelude -import Distribution.Compat.Lens (Lens, Lens') +import Distribution.Compat.Lens (Lens, Lens') import Prelude () import Distribution.FieldGrammar import Distribution.Types.SourceRepo (RepoType (..)) -- | @source-repository-package@ definition --- data SourceRepositoryPackage f = SourceRepositoryPackage - { srpType :: !RepoType - , srpLocation :: !String - , srpTag :: !(Maybe String) - , srpBranch :: !(Maybe String) - , srpSubdir :: !(f FilePath) - , srpCommand :: ![String] - } + { srpType :: !RepoType + , srpLocation :: !String + , srpTag :: !(Maybe String) + , srpBranch :: !(Maybe String) + , srpSubdir :: !(f FilePath) + , srpCommand :: ![String] + } deriving (Generic) -deriving instance (Eq (f FilePath)) => Eq (SourceRepositoryPackage f) -deriving instance (Ord (f FilePath)) => Ord (SourceRepositoryPackage f) -deriving instance (Show (f FilePath)) => Show (SourceRepositoryPackage f) -deriving instance (Binary (f FilePath)) => Binary (SourceRepositoryPackage f) +deriving instance Eq (f FilePath) => Eq (SourceRepositoryPackage f) +deriving instance Ord (f FilePath) => Ord (SourceRepositoryPackage f) +deriving instance Show (f FilePath) => Show (SourceRepositoryPackage f) +deriving instance Binary (f FilePath) => Binary (SourceRepositoryPackage f) deriving instance (Typeable f, Structured (f FilePath)) => Structured (SourceRepositoryPackage f) -- | Read from @cabal.project@ -type SourceRepoList = SourceRepositoryPackage [] +type SourceRepoList = SourceRepositoryPackage [] -- | Distilled from 'Distribution.Types.SourceRepo.SourceRepo' type SourceRepoMaybe = SourceRepositoryPackage Maybe @@ -52,45 +52,46 @@ type SourceRepoMaybe = SourceRepositoryPackage Maybe type SourceRepoProxy = SourceRepositoryPackage Proxy srpHoist :: (forall x. f x -> g x) -> SourceRepositoryPackage f -> SourceRepositoryPackage g -srpHoist nt s = s { srpSubdir = nt (srpSubdir s) } +srpHoist nt s = s{srpSubdir = nt (srpSubdir s)} srpToProxy :: SourceRepositoryPackage f -> SourceRepositoryPackage Proxy -srpToProxy s = s { srpSubdir = Proxy } +srpToProxy s = s{srpSubdir = Proxy} -- | Split single @source-repository-package@ declaration with multiple subdirs, -- into multiple ones with at most single subdir. srpFanOut :: SourceRepositoryPackage [] -> NonEmpty (SourceRepositoryPackage Maybe) -srpFanOut s@SourceRepositoryPackage { srpSubdir = [] } = - s { srpSubdir = Nothing } :| [] -srpFanOut s@SourceRepositoryPackage { srpSubdir = d:ds } = f d :| map f ds where - f subdir = s { srpSubdir = Just subdir } +srpFanOut s@SourceRepositoryPackage{srpSubdir = []} = + s{srpSubdir = Nothing} :| [] +srpFanOut s@SourceRepositoryPackage{srpSubdir = d : ds} = f d :| map f ds + where + f subdir = s{srpSubdir = Just subdir} ------------------------------------------------------------------------------- -- Lens ------------------------------------------------------------------------------- srpTypeLens :: Lens' (SourceRepositoryPackage f) RepoType -srpTypeLens f s = fmap (\x -> s { srpType = x }) (f (srpType s)) +srpTypeLens f s = fmap (\x -> s{srpType = x}) (f (srpType s)) {-# INLINE srpTypeLens #-} srpLocationLens :: Lens' (SourceRepositoryPackage f) String -srpLocationLens f s = fmap (\x -> s { srpLocation = x }) (f (srpLocation s)) +srpLocationLens f s = fmap (\x -> s{srpLocation = x}) (f (srpLocation s)) {-# INLINE srpLocationLens #-} srpTagLens :: Lens' (SourceRepositoryPackage f) (Maybe String) -srpTagLens f s = fmap (\x -> s { srpTag = x }) (f (srpTag s)) +srpTagLens f s = fmap (\x -> s{srpTag = x}) (f (srpTag s)) {-# INLINE srpTagLens #-} srpBranchLens :: Lens' (SourceRepositoryPackage f) (Maybe String) -srpBranchLens f s = fmap (\x -> s { srpBranch = x }) (f (srpBranch s)) +srpBranchLens f s = fmap (\x -> s{srpBranch = x}) (f (srpBranch s)) {-# INLINE srpBranchLens #-} srpSubdirLens :: Lens (SourceRepositoryPackage f) (SourceRepositoryPackage g) (f FilePath) (g FilePath) -srpSubdirLens f s = fmap (\x -> s { srpSubdir = x }) (f (srpSubdir s)) +srpSubdirLens f s = fmap (\x -> s{srpSubdir = x}) (f (srpSubdir s)) {-# INLINE srpSubdirLens #-} srpCommandLensNE :: Lens' (SourceRepositoryPackage f) (Maybe (NonEmpty String)) -srpCommandLensNE f s = fmap (\x -> s { srpCommand = maybe [] toList x }) (f (nonEmpty (srpCommand s))) +srpCommandLensNE f s = fmap (\x -> s{srpCommand = maybe [] toList x}) (f (nonEmpty (srpCommand s))) {-# INLINE srpCommandLensNE #-} ------------------------------------------------------------------------------- @@ -98,18 +99,20 @@ srpCommandLensNE f s = fmap (\x -> s { srpCommand = maybe [] toList x }) (f (non ------------------------------------------------------------------------------- sourceRepositoryPackageGrammar - :: ( FieldGrammar c g, Applicative (g SourceRepoList) - , c (Identity RepoType) - , c (List NoCommaFSep FilePathNT String) - , c (NonEmpty' NoCommaFSep Token String) - ) - => g SourceRepoList SourceRepoList -sourceRepositoryPackageGrammar = SourceRepositoryPackage - <$> uniqueField "type" srpTypeLens - <*> uniqueFieldAla "location" Token srpLocationLens - <*> optionalFieldAla "tag" Token srpTagLens - <*> optionalFieldAla "branch" Token srpBranchLens - <*> monoidalFieldAla "subdir" (alaList' NoCommaFSep FilePathNT) srpSubdirLens -- note: NoCommaFSep is somewhat important for roundtrip, as "." is there... + :: ( FieldGrammar c g + , Applicative (g SourceRepoList) + , c (Identity RepoType) + , c (List NoCommaFSep FilePathNT String) + , c (NonEmpty' NoCommaFSep Token String) + ) + => g SourceRepoList SourceRepoList +sourceRepositoryPackageGrammar = + SourceRepositoryPackage + <$> uniqueField "type" srpTypeLens + <*> uniqueFieldAla "location" Token srpLocationLens + <*> optionalFieldAla "tag" Token srpTagLens + <*> optionalFieldAla "branch" Token srpBranchLens + <*> monoidalFieldAla "subdir" (alaList' NoCommaFSep FilePathNT) srpSubdirLens -- note: NoCommaFSep is somewhat important for roundtrip, as "." is there... <*> fmap (maybe [] toList) pcc where pcc = optionalFieldAla "post-checkout-command" (alaNonEmpty' NoCommaFSep Token) srpCommandLensNE diff --git a/cabal-install/src/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs b/cabal-install/src/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs index b0563ca0c12..042b62d997a 100644 --- a/cabal-install/src/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs +++ b/cabal-install/src/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs @@ -1,10 +1,11 @@ {-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy ( - WriteGhcEnvironmentFilesPolicy (..), -) where -import Prelude () +module Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy + ( WriteGhcEnvironmentFilesPolicy (..) + ) where + import Distribution.Client.Compat.Prelude +import Prelude () -- | Whether 'v2-build' should write a .ghc.environment file after -- success. Possible values: 'always', 'never' (the default), 'ghc8.4.4+' diff --git a/cabal-install/src/Distribution/Client/Upload.hs b/cabal-install/src/Distribution/Client/Upload.hs index d5f46439954..7f78ee8e2e3 100644 --- a/cabal-install/src/Distribution/Client/Upload.hs +++ b/cabal-install/src/Distribution/Client/Upload.hs @@ -1,32 +1,36 @@ module Distribution.Client.Upload (upload, uploadDoc, report) where import Distribution.Client.Compat.Prelude -import qualified Prelude as Unsafe (tail, head, read) +import qualified Prelude as Unsafe (head, read, tail) -import Distribution.Client.Types.Credentials ( Username(..), Password(..) ) -import Distribution.Client.Types.Repo (Repo, RemoteRepo(..), maybeRepoRemote) -import Distribution.Client.Types.RepoName (unRepoName) import Distribution.Client.HttpUtils - ( HttpTransport(..), remoteRepoTryUpgradeToHttps ) + ( HttpTransport (..) + , remoteRepoTryUpgradeToHttps + ) import Distribution.Client.Setup - ( IsCandidate(..), RepoContext(..) ) + ( IsCandidate (..) + , RepoContext (..) + ) +import Distribution.Client.Types.Credentials (Password (..), Username (..)) +import Distribution.Client.Types.Repo (RemoteRepo (..), Repo, maybeRepoRemote) +import Distribution.Client.Types.RepoName (unRepoName) -import Distribution.Simple.Utils (notice, warn, info, die', toUTF8BS) -import Distribution.Utils.String (trim) import Distribution.Client.Config +import Distribution.Simple.Utils (die', info, notice, toUTF8BS, warn) +import Distribution.Utils.String (trim) -import qualified Distribution.Client.BuildReports.Anonymous as BuildReport import Distribution.Client.BuildReports.Anonymous (parseBuildReport) +import qualified Distribution.Client.BuildReports.Anonymous as BuildReport import qualified Distribution.Client.BuildReports.Upload as BuildReport -import Network.URI (URI(uriPath, uriAuthority), URIAuth(uriRegName)) -import Network.HTTP (Header(..), HeaderName(..)) +import Network.HTTP (Header (..), HeaderName (..)) +import Network.URI (URI (uriAuthority, uriPath), URIAuth (uriRegName)) -import System.IO (hFlush, stdout) -import System.IO.Echo (withoutInputEcho) -import System.FilePath ((), takeExtension, takeFileName, dropExtension) -import qualified System.FilePath.Posix as FilePath.Posix (()) import System.Directory +import System.FilePath (dropExtension, takeExtension, takeFileName, ()) +import qualified System.FilePath.Posix as FilePath.Posix (()) +import System.IO (hFlush, stdout) +import System.IO.Echo (withoutInputEcho) type Auth = Maybe (String, String) @@ -36,124 +40,162 @@ type Auth = Maybe (String, String) -- Nothing stripExtensions :: [String] -> FilePath -> Maybe String stripExtensions exts path = foldM f path (reverse exts) - where - f p e - | takeExtension p == '.':e = Just (dropExtension p) - | otherwise = Nothing - -upload :: Verbosity -> RepoContext - -> Maybe Username -> Maybe Password -> IsCandidate -> [FilePath] - -> IO () + where + f p e + | takeExtension p == '.' : e = Just (dropExtension p) + | otherwise = Nothing + +upload + :: Verbosity + -> RepoContext + -> Maybe Username + -> Maybe Password + -> IsCandidate + -> [FilePath] + -> IO () upload verbosity repoCtxt mUsername mPassword isCandidate paths = do - let repos :: [Repo] - repos = repoContextRepos repoCtxt - transport <- repoContextGetTransport repoCtxt - targetRepo <- - case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of - [] -> die' verbosity "Cannot upload. No remote repositories are configured." - (r:rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r:|rs)) - let targetRepoURI :: URI - targetRepoURI = remoteRepoURI targetRepo - domain :: String - domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI - rootIfEmpty x = if null x then "/" else x - uploadURI :: URI - uploadURI = targetRepoURI { - uriPath = rootIfEmpty (uriPath targetRepoURI) FilePath.Posix. - case isCandidate of - IsCandidate -> "packages/candidates" - IsPublished -> "upload" - } - packageURI pkgid = targetRepoURI { - uriPath = rootIfEmpty (uriPath targetRepoURI) - FilePath.Posix. concat - [ "package/", pkgid - , case isCandidate of - IsCandidate -> "/candidate" - IsPublished -> "" - ] - } - Username username <- maybe (promptUsername domain) return mUsername - Password password <- maybe (promptPassword domain) return mPassword - let auth = Just (username,password) - for_ paths $ \path -> do - notice verbosity $ "Uploading " ++ path ++ "... " - case fmap takeFileName (stripExtensions ["tar", "gz"] path) of - Just pkgid -> handlePackage transport verbosity uploadURI - (packageURI pkgid) auth isCandidate path - -- This case shouldn't really happen, since we check in Main that we - -- only pass tar.gz files to upload. - Nothing -> die' verbosity $ "Not a tar.gz file: " ++ path - -uploadDoc :: Verbosity -> RepoContext - -> Maybe Username -> Maybe Password -> IsCandidate -> FilePath - -> IO () + let repos :: [Repo] + repos = repoContextRepos repoCtxt + transport <- repoContextGetTransport repoCtxt + targetRepo <- + case [remoteRepo | Just remoteRepo <- map maybeRepoRemote repos] of + [] -> die' verbosity "Cannot upload. No remote repositories are configured." + (r : rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r :| rs)) + let targetRepoURI :: URI + targetRepoURI = remoteRepoURI targetRepo + domain :: String + domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI + rootIfEmpty x = if null x then "/" else x + uploadURI :: URI + uploadURI = + targetRepoURI + { uriPath = + rootIfEmpty (uriPath targetRepoURI) + FilePath.Posix. case isCandidate of + IsCandidate -> "packages/candidates" + IsPublished -> "upload" + } + packageURI pkgid = + targetRepoURI + { uriPath = + rootIfEmpty (uriPath targetRepoURI) + FilePath.Posix. concat + [ "package/" + , pkgid + , case isCandidate of + IsCandidate -> "/candidate" + IsPublished -> "" + ] + } + Username username <- maybe (promptUsername domain) return mUsername + Password password <- maybe (promptPassword domain) return mPassword + let auth = Just (username, password) + for_ paths $ \path -> do + notice verbosity $ "Uploading " ++ path ++ "... " + case fmap takeFileName (stripExtensions ["tar", "gz"] path) of + Just pkgid -> + handlePackage + transport + verbosity + uploadURI + (packageURI pkgid) + auth + isCandidate + path + -- This case shouldn't really happen, since we check in Main that we + -- only pass tar.gz files to upload. + Nothing -> die' verbosity $ "Not a tar.gz file: " ++ path + +uploadDoc + :: Verbosity + -> RepoContext + -> Maybe Username + -> Maybe Password + -> IsCandidate + -> FilePath + -> IO () uploadDoc verbosity repoCtxt mUsername mPassword isCandidate path = do - let repos = repoContextRepos repoCtxt - transport <- repoContextGetTransport repoCtxt - targetRepo <- - case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of - [] -> die' verbosity $ "Cannot upload. No remote repositories are configured." - (r:rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r:|rs)) - let targetRepoURI = remoteRepoURI targetRepo - domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI - rootIfEmpty x = if null x then "/" else x - uploadURI = targetRepoURI { - uriPath = rootIfEmpty (uriPath targetRepoURI) - FilePath.Posix. concat - [ "package/", pkgid - , case isCandidate of - IsCandidate -> "/candidate" - IsPublished -> "" - , "/docs" - ] - } - packageUri = targetRepoURI { - uriPath = rootIfEmpty (uriPath targetRepoURI) - FilePath.Posix. concat - [ "package/", pkgid - , case isCandidate of - IsCandidate -> "/candidate" - IsPublished -> "" - ] - } - (reverseSuffix, reversePkgid) = break (== '-') - (reverse (takeFileName path)) - pkgid = reverse $ Unsafe.tail reversePkgid - when (reverse reverseSuffix /= "docs.tar.gz" - || null reversePkgid || Unsafe.head reversePkgid /= '-') $ - die' verbosity "Expected a file name matching the pattern -docs.tar.gz" - Username username <- maybe (promptUsername domain) return mUsername - Password password <- maybe (promptPassword domain) return mPassword + let repos = repoContextRepos repoCtxt + transport <- repoContextGetTransport repoCtxt + targetRepo <- + case [remoteRepo | Just remoteRepo <- map maybeRepoRemote repos] of + [] -> die' verbosity $ "Cannot upload. No remote repositories are configured." + (r : rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r :| rs)) + let targetRepoURI = remoteRepoURI targetRepo + domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI + rootIfEmpty x = if null x then "/" else x + uploadURI = + targetRepoURI + { uriPath = + rootIfEmpty (uriPath targetRepoURI) + FilePath.Posix. concat + [ "package/" + , pkgid + , case isCandidate of + IsCandidate -> "/candidate" + IsPublished -> "" + , "/docs" + ] + } + packageUri = + targetRepoURI + { uriPath = + rootIfEmpty (uriPath targetRepoURI) + FilePath.Posix. concat + [ "package/" + , pkgid + , case isCandidate of + IsCandidate -> "/candidate" + IsPublished -> "" + ] + } + (reverseSuffix, reversePkgid) = + break + (== '-') + (reverse (takeFileName path)) + pkgid = reverse $ Unsafe.tail reversePkgid + when + ( reverse reverseSuffix /= "docs.tar.gz" + || null reversePkgid + || Unsafe.head reversePkgid /= '-' + ) + $ die' verbosity "Expected a file name matching the pattern -docs.tar.gz" + Username username <- maybe (promptUsername domain) return mUsername + Password password <- maybe (promptPassword domain) return mPassword - let auth = Just (username,password) - headers = - [ Header HdrContentType "application/x-tar" - , Header HdrContentEncoding "gzip" - ] - notice verbosity $ "Uploading documentation " ++ path ++ "... " - resp <- putHttpFile transport verbosity uploadURI path auth headers - case resp of - -- Hackage responds with 204 No Content when docs are uploaded - -- successfully. - (code,_) | code `elem` [200,204] -> do - notice verbosity $ okMessage packageUri - (code,err) -> do - notice verbosity $ "Error uploading documentation " - ++ path ++ ": " - ++ "http code " ++ show code ++ "\n" - ++ err - exitFailure + let auth = Just (username, password) + headers = + [ Header HdrContentType "application/x-tar" + , Header HdrContentEncoding "gzip" + ] + notice verbosity $ "Uploading documentation " ++ path ++ "... " + resp <- putHttpFile transport verbosity uploadURI path auth headers + case resp of + -- Hackage responds with 204 No Content when docs are uploaded + -- successfully. + (code, _) | code `elem` [200, 204] -> do + notice verbosity $ okMessage packageUri + (code, err) -> do + notice verbosity $ + "Error uploading documentation " + ++ path + ++ ": " + ++ "http code " + ++ show code + ++ "\n" + ++ err + exitFailure where okMessage packageUri = case isCandidate of IsCandidate -> "Documentation successfully uploaded for package candidate. " - ++ "You can now preview the result at '" ++ show packageUri - ++ "'. To upload non-candidate documentation, use 'cabal upload --publish'." + ++ "You can now preview the result at '" + ++ show packageUri + ++ "'. To upload non-candidate documentation, use 'cabal upload --publish'." IsPublished -> "Package documentation successfully published. You can now view it at '" - ++ show packageUri ++ "'." - + ++ show packageUri + ++ "'." promptUsername :: String -> IO Username promptUsername domain = do @@ -172,60 +214,83 @@ promptPassword domain = do report :: Verbosity -> RepoContext -> Maybe Username -> Maybe Password -> IO () report verbosity repoCtxt mUsername mPassword = do - let repos :: [Repo] - repos = repoContextRepos repoCtxt + let repos :: [Repo] + repos = repoContextRepos repoCtxt remoteRepos :: [RemoteRepo] remoteRepos = mapMaybe maybeRepoRemote repos for_ remoteRepos $ \remoteRepo -> do - let domain = maybe "Hackage" uriRegName $ uriAuthority (remoteRepoURI remoteRepo) - Username username <- maybe (promptUsername domain) return mUsername - Password password <- maybe (promptPassword domain) return mPassword - let auth :: (String, String) - auth = (username, password) - - reportsDir <- defaultReportsDir - let srcDir :: FilePath - srcDir = reportsDir unRepoName (remoteRepoName remoteRepo) - -- We don't want to bomb out just because we haven't built any packages - -- from this repo yet. - srcExists <- doesDirectoryExist srcDir - when srcExists $ do - contents <- getDirectoryContents srcDir - for_ (filter (\c -> takeExtension c ==".log") contents) $ \logFile -> - do inp <- readFile (srcDir logFile) - let (reportStr, buildLog) = Unsafe.read inp :: (String,String) -- TODO: eradicateNoParse - case parseBuildReport (toUTF8BS reportStr) of - Left errs -> warn verbosity $ "Errors: " ++ errs -- FIXME - Right report' -> - do info verbosity $ "Uploading report for " - ++ prettyShow (BuildReport.package report') - BuildReport.uploadReports verbosity repoCtxt auth - (remoteRepoURI remoteRepo) [(report', Just buildLog)] - return () - -handlePackage :: HttpTransport -> Verbosity -> URI -> URI -> Auth - -> IsCandidate -> FilePath -> IO () + let domain = maybe "Hackage" uriRegName $ uriAuthority (remoteRepoURI remoteRepo) + Username username <- maybe (promptUsername domain) return mUsername + Password password <- maybe (promptPassword domain) return mPassword + let auth :: (String, String) + auth = (username, password) + + reportsDir <- defaultReportsDir + let srcDir :: FilePath + srcDir = reportsDir unRepoName (remoteRepoName remoteRepo) + -- We don't want to bomb out just because we haven't built any packages + -- from this repo yet. + srcExists <- doesDirectoryExist srcDir + when srcExists $ do + contents <- getDirectoryContents srcDir + for_ (filter (\c -> takeExtension c == ".log") contents) $ \logFile -> + do + inp <- readFile (srcDir logFile) + let (reportStr, buildLog) = Unsafe.read inp :: (String, String) -- TODO: eradicateNoParse + case parseBuildReport (toUTF8BS reportStr) of + Left errs -> warn verbosity $ "Errors: " ++ errs -- FIXME + Right report' -> + do + info verbosity $ + "Uploading report for " + ++ prettyShow (BuildReport.package report') + BuildReport.uploadReports + verbosity + repoCtxt + auth + (remoteRepoURI remoteRepo) + [(report', Just buildLog)] + return () + +handlePackage + :: HttpTransport + -> Verbosity + -> URI + -> URI + -> Auth + -> IsCandidate + -> FilePath + -> IO () handlePackage transport verbosity uri packageUri auth isCandidate path = - do resp <- postHttpFile transport verbosity uri path auth - case resp of - (code,warnings) | code `elem` [200, 204] -> - notice verbosity $ okMessage isCandidate ++ - if null warnings then "" else "\n" ++ formatWarnings (trim warnings) - (code,err) -> do - notice verbosity $ "Error uploading " ++ path ++ ": " - ++ "http code " ++ show code ++ "\n" - ++ err - exitFailure - where - okMessage :: IsCandidate -> String - okMessage IsCandidate = - "Package successfully uploaded as candidate. " - ++ "You can now preview the result at '" ++ show packageUri - ++ "'. To publish the candidate, use 'cabal upload --publish'." - okMessage IsPublished = - "Package successfully published. You can now view it at '" - ++ show packageUri ++ "'." + do + resp <- postHttpFile transport verbosity uri path auth + case resp of + (code, warnings) + | code `elem` [200, 204] -> + notice verbosity $ + okMessage isCandidate + ++ if null warnings then "" else "\n" ++ formatWarnings (trim warnings) + (code, err) -> do + notice verbosity $ + "Error uploading " + ++ path + ++ ": " + ++ "http code " + ++ show code + ++ "\n" + ++ err + exitFailure + where + okMessage :: IsCandidate -> String + okMessage IsCandidate = + "Package successfully uploaded as candidate. " + ++ "You can now preview the result at '" + ++ show packageUri + ++ "'. To publish the candidate, use 'cabal upload --publish'." + okMessage IsPublished = + "Package successfully published. You can now view it at '" + ++ show packageUri + ++ "'." formatWarnings :: String -> String formatWarnings x = "Warnings:\n" ++ (unlines . map ("- " ++) . lines) x - diff --git a/cabal-install/src/Distribution/Client/Utils.hs b/cabal-install/src/Distribution/Client/Utils.hs index 20e68a2695b..f7a51bf8c49 100644 --- a/cabal-install/src/Distribution/Client/Utils.hs +++ b/cabal-install/src/Distribution/Client/Utils.hs @@ -1,21 +1,31 @@ -{-# LANGUAGE ScopedTypeVariables, CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} module Distribution.Client.Utils - ( MergeResult(..) - , mergeBy, duplicates, duplicatesBy + ( MergeResult (..) + , mergeBy + , duplicates + , duplicatesBy , readMaybe - , inDir, withEnv, withEnvOverrides - , logDirChange, withExtraPathEnv - , determineNumJobs, numberOfProcessors + , inDir + , withEnv + , withEnvOverrides + , logDirChange + , withExtraPathEnv + , determineNumJobs + , numberOfProcessors , removeExistingFile , withTempFileName , makeAbsoluteToCwd - , makeRelativeToCwd, makeRelativeToDir + , makeRelativeToCwd + , makeRelativeToDir , makeRelativeCanonical , filePathToByteString - , byteStringToFilePath, tryCanonicalizePath + , byteStringToFilePath + , tryCanonicalizePath , canonicalizePathNoThrow - , moreRecentFile, existsAndIsMoreRecentThan + , moreRecentFile + , existsAndIsMoreRecentThan , tryFindAddSourcePackageDesc , tryFindPackageDesc , findOpenProgramLocation @@ -33,45 +43,67 @@ module Distribution.Client.Utils , giveRTSWarning ) where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () -import Distribution.Compat.Environment -import Distribution.Compat.Time ( getModTime ) -import Distribution.Simple.Setup ( Flag(..) ) -import Distribution.Version -import Distribution.Simple.Utils ( die', findPackageDesc, noticeNoWrap ) -import Distribution.System ( Platform (..), OS(..)) -import qualified Data.ByteString.Lazy as BS -import Data.Bits - ( (.|.), shiftL, shiftR ) -import System.FilePath -import Control.Monad - ( zipWithM_ ) -import Data.List - ( groupBy, elemIndex ) import qualified Control.Exception as Exception - ( finally ) + ( finally + ) import qualified Control.Exception.Safe as Safe - ( bracket ) + ( bracket + ) +import Control.Monad + ( zipWithM_ + ) +import Data.Bits + ( shiftL + , shiftR + , (.|.) + ) +import qualified Data.ByteString.Lazy as BS +import Data.List + ( elemIndex + , groupBy + ) +import Distribution.Compat.Environment +import Distribution.Compat.Time (getModTime) +import Distribution.Simple.Setup (Flag (..)) +import Distribution.Simple.Utils (die', findPackageDesc, noticeNoWrap) +import Distribution.System (OS (..), Platform (..)) +import Distribution.Version import System.Directory - ( canonicalizePath, doesFileExist, findExecutable, getCurrentDirectory - , removeFile, setCurrentDirectory, getDirectoryContents, doesDirectoryExist ) + ( canonicalizePath + , doesDirectoryExist + , doesFileExist + , findExecutable + , getCurrentDirectory + , getDirectoryContents + , removeFile + , setCurrentDirectory + ) +import System.FilePath import System.IO - ( Handle, hClose, openTempFile - , hGetEncoding, hSetEncoding - ) -import System.IO.Unsafe ( unsafePerformIO ) + ( Handle + , hClose + , hGetEncoding + , hSetEncoding + , openTempFile + ) +import System.IO.Unsafe (unsafePerformIO) -import GHC.Conc.Sync ( getNumProcessors ) -import GHC.IO.Encoding - ( recover, TextEncoding(TextEncoding) ) -import GHC.IO.Encoding.Failure - ( recoverEncode, CodingFailureMode(TransliterateCodingFailure) ) -import Data.Time.Clock.POSIX (getCurrentTime) -import Data.Time.LocalTime (getCurrentTimeZone, localDay) import Data.Time (utcToLocalTime) import Data.Time.Calendar (toGregorian) +import Data.Time.Clock.POSIX (getCurrentTime) +import Data.Time.LocalTime (getCurrentTimeZone, localDay) +import GHC.Conc.Sync (getNumProcessors) +import GHC.IO.Encoding + ( TextEncoding (TextEncoding) + , recover + ) +import GHC.IO.Encoding.Failure + ( CodingFailureMode (TransliterateCodingFailure) + , recoverEncode + ) #if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3) import qualified System.Directory as Dir import qualified System.IO.Error as IOError @@ -79,18 +111,17 @@ import qualified System.IO.Error as IOError import qualified Data.Set as Set -- | 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] mergeBy cmp = merge where - merge :: [a] -> [b] -> [MergeResult a b] - merge [] ys = [ OnlyInRight y | y <- ys] - merge xs [] = [ OnlyInLeft x | x <- xs] - merge (x:xs) (y:ys) = + merge :: [a] -> [b] -> [MergeResult a b] + merge [] ys = [OnlyInRight y | y <- ys] + merge xs [] = [OnlyInLeft x | x <- xs] + merge (x : xs) (y : ys) = case x `cmp` y of - GT -> OnlyInRight y : merge (x:xs) ys - EQ -> InBoth x y : merge xs ys - LT -> OnlyInLeft x : merge xs (y:ys) + GT -> OnlyInRight y : merge (x : xs) ys + EQ -> InBoth x y : merge xs ys + LT -> OnlyInLeft x : merge xs (y : ys) data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b @@ -102,10 +133,10 @@ duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp where eq :: a -> a -> Bool eq a b = case cmp a b of - EQ -> True - _ -> False - moreThanOne (_:_:_) = True - moreThanOne _ = False + EQ -> True + _ -> False + moreThanOne (_ : _ : _) = True + moreThanOne _ = False -- | Like 'removeFile', but does not throw an exception when the file does not -- exist. @@ -118,10 +149,11 @@ removeExistingFile path = do -- | A variant of 'withTempFile' that only gives us the file name, and while -- it will clean up the file afterwards, it's lenient if the file is -- moved\/deleted. --- -withTempFileName :: FilePath - -> String - -> (FilePath -> IO a) -> IO a +withTempFileName + :: FilePath + -> String + -> (FilePath -> IO a) + -> IO a withTempFileName tmpDir template action = Safe.bracket (openTempFile tmpDir template) @@ -163,12 +195,12 @@ withEnvOverrides overrides m = do mb_olds <- traverse lookupEnv envVars traverse_ (uncurry setOrUnsetEnv) overrides m `Exception.finally` zipWithM_ setOrUnsetEnv envVars mb_olds - where + where envVars :: [String] envVars = map fst overrides setOrUnsetEnv :: String -> Maybe String -> IO () -setOrUnsetEnv var Nothing = unsetEnv var +setOrUnsetEnv var Nothing = unsetEnv var setOrUnsetEnv var (Just val) = setEnv var val -- | Executes the action, increasing the PATH environment @@ -185,8 +217,9 @@ withExtraPathEnv paths m = do oldPath = mungePath $ intercalate [searchPathSeparator] oldPathSplit -- TODO: This is a horrible hack to work around the fact that -- setEnv can't take empty values as an argument - mungePath p | p == "" = "/dev/null" - | otherwise = p + mungePath p + | p == "" = "/dev/null" + | otherwise = p setEnv "PATH" newPath m `Exception.finally` setEnv "PATH" oldPath @@ -195,8 +228,8 @@ logDirChange :: (String -> IO ()) -> Maybe FilePath -> IO a -> IO a logDirChange _ Nothing m = m logDirChange l (Just d) m = do l $ "cabal: Entering directory '" ++ d ++ "'\n" - m `Exception.finally` - (l $ "cabal: Leaving directory '" ++ d ++ "'\n") + m + `Exception.finally` (l $ "cabal: Leaving directory '" ++ d ++ "'\n") -- The number of processors is not going to change during the duration of the -- program, so unsafePerformIO is safe here. @@ -207,28 +240,30 @@ numberOfProcessors = unsafePerformIO getNumProcessors determineNumJobs :: Flag (Maybe Int) -> Int determineNumJobs numJobsFlag = case numJobsFlag of - NoFlag -> 1 - Flag Nothing -> numberOfProcessors + NoFlag -> 1 + Flag Nothing -> numberOfProcessors Flag (Just n) -> n -- | Given a relative path, make it absolute relative to the current -- directory. Absolute paths are returned unmodified. makeAbsoluteToCwd :: FilePath -> IO FilePath -makeAbsoluteToCwd path | isAbsolute path = return path - | otherwise = do cwd <- getCurrentDirectory - return $! cwd path +makeAbsoluteToCwd path + | isAbsolute path = return path + | otherwise = do + cwd <- 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 <*> getCurrentDirectory -- | Given a path (relative or absolute), make it relative to the given -- directory, including using @../..@ if necessary. makeRelativeToDir :: FilePath -> FilePath -> IO FilePath makeRelativeToDir path dir = - makeRelativeCanonical <$> canonicalizePath path <*> canonicalizePath dir + makeRelativeCanonical <$> canonicalizePath path <*> canonicalizePath dir -- | Given a canonical absolute path and canonical absolute dir, make the path -- relative to the directory, including using @../..@ if necessary. Returns @@ -236,12 +271,13 @@ makeRelativeToDir path dir = makeRelativeCanonical :: FilePath -> FilePath -> FilePath makeRelativeCanonical path dir | takeDrive path /= takeDrive dir = path - | otherwise = go (splitPath path) (splitPath dir) + | otherwise = go (splitPath path) (splitPath dir) where - go (p:ps) (d:ds) | p' == d' = go ps ds - where (p', d') = (dropTrailingPathSeparator p, dropTrailingPathSeparator d) - go [] [] = "./" - go ps ds = joinPath (replicate (length ds) ".." ++ ps) + go (p : ps) (d : ds) | p' == d' = go ps ds + where + (p', d') = (dropTrailingPathSeparator p, dropTrailingPathSeparator d) + go [] [] = "./" + go ps ds = joinPath (replicate (length ds) ".." ++ ps) -- | Convert a 'FilePath' to a lazy 'ByteString'. Each 'Char' is -- encoded as a little-endian 'Word32'. @@ -253,7 +289,7 @@ filePathToByteString p = codepts = map (fromIntegral . ord) p conv :: Word32 -> [Word8] -> [Word8] - conv w32 rest = b0:b1:b2:b3:rest + conv w32 rest = b0 : b1 : b2 : b3 : rest where b0 = fromIntegral $ w32 b1 = fromIntegral $ w32 `shiftR` 8 @@ -262,14 +298,16 @@ filePathToByteString p = -- | Reverse operation to 'filePathToByteString'. byteStringToFilePath :: BS.ByteString -> FilePath -byteStringToFilePath bs | bslen `mod` 4 /= 0 = unexpected - | otherwise = go 0 +byteStringToFilePath bs + | bslen `mod` 4 /= 0 = unexpected + | otherwise = go 0 where unexpected = "Distribution.Client.Utils.byteStringToFilePath: unexpected" bslen = BS.length bs - go i | i == bslen = [] - | otherwise = (chr . fromIntegral $ w32) : go (i+4) + go i + | i == bslen = [] + | otherwise = (chr . fromIntegral $ w32) : go (i + 4) where w32 :: Word32 w32 = b0 .|. (b1 `shiftL` 8) .|. (b2 `shiftL` 16) .|. (b3 `shiftL` 24) @@ -280,6 +318,7 @@ byteStringToFilePath bs | bslen `mod` 4 /= 0 = unexpected -- | Workaround for the inconsistent behaviour of 'canonicalizePath'. Always -- throws an error if the path refers to a non-existent file. +{- FOURMOLU_DISABLE -} tryCanonicalizePath :: FilePath -> IO FilePath tryCanonicalizePath path = do ret <- canonicalizePath path @@ -290,6 +329,7 @@ tryCanonicalizePath path = do Nothing (Just ret) #endif return ret +{- FOURMOLU_ENABLE -} -- | A non-throwing wrapper for 'canonicalizePath'. If 'canonicalizePath' throws -- an exception, returns the path argument unmodified. @@ -308,9 +348,10 @@ moreRecentFile a b = do exists <- doesFileExist b if not exists then return True - else do tb <- getModTime b - ta <- getModTime a - return (ta > tb) + else do + tb <- getModTime b + ta <- getModTime a + return (ta > tb) -- | Like 'moreRecentFile', but also checks that the first file exists. existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool @@ -329,27 +370,31 @@ relaxEncodingErrors :: Handle -> IO () relaxEncodingErrors handle = do maybeEncoding <- hGetEncoding handle case maybeEncoding of - Just (TextEncoding name decoder encoder) | not ("UTF" `isPrefixOf` name) -> - let relax x = x { recover = recoverEncode TransliterateCodingFailure } - in hSetEncoding handle (TextEncoding name decoder (fmap relax encoder)) + Just (TextEncoding name decoder encoder) + | not ("UTF" `isPrefixOf` name) -> + let relax x = x{recover = recoverEncode TransliterateCodingFailure} + in hSetEncoding handle (TextEncoding name decoder (fmap relax encoder)) _ -> return () --- |Like 'tryFindPackageDesc', but with error specific to add-source deps. +-- | 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 - --- |Try to find 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@. +tryFindAddSourcePackageDesc verbosity depPath err = + tryFindPackageDesc verbosity depPath $ + err + ++ "\n" + ++ "Failed to read cabal file of add-source dependency: " + ++ depPath + +-- | Try to find 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 - case errOrCabalFile of - Right file -> return file - Left _ -> die' verbosity err + errOrCabalFile <- findPackageDesc depPath + case errOrCabalFile of + Right file -> return file + Left _ -> die' verbosity err findOpenProgramLocation :: Platform -> IO (Either String FilePath) findOpenProgramLocation (Platform _ os) = @@ -360,41 +405,40 @@ findOpenProgramLocation (Platform _ os) = Just s -> pure (Right s) Nothing -> pure (Left ("Couldn't find file-opener program `" <> name <> "`")) xdg = locate "xdg-open" - in case os of - Windows -> pure (Right "start") - OSX -> locate "open" - Linux -> xdg - FreeBSD -> xdg - OpenBSD -> xdg - NetBSD -> xdg - DragonFly -> xdg - _ -> pure (Left ("Couldn't determine file-opener program for " <> show os)) - + in + case os of + Windows -> pure (Right "start") + OSX -> locate "open" + Linux -> xdg + FreeBSD -> xdg + OpenBSD -> xdg + NetBSD -> xdg + DragonFly -> xdg + _ -> pure (Left ("Couldn't determine file-opener program for " <> show os)) -- | Phase of building a dependency. Represents current status of package -- dependency processing. See #4040 for details. data ProgressPhase - = ProgressDownloading - | ProgressDownloaded - | ProgressStarting - | ProgressBuilding - | ProgressHaddock - | ProgressInstalling - | ProgressCompleted + = ProgressDownloading + | ProgressDownloaded + | ProgressStarting + | ProgressBuilding + | ProgressHaddock + | ProgressInstalling + | ProgressCompleted progressMessage :: Verbosity -> ProgressPhase -> String -> IO () progressMessage verbosity phase subject = do - noticeNoWrap verbosity $ phaseStr ++ subject ++ "\n" + 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. -- @@ -405,20 +449,21 @@ progressMessage verbosity phase subject = do -- Example: @pvpize True (mkVersion [0,4,1])@ produces the version range @>= 0.4 && < 0.5@ (which is the -- same as @0.4.*@). pvpize :: Bool -> Version -> VersionRange -pvpize False v = majorBoundVersion v -pvpize True v = orLaterVersion v' - `intersectVersionRanges` - earlierVersion (incVersion 1 v') - where v' = alterVersion (take 2) v +pvpize False v = majorBoundVersion v +pvpize True v = + orLaterVersion v' + `intersectVersionRanges` earlierVersion (incVersion 1 v') + where + v' = alterVersion (take 2) v -- | Increment the nth version component (counting from 0). incVersion :: Int -> Version -> Version incVersion n = alterVersion (incVersion' n) where - incVersion' 0 [] = [1] - incVersion' 0 (v:_) = [v+1] - incVersion' m [] = replicate m 0 ++ [1] - incVersion' m (v:vs) = v : incVersion' (m-1) vs + incVersion' 0 [] = [1] + incVersion' 0 (v : _) = [v + 1] + incVersion' m [] = replicate m 0 ++ [1] + incVersion' m (v : vs) = v : incVersion' (m - 1) vs -- | Returns the current calendar year. getCurrentYear :: IO Integer @@ -433,9 +478,9 @@ getCurrentYear = do -- https://hackage.haskell.org/package/extra-1.7.9 listFilesInside :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath] listFilesInside test dir = ifNotM (test $ dropTrailingPathSeparator dir) (pure []) $ do - (dirs,files) <- partitionM doesDirectoryExist =<< listContents dir - rest <- concatMapM (listFilesInside test) dirs - pure $ files ++ rest + (dirs, files) <- partitionM doesDirectoryExist =<< listContents dir + rest <- concatMapM (listFilesInside test) dirs + pure $ files ++ rest -- | From System.Directory.Extra -- https://hackage.haskell.org/package/extra-1.7.9 @@ -446,8 +491,8 @@ listFilesRecursive = listFilesInside (const $ pure True) -- https://hackage.haskell.org/package/extra-1.7.9 listContents :: FilePath -> IO [FilePath] listContents dir = do - xs <- getDirectoryContents dir - pure $ sort [dir x | x <- xs, not $ all (== '.') x] + xs <- getDirectoryContents dir + pure $ sort [dir x | x <- xs, not $ all (== '.') x] -- | From Control.Monad.Extra -- https://hackage.haskell.org/package/extra-1.7.9 @@ -464,16 +509,17 @@ ifNotM = flip . ifM concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] {-# INLINE concatMapM #-} concatMapM op = foldr f (pure []) - where f x xs = do x' <- op x; if null x' then xs else do xs' <- xs; pure $ x' ++ xs' + where + f x xs = do x' <- op x; if null x' then xs else do { xs' <- xs; pure $ x' ++ xs' } -- | From Control.Monad.Extra -- https://hackage.haskell.org/package/extra-1.7.9 partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a]) partitionM _ [] = pure ([], []) -partitionM f (x:xs) = do - res <- f x - (as,bs) <- partitionM f xs - pure ([x | res]++as, [x | not res]++bs) +partitionM f (x : xs) = do + res <- f x + (as, bs) <- partitionM f xs + pure ([x | res] ++ as, [x | not res] ++ bs) safeRead :: Read a => String -> Maybe a safeRead s @@ -492,28 +538,32 @@ hasElem :: Ord a => [a] -> a -> Bool hasElem xs = (`Set.member` Set.fromList xs) -- True if x occurs before y -occursOnlyOrBefore :: (Eq a) => [a] -> a -> a -> Bool +occursOnlyOrBefore :: Eq a => [a] -> a -> a -> Bool occursOnlyOrBefore xs x y = case (elemIndex x xs, elemIndex y xs) of - (Just i, Just j) -> i < j - (Just _, _) -> True - _ -> False + (Just i, Just j) -> i < j + (Just _, _) -> True + _ -> False giveRTSWarning :: String -> String -giveRTSWarning "run" = "Your RTS options are applied to cabal, not the " - ++ "executable. Use '--' to separate cabal options from your " - ++ "executable options. For example, use 'cabal run -- +RTS -N " - ++ "to pass the '-N' RTS option to your executable." -giveRTSWarning "test" = "Some RTS options were found standalone, " - ++ "which affect cabal and not the binary. " - ++ "Please note that +RTS inside the --test-options argument " - ++ "suffices if your goal is to affect the tested binary. " - ++ "For example, use \"cabal test --test-options='+RTS -N'\" " - ++ "to pass the '-N' RTS option to your binary." -giveRTSWarning "bench" = "Some RTS options were found standalone, " - ++ "which affect cabal and not the binary. Please note " - ++ "that +RTS inside the --benchmark-options argument " - ++ "suffices if your goal is to affect the benchmarked " - ++ "binary. For example, use \"cabal test --benchmark-options=" - ++ "'+RTS -N'\" to pass the '-N' RTS option to your binary." -giveRTSWarning _ = "Your RTS options are applied to cabal, not the " - ++ "binary." +giveRTSWarning "run" = + "Your RTS options are applied to cabal, not the " + ++ "executable. Use '--' to separate cabal options from your " + ++ "executable options. For example, use 'cabal run -- +RTS -N " + ++ "to pass the '-N' RTS option to your executable." +giveRTSWarning "test" = + "Some RTS options were found standalone, " + ++ "which affect cabal and not the binary. " + ++ "Please note that +RTS inside the --test-options argument " + ++ "suffices if your goal is to affect the tested binary. " + ++ "For example, use \"cabal test --test-options='+RTS -N'\" " + ++ "to pass the '-N' RTS option to your binary." +giveRTSWarning "bench" = + "Some RTS options were found standalone, " + ++ "which affect cabal and not the binary. Please note " + ++ "that +RTS inside the --benchmark-options argument " + ++ "suffices if your goal is to affect the benchmarked " + ++ "binary. For example, use \"cabal test --benchmark-options=" + ++ "'+RTS -N'\" to pass the '-N' RTS option to your binary." +giveRTSWarning _ = + "Your RTS options are applied to cabal, not the " + ++ "binary." diff --git a/cabal-install/src/Distribution/Client/Utils/Json.hs b/cabal-install/src/Distribution/Client/Utils/Json.hs index 01d5753136b..ebbf2bb27fd 100644 --- a/cabal-install/src/Distribution/Client/Utils/Json.hs +++ b/cabal-install/src/Distribution/Client/Utils/Json.hs @@ -5,15 +5,17 @@ -- The API is heavily inspired by @aeson@'s API but puts emphasis on -- simplicity rather than performance. The 'ToJSON' instances are -- intended to have an encoding compatible with @aeson@'s encoding. --- module Distribution.Client.Utils.Json - ( Value(..) - , Object, object, Pair, (.=) - , encodeToString - , encodeToBuilder - , ToJSON(toJSON) - ) - where + ( Value (..) + , Object + , object + , Pair + , (.=) + , encodeToString + , encodeToBuilder + , ToJSON (toJSON) + ) +where import Distribution.Client.Compat.Prelude @@ -25,13 +27,14 @@ import qualified Data.ByteString.Builder as BB -- TODO: We may want to replace 'String' with 'Text' or 'ByteString' -- | A JSON value represented as a Haskell value. -data Value = Object !Object - | Array [Value] - | String String - | Number !Double - | Bool !Bool - | Null - deriving (Eq, Read, Show) +data Value + = Object !Object + | Array [Value] + | String String + | Number !Double + | Bool !Bool + | Null + deriving (Eq, Read, Show) -- | A key\/value pair for an 'Object' type Pair = (String, Value) @@ -43,7 +46,7 @@ infixr 8 .= -- | A key-value pair for encoding a JSON object. (.=) :: ToJSON v => String -> v -> Pair -k .= v = (k, toJSON v) +k .= v = (k, toJSON v) -- | Create a 'Value' from a list of name\/value 'Pair's. object :: [Pair] -> Value @@ -52,7 +55,6 @@ object = Object instance IsString Value where fromString = String - -- | A type that can be converted to JSON. class ToJSON a where -- | Convert a Haskell value to a JSON-friendly intermediate type. @@ -71,17 +73,17 @@ instance ToJSON a => ToJSON [a] where toJSON = Array . map toJSON instance ToJSON a => ToJSON (Maybe a) where - toJSON Nothing = Null + toJSON Nothing = Null toJSON (Just a) = toJSON a -instance (ToJSON a,ToJSON b) => ToJSON (a,b) where - toJSON (a,b) = Array [toJSON a, toJSON b] +instance (ToJSON a, ToJSON b) => ToJSON (a, b) where + toJSON (a, b) = Array [toJSON a, toJSON b] -instance (ToJSON a,ToJSON b,ToJSON c) => ToJSON (a,b,c) where - toJSON (a,b,c) = Array [toJSON a, toJSON b, toJSON c] +instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a, b, c) where + toJSON (a, b, c) = Array [toJSON a, toJSON b, toJSON c] -instance (ToJSON a,ToJSON b,ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where - toJSON (a,b,c,d) = Array [toJSON a, toJSON b, toJSON c, toJSON d] +instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a, b, c, d) where + toJSON (a, b, c, d) = Array [toJSON a, toJSON b, toJSON c, toJSON d] instance ToJSON Float where toJSON = Number . realToFrac @@ -89,21 +91,21 @@ instance ToJSON Float where instance ToJSON Double where toJSON = Number -instance ToJSON Int where toJSON = Number . realToFrac -instance ToJSON Int8 where toJSON = Number . realToFrac -instance ToJSON Int16 where toJSON = Number . realToFrac -instance ToJSON Int32 where toJSON = Number . realToFrac +instance ToJSON Int where toJSON = Number . realToFrac +instance ToJSON Int8 where toJSON = Number . realToFrac +instance ToJSON Int16 where toJSON = Number . realToFrac +instance ToJSON Int32 where toJSON = Number . realToFrac -instance ToJSON Word where toJSON = Number . realToFrac -instance ToJSON Word8 where toJSON = Number . realToFrac -instance ToJSON Word16 where toJSON = Number . realToFrac -instance ToJSON Word32 where toJSON = Number . realToFrac +instance ToJSON Word where toJSON = Number . realToFrac +instance ToJSON Word8 where toJSON = Number . realToFrac +instance ToJSON Word16 where toJSON = Number . realToFrac +instance ToJSON Word32 where toJSON = Number . realToFrac -- | Possibly lossy due to conversion to 'Double' -instance ToJSON Int64 where toJSON = Number . realToFrac +instance ToJSON Int64 where toJSON = Number . realToFrac -- | Possibly lossy due to conversion to 'Double' -instance ToJSON Word64 where toJSON = Number . realToFrac +instance ToJSON Word64 where toJSON = Number . realToFrac -- | Possibly lossy due to conversion to 'Double' instance ToJSON Integer where toJSON = Number . fromInteger @@ -117,14 +119,14 @@ encodeToBuilder = encodeValueBB . toJSON encodeValueBB :: Value -> Builder encodeValueBB jv = case jv of - Bool True -> "true" + Bool True -> "true" Bool False -> "false" - Null -> "null" + Null -> "null" Number n - | isNaN n || isInfinite n -> encodeValueBB Null + | isNaN n || isInfinite n -> encodeValueBB Null | Just i <- doubleToInt64 n -> BB.int64Dec i - | otherwise -> BB.doubleDec n - Array a -> encodeArrayBB a + | otherwise -> BB.doubleDec n + Array a -> encodeArrayBB a String s -> encodeStringBB s Object o -> encodeObjectBB o @@ -139,7 +141,7 @@ encodeObjectBB [] = "{}" encodeObjectBB jvs = BB.char8 '{' <> go jvs <> BB.char8 '}' where go = mconcat . intersperse (BB.char8 ',') . map encPair - encPair (l,x) = encodeStringBB l <> BB.char8 ':' <> encodeValueBB x + encPair (l, x) = encodeStringBB l <> BB.char8 ':' <> encodeValueBB x encodeStringBB :: String -> Builder encodeStringBB str = BB.char8 '"' <> go str <> BB.char8 '"' @@ -155,34 +157,34 @@ encodeToString jv = encodeValue (toJSON jv) [] encodeValue :: Value -> ShowS encodeValue jv = case jv of - Bool b -> showString (if b then "true" else "false") - Null -> showString "null" + Bool b -> showString (if b then "true" else "false") + Null -> showString "null" Number n - | isNaN n || isInfinite n -> encodeValue Null + | isNaN n || isInfinite n -> encodeValue Null | Just i <- doubleToInt64 n -> shows i - | otherwise -> shows n + | otherwise -> shows n Array a -> encodeArray a String s -> encodeString s Object o -> encodeObject o encodeArray :: [Value] -> ShowS encodeArray [] = showString "[]" -encodeArray jvs = ('[':) . go jvs . (']':) +encodeArray jvs = ('[' :) . go jvs . (']' :) where - go [] = id - go [x] = encodeValue x - go (x:xs) = encodeValue x . (',':) . go xs + go [] = id + go [x] = encodeValue x + go (x : xs) = encodeValue x . (',' :) . go xs encodeObject :: Object -> ShowS encodeObject [] = showString "{}" -encodeObject jvs = ('{':) . go jvs . ('}':) +encodeObject jvs = ('{' :) . go jvs . ('}' :) where - go [] = id - go [(l,x)] = encodeString l . (':':) . encodeValue x - go ((l,x):lxs) = encodeString l . (':':) . encodeValue x . (',':) . go lxs + go [] = id + go [(l, x)] = encodeString l . (':' :) . encodeValue x + go ((l, x) : lxs) = encodeString l . (':' :) . encodeValue x . (',' :) . go lxs encodeString :: String -> ShowS -encodeString str = ('"':) . showString (escapeString str) . ('"':) +encodeString str = ('"' :) . showString (escapeString str) . ('"' :) ------------------------------------------------------------------------------ -- helpers @@ -193,8 +195,8 @@ doubleToInt64 :: Double -> Maybe Int64 doubleToInt64 x | fromInteger x' == x , x' <= toInteger (maxBound :: Int64) - , x' >= toInteger (minBound :: Int64) - = Just (fromIntegral x') + , x' >= toInteger (minBound :: Int64) = + Just (fromIntegral x') | otherwise = Nothing where x' = round x @@ -203,20 +205,21 @@ doubleToInt64 x escapeString :: String -> String escapeString s | not (any needsEscape s) = s - | otherwise = escape s + | otherwise = escape s where escape [] = [] - escape (x:xs) = case x of - '\\' -> '\\':'\\':escape xs - '"' -> '\\':'"':escape xs - '\b' -> '\\':'b':escape xs - '\f' -> '\\':'f':escape xs - '\n' -> '\\':'n':escape xs - '\r' -> '\\':'r':escape xs - '\t' -> '\\':'t':escape xs - c | ord c < 0x10 -> '\\':'u':'0':'0':'0':intToDigit (ord c):escape xs - | ord c < 0x20 -> '\\':'u':'0':'0':'1':intToDigit (ord c - 0x10):escape xs - | otherwise -> c : escape xs + escape (x : xs) = case x of + '\\' -> '\\' : '\\' : escape xs + '"' -> '\\' : '"' : escape xs + '\b' -> '\\' : 'b' : escape xs + '\f' -> '\\' : 'f' : escape xs + '\n' -> '\\' : 'n' : escape xs + '\r' -> '\\' : 'r' : escape xs + '\t' -> '\\' : 't' : escape xs + c + | ord c < 0x10 -> '\\' : 'u' : '0' : '0' : '0' : intToDigit (ord c) : escape xs + | ord c < 0x20 -> '\\' : 'u' : '0' : '0' : '1' : intToDigit (ord c - 0x10) : escape xs + | otherwise -> c : escape xs -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF - needsEscape c = ord c < 0x20 || c `elem` ['\\','"'] + needsEscape c = ord c < 0x20 || c `elem` ['\\', '"'] diff --git a/cabal-install/src/Distribution/Client/Utils/Parsec.hs b/cabal-install/src/Distribution/Client/Utils/Parsec.hs index b0afe8f5767..abc9ddd1321 100644 --- a/cabal-install/src/Distribution/Client/Utils/Parsec.hs +++ b/cabal-install/src/Distribution/Client/Utils/Parsec.hs @@ -1,64 +1,66 @@ -module Distribution.Client.Utils.Parsec ( - renderParseError, - ) where +module Distribution.Client.Utils.Parsec + ( renderParseError + ) where import Distribution.Client.Compat.Prelude +import System.FilePath (normalise) import Prelude () -import System.FilePath (normalise) -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 -import Distribution.Parsec (PError (..), PWarning (..), Position (..), showPos, zeroPos) +import Distribution.Parsec (PError (..), PWarning (..), Position (..), showPos, zeroPos) import Distribution.Simple.Utils (fromUTF8BS) -- | Render parse error highlighting the part of the input file. renderParseError - :: FilePath - -> BS.ByteString - -> NonEmpty PError - -> [PWarning] - -> String -renderParseError filepath contents errors warnings = unlines $ + :: FilePath + -> BS.ByteString + -> NonEmpty PError + -> [PWarning] + -> String +renderParseError filepath contents errors warnings = + unlines $ [ "Errors encountered when parsing cabal file " <> filepath <> ":" ] - ++ renderedErrors - ++ renderedWarnings + ++ renderedErrors + ++ renderedWarnings where filepath' = normalise filepath -- lines of the input file. 'lines' is taken, so they are called rows -- contents, line number, whether it's empty line rows :: [(String, Int, Bool)] - rows = zipWith f (BS8.lines contents) [1..] where + rows = zipWith f (BS8.lines contents) [1 ..] + where f bs i = let s = fromUTF8BS bs in (s, i, isEmptyOrComment s) rowsZipper = listToZipper rows isEmptyOrComment :: String -> Bool isEmptyOrComment s = case dropWhile (== ' ') s of - "" -> True -- empty - ('-':'-':_) -> True -- comment - _ -> False + "" -> True -- empty + ('-' : '-' : _) -> True -- comment + _ -> False - renderedErrors = concatMap renderError errors + renderedErrors = concatMap renderError errors renderedWarnings = concatMap renderWarning warnings renderError :: PError -> [String] renderError (PError pos@(Position row col) msg) - -- if position is 0:0, then it doesn't make sense to show input - -- looks like, Parsec errors have line-feed in them - | pos == zeroPos = msgs - | otherwise = msgs ++ formatInput row col + -- if position is 0:0, then it doesn't make sense to show input + -- looks like, Parsec errors have line-feed in them + | pos == zeroPos = msgs + | otherwise = msgs ++ formatInput row col where - msgs = [ "", filepath' ++ ":" ++ showPos pos ++ ": error:", trimLF msg, "" ] + msgs = ["", filepath' ++ ":" ++ showPos pos ++ ": error:", trimLF msg, ""] renderWarning :: PWarning -> [String] renderWarning (PWarning _ pos@(Position row col) msg) - | pos == zeroPos = msgs - | otherwise = msgs ++ formatInput row col + | pos == zeroPos = msgs + | otherwise = msgs ++ formatInput row col where - msgs = [ "", filepath' ++ ":" ++ showPos pos ++ ": warning:", trimLF msg, "" ] + msgs = ["", filepath' ++ ":" ++ showPos pos ++ ": warning:", trimLF msg, ""] -- sometimes there are (especially trailing) newlines. trimLF :: String -> String @@ -67,19 +69,20 @@ renderParseError filepath contents errors warnings = unlines $ -- format line: prepend the given line number formatInput :: Int -> Int -> [String] formatInput row col = case advance (row - 1) rowsZipper of - Zipper xs ys -> before ++ after where - before = case span (\(_, _, b) -> b) xs of - (_, []) -> [] - (zs, z : _) -> map formatInputLine $ z : reverse zs - - after = case ys of - [] -> [] - (z : _zs) -> - [ formatInputLine z -- error line - , " | " ++ replicate (col - 1) ' ' ++ "^" -- pointer: ^ - ] - -- do we need rows after? - -- ++ map formatInputLine (take 1 zs) -- one row after + Zipper xs ys -> before ++ after + where + before = case span (\(_, _, b) -> b) xs of + (_, []) -> [] + (zs, z : _) -> map formatInputLine $ z : reverse zs + + after = case ys of + [] -> [] + (z : _zs) -> + [ formatInputLine z -- error line + , " | " ++ replicate (col - 1) ' ' ++ "^" -- pointer: ^ + ] + -- do we need rows after? + -- ++ map formatInputLine (take 1 zs) -- one row after formatInputLine :: (String, Int, Bool) -> String formatInputLine (str, row, _) = leftPadShow row ++ " | " ++ str @@ -96,7 +99,7 @@ listToZipper = Zipper [] advance :: Int -> Zipper a -> Zipper a advance n z@(Zipper xs ys) - | n <= 0 = z - | otherwise = case ys of - [] -> z - (y:ys') -> advance (n - 1) $ Zipper (y:xs) ys' + | n <= 0 = z + | otherwise = case ys of + [] -> z + (y : ys') -> advance (n - 1) $ Zipper (y : xs) ys' diff --git a/cabal-install/src/Distribution/Client/VCS.hs b/cabal-install/src/Distribution/Client/VCS.hs index aca3f4b109f..7322253e692 100644 --- a/cabal-install/src/Distribution/Client/VCS.hs +++ b/cabal-install/src/Distribution/Client/VCS.hs @@ -1,58 +1,76 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NamedFieldPuns, RecordWildCards, RankNTypes #-} -module Distribution.Client.VCS ( - -- * VCS driver type - VCS, - vcsRepoType, - vcsProgram, + +module Distribution.Client.VCS + ( -- * VCS driver type + VCS + , vcsRepoType + , vcsProgram + -- ** Type re-exports - RepoType, - Program, - ConfiguredProgram, + , RepoType + , Program + , ConfiguredProgram -- * Validating 'SourceRepo's and configuring VCS drivers - validatePDSourceRepo, - validateSourceRepo, - validateSourceRepos, - SourceRepoProblem(..), - configureVCS, - configureVCSs, + , validatePDSourceRepo + , validateSourceRepo + , validateSourceRepos + , SourceRepoProblem (..) + , configureVCS + , configureVCSs -- * Running the VCS driver - cloneSourceRepo, - syncSourceRepos, + , cloneSourceRepo + , syncSourceRepos -- * The individual VCS drivers - knownVCSs, - vcsBzr, - vcsDarcs, - vcsGit, - vcsHg, - vcsSvn, - vcsPijul, + , knownVCSs + , vcsBzr + , vcsDarcs + , vcsGit + , vcsHg + , vcsSvn + , vcsPijul ) where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () -import Distribution.Types.SourceRepo - ( RepoType(..), KnownRepoType (..) ) -import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..), srpToProxy) import Distribution.Client.RebuildMonad - ( Rebuild, monitorFiles, MonitorFilePath, monitorDirectoryExistence ) -import Distribution.Verbosity as Verbosity - ( normal ) + ( MonitorFilePath + , Rebuild + , monitorDirectoryExistence + , monitorFiles + ) +import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..), srpToProxy) +import qualified Distribution.PackageDescription as PD import Distribution.Simple.Program - ( Program(programFindVersion) - , ConfiguredProgram(programVersion) - , simpleProgram, findProgramVersion - , ProgramInvocation(..), programInvocation, runProgramInvocation, getProgramInvocationOutput - , emptyProgramDb, requireProgram ) + ( ConfiguredProgram (programVersion) + , Program (programFindVersion) + , ProgramInvocation (..) + , emptyProgramDb + , findProgramVersion + , getProgramInvocationOutput + , programInvocation + , requireProgram + , runProgramInvocation + , simpleProgram + ) +import Distribution.Types.SourceRepo + ( KnownRepoType (..) + , RepoType (..) + ) +import Distribution.Verbosity as Verbosity + ( normal + ) import Distribution.Version - ( mkVersion ) -import qualified Distribution.PackageDescription as PD + ( mkVersion + ) #if !MIN_VERSION_base(4,18,0) import Control.Applicative @@ -60,130 +78,143 @@ import Control.Applicative #endif import Control.Exception - ( throw, try ) + ( throw + , try + ) import Control.Monad.Trans - ( liftIO ) + ( liftIO + ) import qualified Data.Char as Char import qualified Data.List as List -import qualified Data.Map as Map -import System.FilePath - ( takeDirectory, () ) +import qualified Data.Map as Map import System.Directory - ( doesDirectoryExist - , removeDirectoryRecursive - ) + ( doesDirectoryExist + , removeDirectoryRecursive + ) +import System.FilePath + ( takeDirectory + , () + ) import System.IO.Error - ( isDoesNotExistError ) - + ( isDoesNotExistError + ) -- | A driver for a version control system, e.g. git, darcs etc. --- -data VCS program = VCS { - -- | The type of repository this driver is for. - vcsRepoType :: RepoType, - - -- | The vcs program itself. - -- This is used at type 'Program' and 'ConfiguredProgram'. - vcsProgram :: program, - - -- | The program invocation(s) to get\/clone a repository into a fresh - -- local directory. - vcsCloneRepo :: forall f. Verbosity - -> ConfiguredProgram - -> SourceRepositoryPackage f - -> FilePath -- Source URI - -> FilePath -- Destination directory - -> [ProgramInvocation], - - -- | The program invocation(s) to synchronise a whole set of /related/ - -- repositories with corresponding local directories. Also returns the - -- files that the command depends on, for change monitoring. - vcsSyncRepos :: forall f. Verbosity - -> ConfiguredProgram - -> [(SourceRepositoryPackage f, FilePath)] - -> IO [MonitorFilePath] - } - +data VCS program = VCS + { vcsRepoType :: RepoType + -- ^ The type of repository this driver is for. + , vcsProgram :: program + -- ^ The vcs program itself. + -- This is used at type 'Program' and 'ConfiguredProgram'. + , vcsCloneRepo + :: forall f + . Verbosity + -> ConfiguredProgram + -> SourceRepositoryPackage f + -> FilePath -- Source URI + -> FilePath -- Destination directory + -> [ProgramInvocation] + -- ^ The program invocation(s) to get\/clone a repository into a fresh + -- local directory. + , vcsSyncRepos + :: forall f + . Verbosity + -> ConfiguredProgram + -> [(SourceRepositoryPackage f, FilePath)] + -> IO [MonitorFilePath] + -- ^ The program invocation(s) to synchronise a whole set of /related/ + -- repositories with corresponding local directories. Also returns the + -- files that the command depends on, for change monitoring. + } -- ------------------------------------------------------------ + -- * Selecting repos and drivers + -- ------------------------------------------------------------ -data SourceRepoProblem = SourceRepoRepoTypeUnspecified - | SourceRepoRepoTypeUnsupported (SourceRepositoryPackage Proxy) RepoType - | SourceRepoLocationUnspecified - deriving Show +data SourceRepoProblem + = SourceRepoRepoTypeUnspecified + | SourceRepoRepoTypeUnsupported (SourceRepositoryPackage Proxy) RepoType + | SourceRepoLocationUnspecified + deriving (Show) -- | Validates that the 'SourceRepo' specifies a location URI and a repository -- type that is supported by a VCS driver. -- -- | It also returns the 'VCS' driver we should use to work with it. --- validateSourceRepo - :: SourceRepositoryPackage f - -> Either SourceRepoProblem (SourceRepositoryPackage f, String, RepoType, VCS Program) + :: SourceRepositoryPackage f + -> Either SourceRepoProblem (SourceRepositoryPackage f, String, RepoType, VCS Program) validateSourceRepo = \repo -> do - let rtype = srpType repo - vcs <- Map.lookup rtype knownVCSs ?! SourceRepoRepoTypeUnsupported (srpToProxy repo) rtype - let uri = srpLocation repo - return (repo, uri, rtype, vcs) + let rtype = srpType repo + vcs <- Map.lookup rtype knownVCSs ?! SourceRepoRepoTypeUnsupported (srpToProxy repo) rtype + let uri = srpLocation repo + return (repo, uri, rtype, vcs) where a ?! e = maybe (Left e) Right a validatePDSourceRepo - :: PD.SourceRepo - -> Either SourceRepoProblem (SourceRepoMaybe, String, RepoType, VCS Program) + :: PD.SourceRepo + -> Either SourceRepoProblem (SourceRepoMaybe, String, RepoType, VCS Program) validatePDSourceRepo repo = do - rtype <- PD.repoType repo ?! SourceRepoRepoTypeUnspecified - uri <- PD.repoLocation repo ?! SourceRepoLocationUnspecified - validateSourceRepo SourceRepositoryPackage - { srpType = rtype - , srpLocation = uri - , srpTag = PD.repoTag repo - , srpBranch = PD.repoBranch repo - , srpSubdir = PD.repoSubdir repo - , srpCommand = mempty - } + rtype <- PD.repoType repo ?! SourceRepoRepoTypeUnspecified + uri <- PD.repoLocation repo ?! SourceRepoLocationUnspecified + validateSourceRepo + SourceRepositoryPackage + { srpType = rtype + , srpLocation = uri + , srpTag = PD.repoTag repo + , srpBranch = PD.repoBranch repo + , srpSubdir = PD.repoSubdir repo + , srpCommand = mempty + } where a ?! e = maybe (Left e) Right a - - -- | As 'validateSourceRepo' but for a bunch of 'SourceRepo's, and return -- things in a convenient form to pass to 'configureVCSs', or to report -- problems. --- -validateSourceRepos :: [SourceRepositoryPackage f] - -> Either [(SourceRepositoryPackage f, SourceRepoProblem)] - [(SourceRepositoryPackage f, String, RepoType, VCS Program)] +validateSourceRepos + :: [SourceRepositoryPackage f] + -> Either + [(SourceRepositoryPackage f, SourceRepoProblem)] + [(SourceRepositoryPackage f, String, RepoType, VCS Program)] validateSourceRepos rs = - case partitionEithers (map validateSourceRepo' rs) of - (problems@(_:_), _) -> Left problems - ([], vcss) -> Right vcss + case partitionEithers (map validateSourceRepo' rs) of + (problems@(_ : _), _) -> Left problems + ([], vcss) -> Right vcss where - validateSourceRepo' :: SourceRepositoryPackage f - -> Either (SourceRepositoryPackage f, SourceRepoProblem) - (SourceRepositoryPackage f, String, RepoType, VCS Program) - validateSourceRepo' r = either (Left . (,) r) Right - (validateSourceRepo r) - - -configureVCS :: Verbosity - -> VCS Program - -> IO (VCS ConfiguredProgram) + validateSourceRepo' + :: SourceRepositoryPackage f + -> Either + (SourceRepositoryPackage f, SourceRepoProblem) + (SourceRepositoryPackage f, String, RepoType, VCS Program) + validateSourceRepo' r = + either + (Left . (,) r) + Right + (validateSourceRepo r) + +configureVCS + :: Verbosity + -> VCS Program + -> IO (VCS ConfiguredProgram) configureVCS verbosity vcs@VCS{vcsProgram = prog} = - asVcsConfigured <$> requireProgram verbosity prog emptyProgramDb + asVcsConfigured <$> requireProgram verbosity prog emptyProgramDb where - asVcsConfigured (prog', _) = vcs { vcsProgram = prog' } + asVcsConfigured (prog', _) = vcs{vcsProgram = prog'} -configureVCSs :: Verbosity - -> Map RepoType (VCS Program) - -> IO (Map RepoType (VCS ConfiguredProgram)) +configureVCSs + :: Verbosity + -> Map RepoType (VCS Program) + -> IO (Map RepoType (VCS ConfiguredProgram)) configureVCSs verbosity = traverse (configureVCS verbosity) - -- ------------------------------------------------------------ + -- * Running the driver + -- ------------------------------------------------------------ -- | Clone a single source repo into a fresh directory, using a configured VCS. @@ -192,22 +223,27 @@ configureVCSs verbosity = traverse (configureVCS verbosity) -- fail if the destination directory already exists. -- -- Make sure to validate the 'SourceRepo' using 'validateSourceRepo' first. --- - cloneSourceRepo - :: Verbosity - -> VCS ConfiguredProgram - -> SourceRepositoryPackage f - -> [Char] - -> IO () -cloneSourceRepo verbosity vcs - repo@SourceRepositoryPackage{ srpLocation = srcuri } destdir = + :: Verbosity + -> VCS ConfiguredProgram + -> SourceRepositoryPackage f + -> [Char] + -> IO () +cloneSourceRepo + verbosity + vcs + repo@SourceRepositoryPackage{srpLocation = srcuri} + destdir = traverse_ (runProgramInvocation verbosity) invocations - where - invocations = vcsCloneRepo vcs verbosity - (vcsProgram vcs) repo - srcuri destdir - + where + invocations = + vcsCloneRepo + vcs + verbosity + (vcsProgram vcs) + repo + srcuri + destdir -- | Synchronise a set of 'SourceRepo's referring to the same repository with -- corresponding local directories. The local directories may or may not @@ -223,118 +259,127 @@ cloneSourceRepo verbosity vcs -- For example if a single repo contains multiple packages in different subdirs -- and in some project it may make sense to use a different state of the repo -- for one subdir compared to another. --- -syncSourceRepos :: Verbosity - -> VCS ConfiguredProgram - -> [(SourceRepositoryPackage f, FilePath)] - -> Rebuild () +syncSourceRepos + :: Verbosity + -> VCS ConfiguredProgram + -> [(SourceRepositoryPackage f, FilePath)] + -> Rebuild () syncSourceRepos verbosity vcs repos = do - files <- liftIO $ vcsSyncRepos vcs verbosity (vcsProgram vcs) repos - monitorFiles files - + files <- liftIO $ vcsSyncRepos vcs verbosity (vcsProgram vcs) repos + monitorFiles files -- ------------------------------------------------------------ + -- * The various VCS drivers + -- ------------------------------------------------------------ -- | The set of all supported VCS drivers, organised by 'RepoType'. --- knownVCSs :: Map RepoType (VCS Program) -knownVCSs = Map.fromList [ (vcsRepoType vcs, vcs) | vcs <- vcss ] +knownVCSs = Map.fromList [(vcsRepoType vcs, vcs) | vcs <- vcss] where - vcss = [ vcsBzr, vcsDarcs, vcsGit, vcsHg, vcsSvn ] - + vcss = [vcsBzr, vcsDarcs, vcsGit, vcsHg, vcsSvn] -- | VCS driver for Bazaar. --- vcsBzr :: VCS Program vcsBzr = - VCS { - vcsRepoType = KnownRepoType Bazaar, - vcsProgram = bzrProgram, - vcsCloneRepo, - vcsSyncRepos + VCS + { vcsRepoType = KnownRepoType Bazaar + , vcsProgram = bzrProgram + , vcsCloneRepo + , vcsSyncRepos } where - vcsCloneRepo :: Verbosity - -> ConfiguredProgram - -> SourceRepositoryPackage f - -> FilePath - -> FilePath - -> [ProgramInvocation] + vcsCloneRepo + :: Verbosity + -> ConfiguredProgram + -> SourceRepositoryPackage f + -> FilePath + -> FilePath + -> [ProgramInvocation] vcsCloneRepo verbosity prog repo srcuri destdir = - [ programInvocation prog - ([branchCmd, srcuri, destdir] ++ tagArgs ++ verboseArg) ] + [ programInvocation + prog + ([branchCmd, srcuri, destdir] ++ tagArgs ++ verboseArg) + ] where -- The @get@ command was deprecated in version 2.4 in favour of -- the alias @branch@ - branchCmd | programVersion prog >= Just (mkVersion [2,4]) - = "branch" - | otherwise = "get" + branchCmd + | programVersion prog >= Just (mkVersion [2, 4]) = + "branch" + | otherwise = "get" tagArgs :: [String] tagArgs = case srpTag repo of - Nothing -> [] + Nothing -> [] Just tag -> ["-r", "tag:" ++ tag] verboseArg :: [String] - verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + verboseArg = ["--quiet" | verbosity < Verbosity.normal] - vcsSyncRepos :: Verbosity -> ConfiguredProgram - -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] + vcsSyncRepos + :: Verbosity + -> ConfiguredProgram + -> [(SourceRepositoryPackage f, FilePath)] + -> IO [MonitorFilePath] vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for bzr" bzrProgram :: Program -bzrProgram = (simpleProgram "bzr") { - programFindVersion = findProgramVersion "--version" $ \str -> - case words str of - -- "Bazaar (bzr) 2.6.0\n ... lots of extra stuff" - (_:_:ver:_) -> ver - _ -> "" - } - +bzrProgram = + (simpleProgram "bzr") + { programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- "Bazaar (bzr) 2.6.0\n ... lots of extra stuff" + (_ : _ : ver : _) -> ver + _ -> "" + } -- | VCS driver for Darcs. --- vcsDarcs :: VCS Program vcsDarcs = - VCS { - vcsRepoType = KnownRepoType Darcs, - vcsProgram = darcsProgram, - vcsCloneRepo, - vcsSyncRepos + VCS + { vcsRepoType = KnownRepoType Darcs + , vcsProgram = darcsProgram + , vcsCloneRepo + , vcsSyncRepos } where - vcsCloneRepo :: Verbosity - -> ConfiguredProgram - -> SourceRepositoryPackage f - -> FilePath - -> FilePath - -> [ProgramInvocation] + vcsCloneRepo + :: Verbosity + -> ConfiguredProgram + -> SourceRepositoryPackage f + -> FilePath + -> FilePath + -> [ProgramInvocation] vcsCloneRepo verbosity prog repo srcuri destdir = - [ programInvocation prog cloneArgs ] + [programInvocation prog cloneArgs] where cloneArgs :: [String] - cloneArgs = [cloneCmd, srcuri, destdir] ++ tagArgs ++ verboseArg + cloneArgs = [cloneCmd, srcuri, destdir] ++ tagArgs ++ verboseArg -- At some point the @clone@ command was introduced as an alias for -- @get@, and @clone@ seems to be the recommended one now. cloneCmd :: String - cloneCmd | programVersion prog >= Just (mkVersion [2,8]) - = "clone" - | otherwise = "get" + cloneCmd + | programVersion prog >= Just (mkVersion [2, 8]) = + "clone" + | otherwise = "get" tagArgs :: [String] - tagArgs = case srpTag repo of - Nothing -> [] + tagArgs = case srpTag repo of + Nothing -> [] Just tag -> ["-t", tag] verboseArg :: [String] - verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + verboseArg = ["--quiet" | verbosity < Verbosity.normal] - vcsSyncRepos :: Verbosity -> ConfiguredProgram - -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] + vcsSyncRepos + :: Verbosity + -> ConfiguredProgram + -> [(SourceRepositoryPackage f, FilePath)] + -> IO [MonitorFilePath] vcsSyncRepos _ _ [] = return [] vcsSyncRepos verbosity prog ((primaryRepo, primaryLocalDir) : secondaryRepos) = - monitors <$ do + monitors <$ do vcsSyncRepo verbosity prog primaryRepo primaryLocalDir Nothing - for_ secondaryRepos $ \ (repo, localDir) -> + for_ secondaryRepos $ \(repo, localDir) -> vcsSyncRepo verbosity prog repo localDir $ Just primaryLocalDir where dirs :: [FilePath] @@ -343,11 +388,12 @@ vcsDarcs = monitors = monitorDirectoryExistence <$> dirs vcsSyncRepo verbosity prog SourceRepositoryPackage{..} localDir _peer = - try (lines <$> darcsWithOutput localDir ["log", "--last", "1"]) >>= \ case - Right (_:_:_:x:_) + try (lines <$> darcsWithOutput localDir ["log", "--last", "1"]) >>= \case + Right (_ : _ : _ : x : _) | Just tag <- (List.stripPrefix "tagged " . List.dropWhile Char.isSpace) x , Just tag' <- srpTag - , tag == tag' -> pure () + , tag == tag' -> + pure () Left e | not (isDoesNotExistError e) -> throw e _ -> do removeDirectoryRecursive localDir `catch` liftA2 unless isDoesNotExistError throw @@ -360,247 +406,275 @@ vcsDarcs = darcsWithOutput = darcs' getProgramInvocationOutput darcs' :: (Verbosity -> ProgramInvocation -> t) -> FilePath -> [String] -> t - darcs' f cwd args = f verbosity (programInvocation prog args) - { progInvokeCwd = Just cwd } + darcs' f cwd args = + f + verbosity + (programInvocation prog args) + { progInvokeCwd = Just cwd + } cloneArgs :: [String] cloneArgs = ["clone"] ++ tagArgs ++ [srpLocation, localDir] ++ verboseArg tagArgs :: [String] - tagArgs = case srpTag of - Nothing -> [] + tagArgs = case srpTag of + Nothing -> [] Just tag -> ["-t" ++ tag] verboseArg :: [String] - verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + verboseArg = ["--quiet" | verbosity < Verbosity.normal] darcsProgram :: Program -darcsProgram = (simpleProgram "darcs") { - programFindVersion = findProgramVersion "--version" $ \str -> - case words str of - -- "2.8.5 (release)" - (ver:_) -> ver - _ -> "" - } - +darcsProgram = + (simpleProgram "darcs") + { programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- "2.8.5 (release)" + (ver : _) -> ver + _ -> "" + } -- | VCS driver for Git. --- vcsGit :: VCS Program vcsGit = - VCS { - vcsRepoType = KnownRepoType Git, - vcsProgram = gitProgram, - vcsCloneRepo, - vcsSyncRepos + VCS + { vcsRepoType = KnownRepoType Git + , vcsProgram = gitProgram + , vcsCloneRepo + , vcsSyncRepos } where - vcsCloneRepo :: Verbosity - -> ConfiguredProgram - -> SourceRepositoryPackage f - -> FilePath - -> FilePath - -> [ProgramInvocation] + vcsCloneRepo + :: Verbosity + -> ConfiguredProgram + -> SourceRepositoryPackage f + -> FilePath + -> FilePath + -> [ProgramInvocation] vcsCloneRepo verbosity prog repo srcuri destdir = - [ programInvocation prog cloneArgs ] + [programInvocation prog cloneArgs] -- And if there's a tag, we have to do that in a second step: - ++ [ git (resetArgs tag) | tag <- maybeToList (srpTag repo) ] - ++ [ git (["submodule", "sync", "--recursive"] ++ verboseArg) - , git (["submodule", "update", "--init", "--force", "--recursive"] ++ verboseArg) - ] + ++ [git (resetArgs tag) | tag <- maybeToList (srpTag repo)] + ++ [ git (["submodule", "sync", "--recursive"] ++ verboseArg) + , git (["submodule", "update", "--init", "--force", "--recursive"] ++ verboseArg) + ] where - git args = (programInvocation prog args) {progInvokeCwd = Just destdir} - cloneArgs = ["clone", srcuri, destdir] - ++ branchArgs ++ verboseArg + git args = (programInvocation prog args){progInvokeCwd = Just destdir} + cloneArgs = + ["clone", srcuri, destdir] + ++ branchArgs + ++ verboseArg branchArgs = case srpBranch repo of - Just b -> ["--branch", b] + Just b -> ["--branch", b] Nothing -> [] resetArgs tag = "reset" : verboseArg ++ ["--hard", tag, "--"] - verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + verboseArg = ["--quiet" | verbosity < Verbosity.normal] - vcsSyncRepos :: Verbosity - -> ConfiguredProgram - -> [(SourceRepositoryPackage f, FilePath)] - -> IO [MonitorFilePath] + vcsSyncRepos + :: Verbosity + -> ConfiguredProgram + -> [(SourceRepositoryPackage f, FilePath)] + -> IO [MonitorFilePath] vcsSyncRepos _ _ [] = return [] - vcsSyncRepos verbosity gitProg - ((primaryRepo, primaryLocalDir) : secondaryRepos) = do - - vcsSyncRepo verbosity gitProg primaryRepo primaryLocalDir Nothing - sequence_ - [ vcsSyncRepo verbosity gitProg repo localDir (Just primaryLocalDir) - | (repo, localDir) <- secondaryRepos ] - return [ monitorDirectoryExistence dir - | dir <- (primaryLocalDir : map snd secondaryRepos) ] + vcsSyncRepos + verbosity + gitProg + ((primaryRepo, primaryLocalDir) : secondaryRepos) = do + vcsSyncRepo verbosity gitProg primaryRepo primaryLocalDir Nothing + sequence_ + [ vcsSyncRepo verbosity gitProg repo localDir (Just primaryLocalDir) + | (repo, localDir) <- secondaryRepos + ] + return + [ monitorDirectoryExistence dir + | dir <- (primaryLocalDir : map snd secondaryRepos) + ] vcsSyncRepo verbosity gitProg SourceRepositoryPackage{..} localDir peer = do - exists <- doesDirectoryExist localDir - if exists - then git localDir ["fetch"] - else git (takeDirectory localDir) cloneArgs - -- Before trying to checkout other commits, all submodules must be - -- de-initialised and the .git/modules directory must be deleted. This - -- is needed because sometimes `git submodule sync` does not actually - -- update the submodule source URL. Detailed description here: - -- https://git.coop/-/snippets/85 - git localDir ["submodule", "deinit", "--force", "--all"] - let gitModulesDir = localDir ".git" "modules" - gitModulesExists <- doesDirectoryExist gitModulesDir - when gitModulesExists $ removeDirectoryRecursive gitModulesDir - git localDir resetArgs - git localDir $ ["submodule", "sync", "--recursive"] ++ verboseArg - git localDir $ ["submodule", "update", "--force", "--init", "--recursive"] ++ verboseArg - git localDir $ ["submodule", "foreach", "--recursive"] ++ verboseArg ++ ["git clean -ffxdq"] - git localDir $ ["clean", "-ffxdq"] + exists <- doesDirectoryExist localDir + if exists + then git localDir ["fetch"] + else git (takeDirectory localDir) cloneArgs + -- Before trying to checkout other commits, all submodules must be + -- de-initialised and the .git/modules directory must be deleted. This + -- is needed because sometimes `git submodule sync` does not actually + -- update the submodule source URL. Detailed description here: + -- https://git.coop/-/snippets/85 + git localDir ["submodule", "deinit", "--force", "--all"] + let gitModulesDir = localDir ".git" "modules" + gitModulesExists <- doesDirectoryExist gitModulesDir + when gitModulesExists $ removeDirectoryRecursive gitModulesDir + git localDir resetArgs + git localDir $ ["submodule", "sync", "--recursive"] ++ verboseArg + git localDir $ ["submodule", "update", "--force", "--init", "--recursive"] ++ verboseArg + git localDir $ ["submodule", "foreach", "--recursive"] ++ verboseArg ++ ["git clean -ffxdq"] + git localDir $ ["clean", "-ffxdq"] where git :: FilePath -> [String] -> IO () - git cwd args = runProgramInvocation verbosity $ - (programInvocation gitProg args) { - progInvokeCwd = Just cwd - } - - cloneArgs = ["clone", "--no-checkout", loc, localDir] - ++ case peer of - Nothing -> [] - Just peerLocalDir -> ["--reference", peerLocalDir] - ++ verboseArg - where loc = srpLocation - resetArgs = "reset" : verboseArg ++ ["--hard", resetTarget, "--" ] + git cwd args = + runProgramInvocation verbosity $ + (programInvocation gitProg args) + { progInvokeCwd = Just cwd + } + + cloneArgs = + ["clone", "--no-checkout", loc, localDir] + ++ case peer of + Nothing -> [] + Just peerLocalDir -> ["--reference", peerLocalDir] + ++ verboseArg + where + loc = srpLocation + resetArgs = "reset" : verboseArg ++ ["--hard", resetTarget, "--"] resetTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag) - verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + verboseArg = ["--quiet" | verbosity < Verbosity.normal] gitProgram :: Program -gitProgram = (simpleProgram "git") { - programFindVersion = findProgramVersion "--version" $ \str -> - case words str of - -- "git version 2.5.5" - (_:_:ver:_) | all isTypical ver -> ver - - -- or annoyingly "git version 2.17.1.windows.2" yes, really - (_:_:ver:_) -> intercalate "." - . takeWhile (all isNum) - . split - $ ver - _ -> "" - } +gitProgram = + (simpleProgram "git") + { programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- "git version 2.5.5" + (_ : _ : ver : _) | all isTypical ver -> ver + -- or annoyingly "git version 2.17.1.windows.2" yes, really + (_ : _ : ver : _) -> + intercalate "." + . takeWhile (all isNum) + . split + $ ver + _ -> "" + } where - isNum c = c >= '0' && c <= '9' + isNum c = c >= '0' && c <= '9' isTypical c = isNum c || c == '.' - split cs = case break (=='.') cs of - (chunk,[]) -> chunk : [] - (chunk,_:rest) -> chunk : split rest + split cs = case break (== '.') cs of + (chunk, []) -> chunk : [] + (chunk, _ : rest) -> chunk : split rest -- | VCS driver for Mercurial. --- vcsHg :: VCS Program vcsHg = - VCS { - vcsRepoType = KnownRepoType Mercurial, - vcsProgram = hgProgram, - vcsCloneRepo, - vcsSyncRepos + VCS + { vcsRepoType = KnownRepoType Mercurial + , vcsProgram = hgProgram + , vcsCloneRepo + , vcsSyncRepos } where - vcsCloneRepo :: Verbosity - -> ConfiguredProgram - -> SourceRepositoryPackage f - -> FilePath - -> FilePath - -> [ProgramInvocation] + vcsCloneRepo + :: Verbosity + -> ConfiguredProgram + -> SourceRepositoryPackage f + -> FilePath + -> FilePath + -> [ProgramInvocation] vcsCloneRepo verbosity prog repo srcuri destdir = - [ programInvocation prog cloneArgs ] + [programInvocation prog cloneArgs] where - cloneArgs = ["clone", srcuri, destdir] - ++ branchArgs ++ tagArgs ++ verboseArg + cloneArgs = + ["clone", srcuri, destdir] + ++ branchArgs + ++ tagArgs + ++ verboseArg branchArgs = case srpBranch repo of - Just b -> ["--branch", b] + Just b -> ["--branch", b] Nothing -> [] tagArgs = case srpTag repo of - Just t -> ["--rev", t] + Just t -> ["--rev", t] Nothing -> [] - verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + verboseArg = ["--quiet" | verbosity < Verbosity.normal] - vcsSyncRepos :: Verbosity - -> ConfiguredProgram - -> [(SourceRepositoryPackage f, FilePath)] - -> IO [MonitorFilePath] + vcsSyncRepos + :: Verbosity + -> ConfiguredProgram + -> [(SourceRepositoryPackage f, FilePath)] + -> IO [MonitorFilePath] vcsSyncRepos _ _ [] = return [] - vcsSyncRepos verbosity hgProg - ((primaryRepo, primaryLocalDir) : secondaryRepos) = do - vcsSyncRepo verbosity hgProg primaryRepo primaryLocalDir - sequence_ - [ vcsSyncRepo verbosity hgProg repo localDir - | (repo, localDir) <- secondaryRepos ] - return [ monitorDirectoryExistence dir - | dir <- (primaryLocalDir : map snd secondaryRepos) ] + vcsSyncRepos + verbosity + hgProg + ((primaryRepo, primaryLocalDir) : secondaryRepos) = do + vcsSyncRepo verbosity hgProg primaryRepo primaryLocalDir + sequence_ + [ vcsSyncRepo verbosity hgProg repo localDir + | (repo, localDir) <- secondaryRepos + ] + return + [ monitorDirectoryExistence dir + | dir <- (primaryLocalDir : map snd secondaryRepos) + ] vcsSyncRepo verbosity hgProg repo localDir = do - exists <- doesDirectoryExist localDir - if exists - then hg localDir ["pull"] - else hg (takeDirectory localDir) cloneArgs - hg localDir checkoutArgs + exists <- doesDirectoryExist localDir + if exists + then hg localDir ["pull"] + else hg (takeDirectory localDir) cloneArgs + hg localDir checkoutArgs where hg :: FilePath -> [String] -> IO () - hg cwd args = runProgramInvocation verbosity $ - (programInvocation hgProg args) { - progInvokeCwd = Just cwd - } - cloneArgs = ["clone", "--noupdate", (srpLocation repo), localDir] - ++ verboseArg - verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] - checkoutArgs = [ "checkout", "--clean" ] - ++ tagArgs + hg cwd args = + runProgramInvocation verbosity $ + (programInvocation hgProg args) + { progInvokeCwd = Just cwd + } + cloneArgs = + ["clone", "--noupdate", (srpLocation repo), localDir] + ++ verboseArg + verboseArg = ["--quiet" | verbosity < Verbosity.normal] + checkoutArgs = + ["checkout", "--clean"] + ++ tagArgs tagArgs = case srpTag repo of - Just t -> ["--rev", t] - Nothing -> [] + Just t -> ["--rev", t] + Nothing -> [] hgProgram :: Program -hgProgram = (simpleProgram "hg") { - programFindVersion = findProgramVersion "--version" $ \str -> - case words str of - -- Mercurial Distributed SCM (version 3.5.2)\n ... long message - (_:_:_:_:ver:_) -> takeWhile (\c -> Char.isDigit c || c == '.') ver - _ -> "" - } - +hgProgram = + (simpleProgram "hg") + { programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- Mercurial Distributed SCM (version 3.5.2)\n ... long message + (_ : _ : _ : _ : ver : _) -> takeWhile (\c -> Char.isDigit c || c == '.') ver + _ -> "" + } -- | VCS driver for Subversion. --- vcsSvn :: VCS Program vcsSvn = - VCS { - vcsRepoType = KnownRepoType SVN, - vcsProgram = svnProgram, - vcsCloneRepo, - vcsSyncRepos + VCS + { vcsRepoType = KnownRepoType SVN + , vcsProgram = svnProgram + , vcsCloneRepo + , vcsSyncRepos } where - vcsCloneRepo :: Verbosity - -> ConfiguredProgram - -> SourceRepositoryPackage f - -> FilePath - -> FilePath - -> [ProgramInvocation] + vcsCloneRepo + :: Verbosity + -> ConfiguredProgram + -> SourceRepositoryPackage f + -> FilePath + -> FilePath + -> [ProgramInvocation] vcsCloneRepo verbosity prog _repo srcuri destdir = - [ programInvocation prog checkoutArgs ] + [programInvocation prog checkoutArgs] where checkoutArgs = ["checkout", srcuri, destdir] ++ verboseArg - verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] - --TODO: branch or tag? - - vcsSyncRepos :: Verbosity - -> ConfiguredProgram - -> [(SourceRepositoryPackage f, FilePath)] - -> IO [MonitorFilePath] + verboseArg = ["--quiet" | verbosity < Verbosity.normal] + -- TODO: branch or tag? + + vcsSyncRepos + :: Verbosity + -> ConfiguredProgram + -> [(SourceRepositoryPackage f, FilePath)] + -> IO [MonitorFilePath] vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for svn" svnProgram :: Program -svnProgram = (simpleProgram "svn") { - programFindVersion = findProgramVersion "--version" $ \str -> - case words str of - -- svn, version 1.9.4 (r1740329)\n ... long message - (_:_:ver:_) -> ver - _ -> "" - } - +svnProgram = + (simpleProgram "svn") + { programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- svn, version 1.9.4 (r1740329)\n ... long message + (_ : _ : ver : _) -> ver + _ -> "" + } -- | VCS driver for Pijul. -- Documentation for Pijul can be found at @@ -667,85 +741,96 @@ svnProgram = (simpleProgram "svn") { -- won't work, even the basics are in place. Tests are also written -- but disabled, as the branching model differs from `git` one, -- for which tests are written. --- vcsPijul :: VCS Program vcsPijul = - VCS { - vcsRepoType = KnownRepoType Pijul, - vcsProgram = pijulProgram, - vcsCloneRepo, - vcsSyncRepos + VCS + { vcsRepoType = KnownRepoType Pijul + , vcsProgram = pijulProgram + , vcsCloneRepo + , vcsSyncRepos } where - vcsCloneRepo :: Verbosity -- ^ it seems that pijul does not have verbose flag - -> ConfiguredProgram - -> SourceRepositoryPackage f - -> FilePath - -> FilePath - -> [ProgramInvocation] + vcsCloneRepo + :: Verbosity + -- \^ it seems that pijul does not have verbose flag + -> ConfiguredProgram + -> SourceRepositoryPackage f + -> FilePath + -> FilePath + -> [ProgramInvocation] vcsCloneRepo _verbosity prog repo srcuri destdir = - [ programInvocation prog cloneArgs ] + [programInvocation prog cloneArgs] -- And if there's a tag, we have to do that in a second step: - ++ [ (programInvocation prog (checkoutArgs tag)) { - progInvokeCwd = Just destdir - } - | tag <- maybeToList (srpTag repo) ] + ++ [ (programInvocation prog (checkoutArgs tag)) + { progInvokeCwd = Just destdir + } + | tag <- maybeToList (srpTag repo) + ] where cloneArgs :: [String] - cloneArgs = ["clone", srcuri, destdir] - ++ branchArgs + cloneArgs = + ["clone", srcuri, destdir] + ++ branchArgs branchArgs :: [String] branchArgs = case srpBranch repo of - Just b -> ["--from-branch", b] + Just b -> ["--from-branch", b] Nothing -> [] checkoutArgs tag = "checkout" : [tag] -- TODO: this probably doesn't work either - - vcsSyncRepos :: Verbosity - -> ConfiguredProgram - -> [(SourceRepositoryPackage f, FilePath)] - -> IO [MonitorFilePath] + vcsSyncRepos + :: Verbosity + -> ConfiguredProgram + -> [(SourceRepositoryPackage f, FilePath)] + -> IO [MonitorFilePath] vcsSyncRepos _ _ [] = return [] - vcsSyncRepos verbosity pijulProg - ((primaryRepo, primaryLocalDir) : secondaryRepos) = do - - vcsSyncRepo verbosity pijulProg primaryRepo primaryLocalDir Nothing - sequence_ - [ vcsSyncRepo verbosity pijulProg repo localDir (Just primaryLocalDir) - | (repo, localDir) <- secondaryRepos ] - return [ monitorDirectoryExistence dir - | dir <- (primaryLocalDir : map snd secondaryRepos) ] + vcsSyncRepos + verbosity + pijulProg + ((primaryRepo, primaryLocalDir) : secondaryRepos) = do + vcsSyncRepo verbosity pijulProg primaryRepo primaryLocalDir Nothing + sequence_ + [ vcsSyncRepo verbosity pijulProg repo localDir (Just primaryLocalDir) + | (repo, localDir) <- secondaryRepos + ] + return + [ monitorDirectoryExistence dir + | dir <- (primaryLocalDir : map snd secondaryRepos) + ] vcsSyncRepo verbosity pijulProg SourceRepositoryPackage{..} localDir peer = do - exists <- doesDirectoryExist localDir - if exists - then pijul localDir ["pull"] -- TODO: this probably doesn't work. + exists <- doesDirectoryExist localDir + if exists + then pijul localDir ["pull"] -- TODO: this probably doesn't work. else pijul (takeDirectory localDir) cloneArgs - pijul localDir checkoutArgs + pijul localDir checkoutArgs where pijul :: FilePath -> [String] -> IO () - pijul cwd args = runProgramInvocation verbosity $ - (programInvocation pijulProg args) { - progInvokeCwd = Just cwd - } + pijul cwd args = + runProgramInvocation verbosity $ + (programInvocation pijulProg args) + { progInvokeCwd = Just cwd + } cloneArgs :: [String] - cloneArgs = ["clone", loc, localDir] - ++ case peer of - Nothing -> [] - Just peerLocalDir -> [peerLocalDir] - where loc = srpLocation + cloneArgs = + ["clone", loc, localDir] + ++ case peer of + Nothing -> [] + Just peerLocalDir -> [peerLocalDir] + where + loc = srpLocation checkoutArgs :: [String] - checkoutArgs = "checkout" : ["--force", checkoutTarget, "--" ] + checkoutArgs = "checkout" : ["--force", checkoutTarget, "--"] checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag) -- TODO: this is definitely wrong. pijulProgram :: Program -pijulProgram = (simpleProgram "pijul") { - programFindVersion = findProgramVersion "--version" $ \str -> - case words str of - -- "pijul 0.12.2 - (_:ver:_) | all isTypical ver -> ver - _ -> "" - } +pijulProgram = + (simpleProgram "pijul") + { programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- "pijul 0.12.2 + (_ : ver : _) | all isTypical ver -> ver + _ -> "" + } where - isNum c = c >= '0' && c <= '9' + isNum c = c >= '0' && c <= '9' isTypical c = isNum c || c == '.' diff --git a/cabal-install/src/Distribution/Client/Version.hs b/cabal-install/src/Distribution/Client/Version.hs index ad2f48d7a03..dc06552350f 100644 --- a/cabal-install/src/Distribution/Client/Version.hs +++ b/cabal-install/src/Distribution/Client/Version.hs @@ -1,5 +1,4 @@ -- | Provides the version number of @cabal-install@. - module Distribution.Client.Version ( cabalInstallVersion ) where @@ -13,4 +12,4 @@ import Distribution.Version -- program coverage information generated by HPC, and hence was moved to be a standalone value. -- cabalInstallVersion :: Version -cabalInstallVersion = mkVersion [3,11] +cabalInstallVersion = mkVersion [3, 11] diff --git a/cabal-install/src/Distribution/Client/Win32SelfUpgrade.hs b/cabal-install/src/Distribution/Client/Win32SelfUpgrade.hs index c220d9e9274..516cbdb63b3 100644 --- a/cabal-install/src/Distribution/Client/Win32SelfUpgrade.hs +++ b/cabal-install/src/Distribution/Client/Win32SelfUpgrade.hs @@ -1,5 +1,10 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Client.Win32SelfUpgrade -- Copyright : (c) Duncan Coutts 2008 @@ -10,36 +15,35 @@ -- Portability : portable -- -- Support for self-upgrading executables on Windows platforms. ------------------------------------------------------------------------------ -module Distribution.Client.Win32SelfUpgrade ( --- * Explanation --- --- | Windows inherited a design choice from DOS that while initially innocuous --- has rather unfortunate consequences. It maintains the invariant that every --- open file has a corresponding name on disk. One positive consequence of this --- is that an executable can always find its own executable file. The downside --- is that a program cannot be deleted or upgraded while it is running without --- hideous workarounds. This module implements one such hideous workaround. --- --- The basic idea is: --- --- * Move our own exe file to a new name --- * Copy a new exe file to the previous name --- * Run the new exe file, passing our own PID and new path --- * Wait for the new process to start --- * Close the new exe file --- * Exit old process --- --- Then in the new process: --- --- * Inform the old process that we've started --- * Wait for the old process to die --- * Delete the old exe file --- * Exit new process --- - - possibleSelfUpgrade, - deleteOldExeFile, +module Distribution.Client.Win32SelfUpgrade + ( -- * Explanation + + -- + + -- | Windows inherited a design choice from DOS that while initially innocuous + -- has rather unfortunate consequences. It maintains the invariant that every + -- open file has a corresponding name on disk. One positive consequence of this + -- is that an executable can always find its own executable file. The downside + -- is that a program cannot be deleted or upgraded while it is running without + -- hideous workarounds. This module implements one such hideous workaround. + -- + -- The basic idea is: + -- + -- * Move our own exe file to a new name + -- * Copy a new exe file to the previous name + -- * Run the new exe file, passing our own PID and new path + -- * Wait for the new process to start + -- * Close the new exe file + -- * Exit old process + -- + -- Then in the new process: + -- + -- * Inform the old process that we've started + -- * Wait for the old process to die + -- * Delete the old exe file + -- * Exit new process + possibleSelfUpgrade + , deleteOldExeFile ) where import Distribution.Client.Compat.Prelude hiding (log) @@ -162,6 +166,7 @@ deleteOldExeFile verbosity oldPID tmpPath = do -- A bunch of functions sadly not provided by the Win32 package. +{- FOURMOLU_DISABLE -} #ifdef x86_64_HOST_ARCH #define CALLCONV ccall #else @@ -224,3 +229,4 @@ deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO () deleteOldExeFile verbosity _ _ = die' verbosity "win32selfupgrade not needed except on win32" #endif +{- FOURMOLU_ENABLE -} diff --git a/cabal-install/src/Distribution/Deprecated/ParseUtils.hs b/cabal-install/src/Distribution/Deprecated/ParseUtils.hs index 6ac62a6e82d..592306727c2 100644 --- a/cabal-install/src/Distribution/Deprecated/ParseUtils.hs +++ b/cabal-install/src/Distribution/Deprecated/ParseUtils.hs @@ -1,5 +1,9 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- +-- This module is meant to be local-only to Distribution... +{-# OPTIONS_HADDOCK hide #-} + -- | -- Module : Distribution.Deprecated.ParseUtils -- Copyright : (c) The University of Glasgow 2004 @@ -16,30 +20,42 @@ -- couple others. It has the parsing framework code and also little parsers for -- many of the formats we get in various @.cabal@ file fields, like module -- names, comma separated lists etc. - --- This module is meant to be local-only to Distribution... - -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE Rank2Types #-} -module Distribution.Deprecated.ParseUtils ( - LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning, - runP, runE, ParseResult(..), parseFail, showPWarning, - Field(..), lineNo, - FieldDescr(..), readFields, - parseHaskellString, parseTokenQ, - parseOptCommaList, - showFilePath, showToken, showFreeText, - field, simpleField, listField, listFieldWithSep, spaceListField, - newLineListField, - liftField, - readPToMaybe, - - fieldParsec, simpleFieldParsec, - listFieldParsec, - commaListFieldParsec, - commaNewLineListFieldParsec, - - UnrecFieldParser, +module Distribution.Deprecated.ParseUtils + ( LineNo + , PError (..) + , PWarning (..) + , locatedErrorMsg + , syntaxError + , warning + , runP + , runE + , ParseResult (..) + , parseFail + , showPWarning + , Field (..) + , lineNo + , FieldDescr (..) + , readFields + , parseHaskellString + , parseTokenQ + , parseOptCommaList + , showFilePath + , showToken + , showFreeText + , field + , simpleField + , listField + , listFieldWithSep + , spaceListField + , newLineListField + , liftField + , readPToMaybe + , fieldParsec + , simpleFieldParsec + , listFieldParsec + , commaListFieldParsec + , commaNewLineListFieldParsec + , UnrecFieldParser ) where import Distribution.Client.Compat.Prelude hiding (get) @@ -51,8 +67,8 @@ import Distribution.Pretty import Distribution.ReadE import Distribution.Utils.Generic -import System.FilePath (normalise) -import Text.PrettyPrint (Doc, punctuate, comma, fsep, sep) +import System.FilePath (normalise) +import Text.PrettyPrint (Doc, comma, fsep, punctuate, sep) import qualified Text.Read as Read import qualified Control.Monad.Fail as Fail @@ -61,67 +77,73 @@ import Distribution.Parsec (ParsecParser, parsecLeadingCommaList, parsecLeadingO import qualified Data.ByteString as BS import qualified Distribution.Fields as Fields import qualified Distribution.Fields.Field as Fields -import qualified Distribution.Parsec as Parsec import qualified Distribution.Fields.LexerMonad as Fields +import qualified Distribution.Parsec as Parsec import qualified Text.Parsec.Error as PE import qualified Text.Parsec.Pos as PP -- ----------------------------------------------------------------------------- -type LineNo = Int +type LineNo = Int -data PError = AmbiguousParse String LineNo - | NoParse String LineNo - | TabsError LineNo - | FromString String (Maybe LineNo) - deriving (Eq, Show) +data PError + = AmbiguousParse String LineNo + | NoParse String LineNo + | TabsError LineNo + | FromString String (Maybe LineNo) + deriving (Eq, Show) -data PWarning = PWarning String - | UTFWarning LineNo String - deriving (Eq, Show) +data PWarning + = PWarning String + | UTFWarning LineNo String + deriving (Eq, Show) showPWarning :: FilePath -> PWarning -> String showPWarning fpath (PWarning msg) = normalise fpath ++ ": " ++ msg showPWarning fpath (UTFWarning line fname) = - normalise fpath ++ ":" ++ show line - ++ ": Invalid UTF-8 text in the '" ++ fname ++ "' field." + normalise fpath + ++ ":" + ++ show line + ++ ": Invalid UTF-8 text in the '" + ++ fname + ++ "' field." data ParseResult a = ParseFailed PError | ParseOk [PWarning] a - deriving Show + deriving (Show) instance Functor ParseResult where - fmap _ (ParseFailed err) = ParseFailed err - fmap f (ParseOk ws x) = ParseOk ws $ f x + fmap _ (ParseFailed err) = ParseFailed err + fmap f (ParseOk ws x) = ParseOk ws $ f x instance Applicative ParseResult where - pure = ParseOk [] - (<*>) = ap - + 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' + 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 + fail = parseResultFail #elif !(MIN_VERSION_base(4,13,0)) - fail = Fail.fail + fail = Fail.fail #endif +{- FOURMOLU_ENABLE -} instance Foldable ParseResult where - foldMap _ (ParseFailed _ ) = mempty + foldMap _ (ParseFailed _) = mempty foldMap f (ParseOk _ x) = f x instance Traversable ParseResult where traverse _ (ParseFailed err) = pure (ParseFailed err) traverse f (ParseOk ws x) = ParseOk ws <$> f x - instance Fail.MonadFail ParseResult where - fail = parseResultFail + fail = parseResultFail parseResultFail :: String -> ParseResult a parseResultFail s = parseFail (FromString s Nothing) @@ -131,56 +153,63 @@ parseFail = ParseFailed runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a runP line fieldname p s = - case [ x | (x,"") <- results ] of + case [x | (x, "") <- results] of [a] -> ParseOk (utf8Warnings line fieldname s) a - --TODO: what is this double parse thing all about? + -- TODO: what is this double parse thing all about? -- Can't we just do the all isSpace test the first time? - [] -> case [ x | (x,ys) <- results, all isSpace ys ] of - [a] -> ParseOk (utf8Warnings line fieldname s) a - [] -> ParseFailed (NoParse fieldname line) - _ -> ParseFailed (AmbiguousParse fieldname line) - _ -> ParseFailed (AmbiguousParse fieldname line) - where results = readP_to_S p s + [] -> case [x | (x, ys) <- results, all isSpace ys] of + [a] -> ParseOk (utf8Warnings line fieldname s) a + [] -> ParseFailed (NoParse fieldname line) + _ -> ParseFailed (AmbiguousParse fieldname line) + _ -> ParseFailed (AmbiguousParse fieldname line) + where + results = readP_to_S p s runE :: LineNo -> String -> ReadE a -> String -> ParseResult a runE line fieldname p s = - case runReadE p s of - Right a -> ParseOk (utf8Warnings line fieldname s) a - Left e -> syntaxError line $ + case runReadE p s of + Right a -> ParseOk (utf8Warnings line fieldname s) a + Left e -> + syntaxError line $ "Parse of field '" ++ fieldname ++ "' failed (" ++ e ++ "): " ++ s utf8Warnings :: LineNo -> String -> String -> [PWarning] utf8Warnings line fieldname s = - take 1 [ UTFWarning n fieldname - | (n,l) <- zip [line..] (lines s) - , '\xfffd' `elem` l ] + take + 1 + [ UTFWarning n fieldname + | (n, l) <- zip [line ..] (lines s) + , '\xfffd' `elem` l + ] locatedErrorMsg :: PError -> (Maybe LineNo, String) -locatedErrorMsg (AmbiguousParse f n) = (Just n, - "Ambiguous parse in field '"++f++"'.") -locatedErrorMsg (NoParse f n) = (Just n, - "Parse of field '"++f++"' failed.") -locatedErrorMsg (TabsError n) = (Just n, "Tab used as indentation.") -locatedErrorMsg (FromString s n) = (n, s) +locatedErrorMsg (AmbiguousParse f n) = + ( Just n + , "Ambiguous parse in field '" ++ f ++ "'." + ) +locatedErrorMsg (NoParse f n) = + ( Just n + , "Parse of field '" ++ f ++ "' failed." + ) +locatedErrorMsg (TabsError n) = (Just n, "Tab used as indentation.") +locatedErrorMsg (FromString s n) = (n, s) syntaxError :: LineNo -> String -> ParseResult a syntaxError n s = ParseFailed $ FromString s (Just n) - warning :: String -> ParseResult () warning s = ParseOk [PWarning s] () -- | Field descriptor. The parameter @a@ parameterizes over where the field's -- value is stored in. -data FieldDescr a - = FieldDescr - { fieldName :: String - , fieldGet :: a -> Doc - , fieldSet :: LineNo -> String -> a -> ParseResult a - -- ^ @fieldSet n str x@ Parses the field value from the given input - -- string @str@ and stores the result in @x@ if the parse was - -- successful. Otherwise, reports an error on line number @n@. - } +data FieldDescr a = FieldDescr + { fieldName :: String + , fieldGet :: a -> Doc + , fieldSet :: LineNo -> String -> a -> ParseResult a + -- ^ @fieldSet n str x@ Parses the field value from the given input + -- string @str@ and stores the result in @x@ if the parse was + -- successful. Otherwise, reports an error on line number @n@. + } field :: String -> (a -> Doc) -> ReadP a a -> FieldDescr a field name showF readF = @@ -190,88 +219,147 @@ fieldParsec :: String -> (a -> Doc) -> ParsecParser a -> FieldDescr a fieldParsec name showF readF = FieldDescr name showF $ \line val _st -> case explicitEitherParsec readF val of Left err -> ParseFailed (FromString err (Just line)) - Right x -> ParseOk [] x + Right x -> ParseOk [] x -- Lift a field descriptor storing into an 'a' to a field descriptor storing -- into a 'b'. liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b -liftField get set (FieldDescr name showF parseF) - = FieldDescr name (showF . get) - (\line str b -> do - a <- parseF line str (get b) - return (set a b)) +liftField get set (FieldDescr name showF parseF) = + FieldDescr + name + (showF . get) + ( \line str b -> do + a <- parseF line str (get b) + return (set a b) + ) -- Parser combinator for simple fields. Takes a field name, a pretty printer, -- a parser function, an accessor, and a setter, returns a FieldDescr over the -- compoid structure. -simpleField :: String -> (a -> Doc) -> ReadP a a - -> (b -> a) -> (a -> b -> b) -> FieldDescr b -simpleField name showF readF get set - = liftField get set $ field name showF readF - -simpleFieldParsec :: String -> (a -> Doc) -> ParsecParser a - -> (b -> a) -> (a -> b -> b) -> FieldDescr b -simpleFieldParsec name showF readF get set - = liftField get set $ fieldParsec name showF readF - -commaListFieldWithSepParsec :: Separator -> String -> (a -> Doc) -> ParsecParser a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +simpleField + :: String + -> (a -> Doc) + -> ReadP a a + -> (b -> a) + -> (a -> b -> b) + -> FieldDescr b +simpleField name showF readF get set = + liftField get set $ field name showF readF + +simpleFieldParsec + :: String + -> (a -> Doc) + -> ParsecParser a + -> (b -> a) + -> (a -> b -> b) + -> FieldDescr b +simpleFieldParsec name showF readF get set = + liftField get set $ fieldParsec name showF readF + +commaListFieldWithSepParsec + :: Separator + -> String + -> (a -> Doc) + -> ParsecParser a + -> (b -> [a]) + -> ([a] -> b -> b) + -> FieldDescr b commaListFieldWithSepParsec separator name showF readF get set = - liftField get set' $ - fieldParsec name showF' (parsecLeadingCommaList readF) - where - set' xs b = set (get b ++ xs) b - showF' = separator . punctuate comma . map showF - -commaListFieldParsec :: String -> (a -> Doc) -> ParsecParser a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b + liftField get set' $ + fieldParsec name showF' (parsecLeadingCommaList readF) + where + set' xs b = set (get b ++ xs) b + showF' = separator . punctuate comma . map showF + +commaListFieldParsec + :: String + -> (a -> Doc) + -> ParsecParser a + -> (b -> [a]) + -> ([a] -> b -> b) + -> FieldDescr b commaListFieldParsec = commaListFieldWithSepParsec fsep commaNewLineListFieldParsec - :: String -> (a -> Doc) -> ParsecParser a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b + :: String + -> (a -> Doc) + -> ParsecParser a + -> (b -> [a]) + -> ([a] -> b -> b) + -> FieldDescr b commaNewLineListFieldParsec = commaListFieldWithSepParsec sep -spaceListField :: String -> (a -> Doc) -> ReadP [a] a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +spaceListField + :: String + -> (a -> Doc) + -> ReadP [a] a + -> (b -> [a]) + -> ([a] -> b -> b) + -> FieldDescr b spaceListField name showF readF get set = liftField get set' $ field name showF' (parseSpaceList readF) where set' xs b = set (get b ++ xs) b - showF' = fsep . map showF + showF' = fsep . map showF -- this is a different definition from listField, like -- commaNewLineListField it pretty prints on multiple lines -newLineListField :: String -> (a -> Doc) -> ReadP [a] a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +newLineListField + :: String + -> (a -> Doc) + -> ReadP [a] a + -> (b -> [a]) + -> ([a] -> b -> b) + -> FieldDescr b newLineListField = listFieldWithSep sep -listFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +listFieldWithSep + :: Separator + -> String + -> (a -> Doc) + -> ReadP [a] a + -> (b -> [a]) + -> ([a] -> b -> b) + -> FieldDescr b listFieldWithSep separator name showF readF get set = liftField get set' $ field name showF' (parseOptCommaList readF) where set' xs b = set (get b ++ xs) b - showF' = separator . map showF - -listFieldWithSepParsec :: Separator -> String -> (a -> Doc) -> ParsecParser a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b + showF' = separator . map showF + +listFieldWithSepParsec + :: Separator + -> String + -> (a -> Doc) + -> ParsecParser a + -> (b -> [a]) + -> ([a] -> b -> b) + -> FieldDescr b listFieldWithSepParsec separator name showF readF get set = liftField get set' $ fieldParsec name showF' (parsecLeadingOptCommaList readF) where set' xs b = set (get b ++ xs) b - showF' = separator . map showF - -listField :: String -> (a -> Doc) -> ReadP [a] a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b + showF' = separator . map showF + +listField + :: String + -> (a -> Doc) + -> ReadP [a] a + -> (b -> [a]) + -> ([a] -> b -> b) + -> FieldDescr b listField = listFieldWithSep fsep listFieldParsec - :: String -> (a -> Doc) -> ParsecParser a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b + :: String + -> (a -> Doc) + -> ParsecParser a + -> (b -> [a]) + -> ([a] -> b -> b) + -> FieldDescr b listFieldParsec = listFieldWithSepParsec fsep -- | The type of a function which, given a name-value pair of an @@ -279,25 +367,27 @@ listFieldParsec = listFieldWithSepParsec fsep -- decides whether to incorporate the unrecognized field -- (by returning Just x, where x is a possibly modified version -- of the structure being built), or not (by returning Nothing). -type UnrecFieldParser a = (String,String) -> a -> Maybe a +type UnrecFieldParser a = (String, String) -> a -> Maybe a ------------------------------------------------------------------------------ -- The data type for our three syntactic categories data Field - = F LineNo String String - -- ^ A regular @: @ field - | Section LineNo String String [Field] - -- ^ A section with a name and possible parameter. The syntactic - -- structure is: - -- - -- @ - -- { - -- * - -- } - -- @ - deriving (Show - ,Eq) -- for testing + = -- | A regular @: @ field + F LineNo String String + | -- | A section with a name and possible parameter. The syntactic + -- structure is: + -- + -- @ + -- { + -- * + -- } + -- @ + Section LineNo String String [Field] + deriving + ( Show + , Eq -- for testing + ) lineNo :: Field -> LineNo lineNo (F n _ _) = n @@ -305,25 +395,33 @@ lineNo (Section n _ _ _) = n readFields :: BS.ByteString -> ParseResult [Field] readFields input = case Fields.readFields' input of - Right (fs, ws) -> ParseOk - [ PWarning msg | Fields.PWarning _ _ msg <- Fields.toPWarnings ws ] - (legacyFields fs) - Left perr -> ParseFailed $ NoParse - (PE.showErrorMessages - "or" "unknown parse error" "expecting" "unexpected" "end of file" - (PE.errorMessages perr)) + Right (fs, ws) -> + ParseOk + [PWarning msg | Fields.PWarning _ _ msg <- Fields.toPWarnings ws] + (legacyFields fs) + Left perr -> + ParseFailed $ + NoParse + ( PE.showErrorMessages + "or" + "unknown parse error" + "expecting" + "unexpected" + "end of file" + (PE.errorMessages perr) + ) (PP.sourceLine pos) - where - pos = PE.errorPos perr + where + pos = PE.errorPos perr legacyFields :: [Fields.Field Parsec.Position] -> [Field] legacyFields = map legacyField legacyField :: Fields.Field Parsec.Position -> Field legacyField (Fields.Field (Fields.Name pos name) fls) = - F (posToLineNo pos) (fromUTF8BS name) (Fields.fieldLinesToString fls) + F (posToLineNo pos) (fromUTF8BS name) (Fields.fieldLinesToString fls) legacyField (Fields.Section (Fields.Name pos name) args fs) = - Section (posToLineNo pos) (fromUTF8BS name) (Fields.sectionArgsToString args) (legacyFields fs) + Section (posToLineNo pos) (fromUTF8BS name) (Fields.sectionArgsToString args) (legacyFields fs) posToLineNo :: Parsec.Position -> LineNo posToLineNo (Parsec.Position row _) = row @@ -346,8 +444,10 @@ parseHaskellString = parseTokenQ :: ReadP r String parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',') -parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas - -> ReadP r [a] +parseSpaceList + :: ReadP r a + -- ^ The parser for the stuff between commas + -> ReadP r [a] parseSpaceList p = sepBy p skipSpaces -- This version avoid parse ambiguity for list element parsers @@ -356,9 +456,12 @@ parseOptCommaList :: ReadP r a -> ReadP r [a] parseOptCommaList p = sepBy p localSep where -- The separator must not be empty or it introduces ambiguity - localSep = (skipSpaces >> char ',' >> skipSpaces) - +++ (satisfy isSpace >> skipSpaces) + localSep = + (skipSpaces >> char ',' >> skipSpaces) + +++ (satisfy isSpace >> skipSpaces) readPToMaybe :: ReadP a a -> String -> Maybe a -readPToMaybe p str = listToMaybe [ r | (r,s) <- readP_to_S p str - , all isSpace s ] +readPToMaybe p str = + listToMaybe + [ r | (r, s) <- readP_to_S p str, all isSpace s + ] diff --git a/cabal-install/src/Distribution/Deprecated/ReadP.hs b/cabal-install/src/Distribution/Deprecated/ReadP.hs index 12cebf38e1a..f0626d5cfe7 100644 --- a/cabal-install/src/Distribution/Deprecated/ReadP.hs +++ b/cabal-install/src/Distribution/Deprecated/ReadP.hs @@ -1,6 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- -- Module : Distribution.Deprecated.ReadP @@ -24,64 +28,61 @@ -- -- The unit tests have been moved to UnitTest.Distribution.Deprecated.ReadP, by -- Mark Lentczner ------------------------------------------------------------------------------ - module Distribution.Deprecated.ReadP - ( - -- * The 'ReadP' type - ReadP, -- :: * -> *; instance Functor, Monad, MonadPlus - - -- * Primitive operations - get, -- :: ReadP Char - look, -- :: ReadP String - (+++), -- :: ReadP a -> ReadP a -> ReadP a - (<++), -- :: ReadP a -> ReadP a -> ReadP a - gather, -- :: ReadP a -> ReadP (String, a) - - -- * Other operations - pfail, -- :: ReadP a - eof, -- :: ReadP () - satisfy, -- :: (Char -> Bool) -> ReadP Char - char, -- :: Char -> ReadP Char - string, -- :: String -> ReadP String - munch, -- :: (Char -> Bool) -> ReadP String - munch1, -- :: (Char -> Bool) -> ReadP String - skipSpaces, -- :: ReadP () - skipSpaces1,-- :: ReadP () - choice, -- :: [ReadP a] -> ReadP a - count, -- :: Int -> ReadP a -> ReadP [a] - between, -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a - option, -- :: a -> ReadP a -> ReadP a - optional, -- :: ReadP a -> ReadP () - many, -- :: ReadP a -> ReadP [a] - many1, -- :: ReadP a -> ReadP [a] - skipMany, -- :: ReadP a -> ReadP () - skipMany1, -- :: ReadP a -> ReadP () - sepBy, -- :: ReadP a -> ReadP sep -> ReadP [a] - sepBy1, -- :: ReadP a -> ReadP sep -> ReadP [a] - endBy, -- :: ReadP a -> ReadP sep -> ReadP [a] - endBy1, -- :: ReadP a -> ReadP sep -> ReadP [a] - chainr, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a - chainl, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a - chainl1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a - chainr1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a - manyTill, -- :: ReadP a -> ReadP end -> ReadP [a] - - -- * Running a parser - ReadS, -- :: *; = String -> [(a,String)] - readP_to_S, -- :: ReadP a -> ReadS a - readS_to_P, -- :: ReadS a -> ReadP a - readP_to_E, - - -- ** Internal - Parser, + ( -- * The 'ReadP' type + ReadP -- :: * -> *; instance Functor, Monad, MonadPlus + + -- * Primitive operations + , get -- :: ReadP Char + , look -- :: ReadP String + , (+++) -- :: ReadP a -> ReadP a -> ReadP a + , (<++) -- :: ReadP a -> ReadP a -> ReadP a + , gather -- :: ReadP a -> ReadP (String, a) + + -- * Other operations + , pfail -- :: ReadP a + , eof -- :: ReadP () + , satisfy -- :: (Char -> Bool) -> ReadP Char + , char -- :: Char -> ReadP Char + , string -- :: String -> ReadP String + , munch -- :: (Char -> Bool) -> ReadP String + , munch1 -- :: (Char -> Bool) -> ReadP String + , skipSpaces -- :: ReadP () + , skipSpaces1 -- :: ReadP () + , choice -- :: [ReadP a] -> ReadP a + , count -- :: Int -> ReadP a -> ReadP [a] + , between -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a + , option -- :: a -> ReadP a -> ReadP a + , optional -- :: ReadP a -> ReadP () + , many -- :: ReadP a -> ReadP [a] + , many1 -- :: ReadP a -> ReadP [a] + , skipMany -- :: ReadP a -> ReadP () + , skipMany1 -- :: ReadP a -> ReadP () + , sepBy -- :: ReadP a -> ReadP sep -> ReadP [a] + , sepBy1 -- :: ReadP a -> ReadP sep -> ReadP [a] + , endBy -- :: ReadP a -> ReadP sep -> ReadP [a] + , endBy1 -- :: ReadP a -> ReadP sep -> ReadP [a] + , chainr -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a + , chainl -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a + , chainl1 -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a + , chainr1 -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a + , manyTill -- :: ReadP a -> ReadP end -> ReadP [a] + + -- * Running a parser + , ReadS -- :: *; = String -> [(a,String)] + , readP_to_S -- :: ReadP a -> ReadS a + , readS_to_P -- :: ReadS a -> ReadP a + , readP_to_E + + -- ** Internal + , Parser ) - where +where +import Distribution.Client.Compat.Prelude hiding (get, many) import Prelude () -import Distribution.Client.Compat.Prelude hiding (many, get) -import Control.Monad( replicateM, (>=>) ) +import Control.Monad (replicateM, (>=>)) import qualified Control.Monad.Fail as Fail @@ -98,7 +99,7 @@ data P s a | Look ([s] -> P s a) | Fail | Result a (P s a) - | Final [(a,[s])] -- invariant: list is non-empty! + | Final [(a, [s])] -- invariant: list is non-empty! -- Monad, MonadPlus @@ -112,11 +113,11 @@ instance Applicative (P s) where instance Monad (P s) where return = pure - (Get f) >>= k = Get (f >=> k) - (Look f) >>= k = Look (f >=> k) - Fail >>= _ = Fail + (Get f) >>= k = Get (f >=> k) + (Look f) >>= k = Look (f >=> k) + Fail >>= _ = Fail (Result x p) >>= k = k x `mplus` (p >>= k) - (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s] + (Final r) >>= k = final [ys' | (x, s) <- r, ys' <- run (k x) s] #if !(MIN_VERSION_base(4,9,0)) fail _ = Fail @@ -128,37 +129,33 @@ instance Fail.MonadFail (P s) where fail _ = Fail instance Alternative (P s) where - empty = mzero - (<|>) = mplus + empty = mzero + (<|>) = mplus instance MonadPlus (P s) where mzero = Fail -- most common case: two gets are combined - Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c) - + Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c) -- results are delivered as soon as possible - Result x p `mplus` q = Result x (p `mplus` q) - p `mplus` Result x q = Result x (p `mplus` q) - + Result x p `mplus` q = Result x (p `mplus` q) + p `mplus` Result x q = Result x (p `mplus` q) -- fail disappears - Fail `mplus` p = p - p `mplus` Fail = p - + Fail `mplus` p = p + p `mplus` Fail = p -- two finals are combined -- final + look becomes one look and one final (=optimization) -- final + sthg else becomes one look and one final - Final r `mplus` Final t = Final (r ++ t) - Final r `mplus` Look f = Look (\s -> Final (r ++ run (f s) s)) - Final r `mplus` p = Look (\s -> Final (r ++ run p s)) - Look f `mplus` Final r = Look (\s -> Final (run (f s) s ++ r)) - p `mplus` Final r = Look (\s -> Final (run p s ++ r)) - + Final r `mplus` Final t = Final (r ++ t) + Final r `mplus` Look f = Look (\s -> Final (r ++ run (f s) s)) + Final r `mplus` p = Look (\s -> Final (r ++ run p s)) + Look f `mplus` Final r = Look (\s -> Final (run (f s) s ++ r)) + p `mplus` Final r = Look (\s -> Final (run p s ++ r)) -- two looks are combined (=optimization) -- look + sthg else floats upwards - Look f `mplus` Look g = Look (\s -> f s `mplus` g s) - Look f `mplus` p = Look (\s -> f s `mplus` p) - p `mplus` Look f = Look (\s -> p `mplus` f s) + Look f `mplus` Look g = Look (\s -> f s `mplus` g s) + Look f `mplus` p = Look (\s -> f s `mplus` p) + p `mplus` Look f = Look (\s -> p `mplus` f s) -- --------------------------------------------------------------------------- -- The ReadP type @@ -172,7 +169,7 @@ instance Functor (Parser r s) where fmap h (R f) = R (\k -> f (k . h)) instance Applicative (Parser r s) where - pure x = R (\k -> k x) + pure x = R (\k -> k x) (<*>) = ap instance s ~ Char => Alternative (Parser r s) where @@ -190,7 +187,7 @@ instance Monad (Parser r s) where #endif instance Fail.MonadFail (Parser r s) where - fail _ = R (const Fail) + fail _ = R (const Fail) instance s ~ Char => MonadPlus (Parser r s) where mzero = pfail @@ -199,17 +196,17 @@ instance s ~ Char => MonadPlus (Parser r s) where -- --------------------------------------------------------------------------- -- Operations over P -final :: [(a,[s])] -> P s a +final :: [(a, [s])] -> P s a -- Maintains invariant for Final constructor final [] = Fail -final r = Final r +final r = Final r run :: P c a -> ([c] -> [(a, [c])]) -run (Get f) (c:s) = run (f c) s -run (Look f) s = run (f s) s -run (Result x p) s = (x,s) : run p s -run (Final r) _ = r -run _ _ = [] +run (Get f) (c : s) = run (f c) s +run (Look f) s = run (f s) s +run (Result x p) s = (x, s) : run p s +run (Final r) _ = r +run _ _ = [] -- --------------------------------------------------------------------------- -- Operations over ReadP @@ -230,9 +227,11 @@ pfail = R (const Fail) eof :: ReadP r () -- ^ Succeeds iff we are at the end of input -eof = do { s <- look - ; if null s then return () - else pfail } +eof = do + s <- look + if null s + then return () + else pfail (+++) :: ReadP r a -> ReadP r a -> ReadP r a -- ^ Symmetric choice. @@ -243,17 +242,18 @@ R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k) -- locally produces any result at all, then right parser is -- not used. R f <++ q = - do s <- look - probe (f return) s 0 - where - probe (Get f') (c:s) n = probe (f' c) s (n+1 :: Int) - probe (Look f') s n = probe (f' s) s n - probe p@(Result _ _) _ n = discard n >> R (p >>=) - probe (Final r) _ _ = R (Final r >>=) - probe _ _ _ = q - - discard 0 = return () - discard n = get >> discard (n-1 :: Int) + do + s <- look + probe (f return) s 0 + where + probe (Get f') (c : s) n = probe (f' c) s (n + 1 :: Int) + probe (Look f') s n = probe (f' s) s n + probe p@(Result _ _) _ n = discard n >> R (p >>=) + probe (Final r) _ _ = R (Final r >>=) + probe _ _ _ = q + + discard 0 = return () + discard n = get >> discard (n - 1 :: Int) gather :: ReadP (String -> P Char r) a -> ReadP r (String, a) -- ^ Transforms a parser into one that does the same, but @@ -261,13 +261,13 @@ gather :: ReadP (String -> P Char r) a -> ReadP r (String, a) -- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument -- is built using any occurrences of readS_to_P. gather (R m) = - R (\k -> gath id (m (\a -> return (\s -> k (s,a))))) - where - gath l (Get f) = Get (\c -> gath (l.(c:)) (f c)) - gath _ Fail = Fail - gath l (Look f) = Look (gath l . f) - gath l (Result k p) = k (l []) `mplus` gath l p - gath _ (Final _) = error "do not use readS_to_P in gather!" + R (\k -> gath id (m (\a -> return (\s -> k (s, a))))) + where + gath l (Get f) = Get (\c -> gath (l . (c :)) (f c)) + gath _ Fail = Fail + gath l (Look f) = Look (gath l . f) + gath l (Result k p) = k (l []) `mplus` gath l p + gath _ (Final _) = error "do not use readS_to_P in gather!" -- --------------------------------------------------------------------------- -- Derived operations @@ -284,41 +284,45 @@ char c = satisfy (c ==) string :: String -> ReadP r String -- ^ Parses and returns the specified string. string this = do s <- look; scan this s - where - scan [] _ = return this - scan (x:xs) (y:ys) | x == y = get >> scan xs ys - scan _ _ = pfail + where + scan [] _ = return this + scan (x : xs) (y : ys) | x == y = get >> scan xs ys + scan _ _ = pfail munch :: (Char -> Bool) -> ReadP r String -- ^ Parses the first zero or more characters satisfying the predicate. munch p = - do s <- look - scan s - where - scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s) - scan _ = do return "" + do + s <- look + scan s + where + scan (c : cs) | p c = do _ <- get; s <- scan cs; return (c : s) + scan _ = do return "" munch1 :: (Char -> Bool) -> ReadP r String -- ^ Parses the first one or more characters satisfying the predicate. munch1 p = - do c <- get - if p c then do s <- munch p; return (c:s) - else pfail + do + c <- get + if p c + then do s <- munch p; return (c : s) + else pfail choice :: [ReadP r a] -> ReadP r a -- ^ Combines all parsers in the specified list. -choice [] = pfail -choice [p] = p -choice (p:ps) = p +++ choice ps +choice [] = pfail +choice [p] = p +choice (p : ps) = p +++ choice ps skipSpaces :: ReadP r () -- ^ Skips all whitespace. skipSpaces = - do s <- look - skip s - where - skip (c:s) | isSpace c = do _ <- get; skip s - skip _ = do return () + do + s <- look + skip s + where + skip (c : s) | isSpace c = do _ <- get; skip s + skip _ = do return () skipSpaces1 :: ReadP r () -- ^ Like 'skipSpaces' but succeeds only if there is at least one @@ -333,10 +337,11 @@ count n p = replicateM n p between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a -- ^ @ between open close p @ parses @open@, followed by @p@ and finally -- @close@. Only the value of @p@ is returned. -between open close p = do _ <- open - x <- p - _ <- close - return x +between open close p = do + _ <- open + x <- p + _ <- close + return x option :: a -> ReadP r a -> ReadP r a -- ^ @option x p@ will either parse @p@ or return @x@ without consuming @@ -376,12 +381,12 @@ sepBy1 p sep = liftM2 (:) p (many (sep >> p)) endBy :: ReadP r a -> ReadP r sep -> ReadP r [a] -- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended -- by @sep@. -endBy p sep = many (do x <- p ; _ <- sep ; return x) +endBy p sep = many (do x <- p; _ <- sep; return x) endBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] -- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended -- by @sep@. -endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x) +endBy1 p sep = many1 (do x <- p; _ <- sep; return x) chainr :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a -- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@. @@ -400,25 +405,32 @@ chainl p op x = chainl1 p op +++ return x chainr1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a -- ^ Like 'chainr', but parses one or more occurrences of @p@. chainr1 p op = scan - where scan = p >>= rest - rest x = do f <- op - y <- scan - return (f x y) - +++ return x + where + scan = p >>= rest + rest x = + do + f <- op + y <- scan + return (f x y) + +++ return x chainl1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a -- ^ Like 'chainl', but parses one or more occurrences of @p@. chainl1 p op = p >>= rest - where rest x = do f <- op - y <- p - rest (f x y) - +++ return x + where + rest x = + do + f <- op + y <- p + rest (f x y) + +++ return x manyTill :: ReadP r a -> ReadP [a] end -> ReadP r [a] -- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@ -- succeeds. Returns a list of values returned by @p@. manyTill p end = scan - where scan = (end >> return []) <++ (liftM2 (:) p scan) + where + scan = (end >> return []) <++ (liftM2 (:) p scan) -- --------------------------------------------------------------------------- -- Converting between ReadP and Read @@ -435,7 +447,7 @@ readS_to_P :: ReadS a -> ReadP r a -- Warning: This introduces local backtracking in the resulting -- parser, and therefore a possible inefficiency. readS_to_P r = - R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s'])) + R (\k -> Look (\s -> final [bs'' | (a, s') <- r s, bs'' <- run (k a) s'])) ------------------------------------------------------------------------------- -- ReadE @@ -443,7 +455,7 @@ readS_to_P r = readP_to_E :: (String -> String) -> ReadP a a -> ReadE a readP_to_E err r = - ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt - , all isSpace s ] - of [] -> Left (err txt) - (p:_) -> Right p + ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt, all isSpace s + ] of + [] -> Left (err txt) + (p : _) -> Right p diff --git a/cabal-install/src/Distribution/Deprecated/ViewAsFieldDescr.hs b/cabal-install/src/Distribution/Deprecated/ViewAsFieldDescr.hs index 6129109d58e..35c2564e531 100644 --- a/cabal-install/src/Distribution/Deprecated/ViewAsFieldDescr.hs +++ b/cabal-install/src/Distribution/Deprecated/ViewAsFieldDescr.hs @@ -1,15 +1,15 @@ -module Distribution.Deprecated.ViewAsFieldDescr ( - viewAsFieldDescr - ) where +module Distribution.Deprecated.ViewAsFieldDescr + ( viewAsFieldDescr + ) where import Distribution.Client.Compat.Prelude hiding (get) import Prelude () import qualified Data.List.NonEmpty as NE -import Distribution.ReadE (parsecToReadE) +import Distribution.ReadE (parsecToReadE) import Distribution.Simple.Command -import Text.PrettyPrint (cat, comma, punctuate, text) -import Text.PrettyPrint as PP (empty) +import Text.PrettyPrint (cat, comma, punctuate, text) +import Text.PrettyPrint as PP (empty) import Distribution.Deprecated.ParseUtils (FieldDescr (..), runE, syntaxError) @@ -18,66 +18,62 @@ import Distribution.Deprecated.ParseUtils (FieldDescr (..), runE, syntaxError) viewAsFieldDescr :: OptionField a -> FieldDescr a viewAsFieldDescr (OptionField _n []) = error "Distribution.command.viewAsFieldDescr: unexpected" -viewAsFieldDescr (OptionField n (d:dd)) = FieldDescr n get set - - where - optDescr = head $ NE.sortBy cmp (d:|dd) - - cmp :: OptDescr a -> OptDescr a -> Ordering - ReqArg{} `cmp` ReqArg{} = EQ - ReqArg{} `cmp` _ = GT - BoolOpt{} `cmp` ReqArg{} = LT - BoolOpt{} `cmp` BoolOpt{} = EQ - BoolOpt{} `cmp` _ = GT - ChoiceOpt{} `cmp` ReqArg{} = LT - ChoiceOpt{} `cmp` BoolOpt{} = LT - ChoiceOpt{} `cmp` ChoiceOpt{} = EQ - ChoiceOpt{} `cmp` _ = GT - OptArg{} `cmp` OptArg{} = EQ - OptArg{} `cmp` _ = LT - --- get :: a -> Doc - get t = case optDescr of - ReqArg _ _ _ _ ppr -> - (cat . punctuate comma . map text . ppr) t - - OptArg _ _ _ _ _ ppr -> - case ppr t of [] -> PP.empty - (Nothing : _) -> text "True" - (Just a : _) -> text a - - ChoiceOpt alts -> - fromMaybe PP.empty $ listToMaybe - [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t] - - BoolOpt _ _ _ _ enabled -> (maybe PP.empty pretty . enabled) t - --- set :: LineNo -> String -> a -> ParseResult a - set line val a = - case optDescr of - ReqArg _ _ _ readE _ -> ($ a) `liftM` runE line n readE val - -- We parse for a single value instead of a - -- list, as one can't really implement - -- parseList :: ReadE a -> ReadE [a] with - -- the current ReadE definition - ChoiceOpt{} -> - case getChoiceByLongFlag optDescr val of - Just f -> return (f a) - _ -> syntaxError line val - - BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runE line n (parsecToReadE ("" ++) parsec) val - - OptArg _ _ _ readE _ _ -> ($ a) `liftM` runE line n readE val - -- Optional arguments are parsed just like - -- required arguments here; we don't - -- provide a method to set an OptArg field - -- to the default value. +viewAsFieldDescr (OptionField n (d : dd)) = FieldDescr n get set + where + optDescr = head $ NE.sortBy cmp (d :| dd) + + cmp :: OptDescr a -> OptDescr a -> Ordering + ReqArg{} `cmp` ReqArg{} = EQ + ReqArg{} `cmp` _ = GT + BoolOpt{} `cmp` ReqArg{} = LT + BoolOpt{} `cmp` BoolOpt{} = EQ + BoolOpt{} `cmp` _ = GT + ChoiceOpt{} `cmp` ReqArg{} = LT + ChoiceOpt{} `cmp` BoolOpt{} = LT + ChoiceOpt{} `cmp` ChoiceOpt{} = EQ + ChoiceOpt{} `cmp` _ = GT + OptArg{} `cmp` OptArg{} = EQ + OptArg{} `cmp` _ = LT + + -- get :: a -> Doc + get t = case optDescr of + ReqArg _ _ _ _ ppr -> + (cat . punctuate comma . map text . ppr) t + OptArg _ _ _ _ _ ppr -> + case ppr t of + [] -> PP.empty + (Nothing : _) -> text "True" + (Just a : _) -> text a + ChoiceOpt alts -> + fromMaybe PP.empty $ + listToMaybe + [text lf | (_, (_, lf : _), _, enabled) <- alts, enabled t] + BoolOpt _ _ _ _ enabled -> (maybe PP.empty pretty . enabled) t + + -- set :: LineNo -> String -> a -> ParseResult a + set line val a = + case optDescr of + ReqArg _ _ _ readE _ -> ($ a) `liftM` runE line n readE val + -- We parse for a single value instead of a + -- list, as one can't really implement + -- parseList :: ReadE a -> ReadE [a] with + -- the current ReadE definition + ChoiceOpt{} -> + case getChoiceByLongFlag optDescr val of + Just f -> return (f a) + _ -> syntaxError line val + BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runE line n (parsecToReadE ("" ++) parsec) val + OptArg _ _ _ readE _ _ -> ($ a) `liftM` runE line n readE val + +-- Optional arguments are parsed just like +-- required arguments here; we don't +-- provide a method to set an OptArg field +-- to the default value. getChoiceByLongFlag :: OptDescr a -> String -> Maybe (a -> a) -getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe - [ set | (_,(_sf,lf:_), set, _) <- alts - , lf == val] - +getChoiceByLongFlag (ChoiceOpt alts) val = + listToMaybe + [ set | (_, (_sf, lf : _), set, _) <- alts, lf == val + ] getChoiceByLongFlag _ _ = error "Distribution.command.getChoiceByLongFlag: expected a choice option" - diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index 2f6825f983e..399fcecdc7c 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -1,3 +1,4 @@ +{- FOURMOLU_DISABLE -} {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} diff --git a/cabal-install/tests/IntegrationTests2/build/ignore-project/Setup.hs b/cabal-install/tests/IntegrationTests2/build/ignore-project/Setup.hs index 9a994af677b..e8ef27dbba9 100644 --- a/cabal-install/tests/IntegrationTests2/build/ignore-project/Setup.hs +++ b/cabal-install/tests/IntegrationTests2/build/ignore-project/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/cabal-install/tests/IntegrationTests2/build/setup-custom1/Setup.hs b/cabal-install/tests/IntegrationTests2/build/setup-custom1/Setup.hs index ebab708a329..4258d9b61ef 100644 --- a/cabal-install/tests/IntegrationTests2/build/setup-custom1/Setup.hs +++ b/cabal-install/tests/IntegrationTests2/build/setup-custom1/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain >> writeFile "marker" "ok" diff --git a/cabal-install/tests/IntegrationTests2/build/setup-custom2/Setup.hs b/cabal-install/tests/IntegrationTests2/build/setup-custom2/Setup.hs index ebab708a329..4258d9b61ef 100644 --- a/cabal-install/tests/IntegrationTests2/build/setup-custom2/Setup.hs +++ b/cabal-install/tests/IntegrationTests2/build/setup-custom2/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain >> writeFile "marker" "ok" diff --git a/cabal-install/tests/IntegrationTests2/build/setup-simple/Setup.hs b/cabal-install/tests/IntegrationTests2/build/setup-simple/Setup.hs index 9a994af677b..e8ef27dbba9 100644 --- a/cabal-install/tests/IntegrationTests2/build/setup-simple/Setup.hs +++ b/cabal-install/tests/IntegrationTests2/build/setup-simple/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/cabal-install/tests/LongTests.hs b/cabal-install/tests/LongTests.hs index db036bdf57c..0c315046780 100644 --- a/cabal-install/tests/LongTests.hs +++ b/cabal-install/tests/LongTests.hs @@ -1,46 +1,49 @@ module Main (main) where - import Test.Tasty +import Distribution.Compat.Time import Distribution.Simple.Utils import Distribution.Verbosity -import Distribution.Compat.Time +import qualified UnitTests.Distribution.Client.Described import qualified UnitTests.Distribution.Client.FileMonitor import qualified UnitTests.Distribution.Client.VCS import qualified UnitTests.Distribution.Solver.Modular.QuickCheck -import qualified UnitTests.Distribution.Client.Described import UnitTests.Options - main :: IO () main = do (mtimeChange, mtimeChange') <- calibrateMtimeChangeDelay let toMillis :: Int -> Double toMillis x = fromIntegral x / 1000.0 - notice normal $ "File modification time resolution calibration completed, " - ++ "maximum delay observed: " - ++ (show . toMillis $ mtimeChange ) ++ " ms. " - ++ "Will be using delay of " ++ (show . toMillis $ mtimeChange') - ++ " for test runs." + notice normal $ + "File modification time resolution calibration completed, " + ++ "maximum delay observed: " + ++ (show . toMillis $ mtimeChange) + ++ " ms. " + ++ "Will be using delay of " + ++ (show . toMillis $ mtimeChange') + ++ " for test runs." defaultMainWithIngredients - (includingOptions extraOptions : defaultIngredients) - (tests mtimeChange') - + (includingOptions extraOptions : defaultIngredients) + (tests mtimeChange') tests :: Int -> TestTree tests mtimeChangeCalibrated = askOption $ \(OptionMtimeChangeDelay mtimeChangeProvided) -> - let mtimeChange = if mtimeChangeProvided /= 0 - then mtimeChangeProvided - else mtimeChangeCalibrated - in testGroup "Long-running tests" - [ testGroup "Solver QuickCheck" - UnitTests.Distribution.Solver.Modular.QuickCheck.tests - , testGroup "UnitTests.Distribution.Client.VCS" $ - UnitTests.Distribution.Client.VCS.tests mtimeChange - , testGroup "UnitTests.Distribution.Client.FileMonitor" $ - UnitTests.Distribution.Client.FileMonitor.tests mtimeChange - , UnitTests.Distribution.Client.Described.tests - ] + let mtimeChange = + if mtimeChangeProvided /= 0 + then mtimeChangeProvided + else mtimeChangeCalibrated + in testGroup + "Long-running tests" + [ testGroup + "Solver QuickCheck" + UnitTests.Distribution.Solver.Modular.QuickCheck.tests + , testGroup "UnitTests.Distribution.Client.VCS" $ + UnitTests.Distribution.Client.VCS.tests mtimeChange + , testGroup "UnitTests.Distribution.Client.FileMonitor" $ + UnitTests.Distribution.Client.FileMonitor.tests mtimeChange + , UnitTests.Distribution.Client.Described.tests + ] diff --git a/cabal-install/tests/MemoryUsageTests.hs b/cabal-install/tests/MemoryUsageTests.hs index 0012feab116..3d9b5949590 100644 --- a/cabal-install/tests/MemoryUsageTests.hs +++ b/cabal-install/tests/MemoryUsageTests.hs @@ -6,10 +6,12 @@ import qualified UnitTests.Distribution.Solver.Modular.MemoryUsage tests :: TestTree tests = - testGroup "Memory Usage" - [ testGroup "UnitTests.Distribution.Solver.Modular.MemoryUsage" + testGroup + "Memory Usage" + [ testGroup + "UnitTests.Distribution.Solver.Modular.MemoryUsage" UnitTests.Distribution.Solver.Modular.MemoryUsage.tests - ] + ] main :: IO () main = defaultMain tests diff --git a/cabal-install/tests/UnitTests.hs b/cabal-install/tests/UnitTests.hs index c321f07eb37..8434f623e82 100644 --- a/cabal-install/tests/UnitTests.hs +++ b/cabal-install/tests/UnitTests.hs @@ -1,14 +1,13 @@ module Main (main) where - import Test.Tasty import qualified UnitTests.Distribution.Client.BuildReport import qualified UnitTests.Distribution.Client.Configure import qualified UnitTests.Distribution.Client.FetchUtils +import qualified UnitTests.Distribution.Client.GZipUtils import qualified UnitTests.Distribution.Client.Get import qualified UnitTests.Distribution.Client.Glob -import qualified UnitTests.Distribution.Client.GZipUtils import qualified UnitTests.Distribution.Client.IndexUtils import qualified UnitTests.Distribution.Client.IndexUtils.Timestamp import qualified UnitTests.Distribution.Client.Init @@ -29,49 +28,73 @@ import qualified UnitTests.Distribution.Solver.Types.OptionalStanza main :: IO () main = do initTests <- UnitTests.Distribution.Client.Init.tests - defaultMain $ testGroup "Unit Tests" - [ testGroup "UnitTests.Distribution.Client.BuildReport" - UnitTests.Distribution.Client.BuildReport.tests - , testGroup "UnitTests.Distribution.Client.Configure" - UnitTests.Distribution.Client.Configure.tests - , testGroup "UnitTests.Distribution.Client.FetchUtils" - UnitTests.Distribution.Client.FetchUtils.tests - , testGroup "UnitTests.Distribution.Client.Get" - UnitTests.Distribution.Client.Get.tests - , testGroup "UnitTests.Distribution.Client.Glob" - UnitTests.Distribution.Client.Glob.tests - , testGroup "Distribution.Client.GZipUtils" - UnitTests.Distribution.Client.GZipUtils.tests - , testGroup "UnitTests.Distribution.Client.IndexUtils" - UnitTests.Distribution.Client.IndexUtils.tests - , testGroup "UnitTests.Distribution.Client.IndexUtils.Timestamp" - UnitTests.Distribution.Client.IndexUtils.Timestamp.tests - , testGroup "Distribution.Client.Init" - initTests - , testGroup "UnitTests.Distribution.Client.InstallPlan" - UnitTests.Distribution.Client.InstallPlan.tests - , testGroup "UnitTests.Distribution.Client.JobControl" - UnitTests.Distribution.Client.JobControl.tests - , testGroup "UnitTests.Distribution.Client.ProjectConfig" - UnitTests.Distribution.Client.ProjectConfig.tests - , testGroup "UnitTests.Distribution.Client.ProjectPlanning" - UnitTests.Distribution.Client.ProjectPlanning.tests - , testGroup "Distribution.Client.Store" - UnitTests.Distribution.Client.Store.tests - , testGroup "Distribution.Client.Tar" - UnitTests.Distribution.Client.Tar.tests - , testGroup "Distribution.Client.Targets" - UnitTests.Distribution.Client.Targets.tests - , testGroup "UnitTests.Distribution.Client.UserConfig" - UnitTests.Distribution.Client.UserConfig.tests - , testGroup "UnitTests.Distribution.Solver.Modular.Builder" - UnitTests.Distribution.Solver.Modular.Builder.tests - , testGroup "UnitTests.Distribution.Solver.Modular.RetryLog" - UnitTests.Distribution.Solver.Modular.RetryLog.tests - , testGroup "UnitTests.Distribution.Solver.Modular.Solver" - UnitTests.Distribution.Solver.Modular.Solver.tests - , testGroup "UnitTests.Distribution.Solver.Modular.WeightedPSQ" - UnitTests.Distribution.Solver.Modular.WeightedPSQ.tests - , testGroup "UnitTests.Distribution.Solver.Types.OptionalStanza" - UnitTests.Distribution.Solver.Types.OptionalStanza.tests - ] + defaultMain $ + testGroup + "Unit Tests" + [ testGroup + "UnitTests.Distribution.Client.BuildReport" + UnitTests.Distribution.Client.BuildReport.tests + , testGroup + "UnitTests.Distribution.Client.Configure" + UnitTests.Distribution.Client.Configure.tests + , testGroup + "UnitTests.Distribution.Client.FetchUtils" + UnitTests.Distribution.Client.FetchUtils.tests + , testGroup + "UnitTests.Distribution.Client.Get" + UnitTests.Distribution.Client.Get.tests + , testGroup + "UnitTests.Distribution.Client.Glob" + UnitTests.Distribution.Client.Glob.tests + , testGroup + "Distribution.Client.GZipUtils" + UnitTests.Distribution.Client.GZipUtils.tests + , testGroup + "UnitTests.Distribution.Client.IndexUtils" + UnitTests.Distribution.Client.IndexUtils.tests + , testGroup + "UnitTests.Distribution.Client.IndexUtils.Timestamp" + UnitTests.Distribution.Client.IndexUtils.Timestamp.tests + , testGroup + "Distribution.Client.Init" + initTests + , testGroup + "UnitTests.Distribution.Client.InstallPlan" + UnitTests.Distribution.Client.InstallPlan.tests + , testGroup + "UnitTests.Distribution.Client.JobControl" + UnitTests.Distribution.Client.JobControl.tests + , testGroup + "UnitTests.Distribution.Client.ProjectConfig" + UnitTests.Distribution.Client.ProjectConfig.tests + , testGroup + "UnitTests.Distribution.Client.ProjectPlanning" + UnitTests.Distribution.Client.ProjectPlanning.tests + , testGroup + "Distribution.Client.Store" + UnitTests.Distribution.Client.Store.tests + , testGroup + "Distribution.Client.Tar" + UnitTests.Distribution.Client.Tar.tests + , testGroup + "Distribution.Client.Targets" + UnitTests.Distribution.Client.Targets.tests + , testGroup + "UnitTests.Distribution.Client.UserConfig" + UnitTests.Distribution.Client.UserConfig.tests + , testGroup + "UnitTests.Distribution.Solver.Modular.Builder" + UnitTests.Distribution.Solver.Modular.Builder.tests + , testGroup + "UnitTests.Distribution.Solver.Modular.RetryLog" + UnitTests.Distribution.Solver.Modular.RetryLog.tests + , testGroup + "UnitTests.Distribution.Solver.Modular.Solver" + UnitTests.Distribution.Solver.Modular.Solver.tests + , testGroup + "UnitTests.Distribution.Solver.Modular.WeightedPSQ" + UnitTests.Distribution.Solver.Modular.WeightedPSQ.tests + , testGroup + "UnitTests.Distribution.Solver.Types.OptionalStanza" + UnitTests.Distribution.Solver.Types.OptionalStanza.tests + ] diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs index 3a26ca2e560..d6a85d960ca 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs @@ -1,22 +1,24 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module UnitTests.Distribution.Client.ArbitraryInstances ( - adjustSize, - shortListOf, - shortListOf1, - arbitraryFlag, - ShortToken(..), - arbitraryShortToken, - NonMEmpty(..), - NoShrink(..), + +module UnitTests.Distribution.Client.ArbitraryInstances + ( adjustSize + , shortListOf + , shortListOf1 + , arbitraryFlag + , ShortToken (..) + , arbitraryShortToken + , NonMEmpty (..) + , NoShrink (..) + -- * Shrinker - Shrinker, - runShrinker, - shrinker, - shrinkerPP, - shrinkerAla, + , Shrinker + , runShrinker + , shrinker + , shrinkerPP + , shrinkerAla ) where import Distribution.Client.Compat.Prelude @@ -26,23 +28,23 @@ import Data.Char (isLetter) import Data.List ((\\)) import Distribution.Simple.Setup -import Distribution.Types.Flag (mkFlagAssignment) +import Distribution.Types.Flag (mkFlagAssignment) -import Distribution.Client.BuildReports.Types (BuildReport, InstallOutcome, Outcome, ReportLevel (..)) +import Distribution.Client.BuildReports.Types (BuildReport, InstallOutcome, Outcome, ReportLevel (..)) import Distribution.Client.CmdInstall.ClientInstallFlags (InstallMethod) -import Distribution.Client.Glob (FilePathGlob (..), FilePathGlobRel (..), FilePathRoot (..), GlobPiece (..)) -import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepoEntry (..), ActiveRepos (..), CombineStrategy (..)) -import Distribution.Client.IndexUtils.IndexState (RepoIndexState (..), TotalIndexState, makeTotalIndexState) -import Distribution.Client.IndexUtils.Timestamp (Timestamp, epochTimeToTimestamp) +import Distribution.Client.Glob (FilePathGlob (..), FilePathGlobRel (..), FilePathRoot (..), GlobPiece (..)) +import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepoEntry (..), ActiveRepos (..), CombineStrategy (..)) +import Distribution.Client.IndexUtils.IndexState (RepoIndexState (..), TotalIndexState, makeTotalIndexState) +import Distribution.Client.IndexUtils.Timestamp (Timestamp, epochTimeToTimestamp) import Distribution.Client.Targets -import Distribution.Client.Types (RepoName (..), WriteGhcEnvironmentFilesPolicy) +import Distribution.Client.Types (RepoName (..), WriteGhcEnvironmentFilesPolicy) import Distribution.Client.Types.AllowNewer -import Distribution.Client.Types.OverwritePolicy (OverwritePolicy) -import Distribution.Solver.Types.OptionalStanza (OptionalStanza (..), OptionalStanzaMap, OptionalStanzaSet, optStanzaSetFromList, optStanzaTabulate) -import Distribution.Solver.Types.PackageConstraint (PackageProperty (..)) +import Distribution.Client.Types.OverwritePolicy (OverwritePolicy) +import Distribution.Solver.Types.OptionalStanza (OptionalStanza (..), OptionalStanzaMap, OptionalStanzaSet, optStanzaSetFromList, optStanzaTabulate) +import Distribution.Solver.Types.PackageConstraint (PackageProperty (..)) -import Data.Coerce (Coercible, coerce) -import Network.URI (URI (..), URIAuth (..), isUnreserved) +import Data.Coerce (Coercible, coerce) +import Network.URI (URI (..), URIAuth (..), isUnreserved) import Test.QuickCheck import Test.QuickCheck.GenericArbitrary import Test.QuickCheck.Instances.Cabal () @@ -57,12 +59,12 @@ import Test.QuickCheck.Instances.Cabal () data Shrinker a = Shrinker a [a] instance Functor Shrinker where - fmap f (Shrinker x xs) = Shrinker (f x) (map f xs) + fmap f (Shrinker x xs) = Shrinker (f x) (map f xs) instance Applicative Shrinker where - pure x = Shrinker x [] + pure x = Shrinker x [] - Shrinker f fs <*> Shrinker x xs = Shrinker (f x) (map f xs ++ map ($ x) fs) + Shrinker f fs <*> Shrinker x xs = Shrinker (f x) (map f xs ++ map ($ x) fs) runShrinker :: Shrinker a -> [a] runShrinker (Shrinker _ xs) = xs @@ -82,26 +84,28 @@ shrinkerPP pack unpack x = Shrinker x (map unpack (shrink (pack x))) ------------------------------------------------------------------------------- instance Arbitrary URI where - arbitrary = - URI <$> elements ["file:", "http:", "https:"] - <*> (Just <$> arbitrary) - <*> (('/':) <$> arbitraryURIToken) - <*> (('?':) <$> arbitraryURIToken) - <*> pure "" + arbitrary = + URI + <$> elements ["file:", "http:", "https:"] + <*> (Just <$> arbitrary) + <*> (('/' :) <$> arbitraryURIToken) + <*> (('?' :) <$> arbitraryURIToken) + <*> pure "" instance Arbitrary URIAuth where - arbitrary = - URIAuth <$> pure "" -- no password as this does not roundtrip - <*> arbitraryURIToken - <*> arbitraryURIPort + arbitrary = + URIAuth + <$> pure "" -- no password as this does not roundtrip + <*> arbitraryURIToken + <*> arbitraryURIPort arbitraryURIToken :: Gen String arbitraryURIToken = - shortListOf1 6 (elements (filter isUnreserved ['\0'..'\255'])) + shortListOf1 6 (elements (filter isUnreserved ['\0' .. '\255'])) arbitraryURIPort :: Gen String arbitraryURIPort = - oneof [ pure "", (':':) <$> shortListOf1 4 (choose ('0','9')) ] + oneof [pure "", (':' :) <$> shortListOf1 4 (choose ('0', '9'))] ------------------------------------------------------------------------------- -- cabal-install (and Cabal) types @@ -109,228 +113,244 @@ arbitraryURIPort = shrinkBoundedEnum :: (Eq a, Enum a, Bounded a) => a -> [a] shrinkBoundedEnum x - | x == minBound = [] - | otherwise = [pred x] + | x == minBound = [] + | otherwise = [pred x] adjustSize :: (Int -> Int) -> Gen a -> Gen a adjustSize adjust gen = sized (\n -> resize (adjust n) gen) shortListOf :: Int -> Gen a -> Gen [a] shortListOf bound gen = - sized $ \n -> do - k <- choose (0, (n `div` 2) `min` bound) - vectorOf k gen + sized $ \n -> do + k <- choose (0, (n `div` 2) `min` bound) + vectorOf k gen shortListOf1 :: Int -> Gen a -> Gen [a] shortListOf1 bound gen = - sized $ \n -> do - k <- choose (1, 1 `max` ((n `div` 2) `min` bound)) - vectorOf k gen + sized $ \n -> do + k <- choose (1, 1 `max` ((n `div` 2) `min` bound)) + vectorOf k gen -newtype ShortToken = ShortToken { getShortToken :: String } - deriving Show +newtype ShortToken = ShortToken {getShortToken :: String} + deriving (Show) instance Arbitrary ShortToken where arbitrary = - ShortToken <$> - (shortListOf1 5 (choose ('#', '~')) - `suchThat` (all (`notElem` "{}")) - `suchThat` (not . ("[]" `isPrefixOf`))) - --TODO: [code cleanup] need to replace parseHaskellString impl to stop - -- accepting Haskell list syntax [], ['a'] etc, just allow String syntax. - -- Workaround, don't generate [] as this does not round trip. + ShortToken + <$> ( shortListOf1 5 (choose ('#', '~')) + `suchThat` (all (`notElem` "{}")) + `suchThat` (not . ("[]" `isPrefixOf`)) + ) + + -- TODO: [code cleanup] need to replace parseHaskellString impl to stop + -- accepting Haskell list syntax [], ['a'] etc, just allow String syntax. + -- Workaround, don't generate [] as this does not round trip. shrink (ShortToken cs) = - [ ShortToken cs' | cs' <- shrink cs, not (null cs') ] + [ShortToken cs' | cs' <- shrink cs, not (null cs')] arbitraryShortToken :: Gen String arbitraryShortToken = getShortToken <$> arbitrary -newtype NonMEmpty a = NonMEmpty { getNonMEmpty :: a } +newtype NonMEmpty a = NonMEmpty {getNonMEmpty :: a} deriving (Eq, Ord, Show) instance (Arbitrary a, Monoid a, Eq a) => Arbitrary (NonMEmpty a) where arbitrary = NonMEmpty <$> (arbitrary `suchThat` (/= mempty)) - shrink (NonMEmpty x) = [ NonMEmpty x' | x' <- shrink x, x' /= mempty ] + shrink (NonMEmpty x) = [NonMEmpty x' | x' <- shrink x, x' /= mempty] -newtype NoShrink a = NoShrink { getNoShrink :: a } +newtype NoShrink a = NoShrink {getNoShrink :: a} deriving (Eq, Ord, Show) instance Arbitrary a => Arbitrary (NoShrink a) where - arbitrary = NoShrink <$> arbitrary - shrink _ = [] + arbitrary = NoShrink <$> arbitrary + shrink _ = [] instance Arbitrary Timestamp where - -- note: no negative timestamps - -- - -- >>> utcTimeToPOSIXSeconds $ UTCTime (fromGregorian 100000 01 01) 0 - -- >>> 3093527980800s - -- - arbitrary = maybe (toEnum 0) id . epochTimeToTimestamp . (`mod` 3093527980800) . abs <$> arbitrary + -- note: no negative timestamps + -- + -- >>> utcTimeToPOSIXSeconds $ UTCTime (fromGregorian 100000 01 01) 0 + -- >>> 3093527980800s + -- + arbitrary = maybe (toEnum 0) id . epochTimeToTimestamp . (`mod` 3093527980800) . abs <$> arbitrary instance Arbitrary RepoIndexState where - arbitrary = frequency [ (1, pure IndexStateHead) - , (50, IndexStateTime <$> arbitrary) - ] + arbitrary = + frequency + [ (1, pure IndexStateHead) + , (50, IndexStateTime <$> arbitrary) + ] instance Arbitrary TotalIndexState where - arbitrary = makeTotalIndexState <$> arbitrary <*> arbitrary + arbitrary = makeTotalIndexState <$> arbitrary <*> arbitrary instance Arbitrary WriteGhcEnvironmentFilesPolicy where - arbitrary = arbitraryBoundedEnum + arbitrary = arbitraryBoundedEnum arbitraryFlag :: Gen a -> Gen (Flag a) arbitraryFlag = liftArbitrary instance Arbitrary RepoName where - -- TODO: rename refinement? - arbitrary = RepoName <$> (mk `suchThat` \x -> not $ "--" `isPrefixOf` x) where + -- TODO: rename refinement? + arbitrary = RepoName <$> (mk `suchThat` \x -> not $ "--" `isPrefixOf` x) + where mk = (:) <$> lead <*> rest - lead = elements - [ c | c <- [ '\NUL' .. '\255' ], isAlpha c || c `elem` "_-."] - rest = listOf (elements - [ c | c <- [ '\NUL' .. '\255' ], isAlphaNum c || c `elem` "_-."]) + lead = + elements + [c | c <- ['\NUL' .. '\255'], isAlpha c || c `elem` "_-."] + rest = + listOf + ( elements + [c | c <- ['\NUL' .. '\255'], isAlphaNum c || c `elem` "_-."] + ) instance Arbitrary ReportLevel where - arbitrary = arbitraryBoundedEnum + arbitrary = arbitraryBoundedEnum instance Arbitrary OverwritePolicy where - arbitrary = arbitraryBoundedEnum + arbitrary = arbitraryBoundedEnum instance Arbitrary InstallMethod where - arbitrary = arbitraryBoundedEnum + arbitrary = arbitraryBoundedEnum ------------------------------------------------------------------------------- -- ActiveRepos ------------------------------------------------------------------------------- instance Arbitrary ActiveRepos where - arbitrary = ActiveRepos <$> shortListOf 5 arbitrary + arbitrary = ActiveRepos <$> shortListOf 5 arbitrary instance Arbitrary ActiveRepoEntry where - arbitrary = frequency - [ (10, ActiveRepo <$> arbitrary <*> arbitrary) - , (1, ActiveRepoRest <$> arbitrary) - ] + arbitrary = + frequency + [ (10, ActiveRepo <$> arbitrary <*> arbitrary) + , (1, ActiveRepoRest <$> arbitrary) + ] instance Arbitrary CombineStrategy where - arbitrary = arbitraryBoundedEnum - shrink = shrinkBoundedEnum + arbitrary = arbitraryBoundedEnum + shrink = shrinkBoundedEnum ------------------------------------------------------------------------------- -- AllowNewer ------------------------------------------------------------------------------- instance Arbitrary AllowNewer where - arbitrary = AllowNewer <$> arbitrary + arbitrary = AllowNewer <$> arbitrary instance Arbitrary AllowOlder where - arbitrary = AllowOlder <$> arbitrary + arbitrary = AllowOlder <$> arbitrary instance Arbitrary RelaxDeps where - arbitrary = oneof [ pure mempty - , mkRelaxDepSome <$> shortListOf1 3 arbitrary - , pure RelaxDepsAll - ] + arbitrary = + oneof + [ pure mempty + , mkRelaxDepSome <$> shortListOf1 3 arbitrary + , pure RelaxDepsAll + ] instance Arbitrary RelaxDepMod where - arbitrary = elements [RelaxDepModNone, RelaxDepModCaret] + arbitrary = elements [RelaxDepModNone, RelaxDepModCaret] - shrink RelaxDepModCaret = [RelaxDepModNone] - shrink _ = [] + shrink RelaxDepModCaret = [RelaxDepModNone] + shrink _ = [] instance Arbitrary RelaxDepScope where - arbitrary = genericArbitrary - shrink = genericShrink + arbitrary = genericArbitrary + shrink = genericShrink instance Arbitrary RelaxDepSubject where - arbitrary = genericArbitrary - shrink = genericShrink + arbitrary = genericArbitrary + shrink = genericShrink instance Arbitrary RelaxedDep where - arbitrary = genericArbitrary - shrink = genericShrink + arbitrary = genericArbitrary + shrink = genericShrink ------------------------------------------------------------------------------- -- UserConstraint ------------------------------------------------------------------------------- instance Arbitrary UserConstraintScope where - arbitrary = genericArbitrary - shrink = genericShrink + arbitrary = genericArbitrary + shrink = genericShrink instance Arbitrary UserQualifier where - arbitrary = oneof [ pure UserQualToplevel - , UserQualSetup <$> arbitrary - - -- -- TODO: Re-enable UserQualExe tests once we decide on a syntax. - -- , UserQualExe <$> arbitrary <*> arbitrary - ] - + arbitrary = + oneof + [ pure UserQualToplevel + , UserQualSetup <$> arbitrary + -- -- TODO: Re-enable UserQualExe tests once we decide on a syntax. + -- , UserQualExe <$> arbitrary <*> arbitrary + ] instance Arbitrary UserConstraint where - arbitrary = genericArbitrary - shrink = genericShrink + arbitrary = genericArbitrary + shrink = genericShrink instance Arbitrary PackageProperty where - arbitrary = oneof [ PackagePropertyVersion <$> arbitrary - , pure PackagePropertyInstalled - , pure PackagePropertySource - , PackagePropertyFlags . mkFlagAssignment <$> shortListOf1 3 arbitrary - , PackagePropertyStanzas . (\x->[x]) <$> arbitrary - ] + arbitrary = + oneof + [ PackagePropertyVersion <$> arbitrary + , pure PackagePropertyInstalled + , pure PackagePropertySource + , PackagePropertyFlags . mkFlagAssignment <$> shortListOf1 3 arbitrary + , PackagePropertyStanzas . (\x -> [x]) <$> arbitrary + ] instance Arbitrary OptionalStanza where - arbitrary = elements [minBound..maxBound] + arbitrary = elements [minBound .. maxBound] instance Arbitrary OptionalStanzaSet where - arbitrary = fmap optStanzaSetFromList arbitrary + arbitrary = fmap optStanzaSetFromList arbitrary instance Arbitrary a => Arbitrary (OptionalStanzaMap a) where - arbitrary = do - x1 <- arbitrary - x2 <- arbitrary - return $ optStanzaTabulate $ \x -> case x of - TestStanzas -> x1 - BenchStanzas -> x2 + arbitrary = do + x1 <- arbitrary + x2 <- arbitrary + return $ optStanzaTabulate $ \x -> case x of + TestStanzas -> x1 + BenchStanzas -> x2 ------------------------------------------------------------------------------- -- BuildReport ------------------------------------------------------------------------------- instance Arbitrary BuildReport where - arbitrary = genericArbitrary - shrink = genericShrink + arbitrary = genericArbitrary + shrink = genericShrink instance Arbitrary InstallOutcome where - arbitrary = genericArbitrary - shrink = genericShrink + arbitrary = genericArbitrary + shrink = genericShrink instance Arbitrary Outcome where - arbitrary = genericArbitrary - shrink = genericShrink + arbitrary = genericArbitrary + shrink = genericShrink ------------------------------------------------------------------------------- -- Glob ------------------------------------------------------------------------------- instance Arbitrary FilePathGlob where - arbitrary = (FilePathGlob <$> arbitrary <*> arbitrary) - `suchThat` validFilePathGlob + arbitrary = + (FilePathGlob <$> arbitrary <*> arbitrary) + `suchThat` validFilePathGlob shrink (FilePathGlob root pathglob) = [ FilePathGlob root' pathglob' | (root', pathglob') <- shrink (root, pathglob) - , validFilePathGlob (FilePathGlob root' pathglob') ] + , validFilePathGlob (FilePathGlob root' pathglob') + ] validFilePathGlob :: FilePathGlob -> Bool validFilePathGlob (FilePathGlob FilePathRelative pathglob) = case pathglob of - GlobDirTrailing -> False - GlobDir [Literal "~"] _ -> False - GlobDir [Literal (d:":")] _ - | isLetter d -> False - _ -> True + GlobDirTrailing -> False + GlobDir [Literal "~"] _ -> False + GlobDir [Literal (d : ":")] _ + | isLetter d -> False + _ -> True validFilePathGlob _ = True instance Arbitrary FilePathRoot where @@ -345,45 +365,49 @@ instance Arbitrary FilePathRoot where unixroot = "/" windrive = do d <- choose ('A', 'Z'); return (d : ":\\") - shrink FilePathRelative = [] - shrink (FilePathRoot _) = [FilePathRelative] - shrink FilePathHomeDir = [FilePathRelative] - + shrink FilePathRelative = [] + shrink (FilePathRoot _) = [FilePathRelative] + shrink FilePathHomeDir = [FilePathRelative] instance Arbitrary FilePathGlobRel where arbitrary = sized $ \sz -> - oneof $ take (max 1 sz) - [ pure GlobDirTrailing - , GlobFile <$> (getGlobPieces <$> arbitrary) - , GlobDir <$> (getGlobPieces <$> arbitrary) - <*> resize (sz `div` 2) arbitrary - ] + oneof $ + take + (max 1 sz) + [ pure GlobDirTrailing + , GlobFile <$> (getGlobPieces <$> arbitrary) + , GlobDir + <$> (getGlobPieces <$> arbitrary) + <*> resize (sz `div` 2) arbitrary + ] shrink GlobDirTrailing = [] shrink (GlobFile glob) = - GlobDirTrailing - : [ GlobFile (getGlobPieces glob') | glob' <- shrink (GlobPieces glob) ] + GlobDirTrailing + : [GlobFile (getGlobPieces glob') | glob' <- shrink (GlobPieces glob)] shrink (GlobDir glob pathglob) = - pathglob - : GlobFile glob - : [ GlobDir (getGlobPieces glob') pathglob' - | (glob', pathglob') <- shrink (GlobPieces glob, pathglob) ] + pathglob + : GlobFile glob + : [ GlobDir (getGlobPieces glob') pathglob' + | (glob', pathglob') <- shrink (GlobPieces glob, pathglob) + ] -newtype GlobPieces = GlobPieces { getGlobPieces :: [GlobPiece] } - deriving Eq +newtype GlobPieces = GlobPieces {getGlobPieces :: [GlobPiece]} + deriving (Eq) instance Arbitrary GlobPieces where arbitrary = GlobPieces . mergeLiterals <$> shortListOf1 5 arbitrary shrink (GlobPieces glob) = [ GlobPieces (mergeLiterals (getNonEmpty glob')) - | glob' <- shrink (NonEmpty glob) ] + | glob' <- shrink (NonEmpty glob) + ] mergeLiterals :: [GlobPiece] -> [GlobPiece] -mergeLiterals (Literal a : Literal b : ps) = mergeLiterals (Literal (a++b) : ps) +mergeLiterals (Literal a : Literal b : ps) = mergeLiterals (Literal (a ++ b) : ps) mergeLiterals (Union as : ps) = Union (map mergeLiterals as) : mergeLiterals ps -mergeLiterals (p:ps) = p : mergeLiterals ps -mergeLiterals [] = [] +mergeLiterals (p : ps) = p : mergeLiterals ps +mergeLiterals [] = [] instance Arbitrary GlobPiece where arbitrary = sized $ \sz -> @@ -393,13 +417,17 @@ instance Arbitrary GlobPiece where , (1, Union <$> resize (sz `div` 2) (shortListOf1 5 (shortListOf1 5 arbitrary))) ] - shrink (Literal str) = [ Literal str' - | str' <- shrink str - , not (null str') - , all (`elem` globLiteralChars) str' ] - shrink WildCard = [] - shrink (Union as) = [ Union (map getGlobPieces (getNonEmpty as')) - | as' <- shrink (NonEmpty (map GlobPieces as)) ] + shrink (Literal str) = + [ Literal str' + | str' <- shrink str + , not (null str') + , all (`elem` globLiteralChars) str' + ] + shrink WildCard = [] + shrink (Union as) = + [ Union (map getGlobPieces (getNonEmpty as')) + | as' <- shrink (NonEmpty (map GlobPieces as)) + ] globLiteralChars :: [Char] -globLiteralChars = ['\0'..'\128'] \\ "*{},/\\" +globLiteralChars = ['\0' .. '\128'] \\ "*{},/\\" diff --git a/cabal-install/tests/UnitTests/Distribution/Client/BuildReport.hs b/cabal-install/tests/UnitTests/Distribution/Client/BuildReport.hs index 169a8c6b9b5..639e51c100c 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/BuildReport.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/BuildReport.hs @@ -1,31 +1,31 @@ -module UnitTests.Distribution.Client.BuildReport ( - tests, -) where +module UnitTests.Distribution.Client.BuildReport + ( tests + ) where import Distribution.Client.Compat.Prelude -import Prelude () import UnitTests.Distribution.Client.ArbitraryInstances () import UnitTests.Distribution.Client.TreeDiffInstances () +import Prelude () import Data.TreeDiff.QuickCheck (ediffEq) -import Test.QuickCheck (Property, counterexample) -import Test.Tasty (TestTree) -import Test.Tasty.QuickCheck (testProperty) +import Test.QuickCheck (Property, counterexample) +import Test.Tasty (TestTree) +import Test.Tasty.QuickCheck (testProperty) import Distribution.Client.BuildReports.Anonymous (BuildReport, parseBuildReport, showBuildReport) -import Distribution.Simple.Utils (toUTF8BS) +import Distribution.Simple.Utils (toUTF8BS) -- instances import Test.QuickCheck.Instances.Cabal () tests :: [TestTree] tests = - [ testProperty "test" roundtrip - ] + [ testProperty "test" roundtrip + ] roundtrip :: BuildReport -> Property roundtrip br = - counterexample str $ + counterexample str $ Right br `ediffEq` parseBuildReport (toUTF8BS str) where str :: String diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Configure.hs b/cabal-install/tests/UnitTests/Distribution/Client/Configure.hs index 91a61358ade..c570d7a738a 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Configure.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Configure.hs @@ -1,90 +1,114 @@ {-# LANGUAGE RecordWildCards #-} + module UnitTests.Distribution.Client.Configure (tests) where import Distribution.Client.CmdConfigure -import Test.Tasty -import Test.Tasty.HUnit import Control.Monad import qualified Data.Map as Map -import System.Directory -import System.FilePath -import Distribution.Verbosity -import Distribution.Client.Setup import Distribution.Client.NixStyleOptions import Distribution.Client.ProjectConfig.Types import Distribution.Client.ProjectFlags +import Distribution.Client.Setup import Distribution.Simple import Distribution.Simple.Flag +import Distribution.Verbosity +import System.Directory +import System.FilePath +import Test.Tasty +import Test.Tasty.HUnit tests :: [TestTree] tests = - [ configureTests - ] + [ configureTests + ] configureTests :: TestTree -configureTests = testGroup "Configure tests" +configureTests = + testGroup + "Configure tests" [ testCase "New config" $ do - let flags = (defaultNixStyleFlags ()) - { configFlags = mempty - { configOptimization = Flag MaximumOptimisation - , configVerbosity = Flag silent - } - } + let flags = + (defaultNixStyleFlags ()) + { configFlags = + mempty + { configOptimization = Flag MaximumOptimisation + , configVerbosity = Flag silent + } + } projConfig <- configureAction' flags [] defaultGlobalFlags - Flag MaximumOptimisation @=? - (packageConfigOptimization . projectConfigLocalPackages $ snd projConfig) - + Flag MaximumOptimisation + @=? (packageConfigOptimization . projectConfigLocalPackages $ snd projConfig) , testCase "Replacement + new config" $ do - let flags = (defaultNixStyleFlags ()) - { configExFlags = mempty - { configAppend = Flag True } - , configFlags = mempty - { configOptimization = Flag NoOptimisation - , configVerbosity = Flag silent - } - , projectFlags = mempty - { flagProjectDir = Flag projectDir } - } - (_, ProjectConfig {..}) <- configureAction' flags [] defaultGlobalFlags + let flags = + (defaultNixStyleFlags ()) + { configExFlags = + mempty + { configAppend = Flag True + } + , configFlags = + mempty + { configOptimization = Flag NoOptimisation + , configVerbosity = Flag silent + } + , projectFlags = + mempty + { flagProjectDir = Flag projectDir + } + } + (_, ProjectConfig{..}) <- configureAction' flags [] defaultGlobalFlags Flag NoOptimisation @=? packageConfigOptimization projectConfigLocalPackages - Flag silent @=? projectConfigVerbosity projectConfigBuildOnly - + Flag silent @=? projectConfigVerbosity projectConfigBuildOnly , testCase "Old + new config" $ do - let flags = (defaultNixStyleFlags ()) - { configExFlags = mempty - { configAppend = Flag True } - , configFlags = mempty - { configVerbosity = Flag silent } - , projectFlags = mempty - { flagProjectDir = Flag projectDir } - } - (_, ProjectConfig {..}) <- configureAction' flags [] defaultGlobalFlags + let flags = + (defaultNixStyleFlags ()) + { configExFlags = + mempty + { configAppend = Flag True + } + , configFlags = + mempty + { configVerbosity = Flag silent + } + , projectFlags = + mempty + { flagProjectDir = Flag projectDir + } + } + (_, ProjectConfig{..}) <- configureAction' flags [] defaultGlobalFlags Flag MaximumOptimisation @=? packageConfigOptimization projectConfigLocalPackages - Flag silent @=? projectConfigVerbosity projectConfigBuildOnly - + Flag silent @=? projectConfigVerbosity projectConfigBuildOnly , testCase "Old + new config, no appending" $ do - let flags = (defaultNixStyleFlags ()) - { configFlags = mempty - { configVerbosity = Flag silent } - , projectFlags = mempty - { flagProjectDir = Flag projectDir } - } - (_, ProjectConfig {..}) <- configureAction' flags [] defaultGlobalFlags - - NoFlag @=? packageConfigOptimization projectConfigLocalPackages + let flags = + (defaultNixStyleFlags ()) + { configFlags = + mempty + { configVerbosity = Flag silent + } + , projectFlags = + mempty + { flagProjectDir = Flag projectDir + } + } + (_, ProjectConfig{..}) <- configureAction' flags [] defaultGlobalFlags + + NoFlag @=? packageConfigOptimization projectConfigLocalPackages Flag silent @=? projectConfigVerbosity projectConfigBuildOnly - , testCase "Old + new config, backup check" $ do - let flags = (defaultNixStyleFlags ()) - { configFlags = mempty - { configVerbosity = Flag silent } - , projectFlags = mempty - { flagProjectDir = Flag projectDir } - } + let flags = + (defaultNixStyleFlags ()) + { configFlags = + mempty + { configVerbosity = Flag silent + } + , projectFlags = + mempty + { flagProjectDir = Flag projectDir + } + } backup = projectDir "cabal.project.local~" exists <- doesFileExist backup @@ -93,29 +117,33 @@ configureTests = testGroup "Configure tests" _ <- configureAction' flags [] defaultGlobalFlags - doesFileExist backup >>= - assertBool ("No file found, expected: " ++ backup) - + doesFileExist backup + >>= assertBool ("No file found, expected: " ++ backup) , testCase "Local program options" $ do let ghcFlags = ["-fno-full-laziness"] - flags = (defaultNixStyleFlags ()) - { configFlags = mempty - { configVerbosity = Flag silent - , configProgramArgs = [("ghc", ghcFlags)] - } - , projectFlags = mempty - { flagProjectDir = Flag projectDir } - } - (_, ProjectConfig {..}) <- configureAction' flags [] defaultGlobalFlags - - - assertEqual "global" - Nothing - (Map.lookup "ghc" (getMapMappend (packageConfigProgramArgs projectConfigAllPackages))) - - assertEqual "local" - (Just ghcFlags) - (Map.lookup "ghc" (getMapMappend (packageConfigProgramArgs projectConfigLocalPackages))) + flags = + (defaultNixStyleFlags ()) + { configFlags = + mempty + { configVerbosity = Flag silent + , configProgramArgs = [("ghc", ghcFlags)] + } + , projectFlags = + mempty + { flagProjectDir = Flag projectDir + } + } + (_, ProjectConfig{..}) <- configureAction' flags [] defaultGlobalFlags + + assertEqual + "global" + Nothing + (Map.lookup "ghc" (getMapMappend (packageConfigProgramArgs projectConfigAllPackages))) + + assertEqual + "local" + (Just ghcFlags) + (Map.lookup "ghc" (getMapMappend (packageConfigProgramArgs projectConfigLocalPackages))) ] projectDir :: FilePath diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Described.hs b/cabal-install/tests/UnitTests/Distribution/Client/Described.hs index 820cdf95a70..fbd544a9a0b 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Described.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Described.hs @@ -1,26 +1,29 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} + module UnitTests.Distribution.Client.Described where import Distribution.Client.Compat.Prelude -import Prelude () import Test.QuickCheck.Instances.Cabal () import UnitTests.Distribution.Client.ArbitraryInstances () import UnitTests.Distribution.Client.DescribedInstances () +import Prelude () import Distribution.Described (testDescribed) -import Test.Tasty (TestTree, testGroup) +import Test.Tasty (TestTree, testGroup) -import Distribution.Client.BuildReports.Types (InstallOutcome, Outcome) +import Distribution.Client.BuildReports.Types (InstallOutcome, Outcome) import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepos) -import Distribution.Client.IndexUtils.IndexState (RepoIndexState, TotalIndexState) -import Distribution.Client.IndexUtils.Timestamp (Timestamp) -import Distribution.Client.Targets (UserConstraint) -import Distribution.Client.Types (RepoName) -import Distribution.Client.Types.AllowNewer (RelaxDepSubject, RelaxDeps, RelaxedDep) +import Distribution.Client.IndexUtils.IndexState (RepoIndexState, TotalIndexState) +import Distribution.Client.IndexUtils.Timestamp (Timestamp) +import Distribution.Client.Targets (UserConstraint) +import Distribution.Client.Types (RepoName) +import Distribution.Client.Types.AllowNewer (RelaxDepSubject, RelaxDeps, RelaxedDep) tests :: TestTree -tests = testGroup "Described" +tests = + testGroup + "Described" [ testDescribed (Proxy :: Proxy Timestamp) , testDescribed (Proxy :: Proxy RepoIndexState) , testDescribed (Proxy :: Proxy TotalIndexState) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/DescribedInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/DescribedInstances.hs index d0e2ad43a84..66b9649db11 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/DescribedInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/DescribedInstances.hs @@ -1,47 +1,50 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + module UnitTests.Distribution.Client.DescribedInstances where import Distribution.Client.Compat.Prelude -import Distribution.Described import Data.List ((\\)) +import Distribution.Described -import Distribution.Types.PackageId (PackageIdentifier) -import Distribution.Types.PackageName (PackageName) +import Distribution.Types.PackageId (PackageIdentifier) +import Distribution.Types.PackageName (PackageName) import Distribution.Types.VersionRange (VersionRange) -import Distribution.Client.BuildReports.Types (InstallOutcome, Outcome) +import Distribution.Client.BuildReports.Types (InstallOutcome, Outcome) +import Distribution.Client.Glob (FilePathGlob) import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepoEntry, ActiveRepos, CombineStrategy) -import Distribution.Client.IndexUtils.IndexState (RepoIndexState, TotalIndexState) -import Distribution.Client.IndexUtils.Timestamp (Timestamp) -import Distribution.Client.Targets (UserConstraint) -import Distribution.Client.Types (RepoName) -import Distribution.Client.Types.AllowNewer (RelaxDepSubject, RelaxDeps, RelaxedDep) -import Distribution.Client.Glob (FilePathGlob) +import Distribution.Client.IndexUtils.IndexState (RepoIndexState, TotalIndexState) +import Distribution.Client.IndexUtils.Timestamp (Timestamp) +import Distribution.Client.Targets (UserConstraint) +import Distribution.Client.Types (RepoName) +import Distribution.Client.Types.AllowNewer (RelaxDepSubject, RelaxDeps, RelaxedDep) ------------------------------------------------------------------------------- -- BuildReport ------------------------------------------------------------------------------- instance Described InstallOutcome where - describe _ = REUnion - [ "PlanningFailed" - , "DependencyFailed" <> RESpaces1 <> describe (Proxy :: Proxy PackageIdentifier) - , "DownloadFailed" - , "UnpackFailed" - , "SetupFailed" - , "ConfigureFailed" - , "BuildFailed" - , "TestsFailed" - , "InstallFailed" - , "InstallOk" - ] + describe _ = + REUnion + [ "PlanningFailed" + , "DependencyFailed" <> RESpaces1 <> describe (Proxy :: Proxy PackageIdentifier) + , "DownloadFailed" + , "UnpackFailed" + , "SetupFailed" + , "ConfigureFailed" + , "BuildFailed" + , "TestsFailed" + , "InstallFailed" + , "InstallOk" + ] instance Described Outcome where - describe _ = REUnion - [ fromString (prettyShow o) - | o <- [minBound .. maxBound :: Outcome] - ] + describe _ = + REUnion + [ fromString (prettyShow o) + | o <- [minBound .. maxBound :: Outcome] + ] ------------------------------------------------------------------------------- -- Glob @@ -49,258 +52,293 @@ instance Described Outcome where -- This instance is incorrect as it may generate C:\dir\{foo,bar} instance Described FilePathGlob where - describe _ = REUnion [ root, relative, homedir ] where - root = REUnion - [ fromString "/" - , reChars (['a'..'z'] ++ ['A' .. 'Z']) <> ":" <> reChars "/\\" - ] <> REOpt pieces - homedir = "~/" <> REOpt pieces - relative = pieces - - pieces :: GrammarRegex void - pieces = REMunch1 sep piece <> REOpt "/" - - piece :: GrammarRegex void - piece = RERec "glob" $ REMunch1 mempty $ REUnion - [ normal - , escape - , wildcard - , "{" <> REMunch1 "," (REVar Nothing) <> "}" - ] - - sep :: GrammarRegex void - sep = reChars "/\\" - - wildcard :: GrammarRegex void - wildcard = "*" - - normal = reChars $ ['\0'..'\128'] \\ "*{},/\\" - escape = fromString "\\" <> reChars "*{}," + describe _ = REUnion [root, relative, homedir] + where + root = + REUnion + [ fromString "/" + , reChars (['a' .. 'z'] ++ ['A' .. 'Z']) <> ":" <> reChars "/\\" + ] + <> REOpt pieces + homedir = "~/" <> REOpt pieces + relative = pieces + + pieces :: GrammarRegex void + pieces = REMunch1 sep piece <> REOpt "/" + + piece :: GrammarRegex void + piece = + RERec "glob" $ + REMunch1 mempty $ + REUnion + [ normal + , escape + , wildcard + , "{" <> REMunch1 "," (REVar Nothing) <> "}" + ] + + sep :: GrammarRegex void + sep = reChars "/\\" + + wildcard :: GrammarRegex void + wildcard = "*" + + normal = reChars $ ['\0' .. '\128'] \\ "*{},/\\" + escape = fromString "\\" <> reChars "*{}," ------------------------------------------------------------------------------- -- AllowNewer ------------------------------------------------------------------------------- instance Described RelaxedDep where - describe _ = - REOpt (describeRelaxDepScope <> ":" <> REOpt ("^")) - <> describe (Proxy :: Proxy RelaxDepSubject) - where - describeRelaxDepScope = REUnion - [ "*" - , "all" - , RENamed "package-name" (describe (Proxy :: Proxy PackageName)) - , RENamed "package-id" (describe (Proxy :: Proxy PackageIdentifier)) - ] + describe _ = + REOpt (describeRelaxDepScope <> ":" <> REOpt ("^")) + <> describe (Proxy :: Proxy RelaxDepSubject) + where + describeRelaxDepScope = + REUnion + [ "*" + , "all" + , RENamed "package-name" (describe (Proxy :: Proxy PackageName)) + , RENamed "package-id" (describe (Proxy :: Proxy PackageIdentifier)) + ] instance Described RelaxDepSubject where - describe _ = REUnion - [ "*" - , "all" - , RENamed "package-name" (describe (Proxy :: Proxy PackageName)) - ] + describe _ = + REUnion + [ "*" + , "all" + , RENamed "package-name" (describe (Proxy :: Proxy PackageName)) + ] instance Described RelaxDeps where - describe _ = REUnion - [ "*" - , "all" - , "none" - , RECommaNonEmpty (describe (Proxy :: Proxy RelaxedDep)) - ] + describe _ = + REUnion + [ "*" + , "all" + , "none" + , RECommaNonEmpty (describe (Proxy :: Proxy RelaxedDep)) + ] ------------------------------------------------------------------------------- -- ActiveRepos ------------------------------------------------------------------------------- instance Described ActiveRepos where - describe _ = REUnion - [ ":none" - , RECommaNonEmpty (describe (Proxy :: Proxy ActiveRepoEntry)) - ] + describe _ = + REUnion + [ ":none" + , RECommaNonEmpty (describe (Proxy :: Proxy ActiveRepoEntry)) + ] instance Described ActiveRepoEntry where - describe _ = REUnion - [ ":rest" <> strategy - , REOpt ":repo:" <> describe (Proxy :: Proxy RepoName) <> strategy - ] - where - strategy = REOpt $ ":" <> describe (Proxy :: Proxy CombineStrategy) + describe _ = + REUnion + [ ":rest" <> strategy + , REOpt ":repo:" <> describe (Proxy :: Proxy RepoName) <> strategy + ] + where + strategy = REOpt $ ":" <> describe (Proxy :: Proxy CombineStrategy) instance Described CombineStrategy where - describe _ = REUnion - [ "skip" - , "merge" - , "override" - ] + describe _ = + REUnion + [ "skip" + , "merge" + , "override" + ] ------------------------------------------------------------------------------- -- UserConstraint ------------------------------------------------------------------------------- instance Described UserConstraint where - describe _ = REAppend - [ describeConstraintScope - , describeConstraintProperty - ] - where - describeConstraintScope :: GrammarRegex void - describeConstraintScope = REUnion - [ "any." <> describePN - , "setup." <> describePN - , describePN - , describePN <> ":setup." <> describePN - ] - - describeConstraintProperty :: GrammarRegex void - describeConstraintProperty = REUnion - [ RESpaces <> RENamed "version-range" (describe (Proxy :: Proxy VersionRange)) - , RESpaces1 <> describeConstraintProperty' - ] - - describeConstraintProperty' :: GrammarRegex void - describeConstraintProperty' = REUnion - [ "installed" - , "source" - , "test" - , "bench" - , describeFlagAssignmentNonEmpty - ] - - describePN :: GrammarRegex void - describePN = RENamed "package-name" (describe (Proxy :: Proxy PackageName)) + describe _ = + REAppend + [ describeConstraintScope + , describeConstraintProperty + ] + where + describeConstraintScope :: GrammarRegex void + describeConstraintScope = + REUnion + [ "any." <> describePN + , "setup." <> describePN + , describePN + , describePN <> ":setup." <> describePN + ] + + describeConstraintProperty :: GrammarRegex void + describeConstraintProperty = + REUnion + [ RESpaces <> RENamed "version-range" (describe (Proxy :: Proxy VersionRange)) + , RESpaces1 <> describeConstraintProperty' + ] + + describeConstraintProperty' :: GrammarRegex void + describeConstraintProperty' = + REUnion + [ "installed" + , "source" + , "test" + , "bench" + , describeFlagAssignmentNonEmpty + ] + + describePN :: GrammarRegex void + describePN = RENamed "package-name" (describe (Proxy :: Proxy PackageName)) ------------------------------------------------------------------------------- -- IndexState ------------------------------------------------------------------------------- instance Described TotalIndexState where - describe _ = reCommaNonEmpty $ REUnion + describe _ = + reCommaNonEmpty $ + REUnion [ describe (Proxy :: Proxy RepoName) <> RESpaces1 <> ris , ris ] - where - ris = describe (Proxy :: Proxy RepoIndexState) + where + ris = describe (Proxy :: Proxy RepoIndexState) instance Described RepoName where - describe _ = lead <> rest where - lead = RECharSet $ csAlpha <> "_-." - rest = reMunchCS $ csAlphaNum <> "_-." + describe _ = lead <> rest + where + lead = RECharSet $ csAlpha <> "_-." + rest = reMunchCS $ csAlphaNum <> "_-." instance Described RepoIndexState where - describe _ = REUnion - [ "HEAD" - , RENamed "timestamp" (describe (Proxy :: Proxy Timestamp)) - ] + describe _ = + REUnion + [ "HEAD" + , RENamed "timestamp" (describe (Proxy :: Proxy Timestamp)) + ] instance Described Timestamp where - describe _ = REUnion - [ posix - , utc - ] - where - posix = reChar '@' <> reMunch1CS "0123456789" - utc = RENamed "date" date <> reChar 'T' <> RENamed "time" time <> reChar 'Z' - - date = REOpt digit <> REUnion - [ leapYear <> reChar '-' <> leapMD + describe _ = + REUnion + [ posix + , utc + ] + where + posix = reChar '@' <> reMunch1CS "0123456789" + utc = RENamed "date" date <> reChar 'T' <> RENamed "time" time <> reChar 'Z' + + date = + REOpt digit + <> REUnion + [ leapYear <> reChar '-' <> leapMD , commonYear <> reChar '-' <> commonMD ] - -- leap year: either - -- * divisible by 400 - -- * not divisible by 100 and divisible by 4 - leapYear = REUnion - [ div4 <> "00" - , digit <> digit <> div4not0 - ] - - -- common year: either - -- * not divisible by 400 but divisible by 100 - -- * not divisible by 4 - commonYear = REUnion - [ notDiv4 <> "00" - , digit <> digit <> notDiv4 - ] - - div4 = REUnion - [ "0" <> reChars "048" - , "1" <> reChars "26" - , "2" <> reChars "048" - , "3" <> reChars "26" - , "4" <> reChars "048" - , "5" <> reChars "26" - , "6" <> reChars "048" - , "7" <> reChars "26" - , "8" <> reChars "048" - , "9" <> reChars "26" - ] - - div4not0 = REUnion - [ "0" <> reChars "48" -- no zero - , "1" <> reChars "26" - , "2" <> reChars "048" - , "3" <> reChars "26" - , "4" <> reChars "048" - , "5" <> reChars "26" - , "6" <> reChars "048" - , "7" <> reChars "26" - , "8" <> reChars "048" - , "9" <> reChars "26" - ] - - notDiv4 = REUnion - [ "0" <> reChars "1235679" - , "1" <> reChars "01345789" - , "2" <> reChars "1235679" - , "3" <> reChars "01345789" - , "4" <> reChars "1235679" - , "5" <> reChars "01345789" - , "6" <> reChars "1235679" - , "7" <> reChars "01345789" - , "8" <> reChars "1235679" - , "9" <> reChars "01345789" - ] - - leapMD = REUnion - [ jan, fe', mar, apr, may, jun, jul, aug, sep, oct, nov, dec ] - - commonMD = REUnion - [ jan, feb, mar, apr, may, jun, jul, aug, sep, oct, nov, dec ] - - jan = "01-" <> d31 - feb = "02-" <> d28 - fe' = "02-" <> d29 - mar = "03-" <> d31 - apr = "04-" <> d30 - may = "05-" <> d31 - jun = "06-" <> d30 - jul = "07-" <> d31 - aug = "08-" <> d31 - sep = "09-" <> d30 - oct = "10-" <> d31 - nov = "11-" <> d30 - dec = "12-" <> d31 - - d28 = REUnion - [ "0" <> digit1, "1" <> digit, "2" <> reChars "012345678" ] - d29 = REUnion - [ "0" <> digit1, "1" <> digit, "2" <> digit ] - d30 = REUnion - [ "0" <> digit1, "1" <> digit, "2" <> digit, "30" ] - d31 = REUnion - [ "0" <> digit1, "1" <> digit, "2" <> digit, "30", "31" ] - - time = ho <> reChar ':' <> minSec <> reChar ':' <> minSec - - -- 0..23 - ho = REUnion - [ "0" <> digit - , "1" <> digit - , "2" <> reChars "0123" - ] - - -- 0..59 - minSec = reChars "012345" <> digit - - digit = reChars "0123456789" - digit1 = reChars "123456789" + -- leap year: either + -- \* divisible by 400 + -- \* not divisible by 100 and divisible by 4 + leapYear = + REUnion + [ div4 <> "00" + , digit <> digit <> div4not0 + ] + + -- common year: either + -- \* not divisible by 400 but divisible by 100 + -- \* not divisible by 4 + commonYear = + REUnion + [ notDiv4 <> "00" + , digit <> digit <> notDiv4 + ] + + div4 = + REUnion + [ "0" <> reChars "048" + , "1" <> reChars "26" + , "2" <> reChars "048" + , "3" <> reChars "26" + , "4" <> reChars "048" + , "5" <> reChars "26" + , "6" <> reChars "048" + , "7" <> reChars "26" + , "8" <> reChars "048" + , "9" <> reChars "26" + ] + + div4not0 = + REUnion + [ "0" <> reChars "48" -- no zero + , "1" <> reChars "26" + , "2" <> reChars "048" + , "3" <> reChars "26" + , "4" <> reChars "048" + , "5" <> reChars "26" + , "6" <> reChars "048" + , "7" <> reChars "26" + , "8" <> reChars "048" + , "9" <> reChars "26" + ] + + notDiv4 = + REUnion + [ "0" <> reChars "1235679" + , "1" <> reChars "01345789" + , "2" <> reChars "1235679" + , "3" <> reChars "01345789" + , "4" <> reChars "1235679" + , "5" <> reChars "01345789" + , "6" <> reChars "1235679" + , "7" <> reChars "01345789" + , "8" <> reChars "1235679" + , "9" <> reChars "01345789" + ] + + leapMD = + REUnion + [jan, fe', mar, apr, may, jun, jul, aug, sep, oct, nov, dec] + + commonMD = + REUnion + [jan, feb, mar, apr, may, jun, jul, aug, sep, oct, nov, dec] + + jan = "01-" <> d31 + feb = "02-" <> d28 + fe' = "02-" <> d29 + mar = "03-" <> d31 + apr = "04-" <> d30 + may = "05-" <> d31 + jun = "06-" <> d30 + jul = "07-" <> d31 + aug = "08-" <> d31 + sep = "09-" <> d30 + oct = "10-" <> d31 + nov = "11-" <> d30 + dec = "12-" <> d31 + + d28 = + REUnion + ["0" <> digit1, "1" <> digit, "2" <> reChars "012345678"] + d29 = + REUnion + ["0" <> digit1, "1" <> digit, "2" <> digit] + d30 = + REUnion + ["0" <> digit1, "1" <> digit, "2" <> digit, "30"] + d31 = + REUnion + ["0" <> digit1, "1" <> digit, "2" <> digit, "30", "31"] + + time = ho <> reChar ':' <> minSec <> reChar ':' <> minSec + + -- 0..23 + ho = + REUnion + [ "0" <> digit + , "1" <> digit + , "2" <> reChars "0123" + ] + + -- 0..59 + minSec = reChars "012345" <> digit + + digit = reChars "0123456789" + digit1 = reChars "123456789" diff --git a/cabal-install/tests/UnitTests/Distribution/Client/FetchUtils.hs b/cabal-install/tests/UnitTests/Distribution/Client/FetchUtils.hs index 7ecd5f7ad05..d8c21aa3b17 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/FetchUtils.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/FetchUtils.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} + module UnitTests.Distribution.Client.FetchUtils - ( tests, + ( tests ) where @@ -26,13 +27,13 @@ tests :: [TestTree] tests = [ testGroup "asyncFetchPackages" - [ testCase "handles an empty package list" testEmpty, - testCase "passes an unpacked local package through" testPassLocalPackage, - testCase "handles http" testHttp, - testCase "aborts on interrupt in GET" $ testGetInterrupt, - testCase "aborts on other exception in GET" $ testGetException, - testCase "aborts on interrupt in GET (uncollected download)" $ testUncollectedInterrupt, - testCase "continues on other exception in GET (uncollected download)" $ testUncollectedException + [ testCase "handles an empty package list" testEmpty + , testCase "passes an unpacked local package through" testPassLocalPackage + , testCase "handles http" testHttp + , testCase "aborts on interrupt in GET" $ testGetInterrupt + , testCase "aborts on other exception in GET" $ testGetException + , testCase "aborts on interrupt in GET (uncollected download)" $ testUncollectedInterrupt + , testCase "continues on other exception in GET (uncollected download)" $ testUncollectedException ] ] @@ -175,24 +176,24 @@ mkPkgId :: String -> PackageIdentifier mkPkgId name = PackageIdentifier (mkPackageName name) (mkVersion [1, 0]) -- | Provide a repo and a repo context with the given GET handler. -withFakeRepoCtxt :: - (URI -> IO HttpCode) -> - (RepoContext -> Repo -> IO a) -> - IO a +withFakeRepoCtxt + :: (URI -> IO HttpCode) + -> (RepoContext -> Repo -> IO a) + -> IO a withFakeRepoCtxt handleGet action = withTestDir verbosity "fake repo" $ \tmpDir -> let repo = RepoRemote - { repoRemote = emptyRemoteRepo $ RepoName "fake", - repoLocalDir = tmpDir + { repoRemote = emptyRemoteRepo $ RepoName "fake" + , repoLocalDir = tmpDir } repoCtxt = RepoContext - { repoContextRepos = [repo], - repoContextGetTransport = return httpTransport, - repoContextWithSecureRepo = \_ _ -> - error "fake repo ctxt: repoContextWithSecureRepo not implemented", - repoContextIgnoreExpiry = error "fake repo ctxt: repoContextIgnoreExpiry not implemented" + { repoContextRepos = [repo] + , repoContextGetTransport = return httpTransport + , repoContextWithSecureRepo = \_ _ -> + error "fake repo ctxt: repoContextWithSecureRepo not implemented" + , repoContextIgnoreExpiry = error "fake repo ctxt: repoContextIgnoreExpiry not implemented" } in action repoCtxt repo where @@ -200,10 +201,10 @@ withFakeRepoCtxt handleGet action = HttpTransport { getHttp = \_verbosity uri _etag _filepath _headers -> do code <- handleGet uri - return (code, Nothing), - postHttp = error "fake transport: postHttp not implemented", - postHttpFile = error "fake transport: postHttpFile not implemented", - putHttpFile = error "fake transport: putHttp not implemented", - transportSupportsHttps = error "fake transport: transportSupportsHttps not implemented", - transportManuallySelected = True + return (code, Nothing) + , postHttp = error "fake transport: postHttp not implemented" + , postHttpFile = error "fake transport: postHttpFile not implemented" + , putHttpFile = error "fake transport: putHttp not implemented" + , transportSupportsHttps = error "fake transport: transportSupportsHttps not implemented" + , transportManuallySelected = True } diff --git a/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs b/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs index 629265acb8c..39f508040c3 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs @@ -2,91 +2,89 @@ module UnitTests.Distribution.Client.FileMonitor (tests) where import Distribution.Parsec (simpleParsec) -import Data.Proxy (Proxy (..)) -import Control.Monad -import Control.Exception import Control.Concurrent (threadDelay) +import Control.Exception +import Control.Monad +import Data.Proxy (Proxy (..)) import qualified Data.Set as Set -import System.FilePath import qualified System.Directory as IO +import System.FilePath import Prelude hiding (writeFile) import qualified Prelude as IO (writeFile) import Distribution.Compat.Binary import Distribution.Simple.Utils (withTempDirectory) -import Distribution.System (buildOS, OS (Windows)) +import Distribution.System (OS (Windows), buildOS) import Distribution.Verbosity (silent) import Distribution.Client.FileMonitor import Distribution.Compat.Time -import Distribution.Utils.Structured (structureHash, Structured) +import Distribution.Utils.Structured (Structured, structureHash) import GHC.Fingerprint (Fingerprint (..)) import Test.Tasty import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit - tests :: Int -> [TestTree] tests mtimeChange = - [ testGroup "Structured hashes" - [ testCase "MonitorStateFile" $ structureHash (Proxy :: Proxy MonitorStateFile) @?= Fingerprint 0xe4108804c34962f6 0x06e94f8fc9e48e13 - , testCase "MonitorStateGlob" $ structureHash (Proxy :: Proxy MonitorStateGlob) @?= Fingerprint 0xfd8f6be0e8258fe7 0xdb5fac737139bca6 - , testCase "MonitorStateFileSet" $ structureHash (Proxy :: Proxy MonitorStateFileSet) @?= Fingerprint 0xb745f4ea498389a5 0x70db6adb5078aa27 - ] - , testCase "sanity check mtimes" $ testFileMTimeSanity mtimeChange - , testCase "sanity check dirs" $ testDirChangeSanity mtimeChange - , testCase "no monitor cache" testNoMonitorCache + [ testGroup + "Structured hashes" + [ testCase "MonitorStateFile" $ structureHash (Proxy :: Proxy MonitorStateFile) @?= Fingerprint 0xe4108804c34962f6 0x06e94f8fc9e48e13 + , testCase "MonitorStateGlob" $ structureHash (Proxy :: Proxy MonitorStateGlob) @?= Fingerprint 0xfd8f6be0e8258fe7 0xdb5fac737139bca6 + , testCase "MonitorStateFileSet" $ structureHash (Proxy :: Proxy MonitorStateFileSet) @?= Fingerprint 0xb745f4ea498389a5 0x70db6adb5078aa27 + ] + , testCase "sanity check mtimes" $ testFileMTimeSanity mtimeChange + , testCase "sanity check dirs" $ testDirChangeSanity mtimeChange + , testCase "no monitor cache" testNoMonitorCache , testCaseSteps "corrupt monitor cache" testCorruptMonitorCache - , testCase "empty monitor" testEmptyMonitor - , testCase "missing file" testMissingFile - , testCase "change file" $ testChangedFile mtimeChange + , testCase "empty monitor" testEmptyMonitor + , testCase "missing file" testMissingFile + , testCase "change file" $ testChangedFile mtimeChange , testCase "file mtime vs content" $ testChangedFileMtimeVsContent mtimeChange - , testCase "update during action" $ testUpdateDuringAction mtimeChange - , testCase "remove file" testRemoveFile - , testCase "non-existent file" testNonExistentFile - , testCase "changed file type" $ testChangedFileType mtimeChange + , testCase "update during action" $ testUpdateDuringAction mtimeChange + , testCase "remove file" testRemoveFile + , testCase "non-existent file" testNonExistentFile + , testCase "changed file type" $ testChangedFileType mtimeChange , testCase "several monitor kinds" $ testMultipleMonitorKinds mtimeChange - - , testGroup "glob matches" - [ testCase "no change" testGlobNoChange - , testCase "add match" $ testGlobAddMatch mtimeChange - , testCase "remove match" $ testGlobRemoveMatch mtimeChange - , testCase "change match" $ testGlobChangeMatch mtimeChange - - , testCase "add match subdir" $ testGlobAddMatchSubdir mtimeChange - , testCase "remove match subdir" $ testGlobRemoveMatchSubdir mtimeChange - , testCase "change match subdir" $ testGlobChangeMatchSubdir mtimeChange - - , testCase "match toplevel dir" $ testGlobMatchTopDir mtimeChange - , testCase "add non-match" $ testGlobAddNonMatch mtimeChange - , testCase "remove non-match" $ testGlobRemoveNonMatch mtimeChange - - , knownBrokenInWindows "See issue #3126" $ - testCase "add non-match subdir" $ testGlobAddNonMatchSubdir mtimeChange - , testCase "remove non-match subdir" $ testGlobRemoveNonMatchSubdir mtimeChange - - , testCase "invariant sorted 1" $ testInvariantMonitorStateGlobFiles - mtimeChange - , testCase "invariant sorted 2" $ testInvariantMonitorStateGlobDirs - mtimeChange - - , testCase "match dirs" $ testGlobMatchDir mtimeChange - , knownBrokenInWindows "See issue #3126" $ - testCase "match dirs only" $ testGlobMatchDirOnly mtimeChange - , testCase "change file type" $ testGlobChangeFileType mtimeChange - , testCase "absolute paths" $ testGlobAbsolutePath mtimeChange - ] - - , testCase "value unchanged" testValueUnchanged - , testCase "value changed" testValueChanged - , testCase "value & file changed" $ testValueAndFileChanged mtimeChange - , testCase "value updated" testValueUpdated + , testGroup + "glob matches" + [ testCase "no change" testGlobNoChange + , testCase "add match" $ testGlobAddMatch mtimeChange + , testCase "remove match" $ testGlobRemoveMatch mtimeChange + , testCase "change match" $ testGlobChangeMatch mtimeChange + , testCase "add match subdir" $ testGlobAddMatchSubdir mtimeChange + , testCase "remove match subdir" $ testGlobRemoveMatchSubdir mtimeChange + , testCase "change match subdir" $ testGlobChangeMatchSubdir mtimeChange + , testCase "match toplevel dir" $ testGlobMatchTopDir mtimeChange + , testCase "add non-match" $ testGlobAddNonMatch mtimeChange + , testCase "remove non-match" $ testGlobRemoveNonMatch mtimeChange + , knownBrokenInWindows "See issue #3126" $ + testCase "add non-match subdir" $ + testGlobAddNonMatchSubdir mtimeChange + , testCase "remove non-match subdir" $ testGlobRemoveNonMatchSubdir mtimeChange + , testCase "invariant sorted 1" $ + testInvariantMonitorStateGlobFiles + mtimeChange + , testCase "invariant sorted 2" $ + testInvariantMonitorStateGlobDirs + mtimeChange + , testCase "match dirs" $ testGlobMatchDir mtimeChange + , knownBrokenInWindows "See issue #3126" $ + testCase "match dirs only" $ + testGlobMatchDirOnly mtimeChange + , testCase "change file type" $ testGlobChangeFileType mtimeChange + , testCase "absolute paths" $ testGlobAbsolutePath mtimeChange + ] + , testCase "value unchanged" testValueUnchanged + , testCase "value changed" testValueChanged + , testCase "value & file changed" $ testValueAndFileChanged mtimeChange + , testCase "value updated" testValueUpdated ] - - where knownBrokenInWindows msg = case buildOS of - Windows -> expectFailBecause msg - _ -> id + where + knownBrokenInWindows msg = case buildOS of + Windows -> expectFailBecause msg + _ -> id -- Check the file system behaves the way we expect it to @@ -106,7 +104,6 @@ testFileMTimeSanity mtimeChange = testDirChangeSanity :: Int -> Assertion testDirChangeSanity mtimeChange = withTempDirectory silent "." "dir-mtime-" $ \dir -> do - expectMTimeChange dir "file add" $ IO.writeFile (dir "file") "content" @@ -136,26 +133,28 @@ testDirChangeSanity mtimeChange = expectMTimeChange dir "subdir dir move out" $ IO.renameDirectory (dir "subdir") (dir "dir" "subdir") - where - expectMTimeChange, expectMTimeSame :: FilePath -> String -> IO () - -> Assertion + expectMTimeChange + , expectMTimeSame + :: FilePath + -> String + -> IO () + -> Assertion expectMTimeChange dir descr action = do - t <- getModTime dir + t <- getModTime dir threadDelay mtimeChange action t' <- getModTime dir assertBool ("expected dir mtime change on " ++ descr) (t' > t) expectMTimeSame dir descr action = do - t <- getModTime dir + t <- getModTime dir threadDelay mtimeChange action t' <- getModTime dir assertBool ("expected same dir mtime on " ++ descr) (t' == t) - -- Now for the FileMonitor tests proper... -- first run, where we don't even call updateMonitor @@ -177,7 +176,7 @@ testCorruptMonitorCache step = step "Updating file monitor" updateMonitor root monitor [] () () (res, files) <- expectMonitorUnchanged root monitor () - res @?= () + res @?= () files @?= [] step "Writing broken file again" @@ -193,23 +192,24 @@ testEmptyMonitor = updateMonitor root monitor [] () () touchFile root "b" (res, files) <- expectMonitorUnchanged root monitor () - res @?= () + res @?= () files @?= [] -- monitor a file that is expected to exist testMissingFile :: Assertion testMissingFile = do - test monitorFile touchFile "a" - test monitorFileHashed touchFile "a" - test monitorFile touchFile ("dir" "a") - test monitorFileHashed touchFile ("dir" "a") - test monitorDirectory touchDir "a" - test monitorDirectory touchDir ("dir" "a") + test monitorFile touchFile "a" + test monitorFileHashed touchFile "a" + test monitorFile touchFile ("dir" "a") + test monitorFileHashed touchFile ("dir" "a") + test monitorDirectory touchDir "a" + test monitorDirectory touchDir ("dir" "a") where - test :: (FilePath -> MonitorFilePath) - -> (RootPath -> FilePath -> IO ()) - -> FilePath - -> IO () + test + :: (FilePath -> MonitorFilePath) + -> (RootPath -> FilePath -> IO ()) + -> FilePath + -> IO () test monitorKind touch file = withFileMonitor $ \root monitor -> do -- a file that doesn't exist at snapshot time is considered to have @@ -225,21 +225,21 @@ testMissingFile = do reason2 <- expectMonitorChanged root monitor () reason2 @?= MonitoredFileChanged file - testChangedFile :: Int -> Assertion testChangedFile mtimeChange = do - test monitorFile touchFile touchFile "a" - test monitorFileHashed touchFile touchFileContent "a" - test monitorFile touchFile touchFile ("dir" "a") - test monitorFileHashed touchFile touchFileContent ("dir" "a") - test monitorDirectory touchDir touchDir "a" - test monitorDirectory touchDir touchDir ("dir" "a") + test monitorFile touchFile touchFile "a" + test monitorFileHashed touchFile touchFileContent "a" + test monitorFile touchFile touchFile ("dir" "a") + test monitorFileHashed touchFile touchFileContent ("dir" "a") + test monitorDirectory touchDir touchDir "a" + test monitorDirectory touchDir touchDir ("dir" "a") where - test :: (FilePath -> MonitorFilePath) - -> (RootPath -> FilePath -> IO ()) - -> (RootPath -> FilePath -> IO ()) - -> FilePath - -> IO () + test + :: (FilePath -> MonitorFilePath) + -> (RootPath -> FilePath -> IO ()) + -> (RootPath -> FilePath -> IO ()) + -> FilePath + -> IO () test monitorKind touch touch' file = withFileMonitor $ \root monitor -> do touch root file @@ -249,7 +249,6 @@ testChangedFile mtimeChange = do reason <- expectMonitorChanged root monitor () reason @?= MonitoredFileChanged file - testChangedFileMtimeVsContent :: Int -> Assertion testChangedFileMtimeVsContent mtimeChange = withFileMonitor $ \root monitor -> do @@ -257,7 +256,7 @@ testChangedFileMtimeVsContent mtimeChange = touchFile root "a" updateMonitor root monitor [monitorFile "a"] () () (res, files) <- expectMonitorUnchanged root monitor () - res @?= () + res @?= () files @?= [monitorFile "a"] -- if we do touch the file, it's changed if we only consider mtime @@ -272,7 +271,7 @@ testChangedFileMtimeVsContent mtimeChange = threadDelay mtimeChange touchFile root "a" (res2, files2) <- expectMonitorUnchanged root monitor () - res2 @?= () + res2 @?= () files2 @?= [monitorFileHashed "a"] -- finally if we change the content it's changed @@ -282,20 +281,22 @@ testChangedFileMtimeVsContent mtimeChange = reason2 <- expectMonitorChanged root monitor () reason2 @?= MonitoredFileChanged "a" - testUpdateDuringAction :: Int -> Assertion testUpdateDuringAction mtimeChange = do - test (monitorFile "a") touchFile "a" - test (monitorFileHashed "a") touchFile "a" - test (monitorDirectory "a") touchDir "a" - test (monitorFileGlobStr "*") touchFile "a" - test (monitorFileGlobStr "*") { monitorKindDir = DirModTime } - touchDir "a" + test (monitorFile "a") touchFile "a" + test (monitorFileHashed "a") touchFile "a" + test (monitorDirectory "a") touchDir "a" + test (monitorFileGlobStr "*") touchFile "a" + test + (monitorFileGlobStr "*"){monitorKindDir = DirModTime} + touchDir + "a" where - test :: MonitorFilePath - -> (RootPath -> FilePath -> IO ()) - -> FilePath - -> IO () + test + :: MonitorFilePath + -> (RootPath -> FilePath -> IO ()) + -> FilePath + -> IO () test monitorSpec touch file = withFileMonitor $ \root monitor -> do touch root file @@ -303,19 +304,19 @@ testUpdateDuringAction mtimeChange = do -- start doing an update action... threadDelay mtimeChange -- some time passes - touch root file -- a file gets updates during the action + touch root file -- a file gets updates during the action threadDelay mtimeChange -- some time passes then we finish updateMonitor root monitor [monitorSpec] () () -- we don't notice this change since we took the timestamp after the -- action finished (res, files) <- expectMonitorUnchanged root monitor () - res @?= () + res @?= () files @?= [monitorSpec] -- Let's try again, this time taking the timestamp before the action timestamp' <- beginUpdateFileMonitor threadDelay mtimeChange -- some time passes - touch root file -- a file gets updates during the action + touch root file -- a file gets updates during the action threadDelay mtimeChange -- some time passes then we finish updateMonitorWithTimestamp root monitor timestamp' [monitorSpec] () () -- now we do notice the change since we took the snapshot before the @@ -323,21 +324,21 @@ testUpdateDuringAction mtimeChange = do reason <- expectMonitorChanged root monitor () reason @?= MonitoredFileChanged file - testRemoveFile :: Assertion testRemoveFile = do - test monitorFile touchFile removeFile "a" - test monitorFileHashed touchFile removeFile "a" - test monitorFile touchFile removeFile ("dir" "a") - test monitorFileHashed touchFile removeFile ("dir" "a") - test monitorDirectory touchDir removeDir "a" - test monitorDirectory touchDir removeDir ("dir" "a") + test monitorFile touchFile removeFile "a" + test monitorFileHashed touchFile removeFile "a" + test monitorFile touchFile removeFile ("dir" "a") + test monitorFileHashed touchFile removeFile ("dir" "a") + test monitorDirectory touchDir removeDir "a" + test monitorDirectory touchDir removeDir ("dir" "a") where - test :: (FilePath -> MonitorFilePath) - -> (RootPath -> FilePath -> IO ()) - -> (RootPath -> FilePath -> IO ()) - -> FilePath - -> IO () + test + :: (FilePath -> MonitorFilePath) + -> (RootPath -> FilePath -> IO ()) + -> (RootPath -> FilePath -> IO ()) + -> FilePath + -> IO () test monitorKind touch remove file = withFileMonitor $ \root monitor -> do touch root file @@ -346,7 +347,6 @@ testRemoveFile = do reason <- expectMonitorChanged root monitor () reason @?= MonitoredFileChanged file - -- monitor a file that we expect not to exist testNonExistentFile :: Assertion testNonExistentFile = @@ -354,7 +354,7 @@ testNonExistentFile = -- a file that doesn't exist at snapshot time or check time is unchanged updateMonitor root monitor [monitorNonExistentFile "a"] () () (res, files) <- expectMonitorUnchanged root monitor () - res @?= () + res @?= () files @?= [monitorNonExistentFile "a"] -- if the file then exists it has changed @@ -376,31 +376,37 @@ testNonExistentFile = updateMonitor root monitor [monitorNonExistentFile "a"] () () removeFile root "a" (res2, files2) <- expectMonitorUnchanged root monitor () - res2 @?= () + res2 @?= () files2 @?= [monitorNonExistentFile "a"] - -testChangedFileType :: Int-> Assertion +testChangedFileType :: Int -> Assertion testChangedFileType mtimeChange = do - test (monitorFile "a") touchFile removeFile createDir - test (monitorFileHashed "a") touchFile removeFile createDir - - test (monitorDirectory "a") createDir removeDir touchFile - test (monitorFileOrDirectory "a") createDir removeDir touchFile - - test (monitorFileGlobStr "*") { monitorKindDir = DirModTime } - touchFile removeFile createDir - test (monitorFileGlobStr "*") { monitorKindDir = DirModTime } - createDir removeDir touchFile + test (monitorFile "a") touchFile removeFile createDir + test (monitorFileHashed "a") touchFile removeFile createDir + + test (monitorDirectory "a") createDir removeDir touchFile + test (monitorFileOrDirectory "a") createDir removeDir touchFile + + test + (monitorFileGlobStr "*"){monitorKindDir = DirModTime} + touchFile + removeFile + createDir + test + (monitorFileGlobStr "*"){monitorKindDir = DirModTime} + createDir + removeDir + touchFile where - test :: MonitorFilePath - -> (RootPath -> String -> IO ()) - -> (RootPath -> String -> IO ()) - -> (RootPath -> String -> IO ()) - -> IO () + test + :: MonitorFilePath + -> (RootPath -> String -> IO ()) + -> (RootPath -> String -> IO ()) + -> (RootPath -> String -> IO ()) + -> IO () test monitorKind touch remove touch' = withFileMonitor $ \root monitor -> do - touch root "a" + touch root "a" updateMonitor root monitor [monitorKind] () () threadDelay mtimeChange remove root "a" @@ -418,7 +424,7 @@ testMultipleMonitorKinds mtimeChange = touchFile root "a" updateMonitor root monitor [monitorFile "a", monitorFileHashed "a"] () () (res, files) <- expectMonitorUnchanged root monitor () - res @?= () + res @?= () files @?= [monitorFile "a", monitorFileHashed "a"] threadDelay mtimeChange touchFile root "a" -- not changing content, just mtime @@ -426,17 +432,22 @@ testMultipleMonitorKinds mtimeChange = reason @?= MonitoredFileChanged "a" createDir root "dir" - updateMonitor root monitor [monitorDirectory "dir", - monitorDirectoryExistence "dir"] () () + updateMonitor + root + monitor + [ monitorDirectory "dir" + , monitorDirectoryExistence "dir" + ] + () + () (res2, files2) <- expectMonitorUnchanged root monitor () - res2 @?= () + res2 @?= () files2 @?= [monitorDirectory "dir", monitorDirectoryExistence "dir"] threadDelay mtimeChange touchFile root ("dir" "a") -- changing dir mtime, not existence reason2 <- expectMonitorChanged root monitor () reason2 @?= MonitoredFileChanged "dir" - ------------------ -- globs -- @@ -448,7 +459,7 @@ testGlobNoChange = touchFile root ("dir" "good-b") updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () () (res, files) <- expectMonitorUnchanged root monitor () - res @?= () + res @?= () files @?= [monitorFileGlobStr "dir/good-*"] testGlobAddMatch :: Int -> Assertion @@ -457,7 +468,7 @@ testGlobAddMatch mtimeChange = touchFile root ("dir" "good-a") updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () () (res, files) <- expectMonitorUnchanged root monitor () - res @?= () + res @?= () files @?= [monitorFileGlobStr "dir/good-*"] threadDelay mtimeChange touchFile root ("dir" "good-b") @@ -484,7 +495,7 @@ testGlobChangeMatch mtimeChange = threadDelay mtimeChange touchFile root ("dir" "good-b") (res, files) <- expectMonitorUnchanged root monitor () - res @?= () + res @?= () files @?= [monitorFileGlobStr "dir/good-*"] touchFileContent root ("dir" "good-b") @@ -521,7 +532,7 @@ testGlobChangeMatchSubdir mtimeChange = threadDelay mtimeChange touchFile root ("dir" "b" "good-b") (res, files) <- expectMonitorUnchanged root monitor () - res @?= () + res @?= () files @?= [monitorFileGlobStr "dir/*/good-*"] touchFileContent root "dir/b/good-b" @@ -546,7 +557,7 @@ testGlobAddNonMatch mtimeChange = threadDelay mtimeChange touchFile root ("dir" "bad") (res, files) <- expectMonitorUnchanged root monitor () - res @?= () + res @?= () files @?= [monitorFileGlobStr "dir/good-*"] testGlobRemoveNonMatch :: Int -> Assertion @@ -558,7 +569,7 @@ testGlobRemoveNonMatch mtimeChange = threadDelay mtimeChange removeFile root "dir/bad" (res, files) <- expectMonitorUnchanged root monitor () - res @?= () + res @?= () files @?= [monitorFileGlobStr "dir/good-*"] testGlobAddNonMatchSubdir :: Int -> Assertion @@ -569,7 +580,7 @@ testGlobAddNonMatchSubdir mtimeChange = threadDelay mtimeChange touchFile root ("dir" "b" "bad") (res, files) <- expectMonitorUnchanged root monitor () - res @?= () + res @?= () files @?= [monitorFileGlobStr "dir/*/good-*"] testGlobRemoveNonMatchSubdir :: Int -> Assertion @@ -581,10 +592,9 @@ testGlobRemoveNonMatchSubdir mtimeChange = threadDelay mtimeChange removeDir root ("dir" "b") (res, files) <- expectMonitorUnchanged root monitor () - res @?= () + res @?= () files @?= [monitorFileGlobStr "dir/*/good-*"] - -- try and tickle a bug that happens if we don't maintain the invariant that -- MonitorStateGlobFiles entries are sorted testInvariantMonitorStateGlobFiles :: Int -> Assertion @@ -609,7 +619,7 @@ testInvariantMonitorStateGlobFiles mtimeChange = touchFile root ("dir" "b") touchFile root ("dir" "a") (res, files) <- expectMonitorUnchanged root monitor () - res @?= () + res @?= () files @?= [monitorFileGlobStr "dir/*"] -- same thing for the subdirs case @@ -631,7 +641,7 @@ testInvariantMonitorStateGlobDirs mtimeChange = touchFile root ("dir" "b" "file") touchFile root ("dir" "a" "file") (res, files) <- expectMonitorUnchanged root monitor () - res @?= () + res @?= () files @?= [monitorFileGlobStr "dir/*/file"] -- ensure that a glob can match a directory as well as a file @@ -643,7 +653,7 @@ testGlobMatchDir mtimeChange = threadDelay mtimeChange -- nothing changed yet (res, files) <- expectMonitorUnchanged root monitor () - res @?= () + res @?= () files @?= [monitorFileGlobStr "dir/*"] -- expect dir/b to match and be detected as changed createDir root ("dir" "b") @@ -664,7 +674,7 @@ testGlobMatchDirOnly mtimeChange = -- expect file dir/a to not match, so not detected as changed touchFile root ("dir" "a") (res, files) <- expectMonitorUnchanged root monitor () - res @?= () + res @?= () files @?= [monitorFileGlobStr "dir/*/"] -- note that checking the file monitor for changes can updates the -- cached dir mtimes (when it has to record that there's new matches) @@ -683,7 +693,7 @@ testGlobChangeFileType mtimeChange = updateMonitor root monitor [monitorFileGlobStr "dir/*"] () () threadDelay mtimeChange removeFile root ("dir" "a") - createDir root ("dir" "a") + createDir root ("dir" "a") reason <- expectMonitorChanged root monitor () reason @?= MonitoredFileChanged ("dir" "a") -- change dir to file @@ -719,7 +729,6 @@ testGlobAbsolutePath mtimeChange = reason3 <- expectMonitorChanged root monitor () reason3 @?= MonitoredFileChanged (root' "dir" "good-b") - ------------------ -- value changes -- @@ -730,7 +739,7 @@ testValueUnchanged = touchFile root "a" updateMonitor root monitor [monitorFile "a"] (42 :: Int) "ok" (res, files) <- expectMonitorUnchanged root monitor 42 - res @?= "ok" + res @?= "ok" files @?= [monitorFile "a"] testValueChanged :: Assertion @@ -756,7 +765,7 @@ testValueAndFileChanged mtimeChange = -- if fileMonitorCheckIfOnlyValueChanged then if only the value changed -- then it's reported as MonitoredValueChanged let monitor' :: FileMonitor Int String - monitor' = monitor { fileMonitorCheckIfOnlyValueChanged = True } + monitor' = monitor{fileMonitorCheckIfOnlyValueChanged = True} updateMonitor root monitor' [monitorFile "a"] 42 "ok" reason2 <- expectMonitorChanged root monitor' 43 reason2 @?= MonitoredValueChanged 42 @@ -774,18 +783,18 @@ testValueUpdated = touchFile root "a" let monitor' :: FileMonitor (Set.Set Int) String - monitor' = (monitor :: FileMonitor (Set.Set Int) String) { - fileMonitorCheckIfOnlyValueChanged = True, - fileMonitorKeyValid = Set.isSubsetOf - } - - updateMonitor root monitor' [monitorFile "a"] (Set.fromList [42,43]) "ok" - (res,_files) <- expectMonitorUnchanged root monitor' (Set.fromList [42]) + monitor' = + (monitor :: FileMonitor (Set.Set Int) String) + { fileMonitorCheckIfOnlyValueChanged = True + , fileMonitorKeyValid = Set.isSubsetOf + } + + updateMonitor root monitor' [monitorFile "a"] (Set.fromList [42, 43]) "ok" + (res, _files) <- expectMonitorUnchanged root monitor' (Set.fromList [42]) res @?= "ok" - reason <- expectMonitorChanged root monitor' (Set.fromList [42,44]) - reason @?= MonitoredValueChanged (Set.fromList [42,43]) - + reason <- expectMonitorChanged root monitor' (Set.fromList [42, 44]) + reason @?= MonitoredValueChanged (Set.fromList [42, 43]) ------------- -- Utils @@ -810,7 +819,7 @@ removeFile (RootPath root) fname = IO.removeFile (root fname) touchDir :: RootPath -> FilePath -> IO () touchDir root@(RootPath rootdir) dname = do IO.createDirectoryIfMissing True (rootdir dname) - touchFile root (dname "touch") + touchFile root (dname "touch") removeFile root (dname "touch") createDir :: RootPath -> FilePath -> IO () @@ -828,49 +837,68 @@ absoluteRoot (RootPath root) = IO.canonicalizePath root monitorFileGlobStr :: String -> MonitorFilePath monitorFileGlobStr globstr | Just glob <- simpleParsec globstr = monitorFileGlob glob - | otherwise = error $ "Failed to parse " ++ globstr - - -expectMonitorChanged :: (Binary a, Structured a, Binary b, Structured b) - => RootPath -> FileMonitor a b -> a - -> IO (MonitorChangedReason a) + | otherwise = error $ "Failed to parse " ++ globstr + +expectMonitorChanged + :: (Binary a, Structured a, Binary b, Structured b) + => RootPath + -> FileMonitor a b + -> a + -> IO (MonitorChangedReason a) expectMonitorChanged root monitor key = do res <- checkChanged root monitor key case res of MonitorChanged reason -> return reason - MonitorUnchanged _ _ -> throwIO $ HUnitFailure Nothing "expected change" - -expectMonitorUnchanged :: (Binary a, Structured a, Binary b, Structured b) - => RootPath -> FileMonitor a b -> a - -> IO (b, [MonitorFilePath]) + MonitorUnchanged _ _ -> throwIO $ HUnitFailure Nothing "expected change" + +expectMonitorUnchanged + :: (Binary a, Structured a, Binary b, Structured b) + => RootPath + -> FileMonitor a b + -> a + -> IO (b, [MonitorFilePath]) expectMonitorUnchanged root monitor key = do res <- checkChanged root monitor key case res of - MonitorChanged _reason -> throwIO $ HUnitFailure Nothing "expected no change" + MonitorChanged _reason -> throwIO $ HUnitFailure Nothing "expected no change" MonitorUnchanged b files -> return (b, files) -checkChanged :: (Binary a, Structured a, Binary b, Structured b) - => RootPath -> FileMonitor a b - -> a -> IO (MonitorChanged a b) +checkChanged + :: (Binary a, Structured a, Binary b, Structured b) + => RootPath + -> FileMonitor a b + -> a + -> IO (MonitorChanged a b) checkChanged (RootPath root) monitor key = checkFileMonitorChanged monitor root key -updateMonitor :: (Binary a, Structured a, Binary b, Structured b) - => RootPath -> FileMonitor a b - -> [MonitorFilePath] -> a -> b -> IO () +updateMonitor + :: (Binary a, Structured a, Binary b, Structured b) + => RootPath + -> FileMonitor a b + -> [MonitorFilePath] + -> a + -> b + -> IO () updateMonitor (RootPath root) monitor files key result = updateFileMonitor monitor root Nothing files key result -updateMonitorWithTimestamp :: (Binary a, Structured a, Binary b, Structured b) - => RootPath -> FileMonitor a b -> MonitorTimestamp - -> [MonitorFilePath] -> a -> b -> IO () +updateMonitorWithTimestamp + :: (Binary a, Structured a, Binary b, Structured b) + => RootPath + -> FileMonitor a b + -> MonitorTimestamp + -> [MonitorFilePath] + -> a + -> b + -> IO () updateMonitorWithTimestamp (RootPath root) monitor timestamp files key result = updateFileMonitor monitor root (Just timestamp) files key result withFileMonitor :: Eq a => (RootPath -> FileMonitor a b -> IO c) -> IO c withFileMonitor action = do withTempDirectory silent "." "file-status-" $ \root -> do - let file = root <.> "monitor" + let file = root <.> "monitor" monitor = newFileMonitor file finally (action (RootPath root) monitor) $ do exists <- IO.doesFileExist file diff --git a/cabal-install/tests/UnitTests/Distribution/Client/GZipUtils.hs b/cabal-install/tests/UnitTests/Distribution/Client/GZipUtils.hs index f2ddce463a3..1ba189fe16a 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/GZipUtils.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/GZipUtils.hs @@ -1,40 +1,41 @@ -module UnitTests.Distribution.Client.GZipUtils ( - tests +module UnitTests.Distribution.Client.GZipUtils + ( tests ) where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () -import Codec.Compression.GZip as GZip -import Codec.Compression.Zlib as Zlib -import Control.Exception (try) -import Data.ByteString as BS (null) -import Data.ByteString.Lazy as BSL (pack, toChunks) -import Data.ByteString.Lazy.Char8 as BSLL (pack, init, length) -import Distribution.Client.GZipUtils (maybeDecompress) +import Codec.Compression.GZip as GZip +import Codec.Compression.Zlib as Zlib +import Control.Exception (try) +import Data.ByteString as BS (null) +import Data.ByteString.Lazy as BSL (pack, toChunks) +import Data.ByteString.Lazy.Char8 as BSLL (init, length, pack) +import Distribution.Client.GZipUtils (maybeDecompress) import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck tests :: [TestTree] -tests = [ testCase "maybeDecompress" maybeDecompressUnitTest - -- "decompress plain" property is non-trivial to state, - -- maybeDecompress returns input bytestring only if error occurs right at the beginning of the decompression process - -- generating such input would essentially duplicate maybeDecompress implementation - , testProperty "decompress zlib" prop_maybeDecompress_zlib - , testProperty "decompress gzip" prop_maybeDecompress_gzip - ] +tests = + [ testCase "maybeDecompress" maybeDecompressUnitTest + , -- "decompress plain" property is non-trivial to state, + -- maybeDecompress returns input bytestring only if error occurs right at the beginning of the decompression process + -- generating such input would essentially duplicate maybeDecompress implementation + testProperty "decompress zlib" prop_maybeDecompress_zlib + , testProperty "decompress gzip" prop_maybeDecompress_gzip + ] maybeDecompressUnitTest :: Assertion maybeDecompressUnitTest = - assertBool "decompress plain" (maybeDecompress original == original) - >> assertBool "decompress zlib (with show)" (show (maybeDecompress compressedZlib) == show original) - >> assertBool "decompress gzip (with show)" (show (maybeDecompress compressedGZip) == show original) - >> assertBool "decompress zlib" (maybeDecompress compressedZlib == original) - >> assertBool "decompress gzip" (maybeDecompress compressedGZip == original) - >> assertBool "have no empty chunks" (all (not . BS.null) . BSL.toChunks . maybeDecompress $ compressedZlib) - >> (runBrokenStream >>= assertBool "decompress broken stream" . isLeft) + assertBool "decompress plain" (maybeDecompress original == original) + >> assertBool "decompress zlib (with show)" (show (maybeDecompress compressedZlib) == show original) + >> assertBool "decompress gzip (with show)" (show (maybeDecompress compressedGZip) == show original) + >> assertBool "decompress zlib" (maybeDecompress compressedZlib == original) + >> assertBool "decompress gzip" (maybeDecompress compressedGZip == original) + >> assertBool "have no empty chunks" (all (not . BS.null) . BSL.toChunks . maybeDecompress $ compressedZlib) + >> (runBrokenStream >>= assertBool "decompress broken stream" . isLeft) where original = BSLL.pack "original uncompressed input" compressedZlib = Zlib.compress original @@ -45,13 +46,15 @@ maybeDecompressUnitTest = prop_maybeDecompress_zlib :: [Word8] -> Property prop_maybeDecompress_zlib ws = property $ maybeDecompress compressedZlib === original - where original = BSL.pack ws - compressedZlib = Zlib.compress original + where + original = BSL.pack ws + compressedZlib = Zlib.compress original prop_maybeDecompress_gzip :: [Word8] -> Property prop_maybeDecompress_gzip ws = property $ maybeDecompress compressedGZip === original - where original = BSL.pack ws - compressedGZip = GZip.compress original + where + original = BSL.pack ws + compressedGZip = GZip.compress original -- (Only available from "Data.Either" since 7.8.) isLeft :: Either a b -> Bool diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Get.hs b/cabal-install/tests/UnitTests/Distribution/Client/Get.hs index e5527a63647..11b073d2ebf 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Get.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Get.hs @@ -1,21 +1,23 @@ -{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + module UnitTests.Distribution.Client.Get (tests) where import Distribution.Client.Get +import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage (..)) import Distribution.Types.PackageId import Distribution.Types.PackageName -import Distribution.Types.SourceRepo (SourceRepo (..), emptySourceRepo, RepoKind (..), RepoType (..), KnownRepoType (..)) -import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage (..)) +import Distribution.Types.SourceRepo (KnownRepoType (..), RepoKind (..), RepoType (..), SourceRepo (..), emptySourceRepo) import Distribution.Verbosity as Verbosity import Distribution.Version -import Control.Monad import Control.Exception +import Control.Monad import Data.Typeable -import System.FilePath import System.Directory import System.Exit +import System.FilePath import System.IO.Error import Test.Tasty @@ -23,230 +25,253 @@ import Test.Tasty.HUnit import UnitTests.Options (RunNetworkTests (..)) import UnitTests.TempTestDir (withTestDir) - tests :: [TestTree] tests = - [ testGroup "forkPackages" - [ testCase "no repos" testNoRepos - , testCase "no repos of requested kind" testNoReposOfKind - , testCase "no repo type specified" testNoRepoType - , testCase "unsupported repo type" testUnsupportedRepoType - , testCase "no repo location specified" testNoRepoLocation - , testCase "correct repo kind selection" testSelectRepoKind - , testCase "repo destination exists" testRepoDestinationExists - , testCase "git fetch failure" testGitFetchFailed - ] + [ testGroup + "forkPackages" + [ testCase "no repos" testNoRepos + , testCase "no repos of requested kind" testNoReposOfKind + , testCase "no repo type specified" testNoRepoType + , testCase "unsupported repo type" testUnsupportedRepoType + , testCase "no repo location specified" testNoRepoLocation + , testCase "correct repo kind selection" testSelectRepoKind + , testCase "repo destination exists" testRepoDestinationExists + , testCase "git fetch failure" testGitFetchFailed + ] , askOption $ \(RunNetworkTests doRunNetTests) -> - testGroup "forkPackages, network tests" $ - includeTestsIf doRunNetTests $ - [ testCase "git clone" testNetworkGitClone - ] + testGroup "forkPackages, network tests" $ + includeTestsIf doRunNetTests $ + [ testCase "git clone" testNetworkGitClone + ] ] where includeTestsIf True xs = xs includeTestsIf False _ = [] - - verbosity :: Verbosity verbosity = Verbosity.silent -- for debugging try verbose pkgidfoo :: PackageId -pkgidfoo = PackageIdentifier (mkPackageName "foo") (mkVersion [1,0]) - +pkgidfoo = PackageIdentifier (mkPackageName "foo") (mkVersion [1, 0]) -- ------------------------------------------------------------ + -- * Unit tests + -- ------------------------------------------------------------ testNoRepos :: Assertion testNoRepos = do - e <- assertException $ - clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos - e @?= ClonePackageNoSourceRepos pkgidfoo + e <- + assertException $ + clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos + e @?= ClonePackageNoSourceRepos pkgidfoo where pkgrepos = [(pkgidfoo, [])] - testNoReposOfKind :: Assertion testNoReposOfKind = do - e <- assertException $ - clonePackagesFromSourceRepo verbosity "." repokind pkgrepos - e @?= ClonePackageNoSourceReposOfKind pkgidfoo repokind + e <- + assertException $ + clonePackagesFromSourceRepo verbosity "." repokind pkgrepos + e @?= ClonePackageNoSourceReposOfKind pkgidfoo repokind where pkgrepos = [(pkgidfoo, [repo])] - repo = emptySourceRepo RepoHead + repo = emptySourceRepo RepoHead repokind = Just RepoThis - testNoRepoType :: Assertion testNoRepoType = do - e <- assertException $ - clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos - e @?= ClonePackageNoRepoType pkgidfoo repo + e <- + assertException $ + clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos + e @?= ClonePackageNoRepoType pkgidfoo repo where pkgrepos = [(pkgidfoo, [repo])] - repo = emptySourceRepo RepoHead - + repo = emptySourceRepo RepoHead testUnsupportedRepoType :: Assertion testUnsupportedRepoType = do - e <- assertException $ - clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos - e @?= ClonePackageUnsupportedRepoType pkgidfoo repo' repotype + e <- + assertException $ + clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos + e @?= ClonePackageUnsupportedRepoType pkgidfoo repo' repotype where pkgrepos = [(pkgidfoo, [repo])] - repo = (emptySourceRepo RepoHead) - { repoType = Just repotype - , repoLocation = Just "loc" - } - repo' = SourceRepositoryPackage - { srpType = repotype - , srpLocation = "loc" - , srpTag = Nothing - , srpBranch = Nothing - , srpSubdir = Proxy - , srpCommand = [] - } + repo = + (emptySourceRepo RepoHead) + { repoType = Just repotype + , repoLocation = Just "loc" + } + repo' = + SourceRepositoryPackage + { srpType = repotype + , srpLocation = "loc" + , srpTag = Nothing + , srpBranch = Nothing + , srpSubdir = Proxy + , srpCommand = [] + } repotype = OtherRepoType "baz" - testNoRepoLocation :: Assertion testNoRepoLocation = do - e <- assertException $ - clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos - e @?= ClonePackageNoRepoLocation pkgidfoo repo + e <- + assertException $ + clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos + e @?= ClonePackageNoRepoLocation pkgidfoo repo where pkgrepos = [(pkgidfoo, [repo])] - repo = (emptySourceRepo RepoHead) { - repoType = Just repotype - } + repo = + (emptySourceRepo RepoHead) + { repoType = Just repotype + } repotype = KnownRepoType Darcs - testSelectRepoKind :: Assertion testSelectRepoKind = - sequence_ - [ do e <- test requestedRepoType pkgrepos - e @?= ClonePackageNoRepoType pkgidfoo expectedRepo - - e' <- test requestedRepoType (reverse pkgrepos) - e' @?= ClonePackageNoRepoType pkgidfoo expectedRepo - | let test rt rs = assertException $ - clonePackagesFromSourceRepo verbosity "." rt rs - , (requestedRepoType, expectedRepo) <- cases - ] + sequence_ + [ do + e <- test requestedRepoType pkgrepos + e @?= ClonePackageNoRepoType pkgidfoo expectedRepo + + e' <- test requestedRepoType (reverse pkgrepos) + e' @?= ClonePackageNoRepoType pkgidfoo expectedRepo + | let test rt rs = + assertException $ + clonePackagesFromSourceRepo verbosity "." rt rs + , (requestedRepoType, expectedRepo) <- cases + ] where pkgrepos = [(pkgidfoo, [repo1, repo2, repo3])] - repo1 = emptySourceRepo RepoThis - repo2 = emptySourceRepo RepoHead - repo3 = emptySourceRepo (RepoKindUnknown "bar") - cases = [ (Nothing, repo1) - , (Just RepoThis, repo1) - , (Just RepoHead, repo2) - , (Just (RepoKindUnknown "bar"), repo3) - ] - + repo1 = emptySourceRepo RepoThis + repo2 = emptySourceRepo RepoHead + repo3 = emptySourceRepo (RepoKindUnknown "bar") + cases = + [ (Nothing, repo1) + , (Just RepoThis, repo1) + , (Just RepoHead, repo2) + , (Just (RepoKindUnknown "bar"), repo3) + ] testRepoDestinationExists :: Assertion testRepoDestinationExists = - withTestDir verbosity "repos" $ \tmpdir -> do - let pkgdir = tmpdir "foo" - createDirectory pkgdir - e1 <- assertException $ - clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos - e1 @?= ClonePackageDestinationExists pkgidfoo pkgdir True {- isdir -} - - removeDirectory pkgdir - - writeFile pkgdir "" - e2 <- assertException $ - clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos - e2 @?= ClonePackageDestinationExists pkgidfoo pkgdir False {- isfile -} + withTestDir verbosity "repos" $ \tmpdir -> do + let pkgdir = tmpdir "foo" + createDirectory pkgdir + e1 <- + assertException $ + clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos + e1 @?= ClonePackageDestinationExists pkgidfoo pkgdir True {- isdir -} + removeDirectory pkgdir + + writeFile pkgdir "" + e2 <- + assertException $ + clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos + e2 @?= ClonePackageDestinationExists pkgidfoo pkgdir False {- isfile -} where pkgrepos = [(pkgidfoo, [repo])] - repo = (emptySourceRepo RepoHead) { - repoType = Just (KnownRepoType Darcs), - repoLocation = Just "" - } - + repo = + (emptySourceRepo RepoHead) + { repoType = Just (KnownRepoType Darcs) + , repoLocation = Just "" + } testGitFetchFailed :: Assertion testGitFetchFailed = - withTestDir verbosity "repos" $ \tmpdir -> do - let srcdir = tmpdir "src" - repo = (emptySourceRepo RepoHead) { - repoType = Just (KnownRepoType Git), - repoLocation = Just srcdir - } - repo' = SourceRepositoryPackage - { srpType = KnownRepoType Git - , srpLocation = srcdir - , srpTag = Nothing - , srpBranch = Nothing - , srpSubdir = Proxy - , srpCommand = [] - } - pkgrepos = [(pkgidfoo, [repo])] - e1 <- assertException $ - clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos - e1 @?= ClonePackageFailedWithExitCode pkgidfoo repo' "git" (ExitFailure 128) - + withTestDir verbosity "repos" $ \tmpdir -> do + let srcdir = tmpdir "src" + repo = + (emptySourceRepo RepoHead) + { repoType = Just (KnownRepoType Git) + , repoLocation = Just srcdir + } + repo' = + SourceRepositoryPackage + { srpType = KnownRepoType Git + , srpLocation = srcdir + , srpTag = Nothing + , srpBranch = Nothing + , srpSubdir = Proxy + , srpCommand = [] + } + pkgrepos = [(pkgidfoo, [repo])] + e1 <- + assertException $ + clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos + e1 @?= ClonePackageFailedWithExitCode pkgidfoo repo' "git" (ExitFailure 128) testNetworkGitClone :: Assertion testNetworkGitClone = - withTestDir verbosity "repos" $ \tmpdir -> do - let repo1 = (emptySourceRepo RepoHead) { - repoType = Just (KnownRepoType Git), - repoLocation = Just "https://github.com/haskell/zlib.git" - } - clonePackagesFromSourceRepo verbosity tmpdir Nothing - [(mkpkgid "zlib1", [repo1])] - assertFileContains (tmpdir "zlib1/zlib.cabal") ["name:", "zlib"] - - let repo2 = (emptySourceRepo RepoHead) { - repoType = Just (KnownRepoType Git), - repoLocation = Just (tmpdir "zlib1") - } - clonePackagesFromSourceRepo verbosity tmpdir Nothing - [(mkpkgid "zlib2", [repo2])] - assertFileContains (tmpdir "zlib2/zlib.cabal") ["name:", "zlib"] - - let repo3 = (emptySourceRepo RepoHead) { - repoType = Just (KnownRepoType Git), - repoLocation = Just (tmpdir "zlib1"), - repoTag = Just "0.5.0.0" - } - clonePackagesFromSourceRepo verbosity tmpdir Nothing - [(mkpkgid "zlib3", [repo3])] - assertFileContains (tmpdir "zlib3/zlib.cabal") ["version:", "0.5.0.0"] + withTestDir verbosity "repos" $ \tmpdir -> do + let repo1 = + (emptySourceRepo RepoHead) + { repoType = Just (KnownRepoType Git) + , repoLocation = Just "https://github.com/haskell/zlib.git" + } + clonePackagesFromSourceRepo + verbosity + tmpdir + Nothing + [(mkpkgid "zlib1", [repo1])] + assertFileContains (tmpdir "zlib1/zlib.cabal") ["name:", "zlib"] + + let repo2 = + (emptySourceRepo RepoHead) + { repoType = Just (KnownRepoType Git) + , repoLocation = Just (tmpdir "zlib1") + } + clonePackagesFromSourceRepo + verbosity + tmpdir + Nothing + [(mkpkgid "zlib2", [repo2])] + assertFileContains (tmpdir "zlib2/zlib.cabal") ["name:", "zlib"] + + let repo3 = + (emptySourceRepo RepoHead) + { repoType = Just (KnownRepoType Git) + , repoLocation = Just (tmpdir "zlib1") + , repoTag = Just "0.5.0.0" + } + clonePackagesFromSourceRepo + verbosity + tmpdir + Nothing + [(mkpkgid "zlib3", [repo3])] + assertFileContains (tmpdir "zlib3/zlib.cabal") ["version:", "0.5.0.0"] where mkpkgid nm = PackageIdentifier (mkPackageName nm) (mkVersion []) - -- ------------------------------------------------------------ + -- * HUnit utils + -- ------------------------------------------------------------ assertException :: forall e a. (Exception e, HasCallStack) => IO a -> IO e assertException action = do - r <- try action - case r of - Left e -> return e - Right _ -> assertFailure $ "expected exception of type " - ++ show (typeOf (undefined :: e)) - + r <- try action + case r of + Left e -> return e + Right _ -> + assertFailure $ + "expected exception of type " + ++ show (typeOf (undefined :: e)) -- | Expect that one line in a file matches exactly the given words (i.e. at -- least insensitive to whitespace) --- assertFileContains :: HasCallStack => FilePath -> [String] -> Assertion assertFileContains file expected = do - c <- readFile file `catch` \e -> - if isDoesNotExistError e - then assertFailure $ "expected a file to exist: " ++ file - else throwIO e - unless (expected `elem` map words (lines c)) $ - assertFailure $ "expected the file " ++ file ++ " to contain " - ++ show (take 100 expected) - + c <- + readFile file `catch` \e -> + if isDoesNotExistError e + then assertFailure $ "expected a file to exist: " ++ file + else throwIO e + unless (expected `elem` map words (lines c)) $ + assertFailure $ + "expected the file " + ++ file + ++ " to contain " + ++ show (take 100 expected) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs b/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs index 427516e332d..8d77b6784ef 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs @@ -10,85 +10,118 @@ import Distribution.Client.Glob import Distribution.Utils.Structured (structureHash) import UnitTests.Distribution.Client.ArbitraryInstances () +import GHC.Fingerprint (Fingerprint (..)) import Test.Tasty -import Test.Tasty.QuickCheck import Test.Tasty.HUnit -import GHC.Fingerprint (Fingerprint (..)) +import Test.Tasty.QuickCheck tests :: [TestTree] tests = [ testProperty "print/parse roundtrip" prop_roundtrip_printparse - , testCase "parse examples" testParseCases - , testGroup "Structured hashes" - [ testCase "GlobPiece" $ structureHash (Proxy :: Proxy GlobPiece) @?= Fingerprint 0xd5e5361866a30ea2 0x31fbfe7b58864782 - , testCase "FilePathGlobRel" $ structureHash (Proxy :: Proxy FilePathGlobRel) @?= Fingerprint 0x76fa5bcb865a8501 0xb152f68915316f98 - , testCase "FilePathRoot" $ structureHash (Proxy :: Proxy FilePathRoot) @?= Fingerprint 0x713373d51426ec64 0xda7376a38ecee5a5 - , testCase "FilePathGlob" $ structureHash (Proxy :: Proxy FilePathGlob) @?= Fingerprint 0x3c11c41f3f03a1f0 0x96e69d85c37d0024 - ] + , testCase "parse examples" testParseCases + , testGroup + "Structured hashes" + [ testCase "GlobPiece" $ structureHash (Proxy :: Proxy GlobPiece) @?= Fingerprint 0xd5e5361866a30ea2 0x31fbfe7b58864782 + , testCase "FilePathGlobRel" $ structureHash (Proxy :: Proxy FilePathGlobRel) @?= Fingerprint 0x76fa5bcb865a8501 0xb152f68915316f98 + , testCase "FilePathRoot" $ structureHash (Proxy :: Proxy FilePathRoot) @?= Fingerprint 0x713373d51426ec64 0xda7376a38ecee5a5 + , testCase "FilePathGlob" $ structureHash (Proxy :: Proxy FilePathGlob) @?= Fingerprint 0x3c11c41f3f03a1f0 0x96e69d85c37d0024 + ] ] ---TODO: [nice to have] tests for trivial globs, tests for matching, +-- TODO: [nice to have] tests for trivial globs, tests for matching, -- tests for windows style file paths prop_roundtrip_printparse :: FilePathGlob -> Property prop_roundtrip_printparse pathglob = - counterexample (prettyShow pathglob) $ + counterexample (prettyShow pathglob) $ eitherParsec (prettyShow pathglob) === Right pathglob -- first run, where we don't even call updateMonitor testParseCases :: Assertion testParseCases = do - FilePathGlob (FilePathRoot "/") GlobDirTrailing <- testparse "/" - FilePathGlob FilePathHomeDir GlobDirTrailing <- testparse "~/" + FilePathGlob FilePathHomeDir GlobDirTrailing <- testparse "~/" FilePathGlob (FilePathRoot "A:\\") GlobDirTrailing <- testparse "A:/" FilePathGlob (FilePathRoot "Z:\\") GlobDirTrailing <- testparse "z:/" FilePathGlob (FilePathRoot "C:\\") GlobDirTrailing <- testparse "C:\\" FilePathGlob FilePathRelative (GlobFile [Literal "_:"]) <- testparse "_:" - FilePathGlob FilePathRelative - (GlobFile [Literal "."]) <- testparse "." - - FilePathGlob FilePathRelative - (GlobFile [Literal "~"]) <- testparse "~" - - FilePathGlob FilePathRelative - (GlobDir [Literal "."] GlobDirTrailing) <- testparse "./" - - FilePathGlob FilePathRelative - (GlobFile [Literal "foo"]) <- testparse "foo" - - FilePathGlob FilePathRelative - (GlobDir [Literal "foo"] - (GlobFile [Literal "bar"])) <- testparse "foo/bar" - - FilePathGlob FilePathRelative - (GlobDir [Literal "foo"] - (GlobDir [Literal "bar"] GlobDirTrailing)) <- testparse "foo/bar/" - - FilePathGlob (FilePathRoot "/") - (GlobDir [Literal "foo"] - (GlobDir [Literal "bar"] GlobDirTrailing)) <- testparse "/foo/bar/" - - FilePathGlob (FilePathRoot "C:\\") - (GlobDir [Literal "foo"] - (GlobDir [Literal "bar"] GlobDirTrailing)) <- testparse "C:\\foo\\bar\\" - - FilePathGlob FilePathRelative - (GlobFile [WildCard]) <- testparse "*" - - FilePathGlob FilePathRelative - (GlobFile [WildCard,WildCard]) <- testparse "**" -- not helpful but valid - - FilePathGlob FilePathRelative - (GlobFile [WildCard, Literal "foo", WildCard]) <- testparse "*foo*" - - FilePathGlob FilePathRelative - (GlobFile [Literal "foo", WildCard, Literal "bar"]) <- testparse "foo*bar" - - FilePathGlob FilePathRelative - (GlobFile [Union [[WildCard], [Literal "foo"]]]) <- testparse "{*,foo}" + FilePathGlob + FilePathRelative + (GlobFile [Literal "."]) <- + testparse "." + + FilePathGlob + FilePathRelative + (GlobFile [Literal "~"]) <- + testparse "~" + + FilePathGlob + FilePathRelative + (GlobDir [Literal "."] GlobDirTrailing) <- + testparse "./" + + FilePathGlob + FilePathRelative + (GlobFile [Literal "foo"]) <- + testparse "foo" + + FilePathGlob + FilePathRelative + ( GlobDir + [Literal "foo"] + (GlobFile [Literal "bar"]) + ) <- + testparse "foo/bar" + + FilePathGlob + FilePathRelative + ( GlobDir + [Literal "foo"] + (GlobDir [Literal "bar"] GlobDirTrailing) + ) <- + testparse "foo/bar/" + + FilePathGlob + (FilePathRoot "/") + ( GlobDir + [Literal "foo"] + (GlobDir [Literal "bar"] GlobDirTrailing) + ) <- + testparse "/foo/bar/" + + FilePathGlob + (FilePathRoot "C:\\") + ( GlobDir + [Literal "foo"] + (GlobDir [Literal "bar"] GlobDirTrailing) + ) <- + testparse "C:\\foo\\bar\\" + + FilePathGlob + FilePathRelative + (GlobFile [WildCard]) <- + testparse "*" + + FilePathGlob + FilePathRelative + (GlobFile [WildCard, WildCard]) <- + testparse "**" -- not helpful but valid + FilePathGlob + FilePathRelative + (GlobFile [WildCard, Literal "foo", WildCard]) <- + testparse "*foo*" + + FilePathGlob + FilePathRelative + (GlobFile [Literal "foo", WildCard, Literal "bar"]) <- + testparse "foo*bar" + + FilePathGlob + FilePathRelative + (GlobFile [Union [[WildCard], [Literal "foo"]]]) <- + testparse "{*,foo}" parseFail "{" parseFail "}" @@ -104,12 +137,12 @@ testParseCases = do testparse :: String -> IO FilePathGlob testparse s = - case eitherParsec s of - Right p -> return p - Left err -> throwIO $ HUnitFailure Nothing ("expected parse of: " ++ s ++ " -- " ++ err) + case eitherParsec s of + Right p -> return p + Left err -> throwIO $ HUnitFailure Nothing ("expected parse of: " ++ s ++ " -- " ++ err) parseFail :: String -> Assertion parseFail s = - case eitherParsec s :: Either String FilePathGlob of - Right p -> throwIO $ HUnitFailure Nothing ("expected no parse of: " ++ s ++ " -- " ++ show p) - Left _ -> return () + case eitherParsec s :: Either String FilePathGlob of + Right p -> throwIO $ HUnitFailure Nothing ("expected no parse of: " ++ s ++ " -- " ++ show p) + Left _ -> return () diff --git a/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils.hs b/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils.hs index 52369cbc4a4..fbd5952019a 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils.hs @@ -3,77 +3,80 @@ module UnitTests.Distribution.Client.IndexUtils where import Distribution.Client.IndexUtils import qualified Distribution.Compat.NonEmptySet as NES import Distribution.Simple.Utils (toUTF8LBS) -import Distribution.Version import Distribution.Types.Dependency -import Distribution.Types.PackageName import Distribution.Types.LibraryName - +import Distribution.Types.PackageName +import Distribution.Version import Test.Tasty import Test.Tasty.HUnit tests :: [TestTree] tests = - [ simpleVersionsParserTests - ] + [ simpleVersionsParserTests + ] simpleVersionsParserTests :: TestTree -simpleVersionsParserTests = testGroup "Simple preferred-versions Parser Tests" +simpleVersionsParserTests = + testGroup + "Simple preferred-versions Parser Tests" [ testCase "simple deprecation dependency" $ do let prefs = parsePreferredVersionsWarnings (toUTF8LBS "binary < 0.9.0.0 || > 0.9.0.0") - prefs @?= - [ Right - (Dependency - (mkPackageName "binary") - (unionVersionRanges - (earlierVersion $ mkVersion [0,9,0,0]) - (laterVersion $ mkVersion [0,9,0,0]) - ) - (NES.singleton LMainLibName) - ) - ] + prefs + @?= [ Right + ( Dependency + (mkPackageName "binary") + ( unionVersionRanges + (earlierVersion $ mkVersion [0, 9, 0, 0]) + (laterVersion $ mkVersion [0, 9, 0, 0]) + ) + (NES.singleton LMainLibName) + ) + ] , testCase "multiple deprecation dependency" $ do let prefs = parsePreferredVersionsWarnings (toUTF8LBS "binary < 0.9.0.0 || > 0.9.0.0\ncontainers == 0.6.4.1") - prefs @?= - [ Right - (Dependency - (mkPackageName "binary") - (unionVersionRanges - (earlierVersion $ mkVersion [0,9,0,0]) - (laterVersion $ mkVersion [0,9,0,0]) - ) - (NES.singleton LMainLibName) - ) - , Right - (Dependency - (mkPackageName "containers") - (thisVersion $ mkVersion [0,6,4,1]) - (NES.singleton LMainLibName) - ) - ] + prefs + @?= [ Right + ( Dependency + (mkPackageName "binary") + ( unionVersionRanges + (earlierVersion $ mkVersion [0, 9, 0, 0]) + (laterVersion $ mkVersion [0, 9, 0, 0]) + ) + (NES.singleton LMainLibName) + ) + , Right + ( Dependency + (mkPackageName "containers") + (thisVersion $ mkVersion [0, 6, 4, 1]) + (NES.singleton LMainLibName) + ) + ] , testCase "unparsable dependency" $ do let prefs = parsePreferredVersionsWarnings (toUTF8LBS "binary 0.9.0.0 || > 0.9.0.0") - prefs @?= - [ Left binaryDepParseError - ] + prefs + @?= [ Left binaryDepParseError + ] , testCase "partial parse" $ do let prefs = parsePreferredVersionsWarnings (toUTF8LBS "binary 0.9.0.0 || > 0.9.0.0\ncontainers == 0.6.4.1") - prefs @?= - [ Left binaryDepParseError - , Right - (Dependency - (mkPackageName "containers") - (thisVersion $ mkVersion [0,6,4,1]) - (NES.singleton LMainLibName) - ) - ] + prefs + @?= [ Left binaryDepParseError + , Right + ( Dependency + (mkPackageName "containers") + (thisVersion $ mkVersion [0, 6, 4, 1]) + (NES.singleton LMainLibName) + ) + ] ] - where - binaryDepParseError = PreferredVersionsParseError - { preferredVersionsParsecError = mconcat - [ "\"\" (line 1, column 8):\n" - , "unexpected '0'\n" - , "expecting space, white space, opening paren, operator or end of input" - ] - , preferredVersionsOriginalDependency = "binary 0.9.0.0 || > 0.9.0.0" - } + where + binaryDepParseError = + PreferredVersionsParseError + { preferredVersionsParsecError = + mconcat + [ "\"\" (line 1, column 8):\n" + , "unexpected '0'\n" + , "expecting space, white space, opening paren, operator or end of input" + ] + , preferredVersionsOriginalDependency = "binary 0.9.0.0 || > 0.9.0.0" + } diff --git a/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils/Timestamp.hs b/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils/Timestamp.hs index a7a0b7d7e3e..3b53e66c219 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils/Timestamp.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils/Timestamp.hs @@ -1,9 +1,9 @@ module UnitTests.Distribution.Client.IndexUtils.Timestamp (tests) where -import Distribution.Parsec (simpleParsec) -import Distribution.Pretty (prettyShow) import Data.Time import Data.Time.Clock.POSIX +import Distribution.Parsec (simpleParsec) +import Distribution.Pretty (prettyShow) import Distribution.Client.IndexUtils.Timestamp @@ -12,50 +12,51 @@ import Test.Tasty.QuickCheck tests :: [TestTree] tests = - [ testProperty "Timestamp1" prop_timestamp1 - , testProperty "Timestamp2" prop_timestamp2 - , testProperty "Timestamp3" prop_timestamp3 - , testProperty "Timestamp4" prop_timestamp4 - , testProperty "Timestamp5" prop_timestamp5 - ] + [ testProperty "Timestamp1" prop_timestamp1 + , testProperty "Timestamp2" prop_timestamp2 + , testProperty "Timestamp3" prop_timestamp3 + , testProperty "Timestamp4" prop_timestamp4 + , testProperty "Timestamp5" prop_timestamp5 + ] -- test unixtime format parsing prop_timestamp1 :: NonNegative Int -> Bool -prop_timestamp1 (NonNegative t0) = Just t == simpleParsec ('@':show t0) +prop_timestamp1 (NonNegative t0) = Just t == simpleParsec ('@' : show t0) where t = toEnum t0 :: Timestamp -- test prettyShow/simpleParse roundtrip prop_timestamp2 :: Int -> Bool prop_timestamp2 t0 - | t /= nullTimestamp = simpleParsec (prettyShow t) == Just t - | otherwise = prettyShow t == "" + | t /= nullTimestamp = simpleParsec (prettyShow t) == Just t + | otherwise = prettyShow t == "" where t = toEnum t0 :: Timestamp -- test prettyShow against reference impl prop_timestamp3 :: Int -> Bool prop_timestamp3 t0 - | t /= nullTimestamp = refDisp t == prettyShow t - | otherwise = prettyShow t == "" + | t /= nullTimestamp = refDisp t == prettyShow t + | otherwise = prettyShow t == "" where t = toEnum t0 :: Timestamp - refDisp = maybe undefined (formatTime undefined "%FT%TZ") - . timestampToUTCTime + refDisp = + maybe undefined (formatTime undefined "%FT%TZ") + . timestampToUTCTime -- test utcTimeToTimestamp/timestampToUTCTime roundtrip prop_timestamp4 :: Int -> Bool prop_timestamp4 t0 - | t /= nullTimestamp = (utcTimeToTimestamp =<< timestampToUTCTime t) == Just t - | otherwise = timestampToUTCTime t == Nothing + | t /= nullTimestamp = (utcTimeToTimestamp =<< timestampToUTCTime t) == Just t + | otherwise = timestampToUTCTime t == Nothing where t = toEnum t0 :: Timestamp prop_timestamp5 :: Int -> Bool prop_timestamp5 t0 | t /= nullTimestamp = timestampToUTCTime t == Just ut - | otherwise = timestampToUTCTime t == Nothing + | otherwise = timestampToUTCTime t == Nothing where t = toEnum t0 :: Timestamp ut = posixSecondsToUTCTime (fromIntegral t0) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init.hs index b50a9ab5fa1..b06faef5312 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Init.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Init.hs @@ -1,14 +1,14 @@ module UnitTests.Distribution.Client.Init -( tests -) where + ( tests + ) where import Test.Tasty -import qualified UnitTests.Distribution.Client.Init.Interactive as Interactive +import qualified UnitTests.Distribution.Client.Init.FileCreators as FileCreators +import qualified UnitTests.Distribution.Client.Init.Golden as Golden +import qualified UnitTests.Distribution.Client.Init.Interactive as Interactive import qualified UnitTests.Distribution.Client.Init.NonInteractive as NonInteractive -import qualified UnitTests.Distribution.Client.Init.Golden as Golden -import qualified UnitTests.Distribution.Client.Init.Simple as Simple -import qualified UnitTests.Distribution.Client.Init.FileCreators as FileCreators +import qualified UnitTests.Distribution.Client.Init.Simple as Simple import UnitTests.Distribution.Client.Init.Utils @@ -19,33 +19,32 @@ import Distribution.Client.Sandbox import Distribution.Client.Setup import Distribution.Verbosity - tests :: IO [TestTree] tests = do - confFlags <- loadConfigOrSandboxConfig v defaultGlobalFlags + confFlags <- loadConfigOrSandboxConfig v defaultGlobalFlags - let confFlags' = savedConfigureFlags confFlags `mappend` compFlags - initFlags' = savedInitFlags confFlags `mappend` emptyFlags - globalFlags' = savedGlobalFlags confFlags `mappend` defaultGlobalFlags + let confFlags' = savedConfigureFlags confFlags `mappend` compFlags + initFlags' = savedInitFlags confFlags `mappend` emptyFlags + globalFlags' = savedGlobalFlags confFlags `mappend` defaultGlobalFlags - (comp, _, progdb) <- configCompilerAux' confFlags' + (comp, _, progdb) <- configCompilerAux' confFlags' - withRepoContext v globalFlags' $ \repoCtx -> do - let pkgDb = configPackageDB' confFlags' + withRepoContext v globalFlags' $ \repoCtx -> do + let pkgDb = configPackageDB' confFlags' - pkgIx <- getInstalledPackages v comp pkgDb progdb - srcDb <- getSourcePackages v repoCtx + pkgIx <- getInstalledPackages v comp pkgDb progdb + srcDb <- getSourcePackages v repoCtx - return - [ Interactive.tests v initFlags' pkgIx srcDb - , NonInteractive.tests v initFlags' comp pkgIx srcDb - , Golden.tests v initFlags' pkgIx srcDb - , Simple.tests v initFlags' pkgIx srcDb - , FileCreators.tests v initFlags' comp pkgIx srcDb - ] + return + [ Interactive.tests v initFlags' pkgIx srcDb + , NonInteractive.tests v initFlags' comp pkgIx srcDb + , Golden.tests v initFlags' pkgIx srcDb + , Simple.tests v initFlags' pkgIx srcDb + , FileCreators.tests v initFlags' comp pkgIx srcDb + ] where v :: Verbosity v = normal compFlags :: ConfigFlags - compFlags = mempty { configHcPath = initHcPath emptyFlags } + compFlags = mempty{configHcPath = initHcPath emptyFlags} diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init/FileCreators.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init/FileCreators.hs index 2c0ab936669..38c488dd3a7 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Init/FileCreators.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Init/FileCreators.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + module UnitTests.Distribution.Client.Init.FileCreators ( tests ) where @@ -19,71 +20,70 @@ import Distribution.Simple.PackageIndex import Distribution.Verbosity tests - :: Verbosity - -> InitFlags - -> Compiler - -> InstalledPackageIndex - -> SourcePackageDb - -> TestTree + :: Verbosity + -> InitFlags + -> Compiler + -> InstalledPackageIndex + -> SourcePackageDb + -> TestTree tests _v _initFlags comp pkgIx srcDb = - testGroup "Distribution.Client.Init.FileCreators" + testGroup + "Distribution.Client.Init.FileCreators" [ testCase "Check . as source directory" $ do - let dummyFlags' = dummyFlags - { packageType = Flag LibraryAndExecutable - , minimal = Flag False - , overwrite = Flag False - , packageDir = Flag "/home/test/test-package" - , extraDoc = Flag ["CHANGELOG.md"] - , exposedModules = Flag [] - , otherModules = Flag [] - , otherExts = Flag [] - , buildTools = Flag [] - , mainIs = Flag "quxApp/Main.hs" - , dependencies = Flag [] - , sourceDirs = Flag ["."] - } + let dummyFlags' = + dummyFlags + { packageType = Flag LibraryAndExecutable + , minimal = Flag False + , overwrite = Flag False + , packageDir = Flag "/home/test/test-package" + , extraDoc = Flag ["CHANGELOG.md"] + , exposedModules = Flag [] + , otherModules = Flag [] + , otherExts = Flag [] + , buildTools = Flag [] + , mainIs = Flag "quxApp/Main.hs" + , dependencies = Flag [] + , sourceDirs = Flag ["."] + } inputs = -- createProject stuff [ "Foobar" , "foobar@qux.com" , "True" , "[\"quxTest/Main.hs\"]" - -- writeProject stuff - -- writeLicense - , "2021" - -- writeFileSafe - , "True" - -- findNewPath - , "False" - -- writeChangeLog - -- writeFileSafe - , "False" - -- prepareLibTarget - -- writeDirectoriesSafe - , "True" - -- findNewPath - , "False" - -- prepareExeTarget - -- writeDirectoriesSafe - , "False" - -- writeFileSafe - , "False" - -- prepareTestTarget - -- writeDirectoriesSafe - , "False" - -- writeFileSafe - , "False" - -- writeCabalFile - -- writeFileSafe - , "False" + , -- writeProject stuff + -- writeLicense + "2021" + , -- writeFileSafe + "True" + , -- findNewPath + "False" + , -- writeChangeLog + -- writeFileSafe + "False" + , -- prepareLibTarget + -- writeDirectoriesSafe + "True" + , -- findNewPath + "False" + , -- prepareExeTarget + -- writeDirectoriesSafe + "False" + , -- writeFileSafe + "False" + , -- prepareTestTarget + -- writeDirectoriesSafe + "False" + , -- writeFileSafe + "False" + , -- writeCabalFile + -- writeFileSafe + "False" ] case flip _runPrompt inputs $ do - projSettings <- createProject comp silent pkgIx srcDb dummyFlags' - writeProject projSettings of - + projSettings <- createProject comp silent pkgIx srcDb dummyFlags' + writeProject projSettings of Left (BreakException ex) -> assertFailure $ show ex Right _ -> return () - - ] diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init/Golden.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init/Golden.hs index 1a14e1f69b8..0ad087c2535 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Init/Golden.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Init/Golden.hs @@ -1,9 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} -module UnitTests.Distribution.Client.Init.Golden -( tests -) where +module UnitTests.Distribution.Client.Init.Golden + ( tests + ) where import Test.Tasty import Test.Tasty.Golden @@ -16,22 +16,22 @@ import Data.List.NonEmpty as NEL (NonEmpty, drop) import Data.Semigroup ((<>)) #endif +import Distribution.CabalSpecVersion +import Distribution.Client.Init.FlagExtractors +import Distribution.Client.Init.Format +import Distribution.Client.Init.Interactive.Command import Distribution.Client.Init.Types -import Distribution.Simple.PackageIndex hiding (fromList) -import Distribution.Verbosity import Distribution.Client.Types.SourcePackageDb -import Distribution.Client.Init.Interactive.Command -import Distribution.Client.Init.Format import Distribution.Fields.Pretty -import Distribution.Types.PackageName (PackageName) -import Distribution.Client.Init.FlagExtractors import Distribution.Simple.Flag -import Distribution.CabalSpecVersion +import Distribution.Simple.PackageIndex hiding (fromList) +import Distribution.Types.PackageName (PackageName) +import Distribution.Verbosity import System.FilePath -import UnitTests.Distribution.Client.Init.Utils import Distribution.Client.Init.Defaults +import UnitTests.Distribution.Client.Init.Utils -- -------------------------------------------------------------------- -- -- golden test suite @@ -50,14 +50,15 @@ import Distribution.Client.Init.Defaults -- Additionally, we test whole @.cabal@ file generation for every combination -- of library, lib + tests, exe, exe + tests, exe + lib, exe + lib + tests -- and so on against the same options. --- tests - :: Verbosity - -> InitFlags - -> InstalledPackageIndex - -> SourcePackageDb - -> TestTree -tests v initFlags pkgIx srcDb = testGroup "golden" + :: Verbosity + -> InitFlags + -> InstalledPackageIndex + -> SourcePackageDb + -> TestTree +tests v initFlags pkgIx srcDb = + testGroup + "golden" [ goldenLibTests v pkgIx pkgDir pkgName , goldenExeTests v pkgIx pkgDir pkgName , goldenTestTests v pkgIx pkgDir pkgName @@ -65,37 +66,42 @@ tests v initFlags pkgIx srcDb = testGroup "golden" , goldenCabalTests v pkgIx srcDb ] where - pkgDir = evalPrompt (getPackageDir initFlags) - $ fromList ["."] - pkgName = evalPrompt (packageNamePrompt srcDb initFlags) - $ fromList ["test-package", "test-package", "y"] + pkgDir = + evalPrompt (getPackageDir initFlags) $ + fromList ["."] + pkgName = + evalPrompt (packageNamePrompt srcDb initFlags) $ + fromList ["test-package", "test-package", "y"] goldenPkgDescTests - :: Verbosity - -> SourcePackageDb - -> FilePath - -> PackageName - -> TestTree -goldenPkgDescTests v srcDb pkgDir pkgName = testGroup "package description golden tests" - [ goldenVsString "Empty flags, non-simple, no comments" - (goldenPkgDesc "pkg.golden") $ - let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion - in runPkgDesc opts emptyFlags pkgArgs - - , goldenVsString "Empty flags, non-simple, with comments" - (goldenPkgDesc "pkg-with-comments.golden") $ - let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion - in runPkgDesc opts emptyFlags pkgArgs - - , goldenVsString "Dummy flags, >= cabal version syntax, with comments" - (goldenPkgDesc "pkg-with-flags.golden") $ - let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion - in runPkgDesc opts (dummyFlags {cabalVersion = Flag CabalSpecV1_0}) pkgArgs - - , goldenVsString "Dummy flags, old cabal version, with comments" - (goldenPkgDesc "pkg-old-cabal-with-flags.golden") $ - let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion - in runPkgDesc opts (dummyFlags {cabalVersion = Flag CabalSpecV2_0}) pkgArgs + :: Verbosity + -> SourcePackageDb + -> FilePath + -> PackageName + -> TestTree +goldenPkgDescTests v srcDb pkgDir pkgName = + testGroup + "package description golden tests" + [ goldenVsString + "Empty flags, non-simple, no comments" + (goldenPkgDesc "pkg.golden") + $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion + in runPkgDesc opts emptyFlags pkgArgs + , goldenVsString + "Empty flags, non-simple, with comments" + (goldenPkgDesc "pkg-with-comments.golden") + $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion + in runPkgDesc opts emptyFlags pkgArgs + , goldenVsString + "Dummy flags, >= cabal version syntax, with comments" + (goldenPkgDesc "pkg-with-flags.golden") + $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion + in runPkgDesc opts (dummyFlags{cabalVersion = Flag CabalSpecV1_0}) pkgArgs + , goldenVsString + "Dummy flags, old cabal version, with comments" + (goldenPkgDesc "pkg-old-cabal-with-flags.golden") + $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion + in runPkgDesc opts (dummyFlags{cabalVersion = Flag CabalSpecV2_0}) pkgArgs ] where runPkgDesc opts flags args = do @@ -104,207 +110,220 @@ goldenPkgDescTests v srcDb pkgDir pkgName = testGroup "package description golde Right (pkg, _) -> mkStanza $ mkPkgDescription opts pkg goldenExeTests - :: Verbosity - -> InstalledPackageIndex - -> FilePath - -> PackageName - -> TestTree -goldenExeTests v pkgIx pkgDir pkgName = testGroup "exe golden tests" - [ goldenVsString "Empty flags, not simple, no options, no comments" - (goldenExe "exe-no-comments.golden") $ - let opts = WriteOpts False False True v pkgDir Executable pkgName defaultCabalVersion - in runGoldenExe opts exeArgs emptyFlags - - , goldenVsString "Empty flags, not simple, with comments + no minimal" - (goldenExe "exe-with-comments.golden") $ - let opts = WriteOpts False False False v pkgDir Executable pkgName defaultCabalVersion - in runGoldenExe opts exeArgs emptyFlags - - , goldenVsString "Empty flags, not simple, with minimal + no comments" - (goldenExe "exe-minimal-no-comments.golden") $ - let opts = WriteOpts False True True v pkgDir Executable pkgName defaultCabalVersion - in runGoldenExe opts exeArgs emptyFlags - - , goldenVsString "Empty flags, not simple, with minimal + comments" - (goldenExe "exe-simple-minimal-with-comments.golden") $ - let opts = WriteOpts False True False v pkgDir Executable pkgName defaultCabalVersion - in runGoldenExe opts exeArgs emptyFlags - - , goldenVsString "Build tools flag, not simple, with comments + no minimal" - (goldenExe "exe-build-tools-with-comments.golden") $ - let opts = WriteOpts False False False v pkgDir Executable pkgName defaultCabalVersion - in runGoldenExe opts exeArgs (emptyFlags {buildTools = Flag ["happy"]}) + :: Verbosity + -> InstalledPackageIndex + -> FilePath + -> PackageName + -> TestTree +goldenExeTests v pkgIx pkgDir pkgName = + testGroup + "exe golden tests" + [ goldenVsString + "Empty flags, not simple, no options, no comments" + (goldenExe "exe-no-comments.golden") + $ let opts = WriteOpts False False True v pkgDir Executable pkgName defaultCabalVersion + in runGoldenExe opts exeArgs emptyFlags + , goldenVsString + "Empty flags, not simple, with comments + no minimal" + (goldenExe "exe-with-comments.golden") + $ let opts = WriteOpts False False False v pkgDir Executable pkgName defaultCabalVersion + in runGoldenExe opts exeArgs emptyFlags + , goldenVsString + "Empty flags, not simple, with minimal + no comments" + (goldenExe "exe-minimal-no-comments.golden") + $ let opts = WriteOpts False True True v pkgDir Executable pkgName defaultCabalVersion + in runGoldenExe opts exeArgs emptyFlags + , goldenVsString + "Empty flags, not simple, with minimal + comments" + (goldenExe "exe-simple-minimal-with-comments.golden") + $ let opts = WriteOpts False True False v pkgDir Executable pkgName defaultCabalVersion + in runGoldenExe opts exeArgs emptyFlags + , goldenVsString + "Build tools flag, not simple, with comments + no minimal" + (goldenExe "exe-build-tools-with-comments.golden") + $ let opts = WriteOpts False False False v pkgDir Executable pkgName defaultCabalVersion + in runGoldenExe opts exeArgs (emptyFlags{buildTools = Flag ["happy"]}) ] where runGoldenExe opts args flags = case _runPrompt (genExeTarget flags pkgIx) args of - Right (t, _) -> mkStanza [mkExeStanza opts $ t {_exeDependencies = mangleBaseDep t _exeDependencies}] + Right (t, _) -> mkStanza [mkExeStanza opts $ t{_exeDependencies = mangleBaseDep t _exeDependencies}] Left e -> assertFailure $ show e goldenLibTests - :: Verbosity - -> InstalledPackageIndex - -> FilePath - -> PackageName - -> TestTree -goldenLibTests v pkgIx pkgDir pkgName = testGroup "lib golden tests" - [ goldenVsString "Empty flags, not simple, no options, no comments" - (goldenLib "lib-no-comments.golden") $ - let opts = WriteOpts False False True v pkgDir Library pkgName defaultCabalVersion - in runGoldenLib opts libArgs emptyFlags - - , goldenVsString "Empty flags, simple, no options, no comments" - (goldenLib "lib-simple-no-comments.golden") $ - let opts = WriteOpts False False True v pkgDir Library pkgName defaultCabalVersion - in runGoldenLib opts libArgs emptyFlags - - , goldenVsString "Empty flags, not simple, with comments + no minimal" - (goldenLib "lib-with-comments.golden") $ - let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion - in runGoldenLib opts libArgs emptyFlags - - , goldenVsString "Empty flags, not simple, with minimal + no comments" - (goldenLib "lib-minimal-no-comments.golden") $ - let opts = WriteOpts False True True v pkgDir Library pkgName defaultCabalVersion - in runGoldenLib opts libArgs emptyFlags - - , goldenVsString "Empty flags, not simple, with minimal + comments" - (goldenLib "lib-simple-minimal-with-comments.golden") $ - let opts = WriteOpts False True False v pkgDir Library pkgName defaultCabalVersion - in runGoldenLib opts libArgs emptyFlags - - , goldenVsString "Build tools flag, not simple, with comments + no minimal" - (goldenLib "lib-build-tools-with-comments.golden") $ - let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion - in runGoldenLib opts libArgs (emptyFlags {buildTools = Flag ["happy"]}) + :: Verbosity + -> InstalledPackageIndex + -> FilePath + -> PackageName + -> TestTree +goldenLibTests v pkgIx pkgDir pkgName = + testGroup + "lib golden tests" + [ goldenVsString + "Empty flags, not simple, no options, no comments" + (goldenLib "lib-no-comments.golden") + $ let opts = WriteOpts False False True v pkgDir Library pkgName defaultCabalVersion + in runGoldenLib opts libArgs emptyFlags + , goldenVsString + "Empty flags, simple, no options, no comments" + (goldenLib "lib-simple-no-comments.golden") + $ let opts = WriteOpts False False True v pkgDir Library pkgName defaultCabalVersion + in runGoldenLib opts libArgs emptyFlags + , goldenVsString + "Empty flags, not simple, with comments + no minimal" + (goldenLib "lib-with-comments.golden") + $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion + in runGoldenLib opts libArgs emptyFlags + , goldenVsString + "Empty flags, not simple, with minimal + no comments" + (goldenLib "lib-minimal-no-comments.golden") + $ let opts = WriteOpts False True True v pkgDir Library pkgName defaultCabalVersion + in runGoldenLib opts libArgs emptyFlags + , goldenVsString + "Empty flags, not simple, with minimal + comments" + (goldenLib "lib-simple-minimal-with-comments.golden") + $ let opts = WriteOpts False True False v pkgDir Library pkgName defaultCabalVersion + in runGoldenLib opts libArgs emptyFlags + , goldenVsString + "Build tools flag, not simple, with comments + no minimal" + (goldenLib "lib-build-tools-with-comments.golden") + $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion + in runGoldenLib opts libArgs (emptyFlags{buildTools = Flag ["happy"]}) ] where runGoldenLib opts args flags = case _runPrompt (genLibTarget flags pkgIx) args of - Right (t, _) -> mkStanza [mkLibStanza opts $ t {_libDependencies = mangleBaseDep t _libDependencies}] + Right (t, _) -> mkStanza [mkLibStanza opts $ t{_libDependencies = mangleBaseDep t _libDependencies}] Left e -> assertFailure $ show e goldenTestTests - :: Verbosity - -> InstalledPackageIndex - -> FilePath - -> PackageName - -> TestTree -goldenTestTests v pkgIx pkgDir pkgName = testGroup "test golden tests" - [ goldenVsString "Empty flags, not simple, no options, no comments" - (goldenTest "test-no-comments.golden") $ - let opts = WriteOpts False False True v pkgDir Library pkgName defaultCabalVersion - in runGoldenTest opts testArgs emptyFlags - - , goldenVsString "Empty flags, not simple, with comments + no minimal" - (goldenTest "test-with-comments.golden") $ - let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion - in runGoldenTest opts testArgs emptyFlags - - , goldenVsString "Empty flags, not simple, with minimal + no comments" - (goldenTest "test-minimal-no-comments.golden") $ - let opts = WriteOpts False True True v pkgDir Library pkgName defaultCabalVersion - in runGoldenTest opts testArgs emptyFlags - - , goldenVsString "Empty flags, not simple, with minimal + comments" - (goldenTest "test-simple-minimal-with-comments.golden") $ - let opts = WriteOpts False True False v pkgDir Library pkgName defaultCabalVersion - in runGoldenTest opts testArgs emptyFlags - - , goldenVsString "Build tools flag, not simple, with comments + no minimal" - (goldenTest "test-build-tools-with-comments.golden") $ - let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion - in runGoldenTest opts testArgs (emptyFlags {buildTools = Flag ["happy"]}) - - , goldenVsString "Standalone tests, empty flags, not simple, no options, no comments" - (goldenTest "standalone-test-no-comments.golden") $ - let opts = WriteOpts False False True v pkgDir TestSuite pkgName defaultCabalVersion - in runGoldenTest opts testArgs emptyFlags - - , goldenVsString "Standalone tests, empty flags, not simple, with comments + no minimal" - (goldenTest "standalone-test-with-comments.golden") $ - let opts = WriteOpts False False False v pkgDir TestSuite pkgName defaultCabalVersion - in runGoldenTest opts testArgs emptyFlags + :: Verbosity + -> InstalledPackageIndex + -> FilePath + -> PackageName + -> TestTree +goldenTestTests v pkgIx pkgDir pkgName = + testGroup + "test golden tests" + [ goldenVsString + "Empty flags, not simple, no options, no comments" + (goldenTest "test-no-comments.golden") + $ let opts = WriteOpts False False True v pkgDir Library pkgName defaultCabalVersion + in runGoldenTest opts testArgs emptyFlags + , goldenVsString + "Empty flags, not simple, with comments + no minimal" + (goldenTest "test-with-comments.golden") + $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion + in runGoldenTest opts testArgs emptyFlags + , goldenVsString + "Empty flags, not simple, with minimal + no comments" + (goldenTest "test-minimal-no-comments.golden") + $ let opts = WriteOpts False True True v pkgDir Library pkgName defaultCabalVersion + in runGoldenTest opts testArgs emptyFlags + , goldenVsString + "Empty flags, not simple, with minimal + comments" + (goldenTest "test-simple-minimal-with-comments.golden") + $ let opts = WriteOpts False True False v pkgDir Library pkgName defaultCabalVersion + in runGoldenTest opts testArgs emptyFlags + , goldenVsString + "Build tools flag, not simple, with comments + no minimal" + (goldenTest "test-build-tools-with-comments.golden") + $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion + in runGoldenTest opts testArgs (emptyFlags{buildTools = Flag ["happy"]}) + , goldenVsString + "Standalone tests, empty flags, not simple, no options, no comments" + (goldenTest "standalone-test-no-comments.golden") + $ let opts = WriteOpts False False True v pkgDir TestSuite pkgName defaultCabalVersion + in runGoldenTest opts testArgs emptyFlags + , goldenVsString + "Standalone tests, empty flags, not simple, with comments + no minimal" + (goldenTest "standalone-test-with-comments.golden") + $ let opts = WriteOpts False False False v pkgDir TestSuite pkgName defaultCabalVersion + in runGoldenTest opts testArgs emptyFlags ] where runGoldenTest opts args flags = case _runPrompt (genTestTarget flags pkgIx) args of Left e -> assertFailure $ show e - Right (Nothing, _) -> assertFailure - "goldenTestTests: Tests not enabled." - Right (Just t, _) -> mkStanza [mkTestStanza opts $ t {_testDependencies = mangleBaseDep t _testDependencies}] + Right (Nothing, _) -> + assertFailure + "goldenTestTests: Tests not enabled." + Right (Just t, _) -> mkStanza [mkTestStanza opts $ t{_testDependencies = mangleBaseDep t _testDependencies}] -- | Full cabal file golden tests goldenCabalTests - :: Verbosity - -> InstalledPackageIndex - -> SourcePackageDb - -> TestTree -goldenCabalTests v pkgIx srcDb = testGroup ".cabal file golden tests" - [ goldenVsString "Library and executable, empty flags, not simple, with comments + no minimal" - (goldenCabal "cabal-lib-and-exe-with-comments.golden") $ - runGoldenTest (fullProjArgs "Y") emptyFlags - - , goldenVsString "Library and executable, empty flags, not simple, no comments + no minimal" - (goldenCabal "cabal-lib-and-exe-no-comments.golden") $ - runGoldenTest (fullProjArgs "N") emptyFlags - - , goldenVsString "Library, empty flags, not simple, with comments + no minimal" - (goldenCabal "cabal-lib-with-comments.golden") $ - runGoldenTest (libProjArgs "Y") emptyFlags - - , goldenVsString "Library, empty flags, not simple, no comments + no minimal" - (goldenCabal "cabal-lib-no-comments.golden") $ - runGoldenTest (libProjArgs "N") emptyFlags - - , goldenVsString "Test suite, empty flags, not simple, with comments + no minimal" - (goldenCabal "cabal-test-suite-with-comments.golden") $ - runGoldenTest (testProjArgs "Y") emptyFlags - - , goldenVsString "Test suite, empty flags, not simple, no comments + no minimal" - (goldenCabal "cabal-test-suite-no-comments.golden") $ - runGoldenTest (testProjArgs "N") emptyFlags + :: Verbosity + -> InstalledPackageIndex + -> SourcePackageDb + -> TestTree +goldenCabalTests v pkgIx srcDb = + testGroup + ".cabal file golden tests" + [ goldenVsString + "Library and executable, empty flags, not simple, with comments + no minimal" + (goldenCabal "cabal-lib-and-exe-with-comments.golden") + $ runGoldenTest (fullProjArgs "Y") emptyFlags + , goldenVsString + "Library and executable, empty flags, not simple, no comments + no minimal" + (goldenCabal "cabal-lib-and-exe-no-comments.golden") + $ runGoldenTest (fullProjArgs "N") emptyFlags + , goldenVsString + "Library, empty flags, not simple, with comments + no minimal" + (goldenCabal "cabal-lib-with-comments.golden") + $ runGoldenTest (libProjArgs "Y") emptyFlags + , goldenVsString + "Library, empty flags, not simple, no comments + no minimal" + (goldenCabal "cabal-lib-no-comments.golden") + $ runGoldenTest (libProjArgs "N") emptyFlags + , goldenVsString + "Test suite, empty flags, not simple, with comments + no minimal" + (goldenCabal "cabal-test-suite-with-comments.golden") + $ runGoldenTest (testProjArgs "Y") emptyFlags + , goldenVsString + "Test suite, empty flags, not simple, no comments + no minimal" + (goldenCabal "cabal-test-suite-no-comments.golden") + $ runGoldenTest (testProjArgs "N") emptyFlags ] where runGoldenTest args flags = 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 commonStanza = mkCommonStanza opts - libStanza = mkLibStanza opts $ libTarget {_libDependencies = mangleBaseDep libTarget _libDependencies} - exeStanza = mkExeStanza opts $ exeTarget {_exeDependencies = mangleBaseDep exeTarget _exeDependencies} - testStanza = mkTestStanza opts $ testTarget {_testDependencies = mangleBaseDep testTarget _testDependencies} + libStanza = mkLibStanza opts $ libTarget{_libDependencies = mangleBaseDep libTarget _libDependencies} + exeStanza = mkExeStanza opts $ exeTarget{_exeDependencies = mangleBaseDep exeTarget _exeDependencies} + testStanza = mkTestStanza opts $ testTarget{_testDependencies = mangleBaseDep testTarget _testDependencies} mkStanza $ pkgFields ++ [commonStanza, libStanza, exeStanza, testStanza] - (Right (ProjectSettings opts pkgDesc (Just libTarget) Nothing (Just testTarget), _)) -> do let pkgFields = mkPkgDescription opts pkgDesc commonStanza = mkCommonStanza opts - libStanza = mkLibStanza opts $ libTarget {_libDependencies = mangleBaseDep libTarget _libDependencies} - testStanza = mkTestStanza opts $ testTarget {_testDependencies = mangleBaseDep testTarget _testDependencies} + libStanza = mkLibStanza opts $ libTarget{_libDependencies = mangleBaseDep libTarget _libDependencies} + testStanza = mkTestStanza opts $ testTarget{_testDependencies = mangleBaseDep testTarget _testDependencies} mkStanza $ pkgFields ++ [commonStanza, libStanza, testStanza] - (Right (ProjectSettings opts pkgDesc Nothing Nothing (Just testTarget), _)) -> do let pkgFields = mkPkgDescription opts pkgDesc commonStanza = mkCommonStanza opts - testStanza = mkTestStanza opts $ testTarget {_testDependencies = mangleBaseDep testTarget _testDependencies} + testStanza = mkTestStanza opts $ testTarget{_testDependencies = mangleBaseDep testTarget _testDependencies} mkStanza $ pkgFields ++ [commonStanza, testStanza] - - (Right (ProjectSettings _ _ l e t, _)) -> assertFailure $ - show l ++ "\n" ++ show e ++ "\n" ++ show t - + (Right (ProjectSettings _ _ l e t, _)) -> + assertFailure $ + show l ++ "\n" ++ show e ++ "\n" ++ show t -- -------------------------------------------------------------------- -- -- utils mkStanza :: [PrettyField FieldAnnotation] -> IO BS8.ByteString -mkStanza fields = return . BS8.pack $ showFields' - annCommentLines postProcessFieldLines - 4 fields +mkStanza fields = + return . BS8.pack $ + showFields' + annCommentLines + postProcessFieldLines + 4 + fields golden :: FilePath golden = "tests" "fixtures" "init" "golden" @@ -334,7 +353,8 @@ testArgs :: NonEmpty String testArgs = fromList ["y", "1", "test", "1"] pkgArgs :: NonEmpty String -pkgArgs = fromList +pkgArgs = + fromList [ "5" , "foo-package" , "foo-package" @@ -351,22 +371,25 @@ pkgArgs = fromList ] testProjArgs :: String -> NonEmpty String -testProjArgs comments = fromList ["4", "n", "foo-package"] - <> pkgArgs - <> fromList (NEL.drop 1 testArgs) - <> fromList [comments] +testProjArgs comments = + fromList ["4", "n", "foo-package"] + <> pkgArgs + <> fromList (NEL.drop 1 testArgs) + <> fromList [comments] libProjArgs :: String -> NonEmpty String -libProjArgs comments = fromList ["1", "n", "foo-package"] - <> pkgArgs - <> libArgs - <> testArgs - <> fromList [comments] +libProjArgs comments = + fromList ["1", "n", "foo-package"] + <> pkgArgs + <> libArgs + <> testArgs + <> fromList [comments] fullProjArgs :: String -> NonEmpty String -fullProjArgs comments = fromList ["3", "n", "foo-package"] - <> pkgArgs - <> libArgs - <> exeArgs - <> testArgs - <> fromList [comments] +fullProjArgs comments = + fromList ["3", "n", "foo-package"] + <> pkgArgs + <> libArgs + <> exeArgs + <> testArgs + <> fromList [comments] diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init/Interactive.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init/Interactive.hs index 4a2d000cb47..24f68255cde 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Init/Interactive.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Init/Interactive.hs @@ -1,11 +1,10 @@ module UnitTests.Distribution.Client.Init.Interactive -( tests -) where + ( tests + ) where - -import Prelude as P import Test.Tasty import Test.Tasty.HUnit +import Prelude as P import Distribution.Client.Init.Defaults import Distribution.Client.Init.Interactive.Command @@ -22,1003 +21,1104 @@ import Distribution.Verbosity import Language.Haskell.Extension -import UnitTests.Distribution.Client.Init.Utils -import Distribution.Client.Init.FlagExtractors -import Distribution.Simple.Setup -import Distribution.CabalSpecVersion import qualified Data.Set as Set +import Distribution.CabalSpecVersion +import Distribution.Client.Init.FlagExtractors import Distribution.FieldGrammar.Newtypes - +import Distribution.Simple.Setup +import UnitTests.Distribution.Client.Init.Utils -- -------------------------------------------------------------------- -- -- Init Test main tests - :: Verbosity - -> InitFlags - -> InstalledPackageIndex - -> SourcePackageDb - -> TestTree + :: Verbosity + -> InitFlags + -> InstalledPackageIndex + -> SourcePackageDb + -> TestTree tests _v initFlags pkgIx srcDb = - testGroup "Distribution.Client.Init.Interactive.Command.hs" + testGroup + "Distribution.Client.Init.Interactive.Command.hs" [ createProjectTest pkgIx srcDb , fileCreatorTests pkgIx srcDb pkgName , interactiveTests srcDb ] where - pkgName = evalPrompt (packageNamePrompt srcDb initFlags) $ + pkgName = + evalPrompt (packageNamePrompt srcDb initFlags) $ fromList ["test-package", "y"] - -- pkgNm = evalPrompt (getPackageName srcDb initFlags) $ fromList ["test-package", "y"] +-- pkgNm = evalPrompt (getPackageName srcDb initFlags) $ fromList ["test-package", "y"] createProjectTest :: InstalledPackageIndex -> SourcePackageDb -> TestTree -createProjectTest pkgIx srcDb = testGroup "createProject tests" - [ testGroup "with flags" - [ testCase "Check the interactive workflow" $ do - let dummyFlags' = dummyFlags - { packageType = Flag LibraryAndExecutable - , minimal = Flag False - , overwrite = Flag False - , packageDir = Flag "/home/test/test-package" - , extraSrc = NoFlag - , exposedModules = Flag [] - , otherModules = Flag [] - , otherExts = Flag [] - , buildTools = Flag [] - , mainIs = Flag "quxApp/Main.hs" - , dependencies = Flag [] - } - - case (_runPrompt $ createProject silent pkgIx srcDb dummyFlags') (fromList ["n", "3", "quxTest/Main.hs"]) of - Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do - _optOverwrite opts @?= False - _optMinimal opts @?= False - _optNoComments opts @?= True - _optVerbosity opts @?= silent - _optPkgDir opts @?= "/home/test/test-package" - _optPkgType opts @?= LibraryAndExecutable - _optPkgName opts @?= mkPackageName "QuxPackage" - - _pkgCabalVersion desc @?= CabalSpecV2_2 - _pkgName desc @?= mkPackageName "QuxPackage" - _pkgVersion desc @?= mkVersion [4,2,6] - _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) - _pkgAuthor desc @?= "Foobar" - _pkgEmail desc @?= "foobar@qux.com" - _pkgHomePage desc @?= "qux.com" - _pkgSynopsis desc @?= "We are Qux, and this is our package" - _pkgCategory desc @?= "Control" - _pkgExtraSrcFiles desc @?= mempty - _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") - - _libSourceDirs lib @?= ["quxSrc"] - _libLanguage lib @?= Haskell98 - _libExposedModules lib @?= myLibModule :| [] - _libOtherModules lib @?= [] - _libOtherExts lib @?= [] - _libDependencies lib @?= [] - _libBuildTools lib @?= [] - - _exeMainIs exe @?= HsFilePath "quxApp/Main.hs" Standard - _exeApplicationDirs exe @?= ["quxApp"] - _exeLanguage exe @?= Haskell98 - _exeOtherModules exe @?= [] - _exeOtherExts exe @?= [] - _exeDependencies exe @?! [] - _exeBuildTools exe @?= [] - - _testMainIs test @?= HsFilePath "quxTest/Main.hs" Standard - _testDirs test @?= ["quxTest"] - _testLanguage test @?= Haskell98 - _testOtherModules test @?= [] - _testOtherExts test @?= [] - _testDependencies test @?! [] - _testBuildTools test @?= [] - - Right (ProjectSettings _ _ lib exe test, _) -> do - lib @?! Nothing - exe @?! Nothing - test @?! Nothing - Left e -> assertFailure $ show e - ] - - , testGroup "with tests" - [ testCase "Check the interactive library and executable workflow" $ do - let inputs = fromList - -- package type - [ "3" - -- overwrite - , "n" - -- package dir - , "test-package" - -- package description - -- cabal version - , "4" - -- package name - , "test-package" - , "test-package" - , "test-package" - -- version - , "3.1.2.3" - -- license - , "3" - -- author - , "git username" - , "Foobar" - -- email - , "git email" - , "foobar@qux.com" - -- homepage - , "qux.com" - -- synopsis - , "Qux's package" - -- category - , "3" - -- library target - -- source dir - , "1" - -- language - , "2" - -- executable target - -- main file - , "1" - -- application dir - , "2" - -- language - , "2" - -- test target - , "y" - -- main file - , "1" - -- test dir - , "test" - -- language - , "1" - -- comments - , "y" - ] - - 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 - _optNoComments opts @?= False - _optVerbosity opts @?= silent - _optPkgDir opts @?= "/home/test/test-package" - _optPkgType opts @?= LibraryAndExecutable - _optPkgName opts @?= mkPackageName "test-package" - - _pkgCabalVersion desc @?= CabalSpecV2_4 - _pkgName desc @?= mkPackageName "test-package" - _pkgVersion desc @?= mkVersion [3,1,2,3] - _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) - _pkgAuthor desc @?= "Foobar" - _pkgEmail desc @?= "foobar@qux.com" - _pkgHomePage desc @?= "qux.com" - _pkgSynopsis desc @?= "Qux's package" - _pkgCategory desc @?= "Control" - _pkgExtraSrcFiles desc @?= mempty - _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") - - _libSourceDirs lib @?= ["src"] - _libLanguage lib @?= Haskell98 - _libExposedModules lib @?= myLibModule :| [] - _libOtherModules lib @?= [] - _libOtherExts lib @?= [] - _libDependencies lib @?! [] - _libBuildTools lib @?= [] - - _exeMainIs exe @?= HsFilePath "Main.hs" Standard - _exeApplicationDirs exe @?= ["exe"] - _exeLanguage exe @?= Haskell98 - _exeOtherModules exe @?= [] - _exeOtherExts exe @?= [] - _exeDependencies exe @?! [] - _exeBuildTools exe @?= [] - - _testMainIs test @?= HsFilePath "Main.hs" Standard - _testDirs test @?= ["test"] - _testLanguage test @?= Haskell2010 - _testOtherModules test @?= [] - _testOtherExts test @?= [] - _testDependencies test @?! [] - _testBuildTools test @?= [] - - Right (ProjectSettings _ _ lib exe test, _) -> do - lib @?! Nothing - exe @?! Nothing - test @?! Nothing - Left e -> assertFailure $ show e - - , testCase "Check the interactive library workflow" $ do - let inputs = fromList - -- package type - [ "1" - -- overwrite - , "n" - -- package dir - , "test-package" - -- package description - -- cabal version - , "4" - -- package name - , "test-package" - , "test-package" - , "test-package" - -- version - , "3.1.2.3" - -- license - , "3" - -- author - , "git username" - , "Foobar" - -- email - , "git email" - , "foobar@qux.com" - -- homepage - , "qux.com" - -- synopsis - , "Qux's package" - -- category - , "3" - -- library target - -- source dir - , "1" - -- language - , "2" - -- test target - , "y" - -- main file - , "1" - -- test dir - , "test" - -- language - , "1" - -- comments - , "y" - ] - - 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 - _optNoComments opts @?= False - _optVerbosity opts @?= silent - _optPkgDir opts @?= "/home/test/test-package" - _optPkgType opts @?= Library - _optPkgName opts @?= mkPackageName "test-package" - - _pkgCabalVersion desc @?= CabalSpecV2_4 - _pkgName desc @?= mkPackageName "test-package" - _pkgVersion desc @?= mkVersion [3,1,2,3] - _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) - _pkgAuthor desc @?= "Foobar" - _pkgEmail desc @?= "foobar@qux.com" - _pkgHomePage desc @?= "qux.com" - _pkgSynopsis desc @?= "Qux's package" - _pkgCategory desc @?= "Control" - _pkgExtraSrcFiles desc @?= mempty - _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") - - _libSourceDirs lib @?= ["src"] - _libLanguage lib @?= Haskell98 - _libExposedModules lib @?= myLibModule :| [] - _libOtherModules lib @?= [] - _libOtherExts lib @?= [] - _libDependencies lib @?! [] - _libBuildTools lib @?= [] - - _testMainIs test @?= HsFilePath "Main.hs" Standard - _testDirs test @?= ["test"] - _testLanguage test @?= Haskell2010 - _testOtherModules test @?= [] - _testOtherExts test @?= [] - _testDependencies test @?! [] - _testBuildTools test @?= [] - - Right (ProjectSettings _ _ lib exe test, _) -> do - lib @?! Nothing - exe @?= Nothing - test @?! Nothing - Left e -> assertFailure $ show e - - , testCase "Check the interactive library workflow" $ do - let inputs = fromList - -- package type - [ "4" - -- overwrite - , "n" - -- package dir - , "test-package" - -- package description - -- cabal version - , "4" - -- package name - , "test-package" - , "test-package" - , "test-package" - -- version - , "3.1.2.3" - -- license - , "3" - -- author - , "git username" - , "Foobar" - -- email - , "git email" - , "foobar@qux.com" - -- homepage - , "qux.com" - -- synopsis - , "Qux's package" - -- category - , "3" - -- test target - -- main file - , "1" - -- test dir - , "test" - -- language - , "1" - -- comments - , "y" - ] - - case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of - Right (ProjectSettings opts desc Nothing Nothing (Just test), _) -> do - _optOverwrite opts @?= False - _optMinimal opts @?= False - _optNoComments opts @?= False - _optVerbosity opts @?= silent - _optPkgDir opts @?= "/home/test/test-package" - _optPkgType opts @?= TestSuite - _optPkgName opts @?= mkPackageName "test-package" - - _pkgCabalVersion desc @?= CabalSpecV2_4 - _pkgName desc @?= mkPackageName "test-package" - _pkgVersion desc @?= mkVersion [3,1,2,3] - _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) - _pkgAuthor desc @?= "Foobar" - _pkgEmail desc @?= "foobar@qux.com" - _pkgHomePage desc @?= "qux.com" - _pkgSynopsis desc @?= "Qux's package" - _pkgCategory desc @?= "Control" - _pkgExtraSrcFiles desc @?= mempty - _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") - - _testMainIs test @?= HsFilePath "Main.hs" Standard - _testDirs test @?= ["test"] - _testLanguage test @?= Haskell2010 - _testOtherModules test @?= [] - _testOtherExts test @?= [] - _testDependencies test @?! [] - _testBuildTools test @?= [] - - Right (ProjectSettings _ _ lib exe test, _) -> do - lib @?= Nothing - exe @?= Nothing - test @?! Nothing - Left e -> assertFailure $ show e - ] - , testGroup "without tests" - [ testCase "Check the interactive library and executable workflow" $ do - let inputs = fromList - -- package type - [ "3" - -- overwrite - , "n" - -- package dir - , "test-package" - -- package description - -- cabal version - , "4" - -- package name - , "test-package" - , "test-package" - , "test-package" - -- version - , "3.1.2.3" - -- license - , "3" - -- author - , "git username" - , "Foobar" - -- email - , "git email" - , "foobar@qux.com" - -- homepage - , "qux.com" - -- synopsis - , "Qux's package" - -- category - , "3" - -- library target - -- source dir - , "1" - -- language - , "2" - -- executable target - -- main file - , "1" - -- application dir - , "2" - -- language - , "2" - -- test suite - , "n" - -- comments - , "y" - ] - - 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 - _optNoComments opts @?= False - _optVerbosity opts @?= silent - _optPkgDir opts @?= "/home/test/test-package" - _optPkgType opts @?= LibraryAndExecutable - _optPkgName opts @?= mkPackageName "test-package" - - _pkgCabalVersion desc @?= CabalSpecV2_4 - _pkgName desc @?= mkPackageName "test-package" - _pkgVersion desc @?= mkVersion [3,1,2,3] - _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) - _pkgAuthor desc @?= "Foobar" - _pkgEmail desc @?= "foobar@qux.com" - _pkgHomePage desc @?= "qux.com" - _pkgSynopsis desc @?= "Qux's package" - _pkgCategory desc @?= "Control" - _pkgExtraSrcFiles desc @?= mempty - _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") - - _libSourceDirs lib @?= ["src"] - _libLanguage lib @?= Haskell98 - _libExposedModules lib @?= myLibModule :| [] - _libOtherModules lib @?= [] - _libOtherExts lib @?= [] - _libDependencies lib @?! [] - _libBuildTools lib @?= [] - - _exeMainIs exe @?= HsFilePath "Main.hs" Standard - _exeApplicationDirs exe @?= ["exe"] - _exeLanguage exe @?= Haskell98 - _exeOtherModules exe @?= [] - _exeOtherExts exe @?= [] - _exeDependencies exe @?! [] - _exeBuildTools exe @?= [] - - Right (ProjectSettings _ _ lib exe test, _) -> do - lib @?! Nothing - exe @?! Nothing - test @?= Nothing - Left e -> assertFailure $ show e - - , testCase "Check the interactive library workflow" $ do - let inputs = fromList - -- package type - [ "1" - -- overwrite - , "n" - -- package dir - , "test-package" - -- package description - -- cabal version - , "4" - -- package name - , "test-package" - , "test-package" - , "test-package" - -- version - , "3.1.2.3" - -- license - , "3" - -- author - , "git username" - , "Foobar" - -- email - , "git email" - , "foobar@qux.com" - -- homepage - , "qux.com" - -- synopsis - , "Qux's package" - -- category - , "3" - -- library target - -- source dir - , "1" - -- language - , "2" - -- test suite - , "n" - -- comments - , "y" - ] - - case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of - Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do - _optOverwrite opts @?= False - _optMinimal opts @?= False - _optNoComments opts @?= False - _optVerbosity opts @?= silent - _optPkgDir opts @?= "/home/test/test-package" - _optPkgType opts @?= Library - _optPkgName opts @?= mkPackageName "test-package" - - _pkgCabalVersion desc @?= CabalSpecV2_4 - _pkgName desc @?= mkPackageName "test-package" - _pkgVersion desc @?= mkVersion [3,1,2,3] - _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) - _pkgAuthor desc @?= "Foobar" - _pkgEmail desc @?= "foobar@qux.com" - _pkgHomePage desc @?= "qux.com" - _pkgSynopsis desc @?= "Qux's package" - _pkgCategory desc @?= "Control" - _pkgExtraSrcFiles desc @?= mempty - _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") - - _libSourceDirs lib @?= ["src"] - _libLanguage lib @?= Haskell98 - _libExposedModules lib @?= myLibModule :| [] - _libOtherModules lib @?= [] - _libOtherExts lib @?= [] - _libDependencies lib @?! [] - _libBuildTools lib @?= [] - - Right (ProjectSettings _ _ lib exe test, _) -> do - lib @?! Nothing - exe @?= Nothing - test @?= Nothing - Left e -> assertFailure $ show e - - , testCase "Check the interactive library workflow - cabal < 1.18" $ do - let inputs = fromList - -- package type - [ "1" - -- overwrite - , "n" - -- package dir - , "test-package" - -- package description - -- cabal version - , "4" - -- package name - , "test-package" - , "test-package" - , "test-package" - -- version - , "3.1.2.3" - -- license - , "3" - -- author - , "git username" - , "Foobar" - -- email - , "git email" - , "foobar@qux.com" - -- homepage - , "qux.com" - -- synopsis - , "Qux's package" - -- category - , "3" - -- library target - -- source dir - , "1" - -- language - , "2" - -- test suite - , "n" - -- comments - , "y" - ] - - flags = emptyFlags - { cabalVersion = Flag CabalSpecV1_10 - , extraDoc = Flag [defaultChangelog] - , extraSrc = Flag ["README.md"] - } - - case (_runPrompt $ createProject silent pkgIx srcDb flags) inputs of - Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do - _optOverwrite opts @?= False - _optMinimal opts @?= False - _optNoComments opts @?= False - _optVerbosity opts @?= silent - _optPkgDir opts @?= "/home/test/test-package" - _optPkgType opts @?= Library - _optPkgName opts @?= mkPackageName "test-package" - - _pkgCabalVersion desc @?= CabalSpecV1_10 - _pkgName desc @?= mkPackageName "test-package" - _pkgVersion desc @?= mkVersion [3,1,2,3] - _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) - _pkgAuthor desc @?= "Foobar" - _pkgEmail desc @?= "foobar@qux.com" - _pkgHomePage desc @?= "qux.com" - _pkgSynopsis desc @?= "Qux's package" - _pkgCategory desc @?= "Control" - _pkgExtraSrcFiles desc @?= Set.fromList [defaultChangelog, "README.md"] - _pkgExtraDocFiles desc @?= Nothing - - _libSourceDirs lib @?= ["src"] - _libLanguage lib @?= Haskell98 - _libExposedModules lib @?= myLibModule :| [] - _libOtherModules lib @?= [] - _libOtherExts lib @?= [] - _libDependencies lib @?! [] - _libBuildTools lib @?= [] - - Right (ProjectSettings _ _ lib exe test, _) -> do - lib @?! Nothing - exe @?= Nothing - test @?= Nothing - Left e -> assertFailure $ show e - - , testCase "Check the interactive executable workflow" $ do - let inputs = fromList - -- package type - [ "2" - -- overwrite - , "n" - -- package dir - , "test-package" - -- package description - -- cabal version - , "4" - -- package name - , "test-package" - , "test-package" - , "test-package" - -- version - , "3.1.2.3" - -- license - , "3" - -- author - , "git username" - , "Foobar" - -- email - , "git email" - , "foobar@qux.com" - -- homepage - , "qux.com" - -- synopsis - , "Qux's package" - -- category - , "3" - -- executable target - -- main file - , "1" - -- application dir - , "2" - -- language - , "2" - -- comments - , "y" - ] - - case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of - Right (ProjectSettings opts desc Nothing (Just exe) Nothing, _) -> do - _optOverwrite opts @?= False - _optMinimal opts @?= False - _optNoComments opts @?= False - _optVerbosity opts @?= silent - _optPkgDir opts @?= "/home/test/test-package" - _optPkgType opts @?= Executable - _optPkgName opts @?= mkPackageName "test-package" - - _pkgCabalVersion desc @?= CabalSpecV2_4 - _pkgName desc @?= mkPackageName "test-package" - _pkgVersion desc @?= mkVersion [3,1,2,3] - _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) - _pkgAuthor desc @?= "Foobar" - _pkgEmail desc @?= "foobar@qux.com" - _pkgHomePage desc @?= "qux.com" - _pkgSynopsis desc @?= "Qux's package" - _pkgCategory desc @?= "Control" - _pkgExtraSrcFiles desc @?= mempty - _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") - - _exeMainIs exe @?= HsFilePath "Main.hs" Standard - _exeApplicationDirs exe @?= ["exe"] - _exeLanguage exe @?= Haskell98 - _exeOtherModules exe @?= [] - _exeOtherExts exe @?= [] - _exeDependencies exe @?! [] - _exeBuildTools exe @?= [] - - Right (ProjectSettings _ _ lib exe test, _) -> do - lib @?= Nothing - exe @?! Nothing - test @?= Nothing - Left e -> assertFailure $ show e +createProjectTest pkgIx srcDb = + testGroup + "createProject tests" + [ testGroup + "with flags" + [ testCase "Check the interactive workflow" $ do + let dummyFlags' = + dummyFlags + { packageType = Flag LibraryAndExecutable + , minimal = Flag False + , overwrite = Flag False + , packageDir = Flag "/home/test/test-package" + , extraSrc = NoFlag + , exposedModules = Flag [] + , otherModules = Flag [] + , otherExts = Flag [] + , buildTools = Flag [] + , mainIs = Flag "quxApp/Main.hs" + , dependencies = Flag [] + } + + case (_runPrompt $ createProject silent pkgIx srcDb dummyFlags') (fromList ["n", "3", "quxTest/Main.hs"]) of + Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= True + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= LibraryAndExecutable + _optPkgName opts @?= mkPackageName "QuxPackage" + + _pkgCabalVersion desc @?= CabalSpecV2_2 + _pkgName desc @?= mkPackageName "QuxPackage" + _pkgVersion desc @?= mkVersion [4, 2, 6] + _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "We are Qux, and this is our package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _libSourceDirs lib @?= ["quxSrc"] + _libLanguage lib @?= Haskell98 + _libExposedModules lib @?= myLibModule :| [] + _libOtherModules lib @?= [] + _libOtherExts lib @?= [] + _libDependencies lib @?= [] + _libBuildTools lib @?= [] + + _exeMainIs exe @?= HsFilePath "quxApp/Main.hs" Standard + _exeApplicationDirs exe @?= ["quxApp"] + _exeLanguage exe @?= Haskell98 + _exeOtherModules exe @?= [] + _exeOtherExts exe @?= [] + _exeDependencies exe @?! [] + _exeBuildTools exe @?= [] + + _testMainIs test @?= HsFilePath "quxTest/Main.hs" Standard + _testDirs test @?= ["quxTest"] + _testLanguage test @?= Haskell98 + _testOtherModules test @?= [] + _testOtherExts test @?= [] + _testDependencies test @?! [] + _testBuildTools test @?= [] + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?! Nothing + test @?! Nothing + Left e -> assertFailure $ show e + ] + , testGroup + "with tests" + [ testCase "Check the interactive library and executable workflow" $ do + let inputs = + fromList + -- package type + [ "3" + , -- overwrite + "n" + , -- package dir + "test-package" + , -- package description + -- cabal version + "4" + , -- package name + "test-package" + , "test-package" + , "test-package" + , -- version + "3.1.2.3" + , -- license + "3" + , -- author + "git username" + , "Foobar" + , -- email + "git email" + , "foobar@qux.com" + , -- homepage + "qux.com" + , -- synopsis + "Qux's package" + , -- category + "3" + , -- library target + -- source dir + "1" + , -- language + "2" + , -- executable target + -- main file + "1" + , -- application dir + "2" + , -- language + "2" + , -- test target + "y" + , -- main file + "1" + , -- test dir + "test" + , -- language + "1" + , -- comments + "y" + ] + + 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 + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= LibraryAndExecutable + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV2_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [3, 1, 2, 3] + _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "Qux's package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell98 + _libExposedModules lib @?= myLibModule :| [] + _libOtherModules lib @?= [] + _libOtherExts lib @?= [] + _libDependencies lib @?! [] + _libBuildTools lib @?= [] + + _exeMainIs exe @?= HsFilePath "Main.hs" Standard + _exeApplicationDirs exe @?= ["exe"] + _exeLanguage exe @?= Haskell98 + _exeOtherModules exe @?= [] + _exeOtherExts exe @?= [] + _exeDependencies exe @?! [] + _exeBuildTools exe @?= [] + + _testMainIs test @?= HsFilePath "Main.hs" Standard + _testDirs test @?= ["test"] + _testLanguage test @?= Haskell2010 + _testOtherModules test @?= [] + _testOtherExts test @?= [] + _testDependencies test @?! [] + _testBuildTools test @?= [] + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?! Nothing + test @?! Nothing + Left e -> assertFailure $ show e + , testCase "Check the interactive library workflow" $ do + let inputs = + fromList + -- package type + [ "1" + , -- overwrite + "n" + , -- package dir + "test-package" + , -- package description + -- cabal version + "4" + , -- package name + "test-package" + , "test-package" + , "test-package" + , -- version + "3.1.2.3" + , -- license + "3" + , -- author + "git username" + , "Foobar" + , -- email + "git email" + , "foobar@qux.com" + , -- homepage + "qux.com" + , -- synopsis + "Qux's package" + , -- category + "3" + , -- library target + -- source dir + "1" + , -- language + "2" + , -- test target + "y" + , -- main file + "1" + , -- test dir + "test" + , -- language + "1" + , -- comments + "y" + ] + + 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 + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= Library + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV2_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [3, 1, 2, 3] + _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "Qux's package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell98 + _libExposedModules lib @?= myLibModule :| [] + _libOtherModules lib @?= [] + _libOtherExts lib @?= [] + _libDependencies lib @?! [] + _libBuildTools lib @?= [] + + _testMainIs test @?= HsFilePath "Main.hs" Standard + _testDirs test @?= ["test"] + _testLanguage test @?= Haskell2010 + _testOtherModules test @?= [] + _testOtherExts test @?= [] + _testDependencies test @?! [] + _testBuildTools test @?= [] + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?= Nothing + test @?! Nothing + Left e -> assertFailure $ show e + , testCase "Check the interactive library workflow" $ do + let inputs = + fromList + -- package type + [ "4" + , -- overwrite + "n" + , -- package dir + "test-package" + , -- package description + -- cabal version + "4" + , -- package name + "test-package" + , "test-package" + , "test-package" + , -- version + "3.1.2.3" + , -- license + "3" + , -- author + "git username" + , "Foobar" + , -- email + "git email" + , "foobar@qux.com" + , -- homepage + "qux.com" + , -- synopsis + "Qux's package" + , -- category + "3" + , -- test target + -- main file + "1" + , -- test dir + "test" + , -- language + "1" + , -- comments + "y" + ] + + case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + Right (ProjectSettings opts desc Nothing Nothing (Just test), _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= TestSuite + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV2_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [3, 1, 2, 3] + _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "Qux's package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _testMainIs test @?= HsFilePath "Main.hs" Standard + _testDirs test @?= ["test"] + _testLanguage test @?= Haskell2010 + _testOtherModules test @?= [] + _testOtherExts test @?= [] + _testDependencies test @?! [] + _testBuildTools test @?= [] + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?= Nothing + exe @?= Nothing + test @?! Nothing + Left e -> assertFailure $ show e + ] + , testGroup + "without tests" + [ testCase "Check the interactive library and executable workflow" $ do + let inputs = + fromList + -- package type + [ "3" + , -- overwrite + "n" + , -- package dir + "test-package" + , -- package description + -- cabal version + "4" + , -- package name + "test-package" + , "test-package" + , "test-package" + , -- version + "3.1.2.3" + , -- license + "3" + , -- author + "git username" + , "Foobar" + , -- email + "git email" + , "foobar@qux.com" + , -- homepage + "qux.com" + , -- synopsis + "Qux's package" + , -- category + "3" + , -- library target + -- source dir + "1" + , -- language + "2" + , -- executable target + -- main file + "1" + , -- application dir + "2" + , -- language + "2" + , -- test suite + "n" + , -- comments + "y" + ] + + 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 + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= LibraryAndExecutable + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV2_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [3, 1, 2, 3] + _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "Qux's package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell98 + _libExposedModules lib @?= myLibModule :| [] + _libOtherModules lib @?= [] + _libOtherExts lib @?= [] + _libDependencies lib @?! [] + _libBuildTools lib @?= [] + + _exeMainIs exe @?= HsFilePath "Main.hs" Standard + _exeApplicationDirs exe @?= ["exe"] + _exeLanguage exe @?= Haskell98 + _exeOtherModules exe @?= [] + _exeOtherExts exe @?= [] + _exeDependencies exe @?! [] + _exeBuildTools exe @?= [] + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?! Nothing + test @?= Nothing + Left e -> assertFailure $ show e + , testCase "Check the interactive library workflow" $ do + let inputs = + fromList + -- package type + [ "1" + , -- overwrite + "n" + , -- package dir + "test-package" + , -- package description + -- cabal version + "4" + , -- package name + "test-package" + , "test-package" + , "test-package" + , -- version + "3.1.2.3" + , -- license + "3" + , -- author + "git username" + , "Foobar" + , -- email + "git email" + , "foobar@qux.com" + , -- homepage + "qux.com" + , -- synopsis + "Qux's package" + , -- category + "3" + , -- library target + -- source dir + "1" + , -- language + "2" + , -- test suite + "n" + , -- comments + "y" + ] + + case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= Library + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV2_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [3, 1, 2, 3] + _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "Qux's package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell98 + _libExposedModules lib @?= myLibModule :| [] + _libOtherModules lib @?= [] + _libOtherExts lib @?= [] + _libDependencies lib @?! [] + _libBuildTools lib @?= [] + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?= Nothing + test @?= Nothing + Left e -> assertFailure $ show e + , testCase "Check the interactive library workflow - cabal < 1.18" $ do + let inputs = + fromList + -- package type + [ "1" + , -- overwrite + "n" + , -- package dir + "test-package" + , -- package description + -- cabal version + "4" + , -- package name + "test-package" + , "test-package" + , "test-package" + , -- version + "3.1.2.3" + , -- license + "3" + , -- author + "git username" + , "Foobar" + , -- email + "git email" + , "foobar@qux.com" + , -- homepage + "qux.com" + , -- synopsis + "Qux's package" + , -- category + "3" + , -- library target + -- source dir + "1" + , -- language + "2" + , -- test suite + "n" + , -- comments + "y" + ] + + flags = + emptyFlags + { cabalVersion = Flag CabalSpecV1_10 + , extraDoc = Flag [defaultChangelog] + , extraSrc = Flag ["README.md"] + } + + case (_runPrompt $ createProject silent pkgIx srcDb flags) inputs of + Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= Library + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV1_10 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [3, 1, 2, 3] + _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "Qux's package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= Set.fromList [defaultChangelog, "README.md"] + _pkgExtraDocFiles desc @?= Nothing + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell98 + _libExposedModules lib @?= myLibModule :| [] + _libOtherModules lib @?= [] + _libOtherExts lib @?= [] + _libDependencies lib @?! [] + _libBuildTools lib @?= [] + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?= Nothing + test @?= Nothing + Left e -> assertFailure $ show e + , testCase "Check the interactive executable workflow" $ do + let inputs = + fromList + -- package type + [ "2" + , -- overwrite + "n" + , -- package dir + "test-package" + , -- package description + -- cabal version + "4" + , -- package name + "test-package" + , "test-package" + , "test-package" + , -- version + "3.1.2.3" + , -- license + "3" + , -- author + "git username" + , "Foobar" + , -- email + "git email" + , "foobar@qux.com" + , -- homepage + "qux.com" + , -- synopsis + "Qux's package" + , -- category + "3" + , -- executable target + -- main file + "1" + , -- application dir + "2" + , -- language + "2" + , -- comments + "y" + ] + + case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + Right (ProjectSettings opts desc Nothing (Just exe) Nothing, _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= Executable + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV2_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [3, 1, 2, 3] + _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "Qux's package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _exeMainIs exe @?= HsFilePath "Main.hs" Standard + _exeApplicationDirs exe @?= ["exe"] + _exeLanguage exe @?= Haskell98 + _exeOtherModules exe @?= [] + _exeOtherExts exe @?= [] + _exeDependencies exe @?! [] + _exeBuildTools exe @?= [] + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?= Nothing + exe @?! Nothing + test @?= Nothing + Left e -> assertFailure $ show e + ] ] - ] fileCreatorTests :: InstalledPackageIndex -> SourcePackageDb -> PackageName -> TestTree -fileCreatorTests pkgIx srcDb _pkgName = testGroup "generators" - [ testGroup "genPkgDescription" - [ testCase "Check common package flags workflow" $ do - let inputs = fromList - [ "1" -- pick the first cabal version in the list - , "my-test-package" -- package name - , "my-test-package" -- current dir for the purpose of guessing the package name - , "y" -- "yes to prompt internal to package name" - , "0.2.0.1" -- package version - , "2" -- pick the second license in the list - , "git username" -- name guessed by calling "git config user.name" - , "Foobar" -- author name - , "git email" -- email guessed by calling "git config user.email" - , "foobar@qux.com" -- maintainer email - , "qux.com" -- package homepage - , "Qux's package" -- package synopsis - , "3" -- pick the third category in the list - ] - runGenTest inputs $ genPkgDescription emptyFlags srcDb - ] - , testGroup "genLibTarget" - [ testCase "Check library package flags workflow" $ do - let inputs = fromList - [ "1" -- pick the first source directory in the list - , "2" -- pick the second language in the list - ] - - runGenTest inputs $ genLibTarget emptyFlags pkgIx - ] - , testGroup "genExeTarget" - [ testCase "Check executable package flags workflow" $ do - let inputs = fromList - [ "1" -- pick the first main file option in the list - , "2" -- pick the second application directory in the list - , "1" -- pick the first language in the list - ] - - runGenTest inputs $ genExeTarget emptyFlags pkgIx - ] - , testGroup "genTestTarget" - [ testCase "Check test package flags workflow" $ do - let inputs = fromList - [ "y" -- say yes to tests - , "1" -- pick the first main file option in the list - , "test" -- package test dir - , "1" -- pick the first language in the list - ] - - runGenTest inputs $ genTestTarget emptyFlags pkgIx +fileCreatorTests pkgIx srcDb _pkgName = + testGroup + "generators" + [ testGroup + "genPkgDescription" + [ testCase "Check common package flags workflow" $ do + let inputs = + fromList + [ "1" -- pick the first cabal version in the list + , "my-test-package" -- package name + , "my-test-package" -- current dir for the purpose of guessing the package name + , "y" -- "yes to prompt internal to package name" + , "0.2.0.1" -- package version + , "2" -- pick the second license in the list + , "git username" -- name guessed by calling "git config user.name" + , "Foobar" -- author name + , "git email" -- email guessed by calling "git config user.email" + , "foobar@qux.com" -- maintainer email + , "qux.com" -- package homepage + , "Qux's package" -- package synopsis + , "3" -- pick the third category in the list + ] + runGenTest inputs $ genPkgDescription emptyFlags srcDb + ] + , testGroup + "genLibTarget" + [ testCase "Check library package flags workflow" $ do + let inputs = + fromList + [ "1" -- pick the first source directory in the list + , "2" -- pick the second language in the list + ] + + runGenTest inputs $ genLibTarget emptyFlags pkgIx + ] + , testGroup + "genExeTarget" + [ testCase "Check executable package flags workflow" $ do + let inputs = + fromList + [ "1" -- pick the first main file option in the list + , "2" -- pick the second application directory in the list + , "1" -- pick the first language in the list + ] + + runGenTest inputs $ genExeTarget emptyFlags pkgIx + ] + , testGroup + "genTestTarget" + [ testCase "Check test package flags workflow" $ do + let inputs = + fromList + [ "y" -- say yes to tests + , "1" -- pick the first main file option in the list + , "test" -- package test dir + , "1" -- pick the first language in the list + ] + + runGenTest inputs $ genTestTarget emptyFlags pkgIx + ] ] - ] where runGenTest inputs go = case _runPrompt go inputs of Left e -> assertFailure $ show e Right{} -> return () interactiveTests :: SourcePackageDb -> TestTree -interactiveTests srcDb = testGroup "Check top level getter functions" - [ testGroup "Simple prompt tests" - [ testGroup "Check packageNamePrompt output" - [ testSimplePrompt "New package name 1" - (packageNamePrompt srcDb) (mkPackageName "test-package") - [ "test-package" - , "test-package" - , "test-package" - ] - , testSimplePrompt "New package name 2" - (packageNamePrompt srcDb) (mkPackageName "test-package") - [ "test-package" - , "test-package" - , "" - ] - , testSimplePrompt "Existing package name 1" - (packageNamePrompt srcDb) (mkPackageName "test-package") - [ "test-package" - , "test-package" - , "cabal-install" - , "y" - , "test-package" - ] - , testSimplePrompt "Existing package name 2" - (packageNamePrompt srcDb) (mkPackageName "cabal-install") - [ "test-package" - , "test-package" - , "cabal-install" - , "n" - ] - ] - , testGroup "Check mainFilePrompt output" - [ testSimplePrompt "New valid main file" - mainFilePrompt defaultMainIs - [ "1" - ] - , testSimplePrompt "New valid other main file" - mainFilePrompt (HsFilePath "Main.hs" Standard) - [ "3" - , "Main.hs" - ] - , testSimplePrompt "Invalid other main file" - mainFilePrompt (HsFilePath "Main.lhs" Literate) - [ "3" - , "Yoink.jl" - , "2" - ] - ] - , testGroup "Check versionPrompt output" - [ testSimplePrompt "Proper PVP" - versionPrompt (mkVersion [0,3,1,0]) - [ "0.3.1.0" - ] - , testSimplePrompt "No PVP" - versionPrompt (mkVersion [0,3,1,0]) - [ "yee-haw" - , "0.3.1.0" - ] - ] - , testGroup "Check synopsisPrompt output" - [ testSimplePrompt "1" synopsisPrompt - "We are Qux, and this is our package" ["We are Qux, and this is our package"] - , testSimplePrompt "2" synopsisPrompt - "Resistance is futile, you will be assimilated" ["Resistance is futile, you will be assimilated"] - ] - , testSimplePrompt "Check authorPrompt output (name supplied by the user)" authorPrompt - "Foobar" ["git username", "Foobar"] - , testSimplePrompt "Check authorPrompt output (name guessed from git config)" authorPrompt - "git username" ["git username", ""] - , testSimplePrompt "Check emailPrompt output (email supplied by the user)" emailPrompt - "foobar@qux.com" ["git email", "foobar@qux.com"] - , testSimplePrompt "Check emailPrompt output (email guessed from git config)" emailPrompt - "git@email" ["git@email", ""] - , testSimplePrompt "Check homepagePrompt output" homepagePrompt - "qux.com" ["qux.com"] - , testSimplePrompt "Check testDirsPrompt output" testDirsPrompt - ["quxTest"] ["quxTest"] - -- this tests 4) other, and can be used to model more inputs in case of failure - , testSimplePrompt "Check srcDirsPrompt output" srcDirsPrompt - ["app"] ["4", "app"] - ] - , testGroup "Numbered prompt tests" - [ testGroup "Check categoryPrompt output" - [ testNumberedPrompt "Category indices" categoryPrompt - defaultCategories - , testSimplePrompt "Other category" - categoryPrompt "Unlisted" - [ show $ P.length defaultCategories + 1 - , "Unlisted" - ] - , testSimplePrompt "No category" - categoryPrompt "" - [ "" - ] - ] - , testGroup "Check licensePrompt output" $ let other = show (1 + P.length defaultLicenseIds) in - [ testNumberedPrompt "License indices" licensePrompt $ - fmap (\l -> SpecLicense . Left . SPDX.License $ SPDX.ELicense (SPDX.ELicenseId l) Nothing) defaultLicenseIds - , testSimplePrompt "Other license 1" - licensePrompt (SpecLicense . Left $ mkLicense SPDX.CC_BY_NC_ND_4_0) - [ other - , "CC-BY-NC-ND-4.0" - ] - , testSimplePrompt "Other license 2" - licensePrompt (SpecLicense . Left $ mkLicense SPDX.D_FSL_1_0) - [ other - , "D-FSL-1.0" +interactiveTests srcDb = + testGroup + "Check top level getter functions" + [ testGroup + "Simple prompt tests" + [ testGroup + "Check packageNamePrompt output" + [ testSimplePrompt + "New package name 1" + (packageNamePrompt srcDb) + (mkPackageName "test-package") + [ "test-package" + , "test-package" + , "test-package" + ] + , testSimplePrompt + "New package name 2" + (packageNamePrompt srcDb) + (mkPackageName "test-package") + [ "test-package" + , "test-package" + , "" + ] + , testSimplePrompt + "Existing package name 1" + (packageNamePrompt srcDb) + (mkPackageName "test-package") + [ "test-package" + , "test-package" + , "cabal-install" + , "y" + , "test-package" + ] + , testSimplePrompt + "Existing package name 2" + (packageNamePrompt srcDb) + (mkPackageName "cabal-install") + [ "test-package" + , "test-package" + , "cabal-install" + , "n" + ] ] - , testSimplePrompt "Other license 3" - licensePrompt (SpecLicense . Left $ mkLicense SPDX.NPOSL_3_0) - [ other - , "NPOSL-3.0" + , testGroup + "Check mainFilePrompt output" + [ testSimplePrompt + "New valid main file" + mainFilePrompt + defaultMainIs + [ "1" + ] + , testSimplePrompt + "New valid other main file" + mainFilePrompt + (HsFilePath "Main.hs" Standard) + [ "3" + , "Main.hs" + ] + , testSimplePrompt + "Invalid other main file" + mainFilePrompt + (HsFilePath "Main.lhs" Literate) + [ "3" + , "Yoink.jl" + , "2" + ] ] - , testSimplePrompt "Invalid license" - licensePrompt (SpecLicense $ Left SPDX.NONE) - [ other - , "yay" - , other - , "NONE" + , testGroup + "Check versionPrompt output" + [ testSimplePrompt + "Proper PVP" + versionPrompt + (mkVersion [0, 3, 1, 0]) + [ "0.3.1.0" + ] + , testSimplePrompt + "No PVP" + versionPrompt + (mkVersion [0, 3, 1, 0]) + [ "yee-haw" + , "0.3.1.0" + ] ] - , testPromptBreak "Invalid index" - licensePrompt - [ "42" + , testGroup + "Check synopsisPrompt output" + [ testSimplePrompt + "1" + synopsisPrompt + "We are Qux, and this is our package" + ["We are Qux, and this is our package"] + , testSimplePrompt + "2" + synopsisPrompt + "Resistance is futile, you will be assimilated" + ["Resistance is futile, you will be assimilated"] ] + , testSimplePrompt + "Check authorPrompt output (name supplied by the user)" + authorPrompt + "Foobar" + ["git username", "Foobar"] + , testSimplePrompt + "Check authorPrompt output (name guessed from git config)" + authorPrompt + "git username" + ["git username", ""] + , testSimplePrompt + "Check emailPrompt output (email supplied by the user)" + emailPrompt + "foobar@qux.com" + ["git email", "foobar@qux.com"] + , testSimplePrompt + "Check emailPrompt output (email guessed from git config)" + emailPrompt + "git@email" + ["git@email", ""] + , testSimplePrompt + "Check homepagePrompt output" + homepagePrompt + "qux.com" + ["qux.com"] + , testSimplePrompt + "Check testDirsPrompt output" + testDirsPrompt + ["quxTest"] + ["quxTest"] + , -- this tests 4) other, and can be used to model more inputs in case of failure + testSimplePrompt + "Check srcDirsPrompt output" + srcDirsPrompt + ["app"] + ["4", "app"] ] - , testGroup "Check languagePrompt output" - [ testNumberedPrompt "Language indices" (`languagePrompt` "test") - [Haskell2010, Haskell98, GHC2021] - , testSimplePrompt "Other language" - (`languagePrompt` "test") (UnknownLanguage "Haskell2022") - [ "4" - , "Haskell2022" + , testGroup + "Numbered prompt tests" + [ testGroup + "Check categoryPrompt output" + [ testNumberedPrompt + "Category indices" + categoryPrompt + defaultCategories + , testSimplePrompt + "Other category" + categoryPrompt + "Unlisted" + [ show $ P.length defaultCategories + 1 + , "Unlisted" + ] + , testSimplePrompt + "No category" + categoryPrompt + "" + [ "" + ] ] - , testSimplePrompt "Invalid language" - (`languagePrompt` "test") (UnknownLanguage "Lang_TS!") - [ "4" - , "Lang_TS!" + , testGroup "Check licensePrompt output" $ + let other = show (1 + P.length defaultLicenseIds) + in [ testNumberedPrompt "License indices" licensePrompt $ + fmap (\l -> SpecLicense . Left . SPDX.License $ SPDX.ELicense (SPDX.ELicenseId l) Nothing) defaultLicenseIds + , testSimplePrompt + "Other license 1" + licensePrompt + (SpecLicense . Left $ mkLicense SPDX.CC_BY_NC_ND_4_0) + [ other + , "CC-BY-NC-ND-4.0" + ] + , testSimplePrompt + "Other license 2" + licensePrompt + (SpecLicense . Left $ mkLicense SPDX.D_FSL_1_0) + [ other + , "D-FSL-1.0" + ] + , testSimplePrompt + "Other license 3" + licensePrompt + (SpecLicense . Left $ mkLicense SPDX.NPOSL_3_0) + [ other + , "NPOSL-3.0" + ] + , testSimplePrompt + "Invalid license" + licensePrompt + (SpecLicense $ Left SPDX.NONE) + [ other + , "yay" + , other + , "NONE" + ] + , testPromptBreak + "Invalid index" + licensePrompt + [ "42" + ] + ] + , testGroup + "Check languagePrompt output" + [ testNumberedPrompt + "Language indices" + (`languagePrompt` "test") + [Haskell2010, Haskell98, GHC2021] + , testSimplePrompt + "Other language" + (`languagePrompt` "test") + (UnknownLanguage "Haskell2022") + [ "4" + , "Haskell2022" + ] + , testSimplePrompt + "Invalid language" + (`languagePrompt` "test") + (UnknownLanguage "Lang_TS!") + [ "4" + , "Lang_TS!" + ] ] - ] - , testGroup "Check srcDirsPrompt output" - [ testNumberedPrompt "Source dirs indices" srcDirsPrompt - [[defaultSourceDir], ["lib"], ["src-lib"]] - , testSimplePrompt "Other source dir" - srcDirsPrompt ["src"] - [ "4" - , "src" + , testGroup + "Check srcDirsPrompt output" + [ testNumberedPrompt + "Source dirs indices" + srcDirsPrompt + [[defaultSourceDir], ["lib"], ["src-lib"]] + , testSimplePrompt + "Other source dir" + srcDirsPrompt + ["src"] + [ "4" + , "src" + ] ] - ] - , testGroup "Check appDirsPrompt output" - [ testNumberedPrompt "App dirs indices" appDirsPrompt - [[defaultApplicationDir], ["exe"], ["src-exe"]] - , testSimplePrompt "Other app dir" - appDirsPrompt ["app"] - [ "4" - , "app" + , testGroup + "Check appDirsPrompt output" + [ testNumberedPrompt + "App dirs indices" + appDirsPrompt + [[defaultApplicationDir], ["exe"], ["src-exe"]] + , testSimplePrompt + "Other app dir" + appDirsPrompt + ["app"] + [ "4" + , "app" + ] ] + , testNumberedPrompt + "Check packageTypePrompt output" + packageTypePrompt + [Library, Executable, LibraryAndExecutable] + , testNumberedPrompt + "Check cabalVersionPrompt output" + cabalVersionPrompt + defaultCabalVersions + ] + , testGroup + "Bool prompt tests" + [ testBoolPrompt "Check noCommentsPrompt output - y" noCommentsPrompt False "y" + , testBoolPrompt "Check noCommentsPrompt output - Y" noCommentsPrompt False "Y" + , testBoolPrompt "Check noCommentsPrompt output - n" noCommentsPrompt True "n" + , testBoolPrompt "Check noCommentsPrompt output - N" noCommentsPrompt True "N" ] - , testNumberedPrompt "Check packageTypePrompt output" packageTypePrompt - [Library, Executable, LibraryAndExecutable] - , testNumberedPrompt "Check cabalVersionPrompt output" cabalVersionPrompt - defaultCabalVersions - ] - , testGroup "Bool prompt tests" - [ testBoolPrompt "Check noCommentsPrompt output - y" noCommentsPrompt False "y" - , testBoolPrompt "Check noCommentsPrompt output - Y" noCommentsPrompt False "Y" - , testBoolPrompt "Check noCommentsPrompt output - n" noCommentsPrompt True "n" - , testBoolPrompt "Check noCommentsPrompt output - N" noCommentsPrompt True "N" ] - ] - - -- -------------------------------------------------------------------- -- -- Prompt test utils - testSimplePrompt - :: Eq a - => Show a - => String - -> (InitFlags -> PurePrompt a) - -> a - -> [String] - -> TestTree + :: Eq a + => Show a + => String + -> (InitFlags -> PurePrompt a) + -> a + -> [String] + -> TestTree testSimplePrompt label f target = - testPrompt label f (assertFailure . show) (\(a,_) -> target @=? a) + testPrompt label f (assertFailure . show) (\(a, _) -> target @=? a) testPromptBreak - :: Eq a - => Show a - => String - -> (InitFlags -> PurePrompt a) - -> [String] - -> TestTree + :: Eq a + => Show a + => String + -> (InitFlags -> PurePrompt a) + -> [String] + -> TestTree testPromptBreak label f = - testPrompt label f go (assertFailure . show) + testPrompt label f go (assertFailure . show) where go BreakException{} = return () testPrompt - :: Eq a - => Show a - => String - -> (InitFlags -> PurePrompt a) - -> (BreakException -> Assertion) - -> ((a, NonEmpty String) -> Assertion) - -> [String] - -> TestTree + :: Eq a + => Show a + => String + -> (InitFlags -> PurePrompt a) + -> (BreakException -> Assertion) + -> ((a, NonEmpty String) -> Assertion) + -> [String] + -> TestTree testPrompt label f g h input = testCase label $ - case (_runPrompt $ f emptyFlags) (fromList input) of - Left x -> g x -- :: BreakException - Right x -> h x -- :: (a, other inputs) + case (_runPrompt $ f emptyFlags) (fromList input) of + Left x -> g x -- :: BreakException + Right x -> h x -- :: (a, other inputs) testNumberedPrompt :: (Eq a, Show a) => String -> (InitFlags -> PurePrompt a) -> [a] -> TestTree testNumberedPrompt label act = testGroup label . (++ goBreak) . fmap go . indexed1 where indexed1 = zip [1 :: Int ..] - mkLabel a n = "testing index " - ++ show n - ++ ") with: " - ++ show a + mkLabel a n = + "testing index " + ++ show n + ++ ") with: " + ++ show a go (n, a) = testSimplePrompt (mkLabel a n) act a [show n] @@ -1028,10 +1128,10 @@ testNumberedPrompt label act = testGroup label . (++ goBreak) . fmap go . indexe ] testBoolPrompt - :: String - -> (InitFlags -> PurePrompt Bool) - -> Bool - -> String - -> TestTree + :: String + -> (InitFlags -> PurePrompt Bool) + -> Bool + -> String + -> TestTree testBoolPrompt label act target b = - testSimplePrompt label act target [b] + testSimplePrompt label act target [b] diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs index d63e8110549..d35ab35a659 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} + module UnitTests.Distribution.Client.Init.NonInteractive ( tests ) where @@ -9,46 +10,51 @@ import Test.Tasty.HUnit import UnitTests.Distribution.Client.Init.Utils import qualified Data.List.NonEmpty as NEL -import qualified Distribution.SPDX as SPDX +import qualified Distribution.SPDX as SPDX +import Data.List (foldl') +import qualified Data.Set as Set +import Distribution.CabalSpecVersion import Distribution.Client.Init.Defaults import Distribution.Client.Init.NonInteractive.Command import Distribution.Client.Init.Types +import Distribution.Client.Init.Utils (mkPackageNameDep, mkStringyDep) +import Distribution.Client.Setup (initCommand) import Distribution.Client.Types +import Distribution.FieldGrammar.Newtypes +import Distribution.ModuleName (fromString) import Distribution.Simple +import Distribution.Simple.Command +import Distribution.Simple.Flag import Distribution.Simple.PackageIndex import Distribution.Verbosity -import Distribution.CabalSpecVersion -import Distribution.ModuleName (fromString) -import Distribution.Simple.Flag -import Data.List (foldl') -import qualified Data.Set as Set -import Distribution.Client.Init.Utils (mkPackageNameDep, mkStringyDep) -import Distribution.FieldGrammar.Newtypes -import Distribution.Simple.Command -import Distribution.Client.Setup (initCommand) tests - :: Verbosity - -> InitFlags - -> Compiler - -> InstalledPackageIndex - -> SourcePackageDb - -> TestTree + :: Verbosity + -> InitFlags + -> Compiler + -> InstalledPackageIndex + -> SourcePackageDb + -> TestTree tests _v _initFlags comp pkgIx srcDb = - testGroup "Distribution.Client.Init.NonInteractive.Command" - [ testGroup "driver function test" - [ driverFunctionTest pkgIx srcDb comp - ] - , testGroup "target creator tests" - [ fileCreatorTests pkgIx srcDb comp - ] - , testGroup "non-interactive tests" - [ nonInteractiveTests pkgIx srcDb comp - ] - , testGroup "cli parser tests" - [ cliListParserTests - ] + testGroup + "Distribution.Client.Init.NonInteractive.Command" + [ testGroup + "driver function test" + [ driverFunctionTest pkgIx srcDb comp + ] + , testGroup + "target creator tests" + [ fileCreatorTests pkgIx srcDb comp + ] + , testGroup + "non-interactive tests" + [ nonInteractiveTests pkgIx srcDb comp + ] + , testGroup + "cli parser tests" + [ cliListParserTests + ] ] driverFunctionTest @@ -56,1191 +62,1312 @@ driverFunctionTest -> SourcePackageDb -> Compiler -> TestTree -driverFunctionTest pkgIx srcDb comp = testGroup "createProject" - [ testGroup "with flags" - [ testCase "Check the non-interactive workflow 1" $ do - let dummyFlags' = dummyFlags - { packageType = Flag LibraryAndExecutable - , minimal = Flag False - , overwrite = Flag False - , packageDir = Flag "/home/test/test-package" - , extraDoc = Flag ["CHANGELOG.md"] - , exposedModules = Flag [] - , otherModules = Flag [] - , otherExts = Flag [] - , buildTools = Flag [] - , mainIs = Flag "quxApp/Main.hs" - , dependencies = Flag [] - } - inputs = NEL.fromList - ["Foobar" - , "foobar@qux.com" - , "True" - , "[\"quxTest/Main.hs\"]" - ] - - 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 - _optNoComments opts @?= True - _optVerbosity opts @?= silent - _optPkgDir opts @?= "/home/test/test-package" - _optPkgType opts @?= LibraryAndExecutable - _optPkgName opts @?= mkPackageName "QuxPackage" - - _pkgCabalVersion desc @?= CabalSpecV2_2 - _pkgName desc @?= mkPackageName "QuxPackage" - _pkgVersion desc @?= mkVersion [4,2,6] - _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) - _pkgAuthor desc @?= "Foobar" - _pkgEmail desc @?= "foobar@qux.com" - _pkgHomePage desc @?= "qux.com" - _pkgSynopsis desc @?= "We are Qux, and this is our package" - _pkgCategory desc @?= "Control" - _pkgExtraSrcFiles desc @?= mempty - _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") - - _libSourceDirs lib @?= ["quxSrc"] - _libLanguage lib @?= Haskell98 - _libExposedModules lib @?= myLibModule NEL.:| [] - _libOtherModules lib @?= [] - _libOtherExts lib @?= [] - _libDependencies lib @?= [] - _libBuildTools lib @?= [] - - _exeMainIs exe @?= HsFilePath "quxApp/Main.hs" Standard - _exeApplicationDirs exe @?= ["quxApp"] - _exeLanguage exe @?= Haskell98 - _exeOtherModules exe @?= [] - _exeOtherExts exe @?= [] - _exeDependencies exe @?! [] - _exeBuildTools exe @?= [] - - _testMainIs test @?= HsFilePath "quxTest/Main.hs" Standard - _testDirs test @?= ["quxTest"] - _testLanguage test @?= Haskell98 - _testOtherModules test @?= [] - _testOtherExts test @?= [] - _testDependencies test @?! [] - _testBuildTools test @?= [] - - assertBool "The library should be a dependency of the executable" $ - mkPackageNameDep (_optPkgName opts) `elem` _exeDependencies exe - assertBool "The library should be a dependency of the test executable" $ - mkPackageNameDep (_optPkgName opts) `elem` _testDependencies test - - Right (ProjectSettings _ _ lib exe test, _) -> do - lib @?! Nothing - exe @?! Nothing - test @?! Nothing - Left e -> assertFailure $ show e - - , testCase "Check the non-interactive workflow 2" $ do - let dummyFlags' = dummyFlags - { packageType = Flag LibraryAndExecutable - , minimal = Flag False - , overwrite = Flag False - , packageDir = Flag "/home/test/test-package" - , extraSrc = Flag [] - , exposedModules = Flag [] - , otherModules = NoFlag - , otherExts = Flag [] - , buildTools = Flag [] - , mainIs = Flag "quxApp/Main.hs" - , dependencies = Flag [] - } - inputs = NEL.fromList - - [ "Foobar" - , "foobar@qux.com" - -- extra sources - , "[\"CHANGELOG.md\"]" - -- lib other modules - , "False" - -- exe other modules - , "False" - -- test main file - , "True" - , "[\"quxTest/Main.hs\"]" - -- test other modules - , "False" - ] - - 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 - _optNoComments opts @?= True - _optVerbosity opts @?= silent - _optPkgDir opts @?= "/home/test/test-package" - _optPkgType opts @?= LibraryAndExecutable - _optPkgName opts @?= mkPackageName "QuxPackage" - - _pkgCabalVersion desc @?= CabalSpecV2_2 - _pkgName desc @?= mkPackageName "QuxPackage" - _pkgVersion desc @?= mkVersion [4,2,6] - _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) - _pkgAuthor desc @?= "Foobar" - _pkgEmail desc @?= "foobar@qux.com" - _pkgHomePage desc @?= "qux.com" - _pkgSynopsis desc @?= "We are Qux, and this is our package" - _pkgCategory desc @?= "Control" - _pkgExtraSrcFiles desc @?= mempty - _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") - - _libSourceDirs lib @?= ["quxSrc"] - _libLanguage lib @?= Haskell98 - _libExposedModules lib @?= myLibModule NEL.:| [] - _libOtherModules lib @?= [] - _libOtherExts lib @?= [] - _libDependencies lib @?= [] - _libBuildTools lib @?= [] - - _exeMainIs exe @?= HsFilePath "quxApp/Main.hs" Standard - _exeApplicationDirs exe @?= ["quxApp"] - _exeLanguage exe @?= Haskell98 - _exeOtherModules exe @?= [] - _exeOtherExts exe @?= [] - _exeDependencies exe @?! [] - _exeBuildTools exe @?= [] - - _testMainIs test @?= HsFilePath "quxTest/Main.hs" Standard - _testDirs test @?= ["quxTest"] - _testLanguage test @?= Haskell98 - _testOtherModules test @?= [] - _testOtherExts test @?= [] - _testDependencies test @?! [] - _testBuildTools test @?= [] - - assertBool "The library should be a dependency of the executable" $ - mkPackageNameDep (_optPkgName opts) `elem` _exeDependencies exe - assertBool "The library should be a dependency of the test executable" $ - mkPackageNameDep (_optPkgName opts) `elem` _testDependencies test - - Right (ProjectSettings _ _ lib exe test, _) -> do - lib @?! Nothing - exe @?! Nothing - test @?! Nothing - Left e -> assertFailure $ show e - ] - , testGroup "with tests" - [ testCase "Check the non-interactive library and executable workflow" $ do - let inputs = NEL.fromList - -- package dir - [ "test-package" - -- package description - -- cabal version - , "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n" - -- package name - , "test-package" - , "test-package" - -- author name - , "" - , "Foobar" - -- author email - , "" - , "foobar@qux.com" - -- extra source files - , "test-package" - , "[]" - -- library target - -- source dirs - , "src" - , "True" - -- exposed modules - , "src" - , "True" - , "True" - , "[\"src/Foo.hs\", \"src/Bar.hs\"]" - , "module Foo where" - , "module Bar where" - , "test-package" - , "True" - , "[\"src/Foo.hs\", \"src/Bar.hs\"]" - , "module Foo where" - , "module Bar where" - -- other modules - , "test-package" - , "True" - , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]" - , "module Foo where" - , "module Bar where" - , "module Baz.Internal where" - -- other extensions - , "True" - , "[\"src/Foo.hs\", \"src/Bar.hs\"]" - , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" - , "\"{-# LANGUAGE RecordWildCards #-}\"" - -- dependencies - , "True" - , "[\"src/Foo.hs\"]" - , "True" - , "test-package" - , "module Main where" - , "import Control.Monad.Extra" - , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" - -- build tools - , "True" - , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" - -- executable target - -- application dirs - , "app" - , "[]" - -- main file - , "test-package" - , "[\"test-package/app/\"]" - , "True" - , "[]" - -- other modules - , "test-package" - , "True" - , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]" - , "module Foo where" - , "module Bar where" - -- other extensions - , "True" - , "[\"app/Foo.hs\", \"app/Bar.hs\"]" - , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" - , "\"{-# LANGUAGE RecordWildCards #-}\"" - -- dependencies - , "True" - , "[\"app/Main.hs\"]" - , "True" - , "test-package" - , "module Main where" - , "import Control.Monad.Extra" - , "{-# LANGUAGE OverloadedStrings, DataKinds #-}" - -- build tools - , "True" - , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" - -- test target - -- main file - , "True" - , "[\"test-package/test/\"]" - -- other modules - , "test-package" - , "True" - , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]" - , "module Foo where" - , "module Bar where" - -- other extensions - , "True" - , "[\"test/Foo.hs\", \"test/Bar.hs\"]" - , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" - , "\"{-# LANGUAGE RecordWildCards #-}\"" - -- dependencies - , "True" - , "[\"test/Main.hs\"]" - , "True" - , "test-package" - , "module Main where" - , "import Test.Tasty\nimport Test.Tasty.HUnit" - , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" - -- build tools - , "True" - , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/bar.y\"]" - ] - - case (_runPrompt $ createProject comp silent pkgIx srcDb (emptyFlags - { initializeTestSuite = Flag True - , packageType = Flag LibraryAndExecutable - })) inputs of - Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do - _optOverwrite opts @?= False - _optMinimal opts @?= False - _optNoComments opts @?= False - _optVerbosity opts @?= silent - _optPkgDir opts @?= "/home/test/test-package" - _optPkgType opts @?= LibraryAndExecutable - _optPkgName opts @?= mkPackageName "test-package" - - _pkgCabalVersion desc @?= CabalSpecV3_4 - _pkgName desc @?= mkPackageName "test-package" - _pkgVersion desc @?= mkVersion [0,1,0,0] - _pkgLicense desc @?= (SpecLicense . Left $ SPDX.NONE) - _pkgAuthor desc @?= "Foobar" - _pkgEmail desc @?= "foobar@qux.com" - _pkgHomePage desc @?= "" - _pkgSynopsis desc @?= "" - _pkgCategory desc @?= "" - _pkgExtraSrcFiles desc @?= mempty - _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") - - _libSourceDirs lib @?= ["src"] - _libLanguage lib @?= Haskell2010 - _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"]) - _libOtherModules lib @?= map fromString ["Baz.Internal"] - _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] - _libDependencies lib @?! [] - _libBuildTools lib @?= [mkStringyDep "happy:happy"] - - _exeMainIs exe @?= HsFilePath "Main.hs" Standard - _exeApplicationDirs exe @?= ["app"] - _exeLanguage exe @?= Haskell2010 - _exeOtherModules exe @?= map fromString ["Foo", "Bar"] - _exeOtherExts exe @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] - _exeDependencies exe @?! [] - _exeBuildTools exe @?= [mkStringyDep "happy:happy"] - - _testMainIs test @?= HsFilePath "Main.hs" Standard - _testDirs test @?= ["test"] - _testLanguage test @?= Haskell2010 - _testOtherModules test @?= map fromString ["Foo", "Bar"] - _testOtherExts test @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] - _testDependencies test @?! [] - _testBuildTools test @?= [mkStringyDep "happy:happy"] - - assertBool "The library should be a dependency of the executable" $ - mkPackageNameDep (_optPkgName opts) `elem` _exeDependencies exe - assertBool "The library should be a dependency of the test executable" $ - mkPackageNameDep (_optPkgName opts) `elem` _testDependencies test - - Right (ProjectSettings _ _ lib exe test, _) -> do - lib @?! Nothing - exe @?! Nothing - test @?! Nothing - Left e -> assertFailure $ show e - - , testCase "Check the non-interactive library workflow" $ do - let inputs = NEL.fromList - -- package dir - [ "test-package" - -- package description - -- cabal version - , "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n" - -- package name - , "test-package" - , "test-package" - -- author name - , "Foobar" - -- author email - , "foobar@qux.com" - -- extra source files - , "test-package" - , "[]" - -- library target - -- source dirs - , "src" - , "True" - -- exposed modules - , "src" - , "True" - , "True" - , "[\"src/Foo.hs\", \"src/Bar.hs\"]" - , "module Foo where" - , "module Bar where" - , "test-package" - , "True" - , "[\"src/Foo.hs\", \"src/Bar.hs\"]" - , "module Foo where" - , "module Bar where" - -- other modules - , "test-package" - , "True" - , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]" - , "module Foo where" - , "module Bar where" - , "module Baz.Internal where" - -- other extensions - , "True" - , "[\"src/Foo.hs\", \"src/Bar.hs\"]" - , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" - , "\"{-# LANGUAGE RecordWildCards #-}\"" - -- dependencies - , "True" - , "[\"src/Foo.hs\"]" - , "True" - , "test-package" - , "module Main where" - , "import Control.Monad.Extra" - , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" - -- build tools - , "True" - , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" - -- test target - -- main file - , "True" - , "[\"test-package/test/\"]" - -- other modules - , "test-package" - , "True" - , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]" - , "module Foo where" - , "module Bar where" - -- other extensions - , "True" - , "[\"test/Foo.hs\", \"test/Bar.hs\"]" - , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" - , "\"{-# LANGUAGE RecordWildCards #-}\"" - -- dependencies - , "True" - , "[\"test/Main.hs\"]" - , "True" - , "test-package" - , "module Main where" - , "import Test.Tasty\nimport Test.Tasty.HUnit" - , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" - -- build tools - , "True" - , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/bar.y\"]" - ] - - case (_runPrompt $ createProject comp silent pkgIx srcDb (emptyFlags - { initializeTestSuite = Flag True - , packageType = Flag Library - })) inputs of - Right (ProjectSettings opts desc (Just lib) Nothing (Just test), _) -> do - _optOverwrite opts @?= False - _optMinimal opts @?= False - _optNoComments opts @?= False - _optVerbosity opts @?= silent - _optPkgDir opts @?= "/home/test/test-package" - _optPkgType opts @?= Library - _optPkgName opts @?= mkPackageName "test-package" - - _pkgCabalVersion desc @?= CabalSpecV3_4 - _pkgName desc @?= mkPackageName "test-package" - _pkgVersion desc @?= mkVersion [0,1,0,0] - _pkgLicense desc @?= (SpecLicense . Left $ SPDX.NONE) - _pkgAuthor desc @?= "Foobar" - _pkgEmail desc @?= "foobar@qux.com" - _pkgHomePage desc @?= "" - _pkgSynopsis desc @?= "" - _pkgCategory desc @?= "" - _pkgExtraSrcFiles desc @?= mempty - _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") - - _libSourceDirs lib @?= ["src"] - _libLanguage lib @?= Haskell2010 - _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"]) - _libOtherModules lib @?= map fromString ["Baz.Internal"] - _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] - _libDependencies lib @?! [] - _libBuildTools lib @?= [mkStringyDep "happy:happy"] - - _testMainIs test @?= HsFilePath "Main.hs" Standard - _testDirs test @?= ["test"] - _testLanguage test @?= Haskell2010 - _testOtherModules test @?= map fromString ["Foo", "Bar"] - _testOtherExts test @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] - _testDependencies test @?! [] - _testBuildTools test @?= [mkStringyDep "happy:happy"] - - assertBool "The library should be a dependency of the test executable" $ - mkPackageNameDep (_optPkgName opts) `elem` _testDependencies test - - Right (ProjectSettings _ _ lib exe test, _) -> do - lib @?! Nothing - exe @?= Nothing - test @?! Nothing - Left e -> assertFailure $ show e - ] - , testGroup "without tests" - [ testCase "Check the non-interactive library and executable workflow" $ do - let inputs = NEL.fromList - -- package type - [ "test-package" - , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]" - , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]" - -- package dir - , "test-package" - -- package description - -- cabal version - , "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n" - -- package name - , "test-package" - , "test-package" - -- author name - , "" - , "Foobar" - -- author email - , "" - , "foobar@qux.com" - -- extra source files - , "test-package" - , "[]" - -- library target - -- source dirs - , "src" - , "True" - -- exposed modules - , "src" - , "True" - , "True" - , "[\"src/Foo.hs\", \"src/Bar.hs\"]" - , "module Foo where" - , "module Bar where" - , "test-package" - , "True" - , "[\"src/Foo.hs\", \"src/Bar.hs\"]" - , "module Foo where" - , "module Bar where" - -- other modules - , "test-package" - , "True" - , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]" - , "module Foo where" - , "module Bar where" - , "module Baz.Internal where" - -- other extensions - , "True" - , "[\"src/Foo.hs\", \"src/Bar.hs\"]" - , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" - , "\"{-# LANGUAGE RecordWildCards #-}\"" - -- dependencies - , "True" - , "[\"src/Foo.hs\"]" - , "True" - , "test-package" - , "module Main where" - , "import Control.Monad.Extra" - , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" - -- build tools - , "True" - , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" - -- executable target - -- application dirs - , "app" - , "[]" - -- main file - , "test-package" - , "[\"test-package/app/\"]" - , "True" - , "[]" - -- other modules - , "test-package" - , "True" - , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]" - , "module Foo where" - , "module Bar where" - -- other extensions - , "True" - , "[\"app/Foo.hs\", \"app/Bar.hs\"]" - , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" - , "\"{-# LANGUAGE RecordWildCards #-}\"" - -- dependencies - , "True" - , "[\"app/Main.hs\"]" - , "True" - , "test-package" - , "module Main where" - , "import Control.Monad.Extra" - , "{-# LANGUAGE OverloadedStrings, DataKinds #-}" - -- build tools - , "True" - , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" - ] - - 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 - _optNoComments opts @?= False - _optVerbosity opts @?= silent - _optPkgDir opts @?= "/home/test/test-package" - _optPkgType opts @?= LibraryAndExecutable - _optPkgName opts @?= mkPackageName "test-package" - - _pkgCabalVersion desc @?= CabalSpecV3_4 - _pkgName desc @?= mkPackageName "test-package" - _pkgVersion desc @?= mkVersion [0,1,0,0] - _pkgLicense desc @?= (SpecLicense . Left $ SPDX.NONE) - _pkgAuthor desc @?= "Foobar" - _pkgEmail desc @?= "foobar@qux.com" - _pkgHomePage desc @?= "" - _pkgSynopsis desc @?= "" - _pkgCategory desc @?= "" - _pkgExtraSrcFiles desc @?= mempty - _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") - - _libSourceDirs lib @?= ["src"] - _libLanguage lib @?= Haskell2010 - _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"]) - _libOtherModules lib @?= map fromString ["Baz.Internal"] - _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] - _libDependencies lib @?! [] - _libBuildTools lib @?= [mkStringyDep "happy:happy"] - - _exeMainIs exe @?= HsFilePath "Main.hs" Standard - _exeApplicationDirs exe @?= ["app"] - _exeLanguage exe @?= Haskell2010 - _exeOtherModules exe @?= map fromString ["Foo", "Bar"] - _exeOtherExts exe @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] - _exeDependencies exe @?! [] - _exeBuildTools exe @?= [mkStringyDep "happy:happy"] - - assertBool "The library should be a dependency of the executable" $ - mkPackageNameDep (_optPkgName opts) `elem` _exeDependencies exe - - Right (ProjectSettings _ _ lib exe test, _) -> do - lib @?! Nothing - exe @?! Nothing - test @?= Nothing - Left e -> assertFailure $ show e - - , testCase "Check the non-interactive library workflow" $ do - let inputs = NEL.fromList - -- package type - [ "test-package" - , "[\".\", \"..\", \"src/\"]" - , "[\".\", \"..\", \"src/\"]" - -- package dir - , "test-package" - -- package description - -- cabal version - , "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n" - -- package name - , "test-package" - , "test-package" - -- author name - , "" - , "Foobar" - -- author email - , "" - , "foobar@qux.com" - -- extra source files - , "test-package" - , "[]" - -- library target - -- source dirs - , "src" - , "True" - -- exposed modules - , "src" - , "True" - , "True" - , "[\"src/Foo.hs\", \"src/Bar.hs\"]" - , "module Foo where" - , "module Bar where" - , "test-package" - , "True" - , "[\"src/Foo.hs\", \"src/Bar.hs\"]" - , "module Foo where" - , "module Bar where" - -- other modules - , "test-package" - , "True" - , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]" - , "module Foo where" - , "module Bar where" - , "module Baz.Internal where" - -- other extensions - , "True" - , "[\"src/Foo.hs\", \"src/Bar.hs\"]" - , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" - , "\"{-# LANGUAGE RecordWildCards #-}\"" - -- dependencies - , "True" - , "[\"src/Foo.hs\"]" - , "True" - , "test-package" - , "module Main where" - , "import Control.Monad.Extra" - , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" - -- build tools - , "True" - , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" - ] - - 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 - _optNoComments opts @?= False - _optVerbosity opts @?= silent - _optPkgDir opts @?= "/home/test/test-package" - _optPkgType opts @?= Library - _optPkgName opts @?= mkPackageName "test-package" - - _pkgCabalVersion desc @?= CabalSpecV3_4 - _pkgName desc @?= mkPackageName "test-package" - _pkgVersion desc @?= mkVersion [0,1,0,0] - _pkgLicense desc @?= (SpecLicense . Left $ SPDX.NONE) - _pkgAuthor desc @?= "Foobar" - _pkgEmail desc @?= "foobar@qux.com" - _pkgHomePage desc @?= "" - _pkgSynopsis desc @?= "" - _pkgCategory desc @?= "" - _pkgExtraSrcFiles desc @?= mempty - _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") - - _libSourceDirs lib @?= ["src"] - _libLanguage lib @?= Haskell2010 - _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"]) - _libOtherModules lib @?= map fromString ["Baz.Internal"] - _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] - _libDependencies lib @?! [] - _libBuildTools lib @?= [mkStringyDep "happy:happy"] - - Right (ProjectSettings _ _ lib exe test, _) -> do - lib @?! Nothing - exe @?= Nothing - test @?= Nothing - Left e -> assertFailure $ show e - - , testCase "Check the non-interactive executable workflow" $ do - let inputs = NEL.fromList - -- package type - [ "test-package" - , "[\".\", \"..\", \"app/Main.hs\"]" - , "[\".\", \"..\", \"app/Main.hs\"]" - -- package dir - , "test-package" - -- package description - -- cabal version - , "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n" - -- package name - , "test-package" - , "test-package" - -- author name - , "" - , "Foobar" - -- author email - , "" - , "foobar@qux.com" - -- extra source files - , "test-package" - , "[]" - -- executable target - -- application dirs - , "app" - , "[]" - -- main file - , "test-package" - , "[\"test-package/app/\"]" - , "True" - , "[]" - -- other modules - , "test-package" - , "True" - , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]" - , "module Foo where" - , "module Bar where" - -- other extensions - , "True" - , "[\"app/Foo.hs\", \"app/Bar.hs\"]" - , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" - , "\"{-# LANGUAGE RecordWildCards #-}\"" - -- dependencies - , "True" - , "[\"app/Main.hs\"]" - , "True" - , "test-package" - , "module Main where" - , "import Control.Monad.Extra" - , "{-# LANGUAGE OverloadedStrings, DataKinds #-}" - -- build tools - , "True" - , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" - ] - - 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 - _optNoComments opts @?= False - _optVerbosity opts @?= silent - _optPkgDir opts @?= "/home/test/test-package" - _optPkgType opts @?= Executable - _optPkgName opts @?= mkPackageName "test-package" - - _pkgCabalVersion desc @?= CabalSpecV3_4 - _pkgName desc @?= mkPackageName "test-package" - _pkgVersion desc @?= mkVersion [0,1,0,0] - _pkgLicense desc @?= (SpecLicense . Left $ SPDX.NONE) - _pkgAuthor desc @?= "Foobar" - _pkgEmail desc @?= "foobar@qux.com" - _pkgHomePage desc @?= "" - _pkgSynopsis desc @?= "" - _pkgCategory desc @?= "" - _pkgExtraSrcFiles desc @?= mempty - _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") - - _exeMainIs exe @?= HsFilePath "Main.hs" Standard - _exeApplicationDirs exe @?= ["app"] - _exeLanguage exe @?= Haskell2010 - _exeOtherModules exe @?= map fromString ["Foo", "Bar"] - _exeOtherExts exe @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] - _exeDependencies exe @?! [] - _exeBuildTools exe @?= [mkStringyDep "happy:happy"] - - Right (ProjectSettings _ _ lib exe test, _) -> do - lib @?= Nothing - exe @?! Nothing - test @?= Nothing - Left e -> assertFailure $ show e +driverFunctionTest pkgIx srcDb comp = + testGroup + "createProject" + [ testGroup + "with flags" + [ testCase "Check the non-interactive workflow 1" $ do + let dummyFlags' = + dummyFlags + { packageType = Flag LibraryAndExecutable + , minimal = Flag False + , overwrite = Flag False + , packageDir = Flag "/home/test/test-package" + , extraDoc = Flag ["CHANGELOG.md"] + , exposedModules = Flag [] + , otherModules = Flag [] + , otherExts = Flag [] + , buildTools = Flag [] + , mainIs = Flag "quxApp/Main.hs" + , dependencies = Flag [] + } + inputs = + NEL.fromList + [ "Foobar" + , "foobar@qux.com" + , "True" + , "[\"quxTest/Main.hs\"]" + ] + + 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 + _optNoComments opts @?= True + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= LibraryAndExecutable + _optPkgName opts @?= mkPackageName "QuxPackage" + + _pkgCabalVersion desc @?= CabalSpecV2_2 + _pkgName desc @?= mkPackageName "QuxPackage" + _pkgVersion desc @?= mkVersion [4, 2, 6] + _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "We are Qux, and this is our package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _libSourceDirs lib @?= ["quxSrc"] + _libLanguage lib @?= Haskell98 + _libExposedModules lib @?= myLibModule NEL.:| [] + _libOtherModules lib @?= [] + _libOtherExts lib @?= [] + _libDependencies lib @?= [] + _libBuildTools lib @?= [] + + _exeMainIs exe @?= HsFilePath "quxApp/Main.hs" Standard + _exeApplicationDirs exe @?= ["quxApp"] + _exeLanguage exe @?= Haskell98 + _exeOtherModules exe @?= [] + _exeOtherExts exe @?= [] + _exeDependencies exe @?! [] + _exeBuildTools exe @?= [] + + _testMainIs test @?= HsFilePath "quxTest/Main.hs" Standard + _testDirs test @?= ["quxTest"] + _testLanguage test @?= Haskell98 + _testOtherModules test @?= [] + _testOtherExts test @?= [] + _testDependencies test @?! [] + _testBuildTools test @?= [] + + assertBool "The library should be a dependency of the executable" $ + mkPackageNameDep (_optPkgName opts) `elem` _exeDependencies exe + assertBool "The library should be a dependency of the test executable" $ + mkPackageNameDep (_optPkgName opts) `elem` _testDependencies test + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?! Nothing + test @?! Nothing + Left e -> assertFailure $ show e + , testCase "Check the non-interactive workflow 2" $ do + let dummyFlags' = + dummyFlags + { packageType = Flag LibraryAndExecutable + , minimal = Flag False + , overwrite = Flag False + , packageDir = Flag "/home/test/test-package" + , extraSrc = Flag [] + , exposedModules = Flag [] + , otherModules = NoFlag + , otherExts = Flag [] + , buildTools = Flag [] + , mainIs = Flag "quxApp/Main.hs" + , dependencies = Flag [] + } + inputs = + NEL.fromList + [ "Foobar" + , "foobar@qux.com" + , -- extra sources + "[\"CHANGELOG.md\"]" + , -- lib other modules + "False" + , -- exe other modules + "False" + , -- test main file + "True" + , "[\"quxTest/Main.hs\"]" + , -- test other modules + "False" + ] + + 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 + _optNoComments opts @?= True + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= LibraryAndExecutable + _optPkgName opts @?= mkPackageName "QuxPackage" + + _pkgCabalVersion desc @?= CabalSpecV2_2 + _pkgName desc @?= mkPackageName "QuxPackage" + _pkgVersion desc @?= mkVersion [4, 2, 6] + _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "qux.com" + _pkgSynopsis desc @?= "We are Qux, and this is our package" + _pkgCategory desc @?= "Control" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _libSourceDirs lib @?= ["quxSrc"] + _libLanguage lib @?= Haskell98 + _libExposedModules lib @?= myLibModule NEL.:| [] + _libOtherModules lib @?= [] + _libOtherExts lib @?= [] + _libDependencies lib @?= [] + _libBuildTools lib @?= [] + + _exeMainIs exe @?= HsFilePath "quxApp/Main.hs" Standard + _exeApplicationDirs exe @?= ["quxApp"] + _exeLanguage exe @?= Haskell98 + _exeOtherModules exe @?= [] + _exeOtherExts exe @?= [] + _exeDependencies exe @?! [] + _exeBuildTools exe @?= [] + + _testMainIs test @?= HsFilePath "quxTest/Main.hs" Standard + _testDirs test @?= ["quxTest"] + _testLanguage test @?= Haskell98 + _testOtherModules test @?= [] + _testOtherExts test @?= [] + _testDependencies test @?! [] + _testBuildTools test @?= [] + + assertBool "The library should be a dependency of the executable" $ + mkPackageNameDep (_optPkgName opts) `elem` _exeDependencies exe + assertBool "The library should be a dependency of the test executable" $ + mkPackageNameDep (_optPkgName opts) `elem` _testDependencies test + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?! Nothing + test @?! Nothing + Left e -> assertFailure $ show e + ] + , testGroup + "with tests" + [ testCase "Check the non-interactive library and executable workflow" $ do + let inputs = + NEL.fromList + -- package dir + [ "test-package" + , -- package description + -- cabal version + "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n" + , -- package name + "test-package" + , "test-package" + , -- author name + "" + , "Foobar" + , -- author email + "" + , "foobar@qux.com" + , -- extra source files + "test-package" + , "[]" + , -- library target + -- source dirs + "src" + , "True" + , -- exposed modules + "src" + , "True" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , -- other modules + "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]" + , "module Foo where" + , "module Bar where" + , "module Baz.Internal where" + , -- other extensions + "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + , -- dependencies + "True" + , "[\"src/Foo.hs\"]" + , "True" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + , -- build tools + "True" + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + , -- executable target + -- application dirs + "app" + , "[]" + , -- main file + "test-package" + , "[\"test-package/app/\"]" + , "True" + , "[]" + , -- other modules + "test-package" + , "True" + , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , -- other extensions + "True" + , "[\"app/Foo.hs\", \"app/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + , -- dependencies + "True" + , "[\"app/Main.hs\"]" + , "True" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, DataKinds #-}" + , -- build tools + "True" + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + , -- test target + -- main file + "True" + , "[\"test-package/test/\"]" + , -- other modules + "test-package" + , "True" + , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , -- other extensions + "True" + , "[\"test/Foo.hs\", \"test/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + , -- dependencies + "True" + , "[\"test/Main.hs\"]" + , "True" + , "test-package" + , "module Main where" + , "import Test.Tasty\nimport Test.Tasty.HUnit" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + , -- build tools + "True" + , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/bar.y\"]" + ] + + case ( _runPrompt $ + createProject + comp + silent + pkgIx + srcDb + ( emptyFlags + { initializeTestSuite = Flag True + , packageType = Flag LibraryAndExecutable + } + ) + ) + inputs of + Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= LibraryAndExecutable + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV3_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [0, 1, 0, 0] + _pkgLicense desc @?= (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "" + _pkgSynopsis desc @?= "" + _pkgCategory desc @?= "" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell2010 + _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"]) + _libOtherModules lib @?= map fromString ["Baz.Internal"] + _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _libDependencies lib @?! [] + _libBuildTools lib @?= [mkStringyDep "happy:happy"] + + _exeMainIs exe @?= HsFilePath "Main.hs" Standard + _exeApplicationDirs exe @?= ["app"] + _exeLanguage exe @?= Haskell2010 + _exeOtherModules exe @?= map fromString ["Foo", "Bar"] + _exeOtherExts exe @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _exeDependencies exe @?! [] + _exeBuildTools exe @?= [mkStringyDep "happy:happy"] + + _testMainIs test @?= HsFilePath "Main.hs" Standard + _testDirs test @?= ["test"] + _testLanguage test @?= Haskell2010 + _testOtherModules test @?= map fromString ["Foo", "Bar"] + _testOtherExts test @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _testDependencies test @?! [] + _testBuildTools test @?= [mkStringyDep "happy:happy"] + + assertBool "The library should be a dependency of the executable" $ + mkPackageNameDep (_optPkgName opts) `elem` _exeDependencies exe + assertBool "The library should be a dependency of the test executable" $ + mkPackageNameDep (_optPkgName opts) `elem` _testDependencies test + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?! Nothing + test @?! Nothing + Left e -> assertFailure $ show e + , testCase "Check the non-interactive library workflow" $ do + let inputs = + NEL.fromList + -- package dir + [ "test-package" + , -- package description + -- cabal version + "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n" + , -- package name + "test-package" + , "test-package" + , -- author name + "Foobar" + , -- author email + "foobar@qux.com" + , -- extra source files + "test-package" + , "[]" + , -- library target + -- source dirs + "src" + , "True" + , -- exposed modules + "src" + , "True" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , -- other modules + "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]" + , "module Foo where" + , "module Bar where" + , "module Baz.Internal where" + , -- other extensions + "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + , -- dependencies + "True" + , "[\"src/Foo.hs\"]" + , "True" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + , -- build tools + "True" + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + , -- test target + -- main file + "True" + , "[\"test-package/test/\"]" + , -- other modules + "test-package" + , "True" + , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , -- other extensions + "True" + , "[\"test/Foo.hs\", \"test/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + , -- dependencies + "True" + , "[\"test/Main.hs\"]" + , "True" + , "test-package" + , "module Main where" + , "import Test.Tasty\nimport Test.Tasty.HUnit" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + , -- build tools + "True" + , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/bar.y\"]" + ] + + case ( _runPrompt $ + createProject + comp + silent + pkgIx + srcDb + ( emptyFlags + { initializeTestSuite = Flag True + , packageType = Flag Library + } + ) + ) + inputs of + Right (ProjectSettings opts desc (Just lib) Nothing (Just test), _) -> do + _optOverwrite opts @?= False + _optMinimal opts @?= False + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= Library + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV3_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [0, 1, 0, 0] + _pkgLicense desc @?= (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "" + _pkgSynopsis desc @?= "" + _pkgCategory desc @?= "" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell2010 + _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"]) + _libOtherModules lib @?= map fromString ["Baz.Internal"] + _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _libDependencies lib @?! [] + _libBuildTools lib @?= [mkStringyDep "happy:happy"] + + _testMainIs test @?= HsFilePath "Main.hs" Standard + _testDirs test @?= ["test"] + _testLanguage test @?= Haskell2010 + _testOtherModules test @?= map fromString ["Foo", "Bar"] + _testOtherExts test @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _testDependencies test @?! [] + _testBuildTools test @?= [mkStringyDep "happy:happy"] + + assertBool "The library should be a dependency of the test executable" $ + mkPackageNameDep (_optPkgName opts) `elem` _testDependencies test + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?= Nothing + test @?! Nothing + Left e -> assertFailure $ show e + ] + , testGroup + "without tests" + [ testCase "Check the non-interactive library and executable workflow" $ do + let inputs = + NEL.fromList + -- package type + [ "test-package" + , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]" + , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]" + , -- package dir + "test-package" + , -- package description + -- cabal version + "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n" + , -- package name + "test-package" + , "test-package" + , -- author name + "" + , "Foobar" + , -- author email + "" + , "foobar@qux.com" + , -- extra source files + "test-package" + , "[]" + , -- library target + -- source dirs + "src" + , "True" + , -- exposed modules + "src" + , "True" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , -- other modules + "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]" + , "module Foo where" + , "module Bar where" + , "module Baz.Internal where" + , -- other extensions + "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + , -- dependencies + "True" + , "[\"src/Foo.hs\"]" + , "True" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + , -- build tools + "True" + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + , -- executable target + -- application dirs + "app" + , "[]" + , -- main file + "test-package" + , "[\"test-package/app/\"]" + , "True" + , "[]" + , -- other modules + "test-package" + , "True" + , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , -- other extensions + "True" + , "[\"app/Foo.hs\", \"app/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + , -- dependencies + "True" + , "[\"app/Main.hs\"]" + , "True" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, DataKinds #-}" + , -- build tools + "True" + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + ] + + 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 + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= LibraryAndExecutable + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV3_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [0, 1, 0, 0] + _pkgLicense desc @?= (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "" + _pkgSynopsis desc @?= "" + _pkgCategory desc @?= "" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell2010 + _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"]) + _libOtherModules lib @?= map fromString ["Baz.Internal"] + _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _libDependencies lib @?! [] + _libBuildTools lib @?= [mkStringyDep "happy:happy"] + + _exeMainIs exe @?= HsFilePath "Main.hs" Standard + _exeApplicationDirs exe @?= ["app"] + _exeLanguage exe @?= Haskell2010 + _exeOtherModules exe @?= map fromString ["Foo", "Bar"] + _exeOtherExts exe @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _exeDependencies exe @?! [] + _exeBuildTools exe @?= [mkStringyDep "happy:happy"] + + assertBool "The library should be a dependency of the executable" $ + mkPackageNameDep (_optPkgName opts) `elem` _exeDependencies exe + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?! Nothing + test @?= Nothing + Left e -> assertFailure $ show e + , testCase "Check the non-interactive library workflow" $ do + let inputs = + NEL.fromList + -- package type + [ "test-package" + , "[\".\", \"..\", \"src/\"]" + , "[\".\", \"..\", \"src/\"]" + , -- package dir + "test-package" + , -- package description + -- cabal version + "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n" + , -- package name + "test-package" + , "test-package" + , -- author name + "" + , "Foobar" + , -- author email + "" + , "foobar@qux.com" + , -- extra source files + "test-package" + , "[]" + , -- library target + -- source dirs + "src" + , "True" + , -- exposed modules + "src" + , "True" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , -- other modules + "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]" + , "module Foo where" + , "module Bar where" + , "module Baz.Internal where" + , -- other extensions + "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + , -- dependencies + "True" + , "[\"src/Foo.hs\"]" + , "True" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + , -- build tools + "True" + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + ] + + 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 + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= Library + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV3_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [0, 1, 0, 0] + _pkgLicense desc @?= (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "" + _pkgSynopsis desc @?= "" + _pkgCategory desc @?= "" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _libSourceDirs lib @?= ["src"] + _libLanguage lib @?= Haskell2010 + _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"]) + _libOtherModules lib @?= map fromString ["Baz.Internal"] + _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _libDependencies lib @?! [] + _libBuildTools lib @?= [mkStringyDep "happy:happy"] + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?! Nothing + exe @?= Nothing + test @?= Nothing + Left e -> assertFailure $ show e + , testCase "Check the non-interactive executable workflow" $ do + let inputs = + NEL.fromList + -- package type + [ "test-package" + , "[\".\", \"..\", \"app/Main.hs\"]" + , "[\".\", \"..\", \"app/Main.hs\"]" + , -- package dir + "test-package" + , -- package description + -- cabal version + "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n" + , -- package name + "test-package" + , "test-package" + , -- author name + "" + , "Foobar" + , -- author email + "" + , "foobar@qux.com" + , -- extra source files + "test-package" + , "[]" + , -- executable target + -- application dirs + "app" + , "[]" + , -- main file + "test-package" + , "[\"test-package/app/\"]" + , "True" + , "[]" + , -- other modules + "test-package" + , "True" + , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , -- other extensions + "True" + , "[\"app/Foo.hs\", \"app/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + , -- dependencies + "True" + , "[\"app/Main.hs\"]" + , "True" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, DataKinds #-}" + , -- build tools + "True" + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + ] + + 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 + _optNoComments opts @?= False + _optVerbosity opts @?= silent + _optPkgDir opts @?= "/home/test/test-package" + _optPkgType opts @?= Executable + _optPkgName opts @?= mkPackageName "test-package" + + _pkgCabalVersion desc @?= CabalSpecV3_4 + _pkgName desc @?= mkPackageName "test-package" + _pkgVersion desc @?= mkVersion [0, 1, 0, 0] + _pkgLicense desc @?= (SpecLicense . Left $ SPDX.NONE) + _pkgAuthor desc @?= "Foobar" + _pkgEmail desc @?= "foobar@qux.com" + _pkgHomePage desc @?= "" + _pkgSynopsis desc @?= "" + _pkgCategory desc @?= "" + _pkgExtraSrcFiles desc @?= mempty + _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md") + + _exeMainIs exe @?= HsFilePath "Main.hs" Standard + _exeApplicationDirs exe @?= ["app"] + _exeLanguage exe @?= Haskell2010 + _exeOtherModules exe @?= map fromString ["Foo", "Bar"] + _exeOtherExts exe @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] + _exeDependencies exe @?! [] + _exeBuildTools exe @?= [mkStringyDep "happy:happy"] + Right (ProjectSettings _ _ lib exe test, _) -> do + lib @?= Nothing + exe @?! Nothing + test @?= Nothing + Left e -> assertFailure $ show e + ] ] - ] fileCreatorTests :: InstalledPackageIndex -> SourcePackageDb -> Compiler -> TestTree -fileCreatorTests pkgIx srcDb comp = testGroup "generators" - [ testGroup "genPkgDescription" - [ testCase "Check common package flags workflow" $ do - let inputs = NEL.fromList - -- cabal version - [ "cabal-install version 2.4.0.0\ncompiled using version 2.4.0.0 of the Cabal library \n" - -- package name - , "test-package" - , "test-package" - -- author name - , "" - , "Foobar" - -- author email - , "" - , "foobar@qux.com" - -- extra source files - , "test-package" - , "[]" - ] - - case (_runPrompt $ genPkgDescription emptyFlags srcDb) inputs of - Left e -> assertFailure $ show e - Right{} -> return () - ] - , testGroup "genLibTarget" - [ testCase "Check library package flags workflow" $ do - let inputs = NEL.fromList - -- source dirs - [ "src" - , "True" - -- exposed modules - , "src" - , "True" - , "True" - , "[\"src/Foo.hs\", \"src/Bar.hs\"]" - , "module Foo where" - , "module Bar where" - , "test-package" - , "True" - , "[\"src/Foo.hs\", \"src/Bar.hs\"]" - , "module Foo where" - , "module Bar where" - -- other modules - , "test-package" - , "True" - , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]" - , "module Foo where" - , "module Bar where" - , "module Baz.Internal where" - -- other extensions - , "True" - , "[\"src/Foo.hs\", \"src/Bar.hs\"]" - , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" - , "\"{-# LANGUAGE RecordWildCards #-}\"" - -- dependencies - , "True" - , "[\"src/Foo.hs\"]" - , "True" - , "test-package" - , "module Main where" - , "import Control.Monad.Extra" - , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" - -- build tools - , "True" - , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" - ] - - case (_runPrompt $ genLibTarget emptyFlags comp pkgIx defaultCabalVersion) inputs of - Left e -> assertFailure $ show e - Right{} -> return () - ] - , testGroup "genExeTarget" - [ testCase "Check executable package flags workflow" $ do - let inputs = NEL.fromList - -- application dirs - [ "app" - , "[]" - -- main file - , "test-package" - , "[\"test-package/app/\"]" - , "True" - , "[]" - -- other modules - , "test-package" - , "True" - , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]" - , "module Foo where" - , "module Bar where" - -- other extensions - , "True" - , "[\"app/Foo.hs\", \"app/Bar.hs\"]" - , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" - , "\"{-# LANGUAGE RecordWildCards #-}\"" - -- dependencies - , "True" - , "[\"app/Main.hs\"]" - , "True" - , "test-package" - , "module Main where" - , "import Control.Monad.Extra" - , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" - -- build tools - , "True" - , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" - ] - - case (_runPrompt $ genExeTarget emptyFlags comp pkgIx defaultCabalVersion) inputs of - Left e -> assertFailure $ show e - Right{} -> return () - ] - , testGroup "genTestTarget" - [ testCase "Check test package flags workflow" $ do - let inputs = NEL.fromList - -- main file - [ "True" - , "[]" - -- other modules - , "test-package" - , "True" - , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]" - , "module Foo where" - , "module Bar where" - -- other extensions - , "True" - , "[\"test/Foo.hs\", \"test/Bar.hs\"]" - , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" - , "\"{-# LANGUAGE RecordWildCards #-}\"" - -- dependencies - , "True" - , "[\"test/Main.hs\"]" - , "True" - , "test-package" - , "module Main where" - , "import Test.Tasty\nimport Test.Tasty.HUnit" - , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" - -- build tools - , "True" - , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/bar.y\"]" - ] - flags = emptyFlags {initializeTestSuite = Flag True} - - case (_runPrompt $ genTestTarget flags comp pkgIx defaultCabalVersion) inputs of - Left e -> assertFailure $ show e - Right{} -> return () +fileCreatorTests pkgIx srcDb comp = + testGroup + "generators" + [ testGroup + "genPkgDescription" + [ testCase "Check common package flags workflow" $ do + let inputs = + NEL.fromList + -- cabal version + [ "cabal-install version 2.4.0.0\ncompiled using version 2.4.0.0 of the Cabal library \n" + , -- package name + "test-package" + , "test-package" + , -- author name + "" + , "Foobar" + , -- author email + "" + , "foobar@qux.com" + , -- extra source files + "test-package" + , "[]" + ] + + case (_runPrompt $ genPkgDescription emptyFlags srcDb) inputs of + Left e -> assertFailure $ show e + Right{} -> return () + ] + , testGroup + "genLibTarget" + [ testCase "Check library package flags workflow" $ do + let inputs = + NEL.fromList + -- source dirs + [ "src" + , "True" + , -- exposed modules + "src" + , "True" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , -- other modules + "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]" + , "module Foo where" + , "module Bar where" + , "module Baz.Internal where" + , -- other extensions + "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + , -- dependencies + "True" + , "[\"src/Foo.hs\"]" + , "True" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + , -- build tools + "True" + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + ] + + case (_runPrompt $ genLibTarget emptyFlags comp pkgIx defaultCabalVersion) inputs of + Left e -> assertFailure $ show e + Right{} -> return () + ] + , testGroup + "genExeTarget" + [ testCase "Check executable package flags workflow" $ do + let inputs = + NEL.fromList + -- application dirs + [ "app" + , "[]" + , -- main file + "test-package" + , "[\"test-package/app/\"]" + , "True" + , "[]" + , -- other modules + "test-package" + , "True" + , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , -- other extensions + "True" + , "[\"app/Foo.hs\", \"app/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + , -- dependencies + "True" + , "[\"app/Main.hs\"]" + , "True" + , "test-package" + , "module Main where" + , "import Control.Monad.Extra" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + , -- build tools + "True" + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" + ] + + case (_runPrompt $ genExeTarget emptyFlags comp pkgIx defaultCabalVersion) inputs of + Left e -> assertFailure $ show e + Right{} -> return () + ] + , testGroup + "genTestTarget" + [ testCase "Check test package flags workflow" $ do + let inputs = + NEL.fromList + -- main file + [ "True" + , "[]" + , -- other modules + "test-package" + , "True" + , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , -- other extensions + "True" + , "[\"test/Foo.hs\", \"test/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + , -- dependencies + "True" + , "[\"test/Main.hs\"]" + , "True" + , "test-package" + , "module Main where" + , "import Test.Tasty\nimport Test.Tasty.HUnit" + , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}" + , -- build tools + "True" + , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/bar.y\"]" + ] + flags = emptyFlags{initializeTestSuite = Flag True} + + case (_runPrompt $ genTestTarget flags comp pkgIx defaultCabalVersion) inputs of + Left e -> assertFailure $ show e + Right{} -> return () + ] ] - ] nonInteractiveTests :: InstalledPackageIndex -> SourcePackageDb -> Compiler -> TestTree -nonInteractiveTests pkgIx srcDb comp = testGroup "Check top level getter functions" - [ testGroup "Simple heuristics tests" - [ testGroup "Check packageNameHeuristics output" - [ testSimple "New package name" (packageNameHeuristics srcDb) - (mkPackageName "test-package") - [ "test-package" - , "test-package" - ] - , testSimple "Existing package name" (packageNameHeuristics srcDb) - (mkPackageName "cabal-install") - [ "test-package" - , "cabal-install" - ] - ] - , testSimple "Check authorHeuristics output" authorHeuristics "Foobar" - [ "" - , "Foobar" - ] - , testSimple "Check emailHeuristics output" emailHeuristics "foobar@qux.com" - [ "" - , "foobar@qux.com" - ] - , testSimple "Check srcDirsHeuristics output" srcDirsHeuristics ["src"] - [ "src" - , "True" - ] - , testSimple "Check appDirsHeuristics output" appDirsHeuristics ["app"] - [ "test-package" - , "[\"test-package/app/\"]" - ] - , testGroup "Check packageTypeHeuristics output" - [ testSimple "Library" packageTypeHeuristics Library - [ "test-package" - , "[\".\", \"..\", \"test/Main.hs\", \"src/\"]" - , "[\".\", \"..\", \"test/Main.hs\", \"src/\"]" +nonInteractiveTests pkgIx srcDb comp = + testGroup + "Check top level getter functions" + [ testGroup + "Simple heuristics tests" + [ testGroup + "Check packageNameHeuristics output" + [ testSimple + "New package name" + (packageNameHeuristics srcDb) + (mkPackageName "test-package") + [ "test-package" + , "test-package" + ] + , testSimple + "Existing package name" + (packageNameHeuristics srcDb) + (mkPackageName "cabal-install") + [ "test-package" + , "cabal-install" + ] ] - , testSimple "Executable" packageTypeHeuristics Executable - [ "test-package" - , "[\".\", \"..\", \"app/Main.hs\"]" - , "[\".\", \"..\", \"app/Main.hs\"]" + , testSimple + "Check authorHeuristics output" + authorHeuristics + "Foobar" + [ "" + , "Foobar" ] - , testSimple "Library and Executable" packageTypeHeuristics LibraryAndExecutable - [ "test-package" - , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]" - , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]" - ] - , testSimple "TestSuite" packageTypeHeuristics TestSuite - [ "test-package" - , "[\".\", \"..\", \"test/Main.hs\"]" - , "[\".\", \"..\", \"test/Main.hs\"]" - ] - ] - , testGroup "Check cabalVersionHeuristics output" - [ testSimple "Broken command" cabalVersionHeuristics defaultCabalVersion - [""] - , testSimple "Proper answer" cabalVersionHeuristics CabalSpecV2_4 - ["cabal-install version 2.4.0.0\ncompiled using version 2.4.0.0 of the Cabal library \n"] - ] - , testGroup "Check languageHeuristics output" - [ testSimple "Non GHC compiler" - (`languageHeuristics` (comp {compilerId = CompilerId Helium $ mkVersion [1,8,1]})) - Haskell2010 [] - , testSimple "Higher version compiler" - (`languageHeuristics` (comp {compilerId = CompilerId GHC $ mkVersion [8,10,4]})) - Haskell2010 [] - , testSimple "Lower version compiler" - (`languageHeuristics` (comp {compilerId = CompilerId GHC $ mkVersion [6,0,1]})) - Haskell98 [] - ] - , testGroup "Check extraDocFileHeuristics output" - [ testSimple "No extra sources" extraDocFileHeuristics - (pure (Set.singleton "CHANGELOG.md")) - [ "test-package" - , "[]" + , testSimple + "Check emailHeuristics output" + emailHeuristics + "foobar@qux.com" + [ "" + , "foobar@qux.com" ] - , testSimple "Extra doc files present" extraDocFileHeuristics - (pure $ Set.singleton "README.md") - [ "test-package" - , "[\"README.md\"]" - ] - ] - , testGroup "Check mainFileHeuristics output" - [ testSimple "No main file defined" mainFileHeuristics - (toHsFilePath "Main.hs") - [ "test-package" - , "[\"test-package/app/\"]" + , testSimple + "Check srcDirsHeuristics output" + srcDirsHeuristics + ["src"] + [ "src" , "True" - , "[]" ] - , testSimple "Main file already defined" mainFileHeuristics - (toHsFilePath "app/Main.hs") + , testSimple + "Check appDirsHeuristics output" + appDirsHeuristics + ["app"] [ "test-package" , "[\"test-package/app/\"]" - , "True" - , "[\"app/Main.hs\"]" ] - , testSimple "Main lhs file already defined" mainFileHeuristics - (toHsFilePath "app/Main.lhs") - [ "test-package" - , "[\"test-package/app/\"]" - , "True" - , "[\"app/Main.lhs\"]" + , testGroup + "Check packageTypeHeuristics output" + [ testSimple + "Library" + packageTypeHeuristics + Library + [ "test-package" + , "[\".\", \"..\", \"test/Main.hs\", \"src/\"]" + , "[\".\", \"..\", \"test/Main.hs\", \"src/\"]" + ] + , testSimple + "Executable" + packageTypeHeuristics + Executable + [ "test-package" + , "[\".\", \"..\", \"app/Main.hs\"]" + , "[\".\", \"..\", \"app/Main.hs\"]" + ] + , testSimple + "Library and Executable" + packageTypeHeuristics + LibraryAndExecutable + [ "test-package" + , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]" + , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]" + ] + , testSimple + "TestSuite" + packageTypeHeuristics + TestSuite + [ "test-package" + , "[\".\", \"..\", \"test/Main.hs\"]" + , "[\".\", \"..\", \"test/Main.hs\"]" + ] ] - ] - , testGroup "Check exposedModulesHeuristics output" - [ testSimple "Default exposed modules" exposedModulesHeuristics - (myLibModule NEL.:| []) - [ "src" - , "True" - , "True" - , "[]" - , "test-package" - , "True" - , "[]" + , testGroup + "Check cabalVersionHeuristics output" + [ testSimple + "Broken command" + cabalVersionHeuristics + defaultCabalVersion + [""] + , testSimple + "Proper answer" + cabalVersionHeuristics + CabalSpecV2_4 + ["cabal-install version 2.4.0.0\ncompiled using version 2.4.0.0 of the Cabal library \n"] ] - , testSimple "Contains exposed modules" exposedModulesHeuristics - (NEL.fromList $ map fromString ["Foo", "Bar"]) - [ "src" - , "True" - , "True" - , "[\"src/Foo.hs\", \"src/Bar.hs\"]" - , "module Foo where" - , "module Bar where" - , "test-package" - , "True" - , "[\"src/Foo.hs\", \"src/Bar.hs\"]" - , "module Foo where" - , "module Bar where" + , testGroup + "Check languageHeuristics output" + [ testSimple + "Non GHC compiler" + (`languageHeuristics` (comp{compilerId = CompilerId Helium $ mkVersion [1, 8, 1]})) + Haskell2010 + [] + , testSimple + "Higher version compiler" + (`languageHeuristics` (comp{compilerId = CompilerId GHC $ mkVersion [8, 10, 4]})) + Haskell2010 + [] + , testSimple + "Lower version compiler" + (`languageHeuristics` (comp{compilerId = CompilerId GHC $ mkVersion [6, 0, 1]})) + Haskell98 + [] ] - ] - , testGroup "Check libOtherModulesHeuristics output" - [ testSimple "Library directory exists" libOtherModulesHeuristics - (map fromString ["Baz.Internal"]) - [ "test-package" - , "True" - , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]" - , "module Foo where" - , "module Bar where" - , "module Baz.Internal where" + , testGroup + "Check extraDocFileHeuristics output" + [ testSimple + "No extra sources" + extraDocFileHeuristics + (pure (Set.singleton "CHANGELOG.md")) + [ "test-package" + , "[]" + ] + , testSimple + "Extra doc files present" + extraDocFileHeuristics + (pure $ Set.singleton "README.md") + [ "test-package" + , "[\"README.md\"]" + ] ] - , testSimple "Library directory doesn't exist" libOtherModulesHeuristics [] - [ "test-package" - , "False" + , testGroup + "Check mainFileHeuristics output" + [ testSimple + "No main file defined" + mainFileHeuristics + (toHsFilePath "Main.hs") + [ "test-package" + , "[\"test-package/app/\"]" + , "True" + , "[]" + ] + , testSimple + "Main file already defined" + mainFileHeuristics + (toHsFilePath "app/Main.hs") + [ "test-package" + , "[\"test-package/app/\"]" + , "True" + , "[\"app/Main.hs\"]" + ] + , testSimple + "Main lhs file already defined" + mainFileHeuristics + (toHsFilePath "app/Main.lhs") + [ "test-package" + , "[\"test-package/app/\"]" + , "True" + , "[\"app/Main.lhs\"]" + ] ] - ] - , testGroup "Check exeOtherModulesHeuristics output" - [ testSimple "Executable directory exists" exeOtherModulesHeuristics - (map fromString ["Foo", "Bar"]) - [ "test-package" - , "True" - , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]" - , "module Foo where" - , "module Bar where" + , testGroup + "Check exposedModulesHeuristics output" + [ testSimple + "Default exposed modules" + exposedModulesHeuristics + (myLibModule NEL.:| []) + [ "src" + , "True" + , "True" + , "[]" + , "test-package" + , "True" + , "[]" + ] + , testSimple + "Contains exposed modules" + exposedModulesHeuristics + (NEL.fromList $ map fromString ["Foo", "Bar"]) + [ "src" + , "True" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + , "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + ] ] - , testSimple "Executable directory doesn't exist" exeOtherModulesHeuristics [] - [ "test-package" - , "False" + , testGroup + "Check libOtherModulesHeuristics output" + [ testSimple + "Library directory exists" + libOtherModulesHeuristics + (map fromString ["Baz.Internal"]) + [ "test-package" + , "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]" + , "module Foo where" + , "module Bar where" + , "module Baz.Internal where" + ] + , testSimple + "Library directory doesn't exist" + libOtherModulesHeuristics + [] + [ "test-package" + , "False" + ] ] - ] - , testGroup "Check testOtherModulesHeuristics output" - [ testSimple "Test directory exists" testOtherModulesHeuristics - (map fromString ["Foo", "Bar"]) - [ "test-package" - , "True" - , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]" - , "module Foo where" - , "module Bar where" + , testGroup + "Check exeOtherModulesHeuristics output" + [ testSimple + "Executable directory exists" + exeOtherModulesHeuristics + (map fromString ["Foo", "Bar"]) + [ "test-package" + , "True" + , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + ] + , testSimple + "Executable directory doesn't exist" + exeOtherModulesHeuristics + [] + [ "test-package" + , "False" + ] ] - , testSimple "Test directory doesn't exist" testOtherModulesHeuristics [] - [ "test-package" - , "False" + , testGroup + "Check testOtherModulesHeuristics output" + [ testSimple + "Test directory exists" + testOtherModulesHeuristics + (map fromString ["Foo", "Bar"]) + [ "test-package" + , "True" + , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]" + , "module Foo where" + , "module Bar where" + ] + , testSimple + "Test directory doesn't exist" + testOtherModulesHeuristics + [] + [ "test-package" + , "False" + ] ] - ] - , testGroup "Check dependenciesHeuristics output" - [ testSimple "base version bounds is correct" - (fmap - (flip foldl' anyVersion $ \a (Dependency n v _) -> - if unPackageName n == "base" && baseVersion comp /= anyVersion - then v else a) - . (\x -> dependenciesHeuristics x "" pkgIx)) - (baseVersion comp) + , testGroup + "Check dependenciesHeuristics output" + [ testSimple + "base version bounds is correct" + ( fmap + ( flip foldl' anyVersion $ \a (Dependency n v _) -> + if unPackageName n == "base" && baseVersion comp /= anyVersion + then v + else a + ) + . (\x -> dependenciesHeuristics x "" pkgIx) + ) + (baseVersion comp) + [ "True" + , "[]" + ] + ] + , testSimple + "Check buildToolsHeuristics output" + (\a -> buildToolsHeuristics a "" defaultCabalVersion) + [mkStringyDep "happy:happy"] [ "True" - , "[]" + , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" ] - ] - , testSimple "Check buildToolsHeuristics output" (\a -> buildToolsHeuristics a "" defaultCabalVersion) - [mkStringyDep "happy:happy"] - [ "True" - , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" - ] - , testSimple "Check otherExtsHeuristics output" (`otherExtsHeuristics` "") - (map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]) - [ "True" - , "[\"src/Foo.hs\", \"src/Bar.hs\"]" - , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" - , "\"{-# LANGUAGE RecordWildCards #-}\"" - ] - - , testSimple "Check versionHeuristics output" versionHeuristics (mkVersion [0,1,0,0]) [""] - , testSimple "Check homepageHeuristics output" homepageHeuristics "" [""] - , testSimple "Check synopsisHeuristics output" synopsisHeuristics "" [""] - , testSimple "Check testDirsHeuristics output" testDirsHeuristics ["test"] [""] - , testSimple "Check categoryHeuristics output" categoryHeuristics "" [""] - , testSimple "Check minimalHeuristics output" minimalHeuristics False [""] - , testSimple "Check overwriteHeuristics output" overwriteHeuristics False [""] - , testSimple "Check initializeTestSuiteHeuristics output" initializeTestSuiteHeuristics False [""] - , testSimple "Check licenseHeuristics output" licenseHeuristics (SpecLicense $ Left SPDX.NONE) [""] - ] - , testGroup "Bool heuristics tests" - [ testBool "Check noCommentsHeuristics output" noCommentsHeuristics False "" - ] + , testSimple + "Check otherExtsHeuristics output" + (`otherExtsHeuristics` "") + (map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]) + [ "True" + , "[\"src/Foo.hs\", \"src/Bar.hs\"]" + , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\"" + , "\"{-# LANGUAGE RecordWildCards #-}\"" + ] + , testSimple "Check versionHeuristics output" versionHeuristics (mkVersion [0, 1, 0, 0]) [""] + , testSimple "Check homepageHeuristics output" homepageHeuristics "" [""] + , testSimple "Check synopsisHeuristics output" synopsisHeuristics "" [""] + , testSimple "Check testDirsHeuristics output" testDirsHeuristics ["test"] [""] + , testSimple "Check categoryHeuristics output" categoryHeuristics "" [""] + , testSimple "Check minimalHeuristics output" minimalHeuristics False [""] + , testSimple "Check overwriteHeuristics output" overwriteHeuristics False [""] + , testSimple "Check initializeTestSuiteHeuristics output" initializeTestSuiteHeuristics False [""] + , testSimple "Check licenseHeuristics output" licenseHeuristics (SpecLicense $ Left SPDX.NONE) [""] + ] + , testGroup + "Bool heuristics tests" + [ testBool "Check noCommentsHeuristics output" noCommentsHeuristics False "" + ] ] testSimple @@ -1274,132 +1401,192 @@ testGo -> TestTree testGo label f g h inputs = testCase label $ case (_runPrompt $ f emptyFlags) (NEL.fromList inputs) of - Left x -> g x + Left x -> g x Right x -> h x cliListParserTests :: TestTree -cliListParserTests = testGroup "cli list parser" - [ testCase "Single extraSrc" $ do - flags <- runParserTest ["-x", "Generated.hs"] - flags @?= emptyFlags - { extraSrc = Flag ["Generated.hs"] - } - , testCase "Multiple extraSrc" $ do - flags <- runParserTest ["-x", "Gen1.hs", "-x", "Gen2.hs", "-x", "Gen3.hs"] - flags @?= emptyFlags - { extraSrc = Flag ["Gen1.hs", "Gen2.hs", "Gen3.hs"] - } - , testCase "Single extraDoc" $ do - flags <- runParserTest ["--extra-doc-file", "README"] - flags @?= emptyFlags - { extraDoc = Flag $ ["README"] - } - , testCase "Multiple extraDoc" $ do - flags <- runParserTest ["--extra-doc-file", "README", - "--extra-doc-file", "CHANGELOG", - "--extra-doc-file", "LICENSE"] - flags @?= emptyFlags - { extraDoc = Flag $ map fromString ["README", "CHANGELOG", "LICENSE"] - } - , testCase "Single exposedModules" $ do - flags <- runParserTest ["-o", "Test"] - flags @?= emptyFlags - { exposedModules = Flag $ map fromString ["Test"] - } - , testCase "Multiple exposedModules" $ do - flags <- runParserTest ["-o", "Test", "-o", "Test2", "-o", "Test3"] - flags @?= emptyFlags - { exposedModules = Flag $ map fromString ["Test", "Test2", "Test3"] - } - -- there is no otherModules cli flag - -- , testCase "Single otherModules" $ do - -- flags <- runParserTest ["-o", "Test"] - -- flags @?= dummyFlags - -- { otherModules = Flag $ map fromString ["Test"] - -- } - -- , testCase "Multiple otherModules" $ do - -- flags <- runParserTest ["-o", "Test", "-o", "Test2", "-o", "Test3"] - -- flags @?= dummyFlags - -- { otherModules = Flag $ map fromString ["Test", "Test2", "Test3"] - -- } - , testCase "Single otherExts" $ do - flags <- runParserTest ["--extension", "OverloadedStrings"] - flags @?= emptyFlags - { otherExts = Flag [EnableExtension OverloadedStrings] - } - , testCase "Multiple otherExts" $ do - flags <- runParserTest ["--extension", "OverloadedStrings", - "--extension", "FlexibleInstances", - "--extension", "FlexibleContexts"] - flags @?= emptyFlags - { otherExts = Flag [EnableExtension OverloadedStrings, - EnableExtension FlexibleInstances, - EnableExtension FlexibleContexts] - } - , testCase "Single dependency" $ do - flags <- runParserTest ["-d", "base"] - flags @?= emptyFlags - { dependencies = Flag [mkStringyDep "base"] - } - , testCase "Multiple dependency flags" $ do - flags <- runParserTest ["-d", "base", "-d", "vector"] - flags @?= emptyFlags - { dependencies = Flag $ fmap mkStringyDep ["base", "vector"] - } - , testCase "Comma separated list of dependencies" $ do - flags <- runParserTest ["-d", "base,vector"] - flags @?= emptyFlags - { dependencies = Flag $ fmap mkStringyDep ["base", "vector"] - } - , testCase "Single applicationDirs" $ do - flags <- runParserTest ["--application-dir", "app"] - flags @?= emptyFlags - { applicationDirs = Flag ["app"] - } - , testCase "Multiple applicationDirs" $ do - flags <- runParserTest ["--application-dir", "app", - "--application-dir", "exe", - "--application-dir", "srcapp"] - flags @?= emptyFlags - { applicationDirs = Flag ["app", "exe", "srcapp"] - } - , testCase "Single sourceDirs" $ do - flags <- runParserTest ["--source-dir", "src"] - flags @?= emptyFlags - { sourceDirs = Flag ["src"] - } - , testCase "Multiple sourceDirs" $ do - flags <- runParserTest ["--source-dir", "src", - "--source-dir", "lib", - "--source-dir", "sources"] - flags @?= emptyFlags - { sourceDirs = Flag ["src", "lib", "sources"] - } - , testCase "Single buildTools" $ do - flags <- runParserTest ["--build-tool", "happy"] - flags @?= emptyFlags - { buildTools = Flag ["happy"] - } - , testCase "Multiple buildTools" $ do - flags <- runParserTest ["--build-tool", "happy", - "--build-tool", "alex", - "--build-tool", "make"] - flags @?= emptyFlags - { buildTools = Flag ["happy", "alex", "make"] - } - , testCase "Single testDirs" $ do - flags <- runParserTest ["--test-dir", "test"] - flags @?= emptyFlags - { testDirs = Flag ["test"] - } - , testCase "Multiple testDirs" $ do - flags <- runParserTest ["--test-dir", "test", - "--test-dir", "tests", - "--test-dir", "testsuite"] - flags @?= emptyFlags - { testDirs = Flag ["test", "tests", "testsuite"] - } - ] +cliListParserTests = + testGroup + "cli list parser" + [ testCase "Single extraSrc" $ do + flags <- runParserTest ["-x", "Generated.hs"] + flags + @?= emptyFlags + { extraSrc = Flag ["Generated.hs"] + } + , testCase "Multiple extraSrc" $ do + flags <- runParserTest ["-x", "Gen1.hs", "-x", "Gen2.hs", "-x", "Gen3.hs"] + flags + @?= emptyFlags + { extraSrc = Flag ["Gen1.hs", "Gen2.hs", "Gen3.hs"] + } + , testCase "Single extraDoc" $ do + flags <- runParserTest ["--extra-doc-file", "README"] + flags + @?= emptyFlags + { extraDoc = Flag $ ["README"] + } + , testCase "Multiple extraDoc" $ do + flags <- + runParserTest + [ "--extra-doc-file" + , "README" + , "--extra-doc-file" + , "CHANGELOG" + , "--extra-doc-file" + , "LICENSE" + ] + flags + @?= emptyFlags + { extraDoc = Flag $ map fromString ["README", "CHANGELOG", "LICENSE"] + } + , testCase "Single exposedModules" $ do + flags <- runParserTest ["-o", "Test"] + flags + @?= emptyFlags + { exposedModules = Flag $ map fromString ["Test"] + } + , testCase "Multiple exposedModules" $ do + flags <- runParserTest ["-o", "Test", "-o", "Test2", "-o", "Test3"] + flags + @?= emptyFlags + { exposedModules = Flag $ map fromString ["Test", "Test2", "Test3"] + } + , -- there is no otherModules cli flag + -- , testCase "Single otherModules" $ do + -- flags <- runParserTest ["-o", "Test"] + -- flags @?= dummyFlags + -- { otherModules = Flag $ map fromString ["Test"] + -- } + -- , testCase "Multiple otherModules" $ do + -- flags <- runParserTest ["-o", "Test", "-o", "Test2", "-o", "Test3"] + -- flags @?= dummyFlags + -- { otherModules = Flag $ map fromString ["Test", "Test2", "Test3"] + -- } + testCase "Single otherExts" $ do + flags <- runParserTest ["--extension", "OverloadedStrings"] + flags + @?= emptyFlags + { otherExts = Flag [EnableExtension OverloadedStrings] + } + , testCase "Multiple otherExts" $ do + flags <- + runParserTest + [ "--extension" + , "OverloadedStrings" + , "--extension" + , "FlexibleInstances" + , "--extension" + , "FlexibleContexts" + ] + flags + @?= emptyFlags + { otherExts = + Flag + [ EnableExtension OverloadedStrings + , EnableExtension FlexibleInstances + , EnableExtension FlexibleContexts + ] + } + , testCase "Single dependency" $ do + flags <- runParserTest ["-d", "base"] + flags + @?= emptyFlags + { dependencies = Flag [mkStringyDep "base"] + } + , testCase "Multiple dependency flags" $ do + flags <- runParserTest ["-d", "base", "-d", "vector"] + flags + @?= emptyFlags + { dependencies = Flag $ fmap mkStringyDep ["base", "vector"] + } + , testCase "Comma separated list of dependencies" $ do + flags <- runParserTest ["-d", "base,vector"] + flags + @?= emptyFlags + { dependencies = Flag $ fmap mkStringyDep ["base", "vector"] + } + , testCase "Single applicationDirs" $ do + flags <- runParserTest ["--application-dir", "app"] + flags + @?= emptyFlags + { applicationDirs = Flag ["app"] + } + , testCase "Multiple applicationDirs" $ do + flags <- + runParserTest + [ "--application-dir" + , "app" + , "--application-dir" + , "exe" + , "--application-dir" + , "srcapp" + ] + flags + @?= emptyFlags + { applicationDirs = Flag ["app", "exe", "srcapp"] + } + , testCase "Single sourceDirs" $ do + flags <- runParserTest ["--source-dir", "src"] + flags + @?= emptyFlags + { sourceDirs = Flag ["src"] + } + , testCase "Multiple sourceDirs" $ do + flags <- + runParserTest + [ "--source-dir" + , "src" + , "--source-dir" + , "lib" + , "--source-dir" + , "sources" + ] + flags + @?= emptyFlags + { sourceDirs = Flag ["src", "lib", "sources"] + } + , testCase "Single buildTools" $ do + flags <- runParserTest ["--build-tool", "happy"] + flags + @?= emptyFlags + { buildTools = Flag ["happy"] + } + , testCase "Multiple buildTools" $ do + flags <- + runParserTest + [ "--build-tool" + , "happy" + , "--build-tool" + , "alex" + , "--build-tool" + , "make" + ] + flags + @?= emptyFlags + { buildTools = Flag ["happy", "alex", "make"] + } + , testCase "Single testDirs" $ do + flags <- runParserTest ["--test-dir", "test"] + flags + @?= emptyFlags + { testDirs = Flag ["test"] + } + , testCase "Multiple testDirs" $ do + flags <- + runParserTest + [ "--test-dir" + , "test" + , "--test-dir" + , "tests" + , "--test-dir" + , "testsuite" + ] + flags + @?= emptyFlags + { testDirs = Flag ["test", "tests", "testsuite"] + } + ] where assumeAllParse :: CommandParse (InitFlags -> InitFlags, [String]) -> IO InitFlags assumeAllParse = \case diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init/Simple.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init/Simple.hs index 2100859e678..13a12ba0827 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Init/Simple.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Init/Simple.hs @@ -1,133 +1,147 @@ module UnitTests.Distribution.Client.Init.Simple -( tests -) where + ( tests + ) where - -import Prelude as P import Test.Tasty import Test.Tasty.HUnit +import Prelude as P import Distribution.Client.Init.Defaults import Distribution.Client.Init.Simple import Distribution.Client.Init.Types - import Data.List.NonEmpty hiding (zip) import Distribution.Client.Types import Distribution.Simple.PackageIndex hiding (fromList) import Distribution.Types.PackageName import Distribution.Verbosity - -import UnitTests.Distribution.Client.Init.Utils -import Distribution.Simple.Setup import qualified Data.List.NonEmpty as NEL -import Distribution.Types.Dependency -import Distribution.Client.Init.Utils (mkPackageNameDep, getBaseDep) import qualified Data.Set as Set import Distribution.Client.Init.FlagExtractors (getCabalVersionNoPrompt) +import Distribution.Client.Init.Utils (getBaseDep, mkPackageNameDep) +import Distribution.Simple.Setup +import Distribution.Types.Dependency +import UnitTests.Distribution.Client.Init.Utils tests - :: Verbosity - -> InitFlags - -> InstalledPackageIndex - -> SourcePackageDb - -> TestTree -tests v _initFlags pkgIx srcDb = testGroup "Distribution.Client.Init.Simple.hs" + :: Verbosity + -> InitFlags + -> InstalledPackageIndex + -> SourcePackageDb + -> TestTree +tests v _initFlags pkgIx srcDb = + testGroup + "Distribution.Client.Init.Simple.hs" [ simpleCreateProjectTests v pkgIx srcDb pkgName ] where pkgName = mkPackageName "simple-test" simpleCreateProjectTests - :: Verbosity - -> InstalledPackageIndex - -> SourcePackageDb - -> PackageName - -> TestTree + :: Verbosity + -> InstalledPackageIndex + -> SourcePackageDb + -> PackageName + -> TestTree simpleCreateProjectTests v pkgIx srcDb pkgName = - testGroup "Simple createProject tests" + testGroup + "Simple createProject tests" [ testCase "Simple lib createProject - no tests" $ do - let inputs = fromList - [ "1" -- package type: Library - , "simple.test" -- package dir: used for determining package name; - -- note that . will be replaced with - in a sanitization step, - -- and we get the expected "simple-test" -- regression test for #8404 - , "simple.test" -- package dir again: the prompt monad needs extra parameter for every - -- IO call, and this one will be used for canonicalizePath, - -- which is called as a part of sanitization - , "n" -- no tests - ] - - flags = emptyFlags { packageType = Flag Library } - settings = ProjectSettings - (WriteOpts False False False v "/home/test/1" Library pkgName defaultCabalVersion) - (simplePkgDesc pkgName) (Just $ simpleLibTarget baseDep) - Nothing Nothing - - case _runPrompt (createProject v pkgIx srcDb flags) inputs of - Left e -> assertFailure $ "Failed to create simple lib project: " ++ show e - Right (settings', _) -> settings @=? settings' - + let inputs = + fromList + [ "1" -- package type: Library + , "simple.test" -- package dir: used for determining package name; + -- note that . will be replaced with - in a sanitization step, + -- and we get the expected "simple-test" -- regression test for #8404 + , "simple.test" -- package dir again: the prompt monad needs extra parameter for every + -- IO call, and this one will be used for canonicalizePath, + -- which is called as a part of sanitization + , "n" -- no tests + ] + + flags = emptyFlags{packageType = Flag Library} + settings = + ProjectSettings + (WriteOpts False False False v "/home/test/1" Library pkgName defaultCabalVersion) + (simplePkgDesc pkgName) + (Just $ simpleLibTarget baseDep) + Nothing + Nothing + + 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 - let inputs = fromList ["1", "simple-test", "simple-test", "y", "1"] - flags = emptyFlags { packageType = Flag Library } - settings = ProjectSettings - (WriteOpts False False False v "/home/test/1" Library pkgName defaultCabalVersion) - (simplePkgDesc pkgName) (Just $ simpleLibTarget baseDep) - Nothing (Just $ simpleTestTarget (Just pkgName) baseDep) - - 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' - + let inputs = fromList ["1", "simple-test", "simple-test", "y", "1"] + flags = emptyFlags{packageType = Flag Library} + settings = + ProjectSettings + (WriteOpts False False False v "/home/test/1" Library pkgName defaultCabalVersion) + (simplePkgDesc pkgName) + (Just $ simpleLibTarget baseDep) + Nothing + (Just $ simpleTestTarget (Just pkgName) baseDep) + + 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 - let inputs = fromList ["2", "simple-test", "simple-test"] - flags = emptyFlags { packageType = Flag Executable } - settings = ProjectSettings - (WriteOpts False False False v "/home/test/2" Executable pkgName defaultCabalVersion) - (simplePkgDesc pkgName) Nothing - (Just $ simpleExeTarget Nothing baseDep) Nothing - - case _runPrompt (createProject v pkgIx srcDb flags) inputs of - Left e -> assertFailure $ "Failed to create simple exe project: " ++ show e - Right (settings', _) -> settings @=? settings' - + let inputs = fromList ["2", "simple-test", "simple-test"] + flags = emptyFlags{packageType = Flag Executable} + settings = + ProjectSettings + (WriteOpts False False False v "/home/test/2" Executable pkgName defaultCabalVersion) + (simplePkgDesc pkgName) + Nothing + (Just $ simpleExeTarget Nothing baseDep) + Nothing + + 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 - let inputs = fromList ["2", "simple-test", "simple-test", "n"] - flags = emptyFlags { packageType = Flag LibraryAndExecutable } - settings = ProjectSettings - (WriteOpts False False False v "/home/test/2" LibraryAndExecutable pkgName defaultCabalVersion) - (simplePkgDesc pkgName) (Just $ simpleLibTarget baseDep) - (Just $ simpleExeTarget (Just pkgName) baseDep) Nothing - - 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' + let inputs = fromList ["2", "simple-test", "simple-test", "n"] + flags = emptyFlags{packageType = Flag LibraryAndExecutable} + settings = + ProjectSettings + (WriteOpts False False False v "/home/test/2" LibraryAndExecutable pkgName defaultCabalVersion) + (simplePkgDesc pkgName) + (Just $ simpleLibTarget baseDep) + (Just $ simpleExeTarget (Just pkgName) baseDep) + Nothing + + 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 - let inputs = fromList ["2", "simple-test", "simple-test", "y", "1"] - flags = emptyFlags { packageType = Flag LibraryAndExecutable } - settings = ProjectSettings - (WriteOpts False False False v "/home/test/2" LibraryAndExecutable pkgName defaultCabalVersion) - (simplePkgDesc pkgName) (Just $ simpleLibTarget baseDep) - (Just $ simpleExeTarget (Just pkgName) baseDep) - (Just $ simpleTestTarget (Just pkgName) baseDep) - - 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' - + let inputs = fromList ["2", "simple-test", "simple-test", "y", "1"] + flags = emptyFlags{packageType = Flag LibraryAndExecutable} + settings = + ProjectSettings + (WriteOpts False False False v "/home/test/2" LibraryAndExecutable pkgName defaultCabalVersion) + (simplePkgDesc pkgName) + (Just $ simpleLibTarget baseDep) + (Just $ simpleExeTarget (Just pkgName) baseDep) + (Just $ simpleTestTarget (Just pkgName) baseDep) + + 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 - let inputs = fromList ["2", "simple-test", "simple-test", "y", "1"] - flags = emptyFlags { packageType = Flag TestSuite } - settings = ProjectSettings - (WriteOpts False False False v "/home/test/2" TestSuite pkgName defaultCabalVersion) - (simplePkgDesc pkgName) Nothing Nothing - (Just $ simpleTestTarget Nothing baseDep) - - 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' + let inputs = fromList ["2", "simple-test", "simple-test", "y", "1"] + flags = emptyFlags{packageType = Flag TestSuite} + settings = + ProjectSettings + (WriteOpts False False False v "/home/test/2" TestSuite pkgName defaultCabalVersion) + (simplePkgDesc pkgName) + Nothing + Nothing + (Just $ simpleTestTarget Nothing baseDep) + + 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 @@ -142,32 +156,49 @@ mkPkgDep Nothing = [] mkPkgDep (Just pn) = [mkPackageNameDep pn] simplePkgDesc :: PackageName -> PkgDescription -simplePkgDesc pkgName = PkgDescription +simplePkgDesc pkgName = + PkgDescription defaultCabalVersion pkgName defaultVersion (defaultLicense $ getCabalVersionNoPrompt dummyFlags) - "" "" "" "" "" + "" + "" + "" + "" + "" mempty (Just $ Set.singleton defaultChangelog) simpleLibTarget :: [Dependency] -> LibTarget -simpleLibTarget baseDep = LibTarget +simpleLibTarget baseDep = + LibTarget [defaultSourceDir] defaultLanguage (myLibModule NEL.:| []) - [] [] baseDep [] + [] + [] + baseDep + [] simpleExeTarget :: Maybe PackageName -> [Dependency] -> ExeTarget -simpleExeTarget pn baseDep = ExeTarget +simpleExeTarget pn baseDep = + ExeTarget defaultMainIs [defaultApplicationDir] defaultLanguage - [] [] (baseDep ++ mkPkgDep pn) [] + [] + [] + (baseDep ++ mkPkgDep pn) + [] simpleTestTarget :: Maybe PackageName -> [Dependency] -> TestTarget -simpleTestTarget pn baseDep = TestTarget +simpleTestTarget pn baseDep = + TestTarget defaultMainIs [defaultTestDir] defaultLanguage - [] [] (baseDep ++ mkPkgDep pn) [] + [] + [] + (baseDep ++ mkPkgDep pn) + [] diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init/Utils.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init/Utils.hs index 0729e507765..e5ed0748a45 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Init/Utils.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Init/Utils.hs @@ -1,75 +1,74 @@ module UnitTests.Distribution.Client.Init.Utils -( dummyFlags -, emptyFlags -, mkLicense -, baseVersion -, mangleBaseDep -, (@?!) -, (@!?) -) where - + ( dummyFlags + , emptyFlags + , mkLicense + , baseVersion + , mangleBaseDep + , (@?!) + , (@!?) + ) where import Distribution.Client.Init.Types import qualified Distribution.SPDX as SPDX import Distribution.CabalSpecVersion +import Distribution.FieldGrammar.Newtypes +import Distribution.Pretty +import Distribution.Simple.Compiler import Distribution.Simple.Setup +import Distribution.Types.Dependency import Distribution.Types.PackageName import Distribution.Types.Version +import Distribution.Types.VersionRange import Language.Haskell.Extension import Test.Tasty.HUnit -import Distribution.Types.Dependency -import Distribution.Types.VersionRange -import Distribution.Simple.Compiler -import Distribution.Pretty -import Distribution.FieldGrammar.Newtypes - -- -------------------------------------------------------------------- -- -- Test flags dummyFlags :: InitFlags -dummyFlags = emptyFlags - { noComments = Flag True - , packageName = Flag (mkPackageName "QuxPackage") - , version = Flag (mkVersion [4,2,6]) - , cabalVersion = Flag CabalSpecV2_2 - , license = Flag $ SpecLicense $ Left $ SPDX.License $ SPDX.ELicense (SPDX.ELicenseId SPDX.MIT) Nothing - , author = Flag "Foobar" - , email = Flag "foobar@qux.com" - , homepage = Flag "qux.com" - , synopsis = Flag "We are Qux, and this is our package" - , category = Flag "Control" - , language = Flag Haskell98 - , initializeTestSuite = Flag True - , sourceDirs = Flag ["quxSrc"] - , testDirs = Flag ["quxTest"] - , applicationDirs = Flag ["quxApp"] - } +dummyFlags = + emptyFlags + { noComments = Flag True + , packageName = Flag (mkPackageName "QuxPackage") + , version = Flag (mkVersion [4, 2, 6]) + , cabalVersion = Flag CabalSpecV2_2 + , license = Flag $ SpecLicense $ Left $ SPDX.License $ SPDX.ELicense (SPDX.ELicenseId SPDX.MIT) Nothing + , author = Flag "Foobar" + , email = Flag "foobar@qux.com" + , homepage = Flag "qux.com" + , synopsis = Flag "We are Qux, and this is our package" + , category = Flag "Control" + , language = Flag Haskell98 + , initializeTestSuite = Flag True + , sourceDirs = Flag ["quxSrc"] + , testDirs = Flag ["quxTest"] + , applicationDirs = Flag ["quxApp"] + } emptyFlags :: InitFlags emptyFlags = mempty -- | Retrieves the proper base version based on the GHC version baseVersion :: Compiler -> VersionRange -baseVersion Compiler {compilerId = CompilerId GHC ver} = - let ghcToBase = baseVersion' . prettyShow $ ver in - if null ghcToBase - then anyVersion - else majorBoundVersion $ mkVersion ghcToBase +baseVersion Compiler{compilerId = CompilerId GHC ver} = + let ghcToBase = baseVersion' . prettyShow $ ver + in if null ghcToBase + then anyVersion + else majorBoundVersion $ mkVersion ghcToBase baseVersion _ = anyVersion baseVersion' :: String -> [Int] -baseVersion' "9.0.1" = [4,15,0,0] -baseVersion' "8.10.4" = [4,14,1,0] -baseVersion' "8.8.4" = [4,13,0,0] -baseVersion' "8.6.5" = [4,12,0,0] -baseVersion' "8.4.4" = [4,11,1,0] -baseVersion' "8.2.2" = [4,10,1,0] -baseVersion' "7.10.3" = [4,9,0,0] -baseVersion' "7.8.4" = [4,8,0,0] -baseVersion' "7.6.3" = [4,7,0,0] +baseVersion' "9.0.1" = [4, 15, 0, 0] +baseVersion' "8.10.4" = [4, 14, 1, 0] +baseVersion' "8.8.4" = [4, 13, 0, 0] +baseVersion' "8.6.5" = [4, 12, 0, 0] +baseVersion' "8.4.4" = [4, 11, 1, 0] +baseVersion' "8.2.2" = [4, 10, 1, 0] +baseVersion' "7.10.3" = [4, 9, 0, 0] +baseVersion' "7.8.4" = [4, 8, 0, 0] +baseVersion' "7.6.3" = [4, 7, 0, 0] baseVersion' _ = [] -- -------------------------------------------------------------------- -- @@ -80,11 +79,11 @@ mkLicense lid = SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing) mangleBaseDep :: a -> (a -> [Dependency]) -> [Dependency] mangleBaseDep target f = - [ if unPackageName x == "base" - then Dependency x anyVersion z - else dep - | dep@(Dependency x _ z) <- f target - ] + [ if unPackageName x == "base" + then Dependency x anyVersion z + else dep + | dep@(Dependency x _ z) <- f target + ] infix 1 @?!, @!? @@ -94,9 +93,10 @@ infix 1 @?!, @!? => a -> a -> Assertion -actual @?! unexpected = assertBool - ("unexpected: " ++ show unexpected) - (actual /= unexpected) +actual @?! unexpected = + assertBool + ("unexpected: " ++ show unexpected) + (actual /= unexpected) -- | Just like @'@=?'@, except it checks for difference rather than equality. (@!?) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs index 34c4d54d7e8..b708ea80302 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs @@ -1,105 +1,114 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoMonoLocalBinds #-} -{-# LANGUAGE ConstraintKinds #-} + module UnitTests.Distribution.Client.InstallPlan (tests) where import Distribution.Client.Compat.Prelude import qualified Prelude as Unsafe (tail) -import Distribution.Package -import Distribution.Version +import Distribution.Client.InstallPlan (GenericInstallPlan, IsUnit) import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.InstallPlan (GenericInstallPlan, IsUnit) +import Distribution.Client.JobControl +import Distribution.Client.Types +import Distribution.Compat.Graph (IsNode (..)) import qualified Distribution.Compat.Graph as Graph -import Distribution.Compat.Graph (IsNode(..)) -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.PackageFixedDeps +import Distribution.Package import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Client.Types -import Distribution.Client.JobControl +import Distribution.Solver.Types.PackageFixedDeps +import Distribution.Solver.Types.Settings +import Distribution.Version -import Data.Graph +import Control.Concurrent (threadDelay) +import Control.Monad (replicateM) import Data.Array hiding (index) +import Data.Graph +import Data.IORef import Data.List () -import Control.Monad (replicateM) import qualified Data.Map as Map import qualified Data.Set as Set -import Data.IORef -import Control.Concurrent (threadDelay) import System.Random import Test.QuickCheck import Test.Tasty import Test.Tasty.QuickCheck - tests :: [TestTree] tests = [ testProperty "reverseTopologicalOrder" prop_reverseTopologicalOrder - , testProperty "executionOrder" prop_executionOrder - , testProperty "execute serial" prop_execute_serial - , testProperty "execute parallel" prop_execute_parallel - , testProperty "execute/executionOrder" prop_execute_vs_executionOrder + , testProperty "executionOrder" prop_executionOrder + , testProperty "execute serial" prop_execute_serial + , testProperty "execute parallel" prop_execute_parallel + , testProperty "execute/executionOrder" prop_execute_vs_executionOrder ] prop_reverseTopologicalOrder :: TestInstallPlan -> Bool prop_reverseTopologicalOrder (TestInstallPlan plan graph toVertex _) = - isReverseTopologicalOrder - graph - (map (toVertex . installedUnitId) - (InstallPlan.reverseTopologicalOrder plan)) + isReverseTopologicalOrder + graph + ( map + (toVertex . installedUnitId) + (InstallPlan.reverseTopologicalOrder plan) + ) -- | @executionOrder@ is in reverse topological order prop_executionOrder :: TestInstallPlan -> Bool prop_executionOrder (TestInstallPlan plan graph toVertex _) = - isReversePartialTopologicalOrder graph (map toVertex pkgids) - && allConfiguredPackages plan == Set.fromList pkgids + isReversePartialTopologicalOrder graph (map toVertex pkgids) + && allConfiguredPackages plan == Set.fromList pkgids where pkgids = map installedUnitId (InstallPlan.executionOrder plan) -- | @execute@ is in reverse topological order prop_execute_serial :: TestInstallPlan -> Property prop_execute_serial tplan@(TestInstallPlan plan graph toVertex _) = - ioProperty $ do - jobCtl <- newSerialJobControl - pkgids <- executeTestInstallPlan jobCtl tplan (\_ -> return ()) - return $ isReversePartialTopologicalOrder graph (map toVertex pkgids) - && allConfiguredPackages plan == Set.fromList pkgids + ioProperty $ do + jobCtl <- newSerialJobControl + pkgids <- executeTestInstallPlan jobCtl tplan (\_ -> return ()) + return $ + isReversePartialTopologicalOrder graph (map toVertex pkgids) + && allConfiguredPackages plan == Set.fromList pkgids prop_execute_parallel :: Positive (Small Int) -> TestInstallPlan -> Property -prop_execute_parallel (Positive (Small maxJobLimit)) - tplan@(TestInstallPlan plan graph toVertex _) = +prop_execute_parallel + (Positive (Small maxJobLimit)) + tplan@(TestInstallPlan plan graph toVertex _) = ioProperty $ do jobCtl <- newParallelJobControl maxJobLimit pkgids <- executeTestInstallPlan jobCtl tplan $ \_ -> do - delay <- randomRIO (0,1000) - threadDelay delay - return $ isReversePartialTopologicalOrder graph (map toVertex pkgids) - && allConfiguredPackages plan == Set.fromList pkgids + delay <- randomRIO (0, 1000) + threadDelay delay + return $ + isReversePartialTopologicalOrder graph (map toVertex pkgids) + && allConfiguredPackages plan == Set.fromList pkgids -- | return the packages that are visited by execute, in order. -executeTestInstallPlan :: JobControl IO (UnitId, Either () ()) - -> TestInstallPlan - -> (TestPkg -> IO ()) - -> IO [UnitId] +executeTestInstallPlan + :: JobControl IO (UnitId, Either () ()) + -> TestInstallPlan + -> (TestPkg -> IO ()) + -> IO [UnitId] executeTestInstallPlan jobCtl (TestInstallPlan plan _ _ _) visit = do - resultsRef <- newIORef [] - _ <- InstallPlan.execute jobCtl False (const ()) - plan $ \(ReadyPackage pkg) -> do - visit pkg - atomicModifyIORef resultsRef $ \pkgs -> (installedUnitId pkg:pkgs, ()) - return (Right ()) - fmap reverse (readIORef resultsRef) + resultsRef <- newIORef [] + _ <- InstallPlan.execute + jobCtl + False + (const ()) + plan + $ \(ReadyPackage pkg) -> do + visit pkg + atomicModifyIORef resultsRef $ \pkgs -> (installedUnitId pkg : pkgs, ()) + return (Right ()) + fmap reverse (readIORef resultsRef) -- | @execute@ visits the packages in the same order as @executionOrder@ prop_execute_vs_executionOrder :: TestInstallPlan -> Property prop_execute_vs_executionOrder tplan@(TestInstallPlan plan _ _ _) = - ioProperty $ do - jobCtl <- newSerialJobControl - pkgids <- executeTestInstallPlan jobCtl tplan (\_ -> return ()) - let pkgids' = map installedUnitId (InstallPlan.executionOrder plan) - return (pkgids == pkgids') - + ioProperty $ do + jobCtl <- newSerialJobControl + pkgids <- executeTestInstallPlan jobCtl tplan (\_ -> return ()) + let pkgids' = map installedUnitId (InstallPlan.executionOrder plan) + return (pkgids == pkgids') -------------------------- -- Property helper utils @@ -111,40 +120,49 @@ prop_execute_vs_executionOrder tplan@(TestInstallPlan plan _ _ _) = -- -- A reverse topological ordering is the swapped: for every directed edge uv -- from vertex u to vertex v, v comes before u in the ordering. --- isReverseTopologicalOrder :: Graph -> [Vertex] -> Bool isReverseTopologicalOrder g vs = - and [ ixs ! u > ixs ! v - | let ixs = array (bounds g) (zip vs [0::Int ..]) - , (u,v) <- edges g ] + and + [ ixs ! u > ixs ! v + | let ixs = array (bounds g) (zip vs [0 :: Int ..]) + , (u, v) <- edges g + ] isReversePartialTopologicalOrder :: Graph -> [Vertex] -> Bool isReversePartialTopologicalOrder g vs = - and [ case (ixs ! u, ixs ! v) of - (Just ixu, Just ixv) -> ixu > ixv - _ -> True - | let ixs = array (bounds g) - (zip (range (bounds g)) (repeat Nothing) ++ - zip vs (map Just [0::Int ..])) - , (u,v) <- edges g ] - -allConfiguredPackages :: HasUnitId srcpkg - => GenericInstallPlan ipkg srcpkg -> Set UnitId + and + [ case (ixs ! u, ixs ! v) of + (Just ixu, Just ixv) -> ixu > ixv + _ -> True + | let ixs = + array + (bounds g) + ( zip (range (bounds g)) (repeat Nothing) + ++ zip vs (map Just [0 :: Int ..]) + ) + , (u, v) <- edges g + ] + +allConfiguredPackages + :: HasUnitId srcpkg + => GenericInstallPlan ipkg srcpkg + -> Set UnitId allConfiguredPackages plan = - Set.fromList - [ installedUnitId pkg - | InstallPlan.Configured pkg <- InstallPlan.toList plan ] - + Set.fromList + [ installedUnitId pkg + | InstallPlan.Configured pkg <- InstallPlan.toList plan + ] -------------------- -- Test generators -- -data TestInstallPlan = TestInstallPlan - (GenericInstallPlan TestPkg TestPkg) - Graph - (UnitId -> Vertex) - (Vertex -> UnitId) +data TestInstallPlan + = TestInstallPlan + (GenericInstallPlan TestPkg TestPkg) + Graph + (UnitId -> Vertex) + (Vertex -> UnitId) instance Show TestInstallPlan where show (TestInstallPlan plan _ _ _) = InstallPlan.showInstallPlan plan @@ -157,7 +175,6 @@ instance IsNode TestPkg where nodeKey (TestPkg _ ipkgid _) = ipkgid nodeNeighbors (TestPkg _ _ deps) = deps - instance Package TestPkg where packageId (TestPkg pkgid _ _) = pkgid @@ -175,71 +192,82 @@ instance Arbitrary TestInstallPlan where arbitraryTestInstallPlan :: Gen TestInstallPlan arbitraryTestInstallPlan = do - graph <- arbitraryAcyclicGraph - (choose (2,5)) - (choose (1,5)) - 0.3 + graph <- + arbitraryAcyclicGraph + (choose (2, 5)) + (choose (1, 5)) + 0.3 - plan <- arbitraryInstallPlan mkTestPkg mkTestPkg 0.5 graph + plan <- arbitraryInstallPlan mkTestPkg mkTestPkg 0.5 graph - let toVertexMap = Map.fromList [ (mkUnitIdV v, v) | v <- vertices graph ] - fromVertexMap = Map.fromList [ (v, mkUnitIdV v) | v <- vertices graph ] - toVertex = (toVertexMap Map.!) - fromVertex = (fromVertexMap Map.!) + let toVertexMap = Map.fromList [(mkUnitIdV v, v) | v <- vertices graph] + fromVertexMap = Map.fromList [(v, mkUnitIdV v) | v <- vertices graph] + toVertex = (toVertexMap Map.!) + fromVertex = (fromVertexMap Map.!) - return (TestInstallPlan plan graph toVertex fromVertex) + return (TestInstallPlan plan graph toVertex fromVertex) where mkTestPkg pkgv depvs = - return (TestPkg pkgid ipkgid deps) + return (TestPkg pkgid ipkgid deps) where - pkgid = mkPkgId pkgv + pkgid = mkPkgId pkgv ipkgid = mkUnitIdV pkgv - deps = map mkUnitIdV depvs + deps = map mkUnitIdV depvs mkUnitIdV = mkUnitId . show - mkPkgId v = PackageIdentifier (mkPackageName ("pkg" ++ show v)) - (mkVersion [1]) - + mkPkgId v = + PackageIdentifier + (mkPackageName ("pkg" ++ show v)) + (mkVersion [1]) -- | Generate a random 'InstallPlan' following the structure of an existing -- 'Graph'. -- -- It takes generators for installed and source packages and the chance that -- each package is installed (for those packages with no prerequisites). --- -arbitraryInstallPlan :: (IsUnit ipkg, - IsUnit srcpkg) - => (Vertex -> [Vertex] -> Gen ipkg) - -> (Vertex -> [Vertex] -> Gen srcpkg) - -> Float - -> Graph - -> Gen (InstallPlan.GenericInstallPlan ipkg srcpkg) +arbitraryInstallPlan + :: ( IsUnit ipkg + , IsUnit srcpkg + ) + => (Vertex -> [Vertex] -> Gen ipkg) + -> (Vertex -> [Vertex] -> Gen srcpkg) + -> Float + -> Graph + -> Gen (InstallPlan.GenericInstallPlan ipkg srcpkg) arbitraryInstallPlan mkIPkg mkSrcPkg ipkgProportion graph = do + (ipkgvs, srcpkgvs) <- + fmap + ( (\(ipkgs, srcpkgs) -> (map fst ipkgs, map fst srcpkgs)) + . partition snd + ) + $ sequenceA + [ do + isipkg <- + if isRoot + then pick ipkgProportion + else return False + return (v, isipkg) + | (v, n) <- assocs (outdegree graph) + , let isRoot = n == 0 + ] - (ipkgvs, srcpkgvs) <- - fmap ((\(ipkgs, srcpkgs) -> (map fst ipkgs, map fst srcpkgs)) - . partition snd) $ - sequenceA - [ do isipkg <- if isRoot then pick ipkgProportion - else return False - return (v, isipkg) - | (v,n) <- assocs (outdegree graph) - , let isRoot = n == 0 ] - - ipkgs <- sequenceA - [ mkIPkg pkgv depvs - | pkgv <- ipkgvs - , let depvs = graph ! pkgv - ] - srcpkgs <- sequenceA - [ mkSrcPkg pkgv depvs - | pkgv <- srcpkgvs - , let depvs = graph ! pkgv - ] - let index = Graph.fromDistinctList - (map InstallPlan.PreExisting ipkgs - ++ map InstallPlan.Configured srcpkgs) - return $ InstallPlan.new (IndependentGoals False) index - + ipkgs <- + sequenceA + [ mkIPkg pkgv depvs + | pkgv <- ipkgvs + , let depvs = graph ! pkgv + ] + srcpkgs <- + sequenceA + [ mkSrcPkg pkgv depvs + | pkgv <- srcpkgvs + , let depvs = graph ! pkgv + ] + let index = + Graph.fromDistinctList + ( map InstallPlan.PreExisting ipkgs + ++ map InstallPlan.Configured srcpkgs + ) + return $ InstallPlan.new (IndependentGoals False) index -- | Generate a random directed acyclic graph, based on the algorithm presented -- here @@ -252,30 +280,29 @@ arbitraryInstallPlan mkIPkg mkSrcPkg ipkgProportion graph = do -- chance that each node in each rank will have an edge from each node in -- each previous rank. Thus a higher chance will produce a more densely -- connected graph. --- arbitraryAcyclicGraph :: Gen Int -> Gen Int -> Float -> Gen Graph arbitraryAcyclicGraph genNRanks genNPerRank edgeChance = do - nranks <- genNRanks - rankSizes <- replicateM nranks genNPerRank - let rankStarts = scanl (+) 0 rankSizes - rankRanges = drop 1 (zip rankStarts (Unsafe.tail rankStarts)) - totalRange = sum rankSizes - rankEdges <- traverse (uncurry genRank) rankRanges - return $ buildG (0, totalRange-1) (concat rankEdges) + nranks <- genNRanks + rankSizes <- replicateM nranks genNPerRank + let rankStarts = scanl (+) 0 rankSizes + rankRanges = drop 1 (zip rankStarts (Unsafe.tail rankStarts)) + totalRange = sum rankSizes + rankEdges <- traverse (uncurry genRank) rankRanges + return $ buildG (0, totalRange - 1) (concat rankEdges) where genRank :: Vertex -> Vertex -> Gen [Edge] genRank rankStart rankEnd = - filterM (const (pick edgeChance)) - [ (i,j) - | i <- [0..rankStart-1] - , j <- [rankStart..rankEnd-1] + filterM + (const (pick edgeChance)) + [ (i, j) + | i <- [0 .. rankStart - 1] + , j <- [rankStart .. rankEnd - 1] ] pick :: Float -> Gen Bool pick chance = do - p <- choose (0,1) - return (p < chance) - + p <- choose (0, 1) + return (p < chance) -------------------------------- -- Inspecting generated graphs @@ -302,7 +329,6 @@ renderDotGraph graph = renderEdge (n, n') = "\t" ++ show n ++ " -> " ++ show n' ++ "[];" - header, footer, graphDefaultAtribs, nodeDefaultAtribs, edgeDefaultAtribs :: String header = "digraph packages {" diff --git a/cabal-install/tests/UnitTests/Distribution/Client/JobControl.hs b/cabal-install/tests/UnitTests/Distribution/Client/JobControl.hs index 05250ff180c..73769f91b18 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/JobControl.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/JobControl.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} + module UnitTests.Distribution.Client.JobControl (tests) where import Distribution.Client.JobControl @@ -6,37 +7,37 @@ import Distribution.Client.JobControl import Distribution.Client.Compat.Prelude import Prelude () -import Data.IORef (newIORef, atomicModifyIORef) -import Control.Monad (replicateM_, replicateM) import Control.Concurrent (threadDelay) -import Control.Exception (try) +import Control.Exception (try) +import Control.Monad (replicateM, replicateM_) +import Data.IORef (atomicModifyIORef, newIORef) import qualified Data.Set as Set import Test.Tasty import Test.Tasty.QuickCheck hiding (collect) - tests :: [TestTree] tests = - [ testGroup "serial" - [ testProperty "submit batch" prop_submit_serial - , testProperty "submit batch" prop_remaining_serial + [ testGroup + "serial" + [ testProperty "submit batch" prop_submit_serial + , testProperty "submit batch" prop_remaining_serial , testProperty "submit interleaved" prop_interleaved_serial - , testProperty "concurrent jobs" prop_concurrent_serial - , testProperty "cancel" prop_cancel_serial - , testProperty "exceptions" prop_exception_serial + , testProperty "concurrent jobs" prop_concurrent_serial + , testProperty "cancel" prop_cancel_serial + , testProperty "exceptions" prop_exception_serial ] - , testGroup "parallel" - [ testProperty "submit batch" prop_submit_parallel - , testProperty "submit batch" prop_remaining_parallel + , testGroup + "parallel" + [ testProperty "submit batch" prop_submit_parallel + , testProperty "submit batch" prop_remaining_parallel , testProperty "submit interleaved" prop_interleaved_parallel - , testProperty "concurrent jobs" prop_concurrent_parallel - , testProperty "cancel" prop_cancel_parallel - , testProperty "exceptions" prop_exception_parallel + , testProperty "concurrent jobs" prop_concurrent_parallel + , testProperty "cancel" prop_cancel_parallel + , testProperty "exceptions" prop_exception_parallel ] ] - prop_submit_serial :: [Int] -> Property prop_submit_serial xs = ioProperty $ do @@ -75,15 +76,15 @@ prop_interleaved_parallel (Positive (Small maxJobLimit)) xs = prop_submit :: JobControl IO Int -> [Int] -> IO Bool prop_submit jobCtl xs = do - traverse_ (\x -> spawnJob jobCtl (return x)) xs - xs' <- traverse (\_ -> collectJob jobCtl) xs - return (sort xs == sort xs') + traverse_ (\x -> spawnJob jobCtl (return x)) xs + xs' <- traverse (\_ -> collectJob jobCtl) xs + return (sort xs == sort xs') prop_remaining :: JobControl IO Int -> [Int] -> IO Bool prop_remaining jobCtl xs = do - traverse_ (\x -> spawnJob jobCtl (return x)) xs - xs' <- collectRemainingJobs jobCtl - return (sort xs == sort xs') + traverse_ (\x -> spawnJob jobCtl (return x)) xs + xs' <- collectRemainingJobs jobCtl + return (sort xs == sort xs') collectRemainingJobs :: Monad m => JobControl m a -> m [a] collectRemainingJobs jobCtl = go [] @@ -91,64 +92,76 @@ collectRemainingJobs jobCtl = go [] go xs = do remaining <- remainingJobs jobCtl if remaining - then do x <- collectJob jobCtl - go (x:xs) + then do + x <- collectJob jobCtl + go (x : xs) else return xs prop_submit_interleaved :: JobControl IO (Maybe Int) -> [Int] -> IO Bool prop_submit_interleaved jobCtl xs = do - xs' <- sequenceA + xs' <- + sequenceA [ spawn >> collect - | let spawns = map (\x -> spawnJob jobCtl (return (Just x))) xs - ++ repeat (return ()) - collects = replicate 5 (return Nothing) - ++ map (\_ -> collectJob jobCtl) xs + | let spawns = + map (\x -> spawnJob jobCtl (return (Just x))) xs + ++ repeat (return ()) + collects = + replicate 5 (return Nothing) + ++ map (\_ -> collectJob jobCtl) xs , (spawn, collect) <- zip spawns collects ] - return (sort xs == sort (catMaybes xs')) + return (sort xs == sort (catMaybes xs')) prop_concurrent_serial :: NonNegative (Small Int) -> Property prop_concurrent_serial (NonNegative (Small ntasks)) = ioProperty $ do - jobCtl <- newSerialJobControl + jobCtl <- newSerialJobControl countRef <- newIORef (0 :: Int) replicateM_ ntasks (spawnJob jobCtl (task countRef)) - counts <- replicateM ntasks (collectJob jobCtl) - return $ length counts == ntasks - && all (\(n0, n1) -> n0 == 0 && n1 == 1) counts + counts <- replicateM ntasks (collectJob jobCtl) + return $ + length counts == ntasks + && all (\(n0, n1) -> n0 == 0 && n1 == 1) counts where task countRef = do - n0 <- atomicModifyIORef countRef (\n -> (n+1, n)) + n0 <- atomicModifyIORef countRef (\n -> (n + 1, n)) threadDelay 100 - n1 <- atomicModifyIORef countRef (\n -> (n-1, n)) + n1 <- atomicModifyIORef countRef (\n -> (n - 1, n)) return (n0, n1) prop_concurrent_parallel :: Positive (Small Int) -> NonNegative Int -> Property prop_concurrent_parallel (Positive (Small maxJobLimit)) (NonNegative ntasks) = ioProperty $ do - jobCtl <- newParallelJobControl maxJobLimit + jobCtl <- newParallelJobControl maxJobLimit countRef <- newIORef (0 :: Int) replicateM_ ntasks (spawnJob jobCtl (task countRef)) - counts <- replicateM ntasks (collectJob jobCtl) - return $ length counts == ntasks - && all (\(n0, n1) -> n0 >= 0 && n0 < maxJobLimit - && n1 > 0 && n1 <= maxJobLimit) counts - -- we do hit the concurrency limit (in the right circumstances) - && if ntasks >= maxJobLimit*2 -- give us enough of a margin - then any (\(_,n1) -> n1 == maxJobLimit) counts - else True + counts <- replicateM ntasks (collectJob jobCtl) + return $ + length counts == ntasks + && all + ( \(n0, n1) -> + n0 >= 0 + && n0 < maxJobLimit + && n1 > 0 + && n1 <= maxJobLimit + ) + counts + -- we do hit the concurrency limit (in the right circumstances) + && if ntasks >= maxJobLimit * 2 -- give us enough of a margin + then any (\(_, n1) -> n1 == maxJobLimit) counts + else True where task countRef = do - n0 <- atomicModifyIORef countRef (\n -> (n+1, n)) + n0 <- atomicModifyIORef countRef (\n -> (n + 1, n)) threadDelay 100 - n1 <- atomicModifyIORef countRef (\n -> (n-1, n)) + n1 <- atomicModifyIORef countRef (\n -> (n - 1, n)) return (n0, n1) prop_cancel_serial :: [Int] -> [Int] -> Property prop_cancel_serial xs ys = ioProperty $ do jobCtl <- newSerialJobControl - traverse_ (\x -> spawnJob jobCtl (return x)) (xs++ys) + traverse_ (\x -> spawnJob jobCtl (return x)) (xs ++ ys) xs' <- traverse (\_ -> collectJob jobCtl) xs cancelJobs jobCtl ys' <- collectRemainingJobs jobCtl @@ -158,11 +171,11 @@ prop_cancel_parallel :: Positive (Small Int) -> [Int] -> [Int] -> Property prop_cancel_parallel (Positive (Small maxJobLimit)) xs ys = do ioProperty $ do jobCtl <- newParallelJobControl maxJobLimit - traverse_ (\x -> spawnJob jobCtl (threadDelay 100 >> return x)) (xs++ys) + traverse_ (\x -> spawnJob jobCtl (threadDelay 100 >> return x)) (xs ++ ys) xs' <- traverse (\_ -> collectJob jobCtl) xs cancelJobs jobCtl ys' <- collectRemainingJobs jobCtl - return $ Set.fromList (xs'++ys') `Set.isSubsetOf` Set.fromList (xs++ys) + return $ Set.fromList (xs' ++ ys') `Set.isSubsetOf` Set.fromList (xs ++ ys) data TestException = TestException Int deriving (Typeable, Show) @@ -183,11 +196,10 @@ prop_exception_parallel (Positive (Small maxJobLimit)) xs = prop_exception :: JobControl IO Int -> [Either Int Int] -> IO Bool prop_exception jobCtl xs = do - traverse_ (\x -> spawnJob jobCtl (either (throwIO . TestException) return x)) xs - xs' <- replicateM (length xs) $ do - mx <- try (collectJob jobCtl) - return $ case mx of - Left (TestException n) -> Left n - Right n -> Right n - return (sort xs == sort xs') - + traverse_ (\x -> spawnJob jobCtl (either (throwIO . TestException) return x)) xs + xs' <- replicateM (length xs) $ do + mx <- try (collectJob jobCtl) + return $ case mx of + Left (TestException n) -> Left n + Right n -> Right n + return (sort xs == sort xs') diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 8fcd15b1310..7a925c97f49 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -17,42 +17,42 @@ import Control.Applicative import Control.Monad import Data.Either (isRight) import Data.Foldable (for_) +import Data.List (intercalate, isPrefixOf, (\\)) import Data.Map (Map) import qualified Data.Map as Map -import Data.List (isPrefixOf, intercalate, (\\)) import Data.Maybe (fromMaybe) import Network.URI (URI) -import System.Directory (withCurrentDirectory, canonicalizePath) +import System.Directory (canonicalizePath, withCurrentDirectory) import System.FilePath import System.IO.Unsafe (unsafePerformIO) import Distribution.Deprecated.ParseUtils import qualified Distribution.Deprecated.ReadP as Parse +import Distribution.Compiler import Distribution.Package import Distribution.PackageDescription -import Distribution.Compiler -import Distribution.Version -import Distribution.Simple.Program.Types +import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Types import Distribution.Simple.Utils (toUTF8BS) -import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Types.PackageVersionConstraint +import Distribution.Version import Distribution.Parsec import Distribution.Pretty -import Distribution.Client.DistDirLayout (defaultProjectFile) -import Distribution.Client.Types import Distribution.Client.CmdInstall.ClientInstallFlags import Distribution.Client.Dependency.Types +import Distribution.Client.DistDirLayout (defaultProjectFile) import Distribution.Client.Targets +import Distribution.Client.Types import Distribution.Client.Types.SourceRepo import Distribution.Utils.NubList import Distribution.Verbosity (silent) -import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.Settings import Distribution.Client.ProjectConfig @@ -70,77 +70,74 @@ import Test.Tasty.QuickCheck tests :: [TestTree] tests = [ testGroup "ProjectConfig <-> LegacyProjectConfig round trip" $ - [ testProperty "packages" prop_roundtrip_legacytypes_packages - , testProperty "buildonly" prop_roundtrip_legacytypes_buildonly - , testProperty "specific" prop_roundtrip_legacytypes_specific - ] ++ - -- a couple tests seem to trigger a RTS fault in ghc-7.6 and older - -- unclear why as of yet - concat - [ [ testProperty "shared" prop_roundtrip_legacytypes_shared - , testProperty "local" prop_roundtrip_legacytypes_local - , testProperty "all" prop_roundtrip_legacytypes_all + [ testProperty "packages" prop_roundtrip_legacytypes_packages + , testProperty "buildonly" prop_roundtrip_legacytypes_buildonly + , testProperty "specific" prop_roundtrip_legacytypes_specific + ] + ++ + -- a couple tests seem to trigger a RTS fault in ghc-7.6 and older + -- unclear why as of yet + concat + [ [ testProperty "shared" prop_roundtrip_legacytypes_shared + , testProperty "local" prop_roundtrip_legacytypes_local + , testProperty "all" prop_roundtrip_legacytypes_all + ] + | not usingGhc76orOlder + ] + , testGroup + "individual parser tests" + [ testProperty "package location" prop_parsePackageLocationTokenQ + , testProperty "RelaxedDep" prop_roundtrip_printparse_RelaxedDep + , testProperty "RelaxDeps" prop_roundtrip_printparse_RelaxDeps + , testProperty "RelaxDeps'" prop_roundtrip_printparse_RelaxDeps' + ] + , testGroup + "ProjectConfig printing/parsing round trip" + [ testProperty "packages" prop_roundtrip_printparse_packages + , testProperty "buildonly" prop_roundtrip_printparse_buildonly + , testProperty "shared" prop_roundtrip_printparse_shared + , testProperty "local" prop_roundtrip_printparse_local + , testProperty "specific" prop_roundtrip_printparse_specific + , testProperty "all" prop_roundtrip_printparse_all ] - | not usingGhc76orOlder - ] - - , testGroup "individual parser tests" - [ testProperty "package location" prop_parsePackageLocationTokenQ - , testProperty "RelaxedDep" prop_roundtrip_printparse_RelaxedDep - , testProperty "RelaxDeps" prop_roundtrip_printparse_RelaxDeps - , testProperty "RelaxDeps'" prop_roundtrip_printparse_RelaxDeps' - ] - - , testGroup "ProjectConfig printing/parsing round trip" - [ testProperty "packages" prop_roundtrip_printparse_packages - , testProperty "buildonly" prop_roundtrip_printparse_buildonly - , testProperty "shared" prop_roundtrip_printparse_shared - , testProperty "local" prop_roundtrip_printparse_local - , testProperty "specific" prop_roundtrip_printparse_specific - , testProperty "all" prop_roundtrip_printparse_all - ] , testFindProjectRoot ] where usingGhc76orOlder = case buildCompilerId of - CompilerId GHC v -> v < mkVersion [7,7] - _ -> False + CompilerId GHC v -> v < mkVersion [7, 7] + _ -> False testFindProjectRoot :: TestTree -testFindProjectRoot = testGroup "findProjectRoot" - [ test "defaults" (cd dir) Nothing Nothing (succeeds dir file) - , test "defaults in lib" (cd libDir) Nothing Nothing (succeeds dir file) - - , test "explicit file" (cd dir) Nothing (Just file) (succeeds dir file) - , 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) - - -- Deprecated use-case - , test "absolute file" Nothing Nothing (Just absFile) (succeeds dir file) - - , test "nested file" (cd dir) Nothing (Just nixFile) (succeeds dir nixFile) - , test "nested file in lib" (cd libDir) Nothing (Just nixFile) (succeeds dir nixFile) - - , test "explicit dir" Nothing (Just dir) Nothing (succeeds dir file) - , test "explicit dir & file" Nothing (Just dir) (Just file) (succeeds dir file) - , test "explicit dir & nested file" Nothing (Just dir) (Just nixFile) (succeeds dir nixFile) - , test "explicit dir & nested other file" Nothing (Just dir) (Just nixOther) (succeeds dir nixOther) - - , test "explicit dir & absolute file" Nothing (Just dir) (Just absFile) (succeedsWith ProjectRootExplicitAbsolute dir absFile) - ] +testFindProjectRoot = + testGroup + "findProjectRoot" + [ test "defaults" (cd dir) Nothing Nothing (succeeds dir file) + , test "defaults in lib" (cd libDir) Nothing Nothing (succeeds dir file) + , test "explicit file" (cd dir) Nothing (Just file) (succeeds dir file) + , 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) + , -- Deprecated use-case + test "absolute file" Nothing Nothing (Just absFile) (succeeds dir file) + , test "nested file" (cd dir) Nothing (Just nixFile) (succeeds dir nixFile) + , test "nested file in lib" (cd libDir) Nothing (Just nixFile) (succeeds dir nixFile) + , test "explicit dir" Nothing (Just dir) Nothing (succeeds dir file) + , test "explicit dir & file" Nothing (Just dir) (Just file) (succeeds dir file) + , test "explicit dir & nested file" Nothing (Just dir) (Just nixFile) (succeeds dir nixFile) + , test "explicit dir & nested other file" Nothing (Just dir) (Just nixOther) (succeeds dir nixOther) + , test "explicit dir & absolute file" Nothing (Just dir) (Just absFile) (succeedsWith ProjectRootExplicitAbsolute dir absFile) + ] where - dir = fixturesDir "project-root" + dir = fixturesDir "project-root" libDir = dir "lib" - file = defaultProjectFile + file = defaultProjectFile fileOther = file <.> "other" - absFile = dir file + absFile = dir file - nixFile = "nix" file - nixOther = nixFile <.> "other" + nixFile = "nix" file + nixOther = nixFile <.> "other" missing path = Just (path <.> "does_not_exist") @@ -167,12 +164,13 @@ testFindProjectRoot = testGroup "findProjectRoot" Right pr -> pr @?= mk projectDir projectFile fails result = case result of - Left _ -> pure () + Left _ -> pure () Right x -> assertFailure $ "Expected an error, but found " <> show x fixturesDir :: FilePath -fixturesDir = unsafePerformIO $ - canonicalizePath ("tests" "fixtures") +fixturesDir = + unsafePerformIO $ + canonicalizePath ("tests" "fixtures") {-# NOINLINE fixturesDir #-} ------------------------------------------------ @@ -181,55 +179,54 @@ fixturesDir = unsafePerformIO $ roundtrip :: (Eq a, ToExpr a, Show b) => (a -> b) -> (b -> a) -> a -> Property roundtrip f f_inv x = - counterexample (show y) $ + counterexample (show y) $ x `ediffEq` f_inv y -- no counterexample with y, as they not have ToExpr where y = f x roundtrip_legacytypes :: ProjectConfig -> Property roundtrip_legacytypes = - roundtrip convertToLegacyProjectConfig - convertLegacyProjectConfig - + roundtrip + convertToLegacyProjectConfig + convertLegacyProjectConfig prop_roundtrip_legacytypes_all :: ProjectConfig -> Property prop_roundtrip_legacytypes_all config = - roundtrip_legacytypes - config { - projectConfigProvenance = mempty + roundtrip_legacytypes + config + { projectConfigProvenance = mempty } prop_roundtrip_legacytypes_packages :: ProjectConfig -> Property prop_roundtrip_legacytypes_packages config = - roundtrip_legacytypes - config { - projectConfigBuildOnly = mempty, - projectConfigShared = mempty, - projectConfigProvenance = mempty, - projectConfigLocalPackages = mempty, - projectConfigSpecificPackage = mempty + roundtrip_legacytypes + config + { projectConfigBuildOnly = mempty + , projectConfigShared = mempty + , projectConfigProvenance = mempty + , projectConfigLocalPackages = mempty + , projectConfigSpecificPackage = mempty } prop_roundtrip_legacytypes_buildonly :: ProjectConfigBuildOnly -> Property prop_roundtrip_legacytypes_buildonly config = - roundtrip_legacytypes - mempty { projectConfigBuildOnly = config } + roundtrip_legacytypes + mempty{projectConfigBuildOnly = config} prop_roundtrip_legacytypes_shared :: ProjectConfigShared -> Property prop_roundtrip_legacytypes_shared config = - roundtrip_legacytypes - mempty { projectConfigShared = config } + roundtrip_legacytypes + mempty{projectConfigShared = config} prop_roundtrip_legacytypes_local :: PackageConfig -> Property prop_roundtrip_legacytypes_local config = - roundtrip_legacytypes - mempty { projectConfigLocalPackages = config } + roundtrip_legacytypes + mempty{projectConfigLocalPackages = config} prop_roundtrip_legacytypes_specific :: Map PackageName PackageConfig -> Property prop_roundtrip_legacytypes_specific config = - roundtrip_legacytypes - mempty { projectConfigSpecificPackage = MapMappend config } - + roundtrip_legacytypes + mempty{projectConfigSpecificPackage = MapMappend config} -------------------------------------------- -- Round trip: printing and parsing config @@ -237,96 +234,97 @@ prop_roundtrip_legacytypes_specific config = roundtrip_printparse :: ProjectConfig -> Property roundtrip_printparse config = - case fmap convertLegacyProjectConfig (parseLegacyProjectConfig "unused" (toUTF8BS str)) of - ParseOk _ x -> counterexample ("shown:\n" ++ str) $ - x `ediffEq` config { projectConfigProvenance = mempty } - ParseFailed err -> counterexample ("shown:\n" ++ str ++ "\nERROR: " ++ show err) False + case fmap convertLegacyProjectConfig (parseLegacyProjectConfig "unused" (toUTF8BS str)) of + ParseOk _ x -> + counterexample ("shown:\n" ++ str) $ + x `ediffEq` config{projectConfigProvenance = mempty} + ParseFailed err -> counterexample ("shown:\n" ++ str ++ "\nERROR: " ++ show err) False where str :: String str = showLegacyProjectConfig (convertToLegacyProjectConfig config) - prop_roundtrip_printparse_all :: ProjectConfig -> Property prop_roundtrip_printparse_all config = - roundtrip_printparse config { - projectConfigBuildOnly = - hackProjectConfigBuildOnly (projectConfigBuildOnly config), - - projectConfigShared = - hackProjectConfigShared (projectConfigShared config) - } + roundtrip_printparse + config + { projectConfigBuildOnly = + hackProjectConfigBuildOnly (projectConfigBuildOnly config) + , projectConfigShared = + hackProjectConfigShared (projectConfigShared config) + } -prop_roundtrip_printparse_packages :: [PackageLocationString] - -> [PackageLocationString] - -> [SourceRepoList] - -> [PackageVersionConstraint] - -> Property +prop_roundtrip_printparse_packages + :: [PackageLocationString] + -> [PackageLocationString] + -> [SourceRepoList] + -> [PackageVersionConstraint] + -> Property prop_roundtrip_printparse_packages pkglocstrs1 pkglocstrs2 repos named = - roundtrip_printparse - mempty { - projectPackages = map getPackageLocationString pkglocstrs1, - projectPackagesOptional = map getPackageLocationString pkglocstrs2, - projectPackagesRepo = repos, - projectPackagesNamed = named + roundtrip_printparse + mempty + { projectPackages = map getPackageLocationString pkglocstrs1 + , projectPackagesOptional = map getPackageLocationString pkglocstrs2 + , projectPackagesRepo = repos + , projectPackagesNamed = named } prop_roundtrip_printparse_buildonly :: ProjectConfigBuildOnly -> Property prop_roundtrip_printparse_buildonly config = - roundtrip_printparse - mempty { - projectConfigBuildOnly = hackProjectConfigBuildOnly config + roundtrip_printparse + mempty + { projectConfigBuildOnly = hackProjectConfigBuildOnly config } hackProjectConfigBuildOnly :: ProjectConfigBuildOnly -> ProjectConfigBuildOnly hackProjectConfigBuildOnly config = - config { - -- These fields are only command line transitory things, not + config + { -- These fields are only command line transitory things, not -- something to be recorded persistently in a config file - projectConfigOnlyDeps = mempty, - projectConfigOnlyDownload = mempty, - projectConfigDryRun = mempty + projectConfigOnlyDeps = mempty + , projectConfigOnlyDownload = mempty + , projectConfigDryRun = mempty } prop_roundtrip_printparse_shared :: ProjectConfigShared -> Property prop_roundtrip_printparse_shared config = - roundtrip_printparse - mempty { - projectConfigShared = hackProjectConfigShared config + roundtrip_printparse + mempty + { projectConfigShared = hackProjectConfigShared config } hackProjectConfigShared :: ProjectConfigShared -> ProjectConfigShared hackProjectConfigShared config = - config { - projectConfigProjectFile = mempty, -- not present within project files - projectConfigProjectDir = mempty, -- ditto - projectConfigConfigFile = mempty, -- ditto - projectConfigConstraints = - --TODO: [required eventually] parse ambiguity in constraint - -- "pkgname -any" as either any version or disabled flag "any". + config + { projectConfigProjectFile = mempty -- not present within project files + , projectConfigProjectDir = mempty -- ditto + , projectConfigConfigFile = mempty -- ditto + , projectConfigConstraints = + -- TODO: [required eventually] parse ambiguity in constraint + -- "pkgname -any" as either any version or disabled flag "any". let ambiguous (UserConstraint _ (PackagePropertyFlags flags), _) = - (not . null) [ () | (name, False) <- unFlagAssignment flags - , "any" `isPrefixOf` unFlagName name ] + (not . null) + [ () | (name, False) <- unFlagAssignment flags, "any" `isPrefixOf` unFlagName name + ] ambiguous _ = False in filter (not . ambiguous) (projectConfigConstraints config) } - prop_roundtrip_printparse_local :: PackageConfig -> Property prop_roundtrip_printparse_local config = - roundtrip_printparse - mempty { - projectConfigLocalPackages = config + roundtrip_printparse + mempty + { projectConfigLocalPackages = config } -prop_roundtrip_printparse_specific :: Map PackageName (NonMEmpty PackageConfig) - -> Property +prop_roundtrip_printparse_specific + :: Map PackageName (NonMEmpty PackageConfig) + -> Property prop_roundtrip_printparse_specific config = - roundtrip_printparse - mempty { - projectConfigSpecificPackage = MapMappend (fmap getNonMEmpty config) + roundtrip_printparse + mempty + { projectConfigSpecificPackage = MapMappend (fmap getNonMEmpty config) } - ---------------------------- -- Individual Parser tests -- @@ -335,27 +333,27 @@ prop_roundtrip_printparse_specific config = -- -- Succeeds only if there is a unique complete parse runReadP :: Parse.ReadP a a -> String -> Maybe a -runReadP parser s = case [ x | (x,"") <- Parse.readP_to_S parser s ] of - [x'] -> Just x' - _ -> Nothing +runReadP parser s = case [x | (x, "") <- Parse.readP_to_S parser s] of + [x'] -> Just x' + _ -> Nothing prop_parsePackageLocationTokenQ :: PackageLocationString -> Bool prop_parsePackageLocationTokenQ (PackageLocationString str) = - runReadP parsePackageLocationTokenQ (renderPackageLocationToken str) == Just str + runReadP parsePackageLocationTokenQ (renderPackageLocationToken str) == Just str prop_roundtrip_printparse_RelaxedDep :: RelaxedDep -> Property prop_roundtrip_printparse_RelaxedDep rdep = - counterexample (prettyShow rdep) $ + counterexample (prettyShow rdep) $ eitherParsec (prettyShow rdep) == Right rdep prop_roundtrip_printparse_RelaxDeps :: RelaxDeps -> Property prop_roundtrip_printparse_RelaxDeps rdep = - counterexample (prettyShow rdep) $ + counterexample (prettyShow rdep) $ Right rdep `ediffEq` eitherParsec (prettyShow rdep) prop_roundtrip_printparse_RelaxDeps' :: RelaxDeps -> Property prop_roundtrip_printparse_RelaxDeps' rdep = - counterexample rdep' $ + counterexample rdep' $ Right rdep `ediffEq` eitherParsec rdep' where rdep' = go (prettyShow rdep) @@ -364,213 +362,244 @@ prop_roundtrip_printparse_RelaxDeps' rdep = go :: String -> String go [] = [] go "all" = "*" - go ('a':'l':'l':c:rest) | c `elem` ":," = '*' : go (c:rest) - go rest = let (x,y) = break (`elem` ":,") rest - (x',y') = span (`elem` ":,^") y - in x++x'++go y' + go ('a' : 'l' : 'l' : c : rest) | c `elem` ":," = '*' : go (c : rest) + go rest = + let (x, y) = break (`elem` ":,") rest + (x', y') = span (`elem` ":,^") y + in x ++ x' ++ go y' ------------------------ -- Arbitrary instances -- instance Arbitrary ProjectConfig where - arbitrary = - ProjectConfig - <$> (map getPackageLocationString <$> arbitrary) - <*> (map getPackageLocationString <$> arbitrary) - <*> shortListOf 3 arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> (MapMappend . fmap getNonMEmpty . Map.fromList - <$> shortListOf 3 arbitrary) - -- package entries with no content are equivalent to - -- the entry not existing at all, so exclude empty - - shrink ProjectConfig { projectPackages = x0 - , projectPackagesOptional = x1 - , projectPackagesRepo = x2 - , projectPackagesNamed = x3 - , projectConfigBuildOnly = x4 - , projectConfigShared = x5 - , projectConfigProvenance = x6 - , projectConfigLocalPackages = x7 - , projectConfigSpecificPackage = x8 - , projectConfigAllPackages = x9 } = - [ ProjectConfig { projectPackages = x0' - , projectPackagesOptional = x1' - , projectPackagesRepo = x2' - , projectPackagesNamed = x3' - , projectConfigBuildOnly = x4' - , projectConfigShared = x5' - , projectConfigProvenance = x6' - , projectConfigLocalPackages = x7' - , projectConfigSpecificPackage = (MapMappend - (fmap getNonMEmpty x8')) - , projectConfigAllPackages = x9' } - | ((x0', x1', x2', x3'), (x4', x5', x6', x7', x8', x9')) - <- shrink ((x0, x1, x2, x3), - (x4, x5, x6, x7, fmap NonMEmpty (getMapMappend x8), x9)) + arbitrary = + ProjectConfig + <$> (map getPackageLocationString <$> arbitrary) + <*> (map getPackageLocationString <$> arbitrary) + <*> shortListOf 3 arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> ( MapMappend . fmap getNonMEmpty . Map.fromList + <$> shortListOf 3 arbitrary + ) + + -- package entries with no content are equivalent to + -- the entry not existing at all, so exclude empty + + shrink + ProjectConfig + { projectPackages = x0 + , projectPackagesOptional = x1 + , projectPackagesRepo = x2 + , projectPackagesNamed = x3 + , projectConfigBuildOnly = x4 + , projectConfigShared = x5 + , projectConfigProvenance = x6 + , projectConfigLocalPackages = x7 + , projectConfigSpecificPackage = x8 + , projectConfigAllPackages = x9 + } = + [ ProjectConfig + { projectPackages = x0' + , projectPackagesOptional = x1' + , projectPackagesRepo = x2' + , projectPackagesNamed = x3' + , projectConfigBuildOnly = x4' + , projectConfigShared = x5' + , projectConfigProvenance = x6' + , projectConfigLocalPackages = x7' + , projectConfigSpecificPackage = + ( MapMappend + (fmap getNonMEmpty x8') + ) + , projectConfigAllPackages = x9' + } + | ((x0', x1', x2', x3'), (x4', x5', x6', x7', x8', x9')) <- + shrink + ( (x0, x1, x2, x3) + , (x4, x5, x6, x7, fmap NonMEmpty (getMapMappend x8), x9) + ) ] -newtype PackageLocationString - = PackageLocationString { getPackageLocationString :: String } - deriving Show +newtype PackageLocationString = PackageLocationString {getPackageLocationString :: String} + deriving (Show) instance Arbitrary PackageLocationString where arbitrary = - PackageLocationString <$> - oneof - [ show . getNonEmpty <$> (arbitrary :: Gen (NonEmptyList String)) - , arbitraryGlobLikeStr - , show <$> (arbitrary :: Gen URI) - ] - `suchThat` (\xs -> not ("{" `isPrefixOf` xs)) + PackageLocationString + <$> oneof + [ show . getNonEmpty <$> (arbitrary :: Gen (NonEmptyList String)) + , arbitraryGlobLikeStr + , show <$> (arbitrary :: Gen URI) + ] + `suchThat` (\xs -> not ("{" `isPrefixOf` xs)) arbitraryGlobLikeStr :: Gen String arbitraryGlobLikeStr = outerTerm where - outerTerm = concat <$> shortListOf1 4 - (frequency [ (2, token) - , (1, braces <$> innerTerm) ]) - innerTerm = intercalate "," <$> shortListOf1 3 - (frequency [ (3, token) - , (1, braces <$> innerTerm) ]) - token = shortListOf1 4 (elements (['#'..'~'] \\ "{,}")) - braces s = "{" ++ s ++ "}" - + outerTerm = + concat + <$> shortListOf1 + 4 + ( frequency + [ (2, token) + , (1, braces <$> innerTerm) + ] + ) + innerTerm = + intercalate "," + <$> shortListOf1 + 3 + ( frequency + [ (3, token) + , (1, braces <$> innerTerm) + ] + ) + token = shortListOf1 4 (elements (['#' .. '~'] \\ "{,}")) + braces s = "{" ++ s ++ "}" instance Arbitrary ClientInstallFlags where - arbitrary = - ClientInstallFlags - <$> arbitrary - <*> arbitraryFlag arbitraryShortToken - <*> arbitrary - <*> arbitrary - <*> arbitraryFlag arbitraryShortToken + arbitrary = + ClientInstallFlags + <$> arbitrary + <*> arbitraryFlag arbitraryShortToken + <*> arbitrary + <*> arbitrary + <*> arbitraryFlag arbitraryShortToken instance Arbitrary ProjectConfigBuildOnly where - arbitrary = - ProjectConfigBuildOnly - <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> (toNubList <$> shortListOf 2 arbitrary) - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> (fmap getShortToken <$> arbitrary) - <*> arbitraryNumJobs - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> (fmap getShortToken <$> arbitrary) - <*> arbitrary - <*> (fmap getShortToken <$> arbitrary) - <*> (fmap getShortToken <$> arbitrary) - <*> arbitrary - where - arbitraryNumJobs = fmap (fmap getPositive) <$> arbitrary - - shrink ProjectConfigBuildOnly { projectConfigVerbosity = x00 - , projectConfigDryRun = x01 - , projectConfigOnlyDeps = x02 - , projectConfigOnlyDownload = x18 - , projectConfigSummaryFile = x03 - , projectConfigLogFile = x04 - , projectConfigBuildReports = x05 - , projectConfigReportPlanningFailure = x06 - , projectConfigSymlinkBinDir = x07 - , projectConfigNumJobs = x09 - , projectConfigKeepGoing = x10 - , projectConfigOfflineMode = x11 - , projectConfigKeepTempFiles = x12 - , projectConfigHttpTransport = x13 - , projectConfigIgnoreExpiry = x14 - , projectConfigCacheDir = x15 - , projectConfigLogsDir = x16 - , projectConfigClientInstallFlags = x17 } = - [ ProjectConfigBuildOnly { projectConfigVerbosity = x00' - , projectConfigDryRun = x01' - , projectConfigOnlyDeps = x02' - , projectConfigOnlyDownload = x18' - , projectConfigSummaryFile = x03' - , projectConfigLogFile = x04' - , projectConfigBuildReports = x05' - , projectConfigReportPlanningFailure = x06' - , projectConfigSymlinkBinDir = x07' - , projectConfigNumJobs = postShrink_NumJobs x09' - , projectConfigKeepGoing = x10' - , projectConfigOfflineMode = x11' - , projectConfigKeepTempFiles = x12' - , projectConfigHttpTransport = x13 - , projectConfigIgnoreExpiry = x14' - , projectConfigCacheDir = x15 - , projectConfigLogsDir = x16 - , projectConfigClientInstallFlags = x17' } - | ((x00', x01', x02', x03', x04'), - (x05', x06', x07', x09'), - (x10', x11', x12', x14'), - ( x17', x18' )) - <- shrink - ((x00, x01, x02, x03, x04), - (x05, x06, x07, preShrink_NumJobs x09), - (x10, x11, x12, x14), - ( x17, x18 )) + arbitrary = + ProjectConfigBuildOnly + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> (toNubList <$> shortListOf 2 arbitrary) + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> (fmap getShortToken <$> arbitrary) + <*> arbitraryNumJobs + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> (fmap getShortToken <$> arbitrary) + <*> arbitrary + <*> (fmap getShortToken <$> arbitrary) + <*> (fmap getShortToken <$> arbitrary) + <*> arbitrary + where + arbitraryNumJobs = fmap (fmap getPositive) <$> arbitrary + + shrink + ProjectConfigBuildOnly + { projectConfigVerbosity = x00 + , projectConfigDryRun = x01 + , projectConfigOnlyDeps = x02 + , projectConfigOnlyDownload = x18 + , projectConfigSummaryFile = x03 + , projectConfigLogFile = x04 + , projectConfigBuildReports = x05 + , projectConfigReportPlanningFailure = x06 + , projectConfigSymlinkBinDir = x07 + , projectConfigNumJobs = x09 + , projectConfigKeepGoing = x10 + , projectConfigOfflineMode = x11 + , projectConfigKeepTempFiles = x12 + , projectConfigHttpTransport = x13 + , projectConfigIgnoreExpiry = x14 + , projectConfigCacheDir = x15 + , projectConfigLogsDir = x16 + , projectConfigClientInstallFlags = x17 + } = + [ ProjectConfigBuildOnly + { projectConfigVerbosity = x00' + , projectConfigDryRun = x01' + , projectConfigOnlyDeps = x02' + , projectConfigOnlyDownload = x18' + , projectConfigSummaryFile = x03' + , projectConfigLogFile = x04' + , projectConfigBuildReports = x05' + , projectConfigReportPlanningFailure = x06' + , projectConfigSymlinkBinDir = x07' + , projectConfigNumJobs = postShrink_NumJobs x09' + , projectConfigKeepGoing = x10' + , projectConfigOfflineMode = x11' + , projectConfigKeepTempFiles = x12' + , projectConfigHttpTransport = x13 + , projectConfigIgnoreExpiry = x14' + , projectConfigCacheDir = x15 + , projectConfigLogsDir = x16 + , projectConfigClientInstallFlags = x17' + } + | ( (x00', x01', x02', x03', x04') + , (x05', x06', x07', x09') + , (x10', x11', x12', x14') + , (x17', x18') + ) <- + shrink + ( (x00, x01, x02, x03, x04) + , (x05, x06, x07, preShrink_NumJobs x09) + , (x10, x11, x12, x14) + , (x17, x18) + ) ] where - preShrink_NumJobs = fmap (fmap Positive) + preShrink_NumJobs = fmap (fmap Positive) postShrink_NumJobs = fmap (fmap getPositive) instance Arbitrary ProjectConfigShared where - arbitrary = do - projectConfigDistDir <- arbitraryFlag arbitraryShortToken - projectConfigConfigFile <- arbitraryFlag arbitraryShortToken - projectConfigProjectDir <- arbitraryFlag arbitraryShortToken - projectConfigProjectFile <- arbitraryFlag arbitraryShortToken - projectConfigIgnoreProject <- arbitrary - projectConfigHcFlavor <- arbitrary - projectConfigHcPath <- arbitraryFlag arbitraryShortToken - projectConfigHcPkg <- arbitraryFlag arbitraryShortToken - projectConfigHaddockIndex <- arbitrary - projectConfigInstallDirs <- fixInstallDirs <$> arbitrary - projectConfigPackageDBs <- shortListOf 2 arbitrary - projectConfigRemoteRepos <- arbitrary - projectConfigLocalNoIndexRepos <- arbitrary - projectConfigActiveRepos <- arbitrary - projectConfigIndexState <- arbitrary - projectConfigStoreDir <- arbitraryFlag arbitraryShortToken - projectConfigConstraints <- arbitraryConstraints - projectConfigPreferences <- shortListOf 2 arbitrary - projectConfigCabalVersion <- arbitrary - projectConfigSolver <- arbitrary - projectConfigAllowOlder <- arbitrary - projectConfigAllowNewer <- arbitrary - projectConfigWriteGhcEnvironmentFilesPolicy <- arbitrary - projectConfigMaxBackjumps <- arbitrary - projectConfigReorderGoals <- arbitrary - projectConfigCountConflicts <- arbitrary - projectConfigFineGrainedConflicts <- arbitrary - projectConfigMinimizeConflictSet <- arbitrary - projectConfigStrongFlags <- arbitrary - projectConfigAllowBootLibInstalls <- arbitrary - projectConfigOnlyConstrained <- arbitrary - projectConfigPerComponent <- arbitrary - projectConfigIndependentGoals <- arbitrary - projectConfigPreferOldest <- arbitrary - projectConfigProgPathExtra <- toNubList <$> listOf arbitraryShortToken - return ProjectConfigShared {..} - where - arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)] - arbitraryConstraints = - fmap (\uc -> (uc, projectConfigConstraintSource)) <$> arbitrary - fixInstallDirs x = x {InstallDirs.includedir = mempty, InstallDirs.mandir = mempty, InstallDirs.flibdir = mempty} - - shrink ProjectConfigShared {..} = runShrinker $ pure ProjectConfigShared + arbitrary = do + projectConfigDistDir <- arbitraryFlag arbitraryShortToken + projectConfigConfigFile <- arbitraryFlag arbitraryShortToken + projectConfigProjectDir <- arbitraryFlag arbitraryShortToken + projectConfigProjectFile <- arbitraryFlag arbitraryShortToken + projectConfigIgnoreProject <- arbitrary + projectConfigHcFlavor <- arbitrary + projectConfigHcPath <- arbitraryFlag arbitraryShortToken + projectConfigHcPkg <- arbitraryFlag arbitraryShortToken + projectConfigHaddockIndex <- arbitrary + projectConfigInstallDirs <- fixInstallDirs <$> arbitrary + projectConfigPackageDBs <- shortListOf 2 arbitrary + projectConfigRemoteRepos <- arbitrary + projectConfigLocalNoIndexRepos <- arbitrary + projectConfigActiveRepos <- arbitrary + projectConfigIndexState <- arbitrary + projectConfigStoreDir <- arbitraryFlag arbitraryShortToken + projectConfigConstraints <- arbitraryConstraints + projectConfigPreferences <- shortListOf 2 arbitrary + projectConfigCabalVersion <- arbitrary + projectConfigSolver <- arbitrary + projectConfigAllowOlder <- arbitrary + projectConfigAllowNewer <- arbitrary + projectConfigWriteGhcEnvironmentFilesPolicy <- arbitrary + projectConfigMaxBackjumps <- arbitrary + projectConfigReorderGoals <- arbitrary + projectConfigCountConflicts <- arbitrary + projectConfigFineGrainedConflicts <- arbitrary + projectConfigMinimizeConflictSet <- arbitrary + projectConfigStrongFlags <- arbitrary + projectConfigAllowBootLibInstalls <- arbitrary + projectConfigOnlyConstrained <- arbitrary + projectConfigPerComponent <- arbitrary + projectConfigIndependentGoals <- arbitrary + projectConfigPreferOldest <- arbitrary + projectConfigProgPathExtra <- toNubList <$> listOf arbitraryShortToken + return ProjectConfigShared{..} + where + arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)] + arbitraryConstraints = + fmap (\uc -> (uc, projectConfigConstraintSource)) <$> arbitrary + fixInstallDirs x = x{InstallDirs.includedir = mempty, InstallDirs.mandir = mempty, InstallDirs.flibdir = mempty} + + shrink ProjectConfigShared{..} = + runShrinker $ + pure ProjectConfigShared <*> shrinker projectConfigDistDir <*> shrinker projectConfigConfigFile <*> shrinker projectConfigProjectDir @@ -606,250 +635,302 @@ instance Arbitrary ProjectConfigShared where <*> shrinker projectConfigIndependentGoals <*> shrinker projectConfigPreferOldest <*> shrinker projectConfigProgPathExtra - where - preShrink_Constraints = map fst - postShrink_Constraints = map (\uc -> (uc, projectConfigConstraintSource)) + where + preShrink_Constraints = map fst + postShrink_Constraints = map (\uc -> (uc, projectConfigConstraintSource)) projectConfigConstraintSource :: ConstraintSource projectConfigConstraintSource = - ConstraintSourceProjectConfig "unused" + ConstraintSourceProjectConfig "unused" instance Arbitrary ProjectConfigProvenance where - arbitrary = elements [Implicit, Explicit "cabal.project"] + arbitrary = elements [Implicit, Explicit "cabal.project"] instance Arbitrary PackageConfig where - arbitrary = - PackageConfig - <$> (MapLast . Map.fromList <$> shortListOf 10 - ((,) <$> arbitraryProgramName - <*> arbitraryShortToken)) - <*> (MapMappend . Map.fromList <$> shortListOf 10 - ((,) <$> arbitraryProgramName - <*> listOf arbitraryShortToken)) - <*> (toNubList <$> listOf arbitraryShortToken) - <*> arbitrary - <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - <*> arbitrary - <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - <*> shortListOf 5 arbitraryShortToken - <*> arbitrary - <*> arbitrary <*> arbitrary - <*> shortListOf 5 arbitraryShortToken - <*> shortListOf 5 arbitraryShortToken - <*> shortListOf 5 arbitraryShortToken - <*> shortListOf 5 arbitraryShortToken - <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - <*> arbitraryFlag arbitraryShortToken - <*> arbitrary - <*> arbitrary - <*> arbitrary <*> arbitrary - <*> arbitrary - <*> arbitraryFlag arbitraryShortToken - <*> arbitrary - <*> arbitrary - <*> arbitraryFlag arbitraryShortToken - <*> arbitrary - <*> arbitrary - <*> arbitraryFlag arbitraryShortToken - <*> arbitraryFlag arbitraryShortToken - <*> arbitraryFlag arbitraryShortToken - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitraryFlag arbitraryShortToken - <*> arbitrary - <*> shortListOf 5 arbitrary - <*> shortListOf 5 arbitrary - where - arbitraryProgramName :: Gen String - arbitraryProgramName = - elements [ programName prog - | (prog, _) <- knownPrograms (defaultProgramDb) ] - - shrink PackageConfig { packageConfigProgramPaths = x00 - , packageConfigProgramArgs = x01 - , packageConfigProgramPathExtra = x02 - , packageConfigFlagAssignment = x03 - , packageConfigVanillaLib = x04 - , packageConfigSharedLib = x05 - , packageConfigStaticLib = x42 - , packageConfigDynExe = x06 - , packageConfigFullyStaticExe = x50 - , packageConfigProf = x07 - , packageConfigProfLib = x08 - , packageConfigProfExe = x09 - , packageConfigProfDetail = x10 - , packageConfigProfLibDetail = x11 - , packageConfigConfigureArgs = x12 - , packageConfigOptimization = x13 - , packageConfigProgPrefix = x14 - , packageConfigProgSuffix = x15 - , packageConfigExtraLibDirs = x16 - , packageConfigExtraLibDirsStatic = x53 - , packageConfigExtraFrameworkDirs = x17 - , packageConfigExtraIncludeDirs = x18 - , packageConfigGHCiLib = x19 - , packageConfigSplitSections = x20 - , packageConfigSplitObjs = x20_1 - , packageConfigStripExes = x21 - , packageConfigStripLibs = x22 - , packageConfigTests = x23 - , packageConfigBenchmarks = x24 - , packageConfigCoverage = x25 - , packageConfigRelocatable = x26 - , packageConfigDebugInfo = x27 - , packageConfigDumpBuildInfo = x27_1 - , packageConfigRunTests = x28 - , packageConfigDocumentation = x29 - , packageConfigHaddockHoogle = x30 - , packageConfigHaddockHtml = x31 - , packageConfigHaddockHtmlLocation = x32 - , packageConfigHaddockForeignLibs = x33 - , packageConfigHaddockExecutables = x33_1 - , packageConfigHaddockTestSuites = x34 - , packageConfigHaddockBenchmarks = x35 - , packageConfigHaddockInternal = x36 - , packageConfigHaddockCss = x37 - , packageConfigHaddockLinkedSource = x38 - , packageConfigHaddockQuickJump = x43 - , packageConfigHaddockHscolourCss = x39 - , packageConfigHaddockContents = x40 - , packageConfigHaddockForHackage = x41 - , packageConfigHaddockIndex = x54 - , packageConfigHaddockBaseUrl = x55 - , packageConfigHaddockLib = x56 - , packageConfigHaddockOutputDir = x57 - , packageConfigTestHumanLog = x44 - , packageConfigTestMachineLog = x45 - , packageConfigTestShowDetails = x46 - , packageConfigTestKeepTix = x47 - , packageConfigTestWrapper = x48 - , packageConfigTestFailWhenNoTestSuites = x49 - , packageConfigTestTestOptions = x51 - , packageConfigBenchmarkOptions = x52 } = - [ PackageConfig { packageConfigProgramPaths = postShrink_Paths x00' - , packageConfigProgramArgs = postShrink_Args x01' - , packageConfigProgramPathExtra = x02' - , packageConfigFlagAssignment = x03' - , packageConfigVanillaLib = x04' - , packageConfigSharedLib = x05' - , packageConfigStaticLib = x42' - , packageConfigDynExe = x06' - , packageConfigFullyStaticExe = x50' - , packageConfigProf = x07' - , packageConfigProfLib = x08' - , packageConfigProfExe = x09' - , packageConfigProfDetail = x10' - , packageConfigProfLibDetail = x11' - , packageConfigConfigureArgs = map getNonEmpty x12' - , packageConfigOptimization = x13' - , packageConfigProgPrefix = x14' - , packageConfigProgSuffix = x15' - , packageConfigExtraLibDirs = map getNonEmpty x16' - , packageConfigExtraLibDirsStatic = map getNonEmpty x53' - , packageConfigExtraFrameworkDirs = map getNonEmpty x17' - , packageConfigExtraIncludeDirs = map getNonEmpty x18' - , packageConfigGHCiLib = x19' - , packageConfigSplitSections = x20' - , packageConfigSplitObjs = x20_1' - , packageConfigStripExes = x21' - , packageConfigStripLibs = x22' - , packageConfigTests = x23' - , packageConfigBenchmarks = x24' - , packageConfigCoverage = x25' - , packageConfigRelocatable = x26' - , packageConfigDebugInfo = x27' - , packageConfigDumpBuildInfo = x27_1' - , packageConfigRunTests = x28' - , packageConfigDocumentation = x29' - , packageConfigHaddockHoogle = x30' - , packageConfigHaddockHtml = x31' - , packageConfigHaddockHtmlLocation = x32' - , packageConfigHaddockForeignLibs = x33' - , packageConfigHaddockExecutables = x33_1' - , packageConfigHaddockTestSuites = x34' - , packageConfigHaddockBenchmarks = x35' - , packageConfigHaddockInternal = x36' - , packageConfigHaddockCss = fmap getNonEmpty x37' - , packageConfigHaddockLinkedSource = x38' - , packageConfigHaddockQuickJump = x43' - , packageConfigHaddockHscolourCss = fmap getNonEmpty x39' - , packageConfigHaddockContents = x40' - , packageConfigHaddockForHackage = x41' - , packageConfigHaddockIndex = x54' - , packageConfigHaddockBaseUrl = x55' - , packageConfigHaddockLib = x56' - , packageConfigHaddockOutputDir = x57' - , packageConfigTestHumanLog = x44' - , packageConfigTestMachineLog = x45' - , packageConfigTestShowDetails = x46' - , packageConfigTestKeepTix = x47' - , packageConfigTestWrapper = x48' - , packageConfigTestFailWhenNoTestSuites = x49' - , packageConfigTestTestOptions = x51' - , packageConfigBenchmarkOptions = x52' } - | (((x00', x01', x02', x03', x04'), - (x05', x42', x06', x50', x07', x08', x09'), - (x10', x11', x12', x13', x14'), - (x15', x16', x53', x17', x18', x19')), - ((x20', x20_1', x21', x22', x23', x24'), - (x25', x26', x27', x27_1', x28', x29'), - (x30', x31', x32', (x33', x33_1'), x34'), - (x35', x36', x37', x38', x43', x39'), - (x40', x41'), - (x44', x45', x46', x47', x48', x49', x51', x52', x54', x55'), - x56', x57')) - <- shrink - (((preShrink_Paths x00, preShrink_Args x01, x02, x03, x04), - (x05, x42, x06, x50, x07, x08, x09), - (x10, x11, map NonEmpty x12, x13, x14), - (x15, map NonEmpty x16, map NonEmpty x53, - map NonEmpty x17, - map NonEmpty x18, - x19)), - ((x20, x20_1, x21, x22, x23, x24), - (x25, x26, x27, x27_1, x28, x29), - (x30, x31, x32, (x33, x33_1), x34), - (x35, x36, fmap NonEmpty x37, x38, x43, fmap NonEmpty x39), - (x40, x41), - (x44, x45, x46, x47, x48, x49, x51, x52, x54, x55), x56, x57)) + arbitrary = + PackageConfig + <$> ( MapLast . Map.fromList + <$> shortListOf + 10 + ( (,) + <$> arbitraryProgramName + <*> arbitraryShortToken + ) + ) + <*> ( MapMappend . Map.fromList + <$> shortListOf + 10 + ( (,) + <$> arbitraryProgramName + <*> listOf arbitraryShortToken + ) + ) + <*> (toNubList <$> listOf arbitraryShortToken) + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> shortListOf 5 arbitraryShortToken + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> shortListOf 5 arbitraryShortToken + <*> shortListOf 5 arbitraryShortToken + <*> shortListOf 5 arbitraryShortToken + <*> shortListOf 5 arbitraryShortToken + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitraryFlag arbitraryShortToken + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitraryFlag arbitraryShortToken + <*> arbitrary + <*> arbitrary + <*> arbitraryFlag arbitraryShortToken + <*> arbitrary + <*> arbitrary + <*> arbitraryFlag arbitraryShortToken + <*> arbitraryFlag arbitraryShortToken + <*> arbitraryFlag arbitraryShortToken + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitraryFlag arbitraryShortToken + <*> arbitrary + <*> shortListOf 5 arbitrary + <*> shortListOf 5 arbitrary + where + arbitraryProgramName :: Gen String + arbitraryProgramName = + elements + [ programName prog + | (prog, _) <- knownPrograms (defaultProgramDb) + ] + + shrink + PackageConfig + { packageConfigProgramPaths = x00 + , packageConfigProgramArgs = x01 + , packageConfigProgramPathExtra = x02 + , packageConfigFlagAssignment = x03 + , packageConfigVanillaLib = x04 + , packageConfigSharedLib = x05 + , packageConfigStaticLib = x42 + , packageConfigDynExe = x06 + , packageConfigFullyStaticExe = x50 + , packageConfigProf = x07 + , packageConfigProfLib = x08 + , packageConfigProfExe = x09 + , packageConfigProfDetail = x10 + , packageConfigProfLibDetail = x11 + , packageConfigConfigureArgs = x12 + , packageConfigOptimization = x13 + , packageConfigProgPrefix = x14 + , packageConfigProgSuffix = x15 + , packageConfigExtraLibDirs = x16 + , packageConfigExtraLibDirsStatic = x53 + , packageConfigExtraFrameworkDirs = x17 + , packageConfigExtraIncludeDirs = x18 + , packageConfigGHCiLib = x19 + , packageConfigSplitSections = x20 + , packageConfigSplitObjs = x20_1 + , packageConfigStripExes = x21 + , packageConfigStripLibs = x22 + , packageConfigTests = x23 + , packageConfigBenchmarks = x24 + , packageConfigCoverage = x25 + , packageConfigRelocatable = x26 + , packageConfigDebugInfo = x27 + , packageConfigDumpBuildInfo = x27_1 + , packageConfigRunTests = x28 + , packageConfigDocumentation = x29 + , packageConfigHaddockHoogle = x30 + , packageConfigHaddockHtml = x31 + , packageConfigHaddockHtmlLocation = x32 + , packageConfigHaddockForeignLibs = x33 + , packageConfigHaddockExecutables = x33_1 + , packageConfigHaddockTestSuites = x34 + , packageConfigHaddockBenchmarks = x35 + , packageConfigHaddockInternal = x36 + , packageConfigHaddockCss = x37 + , packageConfigHaddockLinkedSource = x38 + , packageConfigHaddockQuickJump = x43 + , packageConfigHaddockHscolourCss = x39 + , packageConfigHaddockContents = x40 + , packageConfigHaddockForHackage = x41 + , packageConfigHaddockIndex = x54 + , packageConfigHaddockBaseUrl = x55 + , packageConfigHaddockLib = x56 + , packageConfigHaddockOutputDir = x57 + , packageConfigTestHumanLog = x44 + , packageConfigTestMachineLog = x45 + , packageConfigTestShowDetails = x46 + , packageConfigTestKeepTix = x47 + , packageConfigTestWrapper = x48 + , packageConfigTestFailWhenNoTestSuites = x49 + , packageConfigTestTestOptions = x51 + , packageConfigBenchmarkOptions = x52 + } = + [ PackageConfig + { packageConfigProgramPaths = postShrink_Paths x00' + , packageConfigProgramArgs = postShrink_Args x01' + , packageConfigProgramPathExtra = x02' + , packageConfigFlagAssignment = x03' + , packageConfigVanillaLib = x04' + , packageConfigSharedLib = x05' + , packageConfigStaticLib = x42' + , packageConfigDynExe = x06' + , packageConfigFullyStaticExe = x50' + , packageConfigProf = x07' + , packageConfigProfLib = x08' + , packageConfigProfExe = x09' + , packageConfigProfDetail = x10' + , packageConfigProfLibDetail = x11' + , packageConfigConfigureArgs = map getNonEmpty x12' + , packageConfigOptimization = x13' + , packageConfigProgPrefix = x14' + , packageConfigProgSuffix = x15' + , packageConfigExtraLibDirs = map getNonEmpty x16' + , packageConfigExtraLibDirsStatic = map getNonEmpty x53' + , packageConfigExtraFrameworkDirs = map getNonEmpty x17' + , packageConfigExtraIncludeDirs = map getNonEmpty x18' + , packageConfigGHCiLib = x19' + , packageConfigSplitSections = x20' + , packageConfigSplitObjs = x20_1' + , packageConfigStripExes = x21' + , packageConfigStripLibs = x22' + , packageConfigTests = x23' + , packageConfigBenchmarks = x24' + , packageConfigCoverage = x25' + , packageConfigRelocatable = x26' + , packageConfigDebugInfo = x27' + , packageConfigDumpBuildInfo = x27_1' + , packageConfigRunTests = x28' + , packageConfigDocumentation = x29' + , packageConfigHaddockHoogle = x30' + , packageConfigHaddockHtml = x31' + , packageConfigHaddockHtmlLocation = x32' + , packageConfigHaddockForeignLibs = x33' + , packageConfigHaddockExecutables = x33_1' + , packageConfigHaddockTestSuites = x34' + , packageConfigHaddockBenchmarks = x35' + , packageConfigHaddockInternal = x36' + , packageConfigHaddockCss = fmap getNonEmpty x37' + , packageConfigHaddockLinkedSource = x38' + , packageConfigHaddockQuickJump = x43' + , packageConfigHaddockHscolourCss = fmap getNonEmpty x39' + , packageConfigHaddockContents = x40' + , packageConfigHaddockForHackage = x41' + , packageConfigHaddockIndex = x54' + , packageConfigHaddockBaseUrl = x55' + , packageConfigHaddockLib = x56' + , packageConfigHaddockOutputDir = x57' + , packageConfigTestHumanLog = x44' + , packageConfigTestMachineLog = x45' + , packageConfigTestShowDetails = x46' + , packageConfigTestKeepTix = x47' + , packageConfigTestWrapper = x48' + , packageConfigTestFailWhenNoTestSuites = x49' + , packageConfigTestTestOptions = x51' + , packageConfigBenchmarkOptions = x52' + } + | ( ( (x00', x01', x02', x03', x04') + , (x05', x42', x06', x50', x07', x08', x09') + , (x10', x11', x12', x13', x14') + , (x15', x16', x53', x17', x18', x19') + ) + , ( (x20', x20_1', x21', x22', x23', x24') + , (x25', x26', x27', x27_1', x28', x29') + , (x30', x31', x32', (x33', x33_1'), x34') + , (x35', x36', x37', x38', x43', x39') + , (x40', x41') + , (x44', x45', x46', x47', x48', x49', x51', x52', x54', x55') + , x56' + , x57' + ) + ) <- + shrink + ( + ( (preShrink_Paths x00, preShrink_Args x01, x02, x03, x04) + , (x05, x42, x06, x50, x07, x08, x09) + , (x10, x11, map NonEmpty x12, x13, x14) + , + ( x15 + , map NonEmpty x16 + , map NonEmpty x53 + , map NonEmpty x17 + , map NonEmpty x18 + , x19 + ) + ) + , + ( (x20, x20_1, x21, x22, x23, x24) + , (x25, x26, x27, x27_1, x28, x29) + , (x30, x31, x32, (x33, x33_1), x34) + , (x35, x36, fmap NonEmpty x37, x38, x43, fmap NonEmpty x39) + , (x40, x41) + , (x44, x45, x46, x47, x48, x49, x51, x52, x54, x55) + , x56 + , x57 + ) + ) ] where - preShrink_Paths = Map.map NonEmpty - . Map.mapKeys NoShrink - . getMapLast - postShrink_Paths = MapLast - . Map.map getNonEmpty - . Map.mapKeys getNoShrink - preShrink_Args = Map.map (NonEmpty . map NonEmpty) - . Map.mapKeys NoShrink - . getMapMappend - postShrink_Args = MapMappend - . Map.map (map getNonEmpty . getNonEmpty) - . Map.mapKeys getNoShrink - - + preShrink_Paths = + Map.map NonEmpty + . Map.mapKeys NoShrink + . getMapLast + postShrink_Paths = + MapLast + . Map.map getNonEmpty + . Map.mapKeys getNoShrink + preShrink_Args = + Map.map (NonEmpty . map NonEmpty) + . Map.mapKeys NoShrink + . getMapMappend + postShrink_Args = + MapMappend + . Map.map (map getNonEmpty . getNonEmpty) + . Map.mapKeys getNoShrink instance f ~ [] => Arbitrary (SourceRepositoryPackage f) where - arbitrary = SourceRepositoryPackage - <$> arbitrary - <*> (getShortToken <$> arbitrary) - <*> (fmap getShortToken <$> arbitrary) - <*> (fmap getShortToken <$> arbitrary) - <*> (fmap getShortToken <$> shortListOf 3 arbitrary) - <*> (fmap getShortToken <$> shortListOf 3 arbitrary) - - shrink SourceRepositoryPackage {..} = runShrinker $ pure SourceRepositoryPackage + arbitrary = + SourceRepositoryPackage + <$> arbitrary + <*> (getShortToken <$> arbitrary) + <*> (fmap getShortToken <$> arbitrary) + <*> (fmap getShortToken <$> arbitrary) + <*> (fmap getShortToken <$> shortListOf 3 arbitrary) + <*> (fmap getShortToken <$> shortListOf 3 arbitrary) + + shrink SourceRepositoryPackage{..} = + runShrinker $ + pure SourceRepositoryPackage <*> shrinker srpType <*> shrinkerAla ShortToken srpLocation <*> shrinkerAla (fmap ShortToken) srpTag @@ -858,53 +939,61 @@ instance f ~ [] => Arbitrary (SourceRepositoryPackage f) where <*> shrinkerAla (fmap ShortToken) srpCommand instance Arbitrary RemoteRepo where - arbitrary = - RemoteRepo - <$> arbitrary - <*> arbitrary -- URI - <*> arbitrary - <*> listOf arbitraryRootKey - <*> fmap getNonNegative arbitrary - <*> pure False - where - arbitraryRootKey = - shortListOf1 5 (oneof [ choose ('0', '9') - , choose ('a', 'f') ]) + arbitrary = + RemoteRepo + <$> arbitrary + <*> arbitrary -- URI + <*> arbitrary + <*> listOf arbitraryRootKey + <*> fmap getNonNegative arbitrary + <*> pure False + where + arbitraryRootKey = + shortListOf1 + 5 + ( oneof + [ choose ('0', '9') + , choose ('a', 'f') + ] + ) instance Arbitrary LocalRepo where - arbitrary = LocalRepo - <$> arbitrary - <*> elements ["/tmp/foo", "/tmp/bar"] -- TODO: generate valid absolute paths - <*> arbitrary + arbitrary = + LocalRepo + <$> arbitrary + <*> elements ["/tmp/foo", "/tmp/bar"] -- TODO: generate valid absolute paths + <*> arbitrary instance Arbitrary PreSolver where - arbitrary = elements [minBound..maxBound] + arbitrary = elements [minBound .. maxBound] instance Arbitrary ReorderGoals where - arbitrary = ReorderGoals <$> arbitrary + arbitrary = ReorderGoals <$> arbitrary instance Arbitrary CountConflicts where - arbitrary = CountConflicts <$> arbitrary + arbitrary = CountConflicts <$> arbitrary instance Arbitrary FineGrainedConflicts where - arbitrary = FineGrainedConflicts <$> arbitrary + arbitrary = FineGrainedConflicts <$> arbitrary instance Arbitrary MinimizeConflictSet where - arbitrary = MinimizeConflictSet <$> arbitrary + arbitrary = MinimizeConflictSet <$> arbitrary instance Arbitrary IndependentGoals where - arbitrary = IndependentGoals <$> arbitrary + arbitrary = IndependentGoals <$> arbitrary instance Arbitrary PreferOldest where - arbitrary = PreferOldest <$> arbitrary + arbitrary = PreferOldest <$> arbitrary instance Arbitrary StrongFlags where - arbitrary = StrongFlags <$> arbitrary + arbitrary = StrongFlags <$> arbitrary instance Arbitrary AllowBootLibInstalls where - arbitrary = AllowBootLibInstalls <$> arbitrary + arbitrary = AllowBootLibInstalls <$> arbitrary instance Arbitrary OnlyConstrained where - arbitrary = oneof [ pure OnlyConstrainedAll - , pure OnlyConstrainedNone - ] + arbitrary = + oneof + [ pure OnlyConstrainedAll + , pure OnlyConstrainedNone + ] diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectPlanning.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectPlanning.hs index 11eab4e9d82..184cfef5bdf 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectPlanning.hs @@ -35,8 +35,8 @@ nubComponentTargetsTests = @?= [(mainLibWholeCompTarget, 1 :| [2])] , testCase "Merges whole component targets" $ nubComponentTargets [(mainLibFileTarget, 2), (mainLibWholeCompTarget, 1 :: Int)] - @?= [(mainLibWholeCompTarget, 2 :| [1])], - testCase "Don't merge unrelated targets" $ + @?= [(mainLibWholeCompTarget, 2 :| [1])] + , testCase "Don't merge unrelated targets" $ nubComponentTargets [ (mainLibWholeCompTarget, 1 :: Int) , (exeWholeCompTarget, 2) @@ -58,11 +58,10 @@ nubComponentTargetsTests = , (exeFileTarget, 3) , (exe2FileTarget, 5) ] - @?= - [ (mainLibWholeCompTarget, 1 :| [4]) - , (exeWholeCompTarget, 2 :| [3]) - , (exe2WholeCompTarget, 5 :| []) - ] + @?= [ (mainLibWholeCompTarget, 1 :| [4]) + , (exeWholeCompTarget, 2 :| [3]) + , (exe2WholeCompTarget, 5 :| []) + ] ] -- ---------------------------------------------------------------------------- diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Store.hs b/cabal-install/tests/UnitTests/Distribution/Client/Store.hs index e949b818ec3..7268b4c8c34 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Store.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Store.hs @@ -1,47 +1,45 @@ module UnitTests.Distribution.Client.Store (tests) where ---import Control.Monad ---import Control.Concurrent (forkIO, threadDelay) ---import Control.Concurrent.MVar +-- import Control.Monad +-- import Control.Concurrent (forkIO, threadDelay) +-- import Control.Concurrent.MVar import qualified Data.Set as Set -import System.FilePath import System.Directory ---import System.Random +import System.FilePath + +-- import System.Random +import Distribution.Compiler (CompilerFlavor (..), CompilerId (..)) import Distribution.Package (UnitId, mkUnitId) -import Distribution.Compiler (CompilerId(..), CompilerFlavor(..)) -import Distribution.Version (mkVersion) -import Distribution.Verbosity (Verbosity, silent) import Distribution.Simple.Utils (withTempDirectory) +import Distribution.Verbosity (Verbosity, silent) +import Distribution.Version (mkVersion) -import Distribution.Client.Store import Distribution.Client.RebuildMonad +import Distribution.Client.Store import Test.Tasty import Test.Tasty.HUnit - tests :: [TestTree] tests = - [ testCase "list content empty" testListEmpty - , testCase "install serial" testInstallSerial ---, testCase "install parallel" testInstallParallel - --TODO: figure out some way to do a parallel test, see issue below + [ testCase "list content empty" testListEmpty + , testCase "install serial" testInstallSerial + -- , testCase "install parallel" testInstallParallel + -- TODO: figure out some way to do a parallel test, see issue below ] - testListEmpty :: Assertion testListEmpty = withTempDirectory verbosity "." "store-" $ \tmp -> do let storeDirLayout = defaultStoreDirLayout (tmp "store") assertStoreEntryExists storeDirLayout compid unitid False - assertStoreContent tmp storeDirLayout compid Set.empty + assertStoreContent tmp storeDirLayout compid Set.empty where - compid = CompilerId GHC (mkVersion [1,0]) + compid = CompilerId GHC (mkVersion [1, 0]) unitid = mkUnitId "foo-1.0-xyz" - testInstallSerial :: Assertion testInstallSerial = withTempDirectory verbosity "." "store-" $ \tmp -> do @@ -51,30 +49,44 @@ testInstallSerial = let destprefix = dir "prefix" createDirectory destprefix writeFile (destprefix file) content - return (destprefix,[]) - - assertNewStoreEntry tmp storeDirLayout compid unitid1 - (copyFiles "file1" "content-foo") (return ()) - UseNewStoreEntry - - assertNewStoreEntry tmp storeDirLayout compid unitid1 - (copyFiles "file1" "content-foo") (return ()) - UseExistingStoreEntry - - assertNewStoreEntry tmp storeDirLayout compid unitid2 - (copyFiles "file2" "content-bar") (return ()) - UseNewStoreEntry + return (destprefix, []) + + assertNewStoreEntry + tmp + storeDirLayout + compid + unitid1 + (copyFiles "file1" "content-foo") + (return ()) + UseNewStoreEntry + + assertNewStoreEntry + tmp + storeDirLayout + compid + unitid1 + (copyFiles "file1" "content-foo") + (return ()) + UseExistingStoreEntry + + assertNewStoreEntry + tmp + storeDirLayout + compid + unitid2 + (copyFiles "file2" "content-bar") + (return ()) + UseNewStoreEntry let pkgDir :: UnitId -> FilePath pkgDir = storePackageDirectory storeDirLayout compid assertFileEqual (pkgDir unitid1 "file1") "content-foo" assertFileEqual (pkgDir unitid2 "file2") "content-bar" where - compid = CompilerId GHC (mkVersion [1,0]) + compid = CompilerId GHC (mkVersion [1, 0]) unitid1 = mkUnitId "foo-1.0-xyz" unitid2 = mkUnitId "bar-2.0-xyz" - {- -- unfortunately a parallel test like the one below is thwarted by the normal -- process-internal file locking. If that locking were not in place then we @@ -135,47 +147,63 @@ testInstallParallel = ------------- -- Utils -assertNewStoreEntry :: FilePath -> StoreDirLayout - -> CompilerId -> UnitId - -> (FilePath -> IO (FilePath,[FilePath])) -> IO () - -> NewStoreEntryOutcome - -> Assertion -assertNewStoreEntry tmp storeDirLayout compid unitid - copyFiles register expectedOutcome = do +assertNewStoreEntry + :: FilePath + -> StoreDirLayout + -> CompilerId + -> UnitId + -> (FilePath -> IO (FilePath, [FilePath])) + -> IO () + -> NewStoreEntryOutcome + -> Assertion +assertNewStoreEntry + tmp + storeDirLayout + compid + unitid + copyFiles + register + expectedOutcome = do entries <- runRebuild tmp $ getStoreEntries storeDirLayout compid - outcome <- newStoreEntry verbosity storeDirLayout - compid unitid - copyFiles register + outcome <- + newStoreEntry + verbosity + storeDirLayout + compid + unitid + copyFiles + register assertEqual "newStoreEntry outcome" expectedOutcome outcome assertStoreEntryExists storeDirLayout compid unitid True let expected = Set.insert unitid entries assertStoreContent tmp storeDirLayout compid expected - -assertStoreEntryExists :: StoreDirLayout - -> CompilerId -> UnitId -> Bool - -> Assertion +assertStoreEntryExists + :: StoreDirLayout + -> CompilerId + -> UnitId + -> Bool + -> Assertion assertStoreEntryExists storeDirLayout compid unitid expected = do - actual <- doesStoreEntryExist storeDirLayout compid unitid - assertEqual "store entry exists" expected actual - - -assertStoreContent :: FilePath -> StoreDirLayout - -> CompilerId -> Set.Set UnitId - -> Assertion + actual <- doesStoreEntryExist storeDirLayout compid unitid + assertEqual "store entry exists" expected actual + +assertStoreContent + :: FilePath + -> StoreDirLayout + -> CompilerId + -> Set.Set UnitId + -> Assertion assertStoreContent tmp storeDirLayout compid expected = do - actual <- runRebuild tmp $ getStoreEntries storeDirLayout compid - assertEqual "store content" actual expected - + actual <- runRebuild tmp $ getStoreEntries storeDirLayout compid + assertEqual "store content" actual expected assertFileEqual :: FilePath -> String -> Assertion assertFileEqual path expected = do - exists <- doesFileExist path - assertBool ("file does not exist:\n" ++ path) exists - actual <- readFile path - assertEqual ("file content for:\n" ++ path) expected actual - + exists <- doesFileExist path + assertBool ("file does not exist:\n" ++ path) exists + actual <- readFile path + assertEqual ("file content for:\n" ++ path) expected actual verbosity :: Verbosity verbosity = silent - diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Tar.hs b/cabal-install/tests/UnitTests/Distribution/Client/Tar.hs index 8b70dd89e4c..6295de6ace8 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Tar.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Tar.hs @@ -1,54 +1,73 @@ -module UnitTests.Distribution.Client.Tar ( - tests +module UnitTests.Distribution.Client.Tar + ( tests ) where -import Distribution.Client.Tar ( filterEntries - , filterEntriesM - ) -import Codec.Archive.Tar ( Entries(..) - , foldEntries - ) -import Codec.Archive.Tar.Entry ( EntryContent(..) - , simpleEntry - , Entry(..) - , toTarPath - ) +import Codec.Archive.Tar + ( Entries (..) + , foldEntries + ) +import Codec.Archive.Tar.Entry + ( Entry (..) + , EntryContent (..) + , simpleEntry + , toTarPath + ) +import Distribution.Client.Tar + ( filterEntries + , filterEntriesM + ) import Test.Tasty import Test.Tasty.HUnit +import Control.Monad.Writer.Lazy (runWriterT, tell) import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 -import Control.Monad.Writer.Lazy (runWriterT, tell) tests :: [TestTree] -tests = [ testCase "filterEntries" filterTest - , testCase "filterEntriesM" filterMTest - ] +tests = + [ testCase "filterEntries" filterTest + , testCase "filterEntriesM" filterMTest + ] filterTest :: Assertion filterTest = do let e1 = getFileEntry "file1" "x" e2 = getFileEntry "file2" "y" - p = (\e -> let str = BS.Char8.unpack $ case entryContent e of - NormalFile dta _ -> dta - _ -> error "Invalid entryContent" - in str /= "y") + p = + ( \e -> + let str = BS.Char8.unpack $ case entryContent e of + NormalFile dta _ -> dta + _ -> error "Invalid entryContent" + in str /= "y" + ) assertEqual "Unexpected result for filter" "xz" $ - entriesToString $ filterEntries p $ Next e1 $ Next e2 Done + entriesToString $ + filterEntries p $ + Next e1 $ + Next e2 Done assertEqual "Unexpected result for filter" "z" $ - entriesToString $ filterEntries p $ Done + entriesToString $ + filterEntries p $ + Done assertEqual "Unexpected result for filter" "xf" $ - entriesToString $ filterEntries p $ Next e1 $ Next e2 $ Fail "f" + entriesToString $ + filterEntries p $ + Next e1 $ + Next e2 $ + Fail "f" filterMTest :: Assertion filterMTest = do let e1 = getFileEntry "file1" "x" e2 = getFileEntry "file2" "y" - p = (\e -> let str = BS.Char8.unpack $ case entryContent e of - NormalFile dta _ -> dta - _ -> error "Invalid entryContent" - in tell "t" >> return (str /= "y")) + p = + ( \e -> + let str = BS.Char8.unpack $ case entryContent e of + NormalFile dta _ -> dta + _ -> error "Invalid entryContent" + in tell "t" >> return (str /= "y") + ) (r, w) <- runWriterT $ filterEntriesM p $ Next e1 $ Next e2 Done assertEqual "Unexpected result for filterM" "xz" $ entriesToString r @@ -65,14 +84,20 @@ filterMTest = do getFileEntry :: FilePath -> [Char] -> Entry getFileEntry pth dta = simpleEntry tp $ NormalFile dta' $ BS.length dta' - where tp = case toTarPath False pth of - Right tp' -> tp' - Left e -> error e - dta' = BS.Char8.pack dta + where + tp = case toTarPath False pth of + Right tp' -> tp' + Left e -> error e + dta' = BS.Char8.pack dta entriesToString :: Entries String -> String entriesToString = - foldEntries (\e acc -> let str = BS.Char8.unpack $ case entryContent e of - NormalFile dta _ -> dta - _ -> error "Invalid entryContent" - in str ++ acc) "z" id + foldEntries + ( \e acc -> + let str = BS.Char8.unpack $ case entryContent e of + NormalFile dta _ -> dta + _ -> error "Invalid entryContent" + in str ++ acc + ) + "z" + id diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs b/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs index 0e4e93b8aab..060dbdffe4f 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs @@ -1,82 +1,107 @@ -module UnitTests.Distribution.Client.Targets ( - tests +module UnitTests.Distribution.Client.Targets + ( tests ) where -import Distribution.Client.Targets (UserQualifier(..) - ,UserConstraintScope(..) - ,UserConstraint(..), readUserConstraint) -import Distribution.Package (mkPackageName) -import Distribution.PackageDescription (mkFlagName, mkFlagAssignment) -import Distribution.Version (anyVersion, thisVersion, mkVersion) +import Distribution.Client.Targets + ( UserConstraint (..) + , UserConstraintScope (..) + , UserQualifier (..) + , readUserConstraint + ) +import Distribution.Package (mkPackageName) +import Distribution.PackageDescription (mkFlagAssignment, mkFlagName) +import Distribution.Version (anyVersion, mkVersion, thisVersion) import Distribution.Parsec (explicitEitherParsec, parsec, parsecCommaList) -import Distribution.Solver.Types.PackageConstraint (PackageProperty(..)) -import Distribution.Solver.Types.OptionalStanza (OptionalStanza(..)) +import Distribution.Solver.Types.OptionalStanza (OptionalStanza (..)) +import Distribution.Solver.Types.PackageConstraint (PackageProperty (..)) import Test.Tasty import Test.Tasty.HUnit -import Data.List (intercalate) +import Data.List (intercalate) -- Helper function: makes a test group by mapping each element -- of a list to a test case. makeGroup :: String -> (a -> Assertion) -> [a] -> TestTree -makeGroup name f xs = testGroup name $ - zipWith testCase (map show [0 :: Integer ..]) (map f xs) +makeGroup name f xs = + testGroup name $ + zipWith testCase (map show [0 :: Integer ..]) (map f xs) tests :: [TestTree] tests = - [ makeGroup "readUserConstraint" (uncurry readUserConstraintTest) + [ makeGroup + "readUserConstraint" + (uncurry readUserConstraintTest) exampleConstraints - - , makeGroup "parseUserConstraint" (uncurry parseUserConstraintTest) + , makeGroup + "parseUserConstraint" + (uncurry parseUserConstraintTest) exampleConstraints - - , makeGroup "readUserConstraints" (uncurry readUserConstraintsTest) - [-- First example only. - (head exampleStrs, take 1 exampleUcs), - -- All examples separated by commas. - (intercalate ", " exampleStrs, exampleUcs)] + , makeGroup + "readUserConstraints" + (uncurry readUserConstraintsTest) + [ -- First example only. + (head exampleStrs, take 1 exampleUcs) + , -- All examples separated by commas. + (intercalate ", " exampleStrs, exampleUcs) + ] ] where (exampleStrs, exampleUcs) = unzip exampleConstraints exampleConstraints :: [(String, UserConstraint)] exampleConstraints = - [ ("template-haskell installed", - UserConstraint (UserQualified UserQualToplevel (pn "template-haskell")) - PackagePropertyInstalled) - - , ("bytestring >= 0", - UserConstraint (UserQualified UserQualToplevel (pn "bytestring")) - (PackagePropertyVersion anyVersion)) - - , ("any.directory test", - UserConstraint (UserAnyQualifier (pn "directory")) - (PackagePropertyStanzas [TestStanzas])) - - , ("setup.Cabal installed", - UserConstraint (UserAnySetupQualifier (pn "Cabal")) - PackagePropertyInstalled) - - , ("process:setup.bytestring ==5.2", - UserConstraint (UserQualified (UserQualSetup (pn "process")) (pn "bytestring")) - (PackagePropertyVersion (thisVersion (mkVersion [5, 2])))) - - -- flag MUST be prefixed with - or + - , ("network:setup.containers +foo -bar +baz", - UserConstraint (UserQualified (UserQualSetup (pn "network")) (pn "containers")) - (PackagePropertyFlags (mkFlagAssignment - [(fn "foo", True), - (fn "bar", False), - (fn "baz", True)]))) - - -- -- TODO: Re-enable UserQualExe tests once we decide on a syntax. - -- - -- , ("foo:happy:exe.template-haskell test", - -- UserConstraint (UserQualified (UserQualExe (pn "foo") (pn "happy")) (pn "template-haskell")) - -- (PackagePropertyStanzas [TestStanzas])) + [ + ( "template-haskell installed" + , UserConstraint + (UserQualified UserQualToplevel (pn "template-haskell")) + PackagePropertyInstalled + ) + , + ( "bytestring >= 0" + , UserConstraint + (UserQualified UserQualToplevel (pn "bytestring")) + (PackagePropertyVersion anyVersion) + ) + , + ( "any.directory test" + , UserConstraint + (UserAnyQualifier (pn "directory")) + (PackagePropertyStanzas [TestStanzas]) + ) + , + ( "setup.Cabal installed" + , UserConstraint + (UserAnySetupQualifier (pn "Cabal")) + PackagePropertyInstalled + ) + , + ( "process:setup.bytestring ==5.2" + , UserConstraint + (UserQualified (UserQualSetup (pn "process")) (pn "bytestring")) + (PackagePropertyVersion (thisVersion (mkVersion [5, 2]))) + ) + , -- flag MUST be prefixed with - or + + + ( "network:setup.containers +foo -bar +baz" + , UserConstraint + (UserQualified (UserQualSetup (pn "network")) (pn "containers")) + ( PackagePropertyFlags + ( mkFlagAssignment + [ (fn "foo", True) + , (fn "bar", False) + , (fn "baz", True) + ] + ) + ) + ) + -- -- TODO: Re-enable UserQualExe tests once we decide on a syntax. + -- + -- , ("foo:happy:exe.template-haskell test", + -- UserConstraint (UserQualified (UserQualExe (pn "foo") (pn "happy")) (pn "template-haskell")) + -- (PackagePropertyStanzas [TestStanzas])) ] where pn = mkPackageName @@ -87,18 +112,18 @@ readUserConstraintTest str uc = assertEqual ("Couldn't read constraint: '" ++ str ++ "'") expected actual where expected = Right uc - actual = readUserConstraint str + actual = readUserConstraint str parseUserConstraintTest :: String -> UserConstraint -> Assertion parseUserConstraintTest str uc = assertEqual ("Couldn't parse constraint: '" ++ str ++ "'") expected actual where expected = Right uc - actual = explicitEitherParsec parsec str + actual = explicitEitherParsec parsec str readUserConstraintsTest :: String -> [UserConstraint] -> Assertion readUserConstraintsTest str ucs = assertEqual ("Couldn't read constraints: '" ++ str ++ "'") expected actual where expected = Right ucs - actual = explicitEitherParsec (parsecCommaList parsec) str + actual = explicitEitherParsec (parsecCommaList parsec) str diff --git a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs index e7e0c3671ba..495c4cbf402 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs @@ -17,10 +17,10 @@ import Distribution.Client.IndexUtils.Timestamp import Distribution.Client.ProjectConfig.Types import Distribution.Client.Targets import Distribution.Client.Types -import Distribution.Client.Types.OverwritePolicy (OverwritePolicy) -import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage) +import Distribution.Client.Types.OverwritePolicy (OverwritePolicy) +import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage) -import Distribution.Simple.Compiler (PackageDB) +import Distribution.Simple.Compiler (PackageDB) import Data.TreeDiff.Class import Data.TreeDiff.Instances.Cabal () diff --git a/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs index 3bb92121f62..17adc1b75b4 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs @@ -1,112 +1,110 @@ {-# LANGUAGE CPP #-} + module UnitTests.Distribution.Client.UserConfig - ( tests - ) where + ( tests + ) where import Control.Exception (bracket) import Control.Monad (replicateM_) -import Data.List (sort, nub) +import Data.List (nub, sort) #if !MIN_VERSION_base(4,8,0) import Data.Monoid #endif -import System.Directory (doesFileExist, - getCurrentDirectory, getTemporaryDirectory) +import System.Directory + ( doesFileExist + , getCurrentDirectory + , getTemporaryDirectory + ) import System.FilePath (()) import Test.Tasty import Test.Tasty.HUnit import Distribution.Client.Config -import Distribution.Utils.NubList (fromNubList) import Distribution.Client.Setup (GlobalFlags (..), InstallFlags (..)) import Distribution.Client.Utils (removeExistingFile) -import Distribution.Simple.Setup (Flag (..), ConfigFlags (..), fromFlag) +import Distribution.Simple.Setup (ConfigFlags (..), Flag (..), fromFlag) import Distribution.Simple.Utils (withTempDirectory) +import Distribution.Utils.NubList (fromNubList) import Distribution.Verbosity (silent) tests :: [TestTree] -tests = [ testCase "nullDiffOnCreate" nullDiffOnCreateTest - , testCase "canDetectDifference" canDetectDifference - , testCase "canUpdateConfig" canUpdateConfig - , testCase "doubleUpdateConfig" doubleUpdateConfig - , testCase "newDefaultConfig" newDefaultConfig - ] +tests = + [ testCase "nullDiffOnCreate" nullDiffOnCreateTest + , testCase "canDetectDifference" canDetectDifference + , testCase "canUpdateConfig" canUpdateConfig + , testCase "doubleUpdateConfig" doubleUpdateConfig + , testCase "newDefaultConfig" newDefaultConfig + ] nullDiffOnCreateTest :: Assertion nullDiffOnCreateTest = bracketTest $ \configFile -> do - -- Create a new default config file in our test directory. - _ <- createDefaultConfigFile silent [] configFile - -- Now we read it in and compare it against the default. - diff <- userConfigDiff silent (globalFlags configFile) [] - assertBool (unlines $ "Following diff should be empty:" : diff) $ null diff - + -- Create a new default config file in our test directory. + _ <- createDefaultConfigFile silent [] configFile + -- Now we read it in and compare it against the default. + diff <- userConfigDiff silent (globalFlags configFile) [] + assertBool (unlines $ "Following diff should be empty:" : diff) $ null diff canDetectDifference :: Assertion canDetectDifference = bracketTest $ \configFile -> do - -- Create a new default config file in our test directory. - _ <- createDefaultConfigFile silent [] configFile - appendFile configFile "verbose: 0\n" - diff <- userConfigDiff silent (globalFlags configFile) [] - assertBool (unlines $ "Should detect a difference:" : diff) $ - diff == [ "+ verbose: 0" ] - + -- Create a new default config file in our test directory. + _ <- createDefaultConfigFile silent [] configFile + appendFile configFile "verbose: 0\n" + diff <- userConfigDiff silent (globalFlags configFile) [] + assertBool (unlines $ "Should detect a difference:" : diff) $ + diff == ["+ verbose: 0"] canUpdateConfig :: Assertion canUpdateConfig = bracketTest $ \configFile -> do - -- Write a trivial cabal file. - writeFile configFile "tests: True\n" - -- Update the config file. - userConfigUpdate silent (globalFlags configFile) [] - -- Load it again. - updated <- loadConfig silent (Flag configFile) - assertBool ("Field 'tests' should be True") $ - fromFlag (configTests $ savedConfigureFlags updated) - + -- Write a trivial cabal file. + writeFile configFile "tests: True\n" + -- Update the config file. + userConfigUpdate silent (globalFlags configFile) [] + -- Load it again. + updated <- loadConfig silent (Flag configFile) + assertBool ("Field 'tests' should be True") $ + fromFlag (configTests $ savedConfigureFlags updated) doubleUpdateConfig :: Assertion doubleUpdateConfig = bracketTest $ \configFile -> do - -- Create a new default config file in our test directory. - _ <- createDefaultConfigFile silent [] configFile - -- Update it twice. - replicateM_ 2 $ userConfigUpdate silent (globalFlags configFile) [] - -- Load it again. - updated <- loadConfig silent (Flag configFile) - - assertBool ("Field 'remote-repo' doesn't contain duplicates") $ - listUnique (map show . fromNubList . globalRemoteRepos $ savedGlobalFlags updated) - assertBool ("Field 'extra-prog-path' doesn't contain duplicates") $ - listUnique (map show . fromNubList . configProgramPathExtra $ savedConfigureFlags updated) - assertBool ("Field 'build-summary' doesn't contain duplicates") $ - listUnique (map show . fromNubList . installSummaryFile $ savedInstallFlags updated) - + -- Create a new default config file in our test directory. + _ <- createDefaultConfigFile silent [] configFile + -- Update it twice. + replicateM_ 2 $ userConfigUpdate silent (globalFlags configFile) [] + -- Load it again. + updated <- loadConfig silent (Flag configFile) + + assertBool ("Field 'remote-repo' doesn't contain duplicates") $ + listUnique (map show . fromNubList . globalRemoteRepos $ savedGlobalFlags updated) + assertBool ("Field 'extra-prog-path' doesn't contain duplicates") $ + listUnique (map show . fromNubList . configProgramPathExtra $ savedConfigureFlags updated) + assertBool ("Field 'build-summary' doesn't contain duplicates") $ + listUnique (map show . fromNubList . installSummaryFile $ savedInstallFlags updated) newDefaultConfig :: Assertion newDefaultConfig = do - sysTmpDir <- getTemporaryDirectory - withTempDirectory silent sysTmpDir "cabal-test" $ \tmpDir -> do - let configFile = tmpDir "tmp.config" - _ <- createDefaultConfigFile silent [] configFile - exists <- doesFileExist configFile - assertBool ("Config file should be written to " ++ configFile) exists - + sysTmpDir <- getTemporaryDirectory + withTempDirectory silent sysTmpDir "cabal-test" $ \tmpDir -> do + let configFile = tmpDir "tmp.config" + _ <- createDefaultConfigFile silent [] configFile + exists <- doesFileExist configFile + assertBool ("Config file should be written to " ++ configFile) exists globalFlags :: FilePath -> GlobalFlags -globalFlags configFile = mempty { globalConfigFile = Flag configFile } - +globalFlags configFile = mempty{globalConfigFile = Flag configFile} listUnique :: Ord a => [a] -> Bool listUnique xs = - let sorted = sort xs - in nub sorted == xs - + let sorted = sort xs + in nub sorted == xs bracketTest :: (FilePath -> IO ()) -> Assertion bracketTest = - bracket testSetup testTearDown + bracket testSetup testTearDown where testSetup :: IO FilePath testSetup = fmap ( "test-user-config") getCurrentDirectory testTearDown :: FilePath -> IO () testTearDown configFile = - mapM_ removeExistingFile [configFile, configFile ++ ".backup"] + mapM_ removeExistingFile [configFile, configFile ++ ".backup"] diff --git a/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs b/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs index b361bdd8ff3..6aeadfd2c4e 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs @@ -1,37 +1,43 @@ -{-# LANGUAGE RecordWildCards, NamedFieldPuns, KindSignatures, DataKinds #-} -{-# LANGUAGE AllowAmbiguousTypes, TypeApplications, ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + module UnitTests.Distribution.Client.VCS (tests) where import Distribution.Client.Compat.Prelude -import Distribution.Client.VCS import Distribution.Client.RebuildMonad - ( execRebuild ) + ( execRebuild + ) +import Distribution.Client.Types.SourceRepo (SourceRepoProxy, SourceRepositoryPackage (..)) +import Distribution.Client.VCS import Distribution.Simple.Program -import Distribution.System ( buildOS, OS (Windows) ) +import Distribution.System (OS (Windows), buildOS) import Distribution.Verbosity as Verbosity -import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage (..), SourceRepoProxy) import Data.List (mapAccumL) -import Data.Tuple import qualified Data.Map as Map import qualified Data.Set as Set +import Data.Tuple -import qualified Control.Monad.State as State -import Control.Monad.State (StateT, liftIO, execStateT) -import Control.Exception import Control.Concurrent (threadDelay) +import Control.Exception +import Control.Monad.State (StateT, execStateT, liftIO) +import qualified Control.Monad.State as State -import System.IO -import System.FilePath import System.Directory +import System.FilePath +import System.IO import System.Random import Test.Tasty -import Test.Tasty.QuickCheck import Test.Tasty.ExpectedFailure +import Test.Tasty.QuickCheck import UnitTests.Distribution.Client.ArbitraryInstances -import UnitTests.TempTestDir (withTestDir, removeDirectoryRecursiveHack) - +import UnitTests.TempTestDir (removeDirectoryRecursiveHack, withTestDir) -- | These tests take the following approach: we generate a pure representation -- of a repository plus a corresponding real repository, and then run various @@ -47,248 +53,317 @@ import UnitTests.TempTestDir (withTestDir, removeDirectoryRecursiveHack) -- directories. It picks a number of tags or commits from the source repo and -- synchronises the destination directories to those target states, and then -- checks that the working state is as expected (given the pure representation). --- tests :: MTimeChange -> [TestTree] -tests mtimeChange = map (localOption $ QuickCheckTests 10) - [ ignoreInWindows "See issue #8048" $ - testGroup "git" - [ testProperty "check VCS test framework" prop_framework_git - , testProperty "cloneSourceRepo" prop_cloneRepo_git - , testProperty "syncSourceRepos" prop_syncRepos_git +tests mtimeChange = + map + (localOption $ QuickCheckTests 10) + [ ignoreInWindows "See issue #8048" $ + testGroup + "git" + [ testProperty "check VCS test framework" prop_framework_git + , testProperty "cloneSourceRepo" prop_cloneRepo_git + , testProperty "syncSourceRepos" prop_syncRepos_git + ] + , -- + ignoreTestBecause "for the moment they're not yet working" $ + testGroup + "darcs" + [ testProperty "check VCS test framework" $ prop_framework_darcs mtimeChange + , testProperty "cloneSourceRepo" $ prop_cloneRepo_darcs mtimeChange + , testProperty "syncSourceRepos" $ prop_syncRepos_darcs mtimeChange + ] + , ignoreTestBecause "for the moment they're not yet working" $ + testGroup + "pijul" + [ testProperty "check VCS test framework" prop_framework_pijul + , testProperty "cloneSourceRepo" prop_cloneRepo_pijul + , testProperty "syncSourceRepos" prop_syncRepos_pijul + ] + , ignoreTestBecause "for the moment they're not yet working" $ + testGroup + "mercurial" + [ testProperty "check VCS test framework" prop_framework_hg + , testProperty "cloneSourceRepo" prop_cloneRepo_hg + , testProperty "syncSourceRepos" prop_syncRepos_hg + ] ] - - -- - , ignoreTestBecause "for the moment they're not yet working" $ - testGroup "darcs" - [ testProperty "check VCS test framework" $ prop_framework_darcs mtimeChange - , testProperty "cloneSourceRepo" $ prop_cloneRepo_darcs mtimeChange - , testProperty "syncSourceRepos" $ prop_syncRepos_darcs mtimeChange - ] - - , ignoreTestBecause "for the moment they're not yet working" $ - testGroup "pijul" - [ testProperty "check VCS test framework" prop_framework_pijul - , testProperty "cloneSourceRepo" prop_cloneRepo_pijul - , testProperty "syncSourceRepos" prop_syncRepos_pijul - ] - - , ignoreTestBecause "for the moment they're not yet working" $ - testGroup "mercurial" - [ testProperty "check VCS test framework" prop_framework_hg - , testProperty "cloneSourceRepo" prop_cloneRepo_hg - , testProperty "syncSourceRepos" prop_syncRepos_hg - ] - - ] - - where ignoreInWindows msg = case buildOS of - Windows -> ignoreTestBecause msg - _ -> id + where + ignoreInWindows msg = case buildOS of + Windows -> ignoreTestBecause msg + _ -> id prop_framework_git :: BranchingRepoRecipe 'SubmodulesSupported -> Property prop_framework_git = - ioProperty - . prop_framework vcsGit vcsTestDriverGit - . WithBranchingSupport + ioProperty + . prop_framework vcsGit vcsTestDriverGit + . WithBranchingSupport prop_framework_darcs :: MTimeChange -> NonBranchingRepoRecipe 'SubmodulesNotSupported -> Property prop_framework_darcs mtimeChange = - ioProperty - . prop_framework vcsDarcs (vcsTestDriverDarcs mtimeChange) - . WithoutBranchingSupport + ioProperty + . prop_framework vcsDarcs (vcsTestDriverDarcs mtimeChange) + . WithoutBranchingSupport prop_framework_pijul :: BranchingRepoRecipe 'SubmodulesNotSupported -> Property prop_framework_pijul = - ioProperty - . prop_framework vcsPijul vcsTestDriverPijul - . WithBranchingSupport + ioProperty + . prop_framework vcsPijul vcsTestDriverPijul + . WithBranchingSupport prop_framework_hg :: BranchingRepoRecipe 'SubmodulesNotSupported -> Property prop_framework_hg = - ioProperty - . prop_framework vcsHg vcsTestDriverHg - . WithBranchingSupport + ioProperty + . prop_framework vcsHg vcsTestDriverHg + . WithBranchingSupport prop_cloneRepo_git :: BranchingRepoRecipe 'SubmodulesSupported -> Property prop_cloneRepo_git = - ioProperty - . prop_cloneRepo vcsGit vcsTestDriverGit - . WithBranchingSupport - -prop_cloneRepo_darcs :: MTimeChange - -> NonBranchingRepoRecipe 'SubmodulesNotSupported -> Property + ioProperty + . prop_cloneRepo vcsGit vcsTestDriverGit + . WithBranchingSupport + +prop_cloneRepo_darcs + :: MTimeChange + -> NonBranchingRepoRecipe 'SubmodulesNotSupported + -> Property prop_cloneRepo_darcs mtimeChange = - ioProperty - . prop_cloneRepo vcsDarcs (vcsTestDriverDarcs mtimeChange) - . WithoutBranchingSupport + ioProperty + . prop_cloneRepo vcsDarcs (vcsTestDriverDarcs mtimeChange) + . WithoutBranchingSupport prop_cloneRepo_pijul :: BranchingRepoRecipe 'SubmodulesNotSupported -> Property prop_cloneRepo_pijul = - ioProperty - . prop_cloneRepo vcsPijul vcsTestDriverPijul - . WithBranchingSupport + ioProperty + . prop_cloneRepo vcsPijul vcsTestDriverPijul + . WithBranchingSupport prop_cloneRepo_hg :: BranchingRepoRecipe 'SubmodulesNotSupported -> Property prop_cloneRepo_hg = - ioProperty - . prop_cloneRepo vcsHg vcsTestDriverHg - . WithBranchingSupport + ioProperty + . prop_cloneRepo vcsHg vcsTestDriverHg + . WithBranchingSupport -prop_syncRepos_git :: RepoDirSet -> SyncTargetIterations -> PrngSeed - -> BranchingRepoRecipe 'SubmodulesSupported -> Property +prop_syncRepos_git + :: RepoDirSet + -> SyncTargetIterations + -> PrngSeed + -> BranchingRepoRecipe 'SubmodulesSupported + -> Property prop_syncRepos_git destRepoDirs syncTargetSetIterations seed = - ioProperty - . prop_syncRepos vcsGit vcsTestDriverGit - destRepoDirs syncTargetSetIterations seed - . WithBranchingSupport - -prop_syncRepos_darcs :: MTimeChange - -> RepoDirSet -> SyncTargetIterations -> PrngSeed - -> NonBranchingRepoRecipe 'SubmodulesNotSupported -> Property -prop_syncRepos_darcs mtimeChange destRepoDirs syncTargetSetIterations seed = - ioProperty - . prop_syncRepos vcsDarcs (vcsTestDriverDarcs mtimeChange) - destRepoDirs syncTargetSetIterations seed - . WithoutBranchingSupport - -prop_syncRepos_pijul :: RepoDirSet -> SyncTargetIterations -> PrngSeed - -> BranchingRepoRecipe 'SubmodulesNotSupported -> Property + ioProperty + . prop_syncRepos + vcsGit + vcsTestDriverGit + destRepoDirs + syncTargetSetIterations + seed + . WithBranchingSupport + +prop_syncRepos_darcs + :: MTimeChange + -> RepoDirSet + -> SyncTargetIterations + -> PrngSeed + -> NonBranchingRepoRecipe 'SubmodulesNotSupported + -> Property +prop_syncRepos_darcs mtimeChange destRepoDirs syncTargetSetIterations seed = + ioProperty + . prop_syncRepos + vcsDarcs + (vcsTestDriverDarcs mtimeChange) + destRepoDirs + syncTargetSetIterations + seed + . WithoutBranchingSupport + +prop_syncRepos_pijul + :: RepoDirSet + -> SyncTargetIterations + -> PrngSeed + -> BranchingRepoRecipe 'SubmodulesNotSupported + -> Property prop_syncRepos_pijul destRepoDirs syncTargetSetIterations seed = - ioProperty - . prop_syncRepos vcsPijul vcsTestDriverPijul - destRepoDirs syncTargetSetIterations seed - . WithBranchingSupport - -prop_syncRepos_hg :: RepoDirSet -> SyncTargetIterations -> PrngSeed - -> BranchingRepoRecipe 'SubmodulesNotSupported -> Property + ioProperty + . prop_syncRepos + vcsPijul + vcsTestDriverPijul + destRepoDirs + syncTargetSetIterations + seed + . WithBranchingSupport + +prop_syncRepos_hg + :: RepoDirSet + -> SyncTargetIterations + -> PrngSeed + -> BranchingRepoRecipe 'SubmodulesNotSupported + -> Property prop_syncRepos_hg destRepoDirs syncTargetSetIterations seed = - ioProperty - . prop_syncRepos vcsHg vcsTestDriverHg - destRepoDirs syncTargetSetIterations seed - . WithBranchingSupport + ioProperty + . prop_syncRepos + vcsHg + vcsTestDriverHg + destRepoDirs + syncTargetSetIterations + seed + . WithBranchingSupport -- ------------------------------------------------------------ + -- * General test setup + -- ------------------------------------------------------------ -testSetup :: VCS Program - -> (Verbosity -> VCS ConfiguredProgram - -> FilePath -> FilePath -> VCSTestDriver) - -> RepoRecipe submodules - -> (VCSTestDriver -> FilePath -> RepoState -> IO a) - -> IO a +testSetup + :: VCS Program + -> ( Verbosity + -> VCS ConfiguredProgram + -> FilePath + -> FilePath + -> VCSTestDriver + ) + -> RepoRecipe submodules + -> (VCSTestDriver -> FilePath -> RepoState -> IO a) + -> IO a testSetup vcs mkVCSTestDriver repoRecipe theTest = do - -- test setup - vcs' <- configureVCS verbosity vcs - withTestDir verbosity "vcstest" $ \tmpdir -> do - let srcRepoPath = tmpdir "src" - submodulesPath = tmpdir "submodules" - vcsDriver = mkVCSTestDriver verbosity vcs' submodulesPath srcRepoPath - repoState <- createRepo vcsDriver repoRecipe - - -- actual test - result <- theTest vcsDriver tmpdir repoState - - return result + -- test setup + vcs' <- configureVCS verbosity vcs + withTestDir verbosity "vcstest" $ \tmpdir -> do + let srcRepoPath = tmpdir "src" + submodulesPath = tmpdir "submodules" + vcsDriver = mkVCSTestDriver verbosity vcs' submodulesPath srcRepoPath + repoState <- createRepo vcsDriver repoRecipe + + -- actual test + result <- theTest vcsDriver tmpdir repoState + + return result where verbosity = silent -- ------------------------------------------------------------ + -- * Test 1: VCS infrastructure + -- ------------------------------------------------------------ -- | This test simply checks that the test infrastructure works. It constructs -- a repository on disk and then checks out every tag or commit and checks that -- the working state is the same as the pure representation. --- -prop_framework :: VCS Program - -> (Verbosity -> VCS ConfiguredProgram - -> FilePath -> FilePath -> VCSTestDriver) - -> RepoRecipe submodules - -> IO () +prop_framework + :: VCS Program + -> ( Verbosity + -> VCS ConfiguredProgram + -> FilePath + -> FilePath + -> VCSTestDriver + ) + -> RepoRecipe submodules + -> IO () prop_framework vcs mkVCSTestDriver repoRecipe = - testSetup vcs mkVCSTestDriver repoRecipe $ \vcsDriver tmpdir repoState -> - mapM_ (checkAtTag vcsDriver tmpdir) (Map.toList (allTags repoState)) + testSetup vcs mkVCSTestDriver repoRecipe $ \vcsDriver tmpdir repoState -> + mapM_ (checkAtTag vcsDriver tmpdir) (Map.toList (allTags repoState)) where -- Check for any given tag/commit in the 'RepoState' that the working state -- matches the actual working state from the repository at that tag/commit. - checkAtTag VCSTestDriver {..} tmpdir (tagname, expectedState) = + checkAtTag VCSTestDriver{..} tmpdir (tagname, expectedState) = case vcsCheckoutTag of -- We handle two cases: inplace checkouts for VCSs that support it -- (e.g. git) and separate dir otherwise (e.g. darcs) Left checkoutInplace -> do checkoutInplace tagname checkExpectedWorkingState vcsIgnoreFiles vcsRepoRoot expectedState - Right checkoutCloneTo -> do checkoutCloneTo tagname destRepoPath checkExpectedWorkingState vcsIgnoreFiles destRepoPath expectedState removeDirectoryRecursiveHack silent destRepoPath - where - destRepoPath = tmpdir "dest" - + where + destRepoPath = tmpdir "dest" -- ------------------------------------------------------------ + -- * Test 2: 'cloneSourceRepo' + -- ------------------------------------------------------------ -prop_cloneRepo :: VCS Program - -> (Verbosity -> VCS ConfiguredProgram - -> FilePath -> FilePath -> VCSTestDriver) - -> RepoRecipe submodules - -> IO () +prop_cloneRepo + :: VCS Program + -> ( Verbosity + -> VCS ConfiguredProgram + -> FilePath + -> FilePath + -> VCSTestDriver + ) + -> RepoRecipe submodules + -> IO () prop_cloneRepo vcs mkVCSTestDriver repoRecipe = - testSetup vcs mkVCSTestDriver repoRecipe $ \vcsDriver tmpdir repoState -> - mapM_ (checkAtTag vcsDriver tmpdir) (Map.toList (allTags repoState)) + testSetup vcs mkVCSTestDriver repoRecipe $ \vcsDriver tmpdir repoState -> + mapM_ (checkAtTag vcsDriver tmpdir) (Map.toList (allTags repoState)) where checkAtTag VCSTestDriver{..} tmpdir (tagname, expectedState) = do - cloneSourceRepo verbosity vcsVCS repo destRepoPath - checkExpectedWorkingState vcsIgnoreFiles destRepoPath expectedState - removeDirectoryRecursiveHack verbosity destRepoPath + cloneSourceRepo verbosity vcsVCS repo destRepoPath + checkExpectedWorkingState vcsIgnoreFiles destRepoPath expectedState + removeDirectoryRecursiveHack verbosity destRepoPath where destRepoPath = tmpdir "dest" - repo = SourceRepositoryPackage - { srpType = vcsRepoType vcsVCS + repo = + SourceRepositoryPackage + { srpType = vcsRepoType vcsVCS , srpLocation = vcsRepoRoot - , srpTag = Just tagname - , srpBranch = Nothing - , srpSubdir = [] - , srpCommand = [] + , srpTag = Just tagname + , srpBranch = Nothing + , srpSubdir = [] + , srpCommand = [] } verbosity = silent - -- ------------------------------------------------------------ + -- * Test 3: 'syncSourceRepos' + -- ------------------------------------------------------------ -newtype RepoDirSet = RepoDirSet Int deriving Show -newtype SyncTargetIterations = SyncTargetIterations Int deriving Show -newtype PrngSeed = PrngSeed Int deriving Show - -prop_syncRepos :: VCS Program - -> (Verbosity -> VCS ConfiguredProgram - -> FilePath -> FilePath -> VCSTestDriver) - -> RepoDirSet - -> SyncTargetIterations - -> PrngSeed - -> RepoRecipe submodules - -> IO () -prop_syncRepos vcs mkVCSTestDriver - repoDirs syncTargetSetIterations seed repoRecipe = +newtype RepoDirSet = RepoDirSet Int deriving (Show) +newtype SyncTargetIterations = SyncTargetIterations Int deriving (Show) +newtype PrngSeed = PrngSeed Int deriving (Show) + +prop_syncRepos + :: VCS Program + -> ( Verbosity + -> VCS ConfiguredProgram + -> FilePath + -> FilePath + -> VCSTestDriver + ) + -> RepoDirSet + -> SyncTargetIterations + -> PrngSeed + -> RepoRecipe submodules + -> IO () +prop_syncRepos + vcs + mkVCSTestDriver + repoDirs + syncTargetSetIterations + seed + repoRecipe = testSetup vcs mkVCSTestDriver repoRecipe $ \vcsDriver tmpdir repoState -> - let srcRepoPath = vcsRepoRoot vcsDriver + let srcRepoPath = vcsRepoRoot vcsDriver destRepoPaths = map (tmpdir ) (getRepoDirs repoDirs) - in checkSyncRepos verbosity vcsDriver repoState - srcRepoPath destRepoPaths - syncTargetSetIterations seed - where - verbosity = silent - - getRepoDirs :: RepoDirSet -> [FilePath] - getRepoDirs (RepoDirSet n) = - [ "dest" ++ show i | i <- [1..n] ] + in checkSyncRepos + verbosity + vcsDriver + repoState + srcRepoPath + destRepoPaths + syncTargetSetIterations + seed + where + verbosity = silent + getRepoDirs :: RepoDirSet -> [FilePath] + getRepoDirs (RepoDirSet n) = + ["dest" ++ show i | i <- [1 .. n]] -- | The purpose of this test is to check that irrespective of the local cached -- repo dir we can sync it to an arbitrary target state. So we do that by @@ -303,7 +378,6 @@ prop_syncRepos vcs mkVCSTestDriver -- target repo dirs, pick a sequence of (lists of) sync targets from the -- 'RepoState' and synchronise the target dirs with those targets, checking for -- each one that the actual working state matches the expected repo state. --- checkSyncRepos :: Verbosity -> VCSTestDriver @@ -313,32 +387,49 @@ checkSyncRepos -> SyncTargetIterations -> PrngSeed -> IO () -checkSyncRepos verbosity VCSTestDriver { vcsVCS = vcs, vcsIgnoreFiles } - repoState srcRepoPath destRepoPath - (SyncTargetIterations syncTargetSetIterations) (PrngSeed seed) = +checkSyncRepos + verbosity + VCSTestDriver{vcsVCS = vcs, vcsIgnoreFiles} + repoState + srcRepoPath + destRepoPath + (SyncTargetIterations syncTargetSetIterations) + (PrngSeed seed) = mapM_ checkSyncTargetSet syncTargetSets - where - checkSyncTargetSet :: [(SourceRepoProxy, FilePath, RepoWorkingState)] -> IO () - checkSyncTargetSet syncTargets = do - _ <- execRebuild "root-unused" $ - syncSourceRepos verbosity vcs - [ (repo, repoPath) - | (repo, repoPath, _) <- syncTargets ] - sequence_ - [ checkExpectedWorkingState vcsIgnoreFiles repoPath workingState - | (_, repoPath, workingState) <- syncTargets ] - - syncTargetSets = take syncTargetSetIterations - $ pickSyncTargetSets (vcsRepoType vcs) repoState - srcRepoPath destRepoPath - (mkStdGen seed) - -pickSyncTargetSets :: RepoType -> RepoState - -> FilePath -> [FilePath] - -> StdGen - -> [[(SourceRepoProxy, FilePath, RepoWorkingState)]] + where + checkSyncTargetSet :: [(SourceRepoProxy, FilePath, RepoWorkingState)] -> IO () + checkSyncTargetSet syncTargets = do + _ <- + execRebuild "root-unused" $ + syncSourceRepos + verbosity + vcs + [ (repo, repoPath) + | (repo, repoPath, _) <- syncTargets + ] + sequence_ + [ checkExpectedWorkingState vcsIgnoreFiles repoPath workingState + | (_, repoPath, workingState) <- syncTargets + ] + + syncTargetSets = + take syncTargetSetIterations $ + pickSyncTargetSets + (vcsRepoType vcs) + repoState + srcRepoPath + destRepoPath + (mkStdGen seed) + +pickSyncTargetSets + :: RepoType + -> RepoState + -> FilePath + -> [FilePath] + -> StdGen + -> [[(SourceRepoProxy, FilePath, RepoWorkingState)]] pickSyncTargetSets repoType repoState srcRepoPath dstReposPath = - assert (Map.size (allTags repoState) > 0) $ + assert (Map.size (allTags repoState) > 0) $ unfoldr (Just . swap . pickSyncTargetSet) where pickSyncTargetSet :: Rand [(SourceRepoProxy, FilePath, RepoWorkingState)] @@ -346,40 +437,44 @@ pickSyncTargetSets repoType repoState srcRepoPath dstReposPath = pickSyncTarget :: FilePath -> Rand (SourceRepoProxy, FilePath, RepoWorkingState) pickSyncTarget destRepoPath prng = - (prng', (repo, destRepoPath, workingState)) + (prng', (repo, destRepoPath, workingState)) where - repo = SourceRepositoryPackage - { srpType = repoType - , srpLocation = srcRepoPath - , srpTag = Just tag - , srpBranch = Nothing - , srpSubdir = Proxy - , srpCommand = [] - } + repo = + SourceRepositoryPackage + { srpType = repoType + , srpLocation = srcRepoPath + , srpTag = Just tag + , srpBranch = Nothing + , srpSubdir = Proxy + , srpCommand = [] + } (tag, workingState) = Map.elemAt tagIdx (allTags repoState) - (tagIdx, prng') = randomR (0, Map.size (allTags repoState) - 1) prng + (tagIdx, prng') = randomR (0, Map.size (allTags repoState) - 1) prng type Rand a = StdGen -> (StdGen, a) instance Arbitrary RepoDirSet where arbitrary = - sized $ \n -> oneof $ [ RepoDirSet <$> pure 1 ] - ++ [ RepoDirSet <$> choose (2,5) | n >= 3 ] + sized $ \n -> + oneof $ + [RepoDirSet <$> pure 1] + ++ [RepoDirSet <$> choose (2, 5) | n >= 3] shrink (RepoDirSet n) = - [ RepoDirSet i | i <- shrink n, i > 0 ] + [RepoDirSet i | i <- shrink n, i > 0] instance Arbitrary SyncTargetIterations where arbitrary = - sized $ \n -> SyncTargetIterations <$> elements [ 1 .. min 20 (n + 1) ] + sized $ \n -> SyncTargetIterations <$> elements [1 .. min 20 (n + 1)] shrink (SyncTargetIterations n) = - [ SyncTargetIterations i | i <- shrink n, i > 0 ] + [SyncTargetIterations i | i <- shrink n, i > 0] instance Arbitrary PrngSeed where arbitrary = PrngSeed <$> arbitraryBoundedRandom - -- ------------------------------------------------------------ + -- * Instructions for constructing repositories + -- ------------------------------------------------------------ -- These instructions for constructing a repository can be interpreted in two @@ -397,42 +492,42 @@ instance KnownSubmodulesSupport 'SubmodulesSupported where instance KnownSubmodulesSupport 'SubmodulesNotSupported where submoduleSupport = SubmodulesNotSupported -data FileUpdate = FileUpdate FilePath String - deriving Show +data FileUpdate = FileUpdate FilePath String + deriving (Show) data SubmoduleAdd = SubmoduleAdd FilePath FilePath (Commit 'SubmodulesSupported) - deriving Show + deriving (Show) newtype Commit (submodules :: SubmodulesSupport) = Commit [Either FileUpdate SubmoduleAdd] - deriving Show + deriving (Show) data TaggedCommits (submodules :: SubmodulesSupport) - = TaggedCommits TagName [Commit submodules] - deriving Show + = TaggedCommits TagName [Commit submodules] + deriving (Show) data BranchCommits (submodules :: SubmodulesSupport) = BranchCommits BranchName [Commit submodules] - deriving Show + deriving (Show) type BranchName = String -type TagName = String +type TagName = String -- | Instructions to make a repository without branches, for VCSs that do not -- support branches (e.g. darcs). newtype NonBranchingRepoRecipe submodules = NonBranchingRepoRecipe [TaggedCommits submodules] - deriving Show + deriving (Show) -- | Instructions to make a repository with branches, for VCSs that do -- support branches (e.g. git). newtype BranchingRepoRecipe submodules = BranchingRepoRecipe [Either (TaggedCommits submodules) (BranchCommits submodules)] - deriving Show + deriving (Show) data RepoRecipe submodules - = WithBranchingSupport (BranchingRepoRecipe submodules) + = WithBranchingSupport (BranchingRepoRecipe submodules) | WithoutBranchingSupport (NonBranchingRepoRecipe submodules) - deriving Show + deriving (Show) -- --------------------------------------------------------------------------- -- Arbitrary instances for them @@ -443,28 +538,30 @@ genFileName = (\c -> "file" [c]) <$> choose ('A', 'E') instance Arbitrary FileUpdate where arbitrary = genOnlyFileUpdate where - genOnlyFileUpdate = FileUpdate <$> genFileName <*> genFileContent - genFileContent = vectorOf 10 (choose ('#', '~')) + genOnlyFileUpdate = FileUpdate <$> genFileName <*> genFileContent + genFileContent = vectorOf 10 (choose ('#', '~')) instance Arbitrary SubmoduleAdd where arbitrary = genOnlySubmoduleAdd where genOnlySubmoduleAdd = SubmoduleAdd <$> genFileName <*> genSubmoduleSrc <*> arbitrary - genSubmoduleSrc = vectorOf 20 (choose ('a', 'z')) + genSubmoduleSrc = vectorOf 20 (choose ('a', 'z')) -instance forall submodules.KnownSubmodulesSupport submodules => Arbitrary (Commit submodules) where +instance forall submodules. KnownSubmodulesSupport submodules => Arbitrary (Commit submodules) where arbitrary = Commit <$> shortListOf1 5 fileUpdateOrSubmoduleAdd where fileUpdateOrSubmoduleAdd = case submoduleSupport @submodules of - SubmodulesSupported -> frequency [ (10, Left <$> arbitrary) - , (1, Right <$> arbitrary) - ] + SubmodulesSupported -> + frequency + [ (10, Left <$> arbitrary) + , (1, Right <$> arbitrary) + ] SubmodulesNotSupported -> Left <$> arbitrary shrink (Commit writes) = Commit <$> filter (not . null) (shrink writes) instance KnownSubmodulesSupport submodules => Arbitrary (TaggedCommits submodules) where - arbitrary = TaggedCommits <$> genTagName <*> shortListOf1 5 arbitrary + arbitrary = TaggedCommits <$> genTagName <*> shortListOf1 5 arbitrary where genTagName = ("tag_" ++) <$> shortListOf1 5 (choose ('A', 'Z')) shrink (TaggedCommits tag commits) = @@ -475,7 +572,7 @@ instance KnownSubmodulesSupport submodules => Arbitrary (BranchCommits submodule where genBranchName = sized $ \n -> - (\c -> "branch_" ++ [c]) <$> elements (take (max 1 n) ['A'..'E']) + (\c -> "branch_" ++ [c]) <$> elements (take (max 1 n) ['A' .. 'E']) shrink (BranchCommits branch commits) = BranchCommits branch <$> filter (not . null) (shrink commits) @@ -488,15 +585,18 @@ instance KnownSubmodulesSupport submodules => Arbitrary (NonBranchingRepoRecipe instance KnownSubmodulesSupport submodules => Arbitrary (BranchingRepoRecipe submodules) where arbitrary = BranchingRepoRecipe <$> shortListOf1 15 taggedOrBranch where - taggedOrBranch = frequency [ (3, Left <$> arbitrary) - , (1, Right <$> arbitrary) - ] + taggedOrBranch = + frequency + [ (3, Left <$> arbitrary) + , (1, Right <$> arbitrary) + ] shrink (BranchingRepoRecipe xs) = BranchingRepoRecipe <$> filter (not . null) (shrink xs) - -- ------------------------------------------------------------ + -- * A pure model of repository state + -- ------------------------------------------------------------ -- | The full state of a repository. In particular it records the full working @@ -506,115 +606,124 @@ instance KnownSubmodulesSupport submodules => Arbitrary (BranchingRepoRecipe sub -- -- This allows us to compare expected working states with the actual files in -- the working directory of a repository. See 'checkExpectedWorkingState'. --- -data RepoState = - RepoState { - currentBranch :: BranchName, - currentWorking :: RepoWorkingState, - allTags :: Map TagOrCommitId RepoWorkingState, - allBranches :: Map BranchName RepoWorkingState - } - deriving Show +data RepoState = RepoState + { currentBranch :: BranchName + , currentWorking :: RepoWorkingState + , allTags :: Map TagOrCommitId RepoWorkingState + , allBranches :: Map BranchName RepoWorkingState + } + deriving (Show) type RepoWorkingState = Map FilePath String -type CommitId = String -type TagOrCommitId = String - +type CommitId = String +type TagOrCommitId = String ------------------------------------------------------------------------------ -- Functions used to interpret instructions for constructing repositories initialRepoState :: RepoState initialRepoState = - RepoState { - currentBranch = "branch_master", - currentWorking = Map.empty, - allTags = Map.empty, - allBranches = Map.empty + RepoState + { currentBranch = "branch_master" + , currentWorking = Map.empty + , allTags = Map.empty + , allBranches = Map.empty } updateFile :: FilePath -> String -> RepoState -> RepoState updateFile filename content state@RepoState{currentWorking} = let removeSubmodule = Map.filterWithKey (\path _ -> not $ filename `isPrefixOf` path) currentWorking - in state { currentWorking = Map.insert filename content removeSubmodule } + in state{currentWorking = Map.insert filename content removeSubmodule} addSubmodule :: FilePath -> RepoState -> RepoState -> RepoState addSubmodule submodulePath submoduleState mainState = let newFiles = Map.mapKeys (submodulePath ) (currentWorking submoduleState) - removeSubmodule = Map.filterWithKey (\path _ -> not $ submodulePath `isPrefixOf` path ) (currentWorking mainState) + removeSubmodule = Map.filterWithKey (\path _ -> not $ submodulePath `isPrefixOf` path) (currentWorking mainState) newWorking = Map.union removeSubmodule newFiles - in mainState { currentWorking = newWorking} + in mainState{currentWorking = newWorking} addTagOrCommit :: TagOrCommitId -> RepoState -> RepoState addTagOrCommit commit state@RepoState{currentWorking, allTags} = - state { allTags = Map.insert commit currentWorking allTags } + state{allTags = Map.insert commit currentWorking allTags} switchBranch :: BranchName -> RepoState -> RepoState switchBranch branch state@RepoState{currentWorking, currentBranch, allBranches} = -- Use updated allBranches to cover case of switching to the same branch - let allBranches' = Map.insert currentBranch currentWorking allBranches in - state { - currentBranch = branch, - currentWorking = case Map.lookup branch allBranches' of - Just working -> working - -- otherwise we're creating a new branch, which starts - -- from our current branch state - Nothing -> currentWorking, - allBranches = allBranches' - } - + let allBranches' = Map.insert currentBranch currentWorking allBranches + in state + { currentBranch = branch + , currentWorking = case Map.lookup branch allBranches' of + Just working -> working + -- otherwise we're creating a new branch, which starts + -- from our current branch state + Nothing -> currentWorking + , allBranches = allBranches' + } -- ------------------------------------------------------------ + -- * Comparing on-disk with expected 'RepoWorkingState' + -- ------------------------------------------------------------ -- | Compare expected working states with the actual files in -- the working directory of a repository. --- -checkExpectedWorkingState :: Set FilePath - -> FilePath -> RepoWorkingState -> IO () +checkExpectedWorkingState + :: Set FilePath + -> FilePath + -> RepoWorkingState + -> IO () checkExpectedWorkingState ignore repoPath expectedState = do - currentState <- getCurrentWorkingState ignore repoPath - unless (currentState == expectedState) $ - throwIO (WorkingStateMismatch expectedState currentState) + currentState <- getCurrentWorkingState ignore repoPath + unless (currentState == expectedState) $ + throwIO (WorkingStateMismatch expectedState currentState) -data WorkingStateMismatch = - WorkingStateMismatch RepoWorkingState -- expected - RepoWorkingState -- actual - deriving Show +data WorkingStateMismatch + = WorkingStateMismatch + RepoWorkingState -- expected + RepoWorkingState -- actual + deriving (Show) instance Exception WorkingStateMismatch getCurrentWorkingState :: Set FilePath -> FilePath -> IO RepoWorkingState getCurrentWorkingState ignore repoRoot = do - entries <- getDirectoryContentsRecursive ignore repoRoot "" - Map.fromList <$> mapM getFileEntry - [ file | (file, isDir) <- entries, not isDir ] + entries <- getDirectoryContentsRecursive ignore repoRoot "" + Map.fromList + <$> mapM + getFileEntry + [file | (file, isDir) <- entries, not isDir] where - getFileEntry name = - withBinaryFile (repoRoot name) ReadMode $ \h -> do - str <- hGetContents h - _ <- evaluate (length str) - return (name, str) - -getDirectoryContentsRecursive :: Set FilePath -> FilePath -> FilePath - -> IO [(FilePath, Bool)] + getFileEntry name = + withBinaryFile (repoRoot name) ReadMode $ \h -> do + str <- hGetContents h + _ <- evaluate (length str) + return (name, str) + +getDirectoryContentsRecursive + :: Set FilePath + -> FilePath + -> FilePath + -> IO [(FilePath, Bool)] getDirectoryContentsRecursive ignore dir0 dir = do - entries <- getDirectoryContents (dir0 dir) - entries' <- sequence - [ do isdir <- doesDirectoryExist (dir0 dir entry) - return (dir entry, isdir) - | entry <- entries - , not (isPrefixOf "." entry) - , (dir entry) `Set.notMember` ignore - ] - let subdirs = [ d | (d, True) <- entries' ] - subdirEntries <- mapM (getDirectoryContentsRecursive ignore dir0) subdirs - return (concat (entries' : subdirEntries)) - + entries <- getDirectoryContents (dir0 dir) + entries' <- + sequence + [ do + isdir <- doesDirectoryExist (dir0 dir entry) + return (dir entry, isdir) + | entry <- entries + , not (isPrefixOf "." entry) + , (dir entry) `Set.notMember` ignore + ] + let subdirs = [d | (d, True) <- entries'] + subdirEntries <- mapM (getDirectoryContentsRecursive ignore dir0) subdirs + return (concat (entries' : subdirEntries)) -- ------------------------------------------------------------ + -- * Executing instructions to make on-disk VCS repos + -- ------------------------------------------------------------ -- | Execute the instructions in a 'RepoRecipe' using the given 'VCSTestDriver' @@ -623,47 +732,51 @@ getDirectoryContentsRecursive ignore dir0 dir = do -- This also returns a 'RepoState'. This is done as part of construction to -- support VCSs like git that have commit ids, so that those commit ids can be -- included in the 'RepoState's 'allTags' set. --- createRepo :: VCSTestDriver -> RepoRecipe submodules -> IO RepoState createRepo vcsDriver@VCSTestDriver{vcsRepoRoot, vcsInit} recipe = do - createDirectoryIfMissing True vcsRepoRoot - createDirectoryIfMissing True (vcsRepoRoot "file") - vcsInit - execStateT createRepoAction initialRepoState + createDirectoryIfMissing True vcsRepoRoot + createDirectoryIfMissing True (vcsRepoRoot "file") + vcsInit + execStateT createRepoAction initialRepoState where createRepoAction :: StateT RepoState IO () createRepoAction = case recipe of WithoutBranchingSupport r -> execNonBranchingRepoRecipe vcsDriver r - WithBranchingSupport r -> execBranchingRepoRecipe vcsDriver r + WithBranchingSupport r -> execBranchingRepoRecipe vcsDriver r type CreateRepoAction a = VCSTestDriver -> a -> StateT RepoState IO () execNonBranchingRepoRecipe :: CreateRepoAction (NonBranchingRepoRecipe submodules) execNonBranchingRepoRecipe vcsDriver (NonBranchingRepoRecipe taggedCommits) = - mapM_ (execTaggdCommits vcsDriver) taggedCommits + mapM_ (execTaggdCommits vcsDriver) taggedCommits execBranchingRepoRecipe :: CreateRepoAction (BranchingRepoRecipe submodules) execBranchingRepoRecipe vcsDriver (BranchingRepoRecipe taggedCommits) = - mapM_ (either (execTaggdCommits vcsDriver) - (execBranchCommits vcsDriver)) - taggedCommits + mapM_ + ( either + (execTaggdCommits vcsDriver) + (execBranchCommits vcsDriver) + ) + taggedCommits execBranchCommits :: CreateRepoAction (BranchCommits submodules) -execBranchCommits vcsDriver@VCSTestDriver{vcsSwitchBranch} - (BranchCommits branch commits) = do +execBranchCommits + vcsDriver@VCSTestDriver{vcsSwitchBranch} + (BranchCommits branch commits) = do mapM_ (execCommit vcsDriver) commits -- add commits and then switch branch State.modify (switchBranch branch) state <- State.get -- repo state after the commits and branch switch liftIO $ vcsSwitchBranch state branch - -- It may seem odd that we add commits on the existing branch and then - -- switch branch. In part this is because git cannot branch from an empty - -- repo state, it complains that the master branch doesn't exist yet. +-- It may seem odd that we add commits on the existing branch and then +-- switch branch. In part this is because git cannot branch from an empty +-- repo state, it complains that the master branch doesn't exist yet. execTaggdCommits :: CreateRepoAction (TaggedCommits submodules) -execTaggdCommits vcsDriver@VCSTestDriver{vcsTagState} - (TaggedCommits tagname commits) = do +execTaggdCommits + vcsDriver@VCSTestDriver{vcsTagState} + (TaggedCommits tagname commits) = do mapM_ (execCommit vcsDriver) commits -- add commits then tag state <- State.get -- repo state after the commits @@ -672,31 +785,33 @@ execTaggdCommits vcsDriver@VCSTestDriver{vcsTagState} execCommit :: CreateRepoAction (Commit submodules) execCommit vcsDriver@VCSTestDriver{..} (Commit fileUpdates) = do - mapM_ (either (execFileUpdate vcsDriver) (execSubmoduleAdd vcsDriver)) fileUpdates - state <- State.get -- existing state, not updated - mcommit <- liftIO $ vcsCommitChanges state - State.modify (maybe id addTagOrCommit mcommit) + mapM_ (either (execFileUpdate vcsDriver) (execSubmoduleAdd vcsDriver)) fileUpdates + state <- State.get -- existing state, not updated + mcommit <- liftIO $ vcsCommitChanges state + State.modify (maybe id addTagOrCommit mcommit) execFileUpdate :: CreateRepoAction FileUpdate execFileUpdate VCSTestDriver{..} (FileUpdate filename content) = do - isDir <- liftIO $ doesDirectoryExist (vcsRepoRoot filename) - liftIO . when isDir $ removeDirectoryRecursive (vcsRepoRoot filename) - liftIO $ writeFile (vcsRepoRoot filename) content - state <- State.get -- existing state, not updated - liftIO $ vcsAddFile state filename - State.modify (updateFile filename content) + isDir <- liftIO $ doesDirectoryExist (vcsRepoRoot filename) + liftIO . when isDir $ removeDirectoryRecursive (vcsRepoRoot filename) + liftIO $ writeFile (vcsRepoRoot filename) content + state <- State.get -- existing state, not updated + liftIO $ vcsAddFile state filename + State.modify (updateFile filename content) execSubmoduleAdd :: CreateRepoAction SubmoduleAdd execSubmoduleAdd vcsDriver (SubmoduleAdd submodulePath source submoduleCommit) = do - submoduleVcsDriver <- liftIO $ vcsSubmoduleDriver vcsDriver source - let submoduleRecipe = WithoutBranchingSupport $ NonBranchingRepoRecipe [TaggedCommits "submodule-tag" [submoduleCommit]] - submoduleState <- liftIO $ createRepo submoduleVcsDriver submoduleRecipe - mainState <- State.get -- existing state, not updated - liftIO $ vcsAddSubmodule vcsDriver mainState (vcsRepoRoot submoduleVcsDriver) submodulePath - State.modify $ addSubmodule submodulePath submoduleState + submoduleVcsDriver <- liftIO $ vcsSubmoduleDriver vcsDriver source + let submoduleRecipe = WithoutBranchingSupport $ NonBranchingRepoRecipe [TaggedCommits "submodule-tag" [submoduleCommit]] + submoduleState <- liftIO $ createRepo submoduleVcsDriver submoduleRecipe + mainState <- State.get -- existing state, not updated + liftIO $ vcsAddSubmodule vcsDriver mainState (vcsRepoRoot submoduleVcsDriver) submodulePath + State.modify $ addSubmodule submodulePath submoduleState -- ------------------------------------------------------------ + -- * VCSTestDriver for various VCSs + -- ------------------------------------------------------------ -- | Extends 'VCS' with extra methods to construct a repository. Used by @@ -707,57 +822,62 @@ execSubmoduleAdd vcsDriver (SubmoduleAdd submodulePath source submoduleCommit) = -- (like adding a file to the tracked set, or creating a new branch). -- -- The driver instance knows the particular repo directory. --- -data VCSTestDriver = VCSTestDriver { - vcsVCS :: VCS ConfiguredProgram, - vcsRepoRoot :: FilePath, - vcsIgnoreFiles :: Set FilePath, - vcsInit :: IO (), - vcsAddFile :: RepoState -> FilePath -> IO (), - vcsSubmoduleDriver :: FilePath -> IO VCSTestDriver, - vcsAddSubmodule :: RepoState -> FilePath -> FilePath -> IO (), - vcsCommitChanges :: RepoState -> IO (Maybe CommitId), - vcsTagState :: RepoState -> TagName -> IO (), - vcsSwitchBranch :: RepoState -> BranchName -> IO (), - vcsCheckoutTag :: Either (TagName -> IO ()) - (TagName -> FilePath -> IO ()) - } - - -vcsTestDriverGit :: Verbosity -> VCS ConfiguredProgram - -> FilePath -> FilePath -> VCSTestDriver -vcsTestDriverGit verbosity vcs submoduleDir repoRoot = - VCSTestDriver { - vcsVCS = vcs +data VCSTestDriver = VCSTestDriver + { vcsVCS :: VCS ConfiguredProgram + , vcsRepoRoot :: FilePath + , vcsIgnoreFiles :: Set FilePath + , vcsInit :: IO () + , vcsAddFile :: RepoState -> FilePath -> IO () + , vcsSubmoduleDriver :: FilePath -> IO VCSTestDriver + , vcsAddSubmodule :: RepoState -> FilePath -> FilePath -> IO () + , vcsCommitChanges :: RepoState -> IO (Maybe CommitId) + , vcsTagState :: RepoState -> TagName -> IO () + , vcsSwitchBranch :: RepoState -> BranchName -> IO () + , vcsCheckoutTag + :: Either + (TagName -> IO ()) + (TagName -> FilePath -> IO ()) + } +vcsTestDriverGit + :: Verbosity + -> VCS ConfiguredProgram + -> FilePath + -> FilePath + -> VCSTestDriver +vcsTestDriverGit verbosity vcs submoduleDir repoRoot = + VCSTestDriver + { vcsVCS = vcs , vcsRepoRoot = repoRoot - , vcsIgnoreFiles = Set.empty - , vcsInit = - git $ ["init"] ++ verboseArg - + git $ ["init"] ++ verboseArg , vcsAddFile = \_ filename -> git ["add", filename] - , vcsCommitChanges = \_state -> do - git $ [ "-c", "user.name=A", "-c", "user.email=a@example.com" - , "commit", "--all", "--message=a patch" - , "--author=A " - ] ++ verboseArg + git $ + [ "-c" + , "user.name=A" + , "-c" + , "user.email=a@example.com" + , "commit" + , "--all" + , "--message=a patch" + , "--author=A " + ] + ++ verboseArg commit <- git' ["log", "--format=%H", "-1"] let commit' = takeWhile (not . isSpace) commit return (Just commit') - , vcsTagState = \_ tagname -> git ["tag", "--force", "--no-sign", tagname] - , vcsSubmoduleDriver = pure . vcsTestDriverGit verbosity vcs submoduleDir . (submoduleDir ) - , vcsAddSubmodule = \_ source dest -> do - destExists <- (||) <$> doesFileExist (repoRoot dest) - <*> doesDirectoryExist (repoRoot dest) + destExists <- + (||) + <$> doesFileExist (repoRoot dest) + <*> doesDirectoryExist (repoRoot dest) when destExists $ git ["rm", "-f", dest] -- If there is an old submodule git dir with the same name, remove it. -- It most likely has a different URL and `git submodule add` will fai. @@ -765,26 +885,25 @@ vcsTestDriverGit verbosity vcs submoduleDir repoRoot = when submoduleGitDirExists $ removeDirectoryRecursive (submoduleGitDir dest) git ["submodule", "add", source, dest] git ["submodule", "update", "--init", "--recursive", "--force"] - , vcsSwitchBranch = \RepoState{allBranches} branchname -> do deinitAndRemoveCachedSubmodules unless (branchname `Map.member` allBranches) $ git ["branch", branchname] git $ ["checkout", branchname] ++ verboseArg updateSubmodulesAndCleanup - , vcsCheckoutTag = Left $ \tagname -> do deinitAndRemoveCachedSubmodules git $ ["checkout", "--detach", "--force", tagname] ++ verboseArg updateSubmodulesAndCleanup } where - gitInvocation args = (programInvocation (vcsProgram vcs) args) { - progInvokeCwd = Just repoRoot - } - git = runProgramInvocation verbosity . gitInvocation + gitInvocation args = + (programInvocation (vcsProgram vcs) args) + { progInvokeCwd = Just repoRoot + } + git = runProgramInvocation verbosity . gitInvocation git' = getProgramInvocationOutput verbosity . gitInvocation - verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + verboseArg = ["--quiet" | verbosity < Verbosity.normal] submoduleGitDir path = repoRoot ".git" "modules" path deinitAndRemoveCachedSubmodules = do git $ ["submodule", "deinit", "--force", "--all"] ++ verboseArg @@ -797,151 +916,142 @@ vcsTestDriverGit verbosity vcs submoduleDir repoRoot = git $ ["submodule", "foreach", "--recursive"] ++ verboseArg ++ ["git clean -ffxdq"] git $ ["clean", "-ffxdq"] ++ verboseArg - type MTimeChange = Int -vcsTestDriverDarcs :: MTimeChange -> Verbosity -> VCS ConfiguredProgram - -> FilePath -> FilePath -> VCSTestDriver +vcsTestDriverDarcs + :: MTimeChange + -> Verbosity + -> VCS ConfiguredProgram + -> FilePath + -> FilePath + -> VCSTestDriver vcsTestDriverDarcs mtimeChange verbosity vcs _ repoRoot = - VCSTestDriver { - vcsVCS = vcs - + VCSTestDriver + { vcsVCS = vcs , vcsRepoRoot = repoRoot - , vcsIgnoreFiles = Set.singleton "_darcs" - , vcsInit = darcs ["initialize"] - , vcsAddFile = \state filename -> do threadDelay mtimeChange unless (filename `Map.member` currentWorking state) $ darcs ["add", filename] - -- Darcs's file change tracking relies on mtime changes, - -- so we have to be careful with doing stuff too quickly: + , -- Darcs's file change tracking relies on mtime changes, + -- so we have to be careful with doing stuff too quickly: - , vcsSubmoduleDriver = \_-> + vcsSubmoduleDriver = \_ -> fail "vcsSubmoduleDriver: darcs does not support submodules" - , vcsAddSubmodule = \_ _ _ -> fail "vcsAddSubmodule: darcs does not support submodules" - , vcsCommitChanges = \_state -> do threadDelay mtimeChange darcs ["record", "--all", "--author=author", "--name=a patch"] return Nothing - , vcsTagState = \_ tagname -> darcs ["tag", "--author=author", tagname] - , vcsSwitchBranch = \_ _ -> fail "vcsSwitchBranch: darcs does not support branches within a repo" - , vcsCheckoutTag = Right $ \tagname dest -> darcs ["clone", "--lazy", "--tag=^" ++ tagname ++ "$", ".", dest] } where - darcsInvocation args = (programInvocation (vcsProgram vcs) args) { - progInvokeCwd = Just repoRoot - } + darcsInvocation args = + (programInvocation (vcsProgram vcs) args) + { progInvokeCwd = Just repoRoot + } darcs = runProgramInvocation verbosity . darcsInvocation - -vcsTestDriverPijul :: Verbosity -> VCS ConfiguredProgram - -> FilePath -> FilePath -> VCSTestDriver +vcsTestDriverPijul + :: Verbosity + -> VCS ConfiguredProgram + -> FilePath + -> FilePath + -> VCSTestDriver vcsTestDriverPijul verbosity vcs _ repoRoot = - VCSTestDriver { - vcsVCS = vcs - + VCSTestDriver + { vcsVCS = vcs , vcsRepoRoot = repoRoot - , vcsIgnoreFiles = Set.empty - , vcsInit = pijul $ ["init"] - , vcsAddFile = \_ filename -> pijul ["add", filename] - , vcsSubmoduleDriver = \_ -> fail "vcsSubmoduleDriver: pijul does not support submodules" - , vcsAddSubmodule = \_ _ _ -> fail "vcsAddSubmodule: pijul does not support submodules" - , vcsCommitChanges = \_state -> do - pijul $ ["record", "-a", "-m 'a patch'" - , "-A 'A '" - ] + pijul $ + [ "record" + , "-a" + , "-m 'a patch'" + , "-A 'A '" + ] commit <- pijul' ["log"] let commit' = takeWhile (not . isSpace) commit return (Just commit') - - -- tags work differently in pijul... - -- so this is wrong - , vcsTagState = \_ tagname -> + , -- tags work differently in pijul... + -- so this is wrong + vcsTagState = \_ tagname -> pijul ["tag", tagname] - , vcsSwitchBranch = \_ branchname -> do --- unless (branchname `Map.member` allBranches) $ --- pijul ["from-branch", branchname] + -- unless (branchname `Map.member` allBranches) $ + -- pijul ["from-branch", branchname] pijul $ ["checkout", branchname] - , vcsCheckoutTag = Left $ \tagname -> pijul $ ["checkout", tagname] } where - gitInvocation args = (programInvocation (vcsProgram vcs) args) { - progInvokeCwd = Just repoRoot - } - pijul = runProgramInvocation verbosity . gitInvocation + gitInvocation args = + (programInvocation (vcsProgram vcs) args) + { progInvokeCwd = Just repoRoot + } + pijul = runProgramInvocation verbosity . gitInvocation pijul' = getProgramInvocationOutput verbosity . gitInvocation -vcsTestDriverHg :: Verbosity -> VCS ConfiguredProgram - -> FilePath -> FilePath -> VCSTestDriver +vcsTestDriverHg + :: Verbosity + -> VCS ConfiguredProgram + -> FilePath + -> FilePath + -> VCSTestDriver vcsTestDriverHg verbosity vcs _ repoRoot = - VCSTestDriver { - vcsVCS = vcs - + VCSTestDriver + { vcsVCS = vcs , vcsRepoRoot = repoRoot - , vcsIgnoreFiles = Set.empty - , vcsInit = - hg $ ["init"] ++ verboseArg - + hg $ ["init"] ++ verboseArg , vcsAddFile = \_ filename -> hg ["add", filename] - , vcsSubmoduleDriver = \_ -> fail "vcsSubmoduleDriver: hg submodules not supported" - , vcsAddSubmodule = \_ _ _ -> fail "vcsAddSubmodule: hg submodules not supported" - , vcsCommitChanges = \_state -> do - hg $ [ "--user='A '" - , "commit", "--message=a patch" - ] ++ verboseArg + hg $ + [ "--user='A '" + , "commit" + , "--message=a patch" + ] + ++ verboseArg commit <- hg' ["log", "--template='{node}\\n' -l1"] let commit' = takeWhile (not . isSpace) commit return (Just commit') - , vcsTagState = \_ tagname -> hg ["tag", "--force", tagname] - , vcsSwitchBranch = \RepoState{allBranches} branchname -> do unless (branchname `Map.member` allBranches) $ hg ["branch", branchname] hg $ ["checkout", branchname] ++ verboseArg - , vcsCheckoutTag = Left $ \tagname -> hg $ ["checkout", "--rev", tagname] ++ verboseArg } where - hgInvocation args = (programInvocation (vcsProgram vcs) args) { - progInvokeCwd = Just repoRoot - } - hg = runProgramInvocation verbosity . hgInvocation + hgInvocation args = + (programInvocation (vcsProgram vcs) args) + { progInvokeCwd = Just repoRoot + } + hg = runProgramInvocation verbosity . hgInvocation hg' = getProgramInvocationOutput verbosity . hgInvocation - verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + verboseArg = ["--quiet" | verbosity < Verbosity.normal] diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Builder.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Builder.hs index b8509834a2b..6eb27d39c3b 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Builder.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Builder.hs @@ -1,5 +1,5 @@ -module UnitTests.Distribution.Solver.Modular.Builder ( - tests +module UnitTests.Distribution.Solver.Modular.Builder + ( tests ) where import Distribution.Solver.Modular.Builder @@ -8,13 +8,14 @@ import Test.Tasty import Test.Tasty.QuickCheck tests :: [TestTree] -tests = [ testProperty "splitsAltImplementation" splitsTest - ] +tests = + [ testProperty "splitsAltImplementation" splitsTest + ] -- | Simpler splits implementation splits' :: [a] -> [(a, [a])] splits' [] = [] -splits' (x : xs) = (x, xs) : map (\ (y, ys) -> (y, x : ys)) (splits' xs) +splits' (x : xs) = (x, xs) : map (\(y, ys) -> (y, x : ys)) (splits' xs) splitsTest :: [Int] -> Property splitsTest xs = splits' xs === splits xs diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs index 0d22d5fe758..ba6dd2e14f4 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs @@ -1,27 +1,28 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + -- | DSL for testing the modular solver -module UnitTests.Distribution.Solver.Modular.DSL ( - ExampleDependency(..) - , Dependencies(..) - , ExSubLib(..) - , ExTest(..) - , ExExe(..) - , ExConstraint(..) - , ExPreference(..) +module UnitTests.Distribution.Solver.Modular.DSL + ( ExampleDependency (..) + , Dependencies (..) + , ExSubLib (..) + , ExTest (..) + , ExExe (..) + , ExConstraint (..) + , ExPreference (..) , ExampleDb , ExampleVersionRange , ExamplePkgVersion , ExamplePkgName , ExampleFlagName - , ExFlag(..) - , ExampleAvailable(..) - , ExampleInstalled(..) - , ExampleQualifier(..) - , ExampleVar(..) - , EnableAllTests(..) + , ExFlag (..) + , ExampleAvailable (..) + , ExampleInstalled (..) + , ExampleQualifier (..) + , ExampleVar (..) + , EnableAllTests (..) , dependencies , publicDependencies , unbuildableDependencies @@ -47,9 +48,9 @@ module UnitTests.Distribution.Solver.Modular.DSL ( , mkVersionRange ) where -import Prelude () import Distribution.Solver.Compat.Prelude import Distribution.Utils.Generic +import Prelude () -- base import Control.Arrow (second) @@ -57,53 +58,45 @@ import qualified Data.Map as Map import qualified Distribution.Compat.NonEmptySet as NonEmptySet -- Cabal -import qualified Distribution.CabalSpecVersion as C -import qualified Distribution.Compiler as C -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.License (License(..)) -import qualified Distribution.ModuleName as Module -import qualified Distribution.Package as C - hiding (HasUnitId(..)) -import qualified Distribution.Types.ExeDependency as C -import qualified Distribution.Types.ForeignLib as C -import qualified Distribution.Types.LegacyExeDependency as C -import qualified Distribution.Types.LibraryVisibility as C -import qualified Distribution.Types.PkgconfigDependency as C -import qualified Distribution.Types.PkgconfigVersion as C -import qualified Distribution.Types.PkgconfigVersionRange as C -import qualified Distribution.Types.UnqualComponentName as C -import qualified Distribution.Types.CondTree as C -import qualified Distribution.PackageDescription as C -import qualified Distribution.PackageDescription.Check as C -import qualified Distribution.Simple.PackageIndex as C.PackageIndex -import Distribution.Simple.Setup (BooleanFlag(..)) -import qualified Distribution.System as C -import Distribution.Text (display) -import qualified Distribution.Verbosity as C -import qualified Distribution.Version as C -import qualified Distribution.Utils.Path as C -import Language.Haskell.Extension (Extension(..), Language(..)) +import qualified Distribution.CabalSpecVersion as C +import qualified Distribution.Compiler as C +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.License (License (..)) +import qualified Distribution.ModuleName as Module +import qualified Distribution.Package as C hiding + ( HasUnitId (..) + ) +import qualified Distribution.PackageDescription as C +import qualified Distribution.PackageDescription.Check as C +import qualified Distribution.Simple.PackageIndex as C.PackageIndex +import Distribution.Simple.Setup (BooleanFlag (..)) +import qualified Distribution.System as C +import Distribution.Text (display) +import qualified Distribution.Utils.Path as C +import qualified Distribution.Verbosity as C +import qualified Distribution.Version as C +import Language.Haskell.Extension (Extension (..), Language (..)) -- cabal-install import Distribution.Client.Dependency import Distribution.Client.Dependency.Types -import Distribution.Client.Types import qualified Distribution.Client.SolverInstallPlan as CI.SolverInstallPlan +import Distribution.Client.Types -import Distribution.Solver.Types.ComponentDeps (ComponentDeps) +import Distribution.Solver.Types.ComponentDeps (ComponentDeps) import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.Flag -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.OptionalStanza -import qualified Distribution.Solver.Types.PackageIndex as CI.PackageIndex -import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.Flag +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageConstraint +import qualified Distribution.Solver.Types.PackageIndex as CI.PackageIndex import qualified Distribution.Solver.Types.PackagePath as P import qualified Distribution.Solver.Types.PkgConfigDb as PC -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.SolverPackage -import Distribution.Solver.Types.SourcePackage -import Distribution.Solver.Types.Variable +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Variable {------------------------------------------------------------------------------- Example package database DSL @@ -147,94 +140,86 @@ import Distribution.Solver.Types.Variable optional. -------------------------------------------------------------------------------} -type ExamplePkgName = String +type ExamplePkgName = String type ExamplePkgVersion = Int -type ExamplePkgHash = String -- for example "installed" packages -type ExampleFlagName = String +type ExamplePkgHash = String -- for example "installed" packages +type ExampleFlagName = String type ExampleSubLibName = String -type ExampleTestName = String -type ExampleExeName = String +type ExampleTestName = String +type ExampleExeName = String type ExampleVersionRange = C.VersionRange -data Dependencies = Dependencies { - depsVisibility :: C.LibraryVisibility +data Dependencies = Dependencies + { depsVisibility :: C.LibraryVisibility , depsIsBuildable :: Bool , depsExampleDependencies :: [ExampleDependency] - } deriving Show + } + deriving (Show) instance Semigroup Dependencies where - deps1 <> deps2 = Dependencies { - depsVisibility = depsVisibility deps1 <> depsVisibility deps2 - , depsIsBuildable = depsIsBuildable deps1 && depsIsBuildable deps2 - , depsExampleDependencies = depsExampleDependencies deps1 ++ depsExampleDependencies deps2 - } + deps1 <> deps2 = + Dependencies + { depsVisibility = depsVisibility deps1 <> depsVisibility deps2 + , depsIsBuildable = depsIsBuildable deps1 && depsIsBuildable deps2 + , depsExampleDependencies = depsExampleDependencies deps1 ++ depsExampleDependencies deps2 + } instance Monoid Dependencies where - mempty = Dependencies { - depsVisibility = mempty - , depsIsBuildable = True - , depsExampleDependencies = [] - } + mempty = + Dependencies + { depsVisibility = mempty + , depsIsBuildable = True + , depsExampleDependencies = [] + } mappend = (<>) dependencies :: [ExampleDependency] -> Dependencies -dependencies deps = mempty { depsExampleDependencies = deps } +dependencies deps = mempty{depsExampleDependencies = deps} publicDependencies :: Dependencies -publicDependencies = mempty { depsVisibility = C.LibraryVisibilityPublic } +publicDependencies = mempty{depsVisibility = C.LibraryVisibilityPublic} unbuildableDependencies :: Dependencies -unbuildableDependencies = mempty { depsIsBuildable = False } +unbuildableDependencies = mempty{depsIsBuildable = False} -data ExampleDependency = - -- | Simple dependency on any version +data ExampleDependency + = -- | Simple dependency on any version ExAny ExamplePkgName - - -- | Simple dependency on a fixed version - | ExFix ExamplePkgName ExamplePkgVersion - - -- | Simple dependency on a range of versions, with an inclusive lower bound + | -- | Simple dependency on a fixed version + ExFix ExamplePkgName ExamplePkgVersion + | -- | Simple dependency on a range of versions, with an inclusive lower bound -- and an exclusive upper bound. - | ExRange ExamplePkgName ExamplePkgVersion ExamplePkgVersion - - -- | Sub-library dependency - | ExSubLibAny ExamplePkgName ExampleSubLibName - - -- | Sub-library dependency on a fixed version - | ExSubLibFix ExamplePkgName ExampleSubLibName ExamplePkgVersion - - -- | Build-tool-depends dependency - | ExBuildToolAny ExamplePkgName ExampleExeName - - -- | Build-tool-depends dependency on a fixed version - | ExBuildToolFix ExamplePkgName ExampleExeName ExamplePkgVersion - - -- | Legacy build-tools dependency - | ExLegacyBuildToolAny ExamplePkgName - - -- | Legacy build-tools dependency on a fixed version - | ExLegacyBuildToolFix ExamplePkgName ExamplePkgVersion - - -- | Dependencies indexed by a flag - | ExFlagged ExampleFlagName Dependencies Dependencies - - -- | Dependency on a language extension - | ExExt Extension - - -- | Dependency on a language version - | ExLang Language - - -- | Dependency on a pkg-config package - | ExPkg (ExamplePkgName, ExamplePkgVersion) - deriving Show + ExRange ExamplePkgName ExamplePkgVersion ExamplePkgVersion + | -- | Sub-library dependency + ExSubLibAny ExamplePkgName ExampleSubLibName + | -- | Sub-library dependency on a fixed version + ExSubLibFix ExamplePkgName ExampleSubLibName ExamplePkgVersion + | -- | Build-tool-depends dependency + ExBuildToolAny ExamplePkgName ExampleExeName + | -- | Build-tool-depends dependency on a fixed version + ExBuildToolFix ExamplePkgName ExampleExeName ExamplePkgVersion + | -- | Legacy build-tools dependency + ExLegacyBuildToolAny ExamplePkgName + | -- | Legacy build-tools dependency on a fixed version + ExLegacyBuildToolFix ExamplePkgName ExamplePkgVersion + | -- | Dependencies indexed by a flag + ExFlagged ExampleFlagName Dependencies Dependencies + | -- | Dependency on a language extension + ExExt Extension + | -- | Dependency on a language version + ExLang Language + | -- | Dependency on a pkg-config package + ExPkg (ExamplePkgName, ExamplePkgVersion) + deriving (Show) -- | Simplified version of D.Types.GenericPackageDescription.Flag for use in -- example source packages. -data ExFlag = ExFlag { - exFlagName :: ExampleFlagName +data ExFlag = ExFlag + { exFlagName :: ExampleFlagName , exFlagDefault :: Bool - , exFlagType :: FlagType - } deriving Show + , exFlagType :: FlagType + } + deriving (Show) data ExSubLib = ExSubLib ExampleSubLibName Dependencies @@ -251,52 +236,53 @@ exTest name deps = ExTest name (dependencies deps) exExe :: ExampleExeName -> [ExampleDependency] -> ExExe exExe name deps = ExExe name (dependencies deps) -exFlagged :: ExampleFlagName -> [ExampleDependency] -> [ExampleDependency] - -> ExampleDependency +exFlagged + :: ExampleFlagName + -> [ExampleDependency] + -> [ExampleDependency] + -> ExampleDependency exFlagged n t e = ExFlagged n (dependencies t) (dependencies e) -data ExConstraint = - ExVersionConstraint ConstraintScope ExampleVersionRange +data ExConstraint + = ExVersionConstraint ConstraintScope ExampleVersionRange | ExFlagConstraint ConstraintScope ExampleFlagName Bool | ExStanzaConstraint ConstraintScope [OptionalStanza] - deriving Show + deriving (Show) -data ExPreference = - ExPkgPref ExamplePkgName ExampleVersionRange +data ExPreference + = ExPkgPref ExamplePkgName ExampleVersionRange | ExStanzaPref ExamplePkgName [OptionalStanza] - deriving Show + deriving (Show) -data ExampleAvailable = ExAv { - exAvName :: ExamplePkgName +data ExampleAvailable = ExAv + { exAvName :: ExamplePkgName , exAvVersion :: ExamplePkgVersion - , exAvDeps :: ComponentDeps Dependencies - - -- Setting flags here is only necessary to override the default values of - -- the fields in C.Flag. - , exAvFlags :: [ExFlag] - } deriving Show + , exAvDeps :: ComponentDeps Dependencies + , -- Setting flags here is only necessary to override the default values of + -- the fields in C.Flag. + exAvFlags :: [ExFlag] + } + deriving (Show) -data ExampleVar = - P ExampleQualifier ExamplePkgName +data ExampleVar + = P ExampleQualifier ExamplePkgName | F ExampleQualifier ExamplePkgName ExampleFlagName | S ExampleQualifier ExamplePkgName OptionalStanza -data ExampleQualifier = - QualNone +data ExampleQualifier + = QualNone | QualIndep ExamplePkgName | QualSetup ExamplePkgName - - -- The two package names are the build target and the package containing the + | -- The two package names are the build target and the package containing the -- setup script. - | QualIndepSetup ExamplePkgName ExamplePkgName - - -- The two package names are the package depending on the exe and the + QualIndepSetup ExamplePkgName ExamplePkgName + | -- The two package names are the package depending on the exe and the -- package containing the exe. - | QualExe ExamplePkgName ExamplePkgName + QualExe ExamplePkgName ExamplePkgName -- | Whether to enable tests in all packages in a test case. newtype EnableAllTests = EnableAllTests Bool - deriving BooleanFlag + deriving (BooleanFlag) -- | Constructs an 'ExampleAvailable' package for the 'ExampleDb', -- given: @@ -306,24 +292,30 @@ newtype EnableAllTests = EnableAllTests Bool -- 3. The list of dependency constraints ('ExampleDependency') -- for this package's library component. 'ExampleDependency' -- provides a number of pre-canned dependency types to look at. --- -exAv :: ExamplePkgName -> ExamplePkgVersion -> [ExampleDependency] - -> ExampleAvailable -exAv n v ds = (exAvNoLibrary n v) { exAvDeps = CD.fromLibraryDeps (dependencies ds) } +exAv + :: ExamplePkgName + -> ExamplePkgVersion + -> [ExampleDependency] + -> ExampleAvailable +exAv n v ds = (exAvNoLibrary n v){exAvDeps = CD.fromLibraryDeps (dependencies ds)} -- | Constructs an 'ExampleAvailable' package without a default library -- component. exAvNoLibrary :: ExamplePkgName -> ExamplePkgVersion -> ExampleAvailable -exAvNoLibrary n v = ExAv { exAvName = n - , exAvVersion = v - , exAvDeps = CD.empty - , exAvFlags = [] } +exAvNoLibrary n v = + ExAv + { exAvName = n + , exAvVersion = v + , exAvDeps = CD.empty + , exAvFlags = [] + } -- | Override the default settings (e.g., manual vs. automatic) for a subset of -- a package's flags. declareFlags :: [ExFlag] -> ExampleAvailable -> ExampleAvailable -declareFlags flags ex = ex { - exAvFlags = flags +declareFlags flags ex = + ex + { exAvFlags = flags } withSubLibrary :: ExampleAvailable -> ExSubLib -> ExampleAvailable @@ -331,13 +323,17 @@ withSubLibrary ex lib = withSubLibraries ex [lib] withSubLibraries :: ExampleAvailable -> [ExSubLib] -> ExampleAvailable withSubLibraries ex libs = - let subLibCDs = CD.fromList [(CD.ComponentSubLib $ C.mkUnqualComponentName name, deps) - | ExSubLib name deps <- libs] - in ex { exAvDeps = exAvDeps ex <> subLibCDs } + let subLibCDs = + CD.fromList + [ (CD.ComponentSubLib $ C.mkUnqualComponentName name, deps) + | ExSubLib name deps <- libs + ] + in ex{exAvDeps = exAvDeps ex <> subLibCDs} withSetupDeps :: ExampleAvailable -> [ExampleDependency] -> ExampleAvailable -withSetupDeps ex setupDeps = ex { - exAvDeps = exAvDeps ex <> CD.fromSetupDeps (dependencies setupDeps) +withSetupDeps ex setupDeps = + ex + { exAvDeps = exAvDeps ex <> CD.fromSetupDeps (dependencies setupDeps) } withTest :: ExampleAvailable -> ExTest -> ExampleAvailable @@ -345,26 +341,33 @@ withTest ex test = withTests ex [test] withTests :: ExampleAvailable -> [ExTest] -> ExampleAvailable withTests ex tests = - let testCDs = CD.fromList [(CD.ComponentTest $ C.mkUnqualComponentName name, deps) - | ExTest name deps <- tests] - in ex { exAvDeps = exAvDeps ex <> testCDs } + let testCDs = + CD.fromList + [ (CD.ComponentTest $ C.mkUnqualComponentName name, deps) + | ExTest name deps <- tests + ] + in ex{exAvDeps = exAvDeps ex <> testCDs} withExe :: ExampleAvailable -> ExExe -> ExampleAvailable withExe ex exe = withExes ex [exe] withExes :: ExampleAvailable -> [ExExe] -> ExampleAvailable withExes ex exes = - let exeCDs = CD.fromList [(CD.ComponentExe $ C.mkUnqualComponentName name, deps) - | ExExe name deps <- exes] - in ex { exAvDeps = exAvDeps ex <> exeCDs } + let exeCDs = + CD.fromList + [ (CD.ComponentExe $ C.mkUnqualComponentName name, deps) + | ExExe name deps <- exes + ] + in ex{exAvDeps = exAvDeps ex <> exeCDs} -- | An installed package in 'ExampleDb'; construct me with 'exInst'. -data ExampleInstalled = ExInst { - exInstName :: ExamplePkgName - , exInstVersion :: ExamplePkgVersion - , exInstHash :: ExamplePkgHash +data ExampleInstalled = ExInst + { exInstName :: ExamplePkgName + , exInstVersion :: ExamplePkgVersion + , exInstHash :: ExamplePkgHash , exInstBuildAgainst :: [ExamplePkgHash] - } deriving Show + } + deriving (Show) -- | Constructs an example installed package given: -- @@ -374,9 +377,12 @@ data ExampleInstalled = ExInst { -- (just some unique identifier for the package.) -- 4. The 'ExampleInstalled' packages which this package was -- compiled against.) --- -exInst :: ExamplePkgName -> ExamplePkgVersion -> ExamplePkgHash - -> [ExampleInstalled] -> ExampleInstalled +exInst + :: ExamplePkgName + -> ExamplePkgVersion + -> ExamplePkgHash + -> [ExampleInstalled] + -> ExampleInstalled exInst pn v hash deps = ExInst pn v hash (map exInstHash deps) -- | An example package database is a list of installed packages @@ -394,201 +400,219 @@ exDbPkgs = map (either exInstName exAvName) exAvSrcPkg :: ExampleAvailable -> UnresolvedSourcePackage exAvSrcPkg ex = - let pkgId = exAvPkgId ex - - flags :: [C.PackageFlag] - flags = - let declaredFlags :: Map ExampleFlagName C.PackageFlag - declaredFlags = - Map.fromListWith - (\f1 f2 -> error $ "duplicate flag declarations: " ++ show [f1, f2]) - [(exFlagName flag, mkFlag flag) | flag <- exAvFlags ex] - - usedFlags :: Map ExampleFlagName C.PackageFlag - usedFlags = Map.fromList [(fn, mkDefaultFlag fn) | fn <- names] - where - names = extractFlags $ CD.flatDeps (exAvDeps ex) - in -- 'declaredFlags' overrides 'usedFlags' to give flags non-default settings: - Map.elems $ declaredFlags `Map.union` usedFlags - - subLibraries = [(name, deps) | (CD.ComponentSubLib name, deps) <- CD.toList (exAvDeps ex)] - foreignLibraries = [(name, deps) | (CD.ComponentFLib name, deps) <- CD.toList (exAvDeps ex)] - testSuites = [(name, deps) | (CD.ComponentTest name, deps) <- CD.toList (exAvDeps ex)] - benchmarks = [(name, deps) | (CD.ComponentBench name, deps) <- CD.toList (exAvDeps ex)] - executables = [(name, deps) | (CD.ComponentExe name, deps) <- CD.toList (exAvDeps ex)] - setup = case depsExampleDependencies $ CD.setupDeps (exAvDeps ex) of - [] -> Nothing - deps -> Just C.SetupBuildInfo { - C.setupDepends = mkSetupDeps deps, - C.defaultSetupDepends = False - } - package = SourcePackage - { srcpkgPackageId = pkgId - , srcpkgSource = LocalTarballPackage "<>" - , srcpkgDescrOverride = Nothing - , srcpkgDescription = C.GenericPackageDescription { - C.packageDescription = C.emptyPackageDescription { - C.package = pkgId - , C.setupBuildInfo = setup - , C.licenseRaw = Right BSD3 - , C.buildTypeRaw = if isNothing setup - then Just C.Simple - else Just C.Custom - , C.category = "category" - , C.maintainer = "maintainer" - , C.description = "description" - , C.synopsis = "synopsis" - , C.licenseFiles = [C.unsafeMakeSymbolicPath "LICENSE"] - -- Version 2.0 is required for internal libraries. - , C.specVersion = C.CabalSpecV2_0 - } - , C.gpdScannedVersion = Nothing - , C.genPackageFlags = flags - , C.condLibrary = - let mkLib v bi = mempty { C.libVisibility = v, C.libBuildInfo = bi } - -- Avoid using the Monoid instance for [a] when getting - -- the library dependencies, to allow for the possibility - -- that the package doesn't have a library: - libDeps = lookup CD.ComponentLib (CD.toList (exAvDeps ex)) - in mkTopLevelCondTree defaultLib mkLib <$> libDeps - , C.condSubLibraries = - let mkTree = mkTopLevelCondTree defaultSubLib mkLib - mkLib v bi = mempty { C.libVisibility = v, C.libBuildInfo = bi } - in map (second mkTree) subLibraries - , C.condForeignLibs = - let mkTree = mkTopLevelCondTree (mkLib defaultTopLevelBuildInfo) (const mkLib) - mkLib bi = mempty { C.foreignLibBuildInfo = bi } - in map (second mkTree) foreignLibraries - , C.condExecutables = - let mkTree = mkTopLevelCondTree defaultExe (const mkExe) - mkExe bi = mempty { C.buildInfo = bi } - in map (second mkTree) executables - , C.condTestSuites = - let mkTree = mkTopLevelCondTree defaultTest (const mkTest) - mkTest bi = mempty { C.testBuildInfo = bi } - in map (second mkTree) testSuites - , C.condBenchmarks = - let mkTree = mkTopLevelCondTree defaultBenchmark (const mkBench) - mkBench bi = mempty { C.benchmarkBuildInfo = bi } - in map (second mkTree) benchmarks + let pkgId = exAvPkgId ex + + flags :: [C.PackageFlag] + flags = + let declaredFlags :: Map ExampleFlagName C.PackageFlag + declaredFlags = + Map.fromListWith + (\f1 f2 -> error $ "duplicate flag declarations: " ++ show [f1, f2]) + [(exFlagName flag, mkFlag flag) | flag <- exAvFlags ex] + + usedFlags :: Map ExampleFlagName C.PackageFlag + usedFlags = Map.fromList [(fn, mkDefaultFlag fn) | fn <- names] + where + names = extractFlags $ CD.flatDeps (exAvDeps ex) + in -- 'declaredFlags' overrides 'usedFlags' to give flags non-default settings: + Map.elems $ declaredFlags `Map.union` usedFlags + + subLibraries = [(name, deps) | (CD.ComponentSubLib name, deps) <- CD.toList (exAvDeps ex)] + foreignLibraries = [(name, deps) | (CD.ComponentFLib name, deps) <- CD.toList (exAvDeps ex)] + testSuites = [(name, deps) | (CD.ComponentTest name, deps) <- CD.toList (exAvDeps ex)] + benchmarks = [(name, deps) | (CD.ComponentBench name, deps) <- CD.toList (exAvDeps ex)] + executables = [(name, deps) | (CD.ComponentExe name, deps) <- CD.toList (exAvDeps ex)] + setup = case depsExampleDependencies $ CD.setupDeps (exAvDeps ex) of + [] -> Nothing + deps -> + Just + C.SetupBuildInfo + { C.setupDepends = mkSetupDeps deps + , C.defaultSetupDepends = False } - } - pkgCheckErrors = - -- We ignore unknown extensions/languages warnings because - -- some there are some unit tests test in which the solver allows - -- unknown extensions/languages when the compiler supports them. - -- Furthermore we ignore missing upper bound warnings because - -- they are not related to this test suite, and are tested - -- with golden tests. - let checks = C.checkPackage (srcpkgDescription package) Nothing - in filter (\x -> not (isMissingUpperBound x) && not (isUnknownLangExt x)) checks - in if null pkgCheckErrors - then package - else error $ "invalid GenericPackageDescription for package " - ++ display pkgId ++ ": " ++ show pkgCheckErrors + package = + SourcePackage + { srcpkgPackageId = pkgId + , srcpkgSource = LocalTarballPackage "<>" + , srcpkgDescrOverride = Nothing + , srcpkgDescription = + C.GenericPackageDescription + { C.packageDescription = + C.emptyPackageDescription + { C.package = pkgId + , C.setupBuildInfo = setup + , C.licenseRaw = Right BSD3 + , C.buildTypeRaw = + if isNothing setup + then Just C.Simple + else Just C.Custom + , C.category = "category" + , C.maintainer = "maintainer" + , C.description = "description" + , C.synopsis = "synopsis" + , C.licenseFiles = [C.unsafeMakeSymbolicPath "LICENSE"] + , -- Version 2.0 is required for internal libraries. + C.specVersion = C.CabalSpecV2_0 + } + , C.gpdScannedVersion = Nothing + , C.genPackageFlags = flags + , C.condLibrary = + let mkLib v bi = mempty{C.libVisibility = v, C.libBuildInfo = bi} + -- Avoid using the Monoid instance for [a] when getting + -- the library dependencies, to allow for the possibility + -- that the package doesn't have a library: + libDeps = lookup CD.ComponentLib (CD.toList (exAvDeps ex)) + in mkTopLevelCondTree defaultLib mkLib <$> libDeps + , C.condSubLibraries = + let mkTree = mkTopLevelCondTree defaultSubLib mkLib + mkLib v bi = mempty{C.libVisibility = v, C.libBuildInfo = bi} + in map (second mkTree) subLibraries + , C.condForeignLibs = + let mkTree = mkTopLevelCondTree (mkLib defaultTopLevelBuildInfo) (const mkLib) + mkLib bi = mempty{C.foreignLibBuildInfo = bi} + in map (second mkTree) foreignLibraries + , C.condExecutables = + let mkTree = mkTopLevelCondTree defaultExe (const mkExe) + mkExe bi = mempty{C.buildInfo = bi} + in map (second mkTree) executables + , C.condTestSuites = + let mkTree = mkTopLevelCondTree defaultTest (const mkTest) + mkTest bi = mempty{C.testBuildInfo = bi} + in map (second mkTree) testSuites + , C.condBenchmarks = + let mkTree = mkTopLevelCondTree defaultBenchmark (const mkBench) + mkBench bi = mempty{C.benchmarkBuildInfo = bi} + in map (second mkTree) benchmarks + } + } + pkgCheckErrors = + -- We ignore unknown extensions/languages warnings because + -- some there are some unit tests test in which the solver allows + -- unknown extensions/languages when the compiler supports them. + -- Furthermore we ignore missing upper bound warnings because + -- they are not related to this test suite, and are tested + -- with golden tests. + let checks = C.checkPackage (srcpkgDescription package) Nothing + in filter (\x -> not (isMissingUpperBound x) && not (isUnknownLangExt x)) checks + in if null pkgCheckErrors + then package + else + error $ + "invalid GenericPackageDescription for package " + ++ display pkgId + ++ ": " + ++ show pkgCheckErrors where defaultTopLevelBuildInfo :: C.BuildInfo - defaultTopLevelBuildInfo = mempty { C.defaultLanguage = Just Haskell98 } + defaultTopLevelBuildInfo = mempty{C.defaultLanguage = Just Haskell98} defaultLib :: C.Library - defaultLib = mempty { - C.libBuildInfo = defaultTopLevelBuildInfo - , C.exposedModules = [Module.fromString "Module"] - , C.libVisibility = C.LibraryVisibilityPublic - } + defaultLib = + mempty + { C.libBuildInfo = defaultTopLevelBuildInfo + , C.exposedModules = [Module.fromString "Module"] + , C.libVisibility = C.LibraryVisibilityPublic + } defaultSubLib :: C.Library - defaultSubLib = mempty { - C.libBuildInfo = defaultTopLevelBuildInfo - , C.exposedModules = [Module.fromString "Module"] - } + defaultSubLib = + mempty + { C.libBuildInfo = defaultTopLevelBuildInfo + , C.exposedModules = [Module.fromString "Module"] + } defaultExe :: C.Executable - defaultExe = mempty { - C.buildInfo = defaultTopLevelBuildInfo - , C.modulePath = "Main.hs" - } + defaultExe = + mempty + { C.buildInfo = defaultTopLevelBuildInfo + , C.modulePath = "Main.hs" + } defaultTest :: C.TestSuite - defaultTest = mempty { - C.testBuildInfo = defaultTopLevelBuildInfo - , C.testInterface = C.TestSuiteExeV10 (C.mkVersion [1,0]) "Test.hs" - } + defaultTest = + mempty + { C.testBuildInfo = defaultTopLevelBuildInfo + , C.testInterface = C.TestSuiteExeV10 (C.mkVersion [1, 0]) "Test.hs" + } defaultBenchmark :: C.Benchmark - defaultBenchmark = mempty { - C.benchmarkBuildInfo = defaultTopLevelBuildInfo - , C.benchmarkInterface = C.BenchmarkExeV10 (C.mkVersion [1,0]) "Benchmark.hs" - } + defaultBenchmark = + mempty + { C.benchmarkBuildInfo = defaultTopLevelBuildInfo + , C.benchmarkInterface = C.BenchmarkExeV10 (C.mkVersion [1, 0]) "Benchmark.hs" + } -- Split the set of dependencies into the set of dependencies of the library, -- the dependencies of the test suites and extensions. - splitTopLevel :: [ExampleDependency] - -> ( [ExampleDependency] - , [Extension] - , Maybe Language - , [(ExamplePkgName, ExamplePkgVersion)] -- pkg-config - , [(ExamplePkgName, ExampleExeName, C.VersionRange)] -- build tools - , [(ExamplePkgName, C.VersionRange)] -- legacy build tools - ) + splitTopLevel + :: [ExampleDependency] + -> ( [ExampleDependency] + , [Extension] + , Maybe Language + , [(ExamplePkgName, ExamplePkgVersion)] -- pkg-config + , [(ExamplePkgName, ExampleExeName, C.VersionRange)] -- build tools + , [(ExamplePkgName, C.VersionRange)] -- legacy build tools + ) splitTopLevel [] = - ([], [], Nothing, [], [], []) - splitTopLevel (ExBuildToolAny p e:deps) = + ([], [], Nothing, [], [], []) + splitTopLevel (ExBuildToolAny p e : deps) = let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps - in (other, exts, lang, pcpkgs, (p, e, C.anyVersion):exes, legacyExes) - splitTopLevel (ExBuildToolFix p e v:deps) = + in (other, exts, lang, pcpkgs, (p, e, C.anyVersion) : exes, legacyExes) + splitTopLevel (ExBuildToolFix p e v : deps) = let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps - in (other, exts, lang, pcpkgs, (p, e, C.thisVersion (mkSimpleVersion v)):exes, legacyExes) - splitTopLevel (ExLegacyBuildToolAny p:deps) = + in (other, exts, lang, pcpkgs, (p, e, C.thisVersion (mkSimpleVersion v)) : exes, legacyExes) + splitTopLevel (ExLegacyBuildToolAny p : deps) = let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps - in (other, exts, lang, pcpkgs, exes, (p, C.anyVersion):legacyExes) - splitTopLevel (ExLegacyBuildToolFix p v:deps) = + in (other, exts, lang, pcpkgs, exes, (p, C.anyVersion) : legacyExes) + splitTopLevel (ExLegacyBuildToolFix p v : deps) = let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps - in (other, exts, lang, pcpkgs, exes, (p, C.thisVersion (mkSimpleVersion v)):legacyExes) - splitTopLevel (ExExt ext:deps) = + in (other, exts, lang, pcpkgs, exes, (p, C.thisVersion (mkSimpleVersion v)) : legacyExes) + splitTopLevel (ExExt ext : deps) = let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps - in (other, ext:exts, lang, pcpkgs, exes, legacyExes) - splitTopLevel (ExLang lang:deps) = - case splitTopLevel deps of - (other, exts, Nothing, pcpkgs, exes, legacyExes) -> (other, exts, Just lang, pcpkgs, exes, legacyExes) - _ -> error "Only 1 Language dependency is supported" - splitTopLevel (ExPkg pkg:deps) = + in (other, ext : exts, lang, pcpkgs, exes, legacyExes) + splitTopLevel (ExLang lang : deps) = + case splitTopLevel deps of + (other, exts, Nothing, pcpkgs, exes, legacyExes) -> (other, exts, Just lang, pcpkgs, exes, legacyExes) + _ -> error "Only 1 Language dependency is supported" + splitTopLevel (ExPkg pkg : deps) = let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps - in (other, exts, lang, pkg:pcpkgs, exes, legacyExes) - splitTopLevel (dep:deps) = + in (other, exts, lang, pkg : pcpkgs, exes, legacyExes) + splitTopLevel (dep : deps) = let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps - in (dep:other, exts, lang, pcpkgs, exes, legacyExes) + in (dep : other, exts, lang, pcpkgs, exes, legacyExes) -- Extract the total set of flags used extractFlags :: Dependencies -> [ExampleFlagName] extractFlags deps = concatMap go (depsExampleDependencies deps) where go :: ExampleDependency -> [ExampleFlagName] - go (ExAny _) = [] - go (ExFix _ _) = [] - go (ExRange _ _ _) = [] - go (ExSubLibAny _ _) = [] - go (ExSubLibFix _ _ _) = [] - go (ExBuildToolAny _ _) = [] - go (ExBuildToolFix _ _ _) = [] - go (ExLegacyBuildToolAny _) = [] + go (ExAny _) = [] + go (ExFix _ _) = [] + go (ExRange _ _ _) = [] + go (ExSubLibAny _ _) = [] + go (ExSubLibFix _ _ _) = [] + go (ExBuildToolAny _ _) = [] + go (ExBuildToolFix _ _ _) = [] + go (ExLegacyBuildToolAny _) = [] go (ExLegacyBuildToolFix _ _) = [] - go (ExFlagged f a b) = f : extractFlags a ++ extractFlags b - go (ExExt _) = [] - go (ExLang _) = [] - go (ExPkg _) = [] + go (ExFlagged f a b) = f : extractFlags a ++ extractFlags b + go (ExExt _) = [] + go (ExLang _) = [] + go (ExPkg _) = [] -- Convert 'Dependencies' into a tree of a specific component type, using -- the given top level component and function for creating a component at -- any level. - mkTopLevelCondTree :: forall a. Semigroup a => - a - -> (C.LibraryVisibility -> C.BuildInfo -> a) - -> Dependencies - -> DependencyTree a + mkTopLevelCondTree + :: forall a + . Semigroup a + => a + -> (C.LibraryVisibility -> C.BuildInfo -> a) + -> Dependencies + -> DependencyTree a mkTopLevelCondTree defaultTopLevel mkComponent deps = let condNode = mkCondTree mkComponent deps - in condNode { C.condTreeData = defaultTopLevel <> C.condTreeData condNode } + in condNode{C.condTreeData = defaultTopLevel <> C.condTreeData condNode} -- Convert 'Dependencies' into a tree of a specific component type, using -- the given function to generate each component. @@ -597,88 +621,97 @@ exAvSrcPkg ex = let (libraryDeps, exts, mlang, pcpkgs, buildTools, legacyBuildTools) = splitTopLevel (depsExampleDependencies deps) (directDeps, flaggedDeps) = splitDeps libraryDeps component = mkComponent (depsVisibility deps) bi - bi = mempty { - C.otherExtensions = exts - , C.defaultLanguage = mlang - , C.buildToolDepends = [ C.ExeDependency (C.mkPackageName p) (C.mkUnqualComponentName e) vr - | (p, e, vr) <- buildTools] - , C.buildTools = [ C.LegacyExeDependency n vr - | (n,vr) <- legacyBuildTools] - , C.pkgconfigDepends = [ C.PkgconfigDependency n' v' - | (n,v) <- pcpkgs - , let n' = C.mkPkgconfigName n - , let v' = C.PcThisVersion (mkSimplePkgconfigVersion v) ] - , C.buildable = depsIsBuildable deps + bi = + mempty + { C.otherExtensions = exts + , C.defaultLanguage = mlang + , C.buildToolDepends = + [ C.ExeDependency (C.mkPackageName p) (C.mkUnqualComponentName e) vr + | (p, e, vr) <- buildTools + ] + , C.buildTools = + [ C.LegacyExeDependency n vr + | (n, vr) <- legacyBuildTools + ] + , C.pkgconfigDepends = + [ C.PkgconfigDependency n' v' + | (n, v) <- pcpkgs + , let n' = C.mkPkgconfigName n + , let v' = C.PcThisVersion (mkSimplePkgconfigVersion v) + ] + , C.buildable = depsIsBuildable deps } - in C.CondNode { - C.condTreeData = component - -- TODO: Arguably, build-tools dependencies should also - -- effect constraints on conditional tree. But no way to - -- distinguish between them - , C.condTreeConstraints = map mkDirect directDeps - , C.condTreeComponents = map (mkFlagged mkComponent) flaggedDeps - } + in C.CondNode + { C.condTreeData = component + , -- TODO: Arguably, build-tools dependencies should also + -- effect constraints on conditional tree. But no way to + -- distinguish between them + C.condTreeConstraints = map mkDirect directDeps + , C.condTreeComponents = map (mkFlagged mkComponent) flaggedDeps + } mkDirect :: (ExamplePkgName, C.LibraryName, C.VersionRange) -> C.Dependency mkDirect (dep, name, vr) = C.Dependency (C.mkPackageName dep) vr (NonEmptySet.singleton name) - mkFlagged :: (C.LibraryVisibility -> C.BuildInfo -> a) - -> (ExampleFlagName, Dependencies, Dependencies) - -> DependencyComponent a + mkFlagged + :: (C.LibraryVisibility -> C.BuildInfo -> a) + -> (ExampleFlagName, Dependencies, Dependencies) + -> DependencyComponent a mkFlagged mkComponent (f, a, b) = - C.CondBranch (C.Var (C.PackageFlag (C.mkFlagName f))) - (mkCondTree mkComponent a) - (Just (mkCondTree mkComponent b)) + C.CondBranch + (C.Var (C.PackageFlag (C.mkFlagName f))) + (mkCondTree mkComponent a) + (Just (mkCondTree mkComponent b)) -- Split a set of dependencies into direct dependencies and flagged -- dependencies. A direct dependency is a tuple of the name of package and -- its version range meant to be converted to a 'C.Dependency' with -- 'mkDirect' for example. A flagged dependency is the set of dependencies -- guarded by a flag. - splitDeps :: [ExampleDependency] - -> ( [(ExamplePkgName, C.LibraryName, C.VersionRange)] - , [(ExampleFlagName, Dependencies, Dependencies)] - ) + splitDeps + :: [ExampleDependency] + -> ( [(ExamplePkgName, C.LibraryName, C.VersionRange)] + , [(ExampleFlagName, Dependencies, Dependencies)] + ) splitDeps [] = ([], []) - splitDeps (ExAny p:deps) = + splitDeps (ExAny p : deps) = let (directDeps, flaggedDeps) = splitDeps deps - in ((p, C.LMainLibName, C.anyVersion):directDeps, flaggedDeps) - splitDeps (ExFix p v:deps) = + in ((p, C.LMainLibName, C.anyVersion) : directDeps, flaggedDeps) + splitDeps (ExFix p v : deps) = let (directDeps, flaggedDeps) = splitDeps deps - in ((p, C.LMainLibName, C.thisVersion $ mkSimpleVersion v):directDeps, flaggedDeps) - splitDeps (ExRange p v1 v2:deps) = + in ((p, C.LMainLibName, C.thisVersion $ mkSimpleVersion v) : directDeps, flaggedDeps) + splitDeps (ExRange p v1 v2 : deps) = let (directDeps, flaggedDeps) = splitDeps deps - in ((p, C.LMainLibName, mkVersionRange v1 v2):directDeps, flaggedDeps) - splitDeps (ExSubLibAny p lib:deps) = + in ((p, C.LMainLibName, mkVersionRange v1 v2) : directDeps, flaggedDeps) + splitDeps (ExSubLibAny p lib : deps) = let (directDeps, flaggedDeps) = splitDeps deps - in ((p, C.LSubLibName (C.mkUnqualComponentName lib), C.anyVersion):directDeps, flaggedDeps) - splitDeps (ExSubLibFix p lib v:deps) = + in ((p, C.LSubLibName (C.mkUnqualComponentName lib), C.anyVersion) : directDeps, flaggedDeps) + splitDeps (ExSubLibFix p lib v : deps) = let (directDeps, flaggedDeps) = splitDeps deps - in ((p, C.LSubLibName (C.mkUnqualComponentName lib), C.thisVersion $ mkSimpleVersion v):directDeps, flaggedDeps) - splitDeps (ExFlagged f a b:deps) = + in ((p, C.LSubLibName (C.mkUnqualComponentName lib), C.thisVersion $ mkSimpleVersion v) : directDeps, flaggedDeps) + splitDeps (ExFlagged f a b : deps) = let (directDeps, flaggedDeps) = splitDeps deps - in (directDeps, (f, a, b):flaggedDeps) - splitDeps (dep:_) = error $ "Unexpected dependency: " ++ show dep + in (directDeps, (f, a, b) : flaggedDeps) + splitDeps (dep : _) = error $ "Unexpected dependency: " ++ show dep -- custom-setup only supports simple dependencies mkSetupDeps :: [ExampleDependency] -> [C.Dependency] mkSetupDeps deps = case splitDeps deps of (directDeps, []) -> map mkDirect directDeps - _ -> error "mkSetupDeps: custom setup has non-simple deps" + _ -> error "mkSetupDeps: custom setup has non-simple deps" -- Check for `UnknownLanguages` and `UnknownExtensions`. See isUnknownLangExt :: C.PackageCheck -> Bool isUnknownLangExt pc = case C.explanation pc of - C.UnknownExtensions {} -> True - C.UnknownLanguages {} -> True - _ -> False + C.UnknownExtensions{} -> True + C.UnknownLanguages{} -> True + _ -> False isMissingUpperBound :: C.PackageCheck -> Bool isMissingUpperBound pc = case C.explanation pc of - C.MissingUpperBounds {} -> True - _ -> False - + C.MissingUpperBounds{} -> True + _ -> False mkSimpleVersion :: ExamplePkgVersion -> C.Version mkSimpleVersion n = C.mkVersion [n, 0, 0] @@ -688,44 +721,50 @@ mkSimplePkgconfigVersion = C.versionToPkgconfigVersion . mkSimpleVersion mkVersionRange :: ExamplePkgVersion -> ExamplePkgVersion -> C.VersionRange mkVersionRange v1 v2 = - C.intersectVersionRanges (C.orLaterVersion $ mkSimpleVersion v1) - (C.earlierVersion $ mkSimpleVersion v2) + C.intersectVersionRanges + (C.orLaterVersion $ mkSimpleVersion v1) + (C.earlierVersion $ mkSimpleVersion v2) mkFlag :: ExFlag -> C.PackageFlag -mkFlag flag = C.MkPackageFlag { - C.flagName = C.mkFlagName $ exFlagName flag - , C.flagDescription = "" - , C.flagDefault = exFlagDefault flag - , C.flagManual = - case exFlagType flag of - Manual -> True - Automatic -> False - } +mkFlag flag = + C.MkPackageFlag + { C.flagName = C.mkFlagName $ exFlagName flag + , C.flagDescription = "" + , C.flagDefault = exFlagDefault flag + , C.flagManual = + case exFlagType flag of + Manual -> True + Automatic -> False + } mkDefaultFlag :: ExampleFlagName -> C.PackageFlag -mkDefaultFlag flag = C.MkPackageFlag { - C.flagName = C.mkFlagName flag - , C.flagDescription = "" - , C.flagDefault = True - , C.flagManual = False - } +mkDefaultFlag flag = + C.MkPackageFlag + { C.flagName = C.mkFlagName flag + , C.flagDescription = "" + , C.flagDefault = True + , C.flagManual = False + } exAvPkgId :: ExampleAvailable -> C.PackageIdentifier -exAvPkgId ex = C.PackageIdentifier { - pkgName = C.mkPackageName (exAvName ex) +exAvPkgId ex = + C.PackageIdentifier + { pkgName = C.mkPackageName (exAvName ex) , pkgVersion = C.mkVersion [exAvVersion ex, 0, 0] } exInstInfo :: ExampleInstalled -> IPI.InstalledPackageInfo -exInstInfo ex = IPI.emptyInstalledPackageInfo { - IPI.installedUnitId = C.mkUnitId (exInstHash ex) - , IPI.sourcePackageId = exInstPkgId ex - , IPI.depends = map C.mkUnitId (exInstBuildAgainst ex) +exInstInfo ex = + IPI.emptyInstalledPackageInfo + { IPI.installedUnitId = C.mkUnitId (exInstHash ex) + , IPI.sourcePackageId = exInstPkgId ex + , IPI.depends = map C.mkUnitId (exInstBuildAgainst ex) } exInstPkgId :: ExampleInstalled -> C.PackageIdentifier -exInstPkgId ex = C.PackageIdentifier { - pkgName = C.mkPackageName (exInstName ex) +exInstPkgId ex = + C.PackageIdentifier + { pkgName = C.mkPackageName (exInstName ex) , pkgVersion = C.mkVersion [exInstVersion ex, 0, 0] } @@ -735,94 +774,122 @@ exAvIdx = CI.PackageIndex.fromList . map exAvSrcPkg exInstIdx :: [ExampleInstalled] -> C.PackageIndex.InstalledPackageIndex exInstIdx = C.PackageIndex.fromList . map exInstInfo -exResolve :: ExampleDb - -- List of extensions supported by the compiler, or Nothing if unknown. - -> Maybe [Extension] - -- List of languages supported by the compiler, or Nothing if unknown. - -> Maybe [Language] - -> PC.PkgConfigDb - -> [ExamplePkgName] - -> Maybe Int - -> CountConflicts - -> FineGrainedConflicts - -> MinimizeConflictSet - -> IndependentGoals - -> PreferOldest - -> ReorderGoals - -> AllowBootLibInstalls - -> OnlyConstrained - -> EnableBackjumping - -> SolveExecutables - -> Maybe (Variable P.QPN -> Variable P.QPN -> Ordering) - -> [ExConstraint] - -> [ExPreference] - -> C.Verbosity - -> EnableAllTests - -> Progress String String CI.SolverInstallPlan.SolverInstallPlan -exResolve db exts langs pkgConfigDb targets mbj countConflicts - fineGrainedConflicts minimizeConflictSet indepGoals prefOldest reorder - allowBootLibInstalls onlyConstrained enableBj solveExes goalOrder - constraints prefs verbosity enableAllTests - = resolveDependencies C.buildPlatform compiler pkgConfigDb Modular params - where - defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag - compiler = defaultCompiler { C.compilerInfoExtensions = exts - , C.compilerInfoLanguages = langs - } - (inst, avai) = partitionEithers db - instIdx = exInstIdx inst - avaiIdx = SourcePackageDb { - packageIndex = exAvIdx avai - , packagePreferences = Map.empty - } - enableTests - | asBool enableAllTests = fmap (\p -> PackageConstraint - (scopeToplevel (C.mkPackageName p)) - (PackagePropertyStanzas [TestStanzas])) - (exDbPkgs db) - | otherwise = [] - targets' = fmap (\p -> NamedPackage (C.mkPackageName p) []) targets - params = addConstraints (fmap toConstraint constraints) - $ addConstraints (fmap toLpc enableTests) - $ addPreferences (fmap toPref prefs) - $ setCountConflicts countConflicts - $ setFineGrainedConflicts fineGrainedConflicts - $ setMinimizeConflictSet minimizeConflictSet - $ setIndependentGoals indepGoals - $ (if asBool prefOldest then setPreferenceDefault PreferAllOldest else id) - $ setReorderGoals reorder - $ setMaxBackjumps mbj - $ setAllowBootLibInstalls allowBootLibInstalls - $ setOnlyConstrained onlyConstrained - $ setEnableBackjumping enableBj - $ setSolveExecutables solveExes - $ setGoalOrder goalOrder - $ setSolverVerbosity verbosity - $ standardInstallPolicy instIdx avaiIdx targets' - toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown - - toConstraint (ExVersionConstraint scope v) = +exResolve + :: ExampleDb + -- List of extensions supported by the compiler, or Nothing if unknown. + -> Maybe [Extension] + -- List of languages supported by the compiler, or Nothing if unknown. + -> Maybe [Language] + -> PC.PkgConfigDb + -> [ExamplePkgName] + -> Maybe Int + -> CountConflicts + -> FineGrainedConflicts + -> MinimizeConflictSet + -> IndependentGoals + -> PreferOldest + -> ReorderGoals + -> AllowBootLibInstalls + -> OnlyConstrained + -> EnableBackjumping + -> SolveExecutables + -> Maybe (Variable P.QPN -> Variable P.QPN -> Ordering) + -> [ExConstraint] + -> [ExPreference] + -> C.Verbosity + -> EnableAllTests + -> Progress String String CI.SolverInstallPlan.SolverInstallPlan +exResolve + db + exts + langs + pkgConfigDb + targets + mbj + countConflicts + fineGrainedConflicts + minimizeConflictSet + indepGoals + prefOldest + reorder + allowBootLibInstalls + onlyConstrained + enableBj + solveExes + goalOrder + constraints + prefs + verbosity + enableAllTests = + resolveDependencies C.buildPlatform compiler pkgConfigDb Modular params + where + defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag + compiler = + defaultCompiler + { C.compilerInfoExtensions = exts + , C.compilerInfoLanguages = langs + } + (inst, avai) = partitionEithers db + instIdx = exInstIdx inst + avaiIdx = + SourcePackageDb + { packageIndex = exAvIdx avai + , packagePreferences = Map.empty + } + enableTests + | asBool enableAllTests = + fmap + ( \p -> + PackageConstraint + (scopeToplevel (C.mkPackageName p)) + (PackagePropertyStanzas [TestStanzas]) + ) + (exDbPkgs db) + | otherwise = [] + targets' = fmap (\p -> NamedPackage (C.mkPackageName p) []) targets + params = + addConstraints (fmap toConstraint constraints) $ + addConstraints (fmap toLpc enableTests) $ + addPreferences (fmap toPref prefs) $ + setCountConflicts countConflicts $ + setFineGrainedConflicts fineGrainedConflicts $ + setMinimizeConflictSet minimizeConflictSet $ + setIndependentGoals indepGoals $ + (if asBool prefOldest then setPreferenceDefault PreferAllOldest else id) $ + setReorderGoals reorder $ + setMaxBackjumps mbj $ + setAllowBootLibInstalls allowBootLibInstalls $ + setOnlyConstrained onlyConstrained $ + setEnableBackjumping enableBj $ + setSolveExecutables solveExes $ + setGoalOrder goalOrder $ + setSolverVerbosity verbosity $ + standardInstallPolicy instIdx avaiIdx targets' + toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown + + toConstraint (ExVersionConstraint scope v) = toLpc $ PackageConstraint scope (PackagePropertyVersion v) - toConstraint (ExFlagConstraint scope fn b) = + toConstraint (ExFlagConstraint scope fn b) = toLpc $ PackageConstraint scope (PackagePropertyFlags (C.mkFlagAssignment [(C.mkFlagName fn, b)])) - toConstraint (ExStanzaConstraint scope stanzas) = + toConstraint (ExStanzaConstraint scope stanzas) = toLpc $ PackageConstraint scope (PackagePropertyStanzas stanzas) - toPref (ExPkgPref n v) = PackageVersionPreference (C.mkPackageName n) v - toPref (ExStanzaPref n stanzas) = PackageStanzasPreference (C.mkPackageName n) stanzas + toPref (ExPkgPref n v) = PackageVersionPreference (C.mkPackageName n) v + toPref (ExStanzaPref n stanzas) = PackageStanzasPreference (C.mkPackageName n) stanzas -extractInstallPlan :: CI.SolverInstallPlan.SolverInstallPlan - -> [(ExamplePkgName, ExamplePkgVersion)] +extractInstallPlan + :: CI.SolverInstallPlan.SolverInstallPlan + -> [(ExamplePkgName, ExamplePkgVersion)] extractInstallPlan = catMaybes . map confPkg . CI.SolverInstallPlan.toList where confPkg :: CI.SolverInstallPlan.SolverPlanPackage -> Maybe (String, Int) confPkg (CI.SolverInstallPlan.Configured pkg) = srcPkg pkg - confPkg _ = Nothing + confPkg _ = Nothing srcPkg :: SolverPackage UnresolvedPkgLoc -> Maybe (String, Int) srcPkg cpkg = let C.PackageIdentifier pn ver = C.packageId (solverPkgSource cpkg) - in (\vn -> (C.unPackageName pn, vn)) <$> safeHead (C.versionNumbers ver) + in (\vn -> (C.unPackageName pn, vn)) <$> safeHead (C.versionNumbers ver) {------------------------------------------------------------------------------- Auxiliary @@ -832,6 +899,6 @@ extractInstallPlan = catMaybes . map confPkg . CI.SolverInstallPlan.toList runProgress :: Progress step e a -> ([step], Either e a) runProgress = go where - go (Step s p) = let (ss, result) = go p in (s:ss, result) - go (Fail e) = ([], Left e) - go (Done a) = ([], Right a) + go (Step s p) = let (ss, result) = go p in (s : ss, result) + go (Fail e) = ([], Left e) + go (Done a) = ([], Right a) diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs index 1d29baaad12..91ec541f976 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs @@ -1,8 +1,9 @@ {-# LANGUAGE RecordWildCards #-} + -- | Utilities for creating HUnit test cases with the solver DSL. -module UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils ( - SolverTest - , SolverResult(..) +module UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils + ( SolverTest + , SolverResult (..) , maxBackjumps , disableFineGrainedConflicts , minimizeConflictSet @@ -28,119 +29,119 @@ module UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils ( , runTest ) where -import Prelude () import Distribution.Solver.Compat.Prelude +import Prelude () import Data.List (elemIndex) -- test-framework import Test.Tasty as TF -import Test.Tasty.HUnit (testCase, assertEqual, assertBool) +import Test.Tasty.HUnit (assertBool, assertEqual, testCase) -- Cabal import qualified Distribution.PackageDescription as C -import Language.Haskell.Extension (Extension(..), Language(..)) import Distribution.Verbosity +import Language.Haskell.Extension (Extension (..), Language (..)) -- cabal-install + +import Distribution.Client.Dependency (foldProgress) import qualified Distribution.Solver.Types.PackagePath as P import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb (..), pkgConfigDbFromList) import Distribution.Solver.Types.Settings import Distribution.Solver.Types.Variable -import Distribution.Client.Dependency (foldProgress) import UnitTests.Distribution.Solver.Modular.DSL import UnitTests.Options maxBackjumps :: Maybe Int -> SolverTest -> SolverTest -maxBackjumps mbj test = test { testMaxBackjumps = mbj } +maxBackjumps mbj test = test{testMaxBackjumps = mbj} disableFineGrainedConflicts :: SolverTest -> SolverTest disableFineGrainedConflicts test = - test { testFineGrainedConflicts = FineGrainedConflicts False } + test{testFineGrainedConflicts = FineGrainedConflicts False} minimizeConflictSet :: SolverTest -> SolverTest minimizeConflictSet test = - test { testMinimizeConflictSet = MinimizeConflictSet True } + test{testMinimizeConflictSet = MinimizeConflictSet True} -- | Combinator to turn on --independent-goals behavior, i.e. solve -- for the goals as if we were solving for each goal independently. independentGoals :: SolverTest -> SolverTest -independentGoals test = test { testIndepGoals = IndependentGoals True } +independentGoals test = test{testIndepGoals = IndependentGoals True} -- | Combinator to turn on --prefer-oldest preferOldest :: SolverTest -> SolverTest -preferOldest test = test { testPreferOldest = PreferOldest True } +preferOldest test = test{testPreferOldest = PreferOldest True} allowBootLibInstalls :: SolverTest -> SolverTest allowBootLibInstalls test = - test { testAllowBootLibInstalls = AllowBootLibInstalls True } + test{testAllowBootLibInstalls = AllowBootLibInstalls True} onlyConstrained :: SolverTest -> SolverTest onlyConstrained test = - test { testOnlyConstrained = OnlyConstrainedAll } + test{testOnlyConstrained = OnlyConstrainedAll} disableBackjumping :: SolverTest -> SolverTest disableBackjumping test = - test { testEnableBackjumping = EnableBackjumping False } + test{testEnableBackjumping = EnableBackjumping False} disableSolveExecutables :: SolverTest -> SolverTest disableSolveExecutables test = - test { testSolveExecutables = SolveExecutables False } + test{testSolveExecutables = SolveExecutables False} goalOrder :: [ExampleVar] -> SolverTest -> SolverTest -goalOrder order test = test { testGoalOrder = Just order } +goalOrder order test = test{testGoalOrder = Just order} constraints :: [ExConstraint] -> SolverTest -> SolverTest -constraints cs test = test { testConstraints = cs } +constraints cs test = test{testConstraints = cs} preferences :: [ExPreference] -> SolverTest -> SolverTest -preferences prefs test = test { testSoftConstraints = prefs } +preferences prefs test = test{testSoftConstraints = prefs} -- | Increase the solver's verbosity. This is necessary for test cases that -- check the contents of the verbose log. setVerbose :: SolverTest -> SolverTest -setVerbose test = test { testVerbosity = verbose } +setVerbose test = test{testVerbosity = verbose} enableAllTests :: SolverTest -> SolverTest -enableAllTests test = test { testEnableAllTests = EnableAllTests True } +enableAllTests test = test{testEnableAllTests = EnableAllTests True} {------------------------------------------------------------------------------- Solver tests -------------------------------------------------------------------------------} -data SolverTest = SolverTest { - testLabel :: String - , testTargets :: [String] - , testResult :: SolverResult - , testMaxBackjumps :: Maybe Int +data SolverTest = SolverTest + { testLabel :: String + , testTargets :: [String] + , testResult :: SolverResult + , testMaxBackjumps :: Maybe Int , testFineGrainedConflicts :: FineGrainedConflicts - , testMinimizeConflictSet :: MinimizeConflictSet - , testIndepGoals :: IndependentGoals - , testPreferOldest :: PreferOldest + , testMinimizeConflictSet :: MinimizeConflictSet + , testIndepGoals :: IndependentGoals + , testPreferOldest :: PreferOldest , testAllowBootLibInstalls :: AllowBootLibInstalls - , testOnlyConstrained :: OnlyConstrained - , testEnableBackjumping :: EnableBackjumping - , testSolveExecutables :: SolveExecutables - , testGoalOrder :: Maybe [ExampleVar] - , testConstraints :: [ExConstraint] - , testSoftConstraints :: [ExPreference] - , testVerbosity :: Verbosity - , testDb :: ExampleDb - , testSupportedExts :: Maybe [Extension] - , testSupportedLangs :: Maybe [Language] - , testPkgConfigDb :: PkgConfigDb - , testEnableAllTests :: EnableAllTests + , testOnlyConstrained :: OnlyConstrained + , testEnableBackjumping :: EnableBackjumping + , testSolveExecutables :: SolveExecutables + , testGoalOrder :: Maybe [ExampleVar] + , testConstraints :: [ExConstraint] + , testSoftConstraints :: [ExPreference] + , testVerbosity :: Verbosity + , testDb :: ExampleDb + , testSupportedExts :: Maybe [Extension] + , testSupportedLangs :: Maybe [Language] + , testPkgConfigDb :: PkgConfigDb + , testEnableAllTests :: EnableAllTests } -- | Expected result of a solver test. -data SolverResult = SolverResult { - -- | The solver's log should satisfy this predicate. Note that we also print - -- the log, so evaluating a large log here can cause a space leak. - resultLogPredicate :: [String] -> Bool, - - -- | Fails with an error message satisfying the predicate, or succeeds with - -- the given plan. - resultErrorMsgPredicateOrPlan :: Either (String -> Bool) [(String, Int)] +data SolverResult = SolverResult + { resultLogPredicate :: [String] -> Bool + -- ^ The solver's log should satisfy this predicate. Note that we also print + -- the log, so evaluating a large log here can cause a space leak. + , resultErrorMsgPredicateOrPlan :: Either (String -> Bool) [(String, Int)] + -- ^ Fails with an error message satisfying the predicate, or succeeds with + -- the given plan. } solverSuccess :: [(String, Int)] -> SolverResult @@ -167,124 +168,159 @@ anySolverFailure = solverFailure (const True) -- See 'UnitTests.Distribution.Solver.Modular.DSL' for how -- to construct an 'ExampleDb', as well as definitions of 'db1' etc. -- in this file. -mkTest :: ExampleDb - -> String - -> [String] - -> SolverResult - -> SolverTest +mkTest + :: ExampleDb + -> String + -> [String] + -> SolverResult + -> SolverTest mkTest = mkTestExtLangPC Nothing Nothing (Just []) -mkTestExts :: [Extension] - -> ExampleDb - -> String - -> [String] - -> SolverResult - -> SolverTest +mkTestExts + :: [Extension] + -> ExampleDb + -> String + -> [String] + -> SolverResult + -> SolverTest mkTestExts exts = mkTestExtLangPC (Just exts) Nothing (Just []) -mkTestLangs :: [Language] - -> ExampleDb - -> String - -> [String] - -> SolverResult - -> SolverTest +mkTestLangs + :: [Language] + -> ExampleDb + -> String + -> [String] + -> SolverResult + -> SolverTest mkTestLangs langs = mkTestExtLangPC Nothing (Just langs) (Just []) -mkTestPCDepends :: Maybe [(String, String)] - -> ExampleDb - -> String - -> [String] - -> SolverResult - -> SolverTest +mkTestPCDepends + :: Maybe [(String, String)] + -> ExampleDb + -> String + -> [String] + -> SolverResult + -> SolverTest mkTestPCDepends mPkgConfigDb = mkTestExtLangPC Nothing Nothing mPkgConfigDb -mkTestExtLangPC :: Maybe [Extension] - -> Maybe [Language] - -> Maybe [(String, String)] - -> ExampleDb - -> String - -> [String] - -> SolverResult - -> SolverTest -mkTestExtLangPC exts langs mPkgConfigDb db label targets result = SolverTest { - testLabel = label - , testTargets = targets - , testResult = result - , testMaxBackjumps = Nothing - , testFineGrainedConflicts = FineGrainedConflicts True - , testMinimizeConflictSet = MinimizeConflictSet False - , testIndepGoals = IndependentGoals False - , testPreferOldest = PreferOldest False - , testAllowBootLibInstalls = AllowBootLibInstalls False - , testOnlyConstrained = OnlyConstrainedNone - , testEnableBackjumping = EnableBackjumping True - , testSolveExecutables = SolveExecutables True - , testGoalOrder = Nothing - , testConstraints = [] - , testSoftConstraints = [] - , testVerbosity = normal - , testDb = db - , testSupportedExts = exts - , testSupportedLangs = langs - , testPkgConfigDb = maybe NoPkgConfigDb pkgConfigDbFromList mPkgConfigDb - , testEnableAllTests = EnableAllTests False - } +mkTestExtLangPC + :: Maybe [Extension] + -> Maybe [Language] + -> Maybe [(String, String)] + -> ExampleDb + -> String + -> [String] + -> SolverResult + -> SolverTest +mkTestExtLangPC exts langs mPkgConfigDb db label targets result = + SolverTest + { testLabel = label + , testTargets = targets + , testResult = result + , testMaxBackjumps = Nothing + , testFineGrainedConflicts = FineGrainedConflicts True + , testMinimizeConflictSet = MinimizeConflictSet False + , testIndepGoals = IndependentGoals False + , testPreferOldest = PreferOldest False + , testAllowBootLibInstalls = AllowBootLibInstalls False + , testOnlyConstrained = OnlyConstrainedNone + , testEnableBackjumping = EnableBackjumping True + , testSolveExecutables = SolveExecutables True + , testGoalOrder = Nothing + , testConstraints = [] + , testSoftConstraints = [] + , testVerbosity = normal + , testDb = db + , testSupportedExts = exts + , testSupportedLangs = langs + , testPkgConfigDb = maybe NoPkgConfigDb pkgConfigDbFromList mPkgConfigDb + , testEnableAllTests = EnableAllTests False + } runTest :: SolverTest -> TF.TestTree runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) -> - testCase testLabel $ do - let progress = exResolve testDb testSupportedExts - testSupportedLangs testPkgConfigDb testTargets - testMaxBackjumps (CountConflicts True) - testFineGrainedConflicts testMinimizeConflictSet - testIndepGoals testPreferOldest (ReorderGoals False) testAllowBootLibInstalls - testOnlyConstrained testEnableBackjumping testSolveExecutables - (sortGoals <$> testGoalOrder) testConstraints - testSoftConstraints testVerbosity testEnableAllTests - printMsg msg = when showSolverLog $ putStrLn msg - msgs = foldProgress (:) (const []) (const []) progress - assertBool ("Unexpected solver log:\n" ++ unlines msgs) $ - resultLogPredicate testResult $ concatMap lines msgs - result <- foldProgress ((>>) . printMsg) (return . Left) (return . Right) progress - case result of - Left err -> assertBool ("Unexpected error:\n" ++ err) - (checkErrorMsg testResult err) - Right plan -> assertEqual "" (toMaybe testResult) (Just (extractInstallPlan plan)) + testCase testLabel $ do + let progress = + exResolve + testDb + testSupportedExts + testSupportedLangs + testPkgConfigDb + testTargets + testMaxBackjumps + (CountConflicts True) + testFineGrainedConflicts + testMinimizeConflictSet + testIndepGoals + testPreferOldest + (ReorderGoals False) + testAllowBootLibInstalls + testOnlyConstrained + testEnableBackjumping + testSolveExecutables + (sortGoals <$> testGoalOrder) + testConstraints + testSoftConstraints + testVerbosity + testEnableAllTests + printMsg msg = when showSolverLog $ putStrLn msg + msgs = foldProgress (:) (const []) (const []) progress + assertBool ("Unexpected solver log:\n" ++ unlines msgs) $ + resultLogPredicate testResult $ + concatMap lines msgs + result <- foldProgress ((>>) . printMsg) (return . Left) (return . Right) progress + case result of + Left err -> + assertBool + ("Unexpected error:\n" ++ err) + (checkErrorMsg testResult err) + Right plan -> assertEqual "" (toMaybe testResult) (Just (extractInstallPlan plan)) where toMaybe :: SolverResult -> Maybe [(String, Int)] toMaybe = either (const Nothing) Just . resultErrorMsgPredicateOrPlan checkErrorMsg :: SolverResult -> String -> Bool checkErrorMsg result msg = - case resultErrorMsgPredicateOrPlan result of - Left f -> f msg - Right _ -> False - - sortGoals :: [ExampleVar] - -> Variable P.QPN -> Variable P.QPN -> Ordering + case resultErrorMsgPredicateOrPlan result of + Left f -> f msg + Right _ -> False + + sortGoals + :: [ExampleVar] + -> Variable P.QPN + -> Variable P.QPN + -> Ordering sortGoals = orderFromList . map toVariable -- Sort elements in the list ahead of elements not in the list. Otherwise, -- follow the order in the list. orderFromList :: Eq a => [a] -> a -> a -> Ordering orderFromList xs = - comparing $ \x -> let i = elemIndex x xs in (isNothing i, i) + comparing $ \x -> let i = elemIndex x xs in (isNothing i, i) toVariable :: ExampleVar -> Variable P.QPN - toVariable (P q pn) = PackageVar (toQPN q pn) - toVariable (F q pn fn) = FlagVar (toQPN q pn) (C.mkFlagName fn) - toVariable (S q pn stanza) = StanzaVar (toQPN q pn) stanza + toVariable (P q pn) = PackageVar (toQPN q pn) + toVariable (F q pn fn) = FlagVar (toQPN q pn) (C.mkFlagName fn) + toVariable (S q pn stanza) = StanzaVar (toQPN q pn) stanza toQPN :: ExampleQualifier -> ExamplePkgName -> P.QPN toQPN q pn = P.Q pp (C.mkPackageName pn) where pp = case q of - QualNone -> P.PackagePath P.DefaultNamespace P.QualToplevel - QualIndep p -> P.PackagePath (P.Independent $ C.mkPackageName p) - P.QualToplevel - QualSetup s -> P.PackagePath P.DefaultNamespace - (P.QualSetup (C.mkPackageName s)) - QualIndepSetup p s -> P.PackagePath (P.Independent $ C.mkPackageName p) - (P.QualSetup (C.mkPackageName s)) - QualExe p1 p2 -> P.PackagePath P.DefaultNamespace - (P.QualExe (C.mkPackageName p1) (C.mkPackageName p2)) + QualNone -> P.PackagePath P.DefaultNamespace P.QualToplevel + QualIndep p -> + P.PackagePath + (P.Independent $ C.mkPackageName p) + P.QualToplevel + QualSetup s -> + P.PackagePath + P.DefaultNamespace + (P.QualSetup (C.mkPackageName s)) + QualIndepSetup p s -> + P.PackagePath + (P.Independent $ C.mkPackageName p) + (P.QualSetup (C.mkPackageName s)) + QualExe p1 p2 -> + P.PackagePath + P.DefaultNamespace + (P.QualExe (C.mkPackageName p1) (C.mkPackageName p2)) diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs index 463e56bd7e6..ba63db84760 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs @@ -7,13 +7,13 @@ import UnitTests.Distribution.Solver.Modular.DSL import UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils tests :: [TestTree] -tests = [ - runTest $ basicTest "basic space leak test" - , runTest $ flagsTest "package with many flags" - , runTest $ issue2899 "issue #2899" - , runTest $ duplicateDependencies "duplicate dependencies" - , runTest $ duplicateFlaggedDependencies "duplicate flagged dependencies" - ] +tests = + [ runTest $ basicTest "basic space leak test" + , runTest $ flagsTest "package with many flags" + , runTest $ issue2899 "issue #2899" + , runTest $ duplicateDependencies "duplicate dependencies" + , runTest $ duplicateFlaggedDependencies "duplicate flagged dependencies" + ] -- | This test solves for n packages that each have two versions. There is no -- solution, because the nth package depends on another package that doesn't fit @@ -22,19 +22,22 @@ tests = [ -- memory usage is proportional to the size of the tree. basicTest :: String -> SolverTest basicTest name = - disableBackjumping $ + disableBackjumping $ disableFineGrainedConflicts $ - mkTest pkgs name ["target"] anySolverFailure + mkTest pkgs name ["target"] anySolverFailure where n :: Int n = 18 pkgs :: ExampleDb - pkgs = map Right $ - [ exAv "target" 1 [ExAny $ pkgName 1]] - ++ [ exAv (pkgName i) v [ExRange (pkgName $ i + 1) 2 4] - | i <- [1..n], v <- [2, 3]] - ++ [exAv (pkgName $ n + 1) 1 []] + pkgs = + map Right $ + [exAv "target" 1 [ExAny $ pkgName 1]] + ++ [ exAv (pkgName i) v [ExRange (pkgName $ i + 1) 2 4] + | i <- [1 .. n] + , v <- [2, 3] + ] + ++ [exAv (pkgName $ n + 1) 1 []] pkgName :: Int -> ExamplePkgName pkgName x = "pkg-" ++ show x @@ -45,23 +48,25 @@ basicTest name = -- all of the flags. It has to explore the whole search tree. flagsTest :: String -> SolverTest flagsTest name = - disableBackjumping $ + disableBackjumping $ disableFineGrainedConflicts $ - goalOrder orderedFlags $ mkTest pkgs name ["pkg"] anySolverFailure + goalOrder orderedFlags $ + mkTest pkgs name ["pkg"] anySolverFailure where n :: Int n = 16 pkgs :: ExampleDb - pkgs = [Right $ exAv "pkg" 1 $ - [exFlagged (numberedFlag n) [ExAny "unknown1"] [ExAny "unknown2"]] - - -- The remaining flags have no effect: - ++ [exFlagged (numberedFlag i) [] [] | i <- [1..n - 1]] - ] + pkgs = + [ Right $ + exAv "pkg" 1 $ + [exFlagged (numberedFlag n) [ExAny "unknown1"] [ExAny "unknown2"]] + -- The remaining flags have no effect: + ++ [exFlagged (numberedFlag i) [] [] | i <- [1 .. n - 1]] + ] orderedFlags :: [ExampleVar] - orderedFlags = [F QualNone "pkg" (numberedFlag i) | i <- [1..n]] + orderedFlags = [F QualNone "pkg" (numberedFlag i) | i <- [1 .. n]] -- | Test for a space leak caused by sharing of search trees under packages with -- link choices (issue #2899). @@ -80,19 +85,24 @@ flagsTest name = -- trees are shared, memory usage spikes. issue2899 :: String -> SolverTest issue2899 name = - disableBackjumping $ + disableBackjumping $ disableFineGrainedConflicts $ - goalOrder goals $ mkTest pkgs name ["target"] anySolverFailure + goalOrder goals $ + mkTest pkgs name ["target"] anySolverFailure where n :: Int n = 16 pkgs :: ExampleDb - pkgs = map Right $ - [ exAv "target" 1 [ExAny "setup-dep"] `withSetupDeps` [ExAny "setup-dep"] - , exAv "setup-dep" 1 [ExAny $ pkgName 1]] - ++ [ exAv (pkgName i) v [ExAny $ pkgName (i + 1)] - | i <- [1..n], v <- [1, 2]] + pkgs = + map Right $ + [ exAv "target" 1 [ExAny "setup-dep"] `withSetupDeps` [ExAny "setup-dep"] + , exAv "setup-dep" 1 [ExAny $ pkgName 1] + ] + ++ [ exAv (pkgName i) v [ExAny $ pkgName (i + 1)] + | i <- [1 .. n] + , v <- [1, 2] + ] pkgName :: Int -> ExamplePkgName pkgName x = "pkg-" ++ show x @@ -141,26 +151,31 @@ issue2899 name = -- build-tool dependencies. duplicateDependencies :: String -> SolverTest duplicateDependencies name = - mkTest pkgs name ["A"] $ solverSuccess [("A", 1), ("B", 1)] + mkTest pkgs name ["A"] $ solverSuccess [("A", 1), ("B", 1)] where copies, depth :: Int copies = 50 depth = 50 pkgs :: ExampleDb - pkgs = [ - Right $ exAv "A" 1 (dependencyTree 1) + pkgs = + [ Right $ exAv "A" 1 (dependencyTree 1) , Right $ exAv "B" 1 [] `withExe` exExe "exe" [] ] dependencyTree :: Int -> [ExampleDependency] dependencyTree n - | n > depth = buildDepends - | otherwise = [exFlagged (numberedFlag n) buildDepends - (dependencyTree (n + 1))] + | n > depth = buildDepends + | otherwise = + [ exFlagged + (numberedFlag n) + buildDepends + (dependencyTree (n + 1)) + ] where - buildDepends = replicate copies (ExFix "B" 1) - ++ replicate copies (ExBuildToolFix "B" "exe" 1) + buildDepends = + replicate copies (ExFix "B" 1) + ++ replicate copies (ExBuildToolFix "B" "exe" 1) -- | This test is similar to duplicateDependencies, except that every dependency -- on B is replaced by a conditional that contains B in both branches. It tests @@ -169,27 +184,34 @@ duplicateDependencies name = -- are lifted out of conditionals. duplicateFlaggedDependencies :: String -> SolverTest duplicateFlaggedDependencies name = - mkTest pkgs name ["A"] $ solverSuccess [("A", 1), ("B", 1)] + mkTest pkgs name ["A"] $ solverSuccess [("A", 1), ("B", 1)] where copies, depth :: Int copies = 15 depth = 15 pkgs :: ExampleDb - pkgs = [ - Right $ exAv "A" 1 (dependencyTree 1) + pkgs = + [ Right $ exAv "A" 1 (dependencyTree 1) , Right $ exAv "B" 1 [] `withExe` exExe "exe" [] ] dependencyTree :: Int -> [ExampleDependency] dependencyTree n - | n > depth = flaggedDeps - | otherwise = [exFlagged (numberedFlag n) flaggedDeps - (dependencyTree (n + 1))] + | n > depth = flaggedDeps + | otherwise = + [ exFlagged + (numberedFlag n) + flaggedDeps + (dependencyTree (n + 1)) + ] where flaggedDeps = zipWith ($) (replicate copies flaggedDep) [0 :: Int ..] - flaggedDep m = exFlagged (numberedFlag n ++ "-" ++ show m) buildDepends - buildDepends + flaggedDep m = + exFlagged + (numberedFlag n ++ "-" ++ show m) + buildDepends + buildDepends buildDepends = [ExFix "B" 1, ExBuildToolFix "B" "exe" 1] numberedFlag :: Int -> ExampleFlagName diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs index 7ac722f2e38..114db775f21 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs @@ -5,114 +5,143 @@ module UnitTests.Distribution.Solver.Modular.QuickCheck (tests) where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () import Control.Arrow ((&&&)) import Data.Either (lefts) -import Data.Hashable (Hashable(..)) +import Data.Hashable (Hashable (..)) import Data.List (groupBy, isInfixOf) import Text.Show.Pretty (parseValue, valToStr) -import Test.Tasty (TestTree) -import Test.QuickCheck (Arbitrary (..), Gen, Positive (..), frequency, oneof, shrinkList, shuffle, listOf, shrinkNothing, vectorOf, elements, sublistOf, counterexample, (===), (==>), Blind (..)) +import Test.QuickCheck (Arbitrary (..), Blind (..), Gen, Positive (..), counterexample, elements, frequency, listOf, oneof, shrinkList, shrinkNothing, shuffle, sublistOf, vectorOf, (===), (==>)) import Test.QuickCheck.Instances.Cabal () +import Test.Tasty (TestTree) import Distribution.Types.Flag (FlagName) import Distribution.Utils.ShortText (ShortText) import Distribution.Client.Setup (defaultMaxBackjumps) -import Distribution.Types.LibraryVisibility -import Distribution.Types.PackageName -import Distribution.Types.UnqualComponentName +import Distribution.Types.LibraryVisibility +import Distribution.Types.PackageName +import Distribution.Types.UnqualComponentName +import Distribution.Solver.Types.ComponentDeps + ( Component (..) + , ComponentDep + , ComponentDeps + ) import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.ComponentDeps - ( Component(..), ComponentDep, ComponentDeps ) -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageConstraint import qualified Distribution.Solver.Types.PackagePath as P -import Distribution.Solver.Types.PkgConfigDb - (pkgConfigDbFromList) -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.Variable -import Distribution.Verbosity -import Distribution.Version +import Distribution.Solver.Types.PkgConfigDb + ( pkgConfigDbFromList + ) +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.Variable +import Distribution.Verbosity +import Distribution.Version import UnitTests.Distribution.Solver.Modular.DSL import UnitTests.Distribution.Solver.Modular.QuickCheck.Utils - ( testPropertyWithSeed ) + ( testPropertyWithSeed + ) tests :: [TestTree] -tests = [ - -- 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. - testPropertyWithSeed "target and goal order do not affect solvability" $ - \test targetOrder mGoalOrder1 mGoalOrder2 indepGoals -> - let r1 = solve' mGoalOrder1 test - r2 = solve' mGoalOrder2 test { testTargets = targets2 } - solve' goalOrder = - solve (EnableBackjumping True) (FineGrainedConflicts True) - (ReorderGoals False) (CountConflicts True) indepGoals (PreferOldest False) - (getBlind <$> goalOrder) - targets = testTargets test - targets2 = case targetOrder of - SameOrder -> targets - ReverseOrder -> reverse targets - in counterexample (showResults r1 r2) $ - noneReachedBackjumpLimit [r1, r2] ==> - isRight (resultPlan r1) === isRight (resultPlan r2) - - , testPropertyWithSeed - "solvable without --independent-goals => solvable with --independent-goals" $ - \test reorderGoals -> - let r1 = solve' (IndependentGoals False) test - r2 = solve' (IndependentGoals True) test - solve' indep = - solve (EnableBackjumping True) (FineGrainedConflicts True) - reorderGoals (CountConflicts True) indep (PreferOldest False)Nothing - in counterexample (showResults r1 r2) $ - noneReachedBackjumpLimit [r1, r2] ==> +tests = + [ -- 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. + testPropertyWithSeed "target and goal order do not affect solvability" $ + \test targetOrder mGoalOrder1 mGoalOrder2 indepGoals -> + let r1 = solve' mGoalOrder1 test + r2 = solve' mGoalOrder2 test{testTargets = targets2} + solve' goalOrder = + solve + (EnableBackjumping True) + (FineGrainedConflicts True) + (ReorderGoals False) + (CountConflicts True) + indepGoals + (PreferOldest False) + (getBlind <$> goalOrder) + targets = testTargets test + targets2 = case targetOrder of + SameOrder -> targets + ReverseOrder -> reverse targets + in counterexample (showResults r1 r2) $ + noneReachedBackjumpLimit [r1, r2] ==> + isRight (resultPlan r1) === isRight (resultPlan r2) + , testPropertyWithSeed + "solvable without --independent-goals => solvable with --independent-goals" + $ \test reorderGoals -> + let r1 = solve' (IndependentGoals False) test + r2 = solve' (IndependentGoals True) test + solve' indep = + solve + (EnableBackjumping True) + (FineGrainedConflicts True) + reorderGoals + (CountConflicts True) + indep + (PreferOldest False) + Nothing + in counterexample (showResults r1 r2) $ + noneReachedBackjumpLimit [r1, r2] ==> isRight (resultPlan r1) `implies` isRight (resultPlan r2) - - , testPropertyWithSeed "backjumping does not affect solvability" $ - \test reorderGoals indepGoals -> - let r1 = solve' (EnableBackjumping True) test - r2 = solve' (EnableBackjumping False) test - solve' enableBj = - solve enableBj (FineGrainedConflicts False) reorderGoals - (CountConflicts True) indepGoals (PreferOldest False) Nothing - in counterexample (showResults r1 r2) $ - noneReachedBackjumpLimit [r1, r2] ==> + , testPropertyWithSeed "backjumping does not affect solvability" $ + \test reorderGoals indepGoals -> + let r1 = solve' (EnableBackjumping True) test + r2 = solve' (EnableBackjumping False) test + solve' enableBj = + solve + enableBj + (FineGrainedConflicts False) + reorderGoals + (CountConflicts True) + indepGoals + (PreferOldest False) + Nothing + in counterexample (showResults r1 r2) $ + noneReachedBackjumpLimit [r1, r2] ==> isRight (resultPlan r1) === isRight (resultPlan r2) - - , testPropertyWithSeed "fine-grained conflicts does not affect solvability" $ - \test reorderGoals indepGoals -> - let r1 = solve' (FineGrainedConflicts True) test - r2 = solve' (FineGrainedConflicts False) test - solve' fineGrainedConflicts = - solve (EnableBackjumping True) fineGrainedConflicts - reorderGoals (CountConflicts True) indepGoals (PreferOldest False) Nothing - in counterexample (showResults r1 r2) $ - noneReachedBackjumpLimit [r1, r2] ==> + , testPropertyWithSeed "fine-grained conflicts does not affect solvability" $ + \test reorderGoals indepGoals -> + let r1 = solve' (FineGrainedConflicts True) test + r2 = solve' (FineGrainedConflicts False) test + solve' fineGrainedConflicts = + solve + (EnableBackjumping True) + fineGrainedConflicts + reorderGoals + (CountConflicts True) + indepGoals + (PreferOldest False) + Nothing + in counterexample (showResults r1 r2) $ + noneReachedBackjumpLimit [r1, r2] ==> isRight (resultPlan r1) === isRight (resultPlan r2) - - , testPropertyWithSeed "prefer oldest does not affect solvability" $ - \test reorderGoals indepGoals -> - let r1 = solve' (PreferOldest True) test - r2 = solve' (PreferOldest False) test - solve' prefOldest = - solve (EnableBackjumping True) (FineGrainedConflicts True) - reorderGoals (CountConflicts True) indepGoals prefOldest Nothing - in counterexample (showResults r1 r2) $ - noneReachedBackjumpLimit [r1, r2] ==> + , testPropertyWithSeed "prefer oldest does not affect solvability" $ + \test reorderGoals indepGoals -> + let r1 = solve' (PreferOldest True) test + r2 = solve' (PreferOldest False) test + solve' prefOldest = + solve + (EnableBackjumping True) + (FineGrainedConflicts True) + reorderGoals + (CountConflicts True) + indepGoals + prefOldest + Nothing + in counterexample (showResults r1 r2) $ + noneReachedBackjumpLimit [r1, r2] ==> isRight (resultPlan r1) === isRight (resultPlan r2) - - -- The next two tests use --no-count-conflicts, because the goal order used + , -- The next two tests use --no-count-conflicts, because the goal order used -- with --count-conflicts depends on the total set of conflicts seen by the -- solver. The solver explores more of the tree and encounters more -- conflicts when it doesn't backjump. The different goal orders can lead to @@ -120,94 +149,120 @@ tests = [ -- TODO: Find a faster way to randomly sort goals, and then use a random -- goal order in these tests. - , testPropertyWithSeed - "backjumping does not affect the result (with static goal order)" $ - \test reorderGoals indepGoals -> - let r1 = solve' (EnableBackjumping True) test - r2 = solve' (EnableBackjumping False) test - solve' enableBj = - solve enableBj (FineGrainedConflicts False) reorderGoals - (CountConflicts False) indepGoals (PreferOldest False) Nothing - in counterexample (showResults r1 r2) $ - noneReachedBackjumpLimit [r1, r2] ==> + testPropertyWithSeed + "backjumping does not affect the result (with static goal order)" + $ \test reorderGoals indepGoals -> + let r1 = solve' (EnableBackjumping True) test + r2 = solve' (EnableBackjumping False) test + solve' enableBj = + solve + enableBj + (FineGrainedConflicts False) + reorderGoals + (CountConflicts False) + indepGoals + (PreferOldest False) + Nothing + in counterexample (showResults r1 r2) $ + noneReachedBackjumpLimit [r1, r2] ==> resultPlan r1 === resultPlan r2 - - , testPropertyWithSeed - "fine-grained conflicts does not affect the result (with static goal order)" $ - \test reorderGoals indepGoals -> - let r1 = solve' (FineGrainedConflicts True) test - r2 = solve' (FineGrainedConflicts False) test - solve' fineGrainedConflicts = - solve (EnableBackjumping True) fineGrainedConflicts - reorderGoals (CountConflicts False) indepGoals (PreferOldest False) Nothing - in counterexample (showResults r1 r2) $ - noneReachedBackjumpLimit [r1, r2] ==> + , testPropertyWithSeed + "fine-grained conflicts does not affect the result (with static goal order)" + $ \test reorderGoals indepGoals -> + let r1 = solve' (FineGrainedConflicts True) test + r2 = solve' (FineGrainedConflicts False) test + solve' fineGrainedConflicts = + solve + (EnableBackjumping True) + fineGrainedConflicts + reorderGoals + (CountConflicts False) + indepGoals + (PreferOldest False) + Nothing + in counterexample (showResults r1 r2) $ + noneReachedBackjumpLimit [r1, r2] ==> resultPlan r1 === resultPlan r2 - ] + ] where noneReachedBackjumpLimit :: [Result] -> Bool noneReachedBackjumpLimit = - not . any (\r -> resultPlan r == Left BackjumpLimitReached) + not . any (\r -> resultPlan r == Left BackjumpLimitReached) showResults :: Result -> Result -> String showResults r1 r2 = showResult 1 r1 ++ showResult 2 r2 showResult :: Int -> Result -> String showResult n result = - unlines $ ["", "Run " ++ show n ++ ":"] - ++ resultLog result - ++ ["result: " ++ show (resultPlan result)] + unlines $ + ["", "Run " ++ show n ++ ":"] + ++ resultLog result + ++ ["result: " ++ show (resultPlan result)] implies :: Bool -> Bool -> Bool implies x y = not x || y isRight :: Either a b -> Bool isRight (Right _) = True - isRight _ = False - -newtype VarOrdering = VarOrdering { - unVarOrdering :: Variable P.QPN -> Variable P.QPN -> Ordering - } - -solve :: EnableBackjumping - -> FineGrainedConflicts - -> ReorderGoals - -> CountConflicts - -> IndependentGoals - -> PreferOldest - -> Maybe VarOrdering - -> SolverTest - -> Result + isRight _ = False + +newtype VarOrdering = VarOrdering + { unVarOrdering :: Variable P.QPN -> Variable P.QPN -> Ordering + } + +solve + :: EnableBackjumping + -> FineGrainedConflicts + -> ReorderGoals + -> CountConflicts + -> IndependentGoals + -> PreferOldest + -> Maybe VarOrdering + -> SolverTest + -> Result solve enableBj fineGrainedConflicts reorder countConflicts indep prefOldest goalOrder test = let (lg, result) = - runProgress $ exResolve (unTestDb (testDb test)) Nothing Nothing - (pkgConfigDbFromList []) - (map unPN (testTargets test)) - -- The backjump limit prevents individual tests from using - -- too much time and memory. - (Just defaultMaxBackjumps) - countConflicts fineGrainedConflicts - (MinimizeConflictSet False) indep prefOldest reorder - (AllowBootLibInstalls False) OnlyConstrainedNone enableBj - (SolveExecutables True) (unVarOrdering <$> goalOrder) - (testConstraints test) (testPreferences test) normal - (EnableAllTests False) + runProgress $ + exResolve + (unTestDb (testDb test)) + Nothing + Nothing + (pkgConfigDbFromList []) + (map unPN (testTargets test)) + -- The backjump limit prevents individual tests from using + -- too much time and memory. + (Just defaultMaxBackjumps) + countConflicts + fineGrainedConflicts + (MinimizeConflictSet False) + indep + prefOldest + reorder + (AllowBootLibInstalls False) + OnlyConstrainedNone + enableBj + (SolveExecutables True) + (unVarOrdering <$> goalOrder) + (testConstraints test) + (testPreferences test) + normal + (EnableAllTests False) failure :: String -> Failure failure msg | "Backjump limit reached" `isInfixOf` msg = BackjumpLimitReached - | otherwise = OtherFailure - in Result { - resultLog = lg - , resultPlan = - -- Force the result so that we check for internal errors when we check - -- for success or failure. See D.C.Dependency.validateSolverResult. - force $ either (Left . failure) (Right . extractInstallPlan) result - } + | otherwise = OtherFailure + in Result + { resultLog = lg + , resultPlan = + -- Force the result so that we check for internal errors when we check + -- for success or failure. See D.C.Dependency.validateSolverResult. + force $ either (Left . failure) (Right . extractInstallPlan) result + } -- | How to modify the order of the input targets. data TargetOrder = SameOrder | ReverseOrder - deriving Show + deriving (Show) instance Arbitrary TargetOrder where arbitrary = elements [SameOrder, ReverseOrder] @@ -215,8 +270,8 @@ instance Arbitrary TargetOrder where shrink SameOrder = [] shrink ReverseOrder = [SameOrder] -data Result = Result { - resultLog :: [String] +data Result = Result + { resultLog :: [String] , resultPlan :: Either Failure [(ExamplePkgName, ExamplePkgVersion)] } @@ -226,18 +281,18 @@ data Failure = BackjumpLimitReached | OtherFailure instance NFData Failure -- | Package name. -newtype PN = PN { unPN :: String } +newtype PN = PN {unPN :: String} deriving (Eq, Ord, Show) instance Arbitrary PN where - arbitrary = PN <$> elements ("base" : [[pn] | pn <- ['A'..'G']]) + arbitrary = PN <$> elements ("base" : [[pn] | pn <- ['A' .. 'G']]) -- | Package version. -newtype PV = PV { unPV :: Int } +newtype PV = PV {unPV :: Int} deriving (Eq, Ord, Show) instance Arbitrary PV where - arbitrary = PV <$> elements [1..10] + arbitrary = PV <$> elements [1 .. 10] type TestPackage = Either ExampleInstalled ExampleAvailable @@ -247,8 +302,8 @@ getName = PN . either exInstName exAvName getVersion :: TestPackage -> PV getVersion = PV . either exInstVersion exAvVersion -data SolverTest = SolverTest { - testDb :: TestDb +data SolverTest = SolverTest + { testDb :: TestDb , testTargets :: [PN] , testConstraints :: [ExConstraint] , testPreferences :: [ExPreference] @@ -257,12 +312,17 @@ data SolverTest = SolverTest { -- | Pretty-print the test when quickcheck calls 'show'. instance Show SolverTest where show test = - let str = "SolverTest {testDb = " ++ show (testDb test) - ++ ", testTargets = " ++ show (testTargets test) - ++ ", testConstraints = " ++ show (testConstraints test) - ++ ", testPreferences = " ++ show (testPreferences test) - ++ "}" - in maybe str valToStr $ parseValue str + let str = + "SolverTest {testDb = " + ++ show (testDb test) + ++ ", testTargets = " + ++ show (testTargets test) + ++ ", testConstraints = " + ++ show (testConstraints test) + ++ ", testPreferences = " + ++ show (testPreferences test) + ++ "}" + in maybe str valToStr $ parseValue str instance Arbitrary SolverTest where arbitrary = do @@ -272,31 +332,32 @@ instance Arbitrary SolverTest where Positive n <- arbitrary targets <- randomSubset n pkgs constraints <- case pkgVersions of - [] -> return [] - _ -> boundedListOf 1 $ arbitraryConstraint pkgVersions + [] -> return [] + _ -> boundedListOf 1 $ arbitraryConstraint pkgVersions prefs <- case pkgVersions of - [] -> return [] - _ -> boundedListOf 3 $ arbitraryPreference pkgVersions + [] -> return [] + _ -> boundedListOf 3 $ arbitraryPreference pkgVersions return (SolverTest db targets constraints prefs) shrink test = - [test { testDb = db } | db <- shrink (testDb test)] - ++ [test { testTargets = targets } | targets <- shrink (testTargets test)] - ++ [test { testConstraints = cs } | cs <- shrink (testConstraints test)] - ++ [test { testPreferences = prefs } | prefs <- shrink (testPreferences test)] + [test{testDb = db} | db <- shrink (testDb test)] + ++ [test{testTargets = targets} | targets <- shrink (testTargets test)] + ++ [test{testConstraints = cs} | cs <- shrink (testConstraints test)] + ++ [test{testPreferences = prefs} | prefs <- shrink (testPreferences test)] -- | Collection of source and installed packages. -newtype TestDb = TestDb { unTestDb :: ExampleDb } - deriving Show +newtype TestDb = TestDb {unTestDb :: ExampleDb} + deriving (Show) instance Arbitrary TestDb where arbitrary = do - -- Avoid cyclic dependencies by grouping packages by name and only - -- allowing each package to depend on packages in the groups before it. - groupedPkgs <- shuffle . groupBy ((==) `on` fst) . nub . sort =<< - boundedListOf 10 arbitrary - db <- foldM nextPkgs (TestDb []) groupedPkgs - TestDb <$> shuffle (unTestDb db) + -- Avoid cyclic dependencies by grouping packages by name and only + -- allowing each package to depend on packages in the groups before it. + groupedPkgs <- + shuffle . groupBy ((==) `on` fst) . nub . sort + =<< boundedListOf 10 arbitrary + db <- foldM nextPkgs (TestDb []) groupedPkgs + TestDb <$> shuffle (unTestDb db) where nextPkgs :: TestDb -> [(PN, PV)] -> Gen TestDb nextPkgs db pkgs = TestDb . (++ unTestDb db) <$> traverse (nextPkg db) pkgs @@ -305,140 +366,145 @@ instance Arbitrary TestDb where nextPkg db (pn, v) = do installed <- arbitrary if installed - then Left <$> arbitraryExInst pn v (lefts $ unTestDb db) - else Right <$> arbitraryExAv pn v db + then Left <$> arbitraryExInst pn v (lefts $ unTestDb db) + else Right <$> arbitraryExAv pn v db shrink (TestDb pkgs) = map TestDb $ shrink pkgs arbitraryExAv :: PN -> PV -> TestDb -> Gen ExampleAvailable arbitraryExAv pn v db = - (\cds -> ExAv (unPN pn) (unPV v) cds []) <$> arbitraryComponentDeps pn db + (\cds -> ExAv (unPN pn) (unPV v) cds []) <$> arbitraryComponentDeps pn db arbitraryExInst :: PN -> PV -> [ExampleInstalled] -> Gen ExampleInstalled arbitraryExInst pn v pkgs = do - pkgHash <- vectorOf 10 $ elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] + pkgHash <- vectorOf 10 $ elements $ ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] numDeps <- min 3 <$> arbitrary deps <- randomSubset numDeps pkgs return $ ExInst (unPN pn) (unPV v) pkgHash (map exInstHash deps) arbitraryComponentDeps :: PN -> TestDb -> Gen (ComponentDeps Dependencies) -arbitraryComponentDeps _ (TestDb []) = return $ CD.fromLibraryDeps (dependencies []) -arbitraryComponentDeps pn db = do +arbitraryComponentDeps _ (TestDb []) = return $ CD.fromLibraryDeps (dependencies []) +arbitraryComponentDeps pn db = do -- dedupComponentNames removes components with duplicate names, for example, -- 'ComponentExe x' and 'ComponentTest x', and then CD.fromList combines -- duplicate unnamed components. - cds <- CD.fromList . dedupComponentNames . filter (isValid . fst) - <$> boundedListOf 5 (arbitraryComponentDep db) - return $ if isCompleteComponentDeps cds - then cds - else -- Add a library if the ComponentDeps isn't complete. - CD.fromLibraryDeps (dependencies []) <> cds + cds <- + CD.fromList . dedupComponentNames . filter (isValid . fst) + <$> boundedListOf 5 (arbitraryComponentDep db) + return $ + if isCompleteComponentDeps cds + then cds + else -- Add a library if the ComponentDeps isn't complete. + CD.fromLibraryDeps (dependencies []) <> cds where isValid :: Component -> Bool isValid (ComponentSubLib name) = name /= mkUnqualComponentName (unPN pn) - isValid _ = True + isValid _ = True dedupComponentNames = - nubBy ((\x y -> isJust x && isJust y && x == y) `on` componentName . fst) + nubBy ((\x y -> isJust x && isJust y && x == y) `on` componentName . fst) componentName :: Component -> Maybe UnqualComponentName - componentName ComponentLib = Nothing - componentName ComponentSetup = Nothing + componentName ComponentLib = Nothing + componentName ComponentSetup = Nothing componentName (ComponentSubLib n) = Just n - componentName (ComponentFLib n) = Just n - componentName (ComponentExe n) = Just n - componentName (ComponentTest n) = Just n - componentName (ComponentBench n) = Just n + componentName (ComponentFLib n) = Just n + componentName (ComponentExe n) = Just n + componentName (ComponentTest n) = Just n + componentName (ComponentBench n) = Just n -- | Returns true if the ComponentDeps forms a complete package, i.e., it -- contains a library, exe, test, or benchmark. isCompleteComponentDeps :: ComponentDeps a -> Bool isCompleteComponentDeps = any (completesPkg . fst) . CD.toList where - completesPkg ComponentLib = True - completesPkg (ComponentExe _) = True - completesPkg (ComponentTest _) = True - completesPkg (ComponentBench _) = True + completesPkg ComponentLib = True + completesPkg (ComponentExe _) = True + completesPkg (ComponentTest _) = True + completesPkg (ComponentBench _) = True completesPkg (ComponentSubLib _) = False - completesPkg (ComponentFLib _) = False - completesPkg ComponentSetup = False + completesPkg (ComponentFLib _) = False + completesPkg ComponentSetup = False arbitraryComponentDep :: TestDb -> Gen (ComponentDep Dependencies) arbitraryComponentDep db = do comp <- arbitrary deps <- case comp of - ComponentSetup -> smallListOf (arbitraryExDep db SetupDep) - _ -> boundedListOf 5 (arbitraryExDep db NonSetupDep) - return ( comp - , Dependencies { - depsExampleDependencies = deps - - -- TODO: Test different values for visibility and buildability. - , depsVisibility = LibraryVisibilityPublic - , depsIsBuildable = True - } ) + ComponentSetup -> smallListOf (arbitraryExDep db SetupDep) + _ -> boundedListOf 5 (arbitraryExDep db NonSetupDep) + return + ( comp + , Dependencies + { depsExampleDependencies = deps + , -- TODO: Test different values for visibility and buildability. + depsVisibility = LibraryVisibilityPublic + , depsIsBuildable = True + } + ) -- | Location of an 'ExampleDependency'. It determines which values are valid. data ExDepLocation = SetupDep | NonSetupDep arbitraryExDep :: TestDb -> ExDepLocation -> Gen ExampleDependency arbitraryExDep db@(TestDb pkgs) level = - let flag = ExFlagged <$> arbitraryFlagName - <*> arbitraryDeps db - <*> arbitraryDeps db + let flag = + ExFlagged + <$> arbitraryFlagName + <*> arbitraryDeps db + <*> arbitraryDeps db other = - -- Package checks require dependencies on "base" to have bounds. + -- Package checks require dependencies on "base" to have bounds. let notBase = filter ((/= PN "base") . getName) pkgs - in [ExAny . unPN <$> elements (map getName notBase) | not (null notBase)] - ++ [ - -- existing version - let fixed pkg = ExFix (unPN $ getName pkg) (unPV $ getVersion pkg) - in fixed <$> elements pkgs - - -- random version of an existing package - , ExFix . unPN . getName <$> elements pkgs <*> (unPV <$> arbitrary) - ] - in oneof $ - case level of - NonSetupDep -> flag : other - SetupDep -> other + in [ExAny . unPN <$> elements (map getName notBase) | not (null notBase)] + ++ [ + -- existing version + let fixed pkg = ExFix (unPN $ getName pkg) (unPV $ getVersion pkg) + in fixed <$> elements pkgs + , -- random version of an existing package + ExFix . unPN . getName <$> elements pkgs <*> (unPV <$> arbitrary) + ] + in oneof $ + case level of + NonSetupDep -> flag : other + SetupDep -> other arbitraryDeps :: TestDb -> Gen Dependencies -arbitraryDeps db = frequency +arbitraryDeps db = + frequency [ (1, return unbuildableDependencies) , (20, dependencies <$> smallListOf (arbitraryExDep db NonSetupDep)) ] arbitraryFlagName :: Gen String -arbitraryFlagName = (:[]) <$> elements ['A'..'E'] +arbitraryFlagName = (: []) <$> elements ['A' .. 'E'] arbitraryConstraint :: [(PN, PV)] -> Gen ExConstraint arbitraryConstraint pkgs = do (PN pn, v) <- elements pkgs let anyQualifier = ScopeAnyQualifier (mkPackageName pn) - oneof [ - ExVersionConstraint anyQualifier <$> arbitraryVersionRange v + oneof + [ ExVersionConstraint anyQualifier <$> arbitraryVersionRange v , ExStanzaConstraint anyQualifier <$> sublistOf [TestStanzas, BenchStanzas] ] arbitraryPreference :: [(PN, PV)] -> Gen ExPreference arbitraryPreference pkgs = do (PN pn, v) <- elements pkgs - oneof [ - ExStanzaPref pn <$> sublistOf [TestStanzas, BenchStanzas] + oneof + [ ExStanzaPref pn <$> sublistOf [TestStanzas, BenchStanzas] , ExPkgPref pn <$> arbitraryVersionRange v ] arbitraryVersionRange :: PV -> Gen VersionRange arbitraryVersionRange (PV v) = let version = mkSimpleVersion v - in elements [ - thisVersion version - , notThisVersion version - , earlierVersion version - , orLaterVersion version - , noVersion - ] + in elements + [ thisVersion version + , notThisVersion version + , earlierVersion version + , orLaterVersion version + , noVersion + ] instance Arbitrary ReorderGoals where arbitrary = ReorderGoals <$> arbitrary @@ -451,14 +517,16 @@ instance Arbitrary IndependentGoals where shrink (IndependentGoals indep) = [IndependentGoals False | indep] instance Arbitrary Component where - arbitrary = oneof [ return ComponentLib - , ComponentSubLib <$> arbitraryUQN - , ComponentExe <$> arbitraryUQN - , ComponentFLib <$> arbitraryUQN - , ComponentTest <$> arbitraryUQN - , ComponentBench <$> arbitraryUQN - , return ComponentSetup - ] + arbitrary = + oneof + [ return ComponentLib + , ComponentSubLib <$> arbitraryUQN + , ComponentExe <$> arbitraryUQN + , ComponentFLib <$> arbitraryUQN + , ComponentTest <$> arbitraryUQN + , ComponentBench <$> arbitraryUQN + , return ComponentSetup + ] shrink ComponentLib = [] shrink _ = [ComponentLib] @@ -469,18 +537,20 @@ instance Arbitrary Component where -- internal libraries. arbitraryUQN :: Gen UnqualComponentName arbitraryUQN = - mkUnqualComponentName <$> (\c -> "component-" ++ [c]) <$> elements "ABC" + mkUnqualComponentName <$> (\c -> "component-" ++ [c]) <$> elements "ABC" instance Arbitrary ExampleInstalled where arbitrary = error "arbitrary not implemented: ExampleInstalled" - shrink ei = [ ei { exInstBuildAgainst = deps } - | deps <- shrinkList shrinkNothing (exInstBuildAgainst ei)] + shrink ei = + [ ei{exInstBuildAgainst = deps} + | deps <- shrinkList shrinkNothing (exInstBuildAgainst ei) + ] instance Arbitrary ExampleAvailable where arbitrary = error "arbitrary not implemented: ExampleAvailable" - shrink ea = [ea { exAvDeps = deps } | deps <- shrink (exAvDeps ea)] + shrink ea = [ea{exAvDeps = deps} | deps <- shrink (exAvDeps ea)] instance (Arbitrary a, Monoid a) => Arbitrary (ComponentDeps a) where arbitrary = error "arbitrary not implemented: ComponentDeps" @@ -494,7 +564,8 @@ instance Arbitrary ExampleDependency where shrink (ExFix "base" _) = [] -- preserve bounds on base shrink (ExFix pn _) = [ExAny pn] shrink (ExFlagged flag th el) = - depsExampleDependencies th ++ depsExampleDependencies el + depsExampleDependencies th + ++ depsExampleDependencies el ++ [ExFlagged flag th' el | th' <- shrink th] ++ [ExFlagged flag th el' | el' <- shrink el] shrink dep = error $ "Dependency not handled: " ++ show dep @@ -503,38 +574,38 @@ instance Arbitrary Dependencies where arbitrary = error "arbitrary not implemented: Dependencies" shrink deps = - [ deps { depsVisibility = v } | v <- shrink $ depsVisibility deps ] - ++ [ deps { depsIsBuildable = b } | b <- shrink $ depsIsBuildable deps ] - ++ [ deps { depsExampleDependencies = ds } | ds <- shrink $ depsExampleDependencies deps ] + [deps{depsVisibility = v} | v <- shrink $ depsVisibility deps] + ++ [deps{depsIsBuildable = b} | b <- shrink $ depsIsBuildable deps] + ++ [deps{depsExampleDependencies = ds} | ds <- shrink $ depsExampleDependencies deps] instance Arbitrary ExConstraint where arbitrary = error "arbitrary not implemented: ExConstraint" shrink (ExStanzaConstraint scope stanzas) = - [ExStanzaConstraint scope stanzas' | stanzas' <- shrink stanzas] + [ExStanzaConstraint scope stanzas' | stanzas' <- shrink stanzas] shrink (ExVersionConstraint scope vr) = - [ExVersionConstraint scope vr' | vr' <- shrink vr] + [ExVersionConstraint scope vr' | vr' <- shrink vr] shrink _ = [] instance Arbitrary ExPreference where arbitrary = error "arbitrary not implemented: ExPreference" shrink (ExStanzaPref pn stanzas) = - [ExStanzaPref pn stanzas' | stanzas' <- shrink stanzas] + [ExStanzaPref pn stanzas' | stanzas' <- shrink stanzas] shrink (ExPkgPref pn vr) = [ExPkgPref pn vr' | vr' <- shrink vr] instance Arbitrary OptionalStanza where arbitrary = error "arbitrary not implemented: OptionalStanza" shrink BenchStanzas = [TestStanzas] - shrink 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)) + f <- arbitrary :: Gen (Int -> Int) + return $ VarOrdering (comparing (f . hash)) instance Hashable pn => Hashable (Variable pn) instance Hashable a => Hashable (P.Qualified a) @@ -561,5 +632,7 @@ boundedListOf n gen = take n <$> listOf gen -- | Generates lists with average length less than 1. smallListOf :: Gen a -> Gen [a] smallListOf gen = - frequency [ (fr, vectorOf n gen) - | (fr, n) <- [(3, 0), (5, 1), (2, 2)]] + frequency + [ (fr, vectorOf n gen) + | (fr, n) <- [(3, 0), (5, 1), (2, 2)] + ] diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs index facc64cedd3..72283639cd9 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs @@ -1,5 +1,5 @@ -module UnitTests.Distribution.Solver.Modular.QuickCheck.Utils ( - testPropertyWithSeed +module UnitTests.Distribution.Solver.Modular.QuickCheck.Utils + ( testPropertyWithSeed ) where import Data.Tagged (Tagged, retag) @@ -9,7 +9,11 @@ import Test.Tasty (TestTree) import Test.Tasty.Options (OptionDescription, lookupOption, setOption) import Test.Tasty.Providers (IsTest (..), singleTest) import Test.Tasty.QuickCheck - ( QC (..), QuickCheckReplay (..), Testable, property ) + ( QC (..) + , QuickCheckReplay (..) + , Testable + , property + ) import Distribution.Simple.Utils import Distribution.Verbosity @@ -27,7 +31,7 @@ instance IsTest QCWithSeed where run options (QCWithSeed test) progress = do replay <- case lookupOption options of - QuickCheckReplay (Just override) -> return override - QuickCheckReplay Nothing -> getStdRandom random + QuickCheckReplay (Just override) -> return override + QuickCheckReplay Nothing -> getStdRandom random notice normal $ "Using --quickcheck-replay=" ++ show replay run (setOption (QuickCheckReplay (Just replay)) options) test progress diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs index d64802c183a..8b0744a4aab 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs @@ -1,7 +1,8 @@ {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module UnitTests.Distribution.Solver.Modular.RetryLog ( - tests + +module UnitTests.Distribution.Solver.Modular.RetryLog + ( tests ) where import Distribution.Solver.Modular.Message @@ -11,53 +12,54 @@ import Distribution.Solver.Types.Progress import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase, (@?=)) import Test.Tasty.QuickCheck - ( Arbitrary(..), Blind(..), listOf, oneof, testProperty, (===)) + ( Arbitrary (..) + , Blind (..) + , listOf + , oneof + , testProperty + , (===) + ) type Log a = Progress a String String tests :: [TestTree] -tests = [ - testProperty "'toProgress . fromProgress' is identity" $ \p -> - toProgress (fromProgress p) === (p :: Log Int) - +tests = + [ testProperty "'toProgress . fromProgress' is identity" $ \p -> + toProgress (fromProgress p) === (p :: Log Int) , testProperty "'mapFailure f' is like 'foldProgress Step (Fail . f) Done'" $ - let mapFailureProgress f = foldProgress Step (Fail . f) Done - in \(Blind f) p -> - toProgress (mapFailure f (fromProgress p)) - === mapFailureProgress (f :: String -> Int) (p :: Log Int) - + let mapFailureProgress f = foldProgress Step (Fail . f) Done + in \(Blind f) p -> + toProgress (mapFailure f (fromProgress p)) + === mapFailureProgress (f :: String -> Int) (p :: Log Int) , testProperty "'retry p f' is like 'foldProgress Step f Done p'" $ \p (Blind f) -> toProgress (retry (fromProgress p) (fromProgress . f)) - === (foldProgress Step f Done (p :: Log Int) :: Log Int) - + === (foldProgress Step f Done (p :: Log Int) :: Log Int) , testProperty "failWith" $ \step failure -> - toProgress (failWith step failure) + toProgress (failWith step failure) === (Step step (Fail failure) :: Log Int) - , testProperty "succeedWith" $ \step success -> - toProgress (succeedWith step success) + toProgress (succeedWith step success) === (Step step (Done success) :: Log Int) - , testProperty "continueWith" $ \step p -> - toProgress (continueWith step (fromProgress p)) + toProgress (continueWith step (fromProgress p)) === (Step step p :: Log Int) - , testCase "tryWith with failure" $ - let failure = Fail "Error" - s = Step Success - in toProgress (tryWith Success $ fromProgress (s (s failure))) - @?= (s (Step Enter (s (s (Step Leave failure)))) :: Log Message) - + let failure = Fail "Error" + s = Step Success + in toProgress (tryWith Success $ fromProgress (s (s failure))) + @?= (s (Step Enter (s (s (Step Leave failure)))) :: Log Message) , testCase "tryWith with success" $ - let done = Done "Done" - s = Step Success - in toProgress (tryWith Success $ fromProgress (s (s done))) - @?= (s (Step Enter (s (s done))) :: Log Message) + let done = Done "Done" + s = Step Success + in toProgress (tryWith Success $ fromProgress (s (s done))) + @?= (s (Step Enter (s (s done))) :: Log Message) ] -instance (Arbitrary step, Arbitrary fail, Arbitrary done) - => Arbitrary (Progress step fail done) where +instance + (Arbitrary step, Arbitrary fail, Arbitrary done) + => Arbitrary (Progress step fail done) + where arbitrary = do steps <- listOf arbitrary end <- oneof [Fail `fmap` arbitrary, Done `fmap` arbitrary] @@ -65,8 +67,9 @@ instance (Arbitrary step, Arbitrary fail, Arbitrary done) deriving instance (Eq step, Eq fail, Eq done) => Eq (Progress step fail done) -deriving instance (Show step, Show fail, Show done) - => Show (Progress step fail done) +deriving instance + (Show step, Show fail, Show done) + => Show (Progress step fail done) deriving instance Eq Message deriving instance Show Message diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs index 1101e05aff9..dedb20bc70c 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs @@ -1,9 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} + -- | This is a set of unit tests for the dependency solver, -- which uses the solver DSL ("UnitTests.Distribution.Solver.Modular.DSL") -- to more conveniently create package databases to run the solver tests on. module UnitTests.Distribution.Solver.Modular.Solver (tests) - where +where -- base import Data.List (isInfixOf) @@ -14,8 +15,11 @@ import qualified Distribution.Version as V import Test.Tasty as TF -- Cabal -import Language.Haskell.Extension ( Extension(..) - , KnownExtension(..), Language(..)) +import Language.Haskell.Extension + ( Extension (..) + , KnownExtension (..) + , Language (..) + ) -- cabal-install import Distribution.Solver.Types.Flag @@ -26,773 +30,901 @@ import UnitTests.Distribution.Solver.Modular.DSL import UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils tests :: [TF.TestTree] -tests = [ - testGroup "Simple dependencies" [ - runTest $ mkTest db1 "alreadyInstalled" ["A"] (solverSuccess []) - , runTest $ mkTest db1 "installLatest" ["B"] (solverSuccess [("B", 2)]) - , runTest $ preferOldest - $ mkTest db1 "installOldest" ["B"] (solverSuccess [("B", 1)]) - , runTest $ mkTest db1 "simpleDep1" ["C"] (solverSuccess [("B", 1), ("C", 1)]) - , runTest $ mkTest db1 "simpleDep2" ["D"] (solverSuccess [("B", 2), ("D", 1)]) - , runTest $ mkTest db1 "failTwoVersions" ["C", "D"] anySolverFailure - , runTest $ indep $ mkTest db1 "indepTwoVersions" ["C", "D"] (solverSuccess [("B", 1), ("B", 2), ("C", 1), ("D", 1)]) - , runTest $ indep $ mkTest db1 "aliasWhenPossible1" ["C", "E"] (solverSuccess [("B", 1), ("C", 1), ("E", 1)]) - , runTest $ indep $ mkTest db1 "aliasWhenPossible2" ["D", "E"] (solverSuccess [("B", 2), ("D", 1), ("E", 1)]) - , runTest $ indep $ mkTest db2 "aliasWhenPossible3" ["C", "D"] (solverSuccess [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("C", 1), ("D", 1)]) - , runTest $ mkTest db1 "buildDepAgainstOld" ["F"] (solverSuccess [("B", 1), ("E", 1), ("F", 1)]) - , runTest $ mkTest db1 "buildDepAgainstNew" ["G"] (solverSuccess [("B", 2), ("E", 1), ("G", 1)]) - , runTest $ indep $ mkTest db1 "multipleInstances" ["F", "G"] anySolverFailure - , runTest $ mkTest db21 "unknownPackage1" ["A"] (solverSuccess [("A", 1), ("B", 1)]) - , runTest $ mkTest db22 "unknownPackage2" ["A"] (solverFailure (isInfixOf "unknown package: C")) - , runTest $ mkTest db23 "unknownPackage3" ["A"] (solverFailure (isInfixOf "unknown package: B")) - , runTest $ mkTest [] "unknown target" ["A"] (solverFailure (isInfixOf "unknown package: A")) - ] - , testGroup "Flagged dependencies" [ - runTest $ mkTest db3 "forceFlagOn" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) - , runTest $ mkTest db3 "forceFlagOff" ["D"] (solverSuccess [("A", 2), ("B", 1), ("D", 1)]) - , runTest $ indep $ mkTest db3 "linkFlags1" ["C", "D"] anySolverFailure - , runTest $ indep $ mkTest db4 "linkFlags2" ["C", "D"] anySolverFailure - , runTest $ indep $ mkTest db18 "linkFlags3" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("F", 1)]) - ] - , testGroup "Lifting dependencies out of conditionals" [ - runTest $ commonDependencyLogMessage "common dependency log message" - , runTest $ twoLevelDeepCommonDependencyLogMessage "two level deep common dependency log message" - , runTest $ testBackjumpingWithCommonDependency "backjumping with common dependency" - ] - , testGroup "Manual flags" [ - runTest $ mkTest dbManualFlags "Use default value for manual flag" ["pkg"] $ - solverSuccess [("pkg", 1), ("true-dep", 1)] - - , let checkFullLog = - any $ isInfixOf "rejecting: pkg:-flag (manual flag can only be changed explicitly)" - in runTest $ setVerbose $ - constraints [ExVersionConstraint (ScopeAnyQualifier "true-dep") V.noVersion] $ - mkTest dbManualFlags "Don't toggle manual flag to avoid conflict" ["pkg"] $ - -- TODO: We should check the summarized log instead of the full log - -- for the manual flags error message, but it currently only - -- appears in the full log. - SolverResult checkFullLog (Left $ const True) - - , let cs = [ExFlagConstraint (ScopeAnyQualifier "pkg") "flag" False] - in runTest $ constraints cs $ - mkTest dbManualFlags "Toggle manual flag with flag constraint" ["pkg"] $ - solverSuccess [("false-dep", 1), ("pkg", 1)] - ] - , testGroup "Qualified manual flag constraints" [ - let name = "Top-level flag constraint does not constrain setup dep's flag" - cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False] - in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $ - solverSuccess [ ("A", 1), ("B", 1), ("B", 2) - , ("b-1-false-dep", 1), ("b-2-true-dep", 1) ] - - , let name = "Solver can toggle setup dep's flag to match top-level constraint" - cs = [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False - , ExVersionConstraint (ScopeAnyQualifier "b-2-true-dep") V.noVersion ] - in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $ - solverSuccess [ ("A", 1), ("B", 1), ("B", 2) - , ("b-1-false-dep", 1), ("b-2-false-dep", 1) ] - - , let name = "User can constrain flags separately with qualified constraints" - cs = [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" True - , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False ] - in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $ - solverSuccess [ ("A", 1), ("B", 1), ("B", 2) - , ("b-1-true-dep", 1), ("b-2-false-dep", 1) ] - - -- Regression test for #4299 - , let name = "Solver can link deps when only one has constrained manual flag" - cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False] - in runTest $ constraints cs $ mkTest dbLinkedSetupDepWithManualFlag name ["A"] $ - solverSuccess [ ("A", 1), ("B", 1), ("b-1-false-dep", 1) ] - - , let name = "Solver cannot link deps that have conflicting manual flag constraints" - cs = [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" True - , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False ] - failureReason = "(constraint from unknown source requires opposite flag selection)" - checkFullLog lns = - all (\msg -> any (msg `isInfixOf`) lns) - [ "rejecting: B:-flag " ++ failureReason - , "rejecting: A:setup.B:+flag " ++ failureReason ] - in runTest $ constraints cs $ setVerbose $ - mkTest dbLinkedSetupDepWithManualFlag name ["A"] $ - SolverResult checkFullLog (Left $ const True) - ] - , testGroup "Stanzas" [ - runTest $ enableAllTests $ mkTest db5 "simpleTest1" ["C"] (solverSuccess [("A", 2), ("C", 1)]) - , runTest $ enableAllTests $ mkTest db5 "simpleTest2" ["D"] anySolverFailure - , runTest $ enableAllTests $ mkTest db5 "simpleTest3" ["E"] (solverSuccess [("A", 1), ("E", 1)]) - , runTest $ enableAllTests $ mkTest db5 "simpleTest4" ["F"] anySolverFailure -- TODO - , runTest $ enableAllTests $ mkTest db5 "simpleTest5" ["G"] (solverSuccess [("A", 2), ("G", 1)]) - , runTest $ enableAllTests $ mkTest db5 "simpleTest6" ["E", "G"] anySolverFailure - , runTest $ indep $ enableAllTests $ mkTest db5 "simpleTest7" ["E", "G"] (solverSuccess [("A", 1), ("A", 2), ("E", 1), ("G", 1)]) - , runTest $ enableAllTests $ mkTest db6 "depsWithTests1" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) - , runTest $ indep $ enableAllTests $ mkTest db6 "depsWithTests2" ["C", "D"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)]) - , runTest $ testTestSuiteWithFlag "test suite with flag" - ] - , testGroup "Setup dependencies" [ - runTest $ mkTest db7 "setupDeps1" ["B"] (solverSuccess [("A", 2), ("B", 1)]) - , runTest $ mkTest db7 "setupDeps2" ["C"] (solverSuccess [("A", 2), ("C", 1)]) - , runTest $ mkTest db7 "setupDeps3" ["D"] (solverSuccess [("A", 1), ("D", 1)]) - , runTest $ mkTest db7 "setupDeps4" ["E"] (solverSuccess [("A", 1), ("A", 2), ("E", 1)]) - , runTest $ mkTest db7 "setupDeps5" ["F"] (solverSuccess [("A", 1), ("A", 2), ("F", 1)]) - , runTest $ mkTest db8 "setupDeps6" ["C", "D"] (solverSuccess [("A", 1), ("B", 1), ("B", 2), ("C", 1), ("D", 1)]) - , runTest $ mkTest db9 "setupDeps7" ["F", "G"] (solverSuccess [("A", 1), ("B", 1), ("B",2 ), ("C", 1), ("D", 1), ("E", 1), ("E", 2), ("F", 1), ("G", 1)]) - , runTest $ mkTest db10 "setupDeps8" ["C"] (solverSuccess [("C", 1)]) - , runTest $ indep $ mkTest dbSetupDeps "setupDeps9" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2)]) - ] - , testGroup "Base shim" [ - runTest $ mkTest db11 "baseShim1" ["A"] (solverSuccess [("A", 1)]) - , runTest $ mkTest db12 "baseShim2" ["A"] (solverSuccess [("A", 1)]) - , runTest $ mkTest db12 "baseShim3" ["B"] (solverSuccess [("B", 1)]) - , runTest $ mkTest db12 "baseShim4" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) - , runTest $ mkTest db12 "baseShim5" ["D"] anySolverFailure - , runTest $ mkTest db12 "baseShim6" ["E"] (solverSuccess [("E", 1), ("syb", 2)]) - ] - , testGroup "Base and Nonupgradable" [ - runTest $ mkTest dbBase "Refuse to install base without --allow-boot-library-installs" ["base"] $ - solverFailure (isInfixOf "only already installed instances can be used") - , runTest $ allowBootLibInstalls $ mkTest dbBase "Install base with --allow-boot-library-installs" ["base"] $ - solverSuccess [("base", 1), ("ghc-prim", 1), ("integer-gmp", 1), ("integer-simple", 1)] - , runTest $ mkTest dbNonupgrade "Refuse to install newer ghc requested by another library" ["A"] $ - solverFailure (isInfixOf "rejecting: ghc-2.0.0 (constraint from non-upgradeable package requires installed instance)") - , runTest $ mkTest dbNonupgrade "Refuse to install newer ghci requested by another library" ["B"] $ - solverFailure (isInfixOf "rejecting: ghci-2.0.0 (constraint from non-upgradeable package requires installed instance)") - , runTest $ mkTest dbNonupgrade "Refuse to install newer ghc-boot requested by another library" ["C"] $ - solverFailure (isInfixOf "rejecting: ghc-boot-2.0.0 (constraint from non-upgradeable package requires installed instance)") - ] - , testGroup "reject-unconstrained" [ - runTest $ onlyConstrained $ mkTest db12 "missing syb" ["E"] $ - solverFailure (isInfixOf "not a user-provided goal") - , runTest $ onlyConstrained $ mkTest db12 "all goals" ["E", "syb"] $ - solverSuccess [("E", 1), ("syb", 2)] - , runTest $ onlyConstrained $ mkTest db17 "backtracking" ["A", "B"] $ - solverSuccess [("A", 2), ("B", 1)] - , runTest $ onlyConstrained $ mkTest db17 "failure message" ["A"] $ - solverFailure $ isInfixOf $ - "Could not resolve dependencies:\n" - ++ "[__0] trying: A-3.0.0 (user goal)\n" - ++ "[__1] next goal: C (dependency of A)\n" - ++ "[__1] fail (not a user-provided goal nor mentioned as a constraint, " - ++ "but reject-unconstrained-dependencies was set)\n" - ++ "[__1] fail (backjumping, conflict set: A, C)\n" - ++ "After searching the rest of the dependency tree exhaustively, " - ++ "these were the goals I've had most trouble fulfilling: A, C, B" - ] - , testGroup "Cycles" [ - runTest $ mkTest db14 "simpleCycle1" ["A"] anySolverFailure - , runTest $ mkTest db14 "simpleCycle2" ["A", "B"] anySolverFailure - , runTest $ mkTest db14 "cycleWithFlagChoice1" ["C"] (solverSuccess [("C", 1), ("E", 1)]) - , runTest $ mkTest db15 "cycleThroughSetupDep1" ["A"] anySolverFailure - , runTest $ mkTest db15 "cycleThroughSetupDep2" ["B"] anySolverFailure - , runTest $ mkTest db15 "cycleThroughSetupDep3" ["C"] (solverSuccess [("C", 2), ("D", 1)]) - , runTest $ mkTest db15 "cycleThroughSetupDep4" ["D"] (solverSuccess [("D", 1)]) - , runTest $ mkTest db15 "cycleThroughSetupDep5" ["E"] (solverSuccess [("C", 2), ("D", 1), ("E", 1)]) - , runTest $ issue4161 "detect cycle between package and its setup script" - , runTest $ testCyclicDependencyErrorMessages "cyclic dependency error messages" - ] - , testGroup "Extensions" [ - runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupported" ["A"] anySolverFailure - , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupportedIndirect" ["B"] anySolverFailure - , runTest $ mkTestExts [EnableExtension RankNTypes] dbExts1 "supported" ["A"] (solverSuccess [("A",1)]) - , runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedIndirect" ["C"] (solverSuccess [("A",1),("B",1), ("C",1)]) - , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "disabledExtension" ["D"] anySolverFailure - , runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "disabledExtension" ["D"] anySolverFailure - , runTest $ mkTestExts (UnknownExtension "custom" : map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedUnknown" ["E"] (solverSuccess [("A",1),("B",1),("C",1),("E",1)]) - ] - , testGroup "Languages" [ - runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupported" ["A"] anySolverFailure - , runTest $ mkTestLangs [Haskell98,Haskell2010] dbLangs1 "supported" ["A"] (solverSuccess [("A",1)]) - , runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupportedIndirect" ["B"] anySolverFailure - , runTest $ mkTestLangs [Haskell98, Haskell2010, UnknownLanguage "Haskell3000"] dbLangs1 "supportedUnknown" ["C"] (solverSuccess [("A",1),("B",1),("C",1)]) - ] - , testGroup "Qualified Package Constraints" [ - runTest $ mkTest dbConstraints "install latest versions without constraints" ["A", "B", "C"] $ - solverSuccess [("A", 7), ("B", 8), ("C", 9), ("D", 7), ("D", 8), ("D", 9)] - - , let cs = [ ExVersionConstraint (ScopeAnyQualifier "D") $ mkVersionRange 1 4 ] - in runTest $ constraints cs $ - mkTest dbConstraints "force older versions with unqualified constraint" ["A", "B", "C"] $ - solverSuccess [("A", 1), ("B", 2), ("C", 3), ("D", 1), ("D", 2), ("D", 3)] - - , let cs = [ ExVersionConstraint (ScopeQualified P.QualToplevel "D") $ mkVersionRange 1 4 - , ExVersionConstraint (ScopeQualified (P.QualSetup "B") "D") $ mkVersionRange 4 7 - ] - in runTest $ constraints cs $ - mkTest dbConstraints "force multiple versions with qualified constraints" ["A", "B", "C"] $ - solverSuccess [("A", 1), ("B", 5), ("C", 9), ("D", 1), ("D", 5), ("D", 9)] - - , let cs = [ ExVersionConstraint (ScopeAnySetupQualifier "D") $ mkVersionRange 1 4 ] - in runTest $ constraints cs $ - mkTest dbConstraints "constrain package across setup scripts" ["A", "B", "C"] $ - solverSuccess [("A", 7), ("B", 2), ("C", 3), ("D", 2), ("D", 3), ("D", 7)] - ] - , testGroup "Package Preferences" [ - runTest $ preferences [ ExPkgPref "A" $ mkvrThis 1] $ mkTest db13 "selectPreferredVersionSimple" ["A"] (solverSuccess [("A", 1)]) - , runTest $ preferences [ ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionSimple2" ["A"] (solverSuccess [("A", 2)]) - , runTest $ preferences [ ExPkgPref "A" $ mkvrOrEarlier 2 - , ExPkgPref "A" $ mkvrOrEarlier 1] $ mkTest db13 "selectPreferredVersionMultiple" ["A"] (solverSuccess [("A", 1)]) - , runTest $ preferences [ ExPkgPref "A" $ mkvrOrEarlier 1 - , ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple2" ["A"] (solverSuccess [("A", 1)]) - , runTest $ preferences [ ExPkgPref "A" $ mkvrThis 1 - , ExPkgPref "A" $ mkvrThis 2] $ mkTest db13 "selectPreferredVersionMultiple3" ["A"] (solverSuccess [("A", 2)]) - , runTest $ preferences [ ExPkgPref "A" $ mkvrThis 1 - , ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple4" ["A"] (solverSuccess [("A", 1)]) - ] - , testGroup "Stanza Preferences" [ - runTest $ - mkTest dbStanzaPreferences1 "disable tests by default" ["pkg"] $ - solverSuccess [("pkg", 1)] - - , runTest $ preferences [ExStanzaPref "pkg" [TestStanzas]] $ - mkTest dbStanzaPreferences1 "enable tests with testing preference" ["pkg"] $ - solverSuccess [("pkg", 1), ("test-dep", 1)] - - , runTest $ preferences [ExStanzaPref "pkg" [TestStanzas]] $ - mkTest dbStanzaPreferences2 "disable testing when it's not possible" ["pkg"] $ - solverSuccess [("pkg", 1)] - - , testStanzaPreference "test stanza preference" - ] - , testGroup "Buildable Field" [ - testBuildable "avoid building component with unknown dependency" (ExAny "unknown") - , testBuildable "avoid building component with unknown extension" (ExExt (UnknownExtension "unknown")) - , testBuildable "avoid building component with unknown language" (ExLang (UnknownLanguage "unknown")) - , runTest $ mkTest dbBuildable1 "choose flags that set buildable to false" ["pkg"] (solverSuccess [("flag1-false", 1), ("flag2-true", 1), ("pkg", 1)]) - , runTest $ mkTest dbBuildable2 "choose version that sets buildable to false" ["A"] (solverSuccess [("A", 1), ("B", 2)]) - ] - , testGroup "Pkg-config dependencies" [ - runTest $ mkTestPCDepends (Just []) dbPC1 "noPkgs" ["A"] anySolverFailure - , runTest $ mkTestPCDepends (Just [("pkgA", "0")]) dbPC1 "tooOld" ["A"] anySolverFailure - , runTest $ mkTestPCDepends (Just [("pkgA", "1.0.0"), ("pkgB", "1.0.0")]) dbPC1 "pruneNotFound" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) - , runTest $ mkTestPCDepends (Just [("pkgA", "1.0.0"), ("pkgB", "2.0.0")]) dbPC1 "chooseNewest" ["C"] (solverSuccess [("A", 1), ("B", 2), ("C", 1)]) - , runTest $ mkTestPCDepends Nothing dbPC1 "noPkgConfigFailure" ["A"] anySolverFailure - , runTest $ mkTestPCDepends Nothing dbPC1 "noPkgConfigSuccess" ["D"] (solverSuccess [("D",1)]) - ] - , testGroup "Independent goals" [ - runTest $ indep $ mkTest db16 "indepGoals1" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("E", 1)]) - , runTest $ testIndepGoals2 "indepGoals2" - , runTest $ testIndepGoals3 "indepGoals3" - , runTest $ testIndepGoals4 "indepGoals4" - , runTest $ testIndepGoals5 "indepGoals5 - fixed goal order" FixedGoalOrder - , runTest $ testIndepGoals5 "indepGoals5 - default goal order" DefaultGoalOrder - , runTest $ testIndepGoals6 "indepGoals6 - fixed goal order" FixedGoalOrder - , runTest $ testIndepGoals6 "indepGoals6 - default goal order" DefaultGoalOrder - ] - -- Tests designed for the backjumping blog post - , testGroup "Backjumping" [ - runTest $ mkTest dbBJ1a "bj1a" ["A"] (solverSuccess [("A", 1), ("B", 1)]) - , runTest $ mkTest dbBJ1b "bj1b" ["A"] (solverSuccess [("A", 1), ("B", 1)]) - , runTest $ mkTest dbBJ1c "bj1c" ["A"] (solverSuccess [("A", 1), ("B", 1)]) - , runTest $ mkTest dbBJ2 "bj2" ["A"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) - , runTest $ mkTest dbBJ3 "bj3" ["A"] (solverSuccess [("A", 1), ("Ba", 1), ("C", 1)]) - , runTest $ mkTest dbBJ4 "bj4" ["A"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) - , runTest $ mkTest dbBJ5 "bj5" ["A"] (solverSuccess [("A", 1), ("B", 1), ("D", 1)]) - , runTest $ mkTest dbBJ6 "bj6" ["A"] (solverSuccess [("A", 1), ("B", 1)]) - , runTest $ mkTest dbBJ7 "bj7" ["A"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) - , runTest $ indep $ mkTest dbBJ8 "bj8" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) - ] - , testGroup "main library dependencies" [ - let db = [Right $ exAvNoLibrary "A" 1 `withExe` exExe "exe" []] - in runTest $ mkTest db "install build target without a library" ["A"] $ - solverSuccess [("A", 1)] - - , let db = [ Right $ exAv "A" 1 [ExAny "B"] - , Right $ exAvNoLibrary "B" 1 `withExe` exExe "exe" [] ] - in runTest $ mkTest db "reject build-depends dependency with no library" ["A"] $ - solverFailure (isInfixOf "rejecting: B-1.0.0 (does not contain library, which is required by A)") - - , let exe = exExe "exe" [] - db = [ Right $ exAv "A" 1 [ExAny "B"] - , Right $ exAvNoLibrary "B" 2 `withExe` exe - , Right $ exAv "B" 1 [] `withExe` exe ] - in runTest $ mkTest db "choose version of build-depends dependency that has a library" ["A"] $ - solverSuccess [("A", 1), ("B", 1)] - ] - , testGroup "sub-library dependencies" [ - let db = [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"] - , Right $ exAv "B" 1 [] ] - in runTest $ - mkTest db "reject package that is missing required sub-library" ["A"] $ - solverFailure $ isInfixOf $ - "rejecting: B-1.0.0 (does not contain library 'sub-lib', which is required by A)" - - , let db = [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"] - , Right $ exAvNoLibrary "B" 1 `withSubLibrary` exSubLib "sub-lib" [] ] - in runTest $ - mkTest db "reject package with private but required sub-library" ["A"] $ - solverFailure $ isInfixOf $ - "rejecting: B-1.0.0 (library 'sub-lib' is private, but it is required by A)" - - , let db = [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"] - , Right $ exAvNoLibrary "B" 1 - `withSubLibrary` exSubLib "sub-lib" [ExFlagged "make-lib-private" (dependencies []) publicDependencies] ] - in runTest $ constraints [ExFlagConstraint (ScopeAnyQualifier "B") "make-lib-private" True] $ - mkTest db "reject package with sub-library made private by flag constraint" ["A"] $ - solverFailure $ isInfixOf $ - "rejecting: B-1.0.0 (library 'sub-lib' is private, but it is required by A)" - - , let db = [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"] - , Right $ exAvNoLibrary "B" 1 - `withSubLibrary` exSubLib "sub-lib" [ExFlagged "make-lib-private" (dependencies []) publicDependencies] ] - in runTest $ - mkTest db "treat sub-library as visible even though flag choice could make it private" ["A"] $ - solverSuccess [("A", 1), ("B", 1)] - - , let db = [ Right $ exAv "A" 1 [ExAny "B"] - , Right $ exAv "B" 1 [] `withSubLibrary` exSubLib "sub-lib" [] - , Right $ exAv "C" 1 [ExSubLibAny "B" "sub-lib"] ] - goals :: [ExampleVar] - goals = [ - P QualNone "A" - , P QualNone "B" - , P QualNone "C" - ] - in runTest $ goalOrder goals $ - mkTest db "reject package that requires a private sub-library" ["A", "C"] $ - solverFailure $ isInfixOf $ - "rejecting: C-1.0.0 (requires library 'sub-lib' from B, but the component is private)" - - , let db = [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib-v1"] - , Right $ exAv "B" 2 [] `withSubLibrary` ExSubLib "sub-lib-v2" publicDependencies - , Right $ exAv "B" 1 [] `withSubLibrary` ExSubLib "sub-lib-v1" publicDependencies ] - in runTest $ mkTest db "choose version of package containing correct sub-library" ["A"] $ - solverSuccess [("A", 1), ("B", 1)] - - , let db = [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"] - , Right $ exAv "B" 2 [] `withSubLibrary` ExSubLib "sub-lib" (dependencies []) - , Right $ exAv "B" 1 [] `withSubLibrary` ExSubLib "sub-lib" publicDependencies ] - in runTest $ mkTest db "choose version of package with public sub-library" ["A"] $ - solverSuccess [("A", 1), ("B", 1)] - ] - -- build-tool-depends dependencies - , testGroup "build-tool-depends" [ - runTest $ mkTest dbBuildTools "simple exe dependency" ["A"] (solverSuccess [("A", 1), ("bt-pkg", 2)]) - - , runTest $ disableSolveExecutables $ - mkTest dbBuildTools "don't install build tool packages in legacy mode" ["A"] (solverSuccess [("A", 1)]) - - , runTest $ mkTest dbBuildTools "flagged exe dependency" ["B"] (solverSuccess [("B", 1), ("bt-pkg", 2)]) - - , runTest $ enableAllTests $ - mkTest dbBuildTools "test suite exe dependency" ["C"] (solverSuccess [("C", 1), ("bt-pkg", 2)]) - - , runTest $ mkTest dbBuildTools "unknown exe" ["D"] $ - solverFailure (isInfixOf "does not contain executable 'unknown-exe', which is required by D") - - , runTest $ disableSolveExecutables $ - mkTest dbBuildTools "don't check for build tool executables in legacy mode" ["D"] $ solverSuccess [("D", 1)] - - , runTest $ mkTest dbBuildTools "unknown build tools package error mentions package, not exe" ["E"] $ - solverFailure (isInfixOf "unknown package: E:unknown-pkg:exe.unknown-pkg (dependency of E)") - - , runTest $ mkTest dbBuildTools "unknown flagged exe" ["F"] $ - solverFailure (isInfixOf "does not contain executable 'unknown-exe', which is required by F +flagF") - - , runTest $ enableAllTests $ mkTest dbBuildTools "unknown test suite exe" ["G"] $ - solverFailure (isInfixOf "does not contain executable 'unknown-exe', which is required by G *test") - - , runTest $ mkTest dbBuildTools "wrong exe for build tool package version" ["H"] $ - solverFailure $ isInfixOf $ - -- The solver reports the version conflict when a version conflict - -- and an executable conflict apply to the same package version. - "[__1] rejecting: H:bt-pkg:exe.bt-pkg-4.0.0 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3.0.0)\n" - ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-3.0.0 (does not contain executable 'exe1', which is required by H)\n" - ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-2.0.0 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3.0.0)" - - , runTest $ chooseExeAfterBuildToolsPackage True "choose exe after choosing its package - success" - - , runTest $ chooseExeAfterBuildToolsPackage False "choose exe after choosing its package - failure" - - , runTest $ rejectInstalledBuildToolPackage "reject installed package for build-tool dependency" - - , runTest $ requireConsistentBuildToolVersions "build tool versions must be consistent within one package" - ] - -- build-tools dependencies - , testGroup "legacy build-tools" [ - runTest $ mkTest dbLegacyBuildTools1 "bt1" ["A"] (solverSuccess [("A", 1), ("alex", 1)]) - - , runTest $ disableSolveExecutables $ - mkTest dbLegacyBuildTools1 "bt1 - don't install build tool packages in legacy mode" ["A"] (solverSuccess [("A", 1)]) - - , runTest $ mkTest dbLegacyBuildTools2 "bt2" ["A"] $ - solverFailure (isInfixOf "does not contain executable 'alex', which is required by A") - - , runTest $ disableSolveExecutables $ - mkTest dbLegacyBuildTools2 "bt2 - don't check for build tool executables in legacy mode" ["A"] (solverSuccess [("A", 1)]) - - , runTest $ mkTest dbLegacyBuildTools3 "bt3" ["A"] (solverSuccess [("A", 1)]) - - , runTest $ mkTest dbLegacyBuildTools4 "bt4" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("alex", 1), ("alex", 2)]) - - , runTest $ mkTest dbLegacyBuildTools5 "bt5" ["B"] (solverSuccess [("A", 1), ("A", 2), ("B", 1), ("alex", 1)]) - - , runTest $ mkTest dbLegacyBuildTools6 "bt6" ["A"] (solverSuccess [("A", 1), ("alex", 1), ("happy", 1)]) - ] - -- internal dependencies - , testGroup "internal dependencies" [ - runTest $ mkTest dbIssue3775 "issue #3775" ["B"] (solverSuccess [("A", 2), ("B", 2), ("warp", 1)]) - ] - -- tests for partial fix for issue #5325 - , testGroup "Components that are unbuildable in the current environment" $ - let flagConstraint = ExFlagConstraint . ScopeAnyQualifier - in [ - let db = [ Right $ exAv "A" 1 [ExFlagged "build-lib" (dependencies []) unbuildableDependencies] ] - in runTest $ constraints [flagConstraint "A" "build-lib" False] $ - mkTest db "install unbuildable library" ["A"] $ - solverSuccess [("A", 1)] - - , let db = [ Right $ exAvNoLibrary "A" 1 - `withExe` exExe "exe" [ExFlagged "build-exe" (dependencies []) unbuildableDependencies] ] - in runTest $ constraints [flagConstraint "A" "build-exe" False] $ - mkTest db "install unbuildable exe" ["A"] $ - solverSuccess [("A", 1)] - - , let db = [ Right $ exAv "A" 1 [ExAny "B"] - , Right $ exAv "B" 1 [ExFlagged "build-lib" (dependencies []) unbuildableDependencies] ] - in runTest $ constraints [flagConstraint "B" "build-lib" False] $ - mkTest db "reject library dependency with unbuildable library" ["A"] $ - solverFailure $ isInfixOf $ - "rejecting: B-1.0.0 (library is not buildable in the " - ++ "current environment, but it is required by A)" - - , let db = [ Right $ exAv "A" 1 [ExBuildToolAny "B" "bt"] - , Right $ exAv "B" 1 [ExFlagged "build-lib" (dependencies []) unbuildableDependencies] - `withExe` exExe "bt" [] ] - in runTest $ constraints [flagConstraint "B" "build-lib" False] $ - mkTest db "allow build-tool dependency with unbuildable library" ["A"] $ - solverSuccess [("A", 1), ("B", 1)] - - , let db = [ Right $ exAv "A" 1 [ExBuildToolAny "B" "bt"] - , Right $ exAv "B" 1 [] - `withExe` exExe "bt" [ExFlagged "build-exe" (dependencies []) unbuildableDependencies] ] - in runTest $ constraints [flagConstraint "B" "build-exe" False] $ - mkTest db "reject build-tool dependency with unbuildable exe" ["A"] $ - solverFailure $ isInfixOf $ - "rejecting: A:B:exe.B-1.0.0 (executable 'bt' is not " - ++ "buildable in the current environment, but it is required by A)" - , runTest $ - chooseUnbuildableExeAfterBuildToolsPackage - "choose unbuildable exe after choosing its package" - ] - - , testGroup "--fine-grained-conflicts" [ - - -- Skipping a version because of a problematic dependency: - -- - -- When the solver explores A-4, it finds that it cannot satisfy B's - -- dependencies. This allows the solver to skip the subsequent - -- versions of A that also depend on B. - runTest $ - let db = [ - Right $ exAv "A" 4 [ExAny "B"] - , Right $ exAv "A" 3 [ExAny "B"] - , Right $ exAv "A" 2 [ExAny "B"] - , Right $ exAv "A" 1 [] - , Right $ exAv "B" 2 [ExAny "unknown1"] - , Right $ exAv "B" 1 [ExAny "unknown2"] - ] - msg = [ - "[__0] trying: A-4.0.0 (user goal)" - , "[__1] trying: B-2.0.0 (dependency of A)" - , "[__2] unknown package: unknown1 (dependency of B)" - , "[__2] fail (backjumping, conflict set: B, unknown1)" - , "[__1] trying: B-1.0.0" - , "[__2] unknown package: unknown2 (dependency of B)" - , "[__2] fail (backjumping, conflict set: B, unknown2)" - , "[__1] fail (backjumping, conflict set: A, B, unknown1, unknown2)" - , "[__0] skipping: A-3.0.0, A-2.0.0 (has the same characteristics that " - ++ "caused the previous version to fail: depends on 'B')" - , "[__0] trying: A-1.0.0" - , "[__1] done" - ] - in setVerbose $ - mkTest db "skip version due to problematic dependency" ["A"] $ - SolverResult (isInfixOf msg) $ Right [("A", 1)] - - , -- Skipping a version because of a restrictive constraint on a - -- dependency: - -- - -- The solver rejects A-4 because its constraint on B excludes B-1. - -- Then the solver is able to skip A-3 and A-2 because they also - -- exclude B-1, even though they don't have the exact same constraints - -- on B. - runTest $ - let db = [ - Right $ exAv "A" 4 [ExFix "B" 14] - , Right $ exAv "A" 3 [ExFix "B" 13] - , Right $ exAv "A" 2 [ExFix "B" 12] - , Right $ exAv "A" 1 [ExFix "B" 11] - , Right $ exAv "B" 11 [] - ] - msg = [ - "[__0] trying: A-4.0.0 (user goal)" - , "[__1] next goal: B (dependency of A)" - , "[__1] rejecting: B-11.0.0 (conflict: A => B==14.0.0)" - , "[__1] fail (backjumping, conflict set: A, B)" - , "[__0] skipping: A-3.0.0, A-2.0.0 (has the same characteristics that " - ++ "caused the previous version to fail: depends on 'B' but excludes " - ++ "version 11.0.0)" - , "[__0] trying: A-1.0.0" - , "[__1] next goal: B (dependency of A)" - , "[__1] trying: B-11.0.0" - , "[__2] done" - ] - in setVerbose $ - mkTest db "skip version due to restrictive constraint on its dependency" ["A"] $ - SolverResult (isInfixOf msg) $ Right [("A", 1), ("B", 11)] - - , -- This test tests the case where the solver chooses a version for one - -- package, B, before choosing a version for one of its reverse - -- dependencies, C. While the solver is exploring the subtree rooted - -- at B-3, it finds that C-2's dependency on B conflicts with B-3. - -- Then the solver is able to skip C-1, because it also excludes B-3. - -- - -- --fine-grained-conflicts could have a benefit in this case even - -- though the solver would have found the conflict between B-3 and C-1 - -- immediately after trying C-1 anyway. It prevents C-1 from - -- introducing any other conflicts which could increase the size of - -- the conflict set. - runTest $ - let db = [ - Right $ exAv "A" 1 [ExAny "B", ExAny "C"] - , Right $ exAv "B" 3 [] - , Right $ exAv "B" 2 [] - , Right $ exAv "B" 1 [] - , Right $ exAv "C" 2 [ExFix "B" 2] - , Right $ exAv "C" 1 [ExFix "B" 1] - ] - goals = [P QualNone pkg | pkg <- ["A", "B", "C"]] - expectedMsg = [ - "[__0] trying: A-1.0.0 (user goal)" - , "[__1] trying: B-3.0.0 (dependency of A)" - , "[__2] next goal: C (dependency of A)" - , "[__2] rejecting: C-2.0.0 (conflict: B==3.0.0, C => B==2.0.0)" - , "[__2] skipping: C-1.0.0 (has the same characteristics that caused the " - ++ "previous version to fail: excludes 'B' version 3.0.0)" - , "[__2] fail (backjumping, conflict set: A, B, C)" - , "[__1] trying: B-2.0.0" - , "[__2] next goal: C (dependency of A)" - , "[__2] trying: C-2.0.0" - , "[__3] done" - ] - in setVerbose $ goalOrder goals $ - mkTest db "skip version that excludes dependency that was already chosen" ["A"] $ - SolverResult (isInfixOf expectedMsg) $ Right [("A", 1), ("B", 2), ("C", 2)] - - , -- This test tests how the solver merges conflicts when it has - -- multiple reasons to add a variable to the conflict set. In this - -- case, package A conflicts with B and C. The solver should take the - -- union of the conflicts and then only skip a version if it does not - -- resolve any of the conflicts. - -- - -- The solver rejects A-3 because it can't find consistent versions for - -- its two dependencies, B and C. Then it skips A-2 because A-2 also - -- depends on B and C. This test ensures that the solver considers - -- A-1 even though A-1 only resolves one of the conflicts (A-1 removes - -- the dependency on C). - runTest $ - let db = [ - Right $ exAv "A" 3 [ExAny "B", ExAny "C"] - , Right $ exAv "A" 2 [ExAny "B", ExAny "C"] - , Right $ exAv "A" 1 [ExAny "B"] - , Right $ exAv "B" 1 [ExFix "D" 1] - , Right $ exAv "C" 1 [ExFix "D" 2] - , Right $ exAv "D" 1 [] - , Right $ exAv "D" 2 [] - ] - goals = [P QualNone pkg | pkg <- ["A", "B", "C", "D"]] - msg = [ - "[__0] trying: A-3.0.0 (user goal)" - , "[__1] trying: B-1.0.0 (dependency of A)" - , "[__2] trying: C-1.0.0 (dependency of A)" - , "[__3] next goal: D (dependency of B)" - , "[__3] rejecting: D-2.0.0 (conflict: B => D==1.0.0)" - , "[__3] rejecting: D-1.0.0 (conflict: C => D==2.0.0)" - , "[__3] fail (backjumping, conflict set: B, C, D)" - , "[__2] fail (backjumping, conflict set: A, B, C, D)" - , "[__1] fail (backjumping, conflict set: A, B, C, D)" - , "[__0] skipping: A-2.0.0 (has the same characteristics that caused the " - ++ "previous version to fail: depends on 'B'; depends on 'C')" - , "[__0] trying: A-1.0.0" - , "[__1] trying: B-1.0.0 (dependency of A)" - , "[__2] next goal: D (dependency of B)" - , "[__2] rejecting: D-2.0.0 (conflict: B => D==1.0.0)" - , "[__2] trying: D-1.0.0" - , "[__3] done" - ] - in setVerbose $ goalOrder goals $ - mkTest db "only skip a version if it resolves none of the previous conflicts" ["A"] $ - SolverResult (isInfixOf msg) $ Right [("A", 1), ("B", 1), ("D", 1)] - - , -- This test ensures that the solver log doesn't show all conflicts - -- that the solver encountered in a subtree. The solver should only - -- show the conflicts that are contained in the current conflict set. - -- - -- The goal order forces the solver to try A-4, encounter a conflict - -- with B-2, try B-1, and then try C. A-4 conflicts with the only - -- version of C, so the solver backjumps with a conflict set of - -- {A, C}. When the solver skips the next version of A, the log should - -- mention the conflict with C but not B. - runTest $ - let db = [ - Right $ exAv "A" 4 [ExFix "B" 1, ExFix "C" 1] - , Right $ exAv "A" 3 [ExFix "B" 1, ExFix "C" 1] - , Right $ exAv "A" 2 [ExFix "C" 1] - , Right $ exAv "A" 1 [ExFix "C" 2] - , Right $ exAv "B" 2 [] - , Right $ exAv "B" 1 [] - , Right $ exAv "C" 2 [] - ] - goals = [P QualNone pkg | pkg <- ["A", "B", "C"]] - msg = [ - "[__0] trying: A-4.0.0 (user goal)" - , "[__1] next goal: B (dependency of A)" - , "[__1] rejecting: B-2.0.0 (conflict: A => B==1.0.0)" - , "[__1] trying: B-1.0.0" - , "[__2] next goal: C (dependency of A)" - , "[__2] rejecting: C-2.0.0 (conflict: A => C==1.0.0)" - , "[__2] fail (backjumping, conflict set: A, C)" - , "[__0] skipping: A-3.0.0, A-2.0.0 (has the same characteristics that caused the " - ++ "previous version to fail: depends on 'C' but excludes version 2.0.0)" - , "[__0] trying: A-1.0.0" - , "[__1] next goal: C (dependency of A)" - , "[__1] trying: C-2.0.0" - , "[__2] done" - ] - in setVerbose $ goalOrder goals $ - mkTest db "don't show conflicts that aren't part of the conflict set" ["A"] $ - SolverResult (isInfixOf msg) $ Right [("A", 1), ("C", 2)] - - , -- Tests that the conflict set is properly updated when a version is - -- skipped due to being excluded by one of its reverse dependencies' - -- constraints. - runTest $ - let db = [ - Right $ exAv "A" 2 [ExFix "B" 3] - , Right $ exAv "A" 1 [ExFix "B" 1] - , Right $ exAv "B" 2 [] - , Right $ exAv "B" 1 [] - ] - msg = [ - "[__0] trying: A-2.0.0 (user goal)" - , "[__1] next goal: B (dependency of A)" - - -- During this step, the solver adds A and B to the - -- conflict set, with the details of each package's - -- conflict: - -- - -- A: A's constraint rejected B-2. - -- B: B was rejected by A's B==3 constraint - , "[__1] rejecting: B-2.0.0 (conflict: A => B==3.0.0)" - - -- When the solver skips B-1, it cannot simply reuse the - -- previous conflict set. It also needs to update A's - -- entry to say that A also rejected B-1. Otherwise, the - -- solver wouldn't know that A-1 could resolve one of - -- the conflicts encountered while exploring A-2. The - -- solver would skip A-1, even though it leads to the - -- solution. - , "[__1] skipping: B-1.0.0 (has the same characteristics that caused " - ++ "the previous version to fail: excluded by constraint '==3.0.0' from 'A')" - - , "[__1] fail (backjumping, conflict set: A, B)" - , "[__0] trying: A-1.0.0" - , "[__1] next goal: B (dependency of A)" - , "[__1] rejecting: B-2.0.0 (conflict: A => B==1.0.0)" - , "[__1] trying: B-1.0.0" - , "[__2] done" +tests = + [ testGroup + "Simple dependencies" + [ runTest $ mkTest db1 "alreadyInstalled" ["A"] (solverSuccess []) + , runTest $ mkTest db1 "installLatest" ["B"] (solverSuccess [("B", 2)]) + , runTest $ + preferOldest $ + mkTest db1 "installOldest" ["B"] (solverSuccess [("B", 1)]) + , runTest $ mkTest db1 "simpleDep1" ["C"] (solverSuccess [("B", 1), ("C", 1)]) + , runTest $ mkTest db1 "simpleDep2" ["D"] (solverSuccess [("B", 2), ("D", 1)]) + , runTest $ mkTest db1 "failTwoVersions" ["C", "D"] anySolverFailure + , runTest $ indep $ mkTest db1 "indepTwoVersions" ["C", "D"] (solverSuccess [("B", 1), ("B", 2), ("C", 1), ("D", 1)]) + , runTest $ indep $ mkTest db1 "aliasWhenPossible1" ["C", "E"] (solverSuccess [("B", 1), ("C", 1), ("E", 1)]) + , runTest $ indep $ mkTest db1 "aliasWhenPossible2" ["D", "E"] (solverSuccess [("B", 2), ("D", 1), ("E", 1)]) + , runTest $ indep $ mkTest db2 "aliasWhenPossible3" ["C", "D"] (solverSuccess [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("C", 1), ("D", 1)]) + , runTest $ mkTest db1 "buildDepAgainstOld" ["F"] (solverSuccess [("B", 1), ("E", 1), ("F", 1)]) + , runTest $ mkTest db1 "buildDepAgainstNew" ["G"] (solverSuccess [("B", 2), ("E", 1), ("G", 1)]) + , runTest $ indep $ mkTest db1 "multipleInstances" ["F", "G"] anySolverFailure + , runTest $ mkTest db21 "unknownPackage1" ["A"] (solverSuccess [("A", 1), ("B", 1)]) + , runTest $ mkTest db22 "unknownPackage2" ["A"] (solverFailure (isInfixOf "unknown package: C")) + , runTest $ mkTest db23 "unknownPackage3" ["A"] (solverFailure (isInfixOf "unknown package: B")) + , runTest $ mkTest [] "unknown target" ["A"] (solverFailure (isInfixOf "unknown package: A")) + ] + , testGroup + "Flagged dependencies" + [ runTest $ mkTest db3 "forceFlagOn" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) + , runTest $ mkTest db3 "forceFlagOff" ["D"] (solverSuccess [("A", 2), ("B", 1), ("D", 1)]) + , runTest $ indep $ mkTest db3 "linkFlags1" ["C", "D"] anySolverFailure + , runTest $ indep $ mkTest db4 "linkFlags2" ["C", "D"] anySolverFailure + , runTest $ indep $ mkTest db18 "linkFlags3" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("F", 1)]) + ] + , testGroup + "Lifting dependencies out of conditionals" + [ runTest $ commonDependencyLogMessage "common dependency log message" + , runTest $ twoLevelDeepCommonDependencyLogMessage "two level deep common dependency log message" + , runTest $ testBackjumpingWithCommonDependency "backjumping with common dependency" + ] + , testGroup + "Manual flags" + [ runTest $ + mkTest dbManualFlags "Use default value for manual flag" ["pkg"] $ + solverSuccess [("pkg", 1), ("true-dep", 1)] + , let checkFullLog = + any $ isInfixOf "rejecting: pkg:-flag (manual flag can only be changed explicitly)" + in runTest $ + setVerbose $ + constraints [ExVersionConstraint (ScopeAnyQualifier "true-dep") V.noVersion] $ + mkTest dbManualFlags "Don't toggle manual flag to avoid conflict" ["pkg"] $ + -- TODO: We should check the summarized log instead of the full log + -- for the manual flags error message, but it currently only + -- appears in the full log. + SolverResult checkFullLog (Left $ const True) + , let cs = [ExFlagConstraint (ScopeAnyQualifier "pkg") "flag" False] + in runTest $ + constraints cs $ + mkTest dbManualFlags "Toggle manual flag with flag constraint" ["pkg"] $ + solverSuccess [("false-dep", 1), ("pkg", 1)] + ] + , testGroup + "Qualified manual flag constraints" + [ let name = "Top-level flag constraint does not constrain setup dep's flag" + cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False] + in runTest $ + constraints cs $ + mkTest dbSetupDepWithManualFlag name ["A"] $ + solverSuccess + [ ("A", 1) + , ("B", 1) + , ("B", 2) + , ("b-1-false-dep", 1) + , ("b-2-true-dep", 1) ] - in setVerbose $ - mkTest db "update conflict set after skipping version - 1" ["A"] $ - SolverResult (isInfixOf msg) $ Right [("A", 1), ("B", 1)] - - , -- Tests that the conflict set is properly updated when a version is - -- skipped due to excluding a version of one of its dependencies. - -- This test is similar the previous one, with the goal order reversed. - runTest $ - let db = [ - Right $ exAv "A" 2 [] - , Right $ exAv "A" 1 [] - , Right $ exAv "B" 2 [ExFix "A" 3] - , Right $ exAv "B" 1 [ExFix "A" 1] + , let name = "Solver can toggle setup dep's flag to match top-level constraint" + cs = + [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False + , ExVersionConstraint (ScopeAnyQualifier "b-2-true-dep") V.noVersion + ] + in runTest $ + constraints cs $ + mkTest dbSetupDepWithManualFlag name ["A"] $ + solverSuccess + [ ("A", 1) + , ("B", 1) + , ("B", 2) + , ("b-1-false-dep", 1) + , ("b-2-false-dep", 1) ] - goals = [P QualNone pkg | pkg <- ["A", "B"]] - msg = [ - "[__0] trying: A-2.0.0 (user goal)" - , "[__1] next goal: B (user goal)" - , "[__1] rejecting: B-2.0.0 (conflict: A==2.0.0, B => A==3.0.0)" - , "[__1] skipping: B-1.0.0 (has the same characteristics that caused " - ++ "the previous version to fail: excludes 'A' version 2.0.0)" - , "[__1] fail (backjumping, conflict set: A, B)" - , "[__0] trying: A-1.0.0" - , "[__1] next goal: B (user goal)" - , "[__1] rejecting: B-2.0.0 (conflict: A==1.0.0, B => A==3.0.0)" - , "[__1] trying: B-1.0.0" - , "[__2] done" + , let name = "User can constrain flags separately with qualified constraints" + cs = + [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" True + , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False + ] + in runTest $ + constraints cs $ + mkTest dbSetupDepWithManualFlag name ["A"] $ + solverSuccess + [ ("A", 1) + , ("B", 1) + , ("B", 2) + , ("b-1-true-dep", 1) + , ("b-2-false-dep", 1) ] - in setVerbose $ goalOrder goals $ - mkTest db "update conflict set after skipping version - 2" ["A", "B"] $ - SolverResult (isInfixOf msg) $ Right [("A", 1), ("B", 1)] - ] - -- Tests for the contents of the solver's log - , testGroup "Solver log" [ - -- See issue #3203. The solver should only choose a version for A once. - runTest $ - let db = [Right $ exAv "A" 1 []] - - p :: [String] -> Bool - p lg = elem "targets: A" lg - && length (filter ("trying: A" `isInfixOf`) lg) == 1 - in setVerbose $ mkTest db "deduplicate targets" ["A", "A"] $ - SolverResult p $ Right [("A", 1)] - , runTest $ - let db = [Right $ exAv "A" 1 [ExAny "B"]] - msg = "After searching the rest of the dependency tree exhaustively, " - ++ "these were the goals I've had most trouble fulfilling: A, B" - in mkTest db "exhaustive search failure message" ["A"] $ - solverFailure (isInfixOf msg) - , testSummarizedLog "show conflicts from final conflict set after exhaustive search" Nothing $ - "Could not resolve dependencies:\n" - ++ "[__0] trying: A-1.0.0 (user goal)\n" - ++ "[__1] unknown package: F (dependency of A)\n" - ++ "[__1] fail (backjumping, conflict set: A, F)\n" - ++ "After searching the rest of the dependency tree exhaustively, " - ++ "these were the goals I've had most trouble fulfilling: A, F" - , testSummarizedLog "show first conflicts after inexhaustive search" (Just 3) $ - "Could not resolve dependencies:\n" - ++ "[__0] trying: A-1.0.0 (user goal)\n" - ++ "[__1] trying: B-3.0.0 (dependency of A)\n" - ++ "[__2] unknown package: C (dependency of B)\n" - ++ "[__2] fail (backjumping, conflict set: B, C)\n" - ++ "Backjump limit reached (currently 3, change with --max-backjumps " - ++ "or try to run with --reorder-goals).\n" - , testSummarizedLog "don't show summarized log when backjump limit is too low" (Just 1) $ - "Backjump limit reached (currently 1, change with --max-backjumps " - ++ "or try to run with --reorder-goals).\n" - ++ "Failed to generate a summarized dependency solver log due to low backjump limit." - , testMinimizeConflictSet - "minimize conflict set with --minimize-conflict-set" - , testNoMinimizeConflictSet - "show original conflict set with --no-minimize-conflict-set" - , runTest $ - let db = [ Right $ exAv "my-package" 1 [ExFix "other-package" 3] - , Left $ exInst "other-package" 2 "other-package-2.0.0" []] - msg = "rejecting: other-package-2.0.0/installed-2.0.0" - in mkTest db "show full installed package version (issue #5892)" ["my-package"] $ - solverFailure (isInfixOf msg) - , runTest $ - let db = [ Right $ exAv "my-package" 1 [ExFix "other-package" 3] - , Left $ exInst "other-package" 2 "other-package-AbCdEfGhIj0123456789" [] ] - msg = "rejecting: other-package-2.0.0/installed-AbCdEfGhIj0123456789" - in mkTest db "show full installed package ABI hash (issue #5892)" ["my-package"] $ - solverFailure (isInfixOf msg) - ] - ] + , -- Regression test for #4299 + let name = "Solver can link deps when only one has constrained manual flag" + cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False] + in runTest $ + constraints cs $ + mkTest dbLinkedSetupDepWithManualFlag name ["A"] $ + solverSuccess [("A", 1), ("B", 1), ("b-1-false-dep", 1)] + , let name = "Solver cannot link deps that have conflicting manual flag constraints" + cs = + [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" True + , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False + ] + failureReason = "(constraint from unknown source requires opposite flag selection)" + checkFullLog lns = + all + (\msg -> any (msg `isInfixOf`) lns) + [ "rejecting: B:-flag " ++ failureReason + , "rejecting: A:setup.B:+flag " ++ failureReason + ] + in runTest $ + constraints cs $ + setVerbose $ + mkTest dbLinkedSetupDepWithManualFlag name ["A"] $ + SolverResult checkFullLog (Left $ const True) + ] + , testGroup + "Stanzas" + [ runTest $ enableAllTests $ mkTest db5 "simpleTest1" ["C"] (solverSuccess [("A", 2), ("C", 1)]) + , runTest $ enableAllTests $ mkTest db5 "simpleTest2" ["D"] anySolverFailure + , runTest $ enableAllTests $ mkTest db5 "simpleTest3" ["E"] (solverSuccess [("A", 1), ("E", 1)]) + , runTest $ enableAllTests $ mkTest db5 "simpleTest4" ["F"] anySolverFailure -- TODO + , runTest $ enableAllTests $ mkTest db5 "simpleTest5" ["G"] (solverSuccess [("A", 2), ("G", 1)]) + , runTest $ enableAllTests $ mkTest db5 "simpleTest6" ["E", "G"] anySolverFailure + , runTest $ indep $ enableAllTests $ mkTest db5 "simpleTest7" ["E", "G"] (solverSuccess [("A", 1), ("A", 2), ("E", 1), ("G", 1)]) + , runTest $ enableAllTests $ mkTest db6 "depsWithTests1" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) + , runTest $ indep $ enableAllTests $ mkTest db6 "depsWithTests2" ["C", "D"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)]) + , runTest $ testTestSuiteWithFlag "test suite with flag" + ] + , testGroup + "Setup dependencies" + [ runTest $ mkTest db7 "setupDeps1" ["B"] (solverSuccess [("A", 2), ("B", 1)]) + , runTest $ mkTest db7 "setupDeps2" ["C"] (solverSuccess [("A", 2), ("C", 1)]) + , runTest $ mkTest db7 "setupDeps3" ["D"] (solverSuccess [("A", 1), ("D", 1)]) + , runTest $ mkTest db7 "setupDeps4" ["E"] (solverSuccess [("A", 1), ("A", 2), ("E", 1)]) + , runTest $ mkTest db7 "setupDeps5" ["F"] (solverSuccess [("A", 1), ("A", 2), ("F", 1)]) + , runTest $ mkTest db8 "setupDeps6" ["C", "D"] (solverSuccess [("A", 1), ("B", 1), ("B", 2), ("C", 1), ("D", 1)]) + , runTest $ mkTest db9 "setupDeps7" ["F", "G"] (solverSuccess [("A", 1), ("B", 1), ("B", 2), ("C", 1), ("D", 1), ("E", 1), ("E", 2), ("F", 1), ("G", 1)]) + , runTest $ mkTest db10 "setupDeps8" ["C"] (solverSuccess [("C", 1)]) + , runTest $ indep $ mkTest dbSetupDeps "setupDeps9" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2)]) + ] + , testGroup + "Base shim" + [ runTest $ mkTest db11 "baseShim1" ["A"] (solverSuccess [("A", 1)]) + , runTest $ mkTest db12 "baseShim2" ["A"] (solverSuccess [("A", 1)]) + , runTest $ mkTest db12 "baseShim3" ["B"] (solverSuccess [("B", 1)]) + , runTest $ mkTest db12 "baseShim4" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) + , runTest $ mkTest db12 "baseShim5" ["D"] anySolverFailure + , runTest $ mkTest db12 "baseShim6" ["E"] (solverSuccess [("E", 1), ("syb", 2)]) + ] + , testGroup + "Base and Nonupgradable" + [ runTest $ + mkTest dbBase "Refuse to install base without --allow-boot-library-installs" ["base"] $ + solverFailure (isInfixOf "only already installed instances can be used") + , runTest $ + allowBootLibInstalls $ + mkTest dbBase "Install base with --allow-boot-library-installs" ["base"] $ + solverSuccess [("base", 1), ("ghc-prim", 1), ("integer-gmp", 1), ("integer-simple", 1)] + , runTest $ + mkTest dbNonupgrade "Refuse to install newer ghc requested by another library" ["A"] $ + solverFailure (isInfixOf "rejecting: ghc-2.0.0 (constraint from non-upgradeable package requires installed instance)") + , runTest $ + mkTest dbNonupgrade "Refuse to install newer ghci requested by another library" ["B"] $ + solverFailure (isInfixOf "rejecting: ghci-2.0.0 (constraint from non-upgradeable package requires installed instance)") + , runTest $ + mkTest dbNonupgrade "Refuse to install newer ghc-boot requested by another library" ["C"] $ + solverFailure (isInfixOf "rejecting: ghc-boot-2.0.0 (constraint from non-upgradeable package requires installed instance)") + ] + , testGroup + "reject-unconstrained" + [ runTest $ + onlyConstrained $ + mkTest db12 "missing syb" ["E"] $ + solverFailure (isInfixOf "not a user-provided goal") + , runTest $ + onlyConstrained $ + mkTest db12 "all goals" ["E", "syb"] $ + solverSuccess [("E", 1), ("syb", 2)] + , runTest $ + onlyConstrained $ + mkTest db17 "backtracking" ["A", "B"] $ + solverSuccess [("A", 2), ("B", 1)] + , runTest $ + onlyConstrained $ + mkTest db17 "failure message" ["A"] $ + solverFailure $ + isInfixOf $ + "Could not resolve dependencies:\n" + ++ "[__0] trying: A-3.0.0 (user goal)\n" + ++ "[__1] next goal: C (dependency of A)\n" + ++ "[__1] fail (not a user-provided goal nor mentioned as a constraint, " + ++ "but reject-unconstrained-dependencies was set)\n" + ++ "[__1] fail (backjumping, conflict set: A, C)\n" + ++ "After searching the rest of the dependency tree exhaustively, " + ++ "these were the goals I've had most trouble fulfilling: A, C, B" + ] + , testGroup + "Cycles" + [ runTest $ mkTest db14 "simpleCycle1" ["A"] anySolverFailure + , runTest $ mkTest db14 "simpleCycle2" ["A", "B"] anySolverFailure + , runTest $ mkTest db14 "cycleWithFlagChoice1" ["C"] (solverSuccess [("C", 1), ("E", 1)]) + , runTest $ mkTest db15 "cycleThroughSetupDep1" ["A"] anySolverFailure + , runTest $ mkTest db15 "cycleThroughSetupDep2" ["B"] anySolverFailure + , runTest $ mkTest db15 "cycleThroughSetupDep3" ["C"] (solverSuccess [("C", 2), ("D", 1)]) + , runTest $ mkTest db15 "cycleThroughSetupDep4" ["D"] (solverSuccess [("D", 1)]) + , runTest $ mkTest db15 "cycleThroughSetupDep5" ["E"] (solverSuccess [("C", 2), ("D", 1), ("E", 1)]) + , runTest $ issue4161 "detect cycle between package and its setup script" + , runTest $ testCyclicDependencyErrorMessages "cyclic dependency error messages" + ] + , testGroup + "Extensions" + [ runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupported" ["A"] anySolverFailure + , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupportedIndirect" ["B"] anySolverFailure + , runTest $ mkTestExts [EnableExtension RankNTypes] dbExts1 "supported" ["A"] (solverSuccess [("A", 1)]) + , runTest $ mkTestExts (map EnableExtension [CPP, RankNTypes]) dbExts1 "supportedIndirect" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) + , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "disabledExtension" ["D"] anySolverFailure + , runTest $ mkTestExts (map EnableExtension [CPP, RankNTypes]) dbExts1 "disabledExtension" ["D"] anySolverFailure + , runTest $ mkTestExts (UnknownExtension "custom" : map EnableExtension [CPP, RankNTypes]) dbExts1 "supportedUnknown" ["E"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("E", 1)]) + ] + , testGroup + "Languages" + [ runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupported" ["A"] anySolverFailure + , runTest $ mkTestLangs [Haskell98, Haskell2010] dbLangs1 "supported" ["A"] (solverSuccess [("A", 1)]) + , runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupportedIndirect" ["B"] anySolverFailure + , runTest $ mkTestLangs [Haskell98, Haskell2010, UnknownLanguage "Haskell3000"] dbLangs1 "supportedUnknown" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) + ] + , testGroup + "Qualified Package Constraints" + [ runTest $ + mkTest dbConstraints "install latest versions without constraints" ["A", "B", "C"] $ + solverSuccess [("A", 7), ("B", 8), ("C", 9), ("D", 7), ("D", 8), ("D", 9)] + , let cs = [ExVersionConstraint (ScopeAnyQualifier "D") $ mkVersionRange 1 4] + in runTest $ + constraints cs $ + mkTest dbConstraints "force older versions with unqualified constraint" ["A", "B", "C"] $ + solverSuccess [("A", 1), ("B", 2), ("C", 3), ("D", 1), ("D", 2), ("D", 3)] + , let cs = + [ ExVersionConstraint (ScopeQualified P.QualToplevel "D") $ mkVersionRange 1 4 + , ExVersionConstraint (ScopeQualified (P.QualSetup "B") "D") $ mkVersionRange 4 7 + ] + in runTest $ + constraints cs $ + mkTest dbConstraints "force multiple versions with qualified constraints" ["A", "B", "C"] $ + solverSuccess [("A", 1), ("B", 5), ("C", 9), ("D", 1), ("D", 5), ("D", 9)] + , let cs = [ExVersionConstraint (ScopeAnySetupQualifier "D") $ mkVersionRange 1 4] + in runTest $ + constraints cs $ + mkTest dbConstraints "constrain package across setup scripts" ["A", "B", "C"] $ + solverSuccess [("A", 7), ("B", 2), ("C", 3), ("D", 2), ("D", 3), ("D", 7)] + ] + , testGroup + "Package Preferences" + [ runTest $ preferences [ExPkgPref "A" $ mkvrThis 1] $ mkTest db13 "selectPreferredVersionSimple" ["A"] (solverSuccess [("A", 1)]) + , runTest $ preferences [ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionSimple2" ["A"] (solverSuccess [("A", 2)]) + , runTest + $ preferences + [ ExPkgPref "A" $ mkvrOrEarlier 2 + , ExPkgPref "A" $ mkvrOrEarlier 1 + ] + $ mkTest db13 "selectPreferredVersionMultiple" ["A"] (solverSuccess [("A", 1)]) + , runTest + $ preferences + [ ExPkgPref "A" $ mkvrOrEarlier 1 + , ExPkgPref "A" $ mkvrOrEarlier 2 + ] + $ mkTest db13 "selectPreferredVersionMultiple2" ["A"] (solverSuccess [("A", 1)]) + , runTest + $ preferences + [ ExPkgPref "A" $ mkvrThis 1 + , ExPkgPref "A" $ mkvrThis 2 + ] + $ mkTest db13 "selectPreferredVersionMultiple3" ["A"] (solverSuccess [("A", 2)]) + , runTest + $ preferences + [ ExPkgPref "A" $ mkvrThis 1 + , ExPkgPref "A" $ mkvrOrEarlier 2 + ] + $ mkTest db13 "selectPreferredVersionMultiple4" ["A"] (solverSuccess [("A", 1)]) + ] + , testGroup + "Stanza Preferences" + [ runTest $ + mkTest dbStanzaPreferences1 "disable tests by default" ["pkg"] $ + solverSuccess [("pkg", 1)] + , runTest $ + preferences [ExStanzaPref "pkg" [TestStanzas]] $ + mkTest dbStanzaPreferences1 "enable tests with testing preference" ["pkg"] $ + solverSuccess [("pkg", 1), ("test-dep", 1)] + , runTest $ + preferences [ExStanzaPref "pkg" [TestStanzas]] $ + mkTest dbStanzaPreferences2 "disable testing when it's not possible" ["pkg"] $ + solverSuccess [("pkg", 1)] + , testStanzaPreference "test stanza preference" + ] + , testGroup + "Buildable Field" + [ testBuildable "avoid building component with unknown dependency" (ExAny "unknown") + , testBuildable "avoid building component with unknown extension" (ExExt (UnknownExtension "unknown")) + , testBuildable "avoid building component with unknown language" (ExLang (UnknownLanguage "unknown")) + , runTest $ mkTest dbBuildable1 "choose flags that set buildable to false" ["pkg"] (solverSuccess [("flag1-false", 1), ("flag2-true", 1), ("pkg", 1)]) + , runTest $ mkTest dbBuildable2 "choose version that sets buildable to false" ["A"] (solverSuccess [("A", 1), ("B", 2)]) + ] + , testGroup + "Pkg-config dependencies" + [ runTest $ mkTestPCDepends (Just []) dbPC1 "noPkgs" ["A"] anySolverFailure + , runTest $ mkTestPCDepends (Just [("pkgA", "0")]) dbPC1 "tooOld" ["A"] anySolverFailure + , runTest $ mkTestPCDepends (Just [("pkgA", "1.0.0"), ("pkgB", "1.0.0")]) dbPC1 "pruneNotFound" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) + , runTest $ mkTestPCDepends (Just [("pkgA", "1.0.0"), ("pkgB", "2.0.0")]) dbPC1 "chooseNewest" ["C"] (solverSuccess [("A", 1), ("B", 2), ("C", 1)]) + , runTest $ mkTestPCDepends Nothing dbPC1 "noPkgConfigFailure" ["A"] anySolverFailure + , runTest $ mkTestPCDepends Nothing dbPC1 "noPkgConfigSuccess" ["D"] (solverSuccess [("D", 1)]) + ] + , testGroup + "Independent goals" + [ runTest $ indep $ mkTest db16 "indepGoals1" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("E", 1)]) + , runTest $ testIndepGoals2 "indepGoals2" + , runTest $ testIndepGoals3 "indepGoals3" + , runTest $ testIndepGoals4 "indepGoals4" + , runTest $ testIndepGoals5 "indepGoals5 - fixed goal order" FixedGoalOrder + , runTest $ testIndepGoals5 "indepGoals5 - default goal order" DefaultGoalOrder + , runTest $ testIndepGoals6 "indepGoals6 - fixed goal order" FixedGoalOrder + , runTest $ testIndepGoals6 "indepGoals6 - default goal order" DefaultGoalOrder + ] + , -- Tests designed for the backjumping blog post + testGroup + "Backjumping" + [ runTest $ mkTest dbBJ1a "bj1a" ["A"] (solverSuccess [("A", 1), ("B", 1)]) + , runTest $ mkTest dbBJ1b "bj1b" ["A"] (solverSuccess [("A", 1), ("B", 1)]) + , runTest $ mkTest dbBJ1c "bj1c" ["A"] (solverSuccess [("A", 1), ("B", 1)]) + , runTest $ mkTest dbBJ2 "bj2" ["A"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) + , runTest $ mkTest dbBJ3 "bj3" ["A"] (solverSuccess [("A", 1), ("Ba", 1), ("C", 1)]) + , runTest $ mkTest dbBJ4 "bj4" ["A"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) + , runTest $ mkTest dbBJ5 "bj5" ["A"] (solverSuccess [("A", 1), ("B", 1), ("D", 1)]) + , runTest $ mkTest dbBJ6 "bj6" ["A"] (solverSuccess [("A", 1), ("B", 1)]) + , runTest $ mkTest dbBJ7 "bj7" ["A"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) + , runTest $ indep $ mkTest dbBJ8 "bj8" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) + ] + , testGroup + "main library dependencies" + [ let db = [Right $ exAvNoLibrary "A" 1 `withExe` exExe "exe" []] + in runTest $ + mkTest db "install build target without a library" ["A"] $ + solverSuccess [("A", 1)] + , let db = + [ Right $ exAv "A" 1 [ExAny "B"] + , Right $ exAvNoLibrary "B" 1 `withExe` exExe "exe" [] + ] + in runTest $ + mkTest db "reject build-depends dependency with no library" ["A"] $ + solverFailure (isInfixOf "rejecting: B-1.0.0 (does not contain library, which is required by A)") + , let exe = exExe "exe" [] + db = + [ Right $ exAv "A" 1 [ExAny "B"] + , Right $ exAvNoLibrary "B" 2 `withExe` exe + , Right $ exAv "B" 1 [] `withExe` exe + ] + in runTest $ + mkTest db "choose version of build-depends dependency that has a library" ["A"] $ + solverSuccess [("A", 1), ("B", 1)] + ] + , testGroup + "sub-library dependencies" + [ let db = + [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"] + , Right $ exAv "B" 1 [] + ] + in runTest $ + mkTest db "reject package that is missing required sub-library" ["A"] $ + solverFailure $ + isInfixOf $ + "rejecting: B-1.0.0 (does not contain library 'sub-lib', which is required by A)" + , let db = + [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"] + , Right $ exAvNoLibrary "B" 1 `withSubLibrary` exSubLib "sub-lib" [] + ] + in runTest $ + mkTest db "reject package with private but required sub-library" ["A"] $ + solverFailure $ + isInfixOf $ + "rejecting: B-1.0.0 (library 'sub-lib' is private, but it is required by A)" + , let db = + [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"] + , Right $ + exAvNoLibrary "B" 1 + `withSubLibrary` exSubLib "sub-lib" [ExFlagged "make-lib-private" (dependencies []) publicDependencies] + ] + in runTest $ + constraints [ExFlagConstraint (ScopeAnyQualifier "B") "make-lib-private" True] $ + mkTest db "reject package with sub-library made private by flag constraint" ["A"] $ + solverFailure $ + isInfixOf $ + "rejecting: B-1.0.0 (library 'sub-lib' is private, but it is required by A)" + , let db = + [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"] + , Right $ + exAvNoLibrary "B" 1 + `withSubLibrary` exSubLib "sub-lib" [ExFlagged "make-lib-private" (dependencies []) publicDependencies] + ] + in runTest $ + mkTest db "treat sub-library as visible even though flag choice could make it private" ["A"] $ + solverSuccess [("A", 1), ("B", 1)] + , let db = + [ Right $ exAv "A" 1 [ExAny "B"] + , Right $ exAv "B" 1 [] `withSubLibrary` exSubLib "sub-lib" [] + , Right $ exAv "C" 1 [ExSubLibAny "B" "sub-lib"] + ] + goals :: [ExampleVar] + goals = + [ P QualNone "A" + , P QualNone "B" + , P QualNone "C" + ] + in runTest $ + goalOrder goals $ + mkTest db "reject package that requires a private sub-library" ["A", "C"] $ + solverFailure $ + isInfixOf $ + "rejecting: C-1.0.0 (requires library 'sub-lib' from B, but the component is private)" + , let db = + [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib-v1"] + , Right $ exAv "B" 2 [] `withSubLibrary` ExSubLib "sub-lib-v2" publicDependencies + , Right $ exAv "B" 1 [] `withSubLibrary` ExSubLib "sub-lib-v1" publicDependencies + ] + in runTest $ + mkTest db "choose version of package containing correct sub-library" ["A"] $ + solverSuccess [("A", 1), ("B", 1)] + , let db = + [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"] + , Right $ exAv "B" 2 [] `withSubLibrary` ExSubLib "sub-lib" (dependencies []) + , Right $ exAv "B" 1 [] `withSubLibrary` ExSubLib "sub-lib" publicDependencies + ] + in runTest $ + mkTest db "choose version of package with public sub-library" ["A"] $ + solverSuccess [("A", 1), ("B", 1)] + ] + , -- build-tool-depends dependencies + testGroup + "build-tool-depends" + [ runTest $ mkTest dbBuildTools "simple exe dependency" ["A"] (solverSuccess [("A", 1), ("bt-pkg", 2)]) + , runTest $ + disableSolveExecutables $ + mkTest dbBuildTools "don't install build tool packages in legacy mode" ["A"] (solverSuccess [("A", 1)]) + , runTest $ mkTest dbBuildTools "flagged exe dependency" ["B"] (solverSuccess [("B", 1), ("bt-pkg", 2)]) + , runTest $ + enableAllTests $ + mkTest dbBuildTools "test suite exe dependency" ["C"] (solverSuccess [("C", 1), ("bt-pkg", 2)]) + , runTest $ + mkTest dbBuildTools "unknown exe" ["D"] $ + solverFailure (isInfixOf "does not contain executable 'unknown-exe', which is required by D") + , runTest $ + disableSolveExecutables $ + mkTest dbBuildTools "don't check for build tool executables in legacy mode" ["D"] $ + solverSuccess [("D", 1)] + , runTest $ + mkTest dbBuildTools "unknown build tools package error mentions package, not exe" ["E"] $ + solverFailure (isInfixOf "unknown package: E:unknown-pkg:exe.unknown-pkg (dependency of E)") + , runTest $ + mkTest dbBuildTools "unknown flagged exe" ["F"] $ + solverFailure (isInfixOf "does not contain executable 'unknown-exe', which is required by F +flagF") + , runTest $ + enableAllTests $ + mkTest dbBuildTools "unknown test suite exe" ["G"] $ + solverFailure (isInfixOf "does not contain executable 'unknown-exe', which is required by G *test") + , runTest $ + mkTest dbBuildTools "wrong exe for build tool package version" ["H"] $ + solverFailure $ + isInfixOf $ + -- The solver reports the version conflict when a version conflict + -- and an executable conflict apply to the same package version. + "[__1] rejecting: H:bt-pkg:exe.bt-pkg-4.0.0 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3.0.0)\n" + ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-3.0.0 (does not contain executable 'exe1', which is required by H)\n" + ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-2.0.0 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3.0.0)" + , runTest $ chooseExeAfterBuildToolsPackage True "choose exe after choosing its package - success" + , runTest $ chooseExeAfterBuildToolsPackage False "choose exe after choosing its package - failure" + , runTest $ rejectInstalledBuildToolPackage "reject installed package for build-tool dependency" + , runTest $ requireConsistentBuildToolVersions "build tool versions must be consistent within one package" + ] + , -- build-tools dependencies + testGroup + "legacy build-tools" + [ runTest $ mkTest dbLegacyBuildTools1 "bt1" ["A"] (solverSuccess [("A", 1), ("alex", 1)]) + , runTest $ + disableSolveExecutables $ + mkTest dbLegacyBuildTools1 "bt1 - don't install build tool packages in legacy mode" ["A"] (solverSuccess [("A", 1)]) + , runTest $ + mkTest dbLegacyBuildTools2 "bt2" ["A"] $ + solverFailure (isInfixOf "does not contain executable 'alex', which is required by A") + , runTest $ + disableSolveExecutables $ + mkTest dbLegacyBuildTools2 "bt2 - don't check for build tool executables in legacy mode" ["A"] (solverSuccess [("A", 1)]) + , runTest $ mkTest dbLegacyBuildTools3 "bt3" ["A"] (solverSuccess [("A", 1)]) + , runTest $ mkTest dbLegacyBuildTools4 "bt4" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("alex", 1), ("alex", 2)]) + , runTest $ mkTest dbLegacyBuildTools5 "bt5" ["B"] (solverSuccess [("A", 1), ("A", 2), ("B", 1), ("alex", 1)]) + , runTest $ mkTest dbLegacyBuildTools6 "bt6" ["A"] (solverSuccess [("A", 1), ("alex", 1), ("happy", 1)]) + ] + , -- internal dependencies + testGroup + "internal dependencies" + [ runTest $ mkTest dbIssue3775 "issue #3775" ["B"] (solverSuccess [("A", 2), ("B", 2), ("warp", 1)]) + ] + , -- tests for partial fix for issue #5325 + testGroup "Components that are unbuildable in the current environment" $ + let flagConstraint = ExFlagConstraint . ScopeAnyQualifier + in [ let db = [Right $ exAv "A" 1 [ExFlagged "build-lib" (dependencies []) unbuildableDependencies]] + in runTest $ + constraints [flagConstraint "A" "build-lib" False] $ + mkTest db "install unbuildable library" ["A"] $ + solverSuccess [("A", 1)] + , let db = + [ Right $ + exAvNoLibrary "A" 1 + `withExe` exExe "exe" [ExFlagged "build-exe" (dependencies []) unbuildableDependencies] + ] + in runTest $ + constraints [flagConstraint "A" "build-exe" False] $ + mkTest db "install unbuildable exe" ["A"] $ + solverSuccess [("A", 1)] + , let db = + [ Right $ exAv "A" 1 [ExAny "B"] + , Right $ exAv "B" 1 [ExFlagged "build-lib" (dependencies []) unbuildableDependencies] + ] + in runTest $ + constraints [flagConstraint "B" "build-lib" False] $ + mkTest db "reject library dependency with unbuildable library" ["A"] $ + solverFailure $ + isInfixOf $ + "rejecting: B-1.0.0 (library is not buildable in the " + ++ "current environment, but it is required by A)" + , let db = + [ Right $ exAv "A" 1 [ExBuildToolAny "B" "bt"] + , Right $ + exAv "B" 1 [ExFlagged "build-lib" (dependencies []) unbuildableDependencies] + `withExe` exExe "bt" [] + ] + in runTest $ + constraints [flagConstraint "B" "build-lib" False] $ + mkTest db "allow build-tool dependency with unbuildable library" ["A"] $ + solverSuccess [("A", 1), ("B", 1)] + , let db = + [ Right $ exAv "A" 1 [ExBuildToolAny "B" "bt"] + , Right $ + exAv "B" 1 [] + `withExe` exExe "bt" [ExFlagged "build-exe" (dependencies []) unbuildableDependencies] + ] + in runTest $ + constraints [flagConstraint "B" "build-exe" False] $ + mkTest db "reject build-tool dependency with unbuildable exe" ["A"] $ + solverFailure $ + isInfixOf $ + "rejecting: A:B:exe.B-1.0.0 (executable 'bt' is not " + ++ "buildable in the current environment, but it is required by A)" + , runTest $ + chooseUnbuildableExeAfterBuildToolsPackage + "choose unbuildable exe after choosing its package" + ] + , testGroup + "--fine-grained-conflicts" + [ -- Skipping a version because of a problematic dependency: + -- + -- When the solver explores A-4, it finds that it cannot satisfy B's + -- dependencies. This allows the solver to skip the subsequent + -- versions of A that also depend on B. + runTest $ + let db = + [ Right $ exAv "A" 4 [ExAny "B"] + , Right $ exAv "A" 3 [ExAny "B"] + , Right $ exAv "A" 2 [ExAny "B"] + , Right $ exAv "A" 1 [] + , Right $ exAv "B" 2 [ExAny "unknown1"] + , Right $ exAv "B" 1 [ExAny "unknown2"] + ] + msg = + [ "[__0] trying: A-4.0.0 (user goal)" + , "[__1] trying: B-2.0.0 (dependency of A)" + , "[__2] unknown package: unknown1 (dependency of B)" + , "[__2] fail (backjumping, conflict set: B, unknown1)" + , "[__1] trying: B-1.0.0" + , "[__2] unknown package: unknown2 (dependency of B)" + , "[__2] fail (backjumping, conflict set: B, unknown2)" + , "[__1] fail (backjumping, conflict set: A, B, unknown1, unknown2)" + , "[__0] skipping: A-3.0.0, A-2.0.0 (has the same characteristics that " + ++ "caused the previous version to fail: depends on 'B')" + , "[__0] trying: A-1.0.0" + , "[__1] done" + ] + in setVerbose $ + mkTest db "skip version due to problematic dependency" ["A"] $ + SolverResult (isInfixOf msg) $ + Right [("A", 1)] + , -- Skipping a version because of a restrictive constraint on a + -- dependency: + -- + -- The solver rejects A-4 because its constraint on B excludes B-1. + -- Then the solver is able to skip A-3 and A-2 because they also + -- exclude B-1, even though they don't have the exact same constraints + -- on B. + runTest $ + let db = + [ Right $ exAv "A" 4 [ExFix "B" 14] + , Right $ exAv "A" 3 [ExFix "B" 13] + , Right $ exAv "A" 2 [ExFix "B" 12] + , Right $ exAv "A" 1 [ExFix "B" 11] + , Right $ exAv "B" 11 [] + ] + msg = + [ "[__0] trying: A-4.0.0 (user goal)" + , "[__1] next goal: B (dependency of A)" + , "[__1] rejecting: B-11.0.0 (conflict: A => B==14.0.0)" + , "[__1] fail (backjumping, conflict set: A, B)" + , "[__0] skipping: A-3.0.0, A-2.0.0 (has the same characteristics that " + ++ "caused the previous version to fail: depends on 'B' but excludes " + ++ "version 11.0.0)" + , "[__0] trying: A-1.0.0" + , "[__1] next goal: B (dependency of A)" + , "[__1] trying: B-11.0.0" + , "[__2] done" + ] + in setVerbose $ + mkTest db "skip version due to restrictive constraint on its dependency" ["A"] $ + SolverResult (isInfixOf msg) $ + Right [("A", 1), ("B", 11)] + , -- This test tests the case where the solver chooses a version for one + -- package, B, before choosing a version for one of its reverse + -- dependencies, C. While the solver is exploring the subtree rooted + -- at B-3, it finds that C-2's dependency on B conflicts with B-3. + -- Then the solver is able to skip C-1, because it also excludes B-3. + -- + -- --fine-grained-conflicts could have a benefit in this case even + -- though the solver would have found the conflict between B-3 and C-1 + -- immediately after trying C-1 anyway. It prevents C-1 from + -- introducing any other conflicts which could increase the size of + -- the conflict set. + runTest $ + let db = + [ Right $ exAv "A" 1 [ExAny "B", ExAny "C"] + , Right $ exAv "B" 3 [] + , Right $ exAv "B" 2 [] + , Right $ exAv "B" 1 [] + , Right $ exAv "C" 2 [ExFix "B" 2] + , Right $ exAv "C" 1 [ExFix "B" 1] + ] + goals = [P QualNone pkg | pkg <- ["A", "B", "C"]] + expectedMsg = + [ "[__0] trying: A-1.0.0 (user goal)" + , "[__1] trying: B-3.0.0 (dependency of A)" + , "[__2] next goal: C (dependency of A)" + , "[__2] rejecting: C-2.0.0 (conflict: B==3.0.0, C => B==2.0.0)" + , "[__2] skipping: C-1.0.0 (has the same characteristics that caused the " + ++ "previous version to fail: excludes 'B' version 3.0.0)" + , "[__2] fail (backjumping, conflict set: A, B, C)" + , "[__1] trying: B-2.0.0" + , "[__2] next goal: C (dependency of A)" + , "[__2] trying: C-2.0.0" + , "[__3] done" + ] + in setVerbose $ + goalOrder goals $ + mkTest db "skip version that excludes dependency that was already chosen" ["A"] $ + SolverResult (isInfixOf expectedMsg) $ + Right [("A", 1), ("B", 2), ("C", 2)] + , -- This test tests how the solver merges conflicts when it has + -- multiple reasons to add a variable to the conflict set. In this + -- case, package A conflicts with B and C. The solver should take the + -- union of the conflicts and then only skip a version if it does not + -- resolve any of the conflicts. + -- + -- The solver rejects A-3 because it can't find consistent versions for + -- its two dependencies, B and C. Then it skips A-2 because A-2 also + -- depends on B and C. This test ensures that the solver considers + -- A-1 even though A-1 only resolves one of the conflicts (A-1 removes + -- the dependency on C). + runTest $ + let db = + [ Right $ exAv "A" 3 [ExAny "B", ExAny "C"] + , Right $ exAv "A" 2 [ExAny "B", ExAny "C"] + , Right $ exAv "A" 1 [ExAny "B"] + , Right $ exAv "B" 1 [ExFix "D" 1] + , Right $ exAv "C" 1 [ExFix "D" 2] + , Right $ exAv "D" 1 [] + , Right $ exAv "D" 2 [] + ] + goals = [P QualNone pkg | pkg <- ["A", "B", "C", "D"]] + msg = + [ "[__0] trying: A-3.0.0 (user goal)" + , "[__1] trying: B-1.0.0 (dependency of A)" + , "[__2] trying: C-1.0.0 (dependency of A)" + , "[__3] next goal: D (dependency of B)" + , "[__3] rejecting: D-2.0.0 (conflict: B => D==1.0.0)" + , "[__3] rejecting: D-1.0.0 (conflict: C => D==2.0.0)" + , "[__3] fail (backjumping, conflict set: B, C, D)" + , "[__2] fail (backjumping, conflict set: A, B, C, D)" + , "[__1] fail (backjumping, conflict set: A, B, C, D)" + , "[__0] skipping: A-2.0.0 (has the same characteristics that caused the " + ++ "previous version to fail: depends on 'B'; depends on 'C')" + , "[__0] trying: A-1.0.0" + , "[__1] trying: B-1.0.0 (dependency of A)" + , "[__2] next goal: D (dependency of B)" + , "[__2] rejecting: D-2.0.0 (conflict: B => D==1.0.0)" + , "[__2] trying: D-1.0.0" + , "[__3] done" + ] + in setVerbose $ + goalOrder goals $ + mkTest db "only skip a version if it resolves none of the previous conflicts" ["A"] $ + SolverResult (isInfixOf msg) $ + Right [("A", 1), ("B", 1), ("D", 1)] + , -- This test ensures that the solver log doesn't show all conflicts + -- that the solver encountered in a subtree. The solver should only + -- show the conflicts that are contained in the current conflict set. + -- + -- The goal order forces the solver to try A-4, encounter a conflict + -- with B-2, try B-1, and then try C. A-4 conflicts with the only + -- version of C, so the solver backjumps with a conflict set of + -- {A, C}. When the solver skips the next version of A, the log should + -- mention the conflict with C but not B. + runTest $ + let db = + [ Right $ exAv "A" 4 [ExFix "B" 1, ExFix "C" 1] + , Right $ exAv "A" 3 [ExFix "B" 1, ExFix "C" 1] + , Right $ exAv "A" 2 [ExFix "C" 1] + , Right $ exAv "A" 1 [ExFix "C" 2] + , Right $ exAv "B" 2 [] + , Right $ exAv "B" 1 [] + , Right $ exAv "C" 2 [] + ] + goals = [P QualNone pkg | pkg <- ["A", "B", "C"]] + msg = + [ "[__0] trying: A-4.0.0 (user goal)" + , "[__1] next goal: B (dependency of A)" + , "[__1] rejecting: B-2.0.0 (conflict: A => B==1.0.0)" + , "[__1] trying: B-1.0.0" + , "[__2] next goal: C (dependency of A)" + , "[__2] rejecting: C-2.0.0 (conflict: A => C==1.0.0)" + , "[__2] fail (backjumping, conflict set: A, C)" + , "[__0] skipping: A-3.0.0, A-2.0.0 (has the same characteristics that caused the " + ++ "previous version to fail: depends on 'C' but excludes version 2.0.0)" + , "[__0] trying: A-1.0.0" + , "[__1] next goal: C (dependency of A)" + , "[__1] trying: C-2.0.0" + , "[__2] done" + ] + in setVerbose $ + goalOrder goals $ + mkTest db "don't show conflicts that aren't part of the conflict set" ["A"] $ + SolverResult (isInfixOf msg) $ + Right [("A", 1), ("C", 2)] + , -- Tests that the conflict set is properly updated when a version is + -- skipped due to being excluded by one of its reverse dependencies' + -- constraints. + runTest $ + let db = + [ Right $ exAv "A" 2 [ExFix "B" 3] + , Right $ exAv "A" 1 [ExFix "B" 1] + , Right $ exAv "B" 2 [] + , Right $ exAv "B" 1 [] + ] + msg = + [ "[__0] trying: A-2.0.0 (user goal)" + , "[__1] next goal: B (dependency of A)" + , -- During this step, the solver adds A and B to the + -- conflict set, with the details of each package's + -- conflict: + -- + -- A: A's constraint rejected B-2. + -- B: B was rejected by A's B==3 constraint + "[__1] rejecting: B-2.0.0 (conflict: A => B==3.0.0)" + , -- When the solver skips B-1, it cannot simply reuse the + -- previous conflict set. It also needs to update A's + -- entry to say that A also rejected B-1. Otherwise, the + -- solver wouldn't know that A-1 could resolve one of + -- the conflicts encountered while exploring A-2. The + -- solver would skip A-1, even though it leads to the + -- solution. + "[__1] skipping: B-1.0.0 (has the same characteristics that caused " + ++ "the previous version to fail: excluded by constraint '==3.0.0' from 'A')" + , "[__1] fail (backjumping, conflict set: A, B)" + , "[__0] trying: A-1.0.0" + , "[__1] next goal: B (dependency of A)" + , "[__1] rejecting: B-2.0.0 (conflict: A => B==1.0.0)" + , "[__1] trying: B-1.0.0" + , "[__2] done" + ] + in setVerbose $ + mkTest db "update conflict set after skipping version - 1" ["A"] $ + SolverResult (isInfixOf msg) $ + Right [("A", 1), ("B", 1)] + , -- Tests that the conflict set is properly updated when a version is + -- skipped due to excluding a version of one of its dependencies. + -- This test is similar the previous one, with the goal order reversed. + runTest $ + let db = + [ Right $ exAv "A" 2 [] + , Right $ exAv "A" 1 [] + , Right $ exAv "B" 2 [ExFix "A" 3] + , Right $ exAv "B" 1 [ExFix "A" 1] + ] + goals = [P QualNone pkg | pkg <- ["A", "B"]] + msg = + [ "[__0] trying: A-2.0.0 (user goal)" + , "[__1] next goal: B (user goal)" + , "[__1] rejecting: B-2.0.0 (conflict: A==2.0.0, B => A==3.0.0)" + , "[__1] skipping: B-1.0.0 (has the same characteristics that caused " + ++ "the previous version to fail: excludes 'A' version 2.0.0)" + , "[__1] fail (backjumping, conflict set: A, B)" + , "[__0] trying: A-1.0.0" + , "[__1] next goal: B (user goal)" + , "[__1] rejecting: B-2.0.0 (conflict: A==1.0.0, B => A==3.0.0)" + , "[__1] trying: B-1.0.0" + , "[__2] done" + ] + in setVerbose $ + goalOrder goals $ + mkTest db "update conflict set after skipping version - 2" ["A", "B"] $ + SolverResult (isInfixOf msg) $ + Right [("A", 1), ("B", 1)] + ] + , -- Tests for the contents of the solver's log + testGroup + "Solver log" + [ -- See issue #3203. The solver should only choose a version for A once. + runTest $ + let db = [Right $ exAv "A" 1 []] + + p :: [String] -> Bool + p lg = + elem "targets: A" lg + && length (filter ("trying: A" `isInfixOf`) lg) == 1 + in setVerbose $ + mkTest db "deduplicate targets" ["A", "A"] $ + SolverResult p $ + Right [("A", 1)] + , runTest $ + let db = [Right $ exAv "A" 1 [ExAny "B"]] + msg = + "After searching the rest of the dependency tree exhaustively, " + ++ "these were the goals I've had most trouble fulfilling: A, B" + in mkTest db "exhaustive search failure message" ["A"] $ + solverFailure (isInfixOf msg) + , testSummarizedLog "show conflicts from final conflict set after exhaustive search" Nothing $ + "Could not resolve dependencies:\n" + ++ "[__0] trying: A-1.0.0 (user goal)\n" + ++ "[__1] unknown package: F (dependency of A)\n" + ++ "[__1] fail (backjumping, conflict set: A, F)\n" + ++ "After searching the rest of the dependency tree exhaustively, " + ++ "these were the goals I've had most trouble fulfilling: A, F" + , testSummarizedLog "show first conflicts after inexhaustive search" (Just 3) $ + "Could not resolve dependencies:\n" + ++ "[__0] trying: A-1.0.0 (user goal)\n" + ++ "[__1] trying: B-3.0.0 (dependency of A)\n" + ++ "[__2] unknown package: C (dependency of B)\n" + ++ "[__2] fail (backjumping, conflict set: B, C)\n" + ++ "Backjump limit reached (currently 3, change with --max-backjumps " + ++ "or try to run with --reorder-goals).\n" + , testSummarizedLog "don't show summarized log when backjump limit is too low" (Just 1) $ + "Backjump limit reached (currently 1, change with --max-backjumps " + ++ "or try to run with --reorder-goals).\n" + ++ "Failed to generate a summarized dependency solver log due to low backjump limit." + , testMinimizeConflictSet + "minimize conflict set with --minimize-conflict-set" + , testNoMinimizeConflictSet + "show original conflict set with --no-minimize-conflict-set" + , runTest $ + let db = + [ Right $ exAv "my-package" 1 [ExFix "other-package" 3] + , Left $ exInst "other-package" 2 "other-package-2.0.0" [] + ] + msg = "rejecting: other-package-2.0.0/installed-2.0.0" + in mkTest db "show full installed package version (issue #5892)" ["my-package"] $ + solverFailure (isInfixOf msg) + , runTest $ + let db = + [ Right $ exAv "my-package" 1 [ExFix "other-package" 3] + , Left $ exInst "other-package" 2 "other-package-AbCdEfGhIj0123456789" [] + ] + msg = "rejecting: other-package-2.0.0/installed-AbCdEfGhIj0123456789" + in mkTest db "show full installed package ABI hash (issue #5892)" ["my-package"] $ + solverFailure (isInfixOf msg) + ] + ] where - indep = independentGoals - mkvrThis = V.thisVersion . makeV - mkvrOrEarlier = V.orEarlierVersion . makeV - makeV v = V.mkVersion [v,0,0] + indep = independentGoals + mkvrThis = V.thisVersion . makeV + mkvrOrEarlier = V.orEarlierVersion . makeV + makeV v = V.mkVersion [v, 0, 0] data GoalOrder = FixedGoalOrder | DefaultGoalOrder @@ -802,23 +934,23 @@ data GoalOrder = FixedGoalOrder | DefaultGoalOrder db1 :: ExampleDb db1 = - let a = exInst "A" 1 "A-1" [] - in [ Left a - , Right $ exAv "B" 1 [ExAny "A"] - , Right $ exAv "B" 2 [ExAny "A"] - , Right $ exAv "C" 1 [ExFix "B" 1] - , Right $ exAv "D" 1 [ExFix "B" 2] - , Right $ exAv "E" 1 [ExAny "B"] - , Right $ exAv "F" 1 [ExFix "B" 1, ExAny "E"] - , Right $ exAv "G" 1 [ExFix "B" 2, ExAny "E"] - , Right $ exAv "Z" 1 [] - ] + let a = exInst "A" 1 "A-1" [] + in [ Left a + , Right $ exAv "B" 1 [ExAny "A"] + , Right $ exAv "B" 2 [ExAny "A"] + , Right $ exAv "C" 1 [ExFix "B" 1] + , Right $ exAv "D" 1 [ExFix "B" 2] + , Right $ exAv "E" 1 [ExAny "B"] + , Right $ exAv "F" 1 [ExFix "B" 1, ExAny "E"] + , Right $ exAv "G" 1 [ExFix "B" 2, ExAny "E"] + , Right $ exAv "Z" 1 [] + ] -- In this example, we _can_ install C and D as independent goals, but we have -- to pick two different versions for B (arbitrarily) db2 :: ExampleDb -db2 = [ - Right $ exAv "A" 1 [] +db2 = + [ Right $ exAv "A" 1 [] , Right $ exAv "A" 2 [] , Right $ exAv "B" 1 [ExAny "A"] , Right $ exAv "B" 2 [ExAny "A"] @@ -827,13 +959,13 @@ db2 = [ ] db3 :: ExampleDb -db3 = [ - Right $ exAv "A" 1 [] - , Right $ exAv "A" 2 [] - , Right $ exAv "B" 1 [exFlagged "flagB" [ExFix "A" 1] [ExFix "A" 2]] - , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"] - , Right $ exAv "D" 1 [ExFix "A" 2, ExAny "B"] - ] +db3 = + [ Right $ exAv "A" 1 [] + , Right $ exAv "A" 2 [] + , Right $ exAv "B" 1 [exFlagged "flagB" [ExFix "A" 1] [ExFix "A" 2]] + , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"] + , Right $ exAv "D" 1 [ExFix "A" 2, ExAny "B"] + ] -- | Like db3, but the flag picks a different package rather than a -- different package version @@ -868,22 +1000,23 @@ db3 = [ -- We will insist that 0.Ay will be linked to 1.Ay, and 0.Ax to 1.Ax, but since -- we only ever assign to one of these, these constraints are never broken. db4 :: ExampleDb -db4 = [ - Right $ exAv "Ax" 1 [] - , Right $ exAv "Ax" 2 [] - , Right $ exAv "Ay" 1 [] - , Right $ exAv "Ay" 2 [] - , Right $ exAv "B" 1 [exFlagged "flagB" [ExFix "Ax" 1] [ExFix "Ay" 1]] - , Right $ exAv "C" 1 [ExFix "Ax" 2, ExAny "B"] - , Right $ exAv "D" 1 [ExFix "Ay" 2, ExAny "B"] - ] +db4 = + [ Right $ exAv "Ax" 1 [] + , Right $ exAv "Ax" 2 [] + , Right $ exAv "Ay" 1 [] + , Right $ exAv "Ay" 2 [] + , Right $ exAv "B" 1 [exFlagged "flagB" [ExFix "Ax" 1] [ExFix "Ay" 1]] + , Right $ exAv "C" 1 [ExFix "Ax" 2, ExAny "B"] + , Right $ exAv "D" 1 [ExFix "Ay" 2, ExAny "B"] + ] -- | Simple database containing one package with a manual flag. dbManualFlags :: ExampleDb -dbManualFlags = [ - Right $ declareFlags [ExFlag "flag" True Manual] $ +dbManualFlags = + [ Right $ + declareFlags [ExFlag "flag" True Manual] $ exAv "pkg" 1 [exFlagged "flag" [ExAny "true-dep"] [ExAny "false-dep"]] - , Right $ exAv "true-dep" 1 [] + , Right $ exAv "true-dep" 1 [] , Right $ exAv "false-dep" 1 [] ] @@ -893,30 +1026,50 @@ dbManualFlags = [ dbSetupDepWithManualFlag :: ExampleDb dbSetupDepWithManualFlag = let bFlags = [ExFlag "flag" True Manual] - in [ - Right $ exAv "A" 1 [ExFix "B" 1] `withSetupDeps` [ExFix "B" 2] - , Right $ declareFlags bFlags $ - exAv "B" 1 [exFlagged "flag" [ExAny "b-1-true-dep"] - [ExAny "b-1-false-dep"]] - , Right $ declareFlags bFlags $ - exAv "B" 2 [exFlagged "flag" [ExAny "b-2-true-dep"] - [ExAny "b-2-false-dep"]] - , Right $ exAv "b-1-true-dep" 1 [] - , Right $ exAv "b-1-false-dep" 1 [] - , Right $ exAv "b-2-true-dep" 1 [] - , Right $ exAv "b-2-false-dep" 1 [] - ] + in [ Right $ exAv "A" 1 [ExFix "B" 1] `withSetupDeps` [ExFix "B" 2] + , Right $ + declareFlags bFlags $ + exAv + "B" + 1 + [ exFlagged + "flag" + [ExAny "b-1-true-dep"] + [ExAny "b-1-false-dep"] + ] + , Right $ + declareFlags bFlags $ + exAv + "B" + 2 + [ exFlagged + "flag" + [ExAny "b-2-true-dep"] + [ExAny "b-2-false-dep"] + ] + , Right $ exAv "b-1-true-dep" 1 [] + , Right $ exAv "b-1-false-dep" 1 [] + , Right $ exAv "b-2-true-dep" 1 [] + , Right $ exAv "b-2-false-dep" 1 [] + ] -- | A database similar to 'dbSetupDepWithManualFlag', except that the library -- and setup script both depend on B-1. B must be linked because of the Single -- Instance Restriction, and its flag can only have one value. dbLinkedSetupDepWithManualFlag :: ExampleDb -dbLinkedSetupDepWithManualFlag = [ - Right $ exAv "A" 1 [ExFix "B" 1] `withSetupDeps` [ExFix "B" 1] - , Right $ declareFlags [ExFlag "flag" True Manual] $ - exAv "B" 1 [exFlagged "flag" [ExAny "b-1-true-dep"] - [ExAny "b-1-false-dep"]] - , Right $ exAv "b-1-true-dep" 1 [] +dbLinkedSetupDepWithManualFlag = + [ Right $ exAv "A" 1 [ExFix "B" 1] `withSetupDeps` [ExFix "B" 1] + , Right $ + declareFlags [ExFlag "flag" True Manual] $ + exAv + "B" + 1 + [ exFlagged + "flag" + [ExAny "b-1-true-dep"] + [ExAny "b-1-false-dep"] + ] + , Right $ exAv "b-1-true-dep" 1 [] , Right $ exAv "b-1-false-dep" 1 [] ] @@ -936,8 +1089,8 @@ dbLinkedSetupDepWithManualFlag = [ -- * G is like E, but for version A-2. This means that if we cannot install -- E and G together, unless we regard them as independent goals. db5 :: ExampleDb -db5 = [ - Right $ exAv "A" 1 [] +db5 = + [ Right $ exAv "A" 1 [] , Right $ exAv "A" 2 [] , Right $ exAv "B" 1 [] , Right $ exAv "C" 1 [] `withTest` exTest "testC" [ExAny "A"] @@ -949,15 +1102,19 @@ db5 = [ -- Now the _dependencies_ have test suites -- + -- * Installing C is a simple example. C wants version 1 of A, but depends on + -- B, and B's testsuite depends on an any version of A. In this case we prefer -- to link (if we don't regard test suites as independent goals then of course -- linking here doesn't even come into it). + -- * Installing [C, D] means that we prefer to link B -- depending on how we + -- set things up, this means that we should also link their test suites. db6 :: ExampleDb -db6 = [ - Right $ exAv "A" 1 [] +db6 = + [ Right $ exAv "A" 1 [] , Right $ exAv "A" 2 [] , Right $ exAv "B" 1 [] `withTest` exTest "testA" [ExAny "A"] , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"] @@ -974,20 +1131,22 @@ db6 = [ -- dependency on B. testTestSuiteWithFlag :: String -> SolverTest testTestSuiteWithFlag name = - goalOrder goals $ enableAllTests $ mkTest db name ["A", "B"] $ - solverSuccess [("A", 1), ("B", 1)] + goalOrder goals $ + enableAllTests $ + mkTest db name ["A", "B"] $ + solverSuccess [("A", 1), ("B", 1)] where db :: ExampleDb - db = [ - Right $ exAv "A" 1 [] - `withTest` - exTest "test" [exFlagged "flag" [ExFix "B" 2] []] + db = + [ Right $ + exAv "A" 1 [] + `withTest` exTest "test" [exFlagged "flag" [ExFix "B" 2] []] , Right $ exAv "B" 1 [] ] goals :: [ExampleVar] - goals = [ - P QualNone "B" + goals = + [ P QualNone "B" , P QualNone "A" , F QualNone "A" "flag" , S QualNone "A" TestStanzas @@ -996,13 +1155,20 @@ testTestSuiteWithFlag name = -- Packages with setup dependencies -- -- Install.. + -- * B: Simple example, just make sure setup deps are taken into account at all + -- * C: Both the package and the setup script depend on any version of A. + -- In this case we prefer to link + -- * D: Variation on C.1 where the package requires a specific (not latest) + -- version but the setup dependency is not fixed. Again, we prefer to -- link (picking the older version) + -- * E: Variation on C.2 with the setup dependency the more inflexible. + -- Currently, in this case we do not see the opportunity to link because -- we consider setup dependencies after normal dependencies; we will -- pick A.2 for E, then realize we cannot link E.setup.A to A.2, and pick @@ -1012,24 +1178,26 @@ testTestSuiteWithFlag name = -- setups to package deps, rather than the other way around. (For example, -- if we change this ordering then the test for D would start to install -- two versions of A). + -- * F: The package and the setup script depend on different versions of A. + -- This will only work if setup dependencies are considered independent. db7 :: ExampleDb -db7 = [ - Right $ exAv "A" 1 [] +db7 = + [ Right $ exAv "A" 1 [] , Right $ exAv "A" 2 [] - , Right $ exAv "B" 1 [] `withSetupDeps` [ExAny "A"] - , Right $ exAv "C" 1 [ExAny "A" ] `withSetupDeps` [ExAny "A" ] - , Right $ exAv "D" 1 [ExFix "A" 1] `withSetupDeps` [ExAny "A" ] - , Right $ exAv "E" 1 [ExAny "A" ] `withSetupDeps` [ExFix "A" 1] + , Right $ exAv "B" 1 [] `withSetupDeps` [ExAny "A"] + , Right $ exAv "C" 1 [ExAny "A"] `withSetupDeps` [ExAny "A"] + , Right $ exAv "D" 1 [ExFix "A" 1] `withSetupDeps` [ExAny "A"] + , Right $ exAv "E" 1 [ExAny "A"] `withSetupDeps` [ExFix "A" 1] , Right $ exAv "F" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1] ] -- If we install C and D together (not as independent goals), we need to build -- both B.1 and B.2, both of which depend on A. db8 :: ExampleDb -db8 = [ - Right $ exAv "A" 1 [] +db8 = + [ Right $ exAv "A" 1 [] , Right $ exAv "B" 1 [ExAny "A"] , Right $ exAv "B" 2 [ExAny "A"] , Right $ exAv "C" 1 [] `withSetupDeps` [ExFix "B" 1] @@ -1038,31 +1206,31 @@ db8 = [ -- Extended version of `db8` so that we have nested setup dependencies db9 :: ExampleDb -db9 = db8 ++ [ - Right $ exAv "E" 1 [ExAny "C"] - , Right $ exAv "E" 2 [ExAny "D"] - , Right $ exAv "F" 1 [] `withSetupDeps` [ExFix "E" 1] - , Right $ exAv "G" 1 [] `withSetupDeps` [ExFix "E" 2] - ] +db9 = + db8 + ++ [ Right $ exAv "E" 1 [ExAny "C"] + , Right $ exAv "E" 2 [ExAny "D"] + , Right $ exAv "F" 1 [] `withSetupDeps` [ExFix "E" 1] + , Right $ exAv "G" 1 [] `withSetupDeps` [ExFix "E" 2] + ] -- Multiple already-installed packages with inter-dependencies, and one package -- (C) that depends on package A-1 for its setup script and package A-2 as a -- library dependency. db10 :: ExampleDb db10 = - let rts = exInst "rts" 1 "rts-inst" [] - ghc_prim = exInst "ghc-prim" 1 "ghc-prim-inst" [rts] - base = exInst "base" 1 "base-inst" [rts, ghc_prim] - a1 = exInst "A" 1 "A1-inst" [base] - a2 = exInst "A" 2 "A2-inst" [base] - in [ - Left rts - , Left ghc_prim - , Left base - , Left a1 - , Left a2 - , Right $ exAv "C" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1] - ] + let rts = exInst "rts" 1 "rts-inst" [] + ghc_prim = exInst "ghc-prim" 1 "ghc-prim-inst" [rts] + base = exInst "base" 1 "base-inst" [rts, ghc_prim] + a1 = exInst "A" 1 "A1-inst" [base] + a2 = exInst "A" 2 "A2-inst" [base] + in [ Left rts + , Left ghc_prim + , Left base + , Left a1 + , Left a2 + , Right $ exAv "C" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1] + ] -- | This database tests that a package's setup dependencies are correctly -- linked when the package is linked. See pull request #3268. @@ -1074,8 +1242,8 @@ db10 = -- independent. The solver should be able to choose D-1 for C's library and D-2 -- for C's setup script. dbSetupDeps :: ExampleDb -dbSetupDeps = [ - Right $ exAv "A" 1 [ExAny "C"] +dbSetupDeps = + [ Right $ exAv "A" 1 [ExAny "C"] , Right $ exAv "B" 1 [ExAny "C"] , Right $ exAv "C" 1 [ExFix "D" 1] `withSetupDeps` [ExFix "D" 2] , Right $ exAv "D" 1 [] @@ -1087,11 +1255,10 @@ db11 :: ExampleDb db11 = let base3 = exInst "base" 3 "base-3-inst" [base4] base4 = exInst "base" 4 "base-4-inst" [] - in [ - Left base3 - , Left base4 - , Right $ exAv "A" 1 [ExFix "base" 3] - ] + in [ Left base3 + , Left base4 + , Right $ exAv "A" 1 [ExFix "base" 3] + ] -- | Slightly more realistic version of db11 where base-3 depends on syb -- This means that if a package depends on base-3 and on syb, then they MUST @@ -1107,31 +1274,33 @@ db12 :: ExampleDb db12 = let base3 = exInst "base" 3 "base-3-inst" [base4, syb1] base4 = exInst "base" 4 "base-4-inst" [] - syb1 = exInst "syb" 1 "syb-1-inst" [base4] - in [ - Left base3 - , Left base4 - , Left syb1 - , Right $ exAv "syb" 2 [ExFix "base" 4] - , Right $ exAv "A" 1 [ExFix "base" 3, ExAny "syb"] - , Right $ exAv "B" 1 [ExFix "base" 4, ExAny "syb"] - , Right $ exAv "C" 1 [ExAny "A", ExAny "B"] - , Right $ exAv "D" 1 [ExFix "base" 3, ExFix "syb" 2] - , Right $ exAv "E" 1 [ExFix "base" 4, ExFix "syb" 2] - ] + syb1 = exInst "syb" 1 "syb-1-inst" [base4] + in [ Left base3 + , Left base4 + , Left syb1 + , Right $ exAv "syb" 2 [ExFix "base" 4] + , Right $ exAv "A" 1 [ExFix "base" 3, ExAny "syb"] + , Right $ exAv "B" 1 [ExFix "base" 4, ExAny "syb"] + , Right $ exAv "C" 1 [ExAny "A", ExAny "B"] + , Right $ exAv "D" 1 [ExFix "base" 3, ExFix "syb" 2] + , Right $ exAv "E" 1 [ExFix "base" 4, ExFix "syb" 2] + ] dbBase :: ExampleDb -dbBase = [ - Right $ exAv "base" 1 - [ExAny "ghc-prim", ExAny "integer-simple", ExAny "integer-gmp"] - , Right $ exAv "ghc-prim" 1 [] - , Right $ exAv "integer-simple" 1 [] - , Right $ exAv "integer-gmp" 1 [] - ] +dbBase = + [ Right $ + exAv + "base" + 1 + [ExAny "ghc-prim", ExAny "integer-simple", ExAny "integer-gmp"] + , Right $ exAv "ghc-prim" 1 [] + , Right $ exAv "integer-simple" 1 [] + , Right $ exAv "integer-gmp" 1 [] + ] dbNonupgrade :: ExampleDb -dbNonupgrade = [ - Left $ exInst "ghc" 1 "ghc-1" [] +dbNonupgrade = + [ Left $ exInst "ghc" 1 "ghc-1" [] , Left $ exInst "ghci" 1 "ghci-1" [] , Left $ exInst "ghc-boot" 1 "ghc-boot-1" [] , Right $ exAv "ghc" 2 [] @@ -1143,8 +1312,8 @@ dbNonupgrade = [ ] db13 :: ExampleDb -db13 = [ - Right $ exAv "A" 1 [] +db13 = + [ Right $ exAv "A" 1 [] , Right $ exAv "A" 2 [] , Right $ exAv "A" 3 [] ] @@ -1158,20 +1327,20 @@ db13 = [ -- behavior. dbConstraints :: ExampleDb dbConstraints = - [Right $ exAv "A" v [ExFix "D" v] | v <- [1, 4, 7]] - ++ [Right $ exAv "B" v [] `withSetupDeps` [ExFix "D" v] | v <- [2, 5, 8]] - ++ [Right $ exAv "C" v [] `withSetupDeps` [ExFix "D" v] | v <- [3, 6, 9]] - ++ [Right $ exAv "D" v [] | v <- [1..9]] + [Right $ exAv "A" v [ExFix "D" v] | v <- [1, 4, 7]] + ++ [Right $ exAv "B" v [] `withSetupDeps` [ExFix "D" v] | v <- [2, 5, 8]] + ++ [Right $ exAv "C" v [] `withSetupDeps` [ExFix "D" v] | v <- [3, 6, 9]] + ++ [Right $ exAv "D" v [] | v <- [1 .. 9]] dbStanzaPreferences1 :: ExampleDb -dbStanzaPreferences1 = [ - Right $ exAv "pkg" 1 [] `withTest` exTest "test" [ExAny "test-dep"] +dbStanzaPreferences1 = + [ Right $ exAv "pkg" 1 [] `withTest` exTest "test" [ExAny "test-dep"] , Right $ exAv "test-dep" 1 [] ] dbStanzaPreferences2 :: ExampleDb -dbStanzaPreferences2 = [ - Right $ exAv "pkg" 1 [] `withTest` exTest "test" [ExAny "unknown"] +dbStanzaPreferences2 = + [ Right $ exAv "pkg" 1 [] `withTest` exTest "test" [ExAny "unknown"] ] -- | This is a test case for a bug in stanza preferences (#3930). The solver @@ -1183,22 +1352,32 @@ dbStanzaPreferences2 = [ -- testing and failed to find the solution. testStanzaPreference :: String -> TestTree testStanzaPreference name = - let pkg = exAv "A" 1 [exFlagged "flag" - [] - [ExAny "unknown-pkg1"]] - `withTest` - exTest "test" [exFlagged "flag" - [ExAny "unknown-pkg2"] - []] - goals = [ - P QualNone "A" + let pkg = + exAv + "A" + 1 + [ exFlagged + "flag" + [] + [ExAny "unknown-pkg1"] + ] + `withTest` exTest + "test" + [ exFlagged + "flag" + [ExAny "unknown-pkg2"] + [] + ] + goals = + [ P QualNone "A" , F QualNone "A" "flag" , S QualNone "A" TestStanzas ] - in runTest $ goalOrder goals $ - preferences [ ExStanzaPref "A" [TestStanzas]] $ - mkTest [Right pkg] name ["A"] $ - solverSuccess [("A", 1)] + in runTest $ + goalOrder goals $ + preferences [ExStanzaPref "A" [TestStanzas]] $ + mkTest [Right pkg] name ["A"] $ + solverSuccess [("A", 1)] -- | Database with some cycles -- @@ -1206,8 +1385,8 @@ testStanzaPreference name = -- * There is a cycle C -> D -> C, but it can be broken by picking the -- right flag assignment. db14 :: ExampleDb -db14 = [ - Right $ exAv "A" 1 [ExAny "B"] +db14 = + [ Right $ exAv "A" 1 [ExAny "B"] , Right $ exAv "B" 1 [ExAny "A"] , Right $ exAv "C" 1 [exFlagged "flagC" [ExAny "D"] [ExAny "E"]] , Right $ exAv "D" 1 [ExAny "C"] @@ -1226,15 +1405,15 @@ db14 = [ -- Thus, we should be able to break this cycle even if we are installing package -- E, which explicitly depends on C-2.0. db15 :: ExampleDb -db15 = [ - -- First example (real cycle, no solution) - Right $ exAv "A" 1 [] `withSetupDeps` [ExAny "B"] - , Right $ exAv "B" 1 [ExAny "A"] - -- Second example (cycle can be broken by picking versions carefully) - , Left $ exInst "C" 1 "C-1-inst" [] - , Right $ exAv "C" 2 [] `withSetupDeps` [ExAny "D"] - , Right $ exAv "D" 1 [ExAny "C" ] - , Right $ exAv "E" 1 [ExFix "C" 2] +db15 = + [ -- First example (real cycle, no solution) + Right $ exAv "A" 1 [] `withSetupDeps` [ExAny "B"] + , Right $ exAv "B" 1 [ExAny "A"] + , -- Second example (cycle can be broken by picking versions carefully) + Left $ exInst "C" 1 "C-1-inst" [] + , Right $ exAv "C" 2 [] `withSetupDeps` [ExAny "D"] + , Right $ exAv "D" 1 [ExAny "C"] + , Right $ exAv "E" 1 [ExFix "C" 2] ] -- | Detect a cycle between a package and its setup script. @@ -1246,20 +1425,24 @@ db15 = [ -- package and then choose a different version for the setup dependency. issue4161 :: String -> SolverTest issue4161 name = - setVerbose $ mkTest db name ["target"] $ - SolverResult checkFullLog $ Right [("target", 1), ("time", 1), ("time", 2)] + setVerbose $ + mkTest db name ["target"] $ + SolverResult checkFullLog $ + Right [("target", 1), ("time", 1), ("time", 2)] where db :: ExampleDb - db = [ - Right $ exAv "target" 1 [ExFix "time" 2] - , Right $ exAv "time" 2 [] `withSetupDeps` [ExAny "time"] - , Right $ exAv "time" 1 [] + db = + [ Right $ exAv "target" 1 [ExFix "time" 2] + , Right $ exAv "time" 2 [] `withSetupDeps` [ExAny "time"] + , Right $ exAv "time" 1 [] ] checkFullLog :: [String] -> Bool - checkFullLog = any $ isInfixOf $ - "rejecting: time:setup.time~>time-2.0.0 (cyclic dependencies; " - ++ "conflict set: time:setup.time)" + checkFullLog = + any $ + isInfixOf $ + "rejecting: time:setup.time~>time-2.0.0 (cyclic dependencies; " + ++ "conflict set: time:setup.time)" -- | Packages pkg-A, pkg-B, and pkg-C form a cycle. The solver should backtrack -- as soon as it chooses the last package in the cycle, to avoid searching parts @@ -1267,13 +1450,14 @@ issue4161 name = -- it should fail with an error message describing the cycle. testCyclicDependencyErrorMessages :: String -> SolverTest testCyclicDependencyErrorMessages name = - goalOrder goals $ + goalOrder goals $ mkTest db name ["pkg-A"] $ - SolverResult checkFullLog $ Left checkSummarizedLog + SolverResult checkFullLog $ + Left checkSummarizedLog where db :: ExampleDb - db = [ - Right $ exAv "pkg-A" 1 [ExAny "pkg-B"] + db = + [ Right $ exAv "pkg-A" 1 [ExAny "pkg-B"] , Right $ exAv "pkg-B" 1 [ExAny "pkg-C"] , Right $ exAv "pkg-C" 1 [ExAny "pkg-A", ExAny "pkg-D"] , Right $ exAv "pkg-D" 1 [ExAny "pkg-E"] @@ -1284,15 +1468,15 @@ testCyclicDependencyErrorMessages name = -- cycle. It shouldn't try pkg-D or pkg-E. checkFullLog :: [String] -> Bool checkFullLog = - not . any (\l -> "pkg-D" `isInfixOf` l || "pkg-E" `isInfixOf` l) + not . any (\l -> "pkg-D" `isInfixOf` l || "pkg-E" `isInfixOf` l) checkSummarizedLog :: String -> Bool checkSummarizedLog = - isInfixOf "rejecting: pkg-C-1.0.0 (cyclic dependencies; conflict set: pkg-A, pkg-B, pkg-C)" + isInfixOf "rejecting: pkg-C-1.0.0 (cyclic dependencies; conflict set: pkg-A, pkg-B, pkg-C)" -- Solve for pkg-D and pkg-E last. goals :: [ExampleVar] - goals = [P QualNone ("pkg-" ++ [c]) | c <- ['A'..'E']] + goals = [P QualNone ("pkg-" ++ [c]) | c <- ['A' .. 'E']] -- | Check that the solver can backtrack after encountering the SIR (issue #2843) -- @@ -1312,28 +1496,35 @@ testCyclicDependencyErrorMessages name = -- would need two instances of C: one built against D-1.0 and one built against -- D-2.0. db16 :: ExampleDb -db16 = [ - Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1] - , Right $ exAv "B" 1 [ ExFix "D" 2 - , exFlagged "flagA" - [ExAny "C"] - [exFlagged "flagB" - [ExAny "E"] - [ExAny "C"]]] +db16 = + [ Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1] + , Right $ + exAv + "B" + 1 + [ ExFix "D" 2 + , exFlagged + "flagA" + [ExAny "C"] + [ exFlagged + "flagB" + [ExAny "E"] + [ExAny "C"] + ] + ] , Right $ exAv "C" 1 [ExAny "D"] , Right $ exAv "D" 1 [] , Right $ exAv "D" 2 [] , Right $ exAv "E" 1 [] ] - -- Try to get the solver to backtrack while satisfying -- reject-unconstrained-dependencies: both the first and last versions of A -- require packages outside the closed set, so it will have to try the -- middle one. db17 :: ExampleDb -db17 = [ - Right $ exAv "A" 1 [ExAny "C"] +db17 = + [ Right $ exAv "A" 1 [ExAny "C"] , Right $ exAv "A" 2 [ExAny "B"] , Right $ exAv "A" 3 [ExAny "C"] , Right $ exAv "B" 1 [] @@ -1351,13 +1542,15 @@ db17 = [ -- solver must backtrack to try D-1 for both 0.D and 1.D. testIndepGoals2 :: String -> SolverTest testIndepGoals2 name = - goalOrder goals $ independentGoals $ - enableAllTests $ mkTest db name ["A", "B"] $ - solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)] + goalOrder goals $ + independentGoals $ + enableAllTests $ + mkTest db name ["A", "B"] $ + solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)] where db :: ExampleDb - db = [ - Right $ exAv "A" 1 [ExAny "C"] `withTest` exTest "test" [ExFix "D" 1] + db = + [ Right $ exAv "A" 1 [ExAny "C"] `withTest` exTest "test" [ExFix "D" 1] , Right $ exAv "B" 1 [ExAny "C"] `withTest` exTest "test" [ExFix "D" 1] , Right $ exAv "C" 1 [ExAny "D"] , Right $ exAv "D" 1 [] @@ -1365,8 +1558,8 @@ testIndepGoals2 name = ] goals :: [ExampleVar] - goals = [ - P (QualIndep "A") "A" + goals = + [ P (QualIndep "A") "A" , P (QualIndep "A") "C" , P (QualIndep "A") "D" , P (QualIndep "B") "B" @@ -1393,14 +1586,22 @@ testIndepGoals2 name = -- D-1, and B depends on C-2, it is therefore important that C cannot depend -- on any version of D. db18 :: ExampleDb -db18 = [ - Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1] +db18 = + [ Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1] , Right $ exAv "B" 1 [ExAny "C", ExFix "D" 2] - , Right $ exAv "C" 1 [exFlagged "flagA" - [ExFix "D" 1, ExAny "E"] - [exFlagged "flagB" - [ExAny "F"] - [ExFix "D" 2, ExAny "G"]]] + , Right $ + exAv + "C" + 1 + [ exFlagged + "flagA" + [ExFix "D" 1, ExAny "E"] + [ exFlagged + "flagB" + [ExAny "F"] + [ExFix "D" 2, ExAny "G"] + ] + ] , Right $ exAv "D" 1 [] , Right $ exAv "D" 2 [] , Right $ exAv "E" 1 [] @@ -1414,34 +1615,54 @@ db18 = [ -- and -flagA. commonDependencyLogMessage :: String -> SolverTest commonDependencyLogMessage name = - mkTest db name ["A"] $ solverFailure $ isInfixOf $ + mkTest db name ["A"] $ + solverFailure $ + isInfixOf $ "[__0] trying: A-1.0.0 (user goal)\n" - ++ "[__1] next goal: B (dependency of A +/-flagA)\n" - ++ "[__1] rejecting: B-2.0.0 (conflict: A +/-flagA => B==1.0.0 || ==3.0.0)" + ++ "[__1] next goal: B (dependency of A +/-flagA)\n" + ++ "[__1] rejecting: B-2.0.0 (conflict: A +/-flagA => B==1.0.0 || ==3.0.0)" where db :: ExampleDb - db = [ - Right $ exAv "A" 1 [exFlagged "flagA" - [ExFix "B" 1] - [ExFix "B" 3]] + db = + [ Right $ + exAv + "A" + 1 + [ exFlagged + "flagA" + [ExFix "B" 1] + [ExFix "B" 3] + ] , Right $ exAv "B" 2 [] ] -- | Test lifting dependencies out of multiple levels of conditionals. twoLevelDeepCommonDependencyLogMessage :: String -> SolverTest twoLevelDeepCommonDependencyLogMessage name = - mkTest db name ["A"] $ solverFailure $ isInfixOf $ + mkTest db name ["A"] $ + solverFailure $ + isInfixOf $ "unknown package: B (dependency of A +/-flagA +/-flagB)" where db :: ExampleDb - db = [ - Right $ exAv "A" 1 [exFlagged "flagA" - [exFlagged "flagB" - [ExAny "B"] - [ExAny "B"]] - [exFlagged "flagB" - [ExAny "B"] - [ExAny "B"]]] + db = + [ Right $ + exAv + "A" + 1 + [ exFlagged + "flagA" + [ exFlagged + "flagB" + [ExAny "B"] + [ExAny "B"] + ] + [ exFlagged + "flagB" + [ExAny "B"] + [ExAny "B"] + ] + ] ] -- | Test handling nested conditionals that are controlled by the same flag. @@ -1451,15 +1672,23 @@ twoLevelDeepCommonDependencyLogMessage name = -- than backjumping past flagA. testBackjumpingWithCommonDependency :: String -> SolverTest testBackjumpingWithCommonDependency name = - mkTest db name ["A"] $ solverSuccess [("A", 1), ("B", 1)] + mkTest db name ["A"] $ solverSuccess [("A", 1), ("B", 1)] where db :: ExampleDb - db = [ - Right $ exAv "A" 1 [exFlagged "flagA" - [exFlagged "flagA" - [ExAny "unknown"] - [ExAny "unknown"]] - [ExAny "B"]] + db = + [ Right $ + exAv + "A" + 1 + [ exFlagged + "flagA" + [ exFlagged + "flagA" + [ExAny "unknown"] + [ExAny "unknown"] + ] + [ExAny "B"] + ] , Right $ exAv "B" 1 [] ] @@ -1489,12 +1718,13 @@ testBackjumpingWithCommonDependency name = -- > D F E testIndepGoals3 :: String -> SolverTest testIndepGoals3 name = - goalOrder goals $ independentGoals $ - mkTest db name ["D", "E", "F"] anySolverFailure + goalOrder goals $ + independentGoals $ + mkTest db name ["D", "E", "F"] anySolverFailure where db :: ExampleDb - db = [ - Right $ exAv "A" 1 [ExAny "C"] + db = + [ Right $ exAv "A" 1 [ExAny "C"] , Right $ exAv "B" 1 [ExAny "C"] , Right $ exAv "C" 1 [] , Right $ exAv "C" 2 [] @@ -1504,8 +1734,8 @@ testIndepGoals3 name = ] goals :: [ExampleVar] - goals = [ - P (QualIndep "D") "D" + goals = + [ P (QualIndep "D") "D" , P (QualIndep "D") "C" , P (QualIndep "D") "A" , P (QualIndep "E") "E" @@ -1531,13 +1761,15 @@ testIndepGoals3 name = -- changed. testIndepGoals4 :: String -> SolverTest testIndepGoals4 name = - goalOrder goals $ independentGoals $ - enableAllTests $ mkTest db name ["A", "B", "C"] $ - solverSuccess [("A",1), ("B",1), ("C",1), ("D",1), ("E",1), ("E",2)] + goalOrder goals $ + independentGoals $ + enableAllTests $ + mkTest db name ["A", "B", "C"] $ + solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("E", 1), ("E", 2)] where db :: ExampleDb - db = [ - Right $ exAv "A" 1 [ExFix "E" 2] + db = + [ Right $ exAv "A" 1 [ExFix "E" 2] , Right $ exAv "B" 1 [ExAny "D"] , Right $ exAv "C" 1 [ExAny "D"] `withTest` exTest "test" [ExFix "E" 1] , Right $ exAv "D" 1 [ExAny "E"] @@ -1546,8 +1778,8 @@ testIndepGoals4 name = ] goals :: [ExampleVar] - goals = [ - P (QualIndep "A") "A" + goals = + [ P (QualIndep "A") "A" , P (QualIndep "A") "E" , P (QualIndep "B") "B" , P (QualIndep "B") "D" @@ -1563,16 +1795,16 @@ testIndepGoals4 name = -- TODO: Currently we don't actually test the trace messages, and this particular -- test still succeeds. The trace can only be verified by hand. db21 :: ExampleDb -db21 = [ - Right $ exAv "A" 1 [ExAny "B"] +db21 = + [ Right $ exAv "A" 1 [ExAny "B"] , Right $ exAv "A" 2 [ExAny "C"] -- A-2.0 will be tried first, but C unknown , Right $ exAv "B" 1 [] ] -- | A variant of 'db21', which actually fails. db22 :: ExampleDb -db22 = [ - Right $ exAv "A" 1 [ExAny "B"] +db22 = + [ Right $ exAv "A" 1 [ExAny "B"] , Right $ exAv "A" 2 [ExAny "C"] ] @@ -1583,8 +1815,8 @@ db22 = [ -- is propagated up the tree to the level of A. Since the conflict set is the -- same at both levels, the solver only keeps one of the backjumping messages. db23 :: ExampleDb -db23 = [ - Right $ exAv "A" 1 [ExAny "B"] +db23 = + [ Right $ exAv "A" 1 [ExAny "B"] ] -- | Database for (unsuccessfully) trying to expose a bug in the handling @@ -1599,21 +1831,22 @@ db23 = [ -- Even if the SIR is not in place, if there is a solution, one will always -- be found, because without the SIR, linking is always optional, but never -- necessary. --- testIndepGoals5 :: String -> GoalOrder -> SolverTest testIndepGoals5 name fixGoalOrder = - case fixGoalOrder of - FixedGoalOrder -> goalOrder goals test - DefaultGoalOrder -> test + case fixGoalOrder of + FixedGoalOrder -> goalOrder goals test + DefaultGoalOrder -> test where test :: SolverTest - test = independentGoals $ mkTest db name ["X", "Y"] $ - solverSuccess - [("A", 1), ("A", 2), ("B", 1), ("C", 1), ("C", 2), ("X", 1), ("Y", 1)] + test = + independentGoals $ + mkTest db name ["X", "Y"] $ + solverSuccess + [("A", 1), ("A", 2), ("B", 1), ("C", 1), ("C", 2), ("X", 1), ("Y", 1)] db :: ExampleDb - db = [ - Right $ exAv "X" 1 [ExFix "C" 2, ExAny "A"] + db = + [ Right $ exAv "X" 1 [ExFix "C" 2, ExAny "A"] , Right $ exAv "Y" 1 [ExFix "C" 1, ExFix "A" 2] , Right $ exAv "A" 1 [] , Right $ exAv "A" 2 [ExAny "B"] @@ -1623,8 +1856,8 @@ testIndepGoals5 name fixGoalOrder = ] goals :: [ExampleVar] - goals = [ - P (QualIndep "X") "X" + goals = + [ P (QualIndep "X") "X" , P (QualIndep "X") "A" , P (QualIndep "X") "B" , P (QualIndep "X") "C" @@ -1637,18 +1870,20 @@ testIndepGoals5 name fixGoalOrder = -- | A simplified version of 'testIndepGoals5'. testIndepGoals6 :: String -> GoalOrder -> SolverTest testIndepGoals6 name fixGoalOrder = - case fixGoalOrder of - FixedGoalOrder -> goalOrder goals test - DefaultGoalOrder -> test + case fixGoalOrder of + FixedGoalOrder -> goalOrder goals test + DefaultGoalOrder -> test where test :: SolverTest - test = independentGoals $ mkTest db name ["X", "Y"] $ - solverSuccess - [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("X", 1), ("Y", 1)] + test = + independentGoals $ + mkTest db name ["X", "Y"] $ + solverSuccess + [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("X", 1), ("Y", 1)] db :: ExampleDb - db = [ - Right $ exAv "X" 1 [ExFix "B" 2, ExAny "A"] + db = + [ Right $ exAv "X" 1 [ExFix "B" 2, ExAny "A"] , Right $ exAv "Y" 1 [ExFix "B" 1, ExFix "A" 2] , Right $ exAv "A" 1 [] , Right $ exAv "A" 2 [ExAny "B"] @@ -1657,8 +1892,8 @@ testIndepGoals6 name fixGoalOrder = ] goals :: [ExampleVar] - goals = [ - P (QualIndep "X") "X" + goals = + [ P (QualIndep "X") "X" , P (QualIndep "X") "A" , P (QualIndep "X") "B" , P (QualIndep "Y") "Y" @@ -1667,8 +1902,8 @@ testIndepGoals6 name fixGoalOrder = ] dbExts1 :: ExampleDb -dbExts1 = [ - Right $ exAv "A" 1 [ExExt (EnableExtension RankNTypes)] +dbExts1 = + [ Right $ exAv "A" 1 [ExExt (EnableExtension RankNTypes)] , Right $ exAv "B" 1 [ExExt (EnableExtension CPP), ExAny "A"] , Right $ exAv "C" 1 [ExAny "B"] , Right $ exAv "D" 1 [ExExt (DisableExtension CPP), ExAny "B"] @@ -1676,8 +1911,8 @@ dbExts1 = [ ] dbLangs1 :: ExampleDb -dbLangs1 = [ - Right $ exAv "A" 1 [ExLang Haskell2010] +dbLangs1 = + [ Right $ exAv "A" 1 [ExLang Haskell2010] , Right $ exAv "B" 1 [ExLang Haskell98, ExAny "A"] , Right $ exAv "C" 1 [ExLang (UnknownLanguage "Haskell3000"), ExAny "B"] ] @@ -1687,17 +1922,25 @@ dbLangs1 = [ -- depend on "false-dep". testBuildable :: String -> ExampleDependency -> TestTree testBuildable testName unavailableDep = - runTest $ + runTest $ mkTestExtLangPC (Just []) (Just [Haskell98]) (Just []) db testName ["pkg"] expected where expected = solverSuccess [("false-dep", 1), ("pkg", 1)] - db = [ - Right $ exAv "pkg" 1 [exFlagged "enable-exe" - [ExAny "true-dep"] - [ExAny "false-dep"]] - `withExe` - exExe "exe" [ unavailableDep - , ExFlagged "enable-exe" (dependencies []) unbuildableDependencies ] + db = + [ Right $ + exAv + "pkg" + 1 + [ exFlagged + "enable-exe" + [ExAny "true-dep"] + [ExAny "false-dep"] + ] + `withExe` exExe + "exe" + [ unavailableDep + , ExFlagged "enable-exe" (dependencies []) unbuildableDependencies + ] , Right $ exAv "true-dep" 1 [] , Right $ exAv "false-dep" 1 [] ] @@ -1705,21 +1948,29 @@ testBuildable testName unavailableDep = -- | cabal must choose -flag1 +flag2 for "pkg", which requires packages -- "flag1-false" and "flag2-true". dbBuildable1 :: ExampleDb -dbBuildable1 = [ - Right $ exAv "pkg" 1 +dbBuildable1 = + [ Right $ + exAv + "pkg" + 1 [ exFlagged "flag1" [ExAny "flag1-true"] [ExAny "flag1-false"] - , exFlagged "flag2" [ExAny "flag2-true"] [ExAny "flag2-false"]] - `withExes` - [ exExe "exe1" - [ ExAny "unknown" - , ExFlagged "flag1" (dependencies []) unbuildableDependencies - , ExFlagged "flag2" (dependencies []) unbuildableDependencies] - , exExe "exe2" - [ ExAny "unknown" - , ExFlagged "flag1" - (dependencies []) - (dependencies [ExFlagged "flag2" unbuildableDependencies (dependencies [])])] - ] + , exFlagged "flag2" [ExAny "flag2-true"] [ExAny "flag2-false"] + ] + `withExes` [ exExe + "exe1" + [ ExAny "unknown" + , ExFlagged "flag1" (dependencies []) unbuildableDependencies + , ExFlagged "flag2" (dependencies []) unbuildableDependencies + ] + , exExe + "exe2" + [ ExAny "unknown" + , ExFlagged + "flag1" + (dependencies []) + (dependencies [ExFlagged "flag2" unbuildableDependencies (dependencies [])]) + ] + ] , Right $ exAv "flag1-true" 1 [] , Right $ exAv "flag1-false" 1 [] , Right $ exAv "flag2-true" 1 [] @@ -1728,23 +1979,24 @@ dbBuildable1 = [ -- | cabal must pick B-2 to avoid the unknown dependency. dbBuildable2 :: ExampleDb -dbBuildable2 = [ - Right $ exAv "A" 1 [ExAny "B"] +dbBuildable2 = + [ Right $ exAv "A" 1 [ExAny "B"] , Right $ exAv "B" 1 [ExAny "unknown"] - , Right $ exAv "B" 2 [] - `withExe` - exExe "exe" - [ ExAny "unknown" - , ExFlagged "disable-exe" unbuildableDependencies (dependencies []) - ] + , Right $ + exAv "B" 2 [] + `withExe` exExe + "exe" + [ ExAny "unknown" + , ExFlagged "disable-exe" unbuildableDependencies (dependencies []) + ] , Right $ exAv "B" 3 [ExAny "unknown"] ] -- | Package databases for testing @pkg-config@ dependencies. -- when no pkgconfig db is present, cabal must pick flag1 false and flag2 true to avoid the pkg dependency. dbPC1 :: ExampleDb -dbPC1 = [ - Right $ exAv "A" 1 [ExPkg ("pkgA", 1)] +dbPC1 = + [ Right $ exAv "A" 1 [ExPkg ("pkgA", 1)] , Right $ exAv "B" 1 [ExPkg ("pkgB", 1), ExAny "A"] , Right $ exAv "B" 2 [ExPkg ("pkgB", 2), ExAny "A"] , Right $ exAv "C" 1 [ExAny "B"] @@ -1759,11 +2011,14 @@ dbPC1 = [ -- conflict set to only show the conflict between A and F in the summarized log. testSummarizedLog :: String -> Maybe Int -> String -> TestTree testSummarizedLog testName mbj expectedMsg = - runTest $ maxBackjumps mbj $ goalOrder goals $ mkTest db testName ["A"] $ - solverFailure (== expectedMsg) + runTest $ + maxBackjumps mbj $ + goalOrder goals $ + mkTest db testName ["A"] $ + solverFailure (== expectedMsg) where - db = [ - Right $ exAv "A" 1 [ExAny "B", ExAny "F"] + db = + [ Right $ exAv "A" 1 [ExAny "B", ExAny "F"] , Right $ exAv "B" 3 [ExAny "C"] , Right $ exAv "B" 2 [ExAny "D"] , Right $ exAv "B" 1 [ExAny "E"] @@ -1774,8 +2029,8 @@ testSummarizedLog testName mbj expectedMsg = goals = [P QualNone pkg | pkg <- ["A", "B", "C", "D", "E", "F"]] dbMinimizeConflictSet :: ExampleDb -dbMinimizeConflictSet = [ - Right $ exAv "A" 3 [ExFix "B" 2, ExFix "C" 1, ExFix "D" 2] +dbMinimizeConflictSet = + [ Right $ exAv "A" 3 [ExFix "B" 2, ExFix "C" 1, ExFix "D" 2] , Right $ exAv "A" 2 [ExFix "B" 1, ExFix "C" 2, ExFix "D" 2] , Right $ exAv "A" 1 [ExFix "B" 1, ExFix "C" 1, ExFix "D" 2] , Right $ exAv "B" 1 [] @@ -1792,31 +2047,35 @@ dbMinimizeConflictSet = [ -- only mention A and D. testMinimizeConflictSet :: String -> TestTree testMinimizeConflictSet testName = - runTest $ minimizeConflictSet $ goalOrder goals $ setVerbose $ - mkTest dbMinimizeConflictSet testName ["A"] $ - SolverResult checkFullLog (Left (== expectedMsg)) + runTest $ + minimizeConflictSet $ + goalOrder goals $ + setVerbose $ + mkTest dbMinimizeConflictSet testName ["A"] $ + SolverResult checkFullLog (Left (== expectedMsg)) where checkFullLog :: [String] -> Bool - checkFullLog = containsInOrder [ - "[__0] fail (backjumping, conflict set: A, B, C, D)" - , "Found no solution after exhaustively searching the dependency tree. " - ++ "Rerunning the dependency solver to minimize the conflict set ({A, B, C, D})." - , "Trying to remove variable \"A\" from the conflict set." - , "Failed to remove \"A\" from the conflict set. Continuing with {A, B, C, D}." - , "Trying to remove variable \"B\" from the conflict set." - , "Successfully removed \"B\" from the conflict set. Continuing with {A, D}." - , "Trying to remove variable \"D\" from the conflict set." - , "Failed to remove \"D\" from the conflict set. Continuing with {A, D}." - ] + checkFullLog = + containsInOrder + [ "[__0] fail (backjumping, conflict set: A, B, C, D)" + , "Found no solution after exhaustively searching the dependency tree. " + ++ "Rerunning the dependency solver to minimize the conflict set ({A, B, C, D})." + , "Trying to remove variable \"A\" from the conflict set." + , "Failed to remove \"A\" from the conflict set. Continuing with {A, B, C, D}." + , "Trying to remove variable \"B\" from the conflict set." + , "Successfully removed \"B\" from the conflict set. Continuing with {A, D}." + , "Trying to remove variable \"D\" from the conflict set." + , "Failed to remove \"D\" from the conflict set. Continuing with {A, D}." + ] expectedMsg = - "Could not resolve dependencies:\n" - ++ "[__0] trying: A-3.0.0 (user goal)\n" - ++ "[__1] next goal: D (dependency of A)\n" - ++ "[__1] rejecting: D-1.0.0 (conflict: A => D==2.0.0)\n" - ++ "[__1] fail (backjumping, conflict set: A, D)\n" - ++ "After searching the rest of the dependency tree exhaustively, these " - ++ "were the goals I've had most trouble fulfilling: A (5), D (4)" + "Could not resolve dependencies:\n" + ++ "[__0] trying: A-3.0.0 (user goal)\n" + ++ "[__1] next goal: D (dependency of A)\n" + ++ "[__1] rejecting: D-1.0.0 (conflict: A => D==2.0.0)\n" + ++ "[__1] fail (backjumping, conflict set: A, D)\n" + ++ "After searching the rest of the dependency tree exhaustively, these " + ++ "were the goals I've had most trouble fulfilling: A (5), D (4)" goals :: [ExampleVar] goals = [P QualNone pkg | pkg <- ["A", "B", "C", "D"]] @@ -1827,20 +2086,22 @@ testMinimizeConflictSet testName = -- suggest rerunning with --minimize-conflict-set. testNoMinimizeConflictSet :: String -> TestTree testNoMinimizeConflictSet testName = - runTest $ goalOrder goals $ setVerbose $ - mkTest dbMinimizeConflictSet testName ["A"] $ - solverFailure (== expectedMsg) + runTest $ + goalOrder goals $ + setVerbose $ + mkTest dbMinimizeConflictSet testName ["A"] $ + solverFailure (== expectedMsg) where expectedMsg = - "Could not resolve dependencies:\n" - ++ "[__0] trying: A-3.0.0 (user goal)\n" - ++ "[__1] next goal: B (dependency of A)\n" - ++ "[__1] rejecting: B-1.0.0 (conflict: A => B==2.0.0)\n" - ++ "[__1] fail (backjumping, conflict set: A, B)\n" - ++ "After searching the rest of the dependency tree exhaustively, " - ++ "these were the goals I've had most trouble fulfilling: " - ++ "A (7), B (2), C (2), D (2)\n" - ++ "Try running with --minimize-conflict-set to improve the error message." + "Could not resolve dependencies:\n" + ++ "[__0] trying: A-3.0.0 (user goal)\n" + ++ "[__1] next goal: B (dependency of A)\n" + ++ "[__1] rejecting: B-1.0.0 (conflict: A => B==2.0.0)\n" + ++ "[__1] fail (backjumping, conflict set: A, B)\n" + ++ "After searching the rest of the dependency tree exhaustively, " + ++ "these were the goals I've had most trouble fulfilling: " + ++ "A (7), B (2), C (2), D (2)\n" + ++ "Try running with --minimize-conflict-set to improve the error message." goals :: [ExampleVar] goals = [P QualNone pkg | pkg <- ["A", "B", "C", "D"]] @@ -1851,16 +2112,16 @@ testNoMinimizeConflictSet testName = -- | Motivate conflict sets dbBJ1a :: ExampleDb -dbBJ1a = [ - Right $ exAv "A" 1 [ExFix "B" 1] +dbBJ1a = + [ Right $ exAv "A" 1 [ExFix "B" 1] , Right $ exAv "A" 2 [ExFix "B" 2] , Right $ exAv "B" 1 [] ] -- | Show that we can skip some decisions dbBJ1b :: ExampleDb -dbBJ1b = [ - Right $ exAv "A" 1 [ExFix "B" 1] +dbBJ1b = + [ Right $ exAv "A" 1 [ExFix "B" 1] , Right $ exAv "A" 2 [ExFix "B" 2, ExAny "C"] , Right $ exAv "B" 1 [] , Right $ exAv "C" 1 [] @@ -1869,36 +2130,36 @@ dbBJ1b = [ -- | Motivate why both A and B need to be in the conflict set dbBJ1c :: ExampleDb -dbBJ1c = [ - Right $ exAv "A" 1 [ExFix "B" 1] +dbBJ1c = + [ Right $ exAv "A" 1 [ExFix "B" 1] , Right $ exAv "B" 1 [] , Right $ exAv "B" 2 [] ] -- | Motivate the need for accumulating conflict sets while we walk the tree dbBJ2 :: ExampleDb -dbBJ2 = [ - Right $ exAv "A" 1 [ExFix "B" 1] - , Right $ exAv "A" 2 [ExFix "B" 2] - , Right $ exAv "B" 1 [ExFix "C" 1] - , Right $ exAv "B" 2 [ExFix "C" 2] - , Right $ exAv "C" 1 [] +dbBJ2 = + [ Right $ exAv "A" 1 [ExFix "B" 1] + , Right $ exAv "A" 2 [ExFix "B" 2] + , Right $ exAv "B" 1 [ExFix "C" 1] + , Right $ exAv "B" 2 [ExFix "C" 2] + , Right $ exAv "C" 1 [] ] -- | Motivate the need for `QGoalReason` dbBJ3 :: ExampleDb -dbBJ3 = [ - Right $ exAv "A" 1 [ExAny "Ba"] - , Right $ exAv "A" 2 [ExAny "Bb"] +dbBJ3 = + [ Right $ exAv "A" 1 [ExAny "Ba"] + , Right $ exAv "A" 2 [ExAny "Bb"] , Right $ exAv "Ba" 1 [ExFix "C" 1] , Right $ exAv "Bb" 1 [ExFix "C" 2] - , Right $ exAv "C" 1 [] + , Right $ exAv "C" 1 [] ] -- | `QGOalReason` not unique dbBJ4 :: ExampleDb -dbBJ4 = [ - Right $ exAv "A" 1 [ExAny "B", ExAny "C"] +dbBJ4 = + [ Right $ exAv "A" 1 [ExAny "B", ExAny "C"] , Right $ exAv "B" 1 [ExAny "C"] , Right $ exAv "C" 1 [] ] @@ -1908,8 +2169,8 @@ dbBJ4 = [ -- This example probably won't be in the blog post itself but as a separate -- bug report (#3409) dbBJ5 :: ExampleDb -dbBJ5 = [ - Right $ exAv "A" 1 [exFlagged "flagA" [ExFix "B" 1] [ExFix "C" 1]] +dbBJ5 = + [ Right $ exAv "A" 1 [exFlagged "flagA" [ExFix "B" 1] [ExFix "C" 1]] , Right $ exAv "B" 1 [ExFix "D" 1] , Right $ exAv "C" 1 [ExFix "D" 2] , Right $ exAv "D" 1 [] @@ -1917,8 +2178,8 @@ dbBJ5 = [ -- | Conflict sets for cycles dbBJ6 :: ExampleDb -dbBJ6 = [ - Right $ exAv "A" 1 [ExAny "B"] +dbBJ6 = + [ Right $ exAv "A" 1 [ExAny "B"] , Right $ exAv "B" 1 [] , Right $ exAv "B" 2 [ExAny "C"] , Right $ exAv "C" 1 [ExAny "A"] @@ -1926,8 +2187,8 @@ dbBJ6 = [ -- | Conflicts not unique dbBJ7 :: ExampleDb -dbBJ7 = [ - Right $ exAv "A" 1 [ExAny "B", ExFix "C" 1] +dbBJ7 = + [ Right $ exAv "A" 1 [ExAny "B", ExFix "C" 1] , Right $ exAv "B" 1 [ExFix "C" 1] , Right $ exAv "C" 1 [] , Right $ exAv "C" 2 [] @@ -1935,8 +2196,8 @@ dbBJ7 = [ -- | Conflict sets for SIR (C shared subgoal of independent goals A, B) dbBJ8 :: ExampleDb -dbBJ8 = [ - Right $ exAv "A" 1 [ExAny "C"] +dbBJ8 = + [ Right $ exAv "A" 1 [ExAny "C"] , Right $ exAv "B" 1 [ExAny "C"] , Right $ exAv "C" 1 [] ] @@ -1947,18 +2208,31 @@ dbBJ8 = [ -- | Multiple packages depending on exes from 'bt-pkg'. dbBuildTools :: ExampleDb -dbBuildTools = [ - Right $ exAv "A" 1 [ExBuildToolAny "bt-pkg" "exe1"] - , Right $ exAv "B" 1 [exFlagged "flagB" [ExAny "unknown"] - [ExBuildToolAny "bt-pkg" "exe1"]] +dbBuildTools = + [ Right $ exAv "A" 1 [ExBuildToolAny "bt-pkg" "exe1"] + , Right $ + exAv + "B" + 1 + [ exFlagged + "flagB" + [ExAny "unknown"] + [ExBuildToolAny "bt-pkg" "exe1"] + ] , Right $ exAv "C" 1 [] `withTest` exTest "testC" [ExBuildToolAny "bt-pkg" "exe1"] , Right $ exAv "D" 1 [ExBuildToolAny "bt-pkg" "unknown-exe"] , Right $ exAv "E" 1 [ExBuildToolAny "unknown-pkg" "exe1"] - , Right $ exAv "F" 1 [exFlagged "flagF" [ExBuildToolAny "bt-pkg" "unknown-exe"] - [ExAny "unknown"]] + , Right $ + exAv + "F" + 1 + [ exFlagged + "flagF" + [ExBuildToolAny "bt-pkg" "unknown-exe"] + [ExAny "unknown"] + ] , Right $ exAv "G" 1 [] `withTest` exTest "testG" [ExBuildToolAny "bt-pkg" "unknown-exe"] , Right $ exAv "H" 1 [ExBuildToolFix "bt-pkg" "exe1" 3] - , Right $ exAv "bt-pkg" 4 [] , Right $ exAv "bt-pkg" 3 [] `withExe` exExe "exe2" [] , Right $ exAv "bt-pkg" 2 [] `withExe` exExe "exe1" [] @@ -1969,13 +2243,15 @@ dbBuildTools = [ -- dependency. rejectInstalledBuildToolPackage :: String -> SolverTest rejectInstalledBuildToolPackage name = - mkTest db name ["A"] $ solverFailure $ isInfixOf $ - "rejecting: A:B:exe.B-1.0.0/installed-1 " - ++ "(does not contain executable 'exe', which is required by A)" + mkTest db name ["A"] $ + solverFailure $ + isInfixOf $ + "rejecting: A:B:exe.B-1.0.0/installed-1 " + ++ "(does not contain executable 'exe', which is required by A)" where db :: ExampleDb - db = [ - Right $ exAv "A" 1 [ExBuildToolAny "B" "exe"] + db = + [ Right $ exAv "A" 1 [ExBuildToolAny "B" "exe"] , Left $ exInst "B" 1 "B-1" [] ] @@ -1991,26 +2267,36 @@ rejectInstalledBuildToolPackage name = -- for B, one for exe1 and another for exe2. chooseExeAfterBuildToolsPackage :: Bool -> String -> SolverTest chooseExeAfterBuildToolsPackage shouldSucceed name = - goalOrder goals $ mkTest db name ["A"] $ + goalOrder goals $ + mkTest db name ["A"] $ if shouldSucceed - then solverSuccess [("A", 1), ("B", 1)] - else solverFailure $ isInfixOf $ - "rejecting: A:+flagA (requires executable 'exe2' from A:B:exe.B, " - ++ "but the component does not exist)" + then solverSuccess [("A", 1), ("B", 1)] + else + solverFailure $ + isInfixOf $ + "rejecting: A:+flagA (requires executable 'exe2' from A:B:exe.B, " + ++ "but the component does not exist)" where db :: ExampleDb - db = [ - Right $ exAv "A" 1 [ ExBuildToolAny "B" "exe1" - , exFlagged "flagA" [ExBuildToolAny "B" "exe2"] - [ExAny "unknown"]] - , Right $ exAv "B" 1 [] - `withExes` - [exExe exe [] | exe <- if shouldSucceed then ["exe1", "exe2"] else ["exe1"]] + db = + [ Right $ + exAv + "A" + 1 + [ ExBuildToolAny "B" "exe1" + , exFlagged + "flagA" + [ExBuildToolAny "B" "exe2"] + [ExAny "unknown"] + ] + , Right $ + exAv "B" 1 [] + `withExes` [exExe exe [] | exe <- if shouldSucceed then ["exe1", "exe2"] else ["exe1"]] ] goals :: [ExampleVar] - goals = [ - P QualNone "A" + goals = + [ P QualNone "A" , P (QualExe "A" "B") "B" , F QualNone "A" "flagA" ] @@ -2021,14 +2307,21 @@ chooseExeAfterBuildToolsPackage shouldSucceed name = -- qualifier. requireConsistentBuildToolVersions :: String -> SolverTest requireConsistentBuildToolVersions name = - mkTest db name ["A"] $ solverFailure $ isInfixOf $ + mkTest db name ["A"] $ + solverFailure $ + isInfixOf $ "[__1] rejecting: A:B:exe.B-2.0.0 (conflict: A => A:B:exe.B (exe exe1)==1.0.0)\n" - ++ "[__1] rejecting: A:B:exe.B-1.0.0 (conflict: A => A:B:exe.B (exe exe2)==2.0.0)" + ++ "[__1] rejecting: A:B:exe.B-1.0.0 (conflict: A => A:B:exe.B (exe exe2)==2.0.0)" where db :: ExampleDb - db = [ - Right $ exAv "A" 1 [ ExBuildToolFix "B" "exe1" 1 - , ExBuildToolFix "B" "exe2" 2 ] + db = + [ Right $ + exAv + "A" + 1 + [ ExBuildToolFix "B" "exe1" 1 + , ExBuildToolFix "B" "exe2" 2 + ] , Right $ exAv "B" 2 [] `withExes` exes , Right $ exAv "B" 1 [] `withExes` exes ] @@ -2040,27 +2333,36 @@ requireConsistentBuildToolVersions name = -- instead of missing. chooseUnbuildableExeAfterBuildToolsPackage :: String -> SolverTest chooseUnbuildableExeAfterBuildToolsPackage name = - constraints [ExFlagConstraint (ScopeAnyQualifier "B") "build-bt2" False] $ + constraints [ExFlagConstraint (ScopeAnyQualifier "B") "build-bt2" False] $ goalOrder goals $ - mkTest db name ["A"] $ solverFailure $ isInfixOf $ - "rejecting: A:+use-bt2 (requires executable 'bt2' from A:B:exe.B, but " - ++ "the component is not buildable in the current environment)" + mkTest db name ["A"] $ + solverFailure $ + isInfixOf $ + "rejecting: A:+use-bt2 (requires executable 'bt2' from A:B:exe.B, but " + ++ "the component is not buildable in the current environment)" where db :: ExampleDb - db = [ - Right $ exAv "A" 1 [ ExBuildToolAny "B" "bt1" - , exFlagged "use-bt2" [ExBuildToolAny "B" "bt2"] - [ExAny "unknown"]] - , Right $ exAvNoLibrary "B" 1 - `withExes` - [ exExe "bt1" [] - , exExe "bt2" [ExFlagged "build-bt2" (dependencies []) unbuildableDependencies] - ] + db = + [ Right $ + exAv + "A" + 1 + [ ExBuildToolAny "B" "bt1" + , exFlagged + "use-bt2" + [ExBuildToolAny "B" "bt2"] + [ExAny "unknown"] + ] + , Right $ + exAvNoLibrary "B" 1 + `withExes` [ exExe "bt1" [] + , exExe "bt2" [ExFlagged "build-bt2" (dependencies []) unbuildableDependencies] + ] ] goals :: [ExampleVar] - goals = [ - P QualNone "A" + goals = + [ P QualNone "A" , P (QualExe "A" "B") "B" , F QualNone "A" "use-bt2" ] @@ -2069,70 +2371,70 @@ chooseUnbuildableExeAfterBuildToolsPackage name = Databases for legacy build-tools -------------------------------------------------------------------------------} dbLegacyBuildTools1 :: ExampleDb -dbLegacyBuildTools1 = [ - Right $ exAv "alex" 1 [] `withExe` exExe "alex" [], - Right $ exAv "A" 1 [ExLegacyBuildToolAny "alex"] +dbLegacyBuildTools1 = + [ Right $ exAv "alex" 1 [] `withExe` exExe "alex" [] + , Right $ exAv "A" 1 [ExLegacyBuildToolAny "alex"] ] -- Test that a recognized build tool dependency specifies the name of both the -- package and the executable. This db has no solution. dbLegacyBuildTools2 :: ExampleDb -dbLegacyBuildTools2 = [ - Right $ exAv "alex" 1 [] `withExe` exExe "other-exe" [], - Right $ exAv "other-package" 1 [] `withExe` exExe "alex" [], - Right $ exAv "A" 1 [ExLegacyBuildToolAny "alex"] +dbLegacyBuildTools2 = + [ Right $ exAv "alex" 1 [] `withExe` exExe "other-exe" [] + , Right $ exAv "other-package" 1 [] `withExe` exExe "alex" [] + , Right $ exAv "A" 1 [ExLegacyBuildToolAny "alex"] ] -- Test that build-tools on a random thing doesn't matter (only -- the ones we recognize need to be in db) dbLegacyBuildTools3 :: ExampleDb -dbLegacyBuildTools3 = [ - Right $ exAv "A" 1 [ExLegacyBuildToolAny "otherdude"] +dbLegacyBuildTools3 = + [ Right $ exAv "A" 1 [ExLegacyBuildToolAny "otherdude"] ] -- Test that we can solve for different versions of executables dbLegacyBuildTools4 :: ExampleDb -dbLegacyBuildTools4 = [ - Right $ exAv "alex" 1 [] `withExe` exExe "alex" [], - Right $ exAv "alex" 2 [] `withExe` exExe "alex" [], - Right $ exAv "A" 1 [ExLegacyBuildToolFix "alex" 1], - Right $ exAv "B" 1 [ExLegacyBuildToolFix "alex" 2], - Right $ exAv "C" 1 [ExAny "A", ExAny "B"] +dbLegacyBuildTools4 = + [ Right $ exAv "alex" 1 [] `withExe` exExe "alex" [] + , Right $ exAv "alex" 2 [] `withExe` exExe "alex" [] + , Right $ exAv "A" 1 [ExLegacyBuildToolFix "alex" 1] + , Right $ exAv "B" 1 [ExLegacyBuildToolFix "alex" 2] + , Right $ exAv "C" 1 [ExAny "A", ExAny "B"] ] -- Test that exe is not related to library choices dbLegacyBuildTools5 :: ExampleDb -dbLegacyBuildTools5 = [ - Right $ exAv "alex" 1 [ExFix "A" 1] `withExe` exExe "alex" [], - Right $ exAv "A" 1 [], - Right $ exAv "A" 2 [], - Right $ exAv "B" 1 [ExLegacyBuildToolFix "alex" 1, ExFix "A" 2] +dbLegacyBuildTools5 = + [ Right $ exAv "alex" 1 [ExFix "A" 1] `withExe` exExe "alex" [] + , Right $ exAv "A" 1 [] + , Right $ exAv "A" 2 [] + , Right $ exAv "B" 1 [ExLegacyBuildToolFix "alex" 1, ExFix "A" 2] ] -- Test that build-tools on build-tools works dbLegacyBuildTools6 :: ExampleDb -dbLegacyBuildTools6 = [ - Right $ exAv "alex" 1 [] `withExe` exExe "alex" [], - Right $ exAv "happy" 1 [ExLegacyBuildToolAny "alex"] `withExe` exExe "happy" [], - Right $ exAv "A" 1 [ExLegacyBuildToolAny "happy"] +dbLegacyBuildTools6 = + [ Right $ exAv "alex" 1 [] `withExe` exExe "alex" [] + , Right $ exAv "happy" 1 [ExLegacyBuildToolAny "alex"] `withExe` exExe "happy" [] + , Right $ exAv "A" 1 [ExLegacyBuildToolAny "happy"] ] -- Test that build-depends on library/executable package works. -- Extracted from https://github.com/haskell/cabal/issues/3775 dbIssue3775 :: ExampleDb -dbIssue3775 = [ - Right $ exAv "warp" 1 [], - -- NB: the warp build-depends refers to the package, not the internal +dbIssue3775 = + [ Right $ exAv "warp" 1 [] + , -- NB: the warp build-depends refers to the package, not the internal -- executable! - Right $ exAv "A" 2 [ExFix "warp" 1] `withExe` exExe "warp" [ExAny "A"], - Right $ exAv "B" 2 [ExAny "A", ExAny "warp"] + Right $ exAv "A" 2 [ExFix "warp" 1] `withExe` exExe "warp" [ExAny "A"] + , Right $ exAv "B" 2 [ExAny "A", ExAny "warp"] ] -- | Returns true if the second list contains all elements of the first list, in -- order. containsInOrder :: Eq a => [a] -> [a] -> Bool -containsInOrder [] _ = True -containsInOrder _ [] = False -containsInOrder (x:xs) (y:ys) +containsInOrder [] _ = True +containsInOrder _ [] = False +containsInOrder (x : xs) (y : ys) | x == y = containsInOrder xs ys - | otherwise = containsInOrder (x:xs) ys + | otherwise = containsInOrder (x : xs) ys diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/WeightedPSQ.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/WeightedPSQ.hs index 9c4f60b2f7b..5cab4f1bdd8 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/WeightedPSQ.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/WeightedPSQ.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ParallelListComp #-} -module UnitTests.Distribution.Solver.Modular.WeightedPSQ ( - tests + +module UnitTests.Distribution.Solver.Modular.WeightedPSQ + ( tests ) where import qualified Distribution.Solver.Modular.WeightedPSQ as W @@ -9,44 +10,43 @@ import Data.List (sort) import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase, (@?=)) -import Test.Tasty.QuickCheck (Blind(..), testProperty) +import Test.Tasty.QuickCheck (Blind (..), testProperty) tests :: [TestTree] -tests = [ - testProperty "'toList . fromList' preserves elements" $ \xs -> - sort (xs :: [(Int, Char, Bool)]) == sort (W.toList (W.fromList xs)) - +tests = + [ testProperty "'toList . fromList' preserves elements" $ \xs -> + sort (xs :: [(Int, Char, Bool)]) == sort (W.toList (W.fromList xs)) , testProperty "'toList . fromList' sorts stably" $ \xs -> - let indexAsValue :: [(Int, (), Int)] - indexAsValue = [(x, (), i) | x <- xs | i <- [0..]] - in isSorted $ W.toList $ W.fromList indexAsValue - + let indexAsValue :: [(Int, (), Int)] + indexAsValue = [(x, (), i) | x <- xs | i <- [0 ..]] + in isSorted $ W.toList $ W.fromList indexAsValue , testProperty "'mapWeightsWithKey' sorts by weight" $ \xs (Blind f) -> - isSorted $ W.weights $ - W.mapWeightsWithKey (f :: Int -> Int -> Int) $ - W.fromList (xs :: [(Int, Int, Int)]) - + isSorted $ + W.weights $ + W.mapWeightsWithKey (f :: Int -> Int -> Int) $ + W.fromList (xs :: [(Int, Int, Int)]) , testCase "applying 'mapWeightsWithKey' twice sorts twice" $ - let indexAsKey :: [((), Int, ())] - indexAsKey = [((), i, ()) | i <- [0..10]] - actual = W.toList $ - W.mapWeightsWithKey (\_ _ -> ()) $ - W.mapWeightsWithKey (\i _ -> -i) $ -- should not be ignored - W.fromList indexAsKey - in reverse indexAsKey @?= actual - + let indexAsKey :: [((), Int, ())] + indexAsKey = [((), i, ()) | i <- [0 .. 10]] + actual = + W.toList $ + W.mapWeightsWithKey (\_ _ -> ()) $ + W.mapWeightsWithKey (\i _ -> -i) $ -- should not be ignored + W.fromList indexAsKey + in reverse indexAsKey @?= actual , testProperty "'union' sorts by weight" $ \xs ys -> - isSorted $ W.weights $ - W.union (W.fromList xs) (W.fromList (ys :: [(Int, Int, Int)])) - + isSorted $ + W.weights $ + W.union (W.fromList xs) (W.fromList (ys :: [(Int, Int, Int)])) , testProperty "'union' preserves elements" $ \xs ys -> - let union = W.union (W.fromList xs) - (W.fromList (ys :: [(Int, Int, Int)])) - in sort (xs ++ ys) == sort (W.toList union) - + let union = + W.union + (W.fromList xs) + (W.fromList (ys :: [(Int, Int, Int)])) + in sort (xs ++ ys) == sort (W.toList union) , testCase "'lookup' returns first occurrence" $ - let xs = W.fromList [((), False, 'A'), ((), True, 'C'), ((), True, 'B')] - in Just 'C' @?= W.lookup True xs + let xs = W.fromList [((), False, 'A'), ((), True, 'C'), ((), True, 'B')] + in Just 'C' @?= W.lookup True xs ] isSorted :: Ord a => [a] -> Bool diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Types/OptionalStanza.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Types/OptionalStanza.hs index 96679e60011..8f068d2ae53 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Types/OptionalStanza.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Types/OptionalStanza.hs @@ -1,7 +1,8 @@ {-# LANGUAGE CPP #-} -module UnitTests.Distribution.Solver.Types.OptionalStanza ( - tests, -) where + +module UnitTests.Distribution.Solver.Types.OptionalStanza + ( tests + ) where import Distribution.Solver.Types.OptionalStanza import UnitTests.Distribution.Client.ArbitraryInstances () @@ -15,19 +16,18 @@ import Data.Monoid tests :: [TestTree] tests = - [ testProperty "fromList . toList = id" $ \xs -> - optStanzaSetFromList (optStanzaSetToList xs) === xs - , testProperty "member x (insert x xs) = True" $ \x xs -> - optStanzaSetMember x (optStanzaSetInsert x xs) === True - , testProperty "member x (singleton y) = (x == y)" $ \x y -> - optStanzaSetMember x (optStanzaSetSingleton y) === (x == y) - , testProperty "(subset xs ys, member x xs) ==> member x ys" $ \x xs ys -> - optStanzaSetIsSubset xs ys && optStanzaSetMember x xs ==> + [ testProperty "fromList . toList = id" $ \xs -> + optStanzaSetFromList (optStanzaSetToList xs) === xs + , testProperty "member x (insert x xs) = True" $ \x xs -> + optStanzaSetMember x (optStanzaSetInsert x xs) === True + , testProperty "member x (singleton y) = (x == y)" $ \x y -> + optStanzaSetMember x (optStanzaSetSingleton y) === (x == y) + , testProperty "(subset xs ys, member x xs) ==> member x ys" $ \x xs ys -> + optStanzaSetIsSubset xs ys && optStanzaSetMember x xs ==> optStanzaSetMember x ys - - , testProperty "tabulate index = id" $ \xs -> - optStanzaTabulate (optStanzaIndex xs) === (xs :: OptionalStanzaMap Int) - , testProperty "keysFilteredByValue" $ \xs -> - let set i = if optStanzaIndex xs i then optStanzaSetSingleton i else mempty - in optStanzaKeysFilteredByValue id xs === set TestStanzas `mappend` set BenchStanzas - ] + , testProperty "tabulate index = id" $ \xs -> + optStanzaTabulate (optStanzaIndex xs) === (xs :: OptionalStanzaMap Int) + , testProperty "keysFilteredByValue" $ \xs -> + let set i = if optStanzaIndex xs i then optStanzaSetSingleton i else mempty + in optStanzaKeysFilteredByValue id xs === set TestStanzas `mappend` set BenchStanzas + ] diff --git a/cabal-install/tests/UnitTests/Options.hs b/cabal-install/tests/UnitTests/Options.hs index 1edce035542..232f80a2711 100644 --- a/cabal-install/tests/UnitTests/Options.hs +++ b/cabal-install/tests/UnitTests/Options.hs @@ -1,10 +1,12 @@ {-# LANGUAGE DeriveDataTypeable #-} -module UnitTests.Options ( OptionShowSolverLog(..) - , OptionMtimeChangeDelay(..) - , RunNetworkTests(..) - , extraOptions ) - where +module UnitTests.Options + ( OptionShowSolverLog (..) + , OptionMtimeChangeDelay (..) + , RunNetworkTests (..) + , extraOptions + ) +where import Data.Proxy import Data.Typeable @@ -23,30 +25,32 @@ extraOptions = ] newtype OptionShowSolverLog = OptionShowSolverLog Bool - deriving Typeable + deriving (Typeable) instance IsOption OptionShowSolverLog where - defaultValue = OptionShowSolverLog False - parseValue = fmap OptionShowSolverLog . safeReadBool - optionName = return "show-solver-log" - optionHelp = return "Show full log from the solver" + defaultValue = OptionShowSolverLog False + parseValue = fmap OptionShowSolverLog . safeReadBool + optionName = return "show-solver-log" + optionHelp = return "Show full log from the solver" optionCLParser = flagCLParser Nothing (OptionShowSolverLog True) newtype OptionMtimeChangeDelay = OptionMtimeChangeDelay Int - deriving Typeable + deriving (Typeable) instance IsOption OptionMtimeChangeDelay where - defaultValue = OptionMtimeChangeDelay 0 - parseValue = fmap OptionMtimeChangeDelay . safeRead - optionName = return "mtime-change-delay" - optionHelp = return $ "How long to wait before attempting to detect" - ++ "file modification, in microseconds" + defaultValue = OptionMtimeChangeDelay 0 + parseValue = fmap OptionMtimeChangeDelay . safeRead + optionName = return "mtime-change-delay" + optionHelp = + return $ + "How long to wait before attempting to detect" + ++ "file modification, in microseconds" newtype RunNetworkTests = RunNetworkTests Bool - deriving Typeable + deriving (Typeable) instance IsOption RunNetworkTests where defaultValue = RunNetworkTests True - parseValue = fmap RunNetworkTests . safeReadBool - optionName = return "run-network-tests" - optionHelp = return "Run tests that need network access (default true)." + parseValue = fmap RunNetworkTests . safeReadBool + optionName = return "run-network-tests" + optionHelp = return "Run tests that need network access (default true)." diff --git a/cabal-install/tests/UnitTests/TempTestDir.hs b/cabal-install/tests/UnitTests/TempTestDir.hs index 77db49bd7aa..5a9d410e53a 100644 --- a/cabal-install/tests/UnitTests/TempTestDir.hs +++ b/cabal-install/tests/UnitTests/TempTestDir.hs @@ -1,36 +1,34 @@ {-# LANGUAGE CPP #-} -module UnitTests.TempTestDir ( - withTestDir, removeDirectoryRecursiveHack +module UnitTests.TempTestDir + ( withTestDir + , removeDirectoryRecursiveHack ) where -import Distribution.Verbosity import Distribution.Compat.Internal.TempFile (createTempDirectory) import Distribution.Simple.Utils (warn) +import Distribution.Verbosity -import Control.Monad (when) -import Control.Exception (bracket, try, throwIO) import Control.Concurrent (threadDelay) +import Control.Exception (bracket, throwIO, try) +import Control.Monad (when) -import System.IO.Error import System.Directory +import System.IO.Error #if !(MIN_VERSION_directory(1,2,7)) import System.FilePath (()) #endif import qualified System.Info (os) - -- | Much like 'withTemporaryDirectory' but with a number of hacks to make -- sure on windows that we can clean up the directory at the end. --- -withTestDir :: Verbosity -> String -> (FilePath -> IO a) -> IO a +withTestDir :: Verbosity -> String -> (FilePath -> IO a) -> IO a withTestDir verbosity template action = do - systmpdir <- getTemporaryDirectory - bracket - (createTempDirectory systmpdir template) - (removeDirectoryRecursiveHack verbosity) - action - + systmpdir <- getTemporaryDirectory + bracket + (createTempDirectory systmpdir template) + (removeDirectoryRecursiveHack verbosity) + action -- | On Windows, file locks held by programs we run (in this case VCSs) -- are not always released prior to completing process termination! @@ -42,40 +40,42 @@ withTestDir verbosity template action = do -- In addition, on Windows a file that is not writable also cannot be deleted, -- so we must try setting the permissions to readable before deleting files. -- Some VCS tools on Windows create files with read-only attributes. --- removeDirectoryRecursiveHack :: Verbosity -> FilePath -> IO () removeDirectoryRecursiveHack verbosity dir | isWindows = go 1 where isWindows = System.Info.os == "mingw32" - limit = 3 + limit = 3 go :: Int -> IO () go n = do res <- try $ removePathForcibly dir case res of Left e - -- wait a second and try again - | isPermissionError e && n < limit -> do + -- wait a second and try again + | isPermissionError e && n < limit -> do threadDelay 1000000 - go (n+1) + go (n + 1) - -- but if we hit the limt warn and fail. + -- but if we hit the limt warn and fail. | isPermissionError e -> do - warn verbosity $ "Windows file locking hack: hit the retry limit " - ++ show limit ++ " while trying to remove " ++ dir + warn verbosity $ + "Windows file locking hack: hit the retry limit " + ++ show limit + ++ " while trying to remove " + ++ dir throwIO e - -- or it's a different error fail. + -- or it's a different error fail. | otherwise -> throwIO e - Right () -> when (n > 1) $ - warn verbosity $ "Windows file locking hack: had to try " - ++ show n ++ " times to remove " ++ dir - + warn verbosity $ + "Windows file locking hack: had to try " + ++ show n + ++ " times to remove " + ++ dir removeDirectoryRecursiveHack _ dir = removeDirectoryRecursive dir - #if !(MIN_VERSION_directory(1,2,7)) -- A simplified version that ought to work for our use case here, and does -- not rely on directory internals. @@ -101,4 +101,3 @@ removePathForcibly path = do writable = True } #endif - From 827ee18e0864d9774eb2f4d687e2eca69a61d478 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?H=C3=A9cate=20Moonlight?= Date: Wed, 24 May 2023 09:34:10 +0200 Subject: [PATCH 2/3] Formatting configuration --- .git-blame-ignore-revs | 7 ++++ .githooks/pre-push | 23 +++++++++++++ .github/PULL_REQUEST_TEMPLATE.md | 2 +- .github/workflows/linting.yml | 23 +++++++++++++ .github/workflows/whitespace.yml | 57 -------------------------------- CONTRIBUTING.md | 34 +++---------------- Makefile | 19 +++++++++++ fourmolu.yaml | 14 ++++++++ 8 files changed, 91 insertions(+), 88 deletions(-) create mode 100755 .githooks/pre-push create mode 100644 .github/workflows/linting.yml delete mode 100644 .github/workflows/whitespace.yml create mode 100644 fourmolu.yaml diff --git a/.git-blame-ignore-revs b/.git-blame-ignore-revs index dfdfeeafa64..72441222a44 100644 --- a/.git-blame-ignore-revs +++ b/.git-blame-ignore-revs @@ -1,3 +1,9 @@ +# 2023 +######################################## + +# Format the source with fourmolu +10a14397e7295f79bb65ff505e52895f4864270a + # 2022 ######################################## @@ -33,3 +39,4 @@ b0333ec5b73ba8f7a18223b203d999b38c75281d # Move source files under 'src/'. 52d506bb4e25489f40cb5eb594dda5595aeb93ed + diff --git a/.githooks/pre-push b/.githooks/pre-push new file mode 100755 index 00000000000..599d13015f9 --- /dev/null +++ b/.githooks/pre-push @@ -0,0 +1,23 @@ +#!/usr/bin/env bash + +set -euxo pipefail + +if [[ $(uname -s) != "Linux" ]] +then + PROCS=$(sysctl -n hw.logicalcpu) +else + PROCS=$(nproc) +fi + +if which fourmolu > /dev/null ; then + find Cabal Cabal-syntax cabal-install -name '*.hs' -print0 \ + ! -path Cabal-syntax/src/Distribution/Fields/Lexer.hs \ + ! -path Cabal-syntax/src/Distribution/SPDX/LicenseExceptionId.hs \ + ! -path Cabal-syntax/src/Distribution/SPDX/LicenseId.hs \ + ! -path Cabal/src/Distribution/Simple/Build/Macros/Z.hs \ + ! -path Cabal/src/Distribution/Simple/Build/PathsModule/Z.hs \ + | xargs -P "${PROCS}" -I {} fourmolu -q --mode check {} +else + echo "Fourmolu not found, aborting." + exit 1 +fi diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md index b85e12b020e..9027e90ef6d 100644 --- a/.github/PULL_REQUEST_TEMPLATE.md +++ b/.github/PULL_REQUEST_TEMPLATE.md @@ -2,7 +2,7 @@ --- Please include the following checklist in your PR: -* [ ] Patches conform to the [coding conventions](https://github.com/haskell/cabal/blob/master/CONTRIBUTING.md#conventions). +* [ ] Patches conform to the [coding conventions](https://github.com/haskell/cabal/blob/master/CONTRIBUTING.md#other-conventions). * [ ] Any changes that could be relevant to users [have been recorded in the changelog](https://github.com/haskell/cabal/blob/master/CONTRIBUTING.md#changelog). * [ ] The documentation has been updated, if necessary. * [ ] Include [manual QA notes](https://github.com/haskell/cabal/blob/master/CONTRIBUTING.md#qa-notes) if your PR relates to cabal-install. diff --git a/.github/workflows/linting.yml b/.github/workflows/linting.yml new file mode 100644 index 00000000000..47595b1f527 --- /dev/null +++ b/.github/workflows/linting.yml @@ -0,0 +1,23 @@ +name: Linting + +on: + pull_request: + push: + branches: ["master"] + +jobs: + fourmolu: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v3 + - uses: haskell-actions/run-fourmolu@v8 + with: + pattern: | + Cabal/**/*.hs + Cabal-syntax/**/*.hs + Cabal-install/**/*.hs + !Cabal-syntax/src/Distribution/Fields/Lexer.hs + !Cabal-syntax/src/Distribution/SPDX/LicenseExceptionId.hs + !Cabal-syntax/src/Distribution/SPDX/LicenseId.hs + !Cabal/src/Distribution/Simple/Build/Macros/Z.hs + !Cabal/src/Distribution/Simple/Build/PathsModule/Z.hs diff --git a/.github/workflows/whitespace.yml b/.github/workflows/whitespace.yml deleted file mode 100644 index 1254f7ccc4e..00000000000 --- a/.github/workflows/whitespace.yml +++ /dev/null @@ -1,57 +0,0 @@ -name: Assorted - -on: - push: - branches: - - master - pull_request: - release: - types: - - created -jobs: - check: - name: Whitespace - runs-on: ubuntu-latest - - env: - fix-whitespace-ver: '0.0.10' - - steps: - - uses: actions/checkout@v3 - name: Checkout sources - - - name: Create directory for binary - run: | - mkdir -p $HOME/.local/bin - - - uses: actions/cache@v3 - name: Cache the binary - id: cache - with: - path: "~/.local/bin" - key: fix-whitespace-${{ env.fix-whitespace-ver }} - - # See https://github.com/haskell/cabal/pull/8739 - - name: Sudo chmod to permit ghcup to update its cache - run: | - if [[ "${{ runner.os }}" == "Linux" ]]; then - sudo mkdir -p /usr/local/.ghcup/cache - sudo chown -R $USER /usr/local/.ghcup - sudo chmod -R 777 /usr/local/.ghcup - fi - - - uses: haskell/actions/setup@v2 - if: ${{ !steps.cache.outputs.cache-hit }} - with: - ghc-version: '9.2' - cabal-version: latest - - - name: Install fix-whitespace - if: ${{ !steps.cache.outputs.cache-hit }} - run: | - cabal install --ignore-project --install-method=copy --installdir=$HOME/.local/bin fix-whitespace-${{ env.fix-whitespace-ver }} - strip $HOME/.local/bin/fix-whitespace - - - name: Check the whitespace issue - run: | - $HOME/.local/bin/fix-whitespace --check diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index dc75fe02190..1dead3afd3b 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -137,38 +137,16 @@ For instance: Manual QA is not expected to find every possible bug, but to really challenge the assumptions of the contributor, and to verify that their own testing of their patch is not influenced by their setup or implicit knowledge of the system. -Whitespace Conventions ----------------------- - -* No tab characters allowed. -* No trailing whitespace allowed. -* File needs to be terminated by a newline character. - -These conventions are enforced by the -[fix-whitespace](https://hackage.haskell.org/package/fix-whitespace) -tool. Install it from hackage as usual (`cabal install fix-whitespace`) -and run it in the project root to fix whitespace violations. - -The files included in the automatic whitespace check are specified in -`fix-whitespace.yaml`. Please add to this file if you add textfiles -to this repository that are not included by the rules given there. -Note that files that make essential use of tab characters (like `Makefile`) -should _not_ be included in the automatic check. - -Whitespace conventions are enforced by -[CI](https://github.com/haskell/cabal/actions/workflows/whitespace.yml). -If you push a fix of a whitespace violation, please do so in a -_separate commit_. - +Code Style +--------------- +We use automated formatting with Fourmolu to enforce a unified style across the code bases. It is checked in the CI process. +You can automatically format the code bases with `make style` at the top level of the project. Other Conventions ----------------- -* Try to follow style conventions of a file you are modifying, and - avoid gratuitous reformatting (it makes merges harder!) - * Format your commit messages [in the standard way](https://chris.beams.io/posts/git-commit/#seven-rules). * A lot of Cabal does not have top-level comments. We are trying to @@ -227,10 +205,6 @@ Other Conventions #endif ``` -We like [this style guide][guide]. - -[guide]: https://github.com/tibbe/haskell-style-guide/blob/master/haskell-style.md - GitHub Ticket Conventions ------------------- diff --git a/Makefile b/Makefile index 9b9cd145726..91ade431fa7 100644 --- a/Makefile +++ b/Makefile @@ -14,6 +14,19 @@ lib : $(LEXER_HS) exe : $(LEXER_HS) $(CABALBUILD) cabal-install:exes +init: ## Set up git hooks and ignored revisions + @git config core.hooksPath .githooks + ## TODO + +style: ## Run the code styler + @find Cabal Cabal-syntax cabal-install -name '*.hs' \ + ! -path Cabal-syntax/src/Distribution/Fields/Lexer.hs \ + ! -path Cabal-syntax/src/Distribution/SPDX/LicenseExceptionId.hs \ + ! -path Cabal-syntax/src/Distribution/SPDX/LicenseId.hs \ + ! -path Cabal/src/Distribution/Simple/Build/Macros/Z.hs \ + ! -path Cabal/src/Distribution/Simple/Build/PathsModule/Z.hs \ + | xargs -P $(PROCS) -I {} fourmolu -q -i {} + # source generation: Lexer LEXER_HS:=Cabal-syntax/src/Distribution/Fields/Lexer.hs @@ -227,3 +240,9 @@ users-guide-requirements: doc/requirements.txt doc/requirements.txt: .python-sphinx-virtualenv . .python-sphinx-virtualenv/bin/activate \ && make -C doc build-and-check-requirements + +ifeq ($(UNAME), Darwin) + PROCS := $(shell sysctl -n hw.logicalcpu) +else + PROCS := $(shell nproc) +endif diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 00000000000..6ba33930bd5 --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,14 @@ +indentation: 2 +comma-style: leading # for lists, tuples etc. - can also be 'trailing' +import-export-style: leading +record-brace-space: false # rec {x = 1} vs. rec{x = 1} +indent-wheres: true # 'false' means save space by only half-indenting the 'where' keyword +respectful: true # don't be too opinionated about newlines etc. +haddock-style: single-line # '--' vs. '{-' +haddock-style-module: single-line +newlines-between-decls: 1 # number of newlines between top-level declarations +fixities: [] +function-arrows: leading +single-constraint-parens: never +in-style: right-align +let-style: auto From c7a5ac671338998395c1d12f04a0f9190d89e3af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?H=C3=A9cate=20Moonlight?= Date: Sun, 28 May 2023 15:52:49 +0200 Subject: [PATCH 3/3] fixup! Merge remote-tracking branch 'upstream/master' into 8936-formatting-codebase --- .../src/Distribution/Compat/Prelude.hs | 2 +- Cabal/src/Distribution/Backpack/Configure.hs | 265 +- .../Backpack/ConfiguredComponent.hs | 52 +- .../Distribution/Backpack/LinkedComponent.hs | 144 +- .../Backpack/PreExistingComponent.hs | 17 +- .../Distribution/PackageDescription/Check.hs | 175 +- Cabal/src/Distribution/Simple/Configure.hs | 1449 ++-- Cabal/src/Distribution/Simple/GHC.hs | 297 +- Cabal/src/Distribution/Simple/GHC/ImplInfo.hs | 110 +- Cabal/src/Distribution/Simple/GHC/Internal.hs | 421 +- Cabal/src/Distribution/Simple/GHCJS.hs | 114 +- Cabal/src/Distribution/Simple/Setup/Config.hs | 614 +- Cabal/src/Distribution/Simple/Setup/Repl.hs | 41 +- Cabal/src/Distribution/Types/AnnotatedId.hs | 21 +- .../src/Distribution/Types/LocalBuildInfo.hs | 191 +- .../src/Distribution/Client/CmdListBin.hs | 55 +- .../src/Distribution/Client/CmdRepl.hs | 691 +- .../src/Distribution/Client/CmdRun.hs | 125 +- .../src/Distribution/Client/Config.hs | 412 +- .../src/Distribution/Client/HashValue.hs | 29 +- .../src/Distribution/Client/InstallPlan.hs | 57 +- .../Distribution/Client/NixStyleOptions.hs | 78 +- .../Distribution/Client/ProjectBuilding.hs | 193 +- .../src/Distribution/Client/ProjectConfig.hs | 88 +- .../Client/ProjectConfig/Legacy.hs | 785 +-- .../Client/ProjectConfig/Types.hs | 82 +- .../Client/ProjectOrchestration.hs | 117 +- .../Distribution/Client/ProjectPlanOutput.hs | 220 +- .../Distribution/Client/ProjectPlanning.hs | 6219 +++++++++-------- .../Client/ProjectPlanning/Types.hs | 1076 ++- .../src/Distribution/Client/ReplFlags.hs | 136 +- .../src/Distribution/Client/ScriptUtils.hs | 496 +- .../src/Distribution/Client/Setup.hs | 3856 ++++++++-- .../Distribution/Client/ProjectConfig.hs | 2421 +++---- test/IntegrationTests2/config/default-config | 246 + .../nix-config/default-config | 246 + 36 files changed, 12720 insertions(+), 8821 deletions(-) create mode 100644 test/IntegrationTests2/config/default-config create mode 100644 test/IntegrationTests2/nix-config/default-config diff --git a/Cabal-syntax/src/Distribution/Compat/Prelude.hs b/Cabal-syntax/src/Distribution/Compat/Prelude.hs index 42915110c1e..5edf0d92e5f 100644 --- a/Cabal-syntax/src/Distribution/Compat/Prelude.hs +++ b/Cabal-syntax/src/Distribution/Compat/Prelude.hs @@ -205,7 +205,7 @@ import Prelude as BasePrelude hiding , Foldable(..) ) {- FOURMOLU_ENABLE -} -import Data.Foldable as BasePrelude (foldl, elem, sum, product, maximum, minimum) +import Data.Foldable as BasePrelude (elem, foldl, maximum, minimum, product, sum) -- AMP import Data.Foldable diff --git a/Cabal/src/Distribution/Backpack/Configure.hs b/Cabal/src/Distribution/Backpack/Configure.hs index d3e69a66138..54a66833715 100644 --- a/Cabal/src/Distribution/Backpack/Configure.hs +++ b/Cabal/src/Distribution/Backpack/Configure.hs @@ -27,6 +27,7 @@ import Distribution.Backpack.LinkedComponent import Distribution.Backpack.PreExistingComponent import Distribution.Backpack.ReadyComponent +import Distribution.Backpack.ModuleShape import Distribution.Compat.Graph (Graph, IsNode (..)) import qualified Distribution.Compat.Graph as Graph import Distribution.InstalledPackageInfo @@ -48,7 +49,6 @@ import Distribution.Types.ComponentRequestedSpec import Distribution.Types.MungedPackageName import Distribution.Utils.LogProgress import Distribution.Verbosity -import Distribution.Backpack.ModuleShape import Data.Either ( lefts @@ -63,19 +63,19 @@ import Text.PrettyPrint ------------------------------------------------------------------------------ configureComponentLocalBuildInfos - :: Verbosity - -> Bool -- use_external_internal_deps - -> ComponentRequestedSpec - -> Bool -- deterministic - -> Flag String -- configIPID - -> Flag ComponentId -- configCID - -> PackageDescription - -> ([PreExistingComponent], [PromisedComponent]) - -> FlagAssignment -- configConfigurationsFlags - -> [(ModuleName, Module)] -- configInstantiateWith - -> InstalledPackageIndex - -> Compiler - -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex) + :: Verbosity + -> Bool -- use_external_internal_deps + -> ComponentRequestedSpec + -> Bool -- deterministic + -> Flag String -- configIPID + -> Flag ComponentId -- configCID + -> PackageDescription + -> ([PreExistingComponent], [PromisedComponent]) + -> FlagAssignment -- configConfigurationsFlags + -> [(ModuleName, Module)] -- configInstantiateWith + -> InstalledPackageIndex + -> Compiler + -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex) configureComponentLocalBuildInfos verbosity use_external_internal_deps @@ -84,7 +84,7 @@ configureComponentLocalBuildInfos ipid_flag cid_flag pkg_descr - prePkgDeps + (prePkgDeps, promisedPkgDeps) flagAssignment instantiate_with installedPackageSet @@ -100,44 +100,75 @@ configureComponentLocalBuildInfos 4 (dispComponentsWithDeps graph0) - let conf_pkg_map = Map.fromListWith Map.union - [(pc_pkgname pkg, - Map.singleton (pc_compname pkg) - (AnnotatedId { - ann_id = pc_cid pkg, - ann_pid = packageId pkg, - ann_cname = pc_compname pkg - })) - | pkg <- prePkgDeps] - `Map.union` - Map.fromListWith Map.union - [ (pkg, Map.singleton (ann_cname aid) aid) - | PromisedComponent pkg aid <- promisedPkgDeps] - graph1 <- toConfiguredComponents use_external_internal_deps - flagAssignment - deterministic ipid_flag cid_flag pkg_descr - conf_pkg_map (map fst graph0) - infoProgress $ hang (text "Configured component graph:") 4 - (vcat (map dispConfiguredComponent graph1)) + let conf_pkg_map = + Map.fromListWith + Map.union + [ ( pc_pkgname pkg + , Map.singleton + (pc_compname pkg) + ( AnnotatedId + { ann_id = pc_cid pkg + , ann_pid = packageId pkg + , ann_cname = pc_compname pkg + } + ) + ) + | pkg <- prePkgDeps + ] + `Map.union` Map.fromListWith + Map.union + [ (pkg, Map.singleton (ann_cname aid) aid) + | PromisedComponent pkg aid <- promisedPkgDeps + ] + graph1 <- + toConfiguredComponents + use_external_internal_deps + flagAssignment + deterministic + ipid_flag + cid_flag + pkg_descr + conf_pkg_map + (map fst graph0) + infoProgress $ + hang + (text "Configured component graph:") + 4 + (vcat (map dispConfiguredComponent graph1)) let shape_pkg_map = Map.fromList [ (pc_cid pkg, (pc_open_uid pkg, pc_shape pkg)) - | pkg <- prePkgDeps] - `Map.union` - Map.fromList - [ (ann_id aid, (DefiniteUnitId (unsafeMkDefUnitId - (mkUnitId (unComponentId (ann_id aid) ))) - , emptyModuleShape)) - | PromisedComponent _ aid <- promisedPkgDeps] + | pkg <- prePkgDeps + ] + `Map.union` Map.fromList + [ ( ann_id aid + , + ( DefiniteUnitId + ( unsafeMkDefUnitId + (mkUnitId (unComponentId (ann_id aid))) + ) + , emptyModuleShape + ) + ) + | PromisedComponent _ aid <- promisedPkgDeps + ] uid_lookup def_uid - | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid - = FullUnitId (Installed.installedComponentId pkg) - (Map.fromList (Installed.instantiatedWith pkg)) - | otherwise = error ("uid_lookup: " ++ prettyShow uid) - where uid = unDefUnitId def_uid - graph2 <- toLinkedComponents verbosity (not (null promisedPkgDeps)) uid_lookup - (package pkg_descr) shape_pkg_map graph1 + | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid = + FullUnitId + (Installed.installedComponentId pkg) + (Map.fromList (Installed.instantiatedWith pkg)) + | otherwise = error ("uid_lookup: " ++ prettyShow uid) + where + uid = unDefUnitId def_uid + graph2 <- + toLinkedComponents + verbosity + (not (null promisedPkgDeps)) + uid_lookup + (package pkg_descr) + shape_pkg_map + graph1 infoProgress $ hang @@ -175,74 +206,90 @@ configureComponentLocalBuildInfos ------------------------------------------------------------------------------ toComponentLocalBuildInfos - :: Compiler - -> InstalledPackageIndex -- FULL set - -> [PromisedComponent] - -> PackageDescription - -> [PreExistingComponent] -- external package deps - -> [ReadyComponent] - -> LogProgress ([ComponentLocalBuildInfo], - InstalledPackageIndex) -- only relevant packages + :: Compiler + -> InstalledPackageIndex -- FULL set + -> [PromisedComponent] + -> PackageDescription + -> [PreExistingComponent] -- external package deps + -> [ReadyComponent] + -> LogProgress + ( [ComponentLocalBuildInfo] + , InstalledPackageIndex -- only relevant packages + ) toComponentLocalBuildInfos - comp installedPackageSet promisedPkgDeps pkg_descr externalPkgDeps graph = do + comp + installedPackageSet + promisedPkgDeps + pkg_descr + externalPkgDeps + graph = do -- Check and make sure that every instantiated component exists. -- We have to do this now, because prior to linking/instantiating -- we don't actually know what the full set of 'UnitId's we need -- are. - let -- TODO: This is actually a bit questionable performance-wise, - -- since we will pay for the ALL installed packages even if - -- they are not related to what we are building. This was true - -- in the old configure code. - external_graph :: Graph (Either InstalledPackageInfo ReadyComponent) - external_graph = Graph.fromDistinctList - . map Left - $ PackageIndex.allPackages installedPackageSet - internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent) - internal_graph = Graph.fromDistinctList - . map Right - $ graph - combined_graph = Graph.unionRight external_graph internal_graph - local_graph = fromMaybe (error "toComponentLocalBuildInfos: closure returned Nothing") - $ Graph.closure combined_graph (map nodeKey graph) - -- The database of transitively reachable installed packages that the - -- external components the package (as a whole) depends on. This will be - -- used in several ways: - -- - -- * We'll use it to do a consistency check so we're not depending - -- on multiple versions of the same package (TODO: someday relax - -- this for private dependencies.) See right below. - -- - -- * We'll pass it on in the LocalBuildInfo, where preprocessors - -- and other things will incorrectly use it to determine what - -- the include paths and everything should be. - -- - packageDependsIndex = PackageIndex.fromList (lefts local_graph) - fullIndex = Graph.fromDistinctList local_graph + let + -- TODO: This is actually a bit questionable performance-wise, + -- since we will pay for the ALL installed packages even if + -- they are not related to what we are building. This was true + -- in the old configure code. + external_graph :: Graph (Either InstalledPackageInfo ReadyComponent) + external_graph = + Graph.fromDistinctList + . map Left + $ PackageIndex.allPackages installedPackageSet + internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent) + internal_graph = + Graph.fromDistinctList + . map Right + $ graph + combined_graph = Graph.unionRight external_graph internal_graph + local_graph = + fromMaybe (error "toComponentLocalBuildInfos: closure returned Nothing") $ + Graph.closure combined_graph (map nodeKey graph) + -- The database of transitively reachable installed packages that the + -- external components the package (as a whole) depends on. This will be + -- used in several ways: + -- + -- * We'll use it to do a consistency check so we're not depending + -- on multiple versions of the same package (TODO: someday relax + -- this for private dependencies.) See right below. + -- + -- * We'll pass it on in the LocalBuildInfo, where preprocessors + -- and other things will incorrectly use it to determine what + -- the include paths and everything should be. + -- + packageDependsIndex = PackageIndex.fromList (lefts local_graph) + fullIndex = Graph.fromDistinctList local_graph case Graph.broken fullIndex of - [] -> return () - -- If there are promised dependencies, we don't know what the dependencies - -- of these are and that can easily lead to a broken graph. So assume that - -- any promised package is not broken (ie all its dependencies, transitively, - -- will be there). That's a promise. - broken | not (null promisedPkgDeps) -> return () - | otherwise -> - -- TODO: ppr this - dieProgress . text $ - "The following packages are broken because other" - ++ " packages they depend on are missing. These broken " - ++ "packages must be rebuilt before they can be used.\n" - -- TODO: Undupe. - ++ unlines [ "installed package " - ++ prettyShow (packageId pkg) - ++ " is broken due to missing package " - ++ intercalate ", " (map prettyShow deps) - | (Left pkg, deps) <- broken ] - ++ unlines [ "planned package " - ++ prettyShow (packageId pkg) - ++ " is broken due to missing package " - ++ intercalate ", " (map prettyShow deps) - | (Right pkg, deps) <- broken ] + [] -> return () + -- If there are promised dependencies, we don't know what the dependencies + -- of these are and that can easily lead to a broken graph. So assume that + -- any promised package is not broken (ie all its dependencies, transitively, + -- will be there). That's a promise. + broken + | not (null promisedPkgDeps) -> return () + | otherwise -> + -- TODO: ppr this + dieProgress . text $ + "The following packages are broken because other" + ++ " packages they depend on are missing. These broken " + ++ "packages must be rebuilt before they can be used.\n" + -- TODO: Undupe. + ++ unlines + [ "installed package " + ++ prettyShow (packageId pkg) + ++ " is broken due to missing package " + ++ intercalate ", " (map prettyShow deps) + | (Left pkg, deps) <- broken + ] + ++ unlines + [ "planned package " + ++ prettyShow (packageId pkg) + ++ " is broken due to missing package " + ++ intercalate ", " (map prettyShow deps) + | (Right pkg, deps) <- broken + ] -- In this section, we'd like to look at the 'packageDependsIndex' -- and see if we've picked multiple versions of the same diff --git a/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs b/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs index 828306f5027..9bfaefb7e0b 100644 --- a/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs +++ b/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs @@ -177,30 +177,36 @@ toConfiguredComponent -> Component -> LogProgress ConfiguredComponent toConfiguredComponent pkg_descr this_cid lib_dep_map exe_dep_map component = do - lib_deps <- - if newPackageDepsBehaviour pkg_descr - then fmap concat $ forM (targetBuildDepends bi) $ - \(Dependency name _ sublibs) -> do - case Map.lookup name lib_dep_map of + lib_deps <- + if newPackageDepsBehaviour pkg_descr + then fmap concat $ + forM (targetBuildDepends bi) $ + \(Dependency name _ sublibs) -> do + case Map.lookup name lib_dep_map of + Nothing -> + dieProgress $ + text "Dependency on unbuildable" + <+> text "package" + <+> pretty name + Just pkg -> do + -- Return all library components + forM (NonEmptySet.toList sublibs) $ \lib -> + let comp = CLibName lib + in case Map.lookup comp pkg of Nothing -> - dieProgress $ - text "Dependency on unbuildable" <+> - text "package" <+> pretty name - Just pkg -> do - -- Return all library components - forM (NonEmptySet.toList sublibs) $ \lib -> - let comp = CLibName lib in - case Map.lookup comp pkg of - Nothing -> - dieProgress $ - text "Dependency on unbuildable" <+> - text (showLibraryName lib) <+> - text "from" <+> pretty name - Just v -> return v - else return old_style_lib_deps - mkConfiguredComponent - pkg_descr this_cid - lib_deps exe_deps component + dieProgress $ + text "Dependency on unbuildable" + <+> text (showLibraryName lib) + <+> text "from" + <+> pretty name + Just v -> return v + else return old_style_lib_deps + mkConfiguredComponent + pkg_descr + this_cid + lib_deps + exe_deps + component where bi = componentBuildInfo component -- lib_dep_map contains a mix of internal and external deps. diff --git a/Cabal/src/Distribution/Backpack/LinkedComponent.hs b/Cabal/src/Distribution/Backpack/LinkedComponent.hs index 561f9d850ac..b2d2bc25066 100644 --- a/Cabal/src/Distribution/Backpack/LinkedComponent.hs +++ b/Cabal/src/Distribution/Backpack/LinkedComponent.hs @@ -112,20 +112,27 @@ instance Package LinkedComponent where packageId = lc_pkgid toLinkedComponent - :: Verbosity - -> Bool -- ^ Whether there are any "promised" package dependencies which we won't find already installed. - -> FullDb - -> PackageId - -> LinkedComponentMap - -> ConfiguredComponent - -> LogProgress LinkedComponent -toLinkedComponent verbosity anyPromised db this_pid pkg_map ConfiguredComponent { - cc_ann_id = aid@AnnotatedId { ann_id = this_cid }, - cc_component = component, - cc_exe_deps = exe_deps, - cc_public = is_public, - cc_includes = cid_includes - } = do + :: Verbosity + -> Bool + -- ^ Whether there are any "promised" package dependencies which we won't find already installed. + -> FullDb + -> PackageId + -> LinkedComponentMap + -> ConfiguredComponent + -> LogProgress LinkedComponent +toLinkedComponent + verbosity + anyPromised + db + this_pid + pkg_map + ConfiguredComponent + { cc_ann_id = aid@AnnotatedId{ann_id = this_cid} + , cc_component = component + , cc_exe_deps = exe_deps + , cc_public = is_public + , cc_includes = cid_includes + } = do let -- The explicitly specified requirements, provisions and -- reexports from the Cabal file. These are only non-empty for @@ -309,39 +316,49 @@ toLinkedComponent verbosity anyPromised db this_pid pkg_map ConfiguredComponent -- dynamically later by an in-memory package which hasn't been installed yet. if anyPromised then return (to, Nothing) - -- But if nothing is promised, eagerly report an error, as we already know everything. - else Left (brokenReexportMsg reex) + else -- But if nothing is promised, eagerly report an error, as we already know everything. + Left (brokenReexportMsg reex) -- TODO: maybe check this earlier; it's syntactically obvious. let build_reexports m (k, v) - | Map.member k m = - dieProgress $ hsep - [ text "Module name ", pretty k, text " is exported multiple times." ] - | otherwise = return (Map.insert k v m) - provs <- foldM build_reexports Map.empty $ - -- TODO: doublecheck we have checked for - -- src_provs duplicates already! - -- These are normal module exports. - [ (mod_name, (OpenModule this_uid mod_name)) | mod_name <- src_provs ] - ++ - -- These are reexports, which we managed to resolve to something in an external package. - [(mn_new, om) | (mn_new, Just om) <- reexports_list ] - ++ - -- These ones.. we didn't resolve but also we might not have to - -- resolve them because they could come from a promised unit, - -- which we don't know anything about yet. GHC will resolve - -- these itself when it is dealing with the multi-session. - -- These ones will not be built, registered and put - -- into a package database, we only need them to make it as far - -- as generating GHC options where the info will be used to - -- pass the reexported-module option to GHC. - - -- We also know that in the case there are promised units that - -- we will not be doing anything to do with backpack like - -- unification etc.. - [ (mod_name, OpenModule (DefiniteUnitId (unsafeMkDefUnitId - (mkUnitId "fake"))) mod_name) - | (mod_name, Nothing) <- reexports_list ] + | Map.member k m = + dieProgress $ + hsep + [text "Module name ", pretty k, text " is exported multiple times."] + | otherwise = return (Map.insert k v m) + provs <- + foldM build_reexports Map.empty $ + -- TODO: doublecheck we have checked for + -- src_provs duplicates already! + -- These are normal module exports. + [(mod_name, (OpenModule this_uid mod_name)) | mod_name <- src_provs] + ++ + -- These are reexports, which we managed to resolve to something in an external package. + [(mn_new, om) | (mn_new, Just om) <- reexports_list] + ++ + -- These ones.. we didn't resolve but also we might not have to + -- resolve them because they could come from a promised unit, + -- which we don't know anything about yet. GHC will resolve + -- these itself when it is dealing with the multi-session. + -- These ones will not be built, registered and put + -- into a package database, we only need them to make it as far + -- as generating GHC options where the info will be used to + -- pass the reexported-module option to GHC. + + -- We also know that in the case there are promised units that + -- we will not be doing anything to do with backpack like + -- unification etc.. + [ ( mod_name + , OpenModule + ( DefiniteUnitId + ( unsafeMkDefUnitId + (mkUnitId "fake") + ) + ) + mod_name + ) + | (mod_name, Nothing) <- reexports_list + ] let final_linked_shape = ModuleShape provs (Map.keysSet (modScopeRequires linked_shape)) @@ -388,24 +405,27 @@ toLinkedComponent verbosity anyPromised db this_pid pkg_map ConfiguredComponent -- Handle mix-in linking for components. In the absence of Backpack, -- every ComponentId gets converted into a UnitId by way of SimpleUnitId. toLinkedComponents - :: Verbosity - -> Bool -- ^ Whether there are any "promised" package dependencies which we won't - -- find already installed. - -> FullDb - -> PackageId - -> LinkedComponentMap - -> [ConfiguredComponent] - -> LogProgress [LinkedComponent] -toLinkedComponents verbosity anyPromised db this_pid lc_map0 comps - = fmap snd (mapAccumM go lc_map0 comps) - where - go :: Map ComponentId (OpenUnitId, ModuleShape) - -> ConfiguredComponent - -> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent) - go lc_map cc = do - lc <- addProgressCtx (text "In the stanza" <+> text (componentNameStanza (cc_name cc))) $ - toLinkedComponent verbosity anyPromised db this_pid lc_map cc - return (extendLinkedComponentMap lc lc_map, lc) + :: Verbosity + -> Bool + -- ^ Whether there are any "promised" package dependencies which we won't + -- find already installed. + -> FullDb + -> PackageId + -> LinkedComponentMap + -> [ConfiguredComponent] + -> LogProgress [LinkedComponent] +toLinkedComponents verbosity anyPromised db this_pid lc_map0 comps = + fmap snd (mapAccumM go lc_map0 comps) + where + go + :: Map ComponentId (OpenUnitId, ModuleShape) + -> ConfiguredComponent + -> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent) + go lc_map cc = do + lc <- + addProgressCtx (text "In the stanza" <+> text (componentNameStanza (cc_name cc))) $ + toLinkedComponent verbosity anyPromised db this_pid lc_map cc + return (extendLinkedComponentMap lc lc_map, lc) type LinkedComponentMap = Map ComponentId (OpenUnitId, ModuleShape) diff --git a/Cabal/src/Distribution/Backpack/PreExistingComponent.hs b/Cabal/src/Distribution/Backpack/PreExistingComponent.hs index 1fac89d4042..5f937de9062 100644 --- a/Cabal/src/Distribution/Backpack/PreExistingComponent.hs +++ b/Cabal/src/Distribution/Backpack/PreExistingComponent.hs @@ -1,9 +1,9 @@ -- | See -module Distribution.Backpack.PreExistingComponent ( - PreExistingComponent(..), - PromisedComponent(..), - ipiToPreExistingComponent, -) where +module Distribution.Backpack.PreExistingComponent + ( PreExistingComponent (..) + , PromisedComponent (..) + , ipiToPreExistingComponent + ) where import Distribution.Compat.Prelude import Prelude () @@ -24,11 +24,10 @@ import Distribution.Types.AnnotatedId -- These components are promised to @configure@ but are not yet built. -- -- In other words this is 'PreExistingComponent' which doesn't yet exist. --- data PromisedComponent = PromisedComponent - { pr_pkgname :: PackageName - , pr_cid :: AnnotatedId ComponentId - } + { pr_pkgname :: PackageName + , pr_cid :: AnnotatedId ComponentId + } instance Package PromisedComponent where packageId = packageId . pr_cid diff --git a/Cabal/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs index 6108d06218d..b3045950708 100644 --- a/Cabal/src/Distribution/PackageDescription/Check.hs +++ b/Cabal/src/Distribution/PackageDescription/Check.hs @@ -1526,94 +1526,88 @@ checkAllGhcOptions pkg = -- or non-portable flags checkGhcOptions :: String -> (BuildInfo -> [String]) -> PackageDescription -> [PackageCheck] checkGhcOptions fieldName getOptions pkg = - catMaybes [ - - checkFlags ["-fasm"] $ - PackageDistInexcusable (OptFasm fieldName) - - , checkFlags ["-fvia-C"] $ - PackageDistSuspicious (OptViaC fieldName) - - , checkFlags ["-fhpc"] $ - PackageDistInexcusable (OptHpc fieldName) - - , checkFlags ["-prof"] $ - PackageBuildWarning (OptProf fieldName) - - , unlessScript . checkFlags ["-o"] $ - PackageBuildWarning (OptO fieldName) - - , checkFlags ["-hide-package"] $ - PackageBuildWarning (OptHide fieldName) - - , checkFlags ["--make"] $ - PackageBuildWarning (OptMake fieldName) - - , checkNonTestAndBenchmarkFlags ["-O0", "-Onot"] $ - PackageDistSuspicious (OptONot fieldName) - - , checkTestAndBenchmarkFlags ["-O0", "-Onot"] $ - PackageDistSuspiciousWarn (OptONot fieldName) - - , checkFlags [ "-O", "-O1"] $ - PackageDistInexcusable (OptOOne fieldName) - - , checkFlags ["-O2"] $ - PackageDistSuspiciousWarn (OptOTwo fieldName) - - , checkFlags ["-split-sections"] $ - PackageBuildWarning (OptSplitSections fieldName) - - , checkFlags ["-split-objs"] $ - PackageBuildWarning (OptSplitObjs fieldName) - - , checkFlags ["-optl-Wl,-s", "-optl-s"] $ - PackageDistInexcusable (OptWls fieldName) - - , checkFlags ["-fglasgow-exts"] $ - PackageDistSuspicious (OptExts fieldName) - - , check ("-rtsopts" `elem` lib_ghc_options) $ - PackageBuildWarning (OptRts fieldName) - - , check (any (\opt -> "-with-rtsopts" `isPrefixOf` opt) lib_ghc_options) $ - PackageBuildWarning (OptWithRts fieldName) - - , checkAlternatives fieldName "extensions" - [ (flag, prettyShow extension) | flag <- ghc_options_no_rtsopts - , Just extension <- [ghcExtension flag] ] - - , checkAlternatives fieldName "extensions" - [ (flag, extension) | flag@('-':'X':extension) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "cpp-options" $ - [ (flag, flag) | flag@('-':'D':_) <- ghc_options_no_rtsopts ] - ++ [ (flag, flag) | flag@('-':'U':_) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "include-dirs" - [ (flag, dir) | flag@('-':'I':dir) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "extra-libraries" - [ (flag, lib) | flag@('-':'l':lib) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "extra-libraries-static" - [ (flag, lib) | flag@('-':'l':lib) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "extra-lib-dirs" - [ (flag, dir) | flag@('-':'L':dir) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "extra-lib-dirs-static" - [ (flag, dir) | flag@('-':'L':dir) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "frameworks" - [ (flag, fmwk) | (flag@"-framework", fmwk) <- - zip ghc_options_no_rtsopts (safeTail ghc_options_no_rtsopts) ] - - , checkAlternatives fieldName "extra-framework-dirs" - [ (flag, dir) | (flag@"-framework-path", dir) <- - zip ghc_options_no_rtsopts (safeTail ghc_options_no_rtsopts) ] - ] - + catMaybes + [ checkFlags ["-fasm"] $ + PackageDistInexcusable (OptFasm fieldName) + , checkFlags ["-fvia-C"] $ + PackageDistSuspicious (OptViaC fieldName) + , checkFlags ["-fhpc"] $ + PackageDistInexcusable (OptHpc fieldName) + , checkFlags ["-prof"] $ + PackageBuildWarning (OptProf fieldName) + , unlessScript . checkFlags ["-o"] $ + PackageBuildWarning (OptO fieldName) + , checkFlags ["-hide-package"] $ + PackageBuildWarning (OptHide fieldName) + , checkFlags ["--make"] $ + PackageBuildWarning (OptMake fieldName) + , checkNonTestAndBenchmarkFlags ["-O0", "-Onot"] $ + PackageDistSuspicious (OptONot fieldName) + , checkTestAndBenchmarkFlags ["-O0", "-Onot"] $ + PackageDistSuspiciousWarn (OptONot fieldName) + , checkFlags ["-O", "-O1"] $ + PackageDistInexcusable (OptOOne fieldName) + , checkFlags ["-O2"] $ + PackageDistSuspiciousWarn (OptOTwo fieldName) + , checkFlags ["-split-sections"] $ + PackageBuildWarning (OptSplitSections fieldName) + , checkFlags ["-split-objs"] $ + PackageBuildWarning (OptSplitObjs fieldName) + , checkFlags ["-optl-Wl,-s", "-optl-s"] $ + PackageDistInexcusable (OptWls fieldName) + , checkFlags ["-fglasgow-exts"] $ + PackageDistSuspicious (OptExts fieldName) + , check ("-rtsopts" `elem` lib_ghc_options) $ + PackageBuildWarning (OptRts fieldName) + , check (any (\opt -> "-with-rtsopts" `isPrefixOf` opt) lib_ghc_options) $ + PackageBuildWarning (OptWithRts fieldName) + , checkAlternatives + fieldName + "extensions" + [ (flag, prettyShow extension) | flag <- ghc_options_no_rtsopts, Just extension <- [ghcExtension flag] + ] + , checkAlternatives + fieldName + "extensions" + [(flag, extension) | flag@('-' : 'X' : extension) <- ghc_options_no_rtsopts] + , checkAlternatives fieldName "cpp-options" $ + [(flag, flag) | flag@('-' : 'D' : _) <- ghc_options_no_rtsopts] + ++ [(flag, flag) | flag@('-' : 'U' : _) <- ghc_options_no_rtsopts] + , checkAlternatives + fieldName + "include-dirs" + [(flag, dir) | flag@('-' : 'I' : dir) <- ghc_options_no_rtsopts] + , checkAlternatives + fieldName + "extra-libraries" + [(flag, lib) | flag@('-' : 'l' : lib) <- ghc_options_no_rtsopts] + , checkAlternatives + fieldName + "extra-libraries-static" + [(flag, lib) | flag@('-' : 'l' : lib) <- ghc_options_no_rtsopts] + , checkAlternatives + fieldName + "extra-lib-dirs" + [(flag, dir) | flag@('-' : 'L' : dir) <- ghc_options_no_rtsopts] + , checkAlternatives + fieldName + "extra-lib-dirs-static" + [(flag, dir) | flag@('-' : 'L' : dir) <- ghc_options_no_rtsopts] + , checkAlternatives + fieldName + "frameworks" + [ (flag, fmwk) + | (flag@"-framework", fmwk) <- + zip ghc_options_no_rtsopts (safeTail ghc_options_no_rtsopts) + ] + , checkAlternatives + fieldName + "extra-framework-dirs" + [ (flag, dir) + | (flag@"-framework-path", dir) <- + zip ghc_options_no_rtsopts (safeTail ghc_options_no_rtsopts) + ] + ] where all_ghc_options = concatMap getOptions (allBuildInfo pkg) ghc_options_no_rtsopts = rmRtsOpts all_ghc_options @@ -1647,8 +1641,9 @@ checkGhcOptions fieldName getOptions pkg = checkFlags flags = check (any (`elem` flags) all_ghc_options) unlessScript :: Maybe PackageCheck -> Maybe PackageCheck - unlessScript pc | packageId pkg == fakePackageId = Nothing - | otherwise = pc + unlessScript pc + | packageId pkg == fakePackageId = Nothing + | otherwise = pc checkTestAndBenchmarkFlags :: [String] -> PackageCheck -> Maybe PackageCheck checkTestAndBenchmarkFlags flags = check (any (`elem` flags) test_and_benchmark_ghc_options) diff --git a/Cabal/src/Distribution/Simple/Configure.hs b/Cabal/src/Distribution/Simple/Configure.hs index 4b3e28665b4..82da0f29aac 100644 --- a/Cabal/src/Distribution/Simple/Configure.hs +++ b/Cabal/src/Distribution/Simple/Configure.hs @@ -412,585 +412,574 @@ configure -> ConfigFlags -> IO LocalBuildInfo configure (pkg_descr0, pbi) cfg = do - -- Determine the component we are configuring, if a user specified - -- one on the command line. We use a fake, flattened version of - -- the package since at this point, we're not really sure what - -- components we *can* configure. @Nothing@ means that we should - -- configure everything (the old behavior). - (mb_cname :: Maybe ComponentName) <- do - let flat_pkg_descr = flattenPackageDescription pkg_descr0 - targets <- readBuildTargets verbosity flat_pkg_descr (configArgs cfg) - -- TODO: bleat if you use the module/file syntax - let targets' = [ cname | BuildTargetComponent cname <- targets ] - case targets' of - _ | null (configArgs cfg) -> return Nothing - [cname] -> return (Just cname) - [] -> die' verbosity "No valid component targets found" - _ -> die' verbosity - "Can only configure either single component or all of them" - - let use_external_internal_deps = isJust mb_cname - case mb_cname of - Nothing -> setupMessage verbosity "Configuring" (packageId pkg_descr0) - Just cname -> setupMessage' verbosity "Configuring" (packageId pkg_descr0) - cname (Just (configInstantiateWith cfg)) - - -- configCID is only valid for per-component configure - when (isJust (flagToMaybe (configCID cfg)) && isNothing mb_cname) $ - die' verbosity "--cid is only supported for per-component configure" - - checkDeprecatedFlags verbosity cfg - checkExactConfiguration verbosity pkg_descr0 cfg - - -- Where to build the package - let buildDir :: FilePath -- e.g. dist/build - -- fromFlag OK due to Distribution.Simple calling - -- findDistPrefOrDefault to fill it in - buildDir = fromFlag (configDistPref cfg) "build" - createDirectoryIfMissingVerbose (lessVerbose verbosity) True buildDir - - -- What package database(s) to use - let packageDbs :: PackageDBStack - packageDbs - = interpretPackageDbFlags - (fromFlag (configUserInstall cfg)) - (configPackageDBs cfg) - - -- comp: the compiler we're building with - -- compPlatform: the platform we're building for - -- programDb: location and args of all programs we're - -- building with - (comp :: Compiler, - compPlatform :: Platform, - programDb :: ProgramDb) - <- configCompilerEx - (flagToMaybe (configHcFlavor cfg)) - (flagToMaybe (configHcPath cfg)) - (flagToMaybe (configHcPkg cfg)) - (mkProgramDb cfg (configPrograms cfg)) - (lessVerbose verbosity) - - -- The InstalledPackageIndex of all installed packages - installedPackageSet :: InstalledPackageIndex - <- getInstalledPackages (lessVerbose verbosity) comp - packageDbs programDb - - -- The set of package names which are "shadowed" by internal - -- packages, and which component they map to - let internalPackageSet :: Set LibraryName - internalPackageSet = getInternalLibraries pkg_descr0 - - -- Make a data structure describing what components are enabled. - let enabled :: ComponentRequestedSpec - enabled = case mb_cname of - Just cname -> OneComponentRequestedSpec cname - Nothing -> ComponentRequestedSpec - -- The flag name (@--enable-tests@) is a - -- little bit of a misnomer, because - -- just passing this flag won't - -- "enable", in our internal - -- nomenclature; it's just a request; a - -- @buildable: False@ might make it - -- not possible to enable. - { testsRequested = fromFlag (configTests cfg) - , benchmarksRequested = - fromFlag (configBenchmarks cfg) } - -- Some sanity checks related to enabling components. - when (isJust mb_cname - && (fromFlag (configTests cfg) || fromFlag (configBenchmarks cfg))) $ - die' verbosity $ - "--enable-tests/--enable-benchmarks are incompatible with" ++ - " explicitly specifying a component to configure." + -- Determine the component we are configuring, if a user specified + -- one on the command line. We use a fake, flattened version of + -- the package since at this point, we're not really sure what + -- components we *can* configure. @Nothing@ means that we should + -- configure everything (the old behavior). + (mb_cname :: Maybe ComponentName) <- do + let flat_pkg_descr = flattenPackageDescription pkg_descr0 + targets <- readBuildTargets verbosity flat_pkg_descr (configArgs cfg) + -- TODO: bleat if you use the module/file syntax + let targets' = [cname | BuildTargetComponent cname <- targets] + case targets' of + _ | null (configArgs cfg) -> return Nothing + [cname] -> return (Just cname) + [] -> die' verbosity "No valid component targets found" + _ -> + die' + verbosity + "Can only configure either single component or all of them" - -- Some sanity checks related to dynamic/static linking. - when (fromFlag (configDynExe cfg) && fromFlag (configFullyStaticExe cfg)) $ - die' verbosity $ - "--enable-executable-dynamic and --enable-executable-static" ++ - " are incompatible with each other." + let use_external_internal_deps = isJust mb_cname + case mb_cname of + Nothing -> setupMessage verbosity "Configuring" (packageId pkg_descr0) + Just cname -> + setupMessage' + verbosity + "Configuring" + (packageId pkg_descr0) + cname + (Just (configInstantiateWith cfg)) + + -- configCID is only valid for per-component configure + when (isJust (flagToMaybe (configCID cfg)) && isNothing mb_cname) $ + die' verbosity "--cid is only supported for per-component configure" + + checkDeprecatedFlags verbosity cfg + checkExactConfiguration verbosity pkg_descr0 cfg + + -- Where to build the package + let buildDir :: FilePath -- e.g. dist/build + -- fromFlag OK due to Distribution.Simple calling + -- findDistPrefOrDefault to fill it in + buildDir = fromFlag (configDistPref cfg) "build" + createDirectoryIfMissingVerbose (lessVerbose verbosity) True buildDir + + -- What package database(s) to use + let packageDbs :: PackageDBStack + packageDbs = + interpretPackageDbFlags + (fromFlag (configUserInstall cfg)) + (configPackageDBs cfg) + + -- comp: the compiler we're building with + -- compPlatform: the platform we're building for + -- programDb: location and args of all programs we're + -- building with + ( comp :: Compiler + , compPlatform :: Platform + , programDb :: ProgramDb + ) <- + configCompilerEx + (flagToMaybe (configHcFlavor cfg)) + (flagToMaybe (configHcPath cfg)) + (flagToMaybe (configHcPkg cfg)) + (mkProgramDb cfg (configPrograms cfg)) + (lessVerbose verbosity) + + -- The InstalledPackageIndex of all installed packages + installedPackageSet :: InstalledPackageIndex <- + getInstalledPackages + (lessVerbose verbosity) + comp + packageDbs + programDb + + -- The set of package names which are "shadowed" by internal + -- packages, and which component they map to + let internalPackageSet :: Set LibraryName + internalPackageSet = getInternalLibraries pkg_descr0 + + -- Make a data structure describing what components are enabled. + let enabled :: ComponentRequestedSpec + enabled = case mb_cname of + Just cname -> OneComponentRequestedSpec cname + Nothing -> + ComponentRequestedSpec + { -- The flag name (@--enable-tests@) is a + -- little bit of a misnomer, because + -- just passing this flag won't + -- "enable", in our internal + -- nomenclature; it's just a request; a + -- @buildable: False@ might make it + -- not possible to enable. + testsRequested = fromFlag (configTests cfg) + , benchmarksRequested = + fromFlag (configBenchmarks cfg) + } + -- Some sanity checks related to enabling components. + when + ( isJust mb_cname + && (fromFlag (configTests cfg) || fromFlag (configBenchmarks cfg)) + ) + $ die' verbosity + $ "--enable-tests/--enable-benchmarks are incompatible with" + ++ " explicitly specifying a component to configure." - -- allConstraints: The set of all 'Dependency's we have. Used ONLY - -- to 'configureFinalizedPackage'. - -- requiredDepsMap: A map from 'PackageName' to the specifically - -- required 'InstalledPackageInfo', due to --dependency - -- - -- NB: These constraints are to be applied to ALL components of - -- a package. Thus, it's not an error if allConstraints contains - -- more constraints than is necessary for a component (another - -- component might need it.) - -- - -- NB: The fact that we bundle all the constraints together means - -- that is not possible to configure a test-suite to use one - -- version of a dependency, and the executable to use another. - (allConstraints :: [PackageVersionConstraint], - requiredDepsMap :: Map (PackageName, ComponentName) InstalledPackageInfo) - <- either (die' verbosity) return $ - combinedConstraints (configConstraints cfg) - (configDependencies cfg) - installedPackageSet - - let promisedDepsSet = mkPromisedDepsSet (configPromisedDependencies cfg) - - -- pkg_descr: The resolved package description, that does not contain any - -- conditionals, because we have an assignment for - -- every flag, either picking them ourselves using a - -- simple naive algorithm, or having them be passed to - -- us by 'configConfigurationsFlags') - -- flags: The 'FlagAssignment' that the conditionals were - -- resolved with. - -- - -- NB: Why doesn't finalizing a package also tell us what the - -- dependencies are (e.g. when we run the naive algorithm, - -- we are checking if dependencies are satisfiable)? The - -- primary reason is that we may NOT have done any solving: - -- if the flags are all chosen for us, this step is a simple - -- matter of flattening according to that assignment. It's - -- cleaner to then configure the dependencies afterwards. - (pkg_descr :: PackageDescription, - flags :: FlagAssignment) - <- configureFinalizedPackage verbosity cfg enabled - allConstraints - (dependencySatisfiable - use_external_internal_deps - (fromFlagOrDefault False (configExactConfiguration cfg)) - (fromFlagOrDefault False (configAllowDependingOnPrivateLibs cfg)) - (packageName pkg_descr0) - installedPackageSet - internalPackageSet - promisedDepsSet - requiredDepsMap) - comp - compPlatform - pkg_descr0 - - debug verbosity $ - "Finalized package description:\n" - ++ showPackageDescription pkg_descr - - let cabalFileDir = - maybe "." takeDirectory $ - flagToMaybe (configCabalFilePath cfg) - checkCompilerProblems verbosity comp pkg_descr enabled - checkPackageProblems + -- Some sanity checks related to dynamic/static linking. + when (fromFlag (configDynExe cfg) && fromFlag (configFullyStaticExe cfg)) $ + die' verbosity $ + "--enable-executable-dynamic and --enable-executable-static" + ++ " are incompatible with each other." + + -- allConstraints: The set of all 'Dependency's we have. Used ONLY + -- to 'configureFinalizedPackage'. + -- requiredDepsMap: A map from 'PackageName' to the specifically + -- required 'InstalledPackageInfo', due to --dependency + -- + -- NB: These constraints are to be applied to ALL components of + -- a package. Thus, it's not an error if allConstraints contains + -- more constraints than is necessary for a component (another + -- component might need it.) + -- + -- NB: The fact that we bundle all the constraints together means + -- that is not possible to configure a test-suite to use one + -- version of a dependency, and the executable to use another. + ( allConstraints :: [PackageVersionConstraint] + , requiredDepsMap :: Map (PackageName, ComponentName) InstalledPackageInfo + ) <- + either (die' verbosity) return $ + combinedConstraints + (configConstraints cfg) + (configDependencies cfg) + installedPackageSet + + let promisedDepsSet = mkPromisedDepsSet (configPromisedDependencies cfg) + + -- pkg_descr: The resolved package description, that does not contain any + -- conditionals, because we have an assignment for + -- every flag, either picking them ourselves using a + -- simple naive algorithm, or having them be passed to + -- us by 'configConfigurationsFlags') + -- flags: The 'FlagAssignment' that the conditionals were + -- resolved with. + -- + -- NB: Why doesn't finalizing a package also tell us what the + -- dependencies are (e.g. when we run the naive algorithm, + -- we are checking if dependencies are satisfiable)? The + -- primary reason is that we may NOT have done any solving: + -- if the flags are all chosen for us, this step is a simple + -- matter of flattening according to that assignment. It's + -- cleaner to then configure the dependencies afterwards. + ( pkg_descr :: PackageDescription + , flags :: FlagAssignment + ) <- + configureFinalizedPackage verbosity - cabalFileDir + cfg + enabled + allConstraints + ( dependencySatisfiable + use_external_internal_deps + (fromFlagOrDefault False (configExactConfiguration cfg)) + (fromFlagOrDefault False (configAllowDependingOnPrivateLibs cfg)) + (packageName pkg_descr0) + installedPackageSet + internalPackageSet + promisedDepsSet + requiredDepsMap + ) + comp + compPlatform pkg_descr0 - (updatePackageDescription pbi pkg_descr) - -- The list of 'InstalledPackageInfo' recording the selected - -- dependencies on external packages. - -- - -- Invariant: For any package name, there is at most one package - -- in externalPackageDeps which has that name. - -- - -- NB: The dependency selection is global over ALL components - -- in the package (similar to how allConstraints and - -- requiredDepsMap are global over all components). In particular, - -- if *any* component (post-flag resolution) has an unsatisfiable - -- dependency, we will fail. This can sometimes be undesirable - -- for users, see #1786 (benchmark conflicts with executable), - -- - -- In the presence of Backpack, these package dependencies are - -- NOT complete: they only ever include the INDEFINITE - -- dependencies. After we apply an instantiation, we'll get - -- definite references which constitute extra dependencies. - -- (Why not have cabal-install pass these in explicitly? - -- For one it's deterministic; for two, we need to associate - -- them with renamings which would require a far more complicated - -- input scheme than what we have today.) - externalPkgDeps :: ([PreExistingComponent], [PromisedComponent]) - <- configureDependencies - verbosity - use_external_internal_deps - internalPackageSet - promisedDepsSet - installedPackageSet - requiredDepsMap - pkg_descr - enabled - - -- Compute installation directory templates, based on user - -- configuration. - -- - -- TODO: Move this into a helper function. - defaultDirs :: InstallDirTemplates <- - defaultInstallDirs' - use_external_internal_deps - (compilerFlavor comp) - (fromFlag (configUserInstall cfg)) - (hasLibs pkg_descr) - let installDirs :: InstallDirTemplates - installDirs = - combineInstallDirs - fromFlagOrDefault - defaultDirs - (configInstallDirs cfg) - - -- Check languages and extensions - -- TODO: Move this into a helper function. - let langlist = - nub $ - catMaybes $ - map - defaultLanguage - (enabledBuildInfos pkg_descr enabled) - let langs = unsupportedLanguages comp langlist - when (not (null langs)) $ - die' verbosity $ - "The package " - ++ prettyShow (packageId pkg_descr0) - ++ " requires the following languages which are not " - ++ "supported by " - ++ prettyShow (compilerId comp) - ++ ": " - ++ intercalate ", " (map prettyShow langs) - let extlist = - nub $ - concatMap - allExtensions + debug verbosity $ + "Finalized package description:\n" + ++ showPackageDescription pkg_descr + + let cabalFileDir = + maybe "." takeDirectory $ + flagToMaybe (configCabalFilePath cfg) + checkCompilerProblems verbosity comp pkg_descr enabled + checkPackageProblems + verbosity + cabalFileDir + pkg_descr0 + (updatePackageDescription pbi pkg_descr) + + -- The list of 'InstalledPackageInfo' recording the selected + -- dependencies on external packages. + -- + -- Invariant: For any package name, there is at most one package + -- in externalPackageDeps which has that name. + -- + -- NB: The dependency selection is global over ALL components + -- in the package (similar to how allConstraints and + -- requiredDepsMap are global over all components). In particular, + -- if *any* component (post-flag resolution) has an unsatisfiable + -- dependency, we will fail. This can sometimes be undesirable + -- for users, see #1786 (benchmark conflicts with executable), + -- + -- In the presence of Backpack, these package dependencies are + -- NOT complete: they only ever include the INDEFINITE + -- dependencies. After we apply an instantiation, we'll get + -- definite references which constitute extra dependencies. + -- (Why not have cabal-install pass these in explicitly? + -- For one it's deterministic; for two, we need to associate + -- them with renamings which would require a far more complicated + -- input scheme than what we have today.) + externalPkgDeps :: ([PreExistingComponent], [PromisedComponent]) <- + configureDependencies + verbosity + use_external_internal_deps + internalPackageSet + promisedDepsSet + installedPackageSet + requiredDepsMap + pkg_descr + enabled + + -- Compute installation directory templates, based on user + -- configuration. + -- + -- TODO: Move this into a helper function. + defaultDirs :: InstallDirTemplates <- + defaultInstallDirs' + use_external_internal_deps + (compilerFlavor comp) + (fromFlag (configUserInstall cfg)) + (hasLibs pkg_descr) + let installDirs :: InstallDirTemplates + installDirs = + combineInstallDirs + fromFlagOrDefault + defaultDirs + (configInstallDirs cfg) + + -- Check languages and extensions + -- TODO: Move this into a helper function. + let langlist = + nub $ + catMaybes $ + map + defaultLanguage (enabledBuildInfos pkg_descr enabled) - let exts = unsupportedExtensions comp extlist - when (not (null exts)) $ - die' verbosity $ - "The package " - ++ prettyShow (packageId pkg_descr0) - ++ " requires the following language extensions which are not " - ++ "supported by " - ++ prettyShow (compilerId comp) - ++ ": " - ++ intercalate ", " (map prettyShow exts) - - -- Check foreign library build requirements - let flibs = [flib | CFLib flib <- enabledComponents pkg_descr enabled] - let unsupportedFLibs = unsupportedForeignLibs comp compPlatform flibs - when (not (null unsupportedFLibs)) $ - die' verbosity $ - "Cannot build some foreign libraries: " - ++ intercalate "," unsupportedFLibs - - -- Configure certain external build tools, see below for which ones. - let requiredBuildTools = do - bi <- enabledBuildInfos pkg_descr enabled - -- First, we collect any tool dep that we know is external. This is, - -- in practice: - -- - -- 1. `build-tools` entries on the whitelist - -- - -- 2. `build-tool-depends` that aren't from the current package. - let externBuildToolDeps = - [ LegacyExeDependency (unUnqualComponentName eName) versionRange - | buildTool@(ExeDependency _ eName versionRange) <- - getAllToolDependencies pkg_descr bi - , not $ isInternal pkg_descr buildTool - ] - -- Second, we collect any build-tools entry we don't know how to - -- desugar. We'll never have any idea how to build them, so we just - -- hope they are already on the PATH. - let unknownBuildTools = - [ buildTool - | buildTool <- buildTools bi - , Nothing == desugarBuildTool pkg_descr buildTool - ] - externBuildToolDeps ++ unknownBuildTools + let langs = unsupportedLanguages comp langlist + when (not (null langs)) $ + die' verbosity $ + "The package " + ++ prettyShow (packageId pkg_descr0) + ++ " requires the following languages which are not " + ++ "supported by " + ++ prettyShow (compilerId comp) + ++ ": " + ++ intercalate ", " (map prettyShow langs) + let extlist = + nub $ + concatMap + allExtensions + (enabledBuildInfos pkg_descr enabled) + let exts = unsupportedExtensions comp extlist + when (not (null exts)) $ + die' verbosity $ + "The package " + ++ prettyShow (packageId pkg_descr0) + ++ " requires the following language extensions which are not " + ++ "supported by " + ++ prettyShow (compilerId comp) + ++ ": " + ++ intercalate ", " (map prettyShow exts) + + -- Check foreign library build requirements + let flibs = [flib | CFLib flib <- enabledComponents pkg_descr enabled] + let unsupportedFLibs = unsupportedForeignLibs comp compPlatform flibs + when (not (null unsupportedFLibs)) $ + die' verbosity $ + "Cannot build some foreign libraries: " + ++ intercalate "," unsupportedFLibs + + -- Configure certain external build tools, see below for which ones. + let requiredBuildTools = do + bi <- enabledBuildInfos pkg_descr enabled + -- First, we collect any tool dep that we know is external. This is, + -- in practice: + -- + -- 1. `build-tools` entries on the whitelist + -- + -- 2. `build-tool-depends` that aren't from the current package. + let externBuildToolDeps = + [ LegacyExeDependency (unUnqualComponentName eName) versionRange + | buildTool@(ExeDependency _ eName versionRange) <- + getAllToolDependencies pkg_descr bi + , not $ isInternal pkg_descr buildTool + ] + -- Second, we collect any build-tools entry we don't know how to + -- desugar. We'll never have any idea how to build them, so we just + -- hope they are already on the PATH. + let unknownBuildTools = + [ buildTool + | buildTool <- buildTools bi + , Nothing == desugarBuildTool pkg_descr buildTool + ] + externBuildToolDeps ++ unknownBuildTools - programDb' <- - configureAllKnownPrograms (lessVerbose verbosity) programDb - >>= configureRequiredPrograms verbosity requiredBuildTools + programDb' <- + configureAllKnownPrograms (lessVerbose verbosity) programDb + >>= configureRequiredPrograms verbosity requiredBuildTools - (pkg_descr', programDb'') <- - configurePkgconfigPackages verbosity pkg_descr programDb' enabled + (pkg_descr', programDb'') <- + configurePkgconfigPackages verbosity pkg_descr programDb' enabled - -- Compute internal component graph - -- - -- The general idea is that we take a look at all the source level - -- components (which may build-depends on each other) and form a graph. - -- From there, we build a ComponentLocalBuildInfo for each of the - -- components, which lets us actually build each component. - -- internalPackageSet - -- use_external_internal_deps - ( buildComponents :: [ComponentLocalBuildInfo] - , packageDependsIndex :: InstalledPackageIndex - ) <- - runLogProgress verbosity $ - configureComponentLocalBuildInfos - verbosity - use_external_internal_deps - enabled - (fromFlagOrDefault False (configDeterministic cfg)) - (configIPID cfg) - (configCID cfg) - pkg_descr - externalPkgDeps - (configConfigurationsFlags cfg) - (configInstantiateWith cfg) - installedPackageSet - comp - - -- Decide if we're going to compile with split sections. - split_sections :: Bool <- - if not (fromFlag $ configSplitSections cfg) - then return False - else case compilerFlavor comp of - GHC - | compilerVersion comp >= mkVersion [8, 0] -> - return True - GHCJS -> - return True - _ -> do - warn - verbosity - ( "this compiler does not support " - ++ "--enable-split-sections; ignoring" - ) - return False + -- Compute internal component graph + -- + -- The general idea is that we take a look at all the source level + -- components (which may build-depends on each other) and form a graph. + -- From there, we build a ComponentLocalBuildInfo for each of the + -- components, which lets us actually build each component. + -- internalPackageSet + -- use_external_internal_deps + ( buildComponents :: [ComponentLocalBuildInfo] + , packageDependsIndex :: InstalledPackageIndex + ) <- + runLogProgress verbosity $ + configureComponentLocalBuildInfos + verbosity + use_external_internal_deps + enabled + (fromFlagOrDefault False (configDeterministic cfg)) + (configIPID cfg) + (configCID cfg) + pkg_descr + externalPkgDeps + (configConfigurationsFlags cfg) + (configInstantiateWith cfg) + installedPackageSet + comp + + -- Decide if we're going to compile with split sections. + split_sections :: Bool <- + if not (fromFlag $ configSplitSections cfg) + then return False + else case compilerFlavor comp of + GHC + | compilerVersion comp >= mkVersion [8, 0] -> + return True + GHCJS -> + return True + _ -> do + warn + verbosity + ( "this compiler does not support " + ++ "--enable-split-sections; ignoring" + ) + return False - -- Decide if we're going to compile with split objects. - split_objs :: Bool <- - if not (fromFlag $ configSplitObjs cfg) - then return False - else case compilerFlavor comp of - _ | split_sections -> - do - warn - verbosity - ( "--enable-split-sections and " - ++ "--enable-split-objs are mutually " - ++ "exclusive; ignoring the latter" - ) - return False - GHC -> - return True - GHCJS -> - return True - _ -> do + -- Decide if we're going to compile with split objects. + split_objs :: Bool <- + if not (fromFlag $ configSplitObjs cfg) + then return False + else case compilerFlavor comp of + _ | split_sections -> + do warn verbosity - ( "this compiler does not support " - ++ "--enable-split-objs; ignoring" + ( "--enable-split-sections and " + ++ "--enable-split-objs are mutually " + ++ "exclusive; ignoring the latter" ) return False + GHC -> + return True + GHCJS -> + return True + _ -> do + warn + verbosity + ( "this compiler does not support " + ++ "--enable-split-objs; ignoring" + ) + return False - let compilerSupportsGhciLibs :: Bool - compilerSupportsGhciLibs = - case compilerId comp of - CompilerId GHC version - | version > mkVersion [9, 3] && windows -> - False - CompilerId GHC _ -> - True - CompilerId GHCJS _ -> - True - _ -> False - where - windows = case compPlatform of - Platform _ Windows -> True - Platform _ _ -> False - - let ghciLibByDefault = - case compilerId comp of + let compilerSupportsGhciLibs :: Bool + compilerSupportsGhciLibs = + case compilerId comp of + CompilerId GHC version + | version > mkVersion [9, 3] && windows -> + False + CompilerId GHC _ -> + True + CompilerId GHCJS _ -> + True + _ -> False + where + windows = case compPlatform of + Platform _ Windows -> True + Platform _ _ -> False + + let ghciLibByDefault = + case compilerId comp of + CompilerId GHC _ -> + -- If ghc is non-dynamic, then ghci needs object files, + -- so we build one by default. + -- + -- Technically, archive files should be sufficient for ghci, + -- but because of GHC bug #8942, it has never been safe to + -- rely on them. By the time that bug was fixed, ghci had + -- been changed to read shared libraries instead of archive + -- files (see next code block). + not (GHC.isDynamic comp) + CompilerId GHCJS _ -> + not (GHCJS.isDynamic comp) + _ -> False + + withGHCiLib_ <- + case fromFlagOrDefault ghciLibByDefault (configGHCiLib cfg) of + True | not compilerSupportsGhciLibs -> do + warn verbosity $ + "--enable-library-for-ghci is no longer supported on Windows with" + ++ " GHC 9.4 and later; ignoring..." + return False + v -> return v + + let sharedLibsByDefault + | fromFlag (configDynExe cfg) = + -- build a shared library if dynamically-linked + -- executables are requested + True + | otherwise = case compilerId comp of CompilerId GHC _ -> - -- If ghc is non-dynamic, then ghci needs object files, - -- so we build one by default. - -- - -- Technically, archive files should be sufficient for ghci, - -- but because of GHC bug #8942, it has never been safe to - -- rely on them. By the time that bug was fixed, ghci had - -- been changed to read shared libraries instead of archive - -- files (see next code block). - not (GHC.isDynamic comp) + -- if ghc is dynamic, then ghci needs a shared + -- library, so we build one by default. + GHC.isDynamic comp CompilerId GHCJS _ -> - not (GHCJS.isDynamic comp) + GHCJS.isDynamic comp _ -> False - - withGHCiLib_ <- - case fromFlagOrDefault ghciLibByDefault (configGHCiLib cfg) of - True | not compilerSupportsGhciLibs -> do - warn verbosity $ - "--enable-library-for-ghci is no longer supported on Windows with" - ++ " GHC 9.4 and later; ignoring..." - return False - v -> return v - - let sharedLibsByDefault - | fromFlag (configDynExe cfg) = - -- build a shared library if dynamically-linked - -- executables are requested - True - | otherwise = case compilerId comp of - CompilerId GHC _ -> - -- if ghc is dynamic, then ghci needs a shared - -- library, so we build one by default. - GHC.isDynamic comp - CompilerId GHCJS _ -> - GHCJS.isDynamic comp - _ -> False - withSharedLib_ = - -- build shared libraries if required by GHC or by the - -- executable linking mode, but allow the user to force - -- building only static library archives with - -- --disable-shared. - fromFlagOrDefault sharedLibsByDefault $ configSharedLib cfg - - withStaticLib_ = - -- build a static library (all dependent libraries rolled - -- into a huge .a archive) via GHCs -staticlib flag. - fromFlagOrDefault False $ configStaticLib cfg - - withDynExe_ = fromFlag $ configDynExe cfg - - withFullyStaticExe_ = fromFlag $ configFullyStaticExe cfg - - when (withDynExe_ && not withSharedLib_) $ - warn verbosity $ - "Executables will use dynamic linking, but a shared library " - ++ "is not being built. Linking will fail if any executables " - ++ "depend on the library." - - setProfLBI <- configureProfiling verbosity cfg comp - - setCoverageLBI <- configureCoverage verbosity cfg comp - - -- Turn off library and executable stripping when `debug-info` is set - -- to anything other than zero. - let - strip_libexe s f = - let defaultStrip = fromFlagOrDefault True (f cfg) - in case fromFlag (configDebugInfo cfg) of - NoDebugInfo -> return defaultStrip - _ -> case f cfg of - Flag True -> do - warn verbosity $ - "Setting debug-info implies " - ++ s - ++ "-stripping: False" - return False - _ -> return False - - strip_lib <- strip_libexe "library" configStripLibs - strip_exe <- strip_libexe "executable" configStripExes - - let reloc = fromFlagOrDefault False $ configRelocatable cfg - - let buildComponentsMap = - foldl' - ( \m clbi -> - Map.insertWith - (++) - (componentLocalName clbi) - [clbi] - m - ) - Map.empty - buildComponents - - let lbi = - (setCoverageLBI . setProfLBI) - LocalBuildInfo - { configFlags = cfg - , flagAssignment = flags - , componentEnabledSpec = enabled - , extraConfigArgs = [] -- Currently configure does not - -- take extra args, but if it - -- did they would go here. - , installDirTemplates = installDirs - , compiler = comp - , hostPlatform = compPlatform - , buildDir = buildDir - , cabalFilePath = flagToMaybe (configCabalFilePath cfg) - , componentGraph = Graph.fromDistinctList buildComponents - , componentNameMap = buildComponentsMap - , installedPkgs = packageDependsIndex - , pkgDescrFile = Nothing - , localPkgDescr = pkg_descr' - , withPrograms = programDb'' - , withVanillaLib = fromFlag $ configVanillaLib cfg - , withSharedLib = withSharedLib_ - , withStaticLib = withStaticLib_ - , withDynExe = withDynExe_ - , withFullyStaticExe = withFullyStaticExe_ - , withProfLib = False - , withProfLibDetail = ProfDetailNone - , withProfExe = False - , withProfExeDetail = ProfDetailNone - , withOptimization = fromFlag $ configOptimization cfg - , withDebugInfo = fromFlag $ configDebugInfo cfg - , withGHCiLib = withGHCiLib_ - , splitSections = split_sections - , splitObjs = split_objs - , stripExes = strip_exe - , stripLibs = strip_lib - , exeCoverage = False - , libCoverage = False - , withPackageDB = packageDbs - , progPrefix = fromFlag $ configProgPrefix cfg - , progSuffix = fromFlag $ configProgSuffix cfg - , relocatable = reloc - } - - when reloc (checkRelocatable verbosity pkg_descr lbi) - - -- TODO: This is not entirely correct, because the dirs may vary - -- across libraries/executables - let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest - relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi - - -- PKGROOT: allowing ${pkgroot} to be passed as --prefix to - -- cabal configure, is only a hidden option. It allows packages - -- to be relocatable with their package database. This however - -- breaks when the Paths_* or other includes are used that - -- contain hard coded paths. This is still an open TODO. - -- - -- Allowing ${pkgroot} here, however requires less custom hooks - -- in scripts that *really* want ${pkgroot}. See haskell/cabal/#4872 - unless - ( isAbsolute (prefix dirs) - || "${pkgroot}" `isPrefixOf` prefix dirs - ) - $ die' verbosity - $ "expected an absolute directory name for --prefix: " ++ prefix dirs - - let lbi = (setCoverageLBI . setProfLBI) - LocalBuildInfo { - configFlags = cfg, - flagAssignment = flags, - componentEnabledSpec = enabled, - extraConfigArgs = [], -- Currently configure does not - -- take extra args, but if it - -- did they would go here. - installDirTemplates = installDirs, - compiler = comp, - hostPlatform = compPlatform, - buildDir = buildDir, - cabalFilePath = flagToMaybe (configCabalFilePath cfg), - componentGraph = Graph.fromDistinctList buildComponents, - componentNameMap = buildComponentsMap, - installedPkgs = packageDependsIndex, - promisedPkgs = promisedDepsSet, - pkgDescrFile = Nothing, - localPkgDescr = pkg_descr', - withPrograms = programDb'', - withVanillaLib = fromFlag $ configVanillaLib cfg, - withSharedLib = withSharedLib_, - withStaticLib = withStaticLib_, - withDynExe = withDynExe_, - withFullyStaticExe = withFullyStaticExe_, - withProfLib = False, - withProfLibDetail = ProfDetailNone, - withProfExe = False, - withProfExeDetail = ProfDetailNone, - withOptimization = fromFlag $ configOptimization cfg, - withDebugInfo = fromFlag $ configDebugInfo cfg, - withGHCiLib = withGHCiLib_, - splitSections = split_sections, - splitObjs = split_objs, - stripExes = strip_exe, - stripLibs = strip_lib, - exeCoverage = False, - libCoverage = False, - withPackageDB = packageDbs, - progPrefix = fromFlag $ configProgPrefix cfg, - progSuffix = fromFlag $ configProgSuffix cfg, - relocatable = reloc - } + withSharedLib_ = + -- build shared libraries if required by GHC or by the + -- executable linking mode, but allow the user to force + -- building only static library archives with + -- --disable-shared. + fromFlagOrDefault sharedLibsByDefault $ configSharedLib cfg + + withStaticLib_ = + -- build a static library (all dependent libraries rolled + -- into a huge .a archive) via GHCs -staticlib flag. + fromFlagOrDefault False $ configStaticLib cfg + + withDynExe_ = fromFlag $ configDynExe cfg + + withFullyStaticExe_ = fromFlag $ configFullyStaticExe cfg + + when (withDynExe_ && not withSharedLib_) $ + warn verbosity $ + "Executables will use dynamic linking, but a shared library " + ++ "is not being built. Linking will fail if any executables " + ++ "depend on the library." + + setProfLBI <- configureProfiling verbosity cfg comp + + setCoverageLBI <- configureCoverage verbosity cfg comp + + -- Turn off library and executable stripping when `debug-info` is set + -- to anything other than zero. + let + strip_libexe s f = + let defaultStrip = fromFlagOrDefault True (f cfg) + in case fromFlag (configDebugInfo cfg) of + NoDebugInfo -> return defaultStrip + _ -> case f cfg of + Flag True -> do + warn verbosity $ + "Setting debug-info implies " + ++ s + ++ "-stripping: False" + return False + _ -> return False + + strip_lib <- strip_libexe "library" configStripLibs + strip_exe <- strip_libexe "executable" configStripExes + + let reloc = fromFlagOrDefault False $ configRelocatable cfg + + let buildComponentsMap = + foldl' + ( \m clbi -> + Map.insertWith + (++) + (componentLocalName clbi) + [clbi] + m + ) + Map.empty + buildComponents + + let lbi = + (setCoverageLBI . setProfLBI) + LocalBuildInfo + { configFlags = cfg + , flagAssignment = flags + , componentEnabledSpec = enabled + , extraConfigArgs = [] -- Currently configure does not + -- take extra args, but if it + -- did they would go here. + , installDirTemplates = installDirs + , compiler = comp + , hostPlatform = compPlatform + , buildDir = buildDir + , cabalFilePath = flagToMaybe (configCabalFilePath cfg) + , componentGraph = Graph.fromDistinctList buildComponents + , componentNameMap = buildComponentsMap + , installedPkgs = packageDependsIndex + , promisedPkgs = promisedDepsSet + , pkgDescrFile = Nothing + , localPkgDescr = pkg_descr' + , withPrograms = programDb'' + , withVanillaLib = fromFlag $ configVanillaLib cfg + , withSharedLib = withSharedLib_ + , withStaticLib = withStaticLib_ + , withDynExe = withDynExe_ + , withFullyStaticExe = withFullyStaticExe_ + , withProfLib = False + , withProfLibDetail = ProfDetailNone + , withProfExe = False + , withProfExeDetail = ProfDetailNone + , withOptimization = fromFlag $ configOptimization cfg + , withDebugInfo = fromFlag $ configDebugInfo cfg + , withGHCiLib = withGHCiLib_ + , splitSections = split_sections + , splitObjs = split_objs + , stripExes = strip_exe + , stripLibs = strip_lib + , exeCoverage = False + , libCoverage = False + , withPackageDB = packageDbs + , progPrefix = fromFlag $ configProgPrefix cfg + , progSuffix = fromFlag $ configProgSuffix cfg + , relocatable = reloc + } + + when reloc (checkRelocatable verbosity pkg_descr lbi) + + -- TODO: This is not entirely correct, because the dirs may vary + -- across libraries/executables + let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest + relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi + + -- PKGROOT: allowing ${pkgroot} to be passed as --prefix to + -- cabal configure, is only a hidden option. It allows packages + -- to be relocatable with their package database. This however + -- breaks when the Paths_* or other includes are used that + -- contain hard coded paths. This is still an open TODO. + -- + -- Allowing ${pkgroot} here, however requires less custom hooks + -- in scripts that *really* want ${pkgroot}. See haskell/cabal/#4872 + unless + ( isAbsolute (prefix dirs) + || "${pkgroot}" `isPrefixOf` prefix dirs + ) + $ die' verbosity + $ "expected an absolute directory name for --prefix: " ++ prefix dirs + + when ("${pkgroot}" `isPrefixOf` prefix dirs) $ + warn verbosity $ + "Using ${pkgroot} in prefix " + ++ prefix dirs + ++ " will not work if you rely on the Path_* module " + ++ " or other hard coded paths. Cabal does not yet " + ++ " support fully relocatable builds! " + ++ " See #462 #2302 #2994 #3305 #3473 #3586 #3909" + ++ " #4097 #4291 #4872" info verbosity $ "Using " @@ -1028,7 +1017,7 @@ configure (pkg_descr0, pbi) cfg = do verbosity = fromFlag (configVerbosity cfg) mkPromisedDepsSet :: [GivenComponent] -> Map (PackageName, ComponentName) ComponentId -mkPromisedDepsSet comps = Map.fromList [ ((pn, CLibName ln), cid) | GivenComponent pn ln cid <- comps ] +mkPromisedDepsSet comps = Map.fromList [((pn, CLibName ln), cid) | GivenComponent pn ln cid <- comps] mkProgramDb :: ConfigFlags -> ProgramDb -> ProgramDb mkProgramDb cfg initialProgramDb = programDb @@ -1114,21 +1103,30 @@ getInternalLibraries pkg_descr0 = -- report a dependency satisfiable even when it is not, but not vice -- versa. This is to be passed to finalize dependencySatisfiable - :: Bool -- ^ use external internal deps? - -> Bool -- ^ exact configuration? - -> Bool -- ^ allow depending on private libs? - -> PackageName - -> InstalledPackageIndex -- ^ installed set - -> Set LibraryName -- ^ library components - -> Map (PackageName, ComponentName) ComponentId - -> Map (PackageName, ComponentName) InstalledPackageInfo - -- ^ required dependencies - -> (Dependency -> Bool) + :: Bool + -- ^ use external internal deps? + -> Bool + -- ^ exact configuration? + -> Bool + -- ^ allow depending on private libs? + -> PackageName + -> InstalledPackageIndex + -- ^ installed set + -> Set LibraryName + -- ^ library components + -> Map (PackageName, ComponentName) ComponentId + -> Map (PackageName, ComponentName) InstalledPackageInfo + -- ^ required dependencies + -> (Dependency -> Bool) dependencySatisfiable use_external_internal_deps exact_config allow_private_deps - pn installedPackageSet packageLibraries promisedDeps requiredDepsMap + pn + installedPackageSet + packageLibraries + promisedDeps + requiredDepsMap (Dependency depName vr sublibs) | exact_config = -- When we're given '--exact-configuration', we assume that all @@ -1178,26 +1176,30 @@ dependencySatisfiable internalDepSatisfiableExternally = all (\ln -> not $ null $ PackageIndex.lookupInternalDependency installedPackageSet pn vr ln) sublibs - -- Check whether a library exists and is visible. - -- We don't disambiguate between dependency on non-existent or private - -- library yet, so we just return a bool and later report a generic error. - visible lib = maybe - False -- Does not even exist (wasn't in the depsMap) - (\ipi -> IPI.libVisibility ipi == LibraryVisibilityPublic - -- If the override is enabled, the visibility does - -- not matter (it's handled externally) - || allow_private_deps - -- If it's a library of the same package then it's - -- always visible. - -- This is only triggered when passing a component - -- of the same package as --dependency, such as in: - -- cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit.test.hs - || pkgName (IPI.sourcePackageId ipi) == pn) - maybeIPI - -- Don't check if it's visible, we promise to build it before we need it. - || promised - where maybeIPI = Map.lookup (depName, CLibName lib) requiredDepsMap - promised = isJust $ Map.lookup (depName, CLibName lib) promisedDeps + -- Check whether a library exists and is visible. + -- We don't disambiguate between dependency on non-existent or private + -- library yet, so we just return a bool and later report a generic error. + visible lib = + maybe + False -- Does not even exist (wasn't in the depsMap) + ( \ipi -> + IPI.libVisibility ipi == LibraryVisibilityPublic + -- If the override is enabled, the visibility does + -- not matter (it's handled externally) + || allow_private_deps + -- If it's a library of the same package then it's + -- always visible. + -- This is only triggered when passing a component + -- of the same package as --dependency, such as in: + -- cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit.test.hs + || pkgName (IPI.sourcePackageId ipi) == pn + ) + maybeIPI + -- Don't check if it's visible, we promise to build it before we need it. + || promised + where + maybeIPI = Map.lookup (depName, CLibName lib) requiredDepsMap + promised = isJust $ Map.lookup (depName, CLibName lib) promisedDeps -- | Finalize a generic package description. The workhorse is -- 'finalizePD' but there's a bit of other nattering @@ -1342,25 +1344,43 @@ checkCompilerProblems verbosity comp pkg_descr enabled = do -- | Select dependencies for the package. configureDependencies - :: Verbosity - -> UseExternalInternalDeps - -> Set LibraryName - -> Map (PackageName, ComponentName) ComponentId - -> InstalledPackageIndex -- ^ installed packages - -> Map (PackageName, ComponentName) InstalledPackageInfo -- ^ required deps - -> PackageDescription - -> ComponentRequestedSpec - -> IO ([PreExistingComponent], [PromisedComponent]) -configureDependencies verbosity use_external_internal_deps - packageLibraries promisedDeps installedPackageSet requiredDepsMap pkg_descr enableSpec = do + :: Verbosity + -> UseExternalInternalDeps + -> Set LibraryName + -> Map (PackageName, ComponentName) ComponentId + -> InstalledPackageIndex + -- ^ installed packages + -> Map (PackageName, ComponentName) InstalledPackageInfo + -- ^ required deps + -> PackageDescription + -> ComponentRequestedSpec + -> IO ([PreExistingComponent], [PromisedComponent]) +configureDependencies + verbosity + use_external_internal_deps + packageLibraries + promisedDeps + installedPackageSet + requiredDepsMap + pkg_descr + enableSpec = do let failedDeps :: [FailedDependency] allPkgDeps :: [ResolvedDependency] - (failedDeps, allPkgDeps) = partitionEithers $ concat - [ fmap (\s -> (dep, s)) <$> status - | dep <- enabledBuildDepends pkg_descr enableSpec - , let status = selectDependency (package pkg_descr) - packageLibraries promisedDeps installedPackageSet - requiredDepsMap use_external_internal_deps dep ] + (failedDeps, allPkgDeps) = + partitionEithers $ + concat + [ fmap (\s -> (dep, s)) <$> status + | dep <- enabledBuildDepends pkg_descr enableSpec + , let status = + selectDependency + (package pkg_descr) + packageLibraries + promisedDeps + installedPackageSet + requiredDepsMap + use_external_internal_deps + dep + ] internalPkgDeps = [ pkgid @@ -1374,16 +1394,21 @@ configureDependencies verbosity use_external_internal_deps | (_, ExternalDependency pec) <- allPkgDeps ] - promisedPkgDeps = [ fpec - | (_, PromisedDependency fpec) <- allPkgDeps ] + promisedPkgDeps = + [ fpec + | (_, PromisedDependency fpec) <- allPkgDeps + ] - when (not (null internalPkgDeps) - && not (newPackageDepsBehaviour pkg_descr)) $ - die' verbosity $ "The field 'build-depends: " - ++ intercalate ", " (map (prettyShow . packageName) internalPkgDeps) - ++ "' refers to a library which is defined within the same " - ++ "package. To use this feature the package must specify at " - ++ "least 'cabal-version: >= 1.8'." + when + ( not (null internalPkgDeps) + && not (newPackageDepsBehaviour pkg_descr) + ) + $ die' verbosity + $ "The field 'build-depends: " + ++ intercalate ", " (map (prettyShow . packageName) internalPkgDeps) + ++ "' refers to a library which is defined within the same " + ++ "package. To use this feature the package must specify at " + ++ "least 'cabal-version: >= 1.8'." reportFailedDependencies verbosity failedDeps reportSelectedDependencies verbosity allPkgDeps @@ -1556,11 +1581,8 @@ data DependencyResolution = -- | An external dependency from the package database, OR an -- internal dependency which we are getting from the package -- database. - = ExternalDependency PreExistingComponent - -- | An internal dependency ('PackageId' should be a library name) - = ExternalDependency PreExistingComponent - - -- | A promised dependency, which doesn't yet exist, but should be provided + ExternalDependency PreExistingComponent + | -- | A promised dependency, which doesn't yet exist, but should be provided -- at the build time. -- -- We have these such that we can configure components without actually @@ -1569,9 +1591,8 @@ data DependencyResolution -- we need to build packages in the interactive ghci session, no matter -- whether they have been built before. -- Building them in the configure phase is then redundant and costs time. - | PromisedDependency PromisedComponent - - -- | An internal dependency ('PackageId' should be a library name) + PromisedDependency PromisedComponent + | -- | An internal dependency ('PackageId' should be a library name) -- which we are going to have to build. (The -- 'PackageId' here is a hack to get a modest amount of -- polymorphism out of the 'Package' typeclass.) @@ -1583,78 +1604,88 @@ data FailedDependency | DependencyNoVersion Dependency -- | Test for a package dependency and record the version we have installed. -selectDependency :: PackageId -- ^ Package id of current package - -> Set LibraryName -- ^ package libraries - -> Map (PackageName, ComponentName) ComponentId -- ^ Set of components that are promised, i.e. are not installed already. See 'PromisedDependency' for more details. - -> InstalledPackageIndex -- ^ Installed packages - -> Map (PackageName, ComponentName) InstalledPackageInfo - -- ^ Packages for which we have been given specific deps to - -- use - -> UseExternalInternalDeps -- ^ Are we configuring a - -- single component? - -> Dependency - -> [Either FailedDependency DependencyResolution] -selectDependency pkgid internalIndex promisedIndex installedIndex requiredDepsMap +selectDependency + :: PackageId + -- ^ Package id of current package + -> Set LibraryName + -- ^ package libraries + -> Map (PackageName, ComponentName) ComponentId + -- ^ Set of components that are promised, i.e. are not installed already. See 'PromisedDependency' for more details. + -> InstalledPackageIndex + -- ^ Installed packages + -> Map (PackageName, ComponentName) InstalledPackageInfo + -- ^ Packages for which we have been given specific deps to + -- use + -> UseExternalInternalDeps + -- ^ Are we configuring a + -- single component? + -> Dependency + -> [Either FailedDependency DependencyResolution] +selectDependency + pkgid + internalIndex + promisedIndex + installedIndex + requiredDepsMap use_external_internal_deps (Dependency dep_pkgname vr libs) = - -- If the dependency specification matches anything in the internal package - -- index, then we prefer that match to anything in the second. - -- For example: - -- - -- Name: MyLibrary - -- Version: 0.1 - -- Library - -- .. - -- Executable my-exec - -- build-depends: MyLibrary - -- - -- We want "build-depends: MyLibrary" always to match the internal library - -- even if there is a newer installed library "MyLibrary-0.2". - if dep_pkgname == pn - then - if use_external_internal_deps - then do_external_internal <$> NES.toList libs - else do_internal <$> NES.toList libs - else - do_external_external <$> NES.toList libs - where - pn = packageName pkgid - - -- It's an internal library, and we're not per-component build - do_internal lib - | Set.member lib internalIndex - = Right $ InternalDependency $ PackageIdentifier dep_pkgname $ packageVersion pkgid - - - | otherwise - = Left $ DependencyMissingInternal dep_pkgname lib - - -- We have to look it up externally - do_external_external :: LibraryName -> Either FailedDependency DependencyResolution - do_external_external lib | Just cid <- Map.lookup (dep_pkgname, CLibName lib) promisedIndex = - return $ PromisedDependency (PromisedComponent dep_pkgname (AnnotatedId currentCabalId (CLibName lib) cid )) - do_external_external lib = do - ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of - -- If we know the exact pkg to use, then use it. - Just pkginstance -> Right pkginstance - -- Otherwise we just pick an arbitrary instance of the latest version. - Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex dep_pkgname vr lib of - Nothing -> Left (DependencyNotExists dep_pkgname) - Just pkg -> Right pkg - return $ ExternalDependency $ ipiToPreExistingComponent ipi - - do_external_internal :: LibraryName -> Either FailedDependency DependencyResolution - do_external_internal lib | Just cid <- Map.lookup (dep_pkgname, CLibName lib) promisedIndex = - return $ PromisedDependency (PromisedComponent dep_pkgname (AnnotatedId currentCabalId (CLibName lib) cid )) - do_external_internal lib = do - ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of - -- If we know the exact pkg to use, then use it. - Just pkginstance -> Right pkginstance - Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex pn vr lib of - -- It's an internal library, being looked up externally - Nothing -> Left (DependencyMissingInternal dep_pkgname lib) - Just pkg -> Right pkg - return $ ExternalDependency $ ipiToPreExistingComponent ipi + -- If the dependency specification matches anything in the internal package + -- index, then we prefer that match to anything in the second. + -- For example: + -- + -- Name: MyLibrary + -- Version: 0.1 + -- Library + -- .. + -- Executable my-exec + -- build-depends: MyLibrary + -- + -- We want "build-depends: MyLibrary" always to match the internal library + -- even if there is a newer installed library "MyLibrary-0.2". + if dep_pkgname == pn + then + if use_external_internal_deps + then do_external_internal <$> NES.toList libs + else do_internal <$> NES.toList libs + else do_external_external <$> NES.toList libs + where + pn = packageName pkgid + + -- It's an internal library, and we're not per-component build + do_internal lib + | Set.member lib internalIndex = + Right $ InternalDependency $ PackageIdentifier dep_pkgname $ packageVersion pkgid + | otherwise = + Left $ DependencyMissingInternal dep_pkgname lib + + -- We have to look it up externally + do_external_external :: LibraryName -> Either FailedDependency DependencyResolution + do_external_external lib + | Just cid <- Map.lookup (dep_pkgname, CLibName lib) promisedIndex = + return $ PromisedDependency (PromisedComponent dep_pkgname (AnnotatedId currentCabalId (CLibName lib) cid)) + do_external_external lib = do + ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of + -- If we know the exact pkg to use, then use it. + Just pkginstance -> Right pkginstance + -- Otherwise we just pick an arbitrary instance of the latest version. + Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex dep_pkgname vr lib of + Nothing -> Left (DependencyNotExists dep_pkgname) + Just pkg -> Right pkg + return $ ExternalDependency $ ipiToPreExistingComponent ipi + + do_external_internal :: LibraryName -> Either FailedDependency DependencyResolution + do_external_internal lib + | Just cid <- Map.lookup (dep_pkgname, CLibName lib) promisedIndex = + return $ PromisedDependency (PromisedComponent dep_pkgname (AnnotatedId currentCabalId (CLibName lib) cid)) + do_external_internal lib = do + ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of + -- If we know the exact pkg to use, then use it. + Just pkginstance -> Right pkginstance + Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex pn vr lib of + -- It's an internal library, being looked up externally + Nothing -> Left (DependencyMissingInternal dep_pkgname lib) + Just pkg -> Right pkg + return $ ExternalDependency $ ipiToPreExistingComponent ipi pickLastIPI :: [(Version, [InstalledPackageInfo])] -> Maybe InstalledPackageInfo pickLastIPI pkgs = safeHead . snd . last =<< nonEmpty pkgs @@ -1664,15 +1695,18 @@ reportSelectedDependencies -> [ResolvedDependency] -> IO () reportSelectedDependencies verbosity deps = - info verbosity $ unlines - [ "Dependency " ++ prettyShow (simplifyDependency dep) - ++ ": using " ++ prettyShow pkgid - | (dep, resolution) <- deps - , let pkgid = case resolution of - ExternalDependency pkg' -> packageId pkg' - InternalDependency pkgid' -> pkgid' - PromisedDependency promisedComp -> packageId promisedComp - ] + info verbosity $ + unlines + [ "Dependency " + ++ prettyShow (simplifyDependency dep) + ++ ": using " + ++ prettyShow pkgid + | (dep, resolution) <- deps + , let pkgid = case resolution of + ExternalDependency pkg' -> packageId pkg' + InternalDependency pkgid' -> pkgid' + PromisedDependency promisedComp -> packageId promisedComp + ] reportFailedDependencies :: Verbosity -> [FailedDependency] -> IO () reportFailedDependencies _ [] = return () @@ -1814,7 +1848,8 @@ interpretPackageDbFlags userInstall specificDBs = -- pick. combinedConstraints :: [PackageVersionConstraint] - -> [GivenComponent] -- ^ installed dependencies + -> [GivenComponent] + -- ^ installed dependencies -> InstalledPackageIndex -> Either String diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs index f3576353ee1..3f02f130f39 100644 --- a/Cabal/src/Distribution/Simple/GHC.hs +++ b/Cabal/src/Distribution/Simple/GHC.hs @@ -92,7 +92,7 @@ import Distribution.PackageDescription.Utils (cabalBug) import Distribution.Pretty import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler -import Distribution.Simple.Flag (Flag (Flag), fromFlag, fromFlagOrDefault, toFlag) +import Distribution.Simple.Flag (Flag (..), fromFlag, fromFlagOrDefault, toFlag) import Distribution.Simple.GHC.EnvironmentParser import Distribution.Simple.GHC.ImplInfo import qualified Distribution.Simple.GHC.Internal as Internal @@ -104,7 +104,9 @@ import Distribution.Simple.Program import qualified Distribution.Simple.Program.Ar as Ar import Distribution.Simple.Program.Builtin (runghcProgram) import Distribution.Simple.Program.GHC -import Distribution.Simple.Flag ( Flag(..), fromFlag, fromFlagOrDefault, toFlag ) +import qualified Distribution.Simple.Program.HcPkg as HcPkg +import qualified Distribution.Simple.Program.Ld as Ld +import qualified Distribution.Simple.Program.Strip as Strip import Distribution.Simple.Setup.Config import Distribution.Simple.Setup.Repl import Distribution.Simple.Utils @@ -121,21 +123,33 @@ import Control.Monad (forM_, msum) import Data.Char (isLower) import qualified Data.Map as Map import System.Directory - ( doesFileExist, doesDirectoryExist - , getAppUserDataDirectory, createDirectoryIfMissing - , canonicalizePath, removeFile, renameFile, getDirectoryContents - , makeRelativeToCurrentDirectory, doesDirectoryExist ) -import System.FilePath ( (), (<.>), takeExtension - , takeDirectory, replaceExtension - ,isRelative ) + ( canonicalizePath + , createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , getAppUserDataDirectory + , getCurrentDirectory + , getDirectoryContents + , makeRelativeToCurrentDirectory + , removeFile + , renameFile + ) +import System.FilePath + ( isRelative + , replaceExtension + , takeDirectory + , takeExtension + , (<.>) + , () + ) import qualified System.Info #ifndef mingw32_HOST_OS import System.Posix (createSymbolicLink) #endif /* mingw32_HOST_OS */ import qualified Data.ByteString.Lazy.Char8 as BS +import Distribution.Compat.Binary (encode) import Distribution.Compat.ResponseFile (escapeArgs) import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.Compat.Binary (encode) -- ----------------------------------------------------------------------------- -- Configuring @@ -695,55 +709,71 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do , ghcOptHPCDir = hpcdir Hpc.Prof } - sharedOpts = vanillaOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "dyn_hi", - ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcSharedOptions GHC libBi, - ghcOptHPCDir = hpcdir Hpc.Dyn - } - linkerOpts = mempty { - ghcOptLinkOptions = PD.ldOptions libBi - ++ [ "-static" - | withFullyStaticExe lbi ] - -- Pass extra `ld-options` given - -- through to GHC's linker. - ++ maybe [] programOverrideArgs - (lookupProgram ldProgram (withPrograms lbi)), - ghcOptLinkLibs = if withFullyStaticExe lbi - then extraLibsStatic libBi - else extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ - if withFullyStaticExe lbi - then cleanedExtraLibDirsStatic - else cleanedExtraLibDirs, - ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, - ghcOptLinkFrameworkDirs = toNubListR $ - PD.extraFrameworkDirs libBi, - ghcOptInputFiles = toNubListR - [relLibTargetDir x | x <- cLikeObjs] - } - replOpts = vanillaOpts { - ghcOptExtra = Internal.filterGhciFlags - (ghcOptExtra vanillaOpts) - <> replOptionsFlags replFlags, - ghcOptNumJobs = mempty, - ghcOptInputModules = replNoLoad replFlags (ghcOptInputModules vanillaOpts) - } - `mappend` linkerOpts - `mappend` mempty { - ghcOptMode = isInteractive, - ghcOptOptimisation = toFlag GhcNoOptimisation - } + sharedOpts = + vanillaOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptFPic = toFlag True + , ghcOptHiSuffix = toFlag "dyn_hi" + , ghcOptObjSuffix = toFlag "dyn_o" + , ghcOptExtra = hcSharedOptions GHC libBi + , ghcOptHPCDir = hpcdir Hpc.Dyn + } + linkerOpts = + mempty + { ghcOptLinkOptions = + PD.ldOptions libBi + ++ [ "-static" + | withFullyStaticExe lbi + ] + -- Pass extra `ld-options` given + -- through to GHC's linker. + ++ maybe + [] + programOverrideArgs + (lookupProgram ldProgram (withPrograms lbi)) + , ghcOptLinkLibs = + if withFullyStaticExe lbi + then extraLibsStatic libBi + else extraLibs libBi + , ghcOptLinkLibPath = + toNubListR $ + if withFullyStaticExe lbi + then cleanedExtraLibDirsStatic + else cleanedExtraLibDirs + , ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi + , ghcOptLinkFrameworkDirs = + toNubListR $ + PD.extraFrameworkDirs libBi + , ghcOptInputFiles = + toNubListR + [relLibTargetDir x | x <- cLikeObjs] + } + replOpts = + vanillaOpts + { ghcOptExtra = + Internal.filterGhciFlags + (ghcOptExtra vanillaOpts) + <> replOptionsFlags replFlags + , ghcOptNumJobs = mempty + , ghcOptInputModules = replNoLoad replFlags (ghcOptInputModules vanillaOpts) + } + `mappend` linkerOpts + `mappend` mempty + { ghcOptMode = isInteractive + , ghcOptOptimisation = toFlag GhcNoOptimisation + } + isInteractive = toFlag GhcModeInteractive - vanillaSharedOpts = vanillaOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, - ghcOptDynHiSuffix = toFlag "dyn_hi", - ghcOptDynObjSuffix = toFlag "dyn_o", - ghcOptHPCDir = hpcdir Hpc.Dyn - } + vanillaSharedOpts = + vanillaOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic + , ghcOptDynHiSuffix = toFlag "dyn_hi" + , ghcOptDynObjSuffix = toFlag "dyn_o" + , ghcOptHPCDir = hpcdir Hpc.Dyn + } unless (forRepl || null (allLibModules lib clbi)) $ do @@ -1117,67 +1147,74 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do , -- For dynamic libs, Mac OS/X needs to know the install location -- at build time. This only applies to GHC < 7.8 - see the -- discussion in #1660. - ghcOptDylibName = if hostOS == OSX - && ghcVersion < mkVersion [7,8] - then toFlag sharedLibInstallPath - else mempty, - ghcOptHideAllPackages = toFlag True, - ghcOptNoAutoLinkPackages = toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo { componentCompatPackageKey = pk } - -> toFlag pk - _ -> mempty, - ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo - { componentInstantiatedWith = insts } -> - if null insts - then mempty - else toFlag (componentComponentId clbi) - _ -> mempty, - ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo - { componentInstantiatedWith = insts } - -> insts - _ -> [], - ghcOptPackages = toNubListR $ - Internal.mkGhcOptPackages mempty clbi , - ghcOptLinkLibs = extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs, - ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, - ghcOptLinkFrameworkDirs = - toNubListR $ PD.extraFrameworkDirs libBi, - ghcOptRPaths = rpaths + ghcOptDylibName = + if hostOS == OSX + && ghcVersion < mkVersion [7, 8] + then toFlag sharedLibInstallPath + else mempty + , ghcOptHideAllPackages = toFlag True + , ghcOptNoAutoLinkPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> + toFlag pk + _ -> mempty + , ghcOptThisComponentId = case clbi of + LibComponentLocalBuildInfo + { componentInstantiatedWith = insts + } -> + if null insts + then mempty + else toFlag (componentComponentId clbi) + _ -> mempty + , ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo + { componentInstantiatedWith = insts + } -> + insts + _ -> [] + , ghcOptPackages = + toNubListR $ + Internal.mkGhcOptPackages mempty clbi + , ghcOptLinkLibs = extraLibs libBi + , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs + , ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi + , ghcOptLinkFrameworkDirs = + toNubListR $ PD.extraFrameworkDirs libBi + , ghcOptRPaths = rpaths } ghcStaticLinkArgs = - mempty { - ghcOptStaticLib = toFlag True, - ghcOptInputFiles = toNubListR staticObjectFiles, - ghcOptOutputFile = toFlag staticLibFilePath, - ghcOptExtra = hcStaticOptions GHC libBi, - ghcOptHideAllPackages = toFlag True, - ghcOptNoAutoLinkPackages = toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo { componentCompatPackageKey = pk } - -> toFlag pk - _ -> mempty, - ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo - { componentInstantiatedWith = insts } -> - if null insts - then mempty - else toFlag (componentComponentId clbi) - _ -> mempty, - ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo - { componentInstantiatedWith = insts } - -> insts - _ -> [], - ghcOptPackages = toNubListR $ - Internal.mkGhcOptPackages mempty clbi , - ghcOptLinkLibs = extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs + mempty + { ghcOptStaticLib = toFlag True + , ghcOptInputFiles = toNubListR staticObjectFiles + , ghcOptOutputFile = toFlag staticLibFilePath + , ghcOptExtra = hcStaticOptions GHC libBi + , ghcOptHideAllPackages = toFlag True + , ghcOptNoAutoLinkPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> + toFlag pk + _ -> mempty + , ghcOptThisComponentId = case clbi of + LibComponentLocalBuildInfo + { componentInstantiatedWith = insts + } -> + if null insts + then mempty + else toFlag (componentComponentId clbi) + _ -> mempty + , ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo + { componentInstantiatedWith = insts + } -> + insts + _ -> [] + , ghcOptPackages = + toNubListR $ + Internal.mkGhcOptPackages mempty clbi + , ghcOptLinkLibs = extraLibs libBi + , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs } info verbosity (show (ghcOptPackages ghcSharedLinkArgs)) @@ -1228,7 +1265,6 @@ startInterpreter verbosity progdb comp platform packageDBs = do (ghcProg, _) <- requireProgram verbosity ghcProgram progdb runGHC verbosity ghcProg comp platform replOpts - runReplOrWriteFlags :: Verbosity -> ConfiguredProgram @@ -1247,16 +1283,17 @@ runReplOrWriteFlags verbosity ghcProg comp platform rflags replOpts bi clbi pkg_ src_dir <- getCurrentDirectory let uid = componentUnitId clbi this_unit = prettyShow uid - reexported_modules = [mn | LibComponentLocalBuildInfo {} <- [clbi], IPI.ExposedModule mn (Just {}) <- componentExposedModules clbi] + reexported_modules = [mn | LibComponentLocalBuildInfo{} <- [clbi], IPI.ExposedModule mn (Just{}) <- componentExposedModules clbi] hidden_modules = otherModules bi - extra_opts = concat $ - [ ["-this-package-name", prettyShow pkg_name] - , ["-working-dir" , src_dir] - ] ++ - [ ["-reexported-module", prettyShow m] | m <- reexported_modules - ] ++ - [ ["-hidden-module", prettyShow m] | m <- hidden_modules - ] + extra_opts = + concat $ + [ ["-this-package-name", prettyShow pkg_name] + , ["-working-dir", src_dir] + ] + ++ [ ["-reexported-module", prettyShow m] | m <- reexported_modules + ] + ++ [ ["-hidden-module", prettyShow m] | m <- hidden_modules + ] -- Create "paths" subdirectory if it doesn't exist. This is where we write -- information about how the PATH was augmented. createDirectoryIfMissing False (out_dir "paths") @@ -1264,8 +1301,10 @@ runReplOrWriteFlags verbosity ghcProg comp platform rflags replOpts bi clbi pkg_ writeFileAtomic (out_dir "paths" this_unit) (encode ghcProg) -- Write out options for this component into a file ready for loading into -- the multi-repl - writeFileAtomic (out_dir this_unit) $ BS.pack $ escapeArgs - $ extra_opts ++ renderGhcOptions comp platform (replOpts { ghcOptMode = NoFlag }) + writeFileAtomic (out_dir this_unit) $ + BS.pack $ + escapeArgs $ + extra_opts ++ renderGhcOptions comp platform (replOpts{ghcOptMode = NoFlag}) -- ----------------------------------------------------------------------------- -- Building an executable or foreign library @@ -1929,7 +1968,7 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do -- with ghci, but .c files can depend on .h files generated by ghc by ffi -- exports. case bm of - GReplExe _ _ -> runReplOrWriteFlags verbosity ghcProg comp platform replFlags replOpts bnfo clbi (pkgName (PD.package pkg_descr)) + GReplExe _ _ -> runReplOrWriteFlags verbosity ghcProg comp platform replFlags replOpts bnfo clbi (pkgName (PD.package pkg_descr)) GReplFLib _ _ -> runReplOrWriteFlags verbosity ghcProg comp platform replFlags replOpts bnfo clbi (pkgName (PD.package pkg_descr)) GBuildExe _ -> do let linkOpts = diff --git a/Cabal/src/Distribution/Simple/GHC/ImplInfo.hs b/Cabal/src/Distribution/Simple/GHC/ImplInfo.hs index f77d2e231fe..34935f5c93e 100644 --- a/Cabal/src/Distribution/Simple/GHC/ImplInfo.hs +++ b/Cabal/src/Distribution/Simple/GHC/ImplInfo.hs @@ -34,19 +34,32 @@ import Distribution.Version -- module) should use implementation info rather than version numbers -- to test for supported features. data GhcImplInfo = GhcImplInfo - { supportsHaskell2010 :: Bool -- ^ -XHaskell2010 and -XHaskell98 flags - , supportsGHC2021 :: Bool -- ^ -XGHC2021 flag - , reportsNoExt :: Bool -- ^ --supported-languages gives Ext and NoExt - , alwaysNondecIndent :: Bool -- ^ NondecreasingIndentation is always on - , flagGhciScript :: Bool -- ^ -ghci-script flag supported - , flagProfAuto :: Bool -- ^ new style -fprof-auto* flags - , flagProfLate :: Bool -- ^ fprof-late flag - , flagPackageConf :: Bool -- ^ use package-conf instead of package-db - , flagDebugInfo :: Bool -- ^ -g flag supported - , supportsDebugLevels :: Bool -- ^ supports numeric @-g@ levels - , supportsPkgEnvFiles :: Bool -- ^ picks up @.ghc.environment@ files - , flagWarnMissingHomeModules :: Bool -- ^ -Wmissing-home-modules is supported - , unitIdForExes :: Bool -- ^ Pass -this-unit-id flag when building executables + { supportsHaskell2010 :: Bool + -- ^ -XHaskell2010 and -XHaskell98 flags + , supportsGHC2021 :: Bool + -- ^ -XGHC2021 flag + , reportsNoExt :: Bool + -- ^ --supported-languages gives Ext and NoExt + , alwaysNondecIndent :: Bool + -- ^ NondecreasingIndentation is always on + , flagGhciScript :: Bool + -- ^ -ghci-script flag supported + , flagProfAuto :: Bool + -- ^ new style -fprof-auto* flags + , flagProfLate :: Bool + -- ^ fprof-late flag + , flagPackageConf :: Bool + -- ^ use package-conf instead of package-db + , flagDebugInfo :: Bool + -- ^ -g flag supported + , supportsDebugLevels :: Bool + -- ^ supports numeric @-g@ levels + , supportsPkgEnvFiles :: Bool + -- ^ picks up @.ghc.environment@ files + , flagWarnMissingHomeModules :: Bool + -- ^ -Wmissing-home-modules is supported + , unitIdForExes :: Bool + -- ^ Pass -this-unit-id flag when building executables } getImplInfo :: Compiler -> GhcImplInfo @@ -69,41 +82,46 @@ getImplInfo comp = ) ghcVersionImplInfo :: Version -> GhcImplInfo -ghcVersionImplInfo ver = GhcImplInfo - { supportsHaskell2010 = v >= [7] - , supportsGHC2021 = v >= [9,1] - , reportsNoExt = v >= [7] - , alwaysNondecIndent = v < [7,1] - , flagGhciScript = v >= [7,2] - , flagProfAuto = v >= [7,4] - , flagProfLate = v >= [9,4] - , flagPackageConf = v < [7,5] - , flagDebugInfo = v >= [7,10] - , supportsDebugLevels = v >= [8,0] - , supportsPkgEnvFiles = v >= [8,0,1,20160901] -- broken in 8.0.1, fixed in 8.0.2 - , flagWarnMissingHomeModules = v >= [8,2] - , unitIdForExes = v >= [9,2] - } +ghcVersionImplInfo ver = + GhcImplInfo + { supportsHaskell2010 = v >= [7] + , supportsGHC2021 = v >= [9, 1] + , reportsNoExt = v >= [7] + , alwaysNondecIndent = v < [7, 1] + , flagGhciScript = v >= [7, 2] + , flagProfAuto = v >= [7, 4] + , flagProfLate = v >= [9, 4] + , flagPackageConf = v < [7, 5] + , flagDebugInfo = v >= [7, 10] + , supportsDebugLevels = v >= [8, 0] + , supportsPkgEnvFiles = v >= [8, 0, 1, 20160901] -- broken in 8.0.1, fixed in 8.0.2 + , flagWarnMissingHomeModules = v >= [8, 2] + , unitIdForExes = v >= [9, 2] + } where v = versionNumbers ver -ghcjsVersionImplInfo :: Version -- ^ The GHCJS version - -> Version -- ^ The GHC version - -> GhcImplInfo -ghcjsVersionImplInfo _ghcjsver ghcver = GhcImplInfo - { supportsHaskell2010 = True - , supportsGHC2021 = True - , reportsNoExt = True - , alwaysNondecIndent = False - , flagGhciScript = True - , flagProfAuto = True - , flagProfLate = True - , flagPackageConf = False - , flagDebugInfo = False - , supportsDebugLevels = ghcv >= [8,0] - , supportsPkgEnvFiles = ghcv >= [8,0,2] --TODO: check this works in ghcjs - , flagWarnMissingHomeModules = ghcv >= [8,2] - , unitIdForExes = ghcv >= [9,2] - } +ghcjsVersionImplInfo + :: Version + -- ^ The GHCJS version + -> Version + -- ^ The GHC version + -> GhcImplInfo +ghcjsVersionImplInfo _ghcjsver ghcver = + GhcImplInfo + { supportsHaskell2010 = True + , supportsGHC2021 = True + , reportsNoExt = True + , alwaysNondecIndent = False + , flagGhciScript = True + , flagProfAuto = True + , flagProfLate = True + , flagPackageConf = False + , flagDebugInfo = False + , supportsDebugLevels = ghcv >= [8, 0] + , supportsPkgEnvFiles = ghcv >= [8, 0, 2] -- TODO: check this works in ghcjs + , flagWarnMissingHomeModules = ghcv >= [8, 2] + , unitIdForExes = ghcv >= [9, 2] + } where ghcv = versionNumbers ghcver diff --git a/Cabal/src/Distribution/Simple/GHC/Internal.hs b/Cabal/src/Distribution/Simple/GHC/Internal.hs index 7a68cd29336..b8c3490f33e 100644 --- a/Cabal/src/Distribution/Simple/GHC/Internal.hs +++ b/Cabal/src/Distribution/Simple/GHC/Internal.hs @@ -78,15 +78,20 @@ import Distribution.Verbosity import Distribution.Version (Version) import Language.Haskell.Extension +import qualified Data.ByteString.Lazy.Char8 as BS import qualified Data.Map as Map import qualified Data.Set as Set -import qualified Data.ByteString.Lazy.Char8 as BS -import System.Directory ( getDirectoryContents, getTemporaryDirectory ) -import System.Environment ( getEnv ) -import System.FilePath ( (), (<.>), takeExtension - , takeDirectory, takeFileName) -import System.IO ( hClose, hPutStrLn ) import Distribution.Types.ComponentId (ComponentId) +import System.Directory (getDirectoryContents, getTemporaryDirectory) +import System.Environment (getEnv) +import System.FilePath + ( takeDirectory + , takeExtension + , takeFileName + , (<.>) + , () + ) +import System.IO (hClose, hPutStrLn) targetPlatform :: [(String, String)] -> Maybe Platform targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo @@ -335,34 +340,41 @@ componentCcGhcOptions verbosity _implInfo lbi bi clbi odir filename = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptMode = toFlag GhcModeCompile, - ghcOptInputFiles = toNubListR [filename], - - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptHideAllPackages= toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi, - ghcOptCcOptions = (case withOptimization lbi of - NoOptimisation -> [] - _ -> ["-O2"]) ++ - (case withDebugInfo lbi of - NoDebugInfo -> [] - MinimalDebugInfo -> ["-g1"] - NormalDebugInfo -> ["-g"] - MaximalDebugInfo -> ["-g3"]) ++ - ccOptions bi, - ghcOptCcProgram = maybeToFlag $ programPath <$> - lookupProgram gccProgram (withPrograms lbi), - ghcOptObjDir = toFlag odir, - ghcOptExtra = hcOptions GHC bi + ghcOptVerbosity = toFlag (min verbosity normal) + , ghcOptMode = toFlag GhcModeCompile + , ghcOptInputFiles = toNubListR [filename] + , ghcOptCppIncludePath = + toNubListR $ + [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + , odir + ] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- includeDirs bi] + , ghcOptHideAllPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi + , ghcOptCcOptions = + ( case withOptimization lbi of + NoOptimisation -> [] + _ -> ["-O2"] + ) + ++ ( case withDebugInfo lbi of + NoDebugInfo -> [] + MinimalDebugInfo -> ["-g1"] + NormalDebugInfo -> ["-g"] + MaximalDebugInfo -> ["-g3"] + ) + ++ ccOptions bi + , ghcOptCcProgram = + maybeToFlag $ + programPath + <$> lookupProgram gccProgram (withPrograms lbi) + , ghcOptObjDir = toFlag odir + , ghcOptExtra = hcOptions GHC bi } componentCxxGhcOptions @@ -378,34 +390,41 @@ componentCxxGhcOptions verbosity _implInfo lbi bi clbi odir filename = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptMode = toFlag GhcModeCompile, - ghcOptInputFiles = toNubListR [filename], - - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptHideAllPackages= toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi, - ghcOptCxxOptions = (case withOptimization lbi of - NoOptimisation -> [] - _ -> ["-O2"]) ++ - (case withDebugInfo lbi of - NoDebugInfo -> [] - MinimalDebugInfo -> ["-g1"] - NormalDebugInfo -> ["-g"] - MaximalDebugInfo -> ["-g3"]) ++ - cxxOptions bi, - ghcOptCcProgram = maybeToFlag $ programPath <$> - lookupProgram gccProgram (withPrograms lbi), - ghcOptObjDir = toFlag odir, - ghcOptExtra = hcOptions GHC bi + ghcOptVerbosity = toFlag (min verbosity normal) + , ghcOptMode = toFlag GhcModeCompile + , ghcOptInputFiles = toNubListR [filename] + , ghcOptCppIncludePath = + toNubListR $ + [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + , odir + ] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- includeDirs bi] + , ghcOptHideAllPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi + , ghcOptCxxOptions = + ( case withOptimization lbi of + NoOptimisation -> [] + _ -> ["-O2"] + ) + ++ ( case withDebugInfo lbi of + NoDebugInfo -> [] + MinimalDebugInfo -> ["-g1"] + NormalDebugInfo -> ["-g"] + MaximalDebugInfo -> ["-g3"] + ) + ++ cxxOptions bi + , ghcOptCcProgram = + maybeToFlag $ + programPath + <$> lookupProgram gccProgram (withPrograms lbi) + , ghcOptObjDir = toFlag odir + , ghcOptExtra = hcOptions GHC bi } componentAsmGhcOptions @@ -421,31 +440,36 @@ componentAsmGhcOptions verbosity _implInfo lbi bi clbi odir filename = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptMode = toFlag GhcModeCompile, - ghcOptInputFiles = toNubListR [filename], - - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptHideAllPackages= toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi, - ghcOptAsmOptions = (case withOptimization lbi of - NoOptimisation -> [] - _ -> ["-O2"]) ++ - (case withDebugInfo lbi of - NoDebugInfo -> [] - MinimalDebugInfo -> ["-g1"] - NormalDebugInfo -> ["-g"] - MaximalDebugInfo -> ["-g3"]) ++ - asmOptions bi, - ghcOptObjDir = toFlag odir + ghcOptVerbosity = toFlag (min verbosity normal) + , ghcOptMode = toFlag GhcModeCompile + , ghcOptInputFiles = toNubListR [filename] + , ghcOptCppIncludePath = + toNubListR $ + [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + , odir + ] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- includeDirs bi] + , ghcOptHideAllPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi + , ghcOptAsmOptions = + ( case withOptimization lbi of + NoOptimisation -> [] + _ -> ["-O2"] + ) + ++ ( case withDebugInfo lbi of + NoDebugInfo -> [] + MinimalDebugInfo -> ["-g1"] + NormalDebugInfo -> ["-g"] + MaximalDebugInfo -> ["-g3"] + ) + ++ asmOptions bi + , ghcOptObjDir = toFlag odir } componentJsGhcOptions @@ -461,22 +485,24 @@ componentJsGhcOptions verbosity _implInfo lbi bi clbi odir filename = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptMode = toFlag GhcModeCompile, - ghcOptInputFiles = toNubListR [filename], - - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptHideAllPackages= toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi, - ghcOptObjDir = toFlag odir + ghcOptVerbosity = toFlag (min verbosity normal) + , ghcOptMode = toFlag GhcModeCompile + , ghcOptInputFiles = toNubListR [filename] + , ghcOptCppIncludePath = + toNubListR $ + [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + , odir + ] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- includeDirs bi] + , ghcOptHideAllPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi + , ghcOptObjDir = toFlag odir } componentGhcOptions @@ -491,69 +517,75 @@ componentGhcOptions verbosity implInfo lbi bi clbi odir = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptCabal = toFlag True, - ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo { componentCompatPackageKey = pk } - -> toFlag pk + ghcOptVerbosity = toFlag (min verbosity normal) + , ghcOptCabal = toFlag True + , ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> + toFlag pk _ | not (unitIdForExes implInfo) -> mempty - ExeComponentLocalBuildInfo { componentUnitId = uid } - -> toFlag (unUnitId uid) - TestComponentLocalBuildInfo { componentUnitId = uid } - -> toFlag (unUnitId uid) - BenchComponentLocalBuildInfo { componentUnitId = uid } - -> toFlag (unUnitId uid) - FLibComponentLocalBuildInfo { componentUnitId = uid } - -> toFlag (unUnitId uid) - - , - ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo { componentComponentId = cid - , componentInstantiatedWith = insts } -> - if null insts - then mempty - else toFlag cid - _ -> mempty, - ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } - -> insts - _ -> [], - ghcOptNoCode = toFlag $ componentIsIndefinite clbi, - ghcOptHideAllPackages = toFlag True, - ghcOptWarnMissingHomeModules = toFlag $ flagWarnMissingHomeModules implInfo, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages mempty clbi, - ghcOptSplitSections = toFlag (splitSections lbi), - ghcOptSplitObjs = toFlag (splitObjs lbi), - ghcOptSourcePathClear = toFlag True, - ghcOptSourcePath = toNubListR $ map getSymbolicPath (hsSourceDirs bi) - ++ [odir] - ++ [autogenComponentModulesDir lbi clbi] - ++ [autogenPackageModulesDir lbi], - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptCppOptions = cppOptions bi, - ghcOptCppIncludes = toNubListR $ - [autogenComponentModulesDir lbi clbi cppHeaderName], - ghcOptFfiIncludes = toNubListR $ includes bi, - ghcOptObjDir = toFlag odir, - ghcOptHiDir = toFlag odir, - ghcOptStubDir = toFlag odir, - ghcOptOutputDir = toFlag odir, - ghcOptOptimisation = toGhcOptimisation (withOptimization lbi), - ghcOptDebugInfo = toFlag (withDebugInfo lbi), - ghcOptExtra = hcOptions GHC bi, - ghcOptExtraPath = toNubListR $ exe_paths, - ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi)), - -- Unsupported extensions have already been checked by configure - ghcOptExtensions = toNubListR $ usedExtensions bi, - ghcOptExtensionMap = Map.fromList . compilerExtensions $ (compiler lbi) + ExeComponentLocalBuildInfo{componentUnitId = uid} -> + toFlag (unUnitId uid) + TestComponentLocalBuildInfo{componentUnitId = uid} -> + toFlag (unUnitId uid) + BenchComponentLocalBuildInfo{componentUnitId = uid} -> + toFlag (unUnitId uid) + FLibComponentLocalBuildInfo{componentUnitId = uid} -> + toFlag (unUnitId uid) + , ghcOptThisComponentId = case clbi of + LibComponentLocalBuildInfo + { componentComponentId = cid + , componentInstantiatedWith = insts + } -> + if null insts + then mempty + else toFlag cid + _ -> mempty + , ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> + insts + _ -> [] + , ghcOptNoCode = toFlag $ componentIsIndefinite clbi + , ghcOptHideAllPackages = toFlag True + , ghcOptWarnMissingHomeModules = toFlag $ flagWarnMissingHomeModules implInfo + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages mempty clbi + , ghcOptSplitSections = toFlag (splitSections lbi) + , ghcOptSplitObjs = toFlag (splitObjs lbi) + , ghcOptSourcePathClear = toFlag True + , ghcOptSourcePath = + toNubListR $ + map getSymbolicPath (hsSourceDirs bi) + ++ [odir] + ++ [autogenComponentModulesDir lbi clbi] + ++ [autogenPackageModulesDir lbi] + , ghcOptCppIncludePath = + toNubListR $ + [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + , odir + ] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- includeDirs bi] + , ghcOptCppOptions = cppOptions bi + , ghcOptCppIncludes = + toNubListR $ + [autogenComponentModulesDir lbi clbi cppHeaderName] + , ghcOptFfiIncludes = toNubListR $ includes bi + , ghcOptObjDir = toFlag odir + , ghcOptHiDir = toFlag odir + , ghcOptStubDir = toFlag odir + , ghcOptOutputDir = toFlag odir + , ghcOptOptimisation = toGhcOptimisation (withOptimization lbi) + , ghcOptDebugInfo = toFlag (withDebugInfo lbi) + , ghcOptExtra = hcOptions GHC bi + , ghcOptExtraPath = toNubListR $ exe_paths + , ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi)) + , -- Unsupported extensions have already been checked by configure + ghcOptExtensions = toNubListR $ usedExtensions bi + , ghcOptExtensionMap = Map.fromList . compilerExtensions $ (compiler lbi) } where exe_paths = @@ -581,28 +613,31 @@ componentCmmGhcOptions verbosity _implInfo lbi bi clbi odir filename = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptMode = toFlag GhcModeCompile, - ghcOptInputFiles = toNubListR [filename], - - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptCppOptions = cppOptions bi, - ghcOptCppIncludes = toNubListR $ - [autogenComponentModulesDir lbi clbi cppHeaderName], - ghcOptHideAllPackages= toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi, - ghcOptOptimisation = toGhcOptimisation (withOptimization lbi), - ghcOptDebugInfo = toFlag (withDebugInfo lbi), - ghcOptExtra = cmmOptions bi, - ghcOptObjDir = toFlag odir + ghcOptVerbosity = toFlag (min verbosity normal) + , ghcOptMode = toFlag GhcModeCompile + , ghcOptInputFiles = toNubListR [filename] + , ghcOptCppIncludePath = + toNubListR $ + [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + , odir + ] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- includeDirs bi] + , ghcOptCppOptions = cppOptions bi + , ghcOptCppIncludes = + toNubListR $ + [autogenComponentModulesDir lbi clbi cppHeaderName] + , ghcOptHideAllPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi + , ghcOptOptimisation = toGhcOptimisation (withOptimization lbi) + , ghcOptDebugInfo = toFlag (withDebugInfo lbi) + , ghcOptExtra = cmmOptions bi + , ghcOptObjDir = toFlag odir } -- | Strip out flags that are not supported in ghci @@ -667,11 +702,13 @@ getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs -- aren't yet built, but promised. This filtering is used when compiling C/Cxx/Asm files, -- and is a hack to avoid passing bogus `-package` arguments to GHC. The assumption being that -- in 99% of cases we will include the right `-package` so that the C file finds the right headers. -mkGhcOptPackages :: Map (PackageName, ComponentName) ComponentId - -> ComponentLocalBuildInfo - -> [(OpenUnitId, ModuleRenaming)] -mkGhcOptPackages promisedPkgsMap clbi = [ i | i@(uid, _) <- componentIncludes clbi - , abstractUnitId uid `Set.notMember` promised_cids ] +mkGhcOptPackages + :: Map (PackageName, ComponentName) ComponentId + -> ComponentLocalBuildInfo + -> [(OpenUnitId, ModuleRenaming)] +mkGhcOptPackages promisedPkgsMap clbi = + [ i | i@(uid, _) <- componentIncludes clbi, abstractUnitId uid `Set.notMember` promised_cids + ] where -- Promised deps are going to be simple UnitIds promised_cids = Set.fromList (map newSimpleUnitId (Map.elems promisedPkgsMap)) diff --git a/Cabal/src/Distribution/Simple/GHCJS.hs b/Cabal/src/Distribution/Simple/GHCJS.hs index 24332b9e3d7..8515635de54 100644 --- a/Cabal/src/Distribution/Simple/GHCJS.hs +++ b/Cabal/src/Distribution/Simple/GHCJS.hs @@ -780,64 +780,66 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do , -- For dynamic libs, Mac OS/X needs to know the install location -- at build time. This only applies to GHC < 7.8 - see the -- discussion in #1660. - {- - ghcOptDylibName = if hostOS == OSX - && ghcVersion < mkVersion [7,8] - then toFlag sharedLibInstallPath - else mempty, -} - ghcOptHideAllPackages = toFlag True, - ghcOptNoAutoLinkPackages = toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo { componentCompatPackageKey = pk } - -> toFlag pk - _ -> mempty, - ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> - if null insts - then mempty - else toFlag (componentComponentId clbi) - _ -> mempty, - ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } - -> insts - _ -> [], - ghcOptPackages = toNubListR $ - Internal.mkGhcOptPackages mempty clbi , - ghcOptLinkLibs = extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, - ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, - ghcOptLinkFrameworkDirs = - toNubListR $ PD.extraFrameworkDirs libBi, - ghcOptRPaths = rpaths + {- + ghcOptDylibName = if hostOS == OSX + && ghcVersion < mkVersion [7,8] + then toFlag sharedLibInstallPath + else mempty, -} + ghcOptHideAllPackages = toFlag True + , ghcOptNoAutoLinkPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> + toFlag pk + _ -> mempty + , ghcOptThisComponentId = case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> + if null insts + then mempty + else toFlag (componentComponentId clbi) + _ -> mempty + , ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> + insts + _ -> [] + , ghcOptPackages = + toNubListR $ + Internal.mkGhcOptPackages mempty clbi + , ghcOptLinkLibs = extraLibs libBi + , ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi + , ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi + , ghcOptLinkFrameworkDirs = + toNubListR $ PD.extraFrameworkDirs libBi + , ghcOptRPaths = rpaths } ghcStaticLinkArgs = - mempty { - ghcOptStaticLib = toFlag True, - ghcOptInputFiles = toNubListR staticObjectFiles, - ghcOptOutputFile = toFlag staticLibFilePath, - ghcOptExtra = hcStaticOptions GHC libBi, - ghcOptHideAllPackages = toFlag True, - ghcOptNoAutoLinkPackages = toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo { componentCompatPackageKey = pk } - -> toFlag pk - _ -> mempty, - ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> - if null insts - then mempty - else toFlag (componentComponentId clbi) - _ -> mempty, - ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } - -> insts - _ -> [], - ghcOptPackages = toNubListR $ - Internal.mkGhcOptPackages mempty clbi , - ghcOptLinkLibs = extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi + mempty + { ghcOptStaticLib = toFlag True + , ghcOptInputFiles = toNubListR staticObjectFiles + , ghcOptOutputFile = toFlag staticLibFilePath + , ghcOptExtra = hcStaticOptions GHC libBi + , ghcOptHideAllPackages = toFlag True + , ghcOptNoAutoLinkPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> + toFlag pk + _ -> mempty + , ghcOptThisComponentId = case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> + if null insts + then mempty + else toFlag (componentComponentId clbi) + _ -> mempty + , ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> + insts + _ -> [] + , ghcOptPackages = + toNubListR $ + Internal.mkGhcOptPackages mempty clbi + , ghcOptLinkLibs = extraLibs libBi + , ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi } info verbosity (show (ghcOptPackages ghcSharedLinkArgs)) diff --git a/Cabal/src/Distribution/Simple/Setup/Config.hs b/Cabal/src/Distribution/Simple/Setup/Config.hs index 262d888aa96..a109a7502b9 100644 --- a/Cabal/src/Distribution/Simple/Setup/Config.hs +++ b/Cabal/src/Distribution/Simple/Setup/Config.hs @@ -82,100 +82,144 @@ data ConfigFlags = ConfigFlags -- because the type of configure is constrained by the UserHooks. -- when we change UserHooks next we should pass the initial -- ProgramDb directly and not via ConfigFlags - configPrograms_ :: Option' (Last' ProgramDb), -- ^All programs that - -- @cabal@ may run - configProgramPaths :: [(String, FilePath)], -- ^user specified programs paths - configProgramArgs :: [(String, [String])], -- ^user specified programs args - configProgramPathExtra :: NubList FilePath, -- ^Extend the $PATH - configHcFlavor :: Flag CompilerFlavor, -- ^The \"flavor\" of the - -- compiler, e.g. GHC. - configHcPath :: Flag FilePath, -- ^given compiler location - configHcPkg :: Flag FilePath, -- ^given hc-pkg location - configVanillaLib :: Flag Bool, -- ^Enable vanilla library - configProfLib :: Flag Bool, -- ^Enable profiling in the library - configSharedLib :: Flag Bool, -- ^Build shared library - configStaticLib :: Flag Bool, -- ^Build static library - configDynExe :: Flag Bool, -- ^Enable dynamic linking of the - -- executables. - configFullyStaticExe :: Flag Bool, -- ^Enable fully static linking of the - -- executables. - configProfExe :: Flag Bool, -- ^Enable profiling in the - -- executables. - configProf :: Flag Bool, -- ^Enable profiling in the library - -- and executables. - configProfDetail :: Flag ProfDetailLevel, -- ^Profiling detail level - -- in the library and executables. - configProfLibDetail :: Flag ProfDetailLevel, -- ^Profiling detail level - -- in the library - configConfigureArgs :: [String], -- ^Extra arguments to @configure@ - configOptimization :: Flag OptimisationLevel, -- ^Enable optimization. - configProgPrefix :: Flag PathTemplate, -- ^Installed executable prefix. - configProgSuffix :: Flag PathTemplate, -- ^Installed executable suffix. - configInstallDirs :: InstallDirs (Flag PathTemplate), -- ^Installation - -- paths - configScratchDir :: Flag FilePath, - configExtraLibDirs :: [FilePath], -- ^ path to search for extra libraries - configExtraLibDirsStatic :: [FilePath], -- ^ path to search for extra - -- libraries when linking - -- fully static executables - configExtraFrameworkDirs :: [FilePath], -- ^ path to search for extra - -- frameworks (OS X only) - configExtraIncludeDirs :: [FilePath], -- ^ path to search for header files - configIPID :: Flag String, -- ^ explicit IPID to be used - configCID :: Flag ComponentId, -- ^ explicit CID to be used - configDeterministic :: Flag Bool, -- ^ be as deterministic as possible - -- (e.g., invariant over GHC, database, - -- etc). Used by the test suite - - configDistPref :: Flag FilePath, -- ^"dist" prefix - configCabalFilePath :: Flag FilePath, -- ^ Cabal file to use - configVerbosity :: Flag Verbosity, -- ^verbosity level - configUserInstall :: Flag Bool, -- ^The --user\/--global flag - configPackageDBs :: [Maybe PackageDB], -- ^Which package DBs to use - configGHCiLib :: Flag Bool, -- ^Enable compiling library for GHCi - configSplitSections :: Flag Bool, -- ^Enable -split-sections with GHC - configSplitObjs :: Flag Bool, -- ^Enable -split-objs with GHC - configStripExes :: Flag Bool, -- ^Enable executable stripping - configStripLibs :: Flag Bool, -- ^Enable library stripping - configConstraints :: [PackageVersionConstraint], -- ^Additional constraints for - -- dependencies. - configDependencies :: [GivenComponent], - -- ^The packages depended on which already exist - configPromisedDependencies :: [GivenComponent], - -- ^The packages depended on which doesn't yet exist (i.e. promised). - -- Promising dependencies enables us to configure components in parallel, - -- and avoids expensive builds if they are not necessary. - -- For example, in multi-repl mode, we don't want to build dependencies that - -- are loaded into the interactive session, since we have to build them again. - - configInstantiateWith :: [(ModuleName, Module)], - -- ^ The requested Backpack instantiation. If empty, either this - -- package does not use Backpack, or we just want to typecheck - -- the indefinite package. - configConfigurationsFlags :: FlagAssignment, - configTests :: Flag Bool, -- ^Enable test suite compilation - configBenchmarks :: Flag Bool, -- ^Enable benchmark compilation - configCoverage :: Flag Bool, -- ^Enable program coverage - configLibCoverage :: Flag Bool, -- ^Enable program coverage (deprecated) - configExactConfiguration :: Flag Bool, - -- ^All direct dependencies and flags are provided on the command line by - -- the user via the '--dependency' and '--flags' options. - configFlagError :: Flag String, - -- ^Halt and show an error message indicating an error in flag assignment - configRelocatable :: Flag Bool, -- ^ Enable relocatable package built - configDebugInfo :: Flag DebugInfoLevel, -- ^ Emit debug info. - configDumpBuildInfo :: Flag DumpBuildInfo, - -- ^ Should we dump available build information on build? - -- Dump build information to disk before attempting to build, - -- tooling can parse these files and use them to compile the - -- source files themselves. - configUseResponseFiles :: Flag Bool, - -- ^ Whether to use response files at all. They're used for such tools - -- as haddock, or ld. - configAllowDependingOnPrivateLibs :: Flag Bool - -- ^ Allow depending on private sublibraries. This is used by external - -- tools (like cabal-install) so they can add multiple-public-libraries - -- compatibility to older ghcs by checking visibility externally. + configPrograms_ :: Option' (Last' ProgramDb) + -- ^ All programs that + -- @cabal@ may run + , configProgramPaths :: [(String, FilePath)] + -- ^ user specified programs paths + , configProgramArgs :: [(String, [String])] + -- ^ user specified programs args + , configProgramPathExtra :: NubList FilePath + -- ^ Extend the $PATH + , configHcFlavor :: Flag CompilerFlavor + -- ^ The \"flavor\" of the + -- compiler, e.g. GHC. + , configHcPath :: Flag FilePath + -- ^ given compiler location + , configHcPkg :: Flag FilePath + -- ^ given hc-pkg location + , configVanillaLib :: Flag Bool + -- ^ Enable vanilla library + , configProfLib :: Flag Bool + -- ^ Enable profiling in the library + , configSharedLib :: Flag Bool + -- ^ Build shared library + , configStaticLib :: Flag Bool + -- ^ Build static library + , configDynExe :: Flag Bool + -- ^ Enable dynamic linking of the + -- executables. + , configFullyStaticExe :: Flag Bool + -- ^ Enable fully static linking of the + -- executables. + , configProfExe :: Flag Bool + -- ^ Enable profiling in the + -- executables. + , configProf :: Flag Bool + -- ^ Enable profiling in the library + -- and executables. + , configProfDetail :: Flag ProfDetailLevel + -- ^ Profiling detail level + -- in the library and executables. + , configProfLibDetail :: Flag ProfDetailLevel + -- ^ Profiling detail level + -- in the library + , configConfigureArgs :: [String] + -- ^ Extra arguments to @configure@ + , configOptimization :: Flag OptimisationLevel + -- ^ Enable optimization. + , configProgPrefix :: Flag PathTemplate + -- ^ Installed executable prefix. + , configProgSuffix :: Flag PathTemplate + -- ^ Installed executable suffix. + , configInstallDirs :: InstallDirs (Flag PathTemplate) + -- ^ Installation + -- paths + , configScratchDir :: Flag FilePath + , configExtraLibDirs :: [FilePath] + -- ^ path to search for extra libraries + , configExtraLibDirsStatic :: [FilePath] + -- ^ path to search for extra + -- libraries when linking + -- fully static executables + , configExtraFrameworkDirs :: [FilePath] + -- ^ path to search for extra + -- frameworks (OS X only) + , configExtraIncludeDirs :: [FilePath] + -- ^ path to search for header files + , configIPID :: Flag String + -- ^ explicit IPID to be used + , configCID :: Flag ComponentId + -- ^ explicit CID to be used + , configDeterministic :: Flag Bool + -- ^ be as deterministic as possible + -- (e.g., invariant over GHC, database, + -- etc). Used by the test suite + , configDistPref :: Flag FilePath + -- ^ "dist" prefix + , configCabalFilePath :: Flag FilePath + -- ^ Cabal file to use + , configVerbosity :: Flag Verbosity + -- ^ verbosity level + , configUserInstall :: Flag Bool + -- ^ The --user\/--global flag + , configPackageDBs :: [Maybe PackageDB] + -- ^ Which package DBs to use + , configGHCiLib :: Flag Bool + -- ^ Enable compiling library for GHCi + , configSplitSections :: Flag Bool + -- ^ Enable -split-sections with GHC + , configSplitObjs :: Flag Bool + -- ^ Enable -split-objs with GHC + , configStripExes :: Flag Bool + -- ^ Enable executable stripping + , configStripLibs :: Flag Bool + -- ^ Enable library stripping + , configConstraints :: [PackageVersionConstraint] + -- ^ Additional constraints for + -- dependencies. + , configDependencies :: [GivenComponent] + -- ^ The packages depended on which already exist + , configPromisedDependencies :: [GivenComponent] + -- ^ The packages depended on which doesn't yet exist (i.e. promised). + -- Promising dependencies enables us to configure components in parallel, + -- and avoids expensive builds if they are not necessary. + -- For example, in multi-repl mode, we don't want to build dependencies that + -- are loaded into the interactive session, since we have to build them again. + , configInstantiateWith :: [(ModuleName, Module)] + -- ^ The requested Backpack instantiation. If empty, either this + -- package does not use Backpack, or we just want to typecheck + -- the indefinite package. + , configConfigurationsFlags :: FlagAssignment + , configTests :: Flag Bool + -- ^ Enable test suite compilation + , configBenchmarks :: Flag Bool + -- ^ Enable benchmark compilation + , configCoverage :: Flag Bool + -- ^ Enable program coverage + , configLibCoverage :: Flag Bool + -- ^ Enable program coverage (deprecated) + , configExactConfiguration :: Flag Bool + -- ^ All direct dependencies and flags are provided on the command line by + -- the user via the '--dependency' and '--flags' options. + , configFlagError :: Flag String + -- ^ Halt and show an error message indicating an error in flag assignment + , configRelocatable :: Flag Bool + -- ^ Enable relocatable package built + , configDebugInfo :: Flag DebugInfoLevel + -- ^ Emit debug info. + , configDumpBuildInfo :: Flag DumpBuildInfo + -- ^ Should we dump available build information on build? + -- Dump build information to disk before attempting to build, + -- tooling can parse these files and use them to compile the + -- source files themselves. + , configUseResponseFiles :: Flag Bool + -- ^ Whether to use response files at all. They're used for such tools + -- as haddock, or ld. + , configAllowDependingOnPrivateLibs :: Flag Bool + -- ^ Allow depending on private sublibraries. This is used by external + -- tools (like cabal-install) so they can add multiple-public-libraries + -- compatibility to older ghcs by checking visibility externally. } deriving (Generic, Read, Show, Typeable) @@ -195,55 +239,55 @@ instance Eq ConfigFlags where (==) a b = -- configPrograms skipped: not user specified, has no Eq instance equal configProgramPaths - && equal configProgramArgs - && equal configProgramPathExtra - && equal configHcFlavor - && equal configHcPath - && equal configHcPkg - && equal configVanillaLib - && equal configProfLib - && equal configSharedLib - && equal configStaticLib - && equal configDynExe - && equal configFullyStaticExe - && equal configProfExe - && equal configProf - && equal configProfDetail - && equal configProfLibDetail - && equal configConfigureArgs - && equal configOptimization - && equal configProgPrefix - && equal configProgSuffix - && equal configInstallDirs - && equal configScratchDir - && equal configExtraLibDirs - && equal configExtraLibDirsStatic - && equal configExtraIncludeDirs - && equal configIPID - && equal configDeterministic - && equal configDistPref - && equal configVerbosity - && equal configUserInstall - && equal configPackageDBs - && equal configGHCiLib - && equal configSplitSections - && equal configSplitObjs - && equal configStripExes - && equal configStripLibs - && equal configConstraints - && equal configDependencies - && equal configPromisedDependencies - && equal configConfigurationsFlags - && equal configTests - && equal configBenchmarks - && equal configCoverage - && equal configLibCoverage - && equal configExactConfiguration - && equal configFlagError - && equal configRelocatable - && equal configDebugInfo - && equal configDumpBuildInfo - && equal configUseResponseFiles + && equal configProgramArgs + && equal configProgramPathExtra + && equal configHcFlavor + && equal configHcPath + && equal configHcPkg + && equal configVanillaLib + && equal configProfLib + && equal configSharedLib + && equal configStaticLib + && equal configDynExe + && equal configFullyStaticExe + && equal configProfExe + && equal configProf + && equal configProfDetail + && equal configProfLibDetail + && equal configConfigureArgs + && equal configOptimization + && equal configProgPrefix + && equal configProgSuffix + && equal configInstallDirs + && equal configScratchDir + && equal configExtraLibDirs + && equal configExtraLibDirsStatic + && equal configExtraIncludeDirs + && equal configIPID + && equal configDeterministic + && equal configDistPref + && equal configVerbosity + && equal configUserInstall + && equal configPackageDBs + && equal configGHCiLib + && equal configSplitSections + && equal configSplitObjs + && equal configStripExes + && equal configStripLibs + && equal configConstraints + && equal configDependencies + && equal configPromisedDependencies + && equal configConfigurationsFlags + && equal configTests + && equal configBenchmarks + && equal configCoverage + && equal configLibCoverage + && equal configExactConfiguration + && equal configFlagError + && equal configRelocatable + && equal configDebugInfo + && equal configDumpBuildInfo + && equal configUseResponseFiles where equal f = on (==) f a b @@ -624,121 +668,167 @@ configureOptions showOrParseArgs = ( reqArg "FLAGS" (parsecToReadE (\err -> "Invalid flag assignment: " ++ err) legacyParsecFlagAssignment) - legacyShowFlagAssignment') - - ,option "" ["extra-include-dirs"] - "A list of directories to search for header files" - configExtraIncludeDirs (\v flags -> flags {configExtraIncludeDirs = v}) - (reqArg' "PATH" (\x -> [x]) id) - - ,option "" ["deterministic"] - "Try to be as deterministic as possible (used by the test suite)" - configDeterministic (\v flags -> flags {configDeterministic = v}) - (boolOpt [] []) - - ,option "" ["ipid"] - "Installed package ID to compile this package as" - configIPID (\v flags -> flags {configIPID = v}) - (reqArgFlag "IPID") - - ,option "" ["cid"] - "Installed component ID to compile this component as" - (fmap prettyShow . configCID) (\v flags -> flags {configCID = fmap mkComponentId v}) - (reqArgFlag "CID") - - ,option "" ["extra-lib-dirs"] - "A list of directories to search for external libraries" - configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v}) - (reqArg' "PATH" (\x -> [x]) id) - - ,option "" ["extra-lib-dirs-static"] - "A list of directories to search for external libraries when linking fully static executables" - configExtraLibDirsStatic (\v flags -> flags {configExtraLibDirsStatic = v}) - (reqArg' "PATH" (\x -> [x]) id) - - ,option "" ["extra-framework-dirs"] - "A list of directories to search for external frameworks (OS X only)" - configExtraFrameworkDirs - (\v flags -> flags {configExtraFrameworkDirs = v}) - (reqArg' "PATH" (\x -> [x]) id) - - ,option "" ["extra-prog-path"] - "A list of directories to search for required programs (in addition to the normal search locations)" - configProgramPathExtra (\v flags -> flags {configProgramPathExtra = v}) - (reqArg' "PATH" (\x -> toNubList [x]) fromNubList) - - ,option "" ["constraint"] - "A list of additional constraints on the dependencies." - configConstraints (\v flags -> flags { configConstraints = v}) - (reqArg "DEPENDENCY" - (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsec)) - (map prettyShow)) - - ,option "" ["dependency"] - "A list of exact dependencies. E.g., --dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\"" - configDependencies (\v flags -> flags { configDependencies = v}) - (reqArg "NAME[:COMPONENT_NAME]=CID" - (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsecGivenComponent)) - (map prettyGivenComponent)) - - ,option "" ["promised-dependency"] - "A list of promised dependencies. E.g., --promised-dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\"" - configPromisedDependencies (\v flags -> flags { configPromisedDependencies = v}) - (reqArg "NAME[:COMPONENT_NAME]=CID" - (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsecGivenComponent)) - (map prettyGivenComponent)) - - ,option "" ["instantiate-with"] - "A mapping of signature names to concrete module instantiations." - configInstantiateWith (\v flags -> flags { configInstantiateWith = v }) - (reqArg "NAME=MOD" - (parsecToReadE ("Cannot parse module substitution: " ++) (fmap (:[]) parsecModSubstEntry)) - (map (Disp.renderStyle defaultStyle . dispModSubstEntry))) - - ,option "" ["tests"] - "dependency checking and compilation for test suites listed in the package description file." - configTests (\v flags -> flags { configTests = v }) - (boolOpt [] []) - - ,option "" ["coverage"] - "build package with Haskell Program Coverage. (GHC only)" - configCoverage (\v flags -> flags { configCoverage = v }) - (boolOpt [] []) - - ,option "" ["library-coverage"] - "build package with Haskell Program Coverage. (GHC only) (DEPRECATED)" - configLibCoverage (\v flags -> flags { configLibCoverage = v }) - (boolOpt [] []) - - ,option "" ["exact-configuration"] - "All direct dependencies and flags are provided on the command line." - configExactConfiguration - (\v flags -> flags { configExactConfiguration = v }) - trueArg - - ,option "" ["benchmarks"] - "dependency checking and compilation for benchmarks listed in the package description file." - configBenchmarks (\v flags -> flags { configBenchmarks = v }) - (boolOpt [] []) - - ,option "" ["relocatable"] - "building a package that is relocatable. (GHC only)" - configRelocatable (\v flags -> flags { configRelocatable = v}) - (boolOpt [] []) - - ,option "" ["response-files"] - "enable workaround for old versions of programs like \"ar\" that do not support @file arguments" - configUseResponseFiles - (\v flags -> flags { configUseResponseFiles = v }) - (boolOpt' ([], ["disable-response-files"]) ([], [])) - - ,option "" ["allow-depending-on-private-libs"] - ( "Allow depending on private libraries. " - ++ "If set, the library visibility check MUST be done externally." ) - configAllowDependingOnPrivateLibs - (\v flags -> flags { configAllowDependingOnPrivateLibs = v }) - trueArg - ] + legacyShowFlagAssignment' + ) + , option + "" + ["extra-include-dirs"] + "A list of directories to search for header files" + configExtraIncludeDirs + (\v flags -> flags{configExtraIncludeDirs = v}) + (reqArg' "PATH" (\x -> [x]) id) + , option + "" + ["deterministic"] + "Try to be as deterministic as possible (used by the test suite)" + configDeterministic + (\v flags -> flags{configDeterministic = v}) + (boolOpt [] []) + , option + "" + ["ipid"] + "Installed package ID to compile this package as" + configIPID + (\v flags -> flags{configIPID = v}) + (reqArgFlag "IPID") + , option + "" + ["cid"] + "Installed component ID to compile this component as" + (fmap prettyShow . configCID) + (\v flags -> flags{configCID = fmap mkComponentId v}) + (reqArgFlag "CID") + , option + "" + ["extra-lib-dirs"] + "A list of directories to search for external libraries" + configExtraLibDirs + (\v flags -> flags{configExtraLibDirs = v}) + (reqArg' "PATH" (\x -> [x]) id) + , option + "" + ["extra-lib-dirs-static"] + "A list of directories to search for external libraries when linking fully static executables" + configExtraLibDirsStatic + (\v flags -> flags{configExtraLibDirsStatic = v}) + (reqArg' "PATH" (\x -> [x]) id) + , option + "" + ["extra-framework-dirs"] + "A list of directories to search for external frameworks (OS X only)" + configExtraFrameworkDirs + (\v flags -> flags{configExtraFrameworkDirs = v}) + (reqArg' "PATH" (\x -> [x]) id) + , option + "" + ["extra-prog-path"] + "A list of directories to search for required programs (in addition to the normal search locations)" + configProgramPathExtra + (\v flags -> flags{configProgramPathExtra = v}) + (reqArg' "PATH" (\x -> toNubList [x]) fromNubList) + , option + "" + ["constraint"] + "A list of additional constraints on the dependencies." + configConstraints + (\v flags -> flags{configConstraints = v}) + ( reqArg + "DEPENDENCY" + (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsec)) + (map prettyShow) + ) + , option + "" + ["dependency"] + "A list of exact dependencies. E.g., --dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\"" + configDependencies + (\v flags -> flags{configDependencies = v}) + ( reqArg + "NAME[:COMPONENT_NAME]=CID" + (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsecGivenComponent)) + (map prettyGivenComponent) + ) + , option + "" + ["promised-dependency"] + "A list of promised dependencies. E.g., --promised-dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\"" + configPromisedDependencies + (\v flags -> flags{configPromisedDependencies = v}) + ( reqArg + "NAME[:COMPONENT_NAME]=CID" + (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsecGivenComponent)) + (map prettyGivenComponent) + ) + , option + "" + ["instantiate-with"] + "A mapping of signature names to concrete module instantiations." + configInstantiateWith + (\v flags -> flags{configInstantiateWith = v}) + ( reqArg + "NAME=MOD" + (parsecToReadE ("Cannot parse module substitution: " ++) (fmap (: []) parsecModSubstEntry)) + (map (Disp.renderStyle defaultStyle . dispModSubstEntry)) + ) + , option + "" + ["tests"] + "dependency checking and compilation for test suites listed in the package description file." + configTests + (\v flags -> flags{configTests = v}) + (boolOpt [] []) + , option + "" + ["coverage"] + "build package with Haskell Program Coverage. (GHC only)" + configCoverage + (\v flags -> flags{configCoverage = v}) + (boolOpt [] []) + , option + "" + ["library-coverage"] + "build package with Haskell Program Coverage. (GHC only) (DEPRECATED)" + configLibCoverage + (\v flags -> flags{configLibCoverage = v}) + (boolOpt [] []) + , option + "" + ["exact-configuration"] + "All direct dependencies and flags are provided on the command line." + configExactConfiguration + (\v flags -> flags{configExactConfiguration = v}) + trueArg + , option + "" + ["benchmarks"] + "dependency checking and compilation for benchmarks listed in the package description file." + configBenchmarks + (\v flags -> flags{configBenchmarks = v}) + (boolOpt [] []) + , option + "" + ["relocatable"] + "building a package that is relocatable. (GHC only)" + configRelocatable + (\v flags -> flags{configRelocatable = v}) + (boolOpt [] []) + , option + "" + ["response-files"] + "enable workaround for old versions of programs like \"ar\" that do not support @file arguments" + configUseResponseFiles + (\v flags -> flags{configUseResponseFiles = v}) + (boolOpt' ([], ["disable-response-files"]) ([], [])) + , option + "" + ["allow-depending-on-private-libs"] + ( "Allow depending on private libraries. " + ++ "If set, the library visibility check MUST be done externally." + ) + configAllowDependingOnPrivateLibs + (\v flags -> flags{configAllowDependingOnPrivateLibs = v}) + trueArg + ] where liftInstallDirs = liftOption configInstallDirs (\v flags -> flags{configInstallDirs = v}) @@ -797,9 +887,11 @@ parsecGivenComponent = do prettyGivenComponent :: GivenComponent -> String prettyGivenComponent (GivenComponent pn cn cid) = prettyShow pn - ++ case cn of LMainLibName -> "" - LSubLibName n -> ":" ++ prettyShow n - ++ "=" ++ prettyShow cid + ++ case cn of + LMainLibName -> "" + LSubLibName n -> ":" ++ prettyShow n + ++ "=" + ++ prettyShow cid installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))] installDirsOptions = diff --git a/Cabal/src/Distribution/Simple/Setup/Repl.hs b/Cabal/src/Distribution/Simple/Setup/Repl.hs index 33b176d1d41..19c75836366 100644 --- a/Cabal/src/Distribution/Simple/Setup/Repl.hs +++ b/Cabal/src/Distribution/Simple/Setup/Repl.hs @@ -43,10 +43,10 @@ import Distribution.Simple.Setup.Common -- ------------------------------------------------------------ -data ReplOptions = ReplOptions { - replOptionsFlags :: [String], - replOptionsNoLoad :: Flag Bool, - replOptionsFlagOutput :: Flag FilePath +data ReplOptions = ReplOptions + { replOptionsFlags :: [String] + , replOptionsNoLoad :: Flag Bool + , replOptionsFlagOutput :: Flag FilePath } deriving (Show, Generic, Typeable) @@ -178,16 +178,25 @@ replCommand progDb = replOptions :: ShowOrParseArgs -> [OptionField ReplOptions] replOptions _ = - [ option [] ["repl-no-load"] - "Disable loading of project modules at REPL startup." - replOptionsNoLoad (\p flags -> flags { replOptionsNoLoad = p }) - trueArg - , option [] ["repl-options"] - "Use the option(s) for the repl" - replOptionsFlags (\p flags -> flags { replOptionsFlags = p }) - (reqArg "FLAG" (succeedReadE words) id) - , option [] ["repl-multi-file"] - "Write repl options to this directory rather than starting repl mode" - replOptionsFlagOutput (\p flags -> flags { replOptionsFlagOutput = p }) - (reqArg "DIR" (succeedReadE Flag) flagToList) + [ option + [] + ["repl-no-load"] + "Disable loading of project modules at REPL startup." + replOptionsNoLoad + (\p flags -> flags{replOptionsNoLoad = p}) + trueArg + , option + [] + ["repl-options"] + "Use the option(s) for the repl" + replOptionsFlags + (\p flags -> flags{replOptionsFlags = p}) + (reqArg "FLAG" (succeedReadE words) id) + , option + [] + ["repl-multi-file"] + "Write repl options to this directory rather than starting repl mode" + replOptionsFlagOutput + (\p flags -> flags{replOptionsFlagOutput = p}) + (reqArg "DIR" (succeedReadE Flag) flagToList) ] diff --git a/Cabal/src/Distribution/Types/AnnotatedId.hs b/Cabal/src/Distribution/Types/AnnotatedId.hs index 6ceacf013b6..70c3e1176dd 100644 --- a/Cabal/src/Distribution/Types/AnnotatedId.hs +++ b/Cabal/src/Distribution/Types/AnnotatedId.hs @@ -1,7 +1,8 @@ {-# LANGUAGE DeriveFunctor #-} -module Distribution.Types.AnnotatedId ( - AnnotatedId(..) -) where + +module Distribution.Types.AnnotatedId + ( AnnotatedId (..) + ) where import Distribution.Compat.Prelude import Prelude () @@ -15,12 +16,12 @@ import Distribution.Types.ComponentName -- -- Invariant: if ann_id x == ann_id y, then ann_pid x == ann_pid y -- and ann_cname x == ann_cname y -data AnnotatedId id = AnnotatedId { - ann_pid :: PackageId, - ann_cname :: ComponentName, - ann_id :: id - } - deriving (Show, Functor) +data AnnotatedId id = AnnotatedId + { ann_pid :: PackageId + , ann_cname :: ComponentName + , ann_id :: id + } + deriving (Show, Functor) instance Eq id => Eq (AnnotatedId id) where x == y = ann_id x == ann_id y @@ -29,4 +30,4 @@ instance Ord id => Ord (AnnotatedId id) where compare x y = compare (ann_id x) (ann_id y) instance Package (AnnotatedId id) where - packageId = ann_pid + packageId = ann_pid diff --git a/Cabal/src/Distribution/Types/LocalBuildInfo.hs b/Cabal/src/Distribution/Types/LocalBuildInfo.hs index 1947b412272..116d5db264e 100644 --- a/Cabal/src/Distribution/Types/LocalBuildInfo.hs +++ b/Cabal/src/Distribution/Types/LocalBuildInfo.hs @@ -76,90 +76,113 @@ import qualified Distribution.Compat.Graph as Graph -- | Data cached after configuration step. See also -- 'Distribution.Simple.Setup.ConfigFlags'. -data LocalBuildInfo = LocalBuildInfo { - configFlags :: ConfigFlags, - -- ^ Options passed to the configuration step. - -- Needed to re-run configuration when .cabal is out of date - flagAssignment :: FlagAssignment, - -- ^ The final set of flags which were picked for this package - componentEnabledSpec :: ComponentRequestedSpec, - -- ^ What components were enabled during configuration, and why. - extraConfigArgs :: [String], - -- ^ Extra args on the command line for the configuration step. - -- Needed to re-run configuration when .cabal is out of date - installDirTemplates :: InstallDirTemplates, - -- ^ The installation directories for the various different - -- kinds of files - --TODO: inplaceDirTemplates :: InstallDirs FilePath - compiler :: Compiler, - -- ^ The compiler we're building with - hostPlatform :: Platform, - -- ^ The platform we're building for - buildDir :: FilePath, - -- ^ Where to build the package. - cabalFilePath :: Maybe FilePath, - -- ^ Path to the cabal file, if given during configuration. - componentGraph :: Graph ComponentLocalBuildInfo, - -- ^ All the components to build, ordered by topological - -- sort, and with their INTERNAL dependencies over the - -- intrapackage dependency graph. - -- TODO: this is assumed to be short; otherwise we want - -- some sort of ordered map. - componentNameMap :: Map ComponentName [ComponentLocalBuildInfo], - -- ^ A map from component name to all matching - -- components. These coincide with 'componentGraph' - promisedPkgs :: Map (PackageName, ComponentName) ComponentId, - -- ^ The packages we were promised, but aren't already installed. - -- MP: Perhaps this just needs to be a Set UnitId at this stage. - installedPkgs :: InstalledPackageIndex, - -- ^ All the info about the installed packages that the - -- current package depends on (directly or indirectly). - -- The copy saved on disk does NOT include internal - -- dependencies (because we just don't have enough - -- information at this point to have an - -- 'InstalledPackageInfo' for an internal dep), but we - -- will often update it with the internal dependencies; - -- see for example 'Distribution.Simple.Build.build'. - -- (This admonition doesn't apply for per-component builds.) - pkgDescrFile :: Maybe FilePath, - -- ^ the filename containing the .cabal file, if available - localPkgDescr :: PackageDescription, - -- ^ WARNING WARNING WARNING Be VERY careful about using - -- this function; we haven't deprecated it but using it - -- could introduce subtle bugs related to - -- 'HookedBuildInfo'. - -- - -- In principle, this is supposed to contain the - -- resolved package description, that does not contain - -- any conditionals. However, it MAY NOT contain - -- the description with a 'HookedBuildInfo' applied - -- to it; see 'HookedBuildInfo' for the whole sordid saga. - -- As much as possible, Cabal library should avoid using - -- this parameter. - withPrograms :: ProgramDb, -- ^Location and args for all programs - withPackageDB :: PackageDBStack, -- ^What package database to use, global\/user - withVanillaLib:: Bool, -- ^Whether to build normal libs. - withProfLib :: Bool, -- ^Whether to build profiling versions of libs. - withSharedLib :: Bool, -- ^Whether to build shared versions of libs. - withStaticLib :: Bool, -- ^Whether to build static versions of libs (with all other libs rolled in) - withDynExe :: Bool, -- ^Whether to link executables dynamically - withFullyStaticExe :: Bool, -- ^Whether to link executables fully statically - withProfExe :: Bool, -- ^Whether to build executables for profiling. - withProfLibDetail :: ProfDetailLevel, -- ^Level of automatic profile detail. - withProfExeDetail :: ProfDetailLevel, -- ^Level of automatic profile detail. - withOptimization :: OptimisationLevel, -- ^Whether to build with optimization (if available). - withDebugInfo :: DebugInfoLevel, -- ^Whether to emit debug info (if available). - withGHCiLib :: Bool, -- ^Whether to build libs suitable for use with GHCi. - splitSections :: Bool, -- ^Use -split-sections with GHC, if available - splitObjs :: Bool, -- ^Use -split-objs with GHC, if available - stripExes :: Bool, -- ^Whether to strip executables during install - stripLibs :: Bool, -- ^Whether to strip libraries during install - exeCoverage :: Bool, -- ^Whether to enable executable program coverage - libCoverage :: Bool, -- ^Whether to enable library program coverage - progPrefix :: PathTemplate, -- ^Prefix to be prepended to installed executables - progSuffix :: PathTemplate, -- ^Suffix to be appended to installed executables - relocatable :: Bool -- ^Whether to build a relocatable package - } deriving (Generic, Read, Show, Typeable) +data LocalBuildInfo = LocalBuildInfo + { configFlags :: ConfigFlags + -- ^ Options passed to the configuration step. + -- Needed to re-run configuration when .cabal is out of date + , flagAssignment :: FlagAssignment + -- ^ The final set of flags which were picked for this package + , componentEnabledSpec :: ComponentRequestedSpec + -- ^ What components were enabled during configuration, and why. + , extraConfigArgs :: [String] + -- ^ Extra args on the command line for the configuration step. + -- Needed to re-run configuration when .cabal is out of date + , installDirTemplates :: InstallDirTemplates + -- ^ The installation directories for the various different + -- kinds of files + -- TODO: inplaceDirTemplates :: InstallDirs FilePath + , compiler :: Compiler + -- ^ The compiler we're building with + , hostPlatform :: Platform + -- ^ The platform we're building for + , buildDir :: FilePath + -- ^ Where to build the package. + , cabalFilePath :: Maybe FilePath + -- ^ Path to the cabal file, if given during configuration. + , componentGraph :: Graph ComponentLocalBuildInfo + -- ^ All the components to build, ordered by topological + -- sort, and with their INTERNAL dependencies over the + -- intrapackage dependency graph. + -- TODO: this is assumed to be short; otherwise we want + -- some sort of ordered map. + , componentNameMap :: Map ComponentName [ComponentLocalBuildInfo] + -- ^ A map from component name to all matching + -- components. These coincide with 'componentGraph' + , promisedPkgs :: Map (PackageName, ComponentName) ComponentId + -- ^ The packages we were promised, but aren't already installed. + -- MP: Perhaps this just needs to be a Set UnitId at this stage. + , installedPkgs :: InstalledPackageIndex + -- ^ All the info about the installed packages that the + -- current package depends on (directly or indirectly). + -- The copy saved on disk does NOT include internal + -- dependencies (because we just don't have enough + -- information at this point to have an + -- 'InstalledPackageInfo' for an internal dep), but we + -- will often update it with the internal dependencies; + -- see for example 'Distribution.Simple.Build.build'. + -- (This admonition doesn't apply for per-component builds.) + , pkgDescrFile :: Maybe FilePath + -- ^ the filename containing the .cabal file, if available + , localPkgDescr :: PackageDescription + -- ^ WARNING WARNING WARNING Be VERY careful about using + -- this function; we haven't deprecated it but using it + -- could introduce subtle bugs related to + -- 'HookedBuildInfo'. + -- + -- In principle, this is supposed to contain the + -- resolved package description, that does not contain + -- any conditionals. However, it MAY NOT contain + -- the description with a 'HookedBuildInfo' applied + -- to it; see 'HookedBuildInfo' for the whole sordid saga. + -- As much as possible, Cabal library should avoid using + -- this parameter. + , withPrograms :: ProgramDb + -- ^ Location and args for all programs + , withPackageDB :: PackageDBStack + -- ^ What package database to use, global\/user + , withVanillaLib :: Bool + -- ^ Whether to build normal libs. + , withProfLib :: Bool + -- ^ Whether to build profiling versions of libs. + , withSharedLib :: Bool + -- ^ Whether to build shared versions of libs. + , withStaticLib :: Bool + -- ^ Whether to build static versions of libs (with all other libs rolled in) + , withDynExe :: Bool + -- ^ Whether to link executables dynamically + , withFullyStaticExe :: Bool + -- ^ Whether to link executables fully statically + , withProfExe :: Bool + -- ^ Whether to build executables for profiling. + , withProfLibDetail :: ProfDetailLevel + -- ^ Level of automatic profile detail. + , withProfExeDetail :: ProfDetailLevel + -- ^ Level of automatic profile detail. + , withOptimization :: OptimisationLevel + -- ^ Whether to build with optimization (if available). + , withDebugInfo :: DebugInfoLevel + -- ^ Whether to emit debug info (if available). + , withGHCiLib :: Bool + -- ^ Whether to build libs suitable for use with GHCi. + , splitSections :: Bool + -- ^ Use -split-sections with GHC, if available + , splitObjs :: Bool + -- ^ Use -split-objs with GHC, if available + , stripExes :: Bool + -- ^ Whether to strip executables during install + , stripLibs :: Bool + -- ^ Whether to strip libraries during install + , exeCoverage :: Bool + -- ^ Whether to enable executable program coverage + , libCoverage :: Bool + -- ^ Whether to enable library program coverage + , progPrefix :: PathTemplate + -- ^ Prefix to be prepended to installed executables + , progSuffix :: PathTemplate + -- ^ Suffix to be appended to installed executables + , relocatable :: Bool -- ^Whether to build a relocatable package + } + deriving (Generic, Read, Show, Typeable) instance Binary LocalBuildInfo instance Structured LocalBuildInfo diff --git a/cabal-install/src/Distribution/Client/CmdListBin.hs b/cabal-install/src/Distribution/Client/CmdListBin.hs index b78f2abd031..7cee2edd3c3 100644 --- a/cabal-install/src/Distribution/Client/CmdListBin.hs +++ b/cabal-install/src/Distribution/Client/CmdListBin.hs @@ -39,21 +39,24 @@ import Distribution.Client.NixStyleOptions import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning.Types import Distribution.Client.ScriptUtils - ( AcceptNoTargets(..), TargetContext(..) - , updateContextAndWriteProjectFile, withContextAndSelectors - , movedExePath ) -import Distribution.Client.Setup (GlobalFlags (..)) -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.Utils (die', withOutputMarker, wrapText) -import Distribution.System (Platform) -import Distribution.Types.ComponentName (showComponentName) -import Distribution.Types.UnitId (UnitId) -import Distribution.Types.UnqualComponentName (UnqualComponentName) -import Distribution.Verbosity (silent, verboseStderr) -import System.FilePath ((<.>), ()) + ( AcceptNoTargets (..) + , TargetContext (..) + , movedExePath + , updateContextAndWriteProjectFile + , withContextAndSelectors + ) +import Distribution.Client.Setup (GlobalFlags (..)) +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.Utils (die', withOutputMarker, wrapText) +import Distribution.System (Platform) +import Distribution.Types.ComponentName (showComponentName) +import Distribution.Types.UnitId (UnitId) +import Distribution.Types.UnqualComponentName (UnqualComponentName) +import Distribution.Verbosity (silent, verboseStderr) +import System.FilePath ((<.>), ()) import qualified Data.Map as Map import qualified Data.Set as Set @@ -195,15 +198,15 @@ listbinAction flags@NixStyleFlags{..} args globalFlags = do dist_dir = distBuildDirectory distDirLayout (elabDistDirParams elaboratedSharedConfig elab) bin_file c = case c of - CD.ComponentExe s - | s == selectedComponent -> [moved_bin_file s] - CD.ComponentTest s - | s == selectedComponent -> [bin_file' s] - CD.ComponentBench s - | s == selectedComponent -> [bin_file' s] - CD.ComponentFLib s - | s == selectedComponent -> [flib_file' s] - _ -> [] + CD.ComponentExe s + | s == selectedComponent -> [moved_bin_file s] + CD.ComponentTest s + | s == selectedComponent -> [bin_file' s] + CD.ComponentBench s + | s == selectedComponent -> [bin_file' s] + CD.ComponentFLib s + | s == selectedComponent -> [flib_file' s] + _ -> [] plat :: Platform plat = pkgConfigPlatform elaboratedSharedConfig @@ -211,12 +214,12 @@ listbinAction flags@NixStyleFlags{..} args globalFlags = do -- here and in PlanOutput, -- use binDirectoryFor? bin_file' s = - if isInplaceBuildStyle (elabBuildStyle elab) + if isInplaceBuildStyle (elabBuildStyle elab) then dist_dir "build" prettyShow s prettyShow s <.> exeExtension plat else InstallDirs.bindir (elabInstallDirs elab) prettyShow s <.> exeExtension plat flib_file' s = - if isInplaceBuildStyle (elabBuildStyle elab) + if isInplaceBuildStyle (elabBuildStyle elab) then dist_dir "build" prettyShow s ("lib" ++ prettyShow s) <.> dllExtension plat else InstallDirs.bindir (elabInstallDirs elab) ("lib" ++ prettyShow s) <.> dllExtension plat diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs index a1f1d6db836..d8458b967c8 100644 --- a/cabal-install/src/Distribution/Client/CmdRepl.hs +++ b/cabal-install/src/Distribution/Client/CmdRepl.hs @@ -1,23 +1,20 @@ -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -- | cabal-install CLI command: repl --- -module Distribution.Client.CmdRepl ( - -- * The @repl@ CLI and action - replCommand, - replAction, - ReplFlags(..), +module Distribution.Client.CmdRepl + ( -- * The @repl@ CLI and action + replCommand + , replAction + , ReplFlags (..) -- * Internals exposed for testing - matchesMultipleProblem, - selectPackageTargets, - selectComponentTarget, - MultiReplDecision (..), + , matchesMultipleProblem + , selectPackageTargets + , selectComponentTarget + , MultiReplDecision (..) ) where import Distribution.Client.Compat.Prelude @@ -27,15 +24,20 @@ import Distribution.Compat.Lens import qualified Distribution.Types.Lens as L import Distribution.Client.CmdErrorMessages - ( renderTargetSelector, showTargetSelector, - renderTargetProblem, - targetSelectorRefersToPkgs, - renderComponentKind, renderListCommaAnd, renderListSemiAnd, - componentKind, sortGroupOn, Plural(..) ) -import Distribution.Client.Targets - ( UserConstraint(..), UserConstraintScope(..) ) -import Distribution.Client.TargetProblem - ( TargetProblem(..) ) + ( Plural (..) + , componentKind + , renderComponentKind + , renderListCommaAnd + , renderListSemiAnd + , renderTargetProblem + , renderTargetSelector + , showTargetSelector + , sortGroupOn + , targetSelectorRefersToPkgs + ) +import Distribution.Client.DistDirLayout + ( DistDirLayout (..) + ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.NixStyleOptions ( NixStyleFlags (..) @@ -52,7 +54,9 @@ import Distribution.Client.ProjectPlanning , ElaboratedSharedConfig (..) ) import Distribution.Client.ProjectPlanning.Types - ( elabOrderExeDependencies, showElaboratedInstallPlan ) + ( elabOrderExeDependencies + , showElaboratedInstallPlan + ) import Distribution.Client.ScriptUtils ( AcceptNoTargets (..) , TargetContext (..) @@ -70,126 +74,192 @@ import qualified Distribution.Client.Setup as Client import Distribution.Client.TargetProblem ( TargetProblem (..) ) +import Distribution.Client.Targets + ( UserConstraint (..) + , UserConstraintScope (..) + ) import Distribution.Client.Types - ( PackageSpecifier(..), UnresolvedSourcePackage ) -import Distribution.Simple.Setup - ( ReplOptions(..) ) -import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives - ) + ( PackageSpecifier (..) + , UnresolvedSourcePackage + ) import Distribution.Compiler ( CompilerFlavor (GHC) ) import Distribution.Package - ( Package(..), packageName, mkPackageName, UnitId, installedUnitId ) -import Distribution.Solver.Types.SourcePackage - ( SourcePackage(..) ) + ( Package (..) + , UnitId + , installedUnitId + , mkPackageName + , packageName + ) +import Distribution.Simple.Command + ( CommandUI (..) + , usageAlternatives + ) +import Distribution.Simple.Compiler + ( Compiler + , compilerCompatVersion + ) +import Distribution.Simple.Setup + ( ReplOptions (..) + ) +import Distribution.Simple.Utils + ( TempFileOptions (..) + , debugNoWrap + , die' + , withTempDirectoryEx + , wrapText + ) import Distribution.Solver.Types.ConstraintSource - ( ConstraintSource(ConstraintSourceMultiRepl) ) + ( ConstraintSource (ConstraintSourceMultiRepl) + ) import Distribution.Solver.Types.PackageConstraint - ( PackageProperty(PackagePropertyVersion) ) + ( PackageProperty (PackagePropertyVersion) + ) +import Distribution.Solver.Types.SourcePackage + ( SourcePackage (..) + ) import Distribution.Types.BuildInfo - ( BuildInfo(..), emptyBuildInfo ) + ( BuildInfo (..) + , emptyBuildInfo + ) import Distribution.Types.ComponentName - ( componentNameString ) + ( componentNameString + ) import Distribution.Types.CondTree - ( CondTree(..) ) + ( CondTree (..) + ) import Distribution.Types.Dependency - ( Dependency(..), mainLibSet ) + ( Dependency (..) + , mainLibSet + ) import Distribution.Types.Library - ( Library(..), emptyLibrary ) + ( Library (..) + , emptyLibrary + ) import Distribution.Types.Version - ( Version, mkVersion ) + ( Version + , mkVersion + ) import Distribution.Types.VersionRange - ( anyVersion, orLaterVersion ) + ( anyVersion + , orLaterVersion + ) import Distribution.Utils.Generic - ( safeHead ) + ( safeHead + ) import Distribution.Verbosity - ( normal, lessVerbose ) -import Distribution.Simple.Utils - ( wrapText, die', debugNoWrap, withTempDirectoryEx, TempFileOptions (..) ) + ( lessVerbose + , normal + ) import Language.Haskell.Extension ( Language (..) ) +import Control.Monad (mapM) +import qualified Data.ByteString.Lazy as BS import Data.List ( (\\) ) import qualified Data.Map as Map import qualified Data.Set as Set -import System.Directory - ( doesFileExist, getCurrentDirectory, listDirectory, makeAbsolute ) -import System.FilePath - ( (), splitSearchPath, searchPathSeparator ) +import Distribution.Client.ProjectConfig + ( ProjectConfig (projectConfigShared) + , ProjectConfigShared (projectConfigConstraints, projectConfigMultiRepl) + ) +import Distribution.Client.ReplFlags + ( EnvFlags (envIncludeTransitive, envPackages) + , ReplFlags (..) + , defaultReplFlags + , topReplOptions + ) +import Distribution.Compat.Binary (decode) +import Distribution.Simple.Flag (Flag (Flag), fromFlagOrDefault) +import Distribution.Simple.Program.Builtin (ghcProgram) +import Distribution.Simple.Program.Db (requireProgram) import Distribution.Simple.Program.Run - ( programInvocation, runProgramInvocation ) -import Distribution.Simple.Program.Builtin ( ghcProgram ) -import Distribution.Simple.Program.Db ( requireProgram ) -import Control.Monad ( mapM ) -import Distribution.Compat.Binary ( decode ) -import qualified Data.ByteString.Lazy as BS + ( programInvocation + , runProgramInvocation + ) import Distribution.Simple.Program.Types - ( ConfiguredProgram(programOverrideEnv) ) -import Distribution.Client.ReplFlags - ( ReplFlags(..), - EnvFlags(envIncludeTransitive, envPackages), - defaultReplFlags, - topReplOptions ) -import Distribution.Simple.Flag ( Flag(Flag), fromFlagOrDefault ) -import Distribution.Client.ProjectConfig - ( ProjectConfigShared(projectConfigMultiRepl, projectConfigConstraints), - ProjectConfig(projectConfigShared) ) + ( ConfiguredProgram (programOverrideEnv) + ) +import System.Directory + ( doesFileExist + , getCurrentDirectory + , listDirectory + , makeAbsolute + ) +import System.FilePath + ( searchPathSeparator + , splitSearchPath + , () + ) replCommand :: CommandUI (NixStyleFlags ReplFlags) -replCommand = Client.installCommand { - commandName = "v2-repl", - commandSynopsis = "Open an interactive session for the given component.", - commandUsage = usageAlternatives "v2-repl" [ "[TARGET] [FLAGS]" ], - commandDescription = Just $ \_ -> wrapText $ - "Open an interactive session for a component within the project. The " - ++ "available targets are the same as for the 'v2-build' command: " - ++ "individual components within packages in the project, including " - ++ "libraries, executables, test-suites or benchmarks. Packages can " - ++ "also be specified in which case the library component in the " - ++ "package will be used, or the (first listed) executable in the " - ++ "package if there is no library.\n\n" - - ++ "Dependencies are built or rebuilt as necessary. Additional " - ++ "configuration flags can be specified on the command line and these " - ++ "extend the project configuration from the 'cabal.project', " - ++ "'cabal.project.local' and other files.", - commandNotes = Just $ \pname -> +replCommand = + Client.installCommand + { commandName = "v2-repl" + , commandSynopsis = "Open an interactive session for the given component." + , commandUsage = usageAlternatives "v2-repl" ["[TARGET] [FLAGS]"] + , commandDescription = Just $ \_ -> + wrapText $ + "Open an interactive session for a component within the project. The " + ++ "available targets are the same as for the 'v2-build' command: " + ++ "individual components within packages in the project, including " + ++ "libraries, executables, test-suites or benchmarks. Packages can " + ++ "also be specified in which case the library component in the " + ++ "package will be used, or the (first listed) executable in the " + ++ "package if there is no library.\n\n" + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files." + , commandNotes = Just $ \pname -> "Examples, open an interactive session:\n" - ++ " " ++ pname ++ " v2-repl\n" - ++ " for the default component in the package in the current directory\n" - ++ " " ++ pname ++ " v2-repl pkgname\n" - ++ " for the default component in the package named 'pkgname'\n" - ++ " " ++ pname ++ " v2-repl ./pkgfoo\n" - ++ " for the default component in the package in the ./pkgfoo directory\n" - ++ " " ++ pname ++ " v2-repl cname\n" - ++ " for the component named 'cname'\n" - ++ " " ++ pname ++ " v2-repl pkgname:cname\n" - ++ " for the component 'cname' in the package 'pkgname'\n\n" - ++ " " ++ pname ++ " v2-repl --build-depends lens\n" - ++ " add the latest version of the library 'lens' to the default component " - ++ "(or no componentif there is no project present)\n" - ++ " " ++ pname ++ " v2-repl --build-depends \"lens >= 4.15 && < 4.18\"\n" - ++ " add a version (constrained between 4.15 and 4.18) of the library 'lens' " - ++ "to the default component (or no component if there is no project present)\n", - - commandDefaultFlags = defaultNixStyleFlags defaultReplFlags, - commandOptions = nixStyleOptions topReplOptions - - } + ++ " " + ++ pname + ++ " v2-repl\n" + ++ " for the default component in the package in the current directory\n" + ++ " " + ++ pname + ++ " v2-repl pkgname\n" + ++ " for the default component in the package named 'pkgname'\n" + ++ " " + ++ pname + ++ " v2-repl ./pkgfoo\n" + ++ " for the default component in the package in the ./pkgfoo directory\n" + ++ " " + ++ pname + ++ " v2-repl cname\n" + ++ " for the component named 'cname'\n" + ++ " " + ++ pname + ++ " v2-repl pkgname:cname\n" + ++ " for the component 'cname' in the package 'pkgname'\n\n" + ++ " " + ++ pname + ++ " v2-repl --build-depends lens\n" + ++ " add the latest version of the library 'lens' to the default component " + ++ "(or no componentif there is no project present)\n" + ++ " " + ++ pname + ++ " v2-repl --build-depends \"lens >= 4.15 && < 4.18\"\n" + ++ " add a version (constrained between 4.15 and 4.18) of the library 'lens' " + ++ "to the default component (or no component if there is no project present)\n" + , commandDefaultFlags = defaultNixStyleFlags defaultReplFlags + , commandOptions = nixStyleOptions topReplOptions + } data MultiReplDecision = MultiReplDecision - { compilerVersion:: Maybe Version - , enabledByFlag :: Bool - } deriving (Eq, Show) + { compilerVersion :: Maybe Version + , enabledByFlag :: Bool + } + deriving (Eq, Show) useMultiRepl :: MultiReplDecision -> Bool -useMultiRepl MultiReplDecision{compilerVersion, enabledByFlag} - = compilerVersion >= Just minMultipleHomeUnitsVersion && enabledByFlag +useMultiRepl MultiReplDecision{compilerVersion, enabledByFlag} = + compilerVersion >= Just minMultipleHomeUnitsVersion && enabledByFlag multiReplDecision :: ProjectConfigShared -> Compiler -> ReplFlags -> MultiReplDecision multiReplDecision ctx compiler flags = @@ -210,10 +280,9 @@ multiReplDecision ctx compiler flags = -- -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" --- replAction :: NixStyleFlags ReplFlags -> [String] -> GlobalFlags -> IO () -replAction flags@NixStyleFlags { extraFlags = r@ReplFlags{..} , ..} targetStrings globalFlags - = withContextAndSelectors AcceptNoTargets (Just LibKind) flags targetStrings globalFlags ReplCommand $ \targetCtx ctx targetSelectors -> do +replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings globalFlags = + withContextAndSelectors AcceptNoTargets (Just LibKind) flags targetStrings globalFlags ReplCommand $ \targetCtx ctx targetSelectors -> do when (buildSettingOnlyDeps (buildSettings ctx)) $ die' verbosity $ "The repl command does not support '--only-dependencies'. " @@ -259,17 +328,20 @@ replAction flags@NixStyleFlags { extraFlags = r@ReplFlags{..} , ..} targetString -- We need to do this before solving, but the compiler version is only known -- after solving (phaseConfigureCompiler), so instead of using -- multiReplDecision we just check the flag. - let baseCtx' = if fromFlagOrDefault False $ - projectConfigMultiRepl (projectConfigShared $ projectConfig baseCtx) - <> replUseMulti - then baseCtx & lProjectConfig . lProjectConfigShared . lProjectConfigConstraints - %~ (multiReplCabalConstraint:) - else baseCtx - - (originalComponent, baseCtx'') <- if null (envPackages replEnvFlags) - then return (Nothing, baseCtx') - else - -- Unfortunately, the best way to do this is to let the normal solver + let baseCtx' = + if fromFlagOrDefault False $ + projectConfigMultiRepl (projectConfigShared $ projectConfig baseCtx) + <> replUseMulti + then + baseCtx + & lProjectConfig . lProjectConfigShared . lProjectConfigConstraints + %~ (multiReplCabalConstraint :) + else baseCtx + + (originalComponent, baseCtx'') <- + if null (envPackages replEnvFlags) + then return (Nothing, baseCtx') + else -- Unfortunately, the best way to do this is to let the normal solver -- help us resolve the targets, but that isn't ideal for performance, -- especially in the no-project case. withInstallPlan (lessVerbose verbosity) baseCtx' $ \elaboratedPlan sharedConfig -> do @@ -301,10 +373,11 @@ replAction flags@NixStyleFlags { extraFlags = r@ReplFlags{..} , ..} targetString targets <- validatedTargets (projectConfigShared projectConfig) (pkgConfigCompiler elaboratedShared') elaboratedPlan targetSelectors let - elaboratedPlan' = pruneInstallPlanToTargets - TargetActionRepl - targets - elaboratedPlan + elaboratedPlan' = + pruneInstallPlanToTargets + TargetActionRepl + targets + elaboratedPlan includeTransitive = fromFlagOrDefault True (envIncludeTransitive replEnvFlags) pkgsBuildStatus <- @@ -313,8 +386,10 @@ replAction flags@NixStyleFlags { extraFlags = r@ReplFlags{..} , ..} targetString elaboratedShared' elaboratedPlan' - let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages - pkgsBuildStatus elaboratedPlan' + let elaboratedPlan'' = + improveInstallPlanWithUpToDatePackages + pkgsBuildStatus + elaboratedPlan' debugNoWrap verbosity (showElaboratedInstallPlan elaboratedPlan'') let @@ -338,77 +413,78 @@ replAction flags@NixStyleFlags { extraFlags = r@ReplFlags{..} , ..} targetString -- Multi Repl implemention see: https://well-typed.com/blog/2023/03/cabal-multi-unit/ for -- a high-level overview about how everything fits together. if Set.size (distinctTargetComponents targets) > 1 - then withTempDirectoryEx verbosity (TempFileOptions keepTempFiles) distDir "multi-out" $ \dir' -> do - -- multi target repl - dir <- makeAbsolute dir' - -- Modify the replOptions so that the ./Setup repl command will write options - -- into the multi-out directory. - replOpts'' <- case targetCtx of - ProjectContext -> return $ replOpts' { replOptionsFlagOutput = Flag dir} - _ -> usingGhciScript compiler projectRoot replOpts' - - let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts'' - printPlan verbosity baseCtx'' buildCtx' - - -- The project build phase will call `./Setup repl` but write the options - -- out into a file without starting a repl. - buildOutcomes <- runProjectBuildPhase verbosity baseCtx'' buildCtx' - runProjectPostBuildPhase verbosity baseCtx'' buildCtx' buildOutcomes - - -- calculate PATH, we construct a PATH which is the union of all paths from - -- the units which have been loaded. This is not quite right but usually works fine. - path_files <- listDirectory (dir "paths") - - -- Note: decode is partial. Should we use Structured here? - -- This might blow up with @build-type: Custom@ stuff. - ghcProgs <- mapM (\f -> decode @ConfiguredProgram <$> BS.readFile (dir "paths" f)) path_files - - let all_paths = concatMap programOverrideEnv ghcProgs - let sp = intercalate [searchPathSeparator] (map fst (sortBy (comparing @Int snd) $ Map.toList (combine_search_paths all_paths))) - -- HACK: Just combine together all env overrides, placing the most common things last - - -- ghc program with overriden PATH - (ghcProg, _) <- requireProgram verbosity ghcProgram (pkgConfigCompilerProgs (elaboratedShared buildCtx')) - let ghcProg' = ghcProg { programOverrideEnv = [("PATH", Just sp)]} - - - -- Find what the unit files are, and start a repl based on all the response - -- files which have been created in the directory. - -- unit files for components - unit_files <- listDirectory dir - - -- run ghc --interactive with - runProgramInvocation verbosity $ programInvocation ghcProg' $ concat $ - ["--interactive" - , "-package-env", "-" -- to ignore ghc.environment.* files - , "-j", show (buildSettingNumJobs (buildSettings ctx)) - ] : - [ ["-unit", "@" ++ dir unit] - | unit <- unit_files, unit /= "paths" - ] - - pure () - - else do - -- single target repl - replOpts'' <- case targetCtx of - ProjectContext -> return replOpts' - _ -> usingGhciScript compiler projectRoot replOpts' - - let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts'' - printPlan verbosity baseCtx'' buildCtx' - - buildOutcomes <- runProjectBuildPhase verbosity baseCtx'' buildCtx' - runProjectPostBuildPhase verbosity baseCtx'' buildCtx' buildOutcomes + then withTempDirectoryEx verbosity (TempFileOptions keepTempFiles) distDir "multi-out" $ \dir' -> do + -- multi target repl + dir <- makeAbsolute dir' + -- Modify the replOptions so that the ./Setup repl command will write options + -- into the multi-out directory. + replOpts'' <- case targetCtx of + ProjectContext -> return $ replOpts'{replOptionsFlagOutput = Flag dir} + _ -> usingGhciScript compiler projectRoot replOpts' + + let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts'' + printPlan verbosity baseCtx'' buildCtx' + + -- The project build phase will call `./Setup repl` but write the options + -- out into a file without starting a repl. + buildOutcomes <- runProjectBuildPhase verbosity baseCtx'' buildCtx' + runProjectPostBuildPhase verbosity baseCtx'' buildCtx' buildOutcomes + + -- calculate PATH, we construct a PATH which is the union of all paths from + -- the units which have been loaded. This is not quite right but usually works fine. + path_files <- listDirectory (dir "paths") + + -- Note: decode is partial. Should we use Structured here? + -- This might blow up with @build-type: Custom@ stuff. + ghcProgs <- mapM (\f -> decode @ConfiguredProgram <$> BS.readFile (dir "paths" f)) path_files + + let all_paths = concatMap programOverrideEnv ghcProgs + let sp = intercalate [searchPathSeparator] (map fst (sortBy (comparing @Int snd) $ Map.toList (combine_search_paths all_paths))) + -- HACK: Just combine together all env overrides, placing the most common things last + + -- ghc program with overriden PATH + (ghcProg, _) <- requireProgram verbosity ghcProgram (pkgConfigCompilerProgs (elaboratedShared buildCtx')) + let ghcProg' = ghcProg{programOverrideEnv = [("PATH", Just sp)]} + + -- Find what the unit files are, and start a repl based on all the response + -- files which have been created in the directory. + -- unit files for components + unit_files <- listDirectory dir + + -- run ghc --interactive with + runProgramInvocation verbosity $ + programInvocation ghcProg' $ + concat $ + [ "--interactive" + , "-package-env" + , "-" -- to ignore ghc.environment.* files + , "-j" + , show (buildSettingNumJobs (buildSettings ctx)) + ] + : [ ["-unit", "@" ++ dir unit] + | unit <- unit_files + , unit /= "paths" + ] + + pure () + else do + -- single target repl + replOpts'' <- case targetCtx of + ProjectContext -> return replOpts' + _ -> usingGhciScript compiler projectRoot replOpts' + + let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts'' + printPlan verbosity baseCtx'' buildCtx' + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx'' buildCtx' + runProjectPostBuildPhase verbosity baseCtx'' buildCtx' buildOutcomes where - combine_search_paths paths = foldl' go Map.empty paths where - go m ("PATH", Just s) = foldl' (\m' f-> Map.insertWith (+) f 1 m') m (splitSearchPath s) + go m ("PATH", Just s) = foldl' (\m' f -> Map.insertWith (+) f 1 m') m (splitSearchPath s) go m _ = m - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) keepTempFiles = fromFlagOrDefault False replKeepTempFiles @@ -416,19 +492,21 @@ replAction flags@NixStyleFlags { extraFlags = r@ReplFlags{..} , ..} targetString let multi_repl_enabled = multiReplDecision ctx compiler r -- Interpret the targets on the command line as repl targets -- (as opposed to say build or haddock targets). - targets <- either (reportTargetProblems verbosity) return - $ resolveTargets - (selectPackageTargets multi_repl_enabled) - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors + targets <- + either (reportTargetProblems verbosity) return $ + resolveTargets + (selectPackageTargets multi_repl_enabled) + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors -- Reject multiple targets, or at least targets in different -- components. It is ok to have two module/file targets in the -- same component, but not two that live in different components. when (Set.size (distinctTargetComponents targets) > 1 && not (useMultiRepl multi_repl_enabled)) $ - reportTargetProblems verbosity + reportTargetProblems + verbosity [multipleTargetsProblem multi_repl_enabled targets] return targets @@ -441,8 +519,9 @@ replAction flags@NixStyleFlags { extraFlags = r@ReplFlags{..} , ..} targetString multiReplCabalConstraint = ( UserConstraint (UserAnySetupQualifier (mkPackageName "Cabal")) - (PackagePropertyVersion $ orLaterVersion $ mkVersion [3,11]) - , ConstraintSourceMultiRepl ) + (PackagePropertyVersion $ orLaterVersion $ mkVersion [3, 11]) + , ConstraintSourceMultiRepl + ) -- | First version of GHC which supports multiple home packages minMultipleHomeUnitsVersion :: Version @@ -518,7 +597,6 @@ usingGhciScript compiler projectRoot replOpts return $ replOpts & lReplOptionsFlags %~ (("-ghci-script" ++ ghciScriptPath) :) | otherwise = return replOpts - -- | First version of GHC where GHCi supported the flag we need. -- https://downloads.haskell.org/~ghc/7.6.1/docs/html/users_guide/release-7-6-1.html minGhciScriptVersion :: Version @@ -538,75 +616,76 @@ minGhciScriptVersion = mkVersion [7, 6] -- -- Fail if there are no buildable lib\/exe components, or if there are -- multiple libs or exes. --- -selectPackageTargets :: MultiReplDecision - -> TargetSelector - -> [AvailableTarget k] -> Either ReplTargetProblem [k] -selectPackageTargets multiple_targets_allowed +selectPackageTargets + :: MultiReplDecision + -> TargetSelector + -> [AvailableTarget k] + -> Either ReplTargetProblem [k] +selectPackageTargets multiple_targets_allowed = -- If explicitly enabled, then select the targets like we would for multi-repl but -- might still fail later because of compiler version. - = if enabledByFlag multiple_targets_allowed - then selectPackageTargetsMulti - else selectPackageTargetsSingle multiple_targets_allowed - -selectPackageTargetsMulti :: TargetSelector - -> [AvailableTarget k] -> Either ReplTargetProblem [k] + if enabledByFlag multiple_targets_allowed + then selectPackageTargetsMulti + else selectPackageTargetsSingle multiple_targets_allowed + +selectPackageTargetsMulti + :: TargetSelector + -> [AvailableTarget k] + -> Either ReplTargetProblem [k] selectPackageTargetsMulti targetSelector targets - | not (null targetsBuildable) - = Right targetsBuildable - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) + | not (null targetsBuildable) = + Right targetsBuildable + -- If there are no targets at all then we report that + | otherwise = + Left (TargetProblemNoTargets targetSelector) where - (targetsBuildable, - _) = selectBuildableTargetsWith' - (isRequested targetSelector) targets + ( targetsBuildable + , _ + ) = + selectBuildableTargetsWith' + (isRequested targetSelector) + targets -- When there's a target filter like "pkg:tests" then we do select tests, -- but if it's just a target like "pkg" then we don't build tests unless -- they are requested by default (i.e. by using --enable-tests) - isRequested (TargetAllPackages Nothing) TargetNotRequestedByDefault = False - isRequested (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False + isRequested (TargetAllPackages Nothing) TargetNotRequestedByDefault = False + isRequested (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False isRequested _ _ = True -- | Target selection behaviour which only select a single target. -- This is used when the compiler version doesn't support multi-repl or the user -- didn't request it. -selectPackageTargetsSingle :: MultiReplDecision -> TargetSelector - -> [AvailableTarget k] -> Either ReplTargetProblem [k] +selectPackageTargetsSingle + :: MultiReplDecision + -> TargetSelector + -> [AvailableTarget k] + -> Either ReplTargetProblem [k] selectPackageTargetsSingle decision targetSelector targets - - -- If there is exactly one buildable library then we select that - | [target] <- targetsLibsBuildable - = Right [target] - - -- but fail if there are multiple buildable libraries. - | not (null targetsLibsBuildable) - = Left (matchesMultipleProblem decision targetSelector targetsLibsBuildable') - - -- If there is exactly one buildable executable then we select that - | [target] <- targetsExesBuildable - = Right [target] - - -- but fail if there are multiple buildable executables. - | not (null targetsExesBuildable) - = Left (matchesMultipleProblem decision targetSelector targetsExesBuildable') - - -- If there is exactly one other target then we select that - | [target] <- targetsBuildable - = Right [target] - - -- but fail if there are multiple such targets - | not (null targetsBuildable) - = Left (matchesMultipleProblem decision targetSelector targetsBuildable') - - -- If there are targets but none are buildable then we report those - | not (null targets) - = Left (TargetProblemNoneEnabled targetSelector targets') - - -- If there are no targets at all then we report that - | otherwise - = Left (TargetProblemNoTargets targetSelector) + -- If there is exactly one buildable library then we select that + | [target] <- targetsLibsBuildable = + Right [target] + -- but fail if there are multiple buildable libraries. + | not (null targetsLibsBuildable) = + Left (matchesMultipleProblem decision targetSelector targetsLibsBuildable') + -- If there is exactly one buildable executable then we select that + | [target] <- targetsExesBuildable = + Right [target] + -- but fail if there are multiple buildable executables. + | not (null targetsExesBuildable) = + Left (matchesMultipleProblem decision targetSelector targetsExesBuildable') + -- If there is exactly one other target then we select that + | [target] <- targetsBuildable = + Right [target] + -- but fail if there are multiple such targets + | not (null targetsBuildable) = + Left (matchesMultipleProblem decision targetSelector targetsBuildable') + -- If there are targets but none are buildable then we report those + | not (null targets) = + Left (TargetProblemNoneEnabled targetSelector targets') + -- If there are no targets at all then we report that + | otherwise = + Left (TargetProblemNoTargets targetSelector) where targets' = forgetTargetsDetail targets ( targetsLibsBuildable @@ -647,9 +726,8 @@ selectComponentTarget = selectComponentTargetBasic data ReplProblem = TargetProblemMatchesMultiple MultiReplDecision TargetSelector [AvailableTarget ()] - - -- | Multiple 'TargetSelector's match multiple targets - | TargetProblemMultipleTargets MultiReplDecision TargetsMap + | -- | Multiple 'TargetSelector's match multiple targets + TargetProblemMultipleTargets MultiReplDecision TargetsMap deriving (Eq, Show) -- | The various error conditions that can occur when matching a @@ -679,13 +757,17 @@ renderReplTargetProblem = renderTargetProblem "open a repl for" renderReplProble renderReplProblem :: ReplProblem -> String renderReplProblem (TargetProblemMatchesMultiple decision targetSelector targets) = - "Cannot open a repl for multiple components at once. The target '" - ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ " which " - ++ (if targetSelectorRefersToPkgs targetSelector then "includes " else "are ") - ++ renderListSemiAnd - [ "the " ++ renderComponentKind Plural ckind ++ " " ++ - renderListCommaAnd + "Cannot open a repl for multiple components at once. The target '" + ++ showTargetSelector targetSelector + ++ "' refers to " + ++ renderTargetSelector targetSelector + ++ " which " + ++ (if targetSelectorRefersToPkgs targetSelector then "includes " else "are ") + ++ renderListSemiAnd + [ "the " + ++ renderComponentKind Plural ckind + ++ " " + ++ renderListCommaAnd [ maybe (prettyShow pkgname) prettyShow (componentNameString cname) | t <- ts , let cname = availableTargetComponentName t @@ -693,18 +775,21 @@ renderReplProblem (TargetProblemMatchesMultiple decision targetSelector targets) ] | (ckind, ts) <- sortGroupOn availableTargetComponentKind targets ] - ++ ".\n\n" ++ explainMultiReplDecision decision + ++ ".\n\n" + ++ explainMultiReplDecision decision where - availableTargetComponentKind = componentKind - . availableTargetComponentName - + availableTargetComponentKind = + componentKind + . availableTargetComponentName renderReplProblem (TargetProblemMultipleTargets multi_decision selectorMap) = - "Cannot open a repl for multiple components at once. The targets " - ++ renderListCommaAnd + "Cannot open a repl for multiple components at once. The targets " + ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'" - | ts <- uniqueTargetSelectors selectorMap ] - ++ " refer to different components." - ++ ".\n\n" ++ explainMultiReplDecision multi_decision + | ts <- uniqueTargetSelectors selectorMap + ] + ++ " refer to different components." + ++ ".\n\n" + ++ explainMultiReplDecision multi_decision explainMultiReplDecision :: MultiReplDecision -> [Char] explainMultiReplDecision MultiReplDecision{compilerVersion, enabledByFlag} = @@ -712,30 +797,32 @@ explainMultiReplDecision MultiReplDecision{compilerVersion, enabledByFlag} = -- Compiler not new enough, and not requested anyway. (False, False) -> explanationSingleComponentLimitation compilerVersion -- Compiler too old, but was requested - (False, True) -> "Multiple component session requested but compiler version is too old.\n" ++ explanationSingleComponentLimitation compilerVersion + (False, True) -> "Multiple component session requested but compiler version is too old.\n" ++ explanationSingleComponentLimitation compilerVersion -- Compiler new enough, but not requested - (True, False) -> explanationNeedToEnableFlag + (True, False) -> explanationNeedToEnableFlag _ -> error "explainMultiReplDecision" explanationNeedToEnableFlag :: String explanationNeedToEnableFlag = - "Your compiler supports a multiple component repl but support is not enabled.\n" ++ - "The experimental multi repl can be enabled by\n" ++ - " * Globally: Setting multi-repl: True in your .cabal/config\n" ++ - " * Project Wide: Setting multi-repl: True in your cabal.project file\n" ++ - " * Per Invocation: By passing --enable-multi-repl when starting the repl" - + "Your compiler supports a multiple component repl but support is not enabled.\n" + ++ "The experimental multi repl can be enabled by\n" + ++ " * Globally: Setting multi-repl: True in your .cabal/config\n" + ++ " * Project Wide: Setting multi-repl: True in your cabal.project file\n" + ++ " * Per Invocation: By passing --enable-multi-repl when starting the repl" explanationSingleComponentLimitation :: Maybe Version -> String explanationSingleComponentLimitation version = - "The reason for this limitation is that your version " ++ versionString ++ "of ghci does not " - ++ "support loading multiple components as source. Load just one component " - ++ "and when you make changes to a dependent component then quit and reload.\n" - ++ prettyShow minMultipleHomeUnitsVersion ++ " is needed to support multiple component sessions." - where - versionString = case version of - Nothing -> "" - Just ver -> "(" ++ prettyShow ver ++ ") " + "The reason for this limitation is that your version " + ++ versionString + ++ "of ghci does not " + ++ "support loading multiple components as source. Load just one component " + ++ "and when you make changes to a dependent component then quit and reload.\n" + ++ prettyShow minMultipleHomeUnitsVersion + ++ " is needed to support multiple component sessions." + where + versionString = case version of + Nothing -> "" + Just ver -> "(" ++ prettyShow ver ++ ") " -- Lenses lElaboratedShared :: Lens' ProjectBuildContext ElaboratedSharedConfig @@ -747,17 +834,17 @@ lPkgConfigReplOptions f s = fmap (\x -> s{pkgConfigReplOptions = x}) (f (pkgConf {-# INLINE lPkgConfigReplOptions #-} lReplOptionsFlags :: Lens' ReplOptions [String] -lReplOptionsFlags f s = fmap (\x -> s { replOptionsFlags = x }) (f (replOptionsFlags s)) -{-# inline lReplOptionsFlags #-} +lReplOptionsFlags f s = fmap (\x -> s{replOptionsFlags = x}) (f (replOptionsFlags s)) +{-# INLINE lReplOptionsFlags #-} lProjectConfig :: Lens' ProjectBaseContext ProjectConfig -lProjectConfig f s = fmap (\x -> s { projectConfig = x }) (f (projectConfig s)) -{-# inline lProjectConfig #-} +lProjectConfig f s = fmap (\x -> s{projectConfig = x}) (f (projectConfig s)) +{-# INLINE lProjectConfig #-} lProjectConfigShared :: Lens' ProjectConfig ProjectConfigShared -lProjectConfigShared f s = fmap (\x -> s { projectConfigShared = x }) (f (projectConfigShared s)) -{-# inline lProjectConfigShared #-} +lProjectConfigShared f s = fmap (\x -> s{projectConfigShared = x}) (f (projectConfigShared s)) +{-# INLINE lProjectConfigShared #-} lProjectConfigConstraints :: Lens' ProjectConfigShared [(UserConstraint, ConstraintSource)] -lProjectConfigConstraints f s = fmap (\x -> s { projectConfigConstraints = x }) (f (projectConfigConstraints s)) -{-# inline lProjectConfigConstraints #-} +lProjectConfigConstraints f s = fmap (\x -> s{projectConfigConstraints = x}) (f (projectConfigConstraints s)) +{-# INLINE lProjectConfigConstraints #-} diff --git a/cabal-install/src/Distribution/Client/CmdRun.hs b/cabal-install/src/Distribution/Client/CmdRun.hs index 536138a8381..cf9338e82d3 100644 --- a/cabal-install/src/Distribution/Client/CmdRun.hs +++ b/cabal-install/src/Distribution/Client/CmdRun.hs @@ -23,55 +23,95 @@ import Distribution.Client.Compat.Prelude hiding (toList) import Prelude () import Distribution.Client.CmdErrorMessages - ( renderTargetSelector, showTargetSelector, - renderTargetProblem, - renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs, - targetSelectorFilter, renderListCommaAnd, - renderListPretty ) + ( plural + , renderListCommaAnd + , renderListPretty + , renderTargetProblem + , renderTargetProblemNoTargets + , renderTargetSelector + , showTargetSelector + , targetSelectorFilter + , targetSelectorPluralPkgs + ) import Distribution.Client.GlobalFlags - ( defaultGlobalFlags ) + ( defaultGlobalFlags + ) import Distribution.Client.InstallPlan - ( toList, foldPlanPackage ) + ( foldPlanPackage + , toList + ) import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) + ( NixStyleFlags (..) + , defaultNixStyleFlags + , nixStyleOptions + ) import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning - ( ElaboratedConfiguredPackage(..) - , ElaboratedInstallPlan, binDirectoryFor ) + ( ElaboratedConfiguredPackage (..) + , ElaboratedInstallPlan + , binDirectoryFor + ) import Distribution.Client.ProjectPlanning.Types - ( dataDirsEnvironmentForPlan ) + ( dataDirsEnvironmentForPlan + ) import Distribution.Client.ScriptUtils - ( AcceptNoTargets(..), TargetContext(..) - , updateContextAndWriteProjectFile, withContextAndSelectors - , movedExePath ) + ( AcceptNoTargets (..) + , TargetContext (..) + , movedExePath + , updateContextAndWriteProjectFile + , withContextAndSelectors + ) import Distribution.Client.Setup - ( GlobalFlags(..), ConfigFlags(..) ) + ( ConfigFlags (..) + , GlobalFlags (..) + ) import Distribution.Client.TargetProblem - ( TargetProblem (..) ) + ( TargetProblem (..) + ) import Distribution.Client.Utils - ( occursOnlyOrBefore, giveRTSWarning ) + ( giveRTSWarning + , occursOnlyOrBefore + ) import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) + ( CommandUI (..) + , usageAlternatives + ) import Distribution.Simple.Flag - ( fromFlagOrDefault ) + ( fromFlagOrDefault + ) import Distribution.Simple.Program.Run - ( runProgramInvocation, ProgramInvocation(..), - emptyProgramInvocation ) + ( ProgramInvocation (..) + , emptyProgramInvocation + , runProgramInvocation + ) import Distribution.Simple.Utils - ( wrapText, die', info, notice, safeHead, warn ) + ( die' + , info + , notice + , safeHead + , warn + , wrapText + ) import Distribution.Types.ComponentName - ( componentNameRaw ) + ( componentNameRaw + ) import Distribution.Types.UnitId - ( UnitId ) + ( UnitId + ) import Distribution.Types.UnqualComponentName - ( UnqualComponentName, unUnqualComponentName ) + ( UnqualComponentName + , unUnqualComponentName + ) import Distribution.Verbosity - ( normal, silent ) + ( normal + , silent + ) import Data.List (group) import qualified Data.Set as Set import GHC.Environment - ( getFullArgs ) + ( getFullArgs + ) import System.Directory ( doesFileExist ) @@ -241,22 +281,25 @@ runAction flags@NixStyleFlags{..} targetAndArgs globalFlags = ++ " to supply " ++ exeName return elabPkg - elabPkgs -> die' verbosity - $ "Multiple matching executables found matching " - ++ exeName - ++ ":\n" - ++ unlines (fmap (\p -> " - in package " ++ prettyShow (elabUnitId p)) elabPkgs) - - let defaultExePath = binDirectoryFor - (distDirLayout baseCtx) - (elaboratedShared buildCtx) - pkg - exeName - exeName + elabPkgs -> + die' verbosity $ + "Multiple matching executables found matching " + ++ exeName + ++ ":\n" + ++ unlines (fmap (\p -> " - in package " ++ prettyShow (elabUnitId p)) elabPkgs) + + let defaultExePath = + binDirectoryFor + (distDirLayout baseCtx) + (elaboratedShared buildCtx) + pkg + exeName + exeName exePath = fromMaybe defaultExePath (movedExePath selectedComponent (distDirLayout baseCtx) (elaboratedShared buildCtx) pkg) - let dryRun = buildSettingDryRun (buildSettings baseCtx) - || buildSettingOnlyDownload (buildSettings baseCtx) + let dryRun = + buildSettingDryRun (buildSettings baseCtx) + || buildSettingOnlyDownload (buildSettings baseCtx) if dryRun then notice verbosity "Running of executable suppressed by flag(s)" diff --git a/cabal-install/src/Distribution/Client/Config.hs b/cabal-install/src/Distribution/Client/Config.hs index c3798e8da8b..a40e31636cc 100644 --- a/cabal-install/src/Distribution/Client/Config.hs +++ b/cabal-install/src/Distribution/Client/Config.hs @@ -195,26 +195,48 @@ import Distribution.Verbosity ( normal ) -import qualified Text.PrettyPrint as Disp - ( render, text, empty ) -import Distribution.Parsec (parsecOptCommaList, ParsecParser, parsecToken, parsecFilePath) -import Text.PrettyPrint - ( ($+$) ) -import Text.PrettyPrint.HughesPJ - ( text, Doc ) -import System.Directory - ( createDirectoryIfMissing, getHomeDirectory, getXdgDirectory, XdgDirectory(XdgCache, XdgConfig, XdgState), renameFile, getAppUserDataDirectory, doesDirectoryExist, doesFileExist ) +import qualified Data.ByteString as BS +import qualified Data.Map as M +import Distribution.Client.ReplFlags +import Distribution.Compat.Environment + ( getEnvironment + ) +import Distribution.Parsec (ParsecParser, parsecFilePath, parsecOptCommaList, parsecToken) import Network.URI - ( URI(..), URIAuth(..), parseURI ) + ( URI (..) + , URIAuth (..) + , parseURI + ) +import System.Directory + ( XdgDirectory (XdgCache, XdgConfig, XdgState) + , createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , getAppUserDataDirectory + , getHomeDirectory + , getXdgDirectory + , renameFile + ) import System.FilePath - ( (<.>), (), takeDirectory ) + ( takeDirectory + , (<.>) + , () + ) import System.IO.Error - ( isDoesNotExistError ) -import Distribution.Compat.Environment - ( getEnvironment ) -import qualified Data.Map as M -import qualified Data.ByteString as BS -import Distribution.Client.ReplFlags + ( isDoesNotExistError + ) +import Text.PrettyPrint + ( ($+$) + ) +import qualified Text.PrettyPrint as Disp + ( empty + , render + , text + ) +import Text.PrettyPrint.HughesPJ + ( Doc + , text + ) -- @@ -223,45 +245,47 @@ import Distribution.Client.ReplFlags -- data SavedConfig = SavedConfig - { savedGlobalFlags :: GlobalFlags - , savedInitFlags :: IT.InitFlags - , savedInstallFlags :: InstallFlags - , savedClientInstallFlags :: ClientInstallFlags - , savedConfigureFlags :: ConfigFlags - , savedConfigureExFlags :: ConfigExFlags - , savedUserInstallDirs :: InstallDirs (Flag PathTemplate) - , savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate) - , savedUploadFlags :: UploadFlags - , savedReportFlags :: ReportFlags - , savedHaddockFlags :: HaddockFlags - , savedTestFlags :: TestFlags - , savedBenchmarkFlags :: BenchmarkFlags - , savedProjectFlags :: ProjectFlags - , savedReplMulti :: Flag Bool - } deriving Generic + { savedGlobalFlags :: GlobalFlags + , savedInitFlags :: IT.InitFlags + , savedInstallFlags :: InstallFlags + , savedClientInstallFlags :: ClientInstallFlags + , savedConfigureFlags :: ConfigFlags + , savedConfigureExFlags :: ConfigExFlags + , savedUserInstallDirs :: InstallDirs (Flag PathTemplate) + , savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate) + , savedUploadFlags :: UploadFlags + , savedReportFlags :: ReportFlags + , savedHaddockFlags :: HaddockFlags + , savedTestFlags :: TestFlags + , savedBenchmarkFlags :: BenchmarkFlags + , savedProjectFlags :: ProjectFlags + , savedReplMulti :: Flag Bool + } + deriving (Generic) instance Monoid SavedConfig where mempty = gmempty mappend = (<>) instance Semigroup SavedConfig where - a <> b = SavedConfig { - savedGlobalFlags = combinedSavedGlobalFlags, - savedInitFlags = combinedSavedInitFlags, - savedInstallFlags = combinedSavedInstallFlags, - savedClientInstallFlags = combinedSavedClientInstallFlags, - savedConfigureFlags = combinedSavedConfigureFlags, - savedConfigureExFlags = combinedSavedConfigureExFlags, - savedUserInstallDirs = combinedSavedUserInstallDirs, - savedGlobalInstallDirs = combinedSavedGlobalInstallDirs, - savedUploadFlags = combinedSavedUploadFlags, - savedReportFlags = combinedSavedReportFlags, - savedHaddockFlags = combinedSavedHaddockFlags, - savedTestFlags = combinedSavedTestFlags, - savedBenchmarkFlags = combinedSavedBenchmarkFlags, - savedProjectFlags = combinedSavedProjectFlags, - savedReplMulti = combinedSavedReplMulti - } + a <> b = + SavedConfig + { savedGlobalFlags = combinedSavedGlobalFlags + , savedInitFlags = combinedSavedInitFlags + , savedInstallFlags = combinedSavedInstallFlags + , savedClientInstallFlags = combinedSavedClientInstallFlags + , savedConfigureFlags = combinedSavedConfigureFlags + , savedConfigureExFlags = combinedSavedConfigureExFlags + , savedUserInstallDirs = combinedSavedUserInstallDirs + , savedGlobalInstallDirs = combinedSavedGlobalInstallDirs + , savedUploadFlags = combinedSavedUploadFlags + , savedReportFlags = combinedSavedReportFlags + , savedHaddockFlags = combinedSavedHaddockFlags + , savedTestFlags = combinedSavedTestFlags + , savedBenchmarkFlags = combinedSavedBenchmarkFlags + , savedProjectFlags = combinedSavedProjectFlags + , savedReplMulti = combinedSavedReplMulti + } where -- This is ugly, but necessary. If we're mappending two config files, we -- want the values of the *non-empty* list fields from the second one to @@ -429,79 +453,80 @@ instance Semigroup SavedConfig where where combine = combine' savedClientInstallFlags - combinedSavedConfigureFlags = ConfigFlags { - configArgs = lastNonEmpty configArgs, - configPrograms_ = configPrograms_ . savedConfigureFlags $ b, - -- TODO: NubListify - configProgramPaths = lastNonEmpty configProgramPaths, - -- TODO: NubListify - configProgramArgs = lastNonEmpty configProgramArgs, - configProgramPathExtra = lastNonEmptyNL configProgramPathExtra, - configInstantiateWith = lastNonEmpty configInstantiateWith, - configHcFlavor = combine configHcFlavor, - configHcPath = combine configHcPath, - configHcPkg = combine configHcPkg, - configVanillaLib = combine configVanillaLib, - configProfLib = combine configProfLib, - configProf = combine configProf, - configSharedLib = combine configSharedLib, - configStaticLib = combine configStaticLib, - configDynExe = combine configDynExe, - configFullyStaticExe = combine configFullyStaticExe, - configProfExe = combine configProfExe, - configProfDetail = combine configProfDetail, - configProfLibDetail = combine configProfLibDetail, - -- TODO: NubListify - configConfigureArgs = lastNonEmpty configConfigureArgs, - configOptimization = combine configOptimization, - configDebugInfo = combine configDebugInfo, - configProgPrefix = combine configProgPrefix, - configProgSuffix = combine configProgSuffix, - -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'. - configInstallDirs = - (configInstallDirs . savedConfigureFlags $ a) - `mappend` (configInstallDirs . savedConfigureFlags $ b), - configScratchDir = combine configScratchDir, - -- TODO: NubListify - configExtraLibDirs = lastNonEmpty configExtraLibDirs, - configExtraLibDirsStatic = lastNonEmpty configExtraLibDirsStatic, - -- TODO: NubListify - configExtraFrameworkDirs = lastNonEmpty configExtraFrameworkDirs, - -- TODO: NubListify - configExtraIncludeDirs = lastNonEmpty configExtraIncludeDirs, - 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, - configGHCiLib = combine configGHCiLib, - configSplitSections = combine configSplitSections, - configSplitObjs = combine configSplitObjs, - configStripExes = combine configStripExes, - configStripLibs = combine configStripLibs, - -- TODO: NubListify - configConstraints = lastNonEmpty configConstraints, - -- TODO: NubListify - configDependencies = lastNonEmpty configDependencies, - configPromisedDependencies = lastNonEmpty configPromisedDependencies, - -- TODO: NubListify - configConfigurationsFlags = lastNonMempty configConfigurationsFlags, - configTests = combine configTests, - configBenchmarks = combine configBenchmarks, - configCoverage = combine configCoverage, - configLibCoverage = combine configLibCoverage, - configExactConfiguration = combine configExactConfiguration, - configFlagError = combine configFlagError, - configRelocatable = combine configRelocatable, - configUseResponseFiles = combine configUseResponseFiles, - configDumpBuildInfo = combine configDumpBuildInfo, - configAllowDependingOnPrivateLibs = - combine configAllowDependingOnPrivateLibs - } + combinedSavedConfigureFlags = + ConfigFlags + { configArgs = lastNonEmpty configArgs + , configPrograms_ = configPrograms_ . savedConfigureFlags $ b + , -- TODO: NubListify + configProgramPaths = lastNonEmpty configProgramPaths + , -- TODO: NubListify + configProgramArgs = lastNonEmpty configProgramArgs + , configProgramPathExtra = lastNonEmptyNL configProgramPathExtra + , configInstantiateWith = lastNonEmpty configInstantiateWith + , configHcFlavor = combine configHcFlavor + , configHcPath = combine configHcPath + , configHcPkg = combine configHcPkg + , configVanillaLib = combine configVanillaLib + , configProfLib = combine configProfLib + , configProf = combine configProf + , configSharedLib = combine configSharedLib + , configStaticLib = combine configStaticLib + , configDynExe = combine configDynExe + , configFullyStaticExe = combine configFullyStaticExe + , configProfExe = combine configProfExe + , configProfDetail = combine configProfDetail + , configProfLibDetail = combine configProfLibDetail + , -- TODO: NubListify + configConfigureArgs = lastNonEmpty configConfigureArgs + , configOptimization = combine configOptimization + , configDebugInfo = combine configDebugInfo + , configProgPrefix = combine configProgPrefix + , configProgSuffix = combine configProgSuffix + , -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'. + configInstallDirs = + (configInstallDirs . savedConfigureFlags $ a) + `mappend` (configInstallDirs . savedConfigureFlags $ b) + , configScratchDir = combine configScratchDir + , -- TODO: NubListify + configExtraLibDirs = lastNonEmpty configExtraLibDirs + , configExtraLibDirsStatic = lastNonEmpty configExtraLibDirsStatic + , -- TODO: NubListify + configExtraFrameworkDirs = lastNonEmpty configExtraFrameworkDirs + , -- TODO: NubListify + configExtraIncludeDirs = lastNonEmpty configExtraIncludeDirs + , 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 + , configGHCiLib = combine configGHCiLib + , configSplitSections = combine configSplitSections + , configSplitObjs = combine configSplitObjs + , configStripExes = combine configStripExes + , configStripLibs = combine configStripLibs + , -- TODO: NubListify + configConstraints = lastNonEmpty configConstraints + , -- TODO: NubListify + configDependencies = lastNonEmpty configDependencies + , configPromisedDependencies = lastNonEmpty configPromisedDependencies + , -- TODO: NubListify + configConfigurationsFlags = lastNonMempty configConfigurationsFlags + , configTests = combine configTests + , configBenchmarks = combine configBenchmarks + , configCoverage = combine configCoverage + , configLibCoverage = combine configLibCoverage + , configExactConfiguration = combine configExactConfiguration + , configFlagError = combine configFlagError + , configRelocatable = combine configRelocatable + , configUseResponseFiles = combine configUseResponseFiles + , configDumpBuildInfo = combine configDumpBuildInfo + , configAllowDependingOnPrivateLibs = + combine configAllowDependingOnPrivateLibs + } where combine = combine' savedConfigureFlags lastNonEmpty = lastNonEmpty' savedConfigureFlags @@ -622,11 +647,12 @@ instance Semigroup SavedConfig where combinedSavedReplMulti = combine' savedReplMulti id - combinedSavedProjectFlags = ProjectFlags - { flagProjectDir = combine flagProjectDir - , flagProjectFile = combine flagProjectFile - , flagIgnoreProject = combine flagIgnoreProject - } + combinedSavedProjectFlags = + ProjectFlags + { flagProjectDir = combine flagProjectDir + , flagProjectFile = combine flagProjectFile + , flagIgnoreProject = combine flagIgnoreProject + } where combine = combine' savedProjectFlags @@ -708,10 +734,12 @@ warnOnTwoConfigs verbosity = do xdgCfgExists <- doesFileExist xdgCfg when (dotCabalExists && xdgCfgExists) $ warn verbosity $ - "Both " <> defaultDir <> - " and " <> xdgCfg <> - " exist - ignoring the former.\n" <> - "It is advisable to remove one of them. In that case, we will use the remaining one by default (unless '$CABAL_DIR' is explicitly set)." + "Both " + <> defaultDir + <> " and " + <> xdgCfg + <> " exist - ignoring the former.\n" + <> "It is advisable to remove one of them. In that case, we will use the remaining one by default (unless '$CABAL_DIR' is explicitly set)." -- | If @CABAL\_DIR@ is set, return @Just@ its value. Otherwise, if -- @~/.cabal@ exists and @$XDG_CONFIG_HOME/cabal/config@ does not @@ -1113,24 +1141,27 @@ commentSavedConfig = do -- | All config file fields. configFieldDescriptions :: ConstraintSource -> [FieldDescr SavedConfig] configFieldDescriptions src = - - toSavedConfig liftGlobalFlag - (commandOptions (globalCommand []) ParseArgs) - ["version", "numeric-version", "config-file"] [] - - ++ toSavedConfig liftConfigFlag - (configureOptions ParseArgs) - (["builddir", "constraint", "dependency", "promised-dependency", "ipid"] - ++ map fieldName installDirsFields) - - -- This is only here because viewAsFieldDescr gives us a parser - -- that only recognises 'ghc' etc, the case-sensitive flag names, not - -- what the normal case-insensitive parser gives us. - [simpleFieldParsec "compiler" - (fromFlagOrDefault Disp.empty . fmap pretty) (Flag <$> parsec <|> pure NoFlag) - configHcFlavor (\v flags -> flags { configHcFlavor = v }) - - -- TODO: The following is a temporary fix. The "optimization" + toSavedConfig + liftGlobalFlag + (commandOptions (globalCommand []) ParseArgs) + ["version", "numeric-version", "config-file"] + [] + ++ toSavedConfig + liftConfigFlag + (configureOptions ParseArgs) + ( ["builddir", "constraint", "dependency", "promised-dependency", "ipid"] + ++ map fieldName installDirsFields + ) + -- This is only here because viewAsFieldDescr gives us a parser + -- that only recognises 'ghc' etc, the case-sensitive flag names, not + -- what the normal case-insensitive parser gives us. + [ simpleFieldParsec + "compiler" + (fromFlagOrDefault Disp.empty . fmap pretty) + (Flag <$> parsec <|> pure NoFlag) + configHcFlavor + (\v flags -> flags{configHcFlavor = v}) + , -- TODO: The following is a temporary fix. The "optimization" -- and "debug-info" fields are OptArg, and viewAsFieldDescr -- fails on that. Instead of a hand-written hackaged parser -- and printer, we should handle this case properly in the @@ -1259,6 +1290,11 @@ configFieldDescriptions src = -- share the options or make then distinct. In any case -- they should probably be per-server. + ++ toSavedConfig + liftReplFlag + [multiReplOption] + [] + [] ++ [ viewAsFieldDescr $ optionDistPref (configDistPref . savedConfigureFlags) @@ -1276,65 +1312,6 @@ configFieldDescriptions src = ) ParseArgs ] - - ++ toSavedConfig liftConfigExFlag - (configureExOptions ParseArgs src) - [] - [let pkgs = (Just . AllowOlder . RelaxDepsSome) - `fmap` parsecOptCommaList parsec - parseAllowOlder = ((Just . AllowOlder . toRelaxDeps) - `fmap` parsec) <|> pkgs - in simpleFieldParsec "allow-older" - (showRelaxDeps . fmap unAllowOlder) parseAllowOlder - configAllowOlder (\v flags -> flags { configAllowOlder = v }) - ,let pkgs = (Just . AllowNewer . RelaxDepsSome) - `fmap` parsecOptCommaList parsec - parseAllowNewer = ((Just . AllowNewer . toRelaxDeps) - `fmap` parsec) <|> pkgs - in simpleFieldParsec "allow-newer" - (showRelaxDeps . fmap unAllowNewer) parseAllowNewer - configAllowNewer (\v flags -> flags { configAllowNewer = v }) - ] - - ++ toSavedConfig liftInstallFlag - (installOptions ParseArgs) - ["dry-run", "only", "only-dependencies", "dependencies-only"] [] - - ++ toSavedConfig liftClientInstallFlag - (clientInstallOptions ParseArgs) - [] [] - - ++ toSavedConfig liftUploadFlag - (commandOptions uploadCommand ParseArgs) - ["verbose", "check", "documentation", "publish"] [] - - ++ toSavedConfig liftReportFlag - (commandOptions reportCommand ParseArgs) - ["verbose", "username", "password"] [] - --FIXME: this is a hack, hiding the user name and password. - -- But otherwise it masks the upload ones. Either need to - -- share the options or make then distinct. In any case - -- they should probably be per-server. - - ++ toSavedConfig liftReplFlag - [multiReplOption] - [] [] - - ++ [ viewAsFieldDescr - $ optionDistPref - (configDistPref . savedConfigureFlags) - (\distPref config -> - config - { savedConfigureFlags = (savedConfigureFlags config) { - configDistPref = distPref } - , savedHaddockFlags = (savedHaddockFlags config) { - haddockDistPref = distPref } - } - ) - ParseArgs - ] - - where toSavedConfig lift options exclusions replacements = [ lift (fromMaybe field replacement) @@ -1465,13 +1442,16 @@ liftReportFlag = (\flags conf -> conf{savedReportFlags = flags}) liftReplFlag :: FieldDescr (Flag Bool) -> FieldDescr SavedConfig -liftReplFlag = liftField - savedReplMulti (\flags conf -> conf { savedReplMulti = flags }) - -parseConfig :: ConstraintSource - -> SavedConfig - -> BS.ByteString - -> ParseResult SavedConfig +liftReplFlag = + liftField + savedReplMulti + (\flags conf -> conf{savedReplMulti = flags}) + +parseConfig + :: ConstraintSource + -> SavedConfig + -> BS.ByteString + -> ParseResult SavedConfig parseConfig src initial = \str -> do fields <- readFields str let (knownSections, others) = partition isKnownSection fields diff --git a/cabal-install/src/Distribution/Client/HashValue.hs b/cabal-install/src/Distribution/Client/HashValue.hs index f13086b6180..c245750bb9f 100644 --- a/cabal-install/src/Distribution/Client/HashValue.hs +++ b/cabal-install/src/Distribution/Client/HashValue.hs @@ -1,25 +1,26 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.HashValue ( - HashValue, - hashValue, - truncateHash, - showHashValue, - showHashValueBase64, - readFileHashValue, - hashFromTUF, - ) where +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Client.HashValue + ( HashValue + , hashValue + , truncateHash + , showHashValue + , showHashValueBase64 + , readFileHashValue + , hashFromTUF + ) where import Distribution.Client.Compat.Prelude import Prelude () import qualified Hackage.Security.Client as Sec -import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Base64 as Base64 -import qualified Data.ByteString.Char8 as BS +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import System.IO (IOMode (..), withBinaryFile) diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs index e4b11b16f04..1a8042d6bad 100644 --- a/cabal-install/src/Distribution/Client/InstallPlan.hs +++ b/cabal-install/src/Distribution/Client/InstallPlan.hs @@ -59,15 +59,12 @@ module Distribution.Client.InstallPlan , completed , failed - -- * Display - showPlanGraph, - showInstallPlan, - -- * Display - showPlanGraph, - ShowPlanNode(..), - showInstallPlan, - showInstallPlan_gen, - showPlanPackageTag, + -- * Display + , showPlanGraph + , ShowPlanNode (..) + , showInstallPlan + , showInstallPlan_gen + , showPlanPackageTag -- * Graph-like operations , dependencyClosure @@ -322,30 +319,44 @@ instance indepGoals <- get return $! mkInstallPlan "(instance Binary)" graph indepGoals -data ShowPlanNode = ShowPlanNode { showPlanHerald :: Doc - , showPlanNeighbours :: [Doc] - } +data ShowPlanNode = ShowPlanNode + { showPlanHerald :: Doc + , showPlanNeighbours :: [Doc] + } showPlanGraph :: [ShowPlanNode] -> String -showPlanGraph graph = renderStyle defaultStyle $ +showPlanGraph graph = + renderStyle defaultStyle $ vcat (map dispPlanPackage graph) - where dispPlanPackage (ShowPlanNode herald neighbours) = - hang herald 2 (vcat neighbours) + where + dispPlanPackage (ShowPlanNode herald neighbours) = + hang herald 2 (vcat neighbours) -- | Generic way to show a 'GenericInstallPlan' which elicits quite a lot of information -showInstallPlan_gen :: forall ipkg srcpkg . - (GenericPlanPackage ipkg srcpkg -> ShowPlanNode) -> GenericInstallPlan ipkg srcpkg -> String +showInstallPlan_gen + :: forall ipkg srcpkg + . (GenericPlanPackage ipkg srcpkg -> ShowPlanNode) + -> GenericInstallPlan ipkg srcpkg + -> String showInstallPlan_gen toShow = showPlanGraph . fmap toShow . Foldable.toList . planGraph -showInstallPlan :: forall ipkg srcpkg . (Package ipkg, Package srcpkg, IsUnit ipkg, IsUnit srcpkg) - => GenericInstallPlan ipkg srcpkg -> String +showInstallPlan + :: forall ipkg srcpkg + . (Package ipkg, Package srcpkg, IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg + -> String showInstallPlan = showInstallPlan_gen toShow where toShow :: GenericPlanPackage ipkg srcpkg -> ShowPlanNode - toShow p = ShowPlanNode (hsep [ text (showPlanPackageTag p) - , pretty (packageId p) - , parens (pretty (nodeKey p))]) - (map pretty (nodeNeighbors p)) + toShow p = + ShowPlanNode + ( hsep + [ text (showPlanPackageTag p) + , pretty (packageId p) + , parens (pretty (nodeKey p)) + ] + ) + (map pretty (nodeNeighbors p)) showPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> String showPlanPackageTag (PreExisting _) = "PreExisting" diff --git a/cabal-install/src/Distribution/Client/NixStyleOptions.hs b/cabal-install/src/Distribution/Client/NixStyleOptions.hs index 46e5dcb6f79..5237901bf80 100644 --- a/cabal-install/src/Distribution/Client/NixStyleOptions.hs +++ b/cabal-install/src/Distribution/Client/NixStyleOptions.hs @@ -51,32 +51,58 @@ nixStyleOptions -> ShowOrParseArgs -> [OptionField (NixStyleFlags a)] nixStyleOptions commandOptions showOrParseArgs = - liftOptions configFlags set1 - -- Note: [Hidden Flags] - -- hide "constraint", "dependency", "promised-dependency" and - -- "exact-configuration" from the configure options. - (filter ((`notElem` ["constraint", "dependency", "promised-dependency" - , "exact-configuration"]) - . optionName) $ configureOptions showOrParseArgs) - ++ liftOptions configExFlags set2 (configureExOptions showOrParseArgs - ConstraintSourceCommandlineFlag) - ++ liftOptions installFlags set3 - -- hide "target-package-db" and "symlink-bindir" flags from the - -- install options. - -- "symlink-bindir" is obsoleted by "installdir" in ClientInstallFlags - (filter ((`notElem` ["target-package-db", "symlink-bindir"]) - . optionName) $ - installOptions showOrParseArgs) - ++ liftOptions haddockFlags set4 - -- hide "verbose" and "builddir" flags from the - -- haddock options. - (filter ((`notElem` ["v", "verbose", "builddir"]) - . optionName) $ - haddockOptions showOrParseArgs) - ++ liftOptions testFlags set5 (testOptions showOrParseArgs) - ++ liftOptions benchmarkFlags set6 (benchmarkOptions showOrParseArgs) - ++ liftOptions projectFlags set7 (projectFlagsOptions showOrParseArgs) - ++ liftOptions extraFlags set8 (commandOptions showOrParseArgs) + liftOptions + configFlags + set1 + -- Note: [Hidden Flags] + -- hide "constraint", "dependency", "promised-dependency" and + -- "exact-configuration" from the configure options. + ( filter + ( ( `notElem` + [ "constraint" + , "dependency" + , "promised-dependency" + , "exact-configuration" + ] + ) + . optionName + ) + $ configureOptions showOrParseArgs + ) + ++ liftOptions + configExFlags + set2 + ( configureExOptions + showOrParseArgs + ConstraintSourceCommandlineFlag + ) + ++ liftOptions + installFlags + set3 + -- hide "target-package-db" and "symlink-bindir" flags from the + -- install options. + -- "symlink-bindir" is obsoleted by "installdir" in ClientInstallFlags + ( filter + ( (`notElem` ["target-package-db", "symlink-bindir"]) + . optionName + ) + $ installOptions showOrParseArgs + ) + ++ liftOptions + haddockFlags + set4 + -- hide "verbose" and "builddir" flags from the + -- haddock options. + ( filter + ( (`notElem` ["v", "verbose", "builddir"]) + . optionName + ) + $ haddockOptions showOrParseArgs + ) + ++ liftOptions testFlags set5 (testOptions showOrParseArgs) + ++ liftOptions benchmarkFlags set6 (benchmarkOptions showOrParseArgs) + ++ liftOptions projectFlags set7 (projectFlagsOptions showOrParseArgs) + ++ liftOptions extraFlags set8 (commandOptions showOrParseArgs) where set1 x flags = flags{configFlags = x} set2 x flags = flags{configExFlags = x} diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 7f137276cd3..f915af12712 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -242,8 +242,8 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared = -> IO BuildStatus dryRunTarballPkg pkg depsBuildStatus tarball = case elabBuildStyle pkg of - BuildAndInstall -> return (BuildStatusUnpack tarball) - BuildInplaceOnly {} -> do + BuildAndInstall -> return (BuildStatusUnpack tarball) + BuildInplaceOnly{} -> do -- TODO: [nice to have] use a proper file monitor rather -- than this dir exists test exists <- doesDirectoryExist srcdir @@ -418,20 +418,19 @@ packageFileMonitorKeyValues elab = elab_config :: ElaboratedConfiguredPackage elab_config = - elab { - elabBuildTargets = [], - elabTestTargets = [], - elabBenchTargets = [], - elabReplTarget = [], - elabHaddockTargets = [], - elabBuildHaddocks = False, - - elabTestMachineLog = Nothing, - elabTestHumanLog = Nothing, - elabTestShowDetails = Nothing, - elabTestKeepTix = False, - elabTestTestOptions = [], - elabBenchmarkOptions = [] + elab + { elabBuildTargets = [] + , elabTestTargets = [] + , elabBenchTargets = [] + , elabReplTarget = [] + , elabHaddockTargets = [] + , elabBuildHaddocks = False + , elabTestMachineLog = Nothing + , elabTestHumanLog = Nothing + , elabTestShowDetails = Nothing + , elabTestKeepTix = False + , elabTestTestOptions = [] + , elabBenchmarkOptions = [] } -- The second part is the value used to guard the build step. So this is @@ -670,26 +669,9 @@ rebuildTargets createDirectoryIfMissingVerbose verbosity True distTempDirectory traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse - createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory - createDirectoryIfMissingVerbose verbosity True distTempDirectory - traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse - - -- Before traversing the install plan, preemptively find all packages that - -- will need to be downloaded and start downloading them. - asyncDownloadPackages verbosity withRepoCtx - installPlan pkgsBuildStatus $ \downloadMap -> - - -- For each package in the plan, in dependency order, but in parallel... - InstallPlan.execute jobControl keepGoing - (BuildFailure Nothing . DependentFailed . packageId) - installPlan $ \pkg -> - --TODO: review exception handling - handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ do - - let uid = installedUnitId pkg - pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus - - rebuildTarget + -- Before traversing the install plan, preemptively find all packages that + -- will need to be downloaded and start downloading them. + asyncDownloadPackages verbosity withRepoCtx installPlan @@ -703,22 +685,22 @@ rebuildTargets installPlan $ \pkg -> -- TODO: review exception handling - handle (\(e :: BuildFailure) -> return (Left e)) $ - fmap Right $ - let uid = installedUnitId pkg - pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus - in rebuildTarget - verbosity - distDirLayout - storeDirLayout - buildSettings - downloadMap - registerLock - cacheLock - sharedPackageConfig - installPlan - pkg - pkgBuildStatus + handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ do + let uid = installedUnitId pkg + pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus + + rebuildTarget + verbosity + distDirLayout + storeDirLayout + buildSettings + downloadMap + registerLock + cacheLock + sharedPackageConfig + installPlan + pkg + pkgBuildStatus where isParallelBuild = buildSettingNumJobs >= 2 keepGoing = buildSettingKeepGoing @@ -864,23 +846,25 @@ rebuildTarget (packageId pkg) (elabDistDirParams sharedPackageConfig pkg) (elabBuildStyle pkg) - (elabPkgDescriptionOverride pkg) $ - - case elabBuildStyle pkg of - BuildAndInstall -> buildAndInstall - BuildInplaceOnly {} -> buildInplace buildStatus + (elabPkgDescriptionOverride pkg) + $ case elabBuildStyle pkg of + BuildAndInstall -> buildAndInstall + BuildInplaceOnly{} -> buildInplace buildStatus where buildStatus = BuildStatusConfigure MonitorFirstRun - -- Note that this really is rebuild, not build. It can only happen for - -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages - -- would only start from download or unpack phases. - -- - rebuildPhase :: BuildStatusRebuild -> FilePath -> IO BuildResult - rebuildPhase buildStatus srcdir = - assert (isInplaceBuildStyle $ elabBuildStyle pkg) - - buildInplace buildStatus srcdir builddir + -- Note that this really is rebuild, not build. It can only happen for + -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages + -- would only start from download or unpack phases. + -- + rebuildPhase :: BuildStatusRebuild -> FilePath -> IO BuildResult + rebuildPhase buildStatus srcdir = + assert + (isInplaceBuildStyle $ elabBuildStyle pkg) + buildInplace + buildStatus + srcdir + builddir where builddir = distBuildDirectory @@ -1035,23 +1019,31 @@ withTarballLocalDirectory builddir = srcdir "dist" buildPkg srcdir builddir - -- In this case we make sure the tarball has been unpacked to the - -- appropriate location under the shared dist dir, and then build it - -- inplace there - BuildInplaceOnly {} -> do - let srcrootdir = distUnpackedSrcRootDirectory - srcdir = distUnpackedSrcDirectory pkgid - builddir = distBuildDirectory dparams - -- 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 verbosity tarball srcrootdir - pkgid pkgTextOverride - moveTarballShippedDistDirectory verbosity distDirLayout - srcrootdir pkgid dparams - buildPkg srcdir builddir + -- In this case we make sure the tarball has been unpacked to the + -- appropriate location under the shared dist dir, and then build it + -- inplace there + BuildInplaceOnly{} -> do + let srcrootdir = distUnpackedSrcRootDirectory + srcdir = distUnpackedSrcDirectory pkgid + builddir = distBuildDirectory dparams + -- 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 + verbosity + tarball + srcrootdir + pkgid + pkgTextOverride + moveTarballShippedDistDirectory + verbosity + distDirLayout + srcrootdir + pkgid + dparams + buildPkg srcdir builddir unpackPackageTarball :: Verbosity @@ -1447,8 +1439,12 @@ hasValidHaddockTargets ElaboratedConfiguredPackage{..} | otherwise = any componentHasHaddocks components where components :: [ComponentTarget] - components = elabBuildTargets ++ elabTestTargets ++ elabBenchTargets - ++ elabReplTarget ++ elabHaddockTargets + components = + elabBuildTargets + ++ elabTestTargets + ++ elabBenchTargets + ++ elabReplTarget + ++ elabHaddockTargets componentHasHaddocks :: ComponentTarget -> Bool componentHasHaddocks (ComponentTarget name _) = @@ -1609,11 +1605,20 @@ buildInplaceUnpackedPackage annotateFailureNoLog ReplFailed $ setupInteractive replCommand replFlags replArgs - -- Repl phase - -- - whenRepl $ - annotateFailureNoLog ReplFailed $ - setupInteractive replCommand replFlags replArgs + -- Haddock phase + whenHaddock $ + annotateFailureNoLog HaddocksFailed $ do + setup haddockCommand haddockFlags haddockArgs + let haddockTarget = elabHaddockForHackage pkg + when (haddockTarget == Cabal.ForHackage) $ do + let dest = distDirectory name <.> "tar.gz" + name = haddockDirName haddockTarget (elabPkgDescription pkg) + docDir = + distBuildDirectory distDirLayout dparams + "doc" + "html" + Tar.createTarGzFile dest docDir name + notice verbosity $ "Documentation tarball created: " ++ dest when (buildSettingHaddockOpen && haddockTarget /= Cabal.ForHackage) $ do let dest = docDir "index.html" @@ -1661,12 +1666,12 @@ buildInplaceUnpackedPackage | otherwise = action whenRepl action - | isNothing (elabReplTarget pkg) = return () + | null (elabReplTarget pkg) = return () | otherwise = action - whenRepl action - | null (elabReplTarget pkg) = return () - | otherwise = action + whenHaddock action + | hasValidHaddockTargets pkg = action + | otherwise = return () whenReRegister action = case buildStatus of diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index 672c4cfa85a..ebe9f0ba16a 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} @@ -23,18 +21,18 @@ module Distribution.Client.ProjectConfig , BadProjectRoot -- * Project config files - readProjectConfig, - readGlobalConfig, - readProjectLocalExtraConfig, - readProjectLocalFreezeConfig, - reportParseResult, - showProjectConfig, - withGlobalConfig, - withProjectOrGlobalConfig, - writeProjectLocalExtraConfig, - writeProjectLocalFreezeConfig, - writeProjectConfigFile, - commandLineFlagsToProjectConfig, + , readProjectConfig + , readGlobalConfig + , readProjectLocalExtraConfig + , readProjectLocalFreezeConfig + , reportParseResult + , showProjectConfig + , withGlobalConfig + , withProjectOrGlobalConfig + , writeProjectLocalExtraConfig + , writeProjectLocalFreezeConfig + , writeProjectConfigFile + , commandLineFlagsToProjectConfig -- * Packages within projects , ProjectPackageLocation (..) @@ -588,12 +586,12 @@ instance Show BadProjectRoot where show = renderBadProjectRoot #endif -{- FOURMOLU_DISABLE -} -instance Exception BadProjectRoot where #if MIN_VERSION_base(4,8,0) +instance Exception BadProjectRoot where displayException = renderBadProjectRoot +#else +instance Exception BadProjectRoot #endif -{- FOURMOLU_ENABLE -} renderBadProjectRoot :: BadProjectRoot -> String renderBadProjectRoot = \case @@ -607,13 +605,16 @@ renderBadProjectRoot = \case "The given project directory/file combination '" <> dir file <> "' does not exist." withGlobalConfig - :: Verbosity -- ^ verbosity - -> Flag FilePath -- ^ @--cabal-config@ - -> (ProjectConfig -> IO a) -- ^ with global - -> IO a + :: Verbosity + -- ^ verbosity + -> Flag FilePath + -- ^ @--cabal-config@ + -> (ProjectConfig -> IO a) + -- ^ with global + -> IO a withGlobalConfig verbosity gcf with = do - globalConfig <- runRebuild "" $ readGlobalConfig verbosity gcf - with globalConfig + globalConfig <- runRebuild "" $ readGlobalConfig verbosity gcf + with globalConfig withProjectOrGlobalConfig :: Verbosity @@ -664,19 +665,17 @@ readProjectConfig -> DistDirLayout -> Rebuild ProjectConfigSkeleton readProjectConfig verbosity httpTransport ignoreProjectFlag configFileFlag distDirLayout = do + let defaultProject = + mempty + { projectPackages = ["./"] + } global <- singletonProjectConfigSkeleton <$> readGlobalConfig verbosity configFileFlag local <- readProjectLocalConfigOrDefault verbosity httpTransport distDirLayout freeze <- readProjectLocalFreezeConfig verbosity httpTransport distDirLayout extra <- readProjectLocalExtraConfig verbosity httpTransport distDirLayout if ignoreProjectFlag == Flag True - then return (global <> (singletonProjectConfigSkeleton defaultProject)) + then return (global <> singletonProjectConfigSkeleton defaultProject) else return (global <> local <> freeze <> extra) - where - defaultProject :: ProjectConfig - defaultProject = - mempty - { projectPackages = ["./"] - } -- | Reads an explicit @cabal.project@ file in the given project root dir, -- or returns the default project config for an implicitly defined project. @@ -686,23 +685,20 @@ readProjectLocalConfigOrDefault -> DistDirLayout -> Rebuild ProjectConfigSkeleton readProjectLocalConfigOrDefault verbosity httpTransport distDirLayout = do + let projectFile = distProjectFile distDirLayout "" usesExplicitProjectRoot <- liftIO $ doesFileExist projectFile + let defaultImplicitProjectConfig = + mempty + { -- We expect a package in the current directory. + projectPackages = ["./*.cabal"] + , projectConfigProvenance = Set.singleton Implicit + } if usesExplicitProjectRoot then do readProjectFileSkeleton verbosity httpTransport distDirLayout "" "project file" else do monitorFiles [monitorNonExistentFile projectFile] return (singletonProjectConfigSkeleton defaultImplicitProjectConfig) - where - projectFile :: FilePath - projectFile = distProjectFile distDirLayout "" - defaultImplicitProjectConfig :: ProjectConfig - defaultImplicitProjectConfig = - mempty - { -- We expect a package in the current directory. - projectPackages = ["./*.cabal"] - , projectConfigProvenance = Set.singleton Implicit - } -- | Reads a @cabal.project.local@ file in the given project root dir, -- or returns empty. This file gets written by @cabal configure@, or in @@ -838,12 +834,12 @@ instance Show BadPackageLocations where show = renderBadPackageLocations #endif -{- FOURMOLU_DISABLE -} -instance Exception BadPackageLocations where #if MIN_VERSION_base(4,8,0) +instance Exception BadPackageLocations where displayException = renderBadPackageLocations +#else +instance Exception BadPackageLocations #endif -{- FOURMOLU_ENABLE -} -- TODO: [nice to have] custom exception subclass for Doc rendering, colour etc data BadPackageLocation @@ -1672,12 +1668,12 @@ instance Show BadPerPackageCompilerPaths where show = renderBadPerPackageCompilerPaths #endif -{- FOURMOLU_DISABLE -} -instance Exception BadPerPackageCompilerPaths where #if MIN_VERSION_base(4,8,0) +instance Exception BadPerPackageCompilerPaths where displayException = renderBadPerPackageCompilerPaths +#else +instance Exception BadPerPackageCompilerPaths #endif -{- FOURMOLU_ENABLE -} -- TODO: [nice to have] custom exception subclass for Doc rendering, colour etc renderBadPerPackageCompilerPaths :: BadPerPackageCompilerPaths -> String diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index 99568712563..cf39d2940ee 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -182,10 +182,9 @@ import Network.URI (URI (..), parseURI) import Distribution.Fields.ConfVar (parseConditionConfVarFromClause) import Distribution.Client.HttpUtils +import Distribution.Client.ReplFlags (multiReplOption) import System.Directory (createDirectoryIfMissing) -import Distribution.Client.ReplFlags ( multiReplOption ) - - +import System.FilePath (isAbsolute, isPathSeparator, makeValid, takeDirectory, ()) ------------------------------------------------------------------ -- Handle extended project config files with conditionals and imports. @@ -356,15 +355,16 @@ instance Monoid LegacyPackageConfig where instance Semigroup LegacyPackageConfig where (<>) = gmappend -data LegacySharedConfig = LegacySharedConfig { - legacyGlobalFlags :: GlobalFlags, - legacyConfigureShFlags :: ConfigFlags, - legacyConfigureExFlags :: ConfigExFlags, - legacyInstallFlags :: InstallFlags, - legacyClientInstallFlags:: ClientInstallFlags, - legacyProjectFlags :: ProjectFlags, - legacyMultiRepl :: Flag Bool - } deriving (Show, Generic) +data LegacySharedConfig = LegacySharedConfig + { legacyGlobalFlags :: GlobalFlags + , legacyConfigureShFlags :: ConfigFlags + , legacyConfigureExFlags :: ConfigExFlags + , legacyInstallFlags :: InstallFlags + , legacyClientInstallFlags :: ClientInstallFlags + , legacyProjectFlags :: ProjectFlags + , legacyMultiRepl :: Flag Bool + } + deriving (Show, Generic) instance Monoid LegacySharedConfig where mempty = gmempty @@ -383,22 +383,32 @@ instance Semigroup LegacySharedConfig where -- -- At the moment this uses the legacy command line flag types. See -- 'LegacyProjectConfig' for an explanation. --- -commandLineFlagsToProjectConfig :: GlobalFlags - -> NixStyleFlags a - -> ClientInstallFlags - -> ProjectConfig -commandLineFlagsToProjectConfig globalFlags NixStyleFlags {..} clientInstallFlags = - mempty { - projectConfigBuildOnly = convertLegacyBuildOnlyFlags - globalFlags configFlags - installFlags clientInstallFlags - haddockFlags testFlags benchmarkFlags, - projectConfigShared = convertLegacyAllPackageFlags - globalFlags configFlags - configExFlags installFlags projectFlags NoFlag, - projectConfigLocalPackages = localConfig, - projectConfigAllPackages = allConfig +commandLineFlagsToProjectConfig + :: GlobalFlags + -> NixStyleFlags a + -> ClientInstallFlags + -> ProjectConfig +commandLineFlagsToProjectConfig globalFlags NixStyleFlags{..} clientInstallFlags = + mempty + { projectConfigBuildOnly = + convertLegacyBuildOnlyFlags + globalFlags + configFlags + installFlags + clientInstallFlags + haddockFlags + testFlags + benchmarkFlags + , projectConfigShared = + convertLegacyAllPackageFlags + globalFlags + configFlags + configExFlags + installFlags + projectFlags + NoFlag + , projectConfigLocalPackages = localConfig + , projectConfigAllPackages = allConfig } where (localConfig, allConfig) = @@ -452,48 +462,37 @@ commandLineFlagsToProjectConfig globalFlags NixStyleFlags {..} clientInstallFlag -- configuration that applies to all packages). convertLegacyGlobalConfig :: SavedConfig -> ProjectConfig convertLegacyGlobalConfig - SavedConfig { - savedGlobalFlags = globalFlags, - savedInstallFlags = installFlags, - savedClientInstallFlags= clientInstallFlags, - savedConfigureFlags = configFlags, - savedConfigureExFlags = configExFlags, - savedUserInstallDirs = _, - savedGlobalInstallDirs = _, - savedUploadFlags = _, - savedReportFlags = _, - savedHaddockFlags = haddockFlags, - savedTestFlags = testFlags, - savedBenchmarkFlags = benchmarkFlags, - savedProjectFlags = projectFlags, - savedReplMulti = replMulti + SavedConfig + { savedGlobalFlags = globalFlags + , savedInstallFlags = installFlags + , savedClientInstallFlags = clientInstallFlags + , savedConfigureFlags = configFlags + , savedConfigureExFlags = configExFlags + , savedUserInstallDirs = _ + , savedGlobalInstallDirs = _ + , savedUploadFlags = _ + , savedReportFlags = _ + , savedHaddockFlags = haddockFlags + , savedTestFlags = testFlags + , savedBenchmarkFlags = benchmarkFlags + , savedProjectFlags = projectFlags + , savedReplMulti = replMulti } = - mempty { - projectConfigBuildOnly = configBuildOnly, - projectConfigShared = configShared, - projectConfigAllPackages = configAllPackages - } - where - --TODO: [code cleanup] eliminate use of default*Flags here and specify the - -- defaults in the various resolve functions in terms of the new types. - configExFlags' = defaultConfigExFlags <> configExFlags - installFlags' = defaultInstallFlags <> installFlags - clientInstallFlags' = defaultClientInstallFlags <> clientInstallFlags - haddockFlags' = defaultHaddockFlags <> haddockFlags - testFlags' = defaultTestFlags <> testFlags - benchmarkFlags' = defaultBenchmarkFlags <> benchmarkFlags - projectFlags' = defaultProjectFlags <> projectFlags - - configAllPackages = convertLegacyPerPackageFlags - configFlags installFlags' - haddockFlags' testFlags' benchmarkFlags' - configShared = convertLegacyAllPackageFlags - globalFlags configFlags - configExFlags' installFlags' projectFlags' replMulti - configBuildOnly = convertLegacyBuildOnlyFlags - globalFlags configFlags - installFlags' clientInstallFlags' - haddockFlags' testFlags' benchmarkFlags' + mempty + { projectConfigBuildOnly = configBuildOnly + , projectConfigShared = configShared + , projectConfigAllPackages = configAllPackages + } + where + -- TODO: [code cleanup] eliminate use of default*Flags here and specify the + -- defaults in the various resolve functions in terms of the new types. + configExFlags' = defaultConfigExFlags <> configExFlags + installFlags' = defaultInstallFlags <> installFlags + clientInstallFlags' = defaultClientInstallFlags <> clientInstallFlags + haddockFlags' = defaultHaddockFlags <> haddockFlags + testFlags' = defaultTestFlags <> testFlags + benchmarkFlags' = defaultBenchmarkFlags <> benchmarkFlags + projectFlags' = defaultProjectFlags <> projectFlags configAllPackages = convertLegacyPerPackageFlags @@ -509,6 +508,7 @@ convertLegacyGlobalConfig configExFlags' installFlags' projectFlags' + replMulti configBuildOnly = convertLegacyBuildOnlyFlags globalFlags @@ -524,53 +524,70 @@ convertLegacyGlobalConfig -- approach. convertLegacyProjectConfig :: LegacyProjectConfig -> ProjectConfig convertLegacyProjectConfig - LegacyProjectConfig { - legacyPackages, - legacyPackagesOptional, - legacyPackagesRepo, - legacyPackagesNamed, - legacySharedConfig = LegacySharedConfig globalFlags configShFlags - configExFlags installSharedFlags - clientInstallFlags projectFlags multiRepl, - legacyAllConfig, - legacyLocalConfig = LegacyPackageConfig configFlags installPerPkgFlags - haddockFlags testFlags benchmarkFlags, - legacySpecificConfig - } = - - ProjectConfig { - projectPackages = legacyPackages, - projectPackagesOptional = legacyPackagesOptional, - projectPackagesRepo = legacyPackagesRepo, - projectPackagesNamed = legacyPackagesNamed, - - projectConfigBuildOnly = configBuildOnly, - projectConfigShared = configPackagesShared, - projectConfigProvenance = mempty, - projectConfigAllPackages = configAllPackages, - projectConfigLocalPackages = configLocalPackages, - projectConfigSpecificPackage = fmap perPackage legacySpecificConfig - } - where - configAllPackages = convertLegacyPerPackageFlags g i h t b - where LegacyPackageConfig g i h t b = legacyAllConfig - configLocalPackages = convertLegacyPerPackageFlags - configFlags installPerPkgFlags haddockFlags - testFlags benchmarkFlags - configPackagesShared= convertLegacyAllPackageFlags - globalFlags (configFlags <> configShFlags) - configExFlags installSharedFlags projectFlags multiRepl - configBuildOnly = convertLegacyBuildOnlyFlags - globalFlags configShFlags - installSharedFlags clientInstallFlags - haddockFlags testFlags benchmarkFlags - - perPackage (LegacyPackageConfig perPkgConfigFlags perPkgInstallFlags - perPkgHaddockFlags perPkgTestFlags - perPkgBenchmarkFlags) = - convertLegacyPerPackageFlags - perPkgConfigFlags perPkgInstallFlags perPkgHaddockFlags - perPkgTestFlags perPkgBenchmarkFlags + LegacyProjectConfig + { legacyPackages + , legacyPackagesOptional + , legacyPackagesRepo + , legacyPackagesNamed + , legacySharedConfig = + LegacySharedConfig + globalFlags + configShFlags + configExFlags + installSharedFlags + clientInstallFlags + projectFlags + multiRepl + , legacyAllConfig + , legacyLocalConfig = + LegacyPackageConfig + configFlags + installPerPkgFlags + haddockFlags + testFlags + benchmarkFlags + , legacySpecificConfig + } = + ProjectConfig + { projectPackages = legacyPackages + , projectPackagesOptional = legacyPackagesOptional + , projectPackagesRepo = legacyPackagesRepo + , projectPackagesNamed = legacyPackagesNamed + , projectConfigBuildOnly = configBuildOnly + , projectConfigShared = configPackagesShared + , projectConfigProvenance = mempty + , projectConfigAllPackages = configAllPackages + , projectConfigLocalPackages = configLocalPackages + , projectConfigSpecificPackage = fmap perPackage legacySpecificConfig + } + where + configAllPackages = convertLegacyPerPackageFlags g i h t b + where + LegacyPackageConfig g i h t b = legacyAllConfig + configLocalPackages = + convertLegacyPerPackageFlags + configFlags + installPerPkgFlags + haddockFlags + testFlags + benchmarkFlags + configPackagesShared = + convertLegacyAllPackageFlags + globalFlags + (configFlags <> configShFlags) + configExFlags + installSharedFlags + projectFlags + multiRepl + configBuildOnly = + convertLegacyBuildOnlyFlags + globalFlags + configShFlags + installSharedFlags + clientInstallFlags + haddockFlags + testFlags + benchmarkFlags perPackage ( LegacyPackageConfig @@ -590,15 +607,15 @@ convertLegacyProjectConfig -- | Helper used by other conversion functions that returns the -- 'ProjectConfigShared' subset of the 'ProjectConfig'. convertLegacyAllPackageFlags - :: GlobalFlags - -> ConfigFlags - -> ConfigExFlags - -> InstallFlags - -> ProjectFlags - -> Flag Bool - -> ProjectConfigShared + :: GlobalFlags + -> ConfigFlags + -> ConfigExFlags + -> InstallFlags + -> ProjectFlags + -> Flag Bool + -> ProjectConfigShared convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags projectFlags projectConfigMultiRepl = - ProjectConfigShared{..} + ProjectConfigShared{..} where GlobalFlags { globalConfigFile = projectConfigConfigFile @@ -842,102 +859,12 @@ convertToLegacyProjectConfig convertToLegacySharedConfig :: ProjectConfig -> LegacySharedConfig convertToLegacySharedConfig - ProjectConfig { - projectConfigBuildOnly = ProjectConfigBuildOnly {..}, - projectConfigShared = ProjectConfigShared {..}, - projectConfigAllPackages = PackageConfig { - packageConfigDocumentation - } - } = - - LegacySharedConfig - { legacyGlobalFlags = globalFlags - , legacyConfigureShFlags = configFlags - , legacyConfigureExFlags = configExFlags - , legacyInstallFlags = installFlags - , legacyClientInstallFlags = projectConfigClientInstallFlags - , legacyProjectFlags = projectFlags - , legacyMultiRepl = projectConfigMultiRepl - } - where - globalFlags = GlobalFlags { - globalVersion = mempty, - globalNumericVersion = mempty, - globalConfigFile = projectConfigConfigFile, - globalConstraintsFile = mempty, - globalRemoteRepos = projectConfigRemoteRepos, - globalCacheDir = projectConfigCacheDir, - globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos, - globalActiveRepos = projectConfigActiveRepos, - globalLogsDir = projectConfigLogsDir, - globalIgnoreExpiry = projectConfigIgnoreExpiry, - globalHttpTransport = projectConfigHttpTransport, - globalNix = mempty, - globalStoreDir = projectConfigStoreDir, - globalProgPathExtra = projectConfigProgPathExtra - } - - configFlags = mempty { - configVerbosity = projectConfigVerbosity, - configDistPref = projectConfigDistDir, - configPackageDBs = projectConfigPackageDBs, - configInstallDirs = projectConfigInstallDirs - } - - configExFlags = ConfigExFlags { - configCabalVersion = projectConfigCabalVersion, - configAppend = mempty, - configBackup = mempty, - configExConstraints = projectConfigConstraints, - configPreferences = projectConfigPreferences, - configSolver = projectConfigSolver, - configAllowOlder = projectConfigAllowOlder, - configAllowNewer = projectConfigAllowNewer, - configWriteGhcEnvironmentFilesPolicy - = projectConfigWriteGhcEnvironmentFilesPolicy - } - - installFlags = InstallFlags { - installDocumentation = packageConfigDocumentation, - installHaddockIndex = projectConfigHaddockIndex, - installDest = Flag NoCopyDest, - installDryRun = projectConfigDryRun, - installOnlyDownload = projectConfigOnlyDownload, - installReinstall = mempty, --projectConfigReinstall, - installAvoidReinstalls = mempty, --projectConfigAvoidReinstalls, - installOverrideReinstall = mempty, --projectConfigOverrideReinstall, - installMaxBackjumps = projectConfigMaxBackjumps, - installUpgradeDeps = mempty, --projectConfigUpgradeDeps, - installReorderGoals = projectConfigReorderGoals, - installCountConflicts = projectConfigCountConflicts, - installFineGrainedConflicts = projectConfigFineGrainedConflicts, - installMinimizeConflictSet = projectConfigMinimizeConflictSet, - installIndependentGoals = projectConfigIndependentGoals, - installPreferOldest = projectConfigPreferOldest, - installShadowPkgs = mempty, --projectConfigShadowPkgs, - installStrongFlags = projectConfigStrongFlags, - installAllowBootLibInstalls = projectConfigAllowBootLibInstalls, - installOnlyConstrained = projectConfigOnlyConstrained, - installOnly = mempty, - installOnlyDeps = projectConfigOnlyDeps, - installIndexState = projectConfigIndexState, - installRootCmd = mempty, --no longer supported - installSummaryFile = projectConfigSummaryFile, - installLogFile = projectConfigLogFile, - installBuildReports = projectConfigBuildReports, - installReportPlanningFailure = projectConfigReportPlanningFailure, - installSymlinkBinDir = projectConfigSymlinkBinDir, - installPerComponent = projectConfigPerComponent, - installNumJobs = projectConfigNumJobs, - installKeepGoing = projectConfigKeepGoing, - installRunTests = mempty, - installOfflineMode = projectConfigOfflineMode - } - - projectFlags = ProjectFlags - { flagProjectDir = projectConfigProjectDir - , flagProjectFile = projectConfigProjectFile - , flagIgnoreProject = projectConfigIgnoreProject + ProjectConfig + { projectConfigBuildOnly = ProjectConfigBuildOnly{..} + , projectConfigShared = ProjectConfigShared{..} + , projectConfigAllPackages = + PackageConfig + { packageConfigDocumentation } } = LegacySharedConfig @@ -947,6 +874,7 @@ convertToLegacySharedConfig , legacyInstallFlags = installFlags , legacyClientInstallFlags = projectConfigClientInstallFlags , legacyProjectFlags = projectFlags + , legacyMultiRepl = projectConfigMultiRepl } where globalFlags = @@ -1090,6 +1018,7 @@ convertToLegacyAllPackageConfig , configExtraFrameworkDirs = mempty , configConstraints = mempty , configDependencies = mempty + , configPromisedDependencies = mempty , configExtraIncludeDirs = mempty , configDeterministic = mempty , configIPID = mempty @@ -1108,77 +1037,10 @@ convertToLegacyAllPackageConfig , configAllowDependingOnPrivateLibs = mempty } - LegacyPackageConfig { - legacyConfigureFlags = configFlags, - legacyInstallPkgFlags= mempty, - legacyHaddockFlags = haddockFlags, - legacyTestFlags = mempty, - legacyBenchmarkFlags = mempty - } - where - configFlags = ConfigFlags { - configArgs = mempty, - configPrograms_ = mempty, - configProgramPaths = mempty, - configProgramArgs = mempty, - configProgramPathExtra = mempty, - configHcFlavor = projectConfigHcFlavor, - configHcPath = projectConfigHcPath, - configHcPkg = projectConfigHcPkg, - configInstantiateWith = mempty, - configVanillaLib = mempty, - configProfLib = mempty, - configSharedLib = mempty, - configStaticLib = mempty, - configDynExe = mempty, - configFullyStaticExe = mempty, - configProfExe = mempty, - configProf = mempty, - configProfDetail = mempty, - configProfLibDetail = mempty, - configConfigureArgs = mempty, - configOptimization = mempty, - configProgPrefix = mempty, - configProgSuffix = mempty, - configInstallDirs = projectConfigInstallDirs, - configScratchDir = mempty, - configDistPref = mempty, - configCabalFilePath = mempty, - configVerbosity = mempty, - configUserInstall = mempty, --projectConfigUserInstall, - configPackageDBs = mempty, - configGHCiLib = mempty, - configSplitSections = mempty, - configSplitObjs = mempty, - configStripExes = mempty, - configStripLibs = mempty, - configExtraLibDirs = mempty, - configExtraLibDirsStatic = mempty, - configExtraFrameworkDirs = mempty, - configConstraints = mempty, - configDependencies = mempty, - configPromisedDependencies = mempty, - configExtraIncludeDirs = mempty, - configDeterministic = mempty, - configIPID = mempty, - configCID = mempty, - configConfigurationsFlags = mempty, - configTests = mempty, - configCoverage = mempty, --TODO: don't merge - configLibCoverage = mempty, --TODO: don't merge - configExactConfiguration = mempty, - configBenchmarks = mempty, - configFlagError = mempty, --TODO: ??? - configRelocatable = mempty, - configDebugInfo = mempty, - configUseResponseFiles = mempty, - configDumpBuildInfo = mempty, - configAllowDependingOnPrivateLibs = mempty - } - - haddockFlags = mempty { - haddockKeepTempFiles = projectConfigKeepTempFiles - } + haddockFlags = + mempty + { haddockKeepTempFiles = projectConfigKeepTempFiles + } convertToLegacyPerPackageConfig :: PackageConfig -> LegacyPackageConfig convertToLegacyPerPackageConfig PackageConfig{..} = @@ -1190,65 +1052,66 @@ convertToLegacyPerPackageConfig PackageConfig{..} = , legacyBenchmarkFlags = benchmarkFlags } where - configFlags = ConfigFlags { - configArgs = mempty, - configPrograms_ = configPrograms_ mempty, - configProgramPaths = Map.toList (getMapLast packageConfigProgramPaths), - configProgramArgs = Map.toList (getMapMappend packageConfigProgramArgs), - configProgramPathExtra = packageConfigProgramPathExtra, - configHcFlavor = mempty, - configHcPath = mempty, - configHcPkg = mempty, - configInstantiateWith = mempty, - configVanillaLib = packageConfigVanillaLib, - configProfLib = packageConfigProfLib, - configSharedLib = packageConfigSharedLib, - configStaticLib = packageConfigStaticLib, - configDynExe = packageConfigDynExe, - configFullyStaticExe = packageConfigFullyStaticExe, - configProfExe = packageConfigProfExe, - configProf = packageConfigProf, - configProfDetail = packageConfigProfDetail, - configProfLibDetail = packageConfigProfLibDetail, - configConfigureArgs = packageConfigConfigureArgs, - configOptimization = packageConfigOptimization, - configProgPrefix = packageConfigProgPrefix, - configProgSuffix = packageConfigProgSuffix, - configInstallDirs = mempty, - configScratchDir = mempty, - configDistPref = mempty, - configCabalFilePath = mempty, - configVerbosity = mempty, - configUserInstall = mempty, - configPackageDBs = mempty, - configGHCiLib = packageConfigGHCiLib, - configSplitSections = packageConfigSplitSections, - configSplitObjs = packageConfigSplitObjs, - configStripExes = packageConfigStripExes, - configStripLibs = packageConfigStripLibs, - configExtraLibDirs = packageConfigExtraLibDirs, - configExtraLibDirsStatic = packageConfigExtraLibDirsStatic, - configExtraFrameworkDirs = packageConfigExtraFrameworkDirs, - configConstraints = mempty, - configDependencies = mempty, - configPromisedDependencies = mempty, - configExtraIncludeDirs = packageConfigExtraIncludeDirs, - configIPID = mempty, - configCID = mempty, - configDeterministic = mempty, - configConfigurationsFlags = packageConfigFlagAssignment, - configTests = packageConfigTests, - configCoverage = packageConfigCoverage, --TODO: don't merge - configLibCoverage = packageConfigCoverage, --TODO: don't merge - configExactConfiguration = mempty, - configBenchmarks = packageConfigBenchmarks, - configFlagError = mempty, --TODO: ??? - configRelocatable = packageConfigRelocatable, - configDebugInfo = packageConfigDebugInfo, - configUseResponseFiles = mempty, - configDumpBuildInfo = packageConfigDumpBuildInfo, - configAllowDependingOnPrivateLibs = mempty - } + configFlags = + ConfigFlags + { configArgs = mempty + , configPrograms_ = configPrograms_ mempty + , configProgramPaths = Map.toList (getMapLast packageConfigProgramPaths) + , configProgramArgs = Map.toList (getMapMappend packageConfigProgramArgs) + , configProgramPathExtra = packageConfigProgramPathExtra + , configHcFlavor = mempty + , configHcPath = mempty + , configHcPkg = mempty + , configInstantiateWith = mempty + , configVanillaLib = packageConfigVanillaLib + , configProfLib = packageConfigProfLib + , configSharedLib = packageConfigSharedLib + , configStaticLib = packageConfigStaticLib + , configDynExe = packageConfigDynExe + , configFullyStaticExe = packageConfigFullyStaticExe + , configProfExe = packageConfigProfExe + , configProf = packageConfigProf + , configProfDetail = packageConfigProfDetail + , configProfLibDetail = packageConfigProfLibDetail + , configConfigureArgs = packageConfigConfigureArgs + , configOptimization = packageConfigOptimization + , configProgPrefix = packageConfigProgPrefix + , configProgSuffix = packageConfigProgSuffix + , configInstallDirs = mempty + , configScratchDir = mempty + , configDistPref = mempty + , configCabalFilePath = mempty + , configVerbosity = mempty + , configUserInstall = mempty + , configPackageDBs = mempty + , configGHCiLib = packageConfigGHCiLib + , configSplitSections = packageConfigSplitSections + , configSplitObjs = packageConfigSplitObjs + , configStripExes = packageConfigStripExes + , configStripLibs = packageConfigStripLibs + , configExtraLibDirs = packageConfigExtraLibDirs + , configExtraLibDirsStatic = packageConfigExtraLibDirsStatic + , configExtraFrameworkDirs = packageConfigExtraFrameworkDirs + , configConstraints = mempty + , configDependencies = mempty + , configPromisedDependencies = mempty + , configExtraIncludeDirs = packageConfigExtraIncludeDirs + , configIPID = mempty + , configCID = mempty + , configDeterministic = mempty + , configConfigurationsFlags = packageConfigFlagAssignment + , configTests = packageConfigTests + , configCoverage = packageConfigCoverage -- TODO: don't merge + , configLibCoverage = packageConfigCoverage -- TODO: don't merge + , configExactConfiguration = mempty + , configBenchmarks = packageConfigBenchmarks + , configFlagError = mempty -- TODO: ??? + , configRelocatable = packageConfigRelocatable + , configDebugInfo = packageConfigDebugInfo + , configUseResponseFiles = mempty + , configDumpBuildInfo = packageConfigDumpBuildInfo + , configAllowDependingOnPrivateLibs = mempty + } installFlags = mempty @@ -1429,105 +1292,129 @@ renderPackageLocationToken s ok n (_ : cs) = ok n cs legacySharedConfigFieldDescrs :: ConstraintSource -> [FieldDescr LegacySharedConfig] -legacySharedConfigFieldDescrs constraintSrc = concat - [ liftFields - legacyGlobalFlags - (\flags conf -> conf { legacyGlobalFlags = flags }) - . addFields - [ newLineListField "extra-prog-path-shared-only" - showTokenQ parseTokenQ - (fromNubList . globalProgPathExtra) - (\v conf -> conf { globalProgPathExtra = toNubList v }) - ] - . filterFields - [ "remote-repo-cache" - , "logs-dir", "store-dir", "ignore-expiry", "http-transport" - , "active-repositories" - ] - . commandOptionsToFields - $ commandOptions (globalCommand []) ParseArgs - - , liftFields - legacyConfigureShFlags - (\flags conf -> conf { legacyConfigureShFlags = flags }) - . addFields - [ commaNewLineListFieldParsec "package-dbs" - (Disp.text . showPackageDb) (fmap readPackageDb parsecToken) - configPackageDBs (\v conf -> conf { configPackageDBs = v }) - ] - . filterFields (["verbose", "builddir"] ++ map optionName installDirsOptions) - . commandOptionsToFields - $ configureOptions ParseArgs - - , liftFields - legacyConfigureExFlags - (\flags conf -> conf { legacyConfigureExFlags = flags }) - . addFields - [ commaNewLineListFieldParsec "constraints" - (pretty . fst) (fmap (\constraint -> (constraint, constraintSrc)) parsec) - configExConstraints (\v conf -> conf { configExConstraints = v }) - - , commaNewLineListFieldParsec "preferences" - pretty parsec - configPreferences (\v conf -> conf { configPreferences = v }) - - , monoidFieldParsec "allow-older" - (maybe mempty pretty) (fmap Just parsec) - (fmap unAllowOlder . configAllowOlder) - (\v conf -> conf { configAllowOlder = fmap AllowOlder v }) - - , monoidFieldParsec "allow-newer" - (maybe mempty pretty) (fmap Just parsec) - (fmap unAllowNewer . configAllowNewer) - (\v conf -> conf { configAllowNewer = fmap AllowNewer v }) - ] - . filterFields - [ "cabal-lib-version", "solver", "write-ghc-environment-files" - -- not "constraint" or "preference", we use our own plural ones above - ] - . commandOptionsToFields - $ configureExOptions ParseArgs constraintSrc - - , liftFields - legacyInstallFlags - (\flags conf -> conf { legacyInstallFlags = flags }) - . addFields - [ newLineListField "build-summary" - (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ) - (fromNubList . installSummaryFile) - (\v conf -> conf { installSummaryFile = toNubList v }) - ] - . filterFields - [ "doc-index-file" - , "root-cmd", "symlink-bindir" - , "build-log" - , "remote-build-reporting", "report-planning-failure" - , "jobs", "keep-going", "offline", "per-component" - -- solver flags: - , "max-backjumps", "reorder-goals", "count-conflicts" - , "fine-grained-conflicts" , "minimize-conflict-set", "independent-goals", "prefer-oldest" - , "strong-flags" , "allow-boot-library-installs" - , "reject-unconstrained-dependencies", "index-state" - ] - . commandOptionsToFields - $ installOptions ParseArgs - - , liftFields - legacyClientInstallFlags - (\flags conf -> conf { legacyClientInstallFlags = flags }) - . commandOptionsToFields - $ clientInstallOptions ParseArgs - - , liftFields - legacyProjectFlags - (\flags conf -> conf { legacyProjectFlags = flags }) - . commandOptionsToFields - $ projectFlagsOptions ParseArgs - - , [ liftField legacyMultiRepl (\flags conf -> conf { legacyMultiRepl = flags }) (commandOptionToField multiReplOption) ] - - ] - +legacySharedConfigFieldDescrs constraintSrc = + concat + [ liftFields + legacyGlobalFlags + (\flags conf -> conf{legacyGlobalFlags = flags}) + . addFields + [ newLineListField + "extra-prog-path-shared-only" + showTokenQ + parseTokenQ + (fromNubList . globalProgPathExtra) + (\v conf -> conf{globalProgPathExtra = toNubList v}) + ] + . filterFields + [ "remote-repo-cache" + , "logs-dir" + , "store-dir" + , "ignore-expiry" + , "http-transport" + , "active-repositories" + ] + . commandOptionsToFields + $ commandOptions (globalCommand []) ParseArgs + , liftFields + legacyConfigureShFlags + (\flags conf -> conf{legacyConfigureShFlags = flags}) + . addFields + [ commaNewLineListFieldParsec + "package-dbs" + (Disp.text . showPackageDb) + (fmap readPackageDb parsecToken) + configPackageDBs + (\v conf -> conf{configPackageDBs = v}) + ] + . filterFields (["verbose", "builddir"] ++ map optionName installDirsOptions) + . commandOptionsToFields + $ configureOptions ParseArgs + , liftFields + legacyConfigureExFlags + (\flags conf -> conf{legacyConfigureExFlags = flags}) + . addFields + [ commaNewLineListFieldParsec + "constraints" + (pretty . fst) + (fmap (\constraint -> (constraint, constraintSrc)) parsec) + configExConstraints + (\v conf -> conf{configExConstraints = v}) + , commaNewLineListFieldParsec + "preferences" + pretty + parsec + configPreferences + (\v conf -> conf{configPreferences = v}) + , monoidFieldParsec + "allow-older" + (maybe mempty pretty) + (fmap Just parsec) + (fmap unAllowOlder . configAllowOlder) + (\v conf -> conf{configAllowOlder = fmap AllowOlder v}) + , monoidFieldParsec + "allow-newer" + (maybe mempty pretty) + (fmap Just parsec) + (fmap unAllowNewer . configAllowNewer) + (\v conf -> conf{configAllowNewer = fmap AllowNewer v}) + ] + . filterFields + [ "cabal-lib-version" + , "solver" + , "write-ghc-environment-files" + -- not "constraint" or "preference", we use our own plural ones above + ] + . commandOptionsToFields + $ configureExOptions ParseArgs constraintSrc + , liftFields + legacyInstallFlags + (\flags conf -> conf{legacyInstallFlags = flags}) + . addFields + [ newLineListField + "build-summary" + (showTokenQ . fromPathTemplate) + (fmap toPathTemplate parseTokenQ) + (fromNubList . installSummaryFile) + (\v conf -> conf{installSummaryFile = toNubList v}) + ] + . filterFields + [ "doc-index-file" + , "root-cmd" + , "symlink-bindir" + , "build-log" + , "remote-build-reporting" + , "report-planning-failure" + , "jobs" + , "keep-going" + , "offline" + , "per-component" + , -- solver flags: + "max-backjumps" + , "reorder-goals" + , "count-conflicts" + , "fine-grained-conflicts" + , "minimize-conflict-set" + , "independent-goals" + , "prefer-oldest" + , "strong-flags" + , "allow-boot-library-installs" + , "reject-unconstrained-dependencies" + , "index-state" + ] + . commandOptionsToFields + $ installOptions ParseArgs + , liftFields + legacyClientInstallFlags + (\flags conf -> conf{legacyClientInstallFlags = flags}) + . commandOptionsToFields + $ clientInstallOptions ParseArgs + , liftFields + legacyProjectFlags + (\flags conf -> conf{legacyProjectFlags = flags}) + . commandOptionsToFields + $ projectFlagsOptions ParseArgs + , [liftField legacyMultiRepl (\flags conf -> conf{legacyMultiRepl = flags}) (commandOptionToField multiReplOption)] + ] legacyPackageConfigFieldDescrs :: [FieldDescr LegacyPackageConfig] legacyPackageConfigFieldDescrs = diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs index 52949ab774a..3ae80d86d31 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs @@ -184,49 +184,45 @@ data ProjectConfigShared = ProjectConfigShared -- too much control! -- projectConfigUserInstall :: Flag Bool, - projectConfigInstallDirs :: InstallDirs (Flag PathTemplate), - projectConfigPackageDBs :: [Maybe PackageDB], - - -- configuration used both by the solver and other phases - projectConfigRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers. - projectConfigLocalNoIndexRepos :: NubList LocalRepo, - projectConfigActiveRepos :: Flag ActiveRepos, - projectConfigIndexState :: Flag TotalIndexState, - projectConfigStoreDir :: Flag FilePath, - - -- solver configuration - projectConfigConstraints :: [(UserConstraint, ConstraintSource)], - projectConfigPreferences :: [PackageVersionConstraint], - projectConfigCabalVersion :: Flag Version, --TODO: [required eventually] unused - projectConfigSolver :: Flag PreSolver, - projectConfigAllowOlder :: Maybe AllowOlder, - projectConfigAllowNewer :: Maybe AllowNewer, - projectConfigWriteGhcEnvironmentFilesPolicy - :: Flag WriteGhcEnvironmentFilesPolicy, - projectConfigMaxBackjumps :: Flag Int, - projectConfigReorderGoals :: Flag ReorderGoals, - projectConfigCountConflicts :: Flag CountConflicts, - projectConfigFineGrainedConflicts :: Flag FineGrainedConflicts, - projectConfigMinimizeConflictSet :: Flag MinimizeConflictSet, - projectConfigStrongFlags :: Flag StrongFlags, - projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls, - projectConfigOnlyConstrained :: Flag OnlyConstrained, - projectConfigPerComponent :: Flag Bool, - projectConfigIndependentGoals :: Flag IndependentGoals, - projectConfigPreferOldest :: Flag PreferOldest, - - projectConfigProgPathExtra :: NubList FilePath, - - projectConfigMultiRepl :: Flag Bool - - -- More things that only make sense for manual mode, not --local mode - -- too much control! - --projectConfigShadowPkgs :: Flag Bool, - --projectConfigReinstall :: Flag Bool, - --projectConfigAvoidReinstalls :: Flag Bool, - --projectConfigOverrideReinstall :: Flag Bool, - --projectConfigUpgradeDeps :: Flag Bool - } + projectConfigInstallDirs :: InstallDirs (Flag PathTemplate) + , projectConfigPackageDBs :: [Maybe PackageDB] + , -- configuration used both by the solver and other phases + projectConfigRemoteRepos :: NubList RemoteRepo + -- ^ Available Hackage servers. + , projectConfigLocalNoIndexRepos :: NubList LocalRepo + , projectConfigActiveRepos :: Flag ActiveRepos + , projectConfigIndexState :: Flag TotalIndexState + , projectConfigStoreDir :: Flag FilePath + , -- solver configuration + projectConfigConstraints :: [(UserConstraint, ConstraintSource)] + , projectConfigPreferences :: [PackageVersionConstraint] + , projectConfigCabalVersion :: Flag Version -- TODO: [required eventually] unused + , projectConfigSolver :: Flag PreSolver + , projectConfigAllowOlder :: Maybe AllowOlder + , projectConfigAllowNewer :: Maybe AllowNewer + , projectConfigWriteGhcEnvironmentFilesPolicy + :: Flag WriteGhcEnvironmentFilesPolicy + , projectConfigMaxBackjumps :: Flag Int + , projectConfigReorderGoals :: Flag ReorderGoals + , projectConfigCountConflicts :: Flag CountConflicts + , projectConfigFineGrainedConflicts :: Flag FineGrainedConflicts + , projectConfigMinimizeConflictSet :: Flag MinimizeConflictSet + , projectConfigStrongFlags :: Flag StrongFlags + , projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls + , projectConfigOnlyConstrained :: Flag OnlyConstrained + , projectConfigPerComponent :: Flag Bool + , projectConfigIndependentGoals :: Flag IndependentGoals + , projectConfigPreferOldest :: Flag PreferOldest + , projectConfigProgPathExtra :: NubList FilePath + , projectConfigMultiRepl :: Flag Bool + -- More things that only make sense for manual mode, not --local mode + -- too much control! + -- projectConfigShadowPkgs :: Flag Bool, + -- projectConfigReinstall :: Flag Bool, + -- projectConfigAvoidReinstalls :: Flag Bool, + -- projectConfigOverrideReinstall :: Flag Bool, + -- projectConfigUpgradeDeps :: Flag Bool + } deriving (Eq, Show, Generic) -- | Specifies the provenance of project configuration, whether defaults were diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index 884c0bc1b34..450ac9d7a37 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -983,24 +983,26 @@ printPlan | buildSettingDryRun = "would" | otherwise = "will" - showPkgAndReason :: ElaboratedReadyPackage -> String - showPkgAndReason (ReadyPackage elab) = unwords $ filter (not . null) $ - [ " -" - , if verbosity >= deafening - then prettyShow (installedUnitId elab) - else prettyShow (packageId elab) - , case elabBuildStyle elab of - BuildInplaceOnly InMemory -> "(interactive)" - _ -> "" - , case elabPkgOrComp elab of - ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas (pkgStanzasEnabled pkg)) - ElabComponent comp -> - "(" ++ showComp elab comp ++ ")" - , showFlagAssignment (nonDefaultFlags elab) - , showConfigureFlags elab - , let buildStatus = pkgsBuildStatus Map.! installedUnitId elab - in "(" ++ showBuildStatus buildStatus ++ ")" - ] + showPkgAndReason :: ElaboratedReadyPackage -> String + showPkgAndReason (ReadyPackage elab) = + unwords $ + filter (not . null) $ + [ " -" + , if verbosity >= deafening + then prettyShow (installedUnitId elab) + else prettyShow (packageId elab) + , case elabBuildStyle elab of + BuildInplaceOnly InMemory -> "(interactive)" + _ -> "" + , case elabPkgOrComp elab of + ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas (pkgStanzasEnabled pkg)) + ElabComponent comp -> + "(" ++ showComp elab comp ++ ")" + , showFlagAssignment (nonDefaultFlags elab) + , showConfigureFlags elab + , let buildStatus = pkgsBuildStatus Map.! installedUnitId elab + in "(" ++ showBuildStatus buildStatus ++ ")" + ] showComp :: ElaboratedConfiguredPackage -> ElaboratedComponent -> String showComp elab comp = @@ -1137,26 +1139,14 @@ writeBuildReports settings buildContext plan buildOutcomes = do DocsFailed -> BuildReports.Failed DocsOk -> BuildReports.Ok - Right _br -> BuildReports.InstallOk - - docsOutcome = case result of - Left bf -> case buildFailureReason bf of - HaddocksFailed _ -> BuildReports.Failed - _ -> BuildReports.NotTried - Right br -> case buildResultDocs br of - DocsNotTried -> BuildReports.NotTried - DocsFailed -> BuildReports.Failed - DocsOk -> BuildReports.Ok - - testsOutcome = case result of - Left bf -> case buildFailureReason bf of - TestsFailed _ -> BuildReports.Failed - _ -> BuildReports.NotTried - Right br -> case buildResultTests br of - TestsNotTried -> BuildReports.NotTried - TestsOk -> BuildReports.Ok - - in Just $ (BuildReports.BuildReport (packageId pkg) os arch (compilerId comp) cabalInstallID (elabFlagAssignment pkg) (map (packageId . fst) $ elabLibDependencies pkg) installOutcome docsOutcome testsOutcome, getRepo . elabPkgSourceLocation $ pkg) -- TODO handle failure log files? + testsOutcome = case result of + Left bf -> case buildFailureReason bf of + TestsFailed _ -> BuildReports.Failed + _ -> BuildReports.NotTried + Right br -> case buildResultTests br of + TestsNotTried -> BuildReports.NotTried + TestsOk -> BuildReports.Ok + in Just $ (BuildReports.BuildReport (packageId pkg) os arch (compilerId comp) cabalInstallID (elabFlagAssignment pkg) (map (packageId . fst) $ elabLibDependencies pkg) installOutcome docsOutcome testsOutcome, getRepo . elabPkgSourceLocation $ pkg) -- TODO handle failure log files? fromPlanPackage _ _ = Nothing buildReports = mapMaybe (\x -> fromPlanPackage x (InstallPlan.lookupBuildOutcome x buildOutcomes)) $ InstallPlan.toList plan @@ -1366,9 +1356,10 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes ++ elabPlanPackageName verbosity p2 ++ " and others)" -{- FOURMOLU_DISABLE -} showException e = case fromException e of Just (ExitFailure 1) -> "" + +{- FOURMOLU_DISABLE -} #ifdef MIN_VERSION_unix -- Note [Positive "signal" exit code] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1386,46 +1377,46 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes Just (ExitFailure n) | -n == fromIntegral sigSEGV -> " The build process segfaulted (i.e. SIGSEGV)." - | n == fromIntegral sigSEGV -> - " The build process terminated with exit code " - ++ show n - ++ " which may be because some part of it segfaulted. (i.e. SIGSEGV)." + + | n == fromIntegral sigSEGV -> + " The build process terminated with exit code " ++ show n + ++ " which may be because some part of it segfaulted. (i.e. SIGSEGV)." + | -n == fromIntegral sigKILL -> " The build process was killed (i.e. SIGKILL). " ++ explanation - | n == fromIntegral sigKILL -> - " The build process terminated with exit code " - ++ show n - ++ " which may be because some part of it was killed " - ++ "(i.e. SIGKILL). " - ++ explanation + + | n == fromIntegral sigKILL -> + " The build process terminated with exit code " ++ show n + ++ " which may be because some part of it was killed " + ++ "(i.e. SIGKILL). " ++ explanation where explanation = "The typical reason for this is that there is not " - ++ "enough memory available (e.g. the OS killed a process " - ++ "using lots of memory)." + ++ "enough memory available (e.g. the OS killed a process " + ++ "using lots of memory)." #endif Just (ExitFailure n) -> " The build process terminated with exit code " ++ show n - _ -> - " The exception was:\n " + + _ -> " The exception was:\n " #if MIN_VERSION_base(4,8,0) - ++ displayException e + ++ displayException e #else - ++ show e + ++ show e #endif buildFailureException :: BuildFailureReason -> Maybe SomeException buildFailureException reason = case reason of - DownloadFailed e -> Just e - UnpackFailed e -> Just e + DownloadFailed e -> Just e + UnpackFailed e -> Just e ConfigureFailed e -> Just e - BuildFailed e -> Just e - ReplFailed e -> Just e - HaddocksFailed e -> Just e - TestsFailed e -> Just e - BenchFailed e -> Just e - InstallFailed e -> Just e + BuildFailed e -> Just e + ReplFailed e -> Just e + HaddocksFailed e -> Just e + TestsFailed e -> Just e + BenchFailed e -> Just e + InstallFailed e -> Just e GracefulFailure _ -> Nothing DependentFailed _ -> Nothing {- FOURMOLU_ENABLE -} diff --git a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs index bb4d4066d76..57aa77af891 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs @@ -167,55 +167,65 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = , "id" J..= (jdisplay . installedUnitId) elab , "pkg-name" J..= (jdisplay . pkgName . packageId) elab , "pkg-version" J..= (jdisplay . pkgVersion . packageId) elab - , "flags" J..= J.object [ PD.unFlagName fn J..= v - | (fn,v) <- PD.unFlagAssignment (elabFlagAssignment elab) ] - , "style" J..= J.String (style2str (elabLocalToProject elab) (elabBuildStyle elab)) - , "pkg-src" J..= packageLocationToJ (elabPkgSourceLocation elab) - ] ++ - [ "pkg-cabal-sha256" J..= J.String (showHashValue hash) - | Just hash <- [ fmap hashValue (elabPkgDescriptionOverride elab) ] ] ++ - [ "pkg-src-sha256" J..= J.String (showHashValue hash) - | Just hash <- [elabPkgSourceHash elab] ] ++ - (case elabBuildStyle elab of - BuildInplaceOnly {} -> - ["dist-dir" J..= J.String dist_dir] ++ [buildInfoFileLocation] - BuildAndInstall -> - -- TODO: install dirs? - [] - ) ++ - case elabPkgOrComp elab of - ElabPackage pkg -> - let components = J.object $ - [ comp2str c J..= (J.object $ - [ "depends" J..= map (jdisplay . confInstId) (map fst ldeps) - , "exe-depends" J..= map (jdisplay . confInstId) edeps - ] ++ - bin_file c) - | (c,(ldeps,edeps)) - <- ComponentDeps.toList $ - ComponentDeps.zip (pkgLibDependencies pkg) - (pkgExeDependencies pkg) ] - in ["components" J..= components] - ElabComponent comp -> - ["depends" J..= map (jdisplay . confInstId) (map fst $ elabLibDependencies elab) - ,"exe-depends" J..= map jdisplay (elabExeDependencies elab) - ,"component-name" J..= J.String (comp2str (compSolverName comp)) - ] ++ - bin_file (compSolverName comp) - where - -- | Only add build-info file location if the Setup.hs CLI - -- is recent enough to be able to generate build info files. - -- Otherwise, write 'null'. - -- - -- Consumers of `plan.json` can use the nullability of this file location - -- to indicate that the given component uses `build-type: Custom` - -- with an old lib:Cabal version. - buildInfoFileLocation :: J.Pair - buildInfoFileLocation - | elabSetupScriptCliVersion elab < mkVersion [3, 7, 0, 0] - = "build-info" J..= J.Null - | otherwise - = "build-info" J..= J.String (buildInfoPref dist_dir) + , "flags" + J..= J.object + [ PD.unFlagName fn J..= v + | (fn, v) <- PD.unFlagAssignment (elabFlagAssignment elab) + ] + , "style" J..= J.String (style2str (elabLocalToProject elab) (elabBuildStyle elab)) + , "pkg-src" J..= packageLocationToJ (elabPkgSourceLocation elab) + ] + ++ [ "pkg-cabal-sha256" J..= J.String (showHashValue hash) + | Just hash <- [fmap hashValue (elabPkgDescriptionOverride elab)] + ] + ++ [ "pkg-src-sha256" J..= J.String (showHashValue hash) + | Just hash <- [elabPkgSourceHash elab] + ] + ++ ( case elabBuildStyle elab of + BuildInplaceOnly{} -> + ["dist-dir" J..= J.String dist_dir] ++ [buildInfoFileLocation] + BuildAndInstall -> + -- TODO: install dirs? + [] + ) + ++ case elabPkgOrComp elab of + ElabPackage pkg -> + let components = + J.object $ + [ comp2str c + J..= ( J.object $ + [ "depends" J..= map (jdisplay . confInstId) (map fst ldeps) + , "exe-depends" J..= map (jdisplay . confInstId) edeps + ] + ++ bin_file c + ) + | (c, (ldeps, edeps)) <- + ComponentDeps.toList $ + ComponentDeps.zip + (pkgLibDependencies pkg) + (pkgExeDependencies pkg) + ] + in ["components" J..= components] + ElabComponent comp -> + [ "depends" J..= map (jdisplay . confInstId) (map fst $ elabLibDependencies elab) + , "exe-depends" J..= map jdisplay (elabExeDependencies elab) + , "component-name" J..= J.String (comp2str (compSolverName comp)) + ] + ++ bin_file (compSolverName comp) + where + -- \| Only add build-info file location if the Setup.hs CLI + -- is recent enough to be able to generate build info files. + -- Otherwise, write 'null'. + -- + -- Consumers of `plan.json` can use the nullability of this file location + -- to indicate that the given component uses `build-type: Custom` + -- with an old lib:Cabal version. + buildInfoFileLocation :: J.Pair + buildInfoFileLocation + | elabSetupScriptCliVersion elab < mkVersion [3, 7, 0, 0] = + "build-info" J..= J.Null + | otherwise = + "build-info" J..= J.String (buildInfoPref dist_dir) packageLocationToJ :: PackageLocation (Maybe FilePath) -> J.Value packageLocationToJ pkgloc = @@ -282,36 +292,38 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = distDirLayout (elabDistDirParams elaboratedSharedConfig elab) - bin_file :: ComponentDeps.Component -> [J.Pair] - bin_file c = case c of - ComponentDeps.ComponentExe s -> bin_file' s - ComponentDeps.ComponentTest s -> bin_file' s - ComponentDeps.ComponentBench s -> bin_file' s - ComponentDeps.ComponentFLib s -> flib_file' s - _ -> [] - bin_file' s = - ["bin-file" J..= J.String bin] - where - bin = if isInplaceBuildStyle (elabBuildStyle elab) - then dist_dir "build" prettyShow s prettyShow s <.> exeExtension plat - else InstallDirs.bindir (elabInstallDirs elab) prettyShow s <.> exeExtension plat - - flib_file' :: (Pretty a, Show a) => a -> [J.Pair] - flib_file' s = - ["bin-file" J..= J.String bin] - where - bin = if isInplaceBuildStyle (elabBuildStyle elab) - then dist_dir "build" prettyShow s ("lib" ++ prettyShow s) <.> dllExtension plat - else InstallDirs.bindir (elabInstallDirs elab) ("lib" ++ prettyShow s) <.> dllExtension plat + bin_file :: ComponentDeps.Component -> [J.Pair] + bin_file c = case c of + ComponentDeps.ComponentExe s -> bin_file' s + ComponentDeps.ComponentTest s -> bin_file' s + ComponentDeps.ComponentBench s -> bin_file' s + ComponentDeps.ComponentFLib s -> flib_file' s + _ -> [] + bin_file' s = + ["bin-file" J..= J.String bin] + where + bin = + if isInplaceBuildStyle (elabBuildStyle elab) + then dist_dir "build" prettyShow s prettyShow s <.> exeExtension plat + else InstallDirs.bindir (elabInstallDirs elab) prettyShow s <.> exeExtension plat + + flib_file' :: (Pretty a, Show a) => a -> [J.Pair] + flib_file' s = + ["bin-file" J..= J.String bin] + where + bin = + if isInplaceBuildStyle (elabBuildStyle elab) + then dist_dir "build" prettyShow s ("lib" ++ prettyShow s) <.> dllExtension plat + else InstallDirs.bindir (elabInstallDirs elab) ("lib" ++ prettyShow s) <.> dllExtension plat comp2str :: ComponentDeps.Component -> String comp2str = prettyShow style2str :: Bool -> BuildStyle -> String - style2str True _ = "local" + style2str True _ = "local" style2str False (BuildInplaceOnly OnDisk) = "inplace" style2str False (BuildInplaceOnly InMemory) = "interactive" - style2str False BuildAndInstall = "global" + style2str False BuildAndInstall = "global" jdisplay :: Pretty a => a -> J.Value jdisplay = J.String . prettyShow @@ -621,8 +633,8 @@ postBuildProjectStatus InstallPlan.Installed srcpkg -> elabLibDeps srcpkg ] - elabLibDeps :: ElaboratedConfiguredPackage -> [UnitId] - elabLibDeps = map (newSimpleUnitId . confInstId) . map fst . elabLibDependencies + elabLibDeps :: ElaboratedConfiguredPackage -> [UnitId] + elabLibDeps = map (newSimpleUnitId . confInstId) . map fst . elabLibDependencies -- Was a build was attempted for this package? -- If it doesn't have both a build status and outcome then the answer is no. @@ -659,9 +671,8 @@ postBuildProjectStatus case pkg of InstallPlan.PreExisting _ -> False InstallPlan.Installed _ -> False - InstallPlan.Configured srcpkg -> - elabBuildStyle srcpkg - == BuildInplaceOnly + InstallPlan.Configured srcpkg -> isInplaceBuildStyle (elabBuildStyle srcpkg) + packagesAlreadyInStore :: Set UnitId packagesAlreadyInStore = selectPlanPackageIdSet $ \pkg -> @@ -670,49 +681,15 @@ postBuildProjectStatus InstallPlan.Installed _ -> True InstallPlan.Configured _ -> False - packagesBuildLocal :: Set UnitId - packagesBuildLocal = - selectPlanPackageIdSet $ \pkg -> - case pkg of - InstallPlan.PreExisting _ -> False - InstallPlan.Installed _ -> False - InstallPlan.Configured srcpkg -> elabLocalToProject srcpkg - - packagesBuildInplace :: Set UnitId - packagesBuildInplace = - selectPlanPackageIdSet $ \pkg -> - case pkg of - InstallPlan.PreExisting _ -> False - InstallPlan.Installed _ -> False - InstallPlan.Configured srcpkg -> isInplaceBuildStyle (elabBuildStyle srcpkg) - - packagesAlreadyInStore :: Set UnitId - packagesAlreadyInStore = - selectPlanPackageIdSet $ \pkg -> - case pkg of - InstallPlan.PreExisting _ -> True - InstallPlan.Installed _ -> True - InstallPlan.Configured _ -> False - - selectPlanPackageIdSet - :: (InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage - -> Bool) - -> Set UnitId - selectPlanPackageIdSet p = Map.keysSet - . Map.filter p - $ InstallPlan.toMap plan - - - -updatePostBuildProjectStatus :: Verbosity - -> DistDirLayout - -> ElaboratedInstallPlan - -> BuildStatusMap - -> BuildOutcomes - -> IO PostBuildProjectStatus -updatePostBuildProjectStatus verbosity distDirLayout - elaboratedInstallPlan - pkgsBuildStatus buildOutcomes = do + selectPlanPackageIdSet + :: ( InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage + -> Bool + ) + -> Set UnitId + selectPlanPackageIdSet p = + Map.keysSet + . Map.filter p + $ InstallPlan.toMap plan updatePostBuildProjectStatus :: Verbosity @@ -1024,7 +1001,8 @@ selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan = inplacePackages = [ srcpkg | srcpkg <- sourcePackages - , isInplaceBuildStyle (elabBuildStyle srcpkg) ] + , isInplaceBuildStyle (elabBuildStyle srcpkg) + ] sourcePackages :: [ElaboratedConfiguredPackage] sourcePackages = diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 794c8ff3dca..1d6f1f25fd6 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1,185 +1,204 @@ -{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, RankNTypes #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NoMonoLocalBinds #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoMonoLocalBinds #-} -- | Planning how to build everything in a project. --- -module Distribution.Client.ProjectPlanning ( - -- * elaborated install plan types - ElaboratedInstallPlan, - ElaboratedConfiguredPackage(..), - ElaboratedPlanPackage, - ElaboratedSharedConfig(..), - ElaboratedReadyPackage, - BuildStyle(..), - CabalFileText, +module Distribution.Client.ProjectPlanning + ( -- * elaborated install plan types + ElaboratedInstallPlan + , ElaboratedConfiguredPackage (..) + , ElaboratedPlanPackage + , ElaboratedSharedConfig (..) + , ElaboratedReadyPackage + , BuildStyle (..) + , CabalFileText -- * Producing the elaborated install plan - rebuildProjectConfig, - rebuildInstallPlan, + , rebuildProjectConfig + , rebuildInstallPlan -- * Build targets - availableTargets, - AvailableTarget(..), - AvailableTargetStatus(..), - TargetRequested(..), - ComponentTarget(..), - SubComponentTarget(..), - showComponentTarget, - nubComponentTargets, + , availableTargets + , AvailableTarget (..) + , AvailableTargetStatus (..) + , TargetRequested (..) + , ComponentTarget (..) + , SubComponentTarget (..) + , showComponentTarget + , nubComponentTargets -- * Selecting a plan subset - pruneInstallPlanToTargets, - TargetAction(..), - pruneInstallPlanToDependencies, - CannotPruneDependencies(..), + , pruneInstallPlanToTargets + , TargetAction (..) + , pruneInstallPlanToDependencies + , CannotPruneDependencies (..) -- * Utils required for building - pkgHasEphemeralBuildTargets, - elabBuildTargetWholeComponents, - configureCompiler, + , pkgHasEphemeralBuildTargets + , elabBuildTargetWholeComponents + , configureCompiler -- * Setup.hs CLI flags for building - setupHsScriptOptions, - setupHsConfigureFlags, - setupHsConfigureArgs, - setupHsBuildFlags, - setupHsBuildArgs, - setupHsReplFlags, - setupHsReplArgs, - setupHsTestFlags, - setupHsTestArgs, - setupHsBenchFlags, - setupHsBenchArgs, - setupHsCopyFlags, - setupHsRegisterFlags, - setupHsHaddockFlags, - setupHsHaddockArgs, - - packageHashInputs, + , setupHsScriptOptions + , setupHsConfigureFlags + , setupHsConfigureArgs + , setupHsBuildFlags + , setupHsBuildArgs + , setupHsReplFlags + , setupHsReplArgs + , setupHsTestFlags + , setupHsTestArgs + , setupHsBenchFlags + , setupHsBenchArgs + , setupHsCopyFlags + , setupHsRegisterFlags + , setupHsHaddockFlags + , setupHsHaddockArgs + , packageHashInputs -- * Path construction - binDirectoryFor, - binDirectories, - storePackageInstallDirs, - storePackageInstallDirs' + , binDirectoryFor + , binDirectories + , storePackageInstallDirs + , storePackageInstallDirs' ) where -import Prelude () import Distribution.Client.Compat.Prelude +import Prelude () -import Distribution.Client.HashValue -import Distribution.Client.HttpUtils -import Distribution.Client.ProjectPlanning.Types as Ty -import Distribution.Client.PackageHash -import Distribution.Client.RebuildMonad -import Distribution.Client.Store -import Distribution.Client.ProjectConfig -import Distribution.Client.ProjectConfig.Legacy -import Distribution.Client.ProjectPlanOutput - -import Distribution.Client.Types +import Distribution.Client.HashValue +import Distribution.Client.HttpUtils +import Distribution.Client.PackageHash +import Distribution.Client.ProjectConfig +import Distribution.Client.ProjectConfig.Legacy +import Distribution.Client.ProjectPlanOutput +import Distribution.Client.ProjectPlanning.Types as Ty +import Distribution.Client.RebuildMonad +import Distribution.Client.Store + +import Distribution.Client.Config +import Distribution.Client.Dependency +import Distribution.Client.Dependency.Types +import Distribution.Client.DistDirLayout +import Distribution.Client.FetchUtils +import qualified Distribution.Client.IndexUtils as IndexUtils import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.JobControl +import Distribution.Client.Setup hiding (cabalVersion, packageName) +import Distribution.Client.SetupWrapper import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan -import Distribution.Client.Dependency -import Distribution.Client.Dependency.Types -import qualified Distribution.Client.IndexUtils as IndexUtils -import Distribution.Client.Utils (incVersion) -import Distribution.Client.Targets (userToPackageConstraint) -import Distribution.Client.DistDirLayout -import Distribution.Client.SetupWrapper -import Distribution.Client.JobControl -import Distribution.Client.FetchUtils -import Distribution.Client.Config +import Distribution.Client.Targets (userToPackageConstraint) +import Distribution.Client.Types +import Distribution.Client.Utils (incVersion) +import Distribution.Utils.LogProgress +import Distribution.Utils.MapAccum +import Distribution.Utils.NubList import qualified Hackage.Security.Client as Sec -import Distribution.Client.Setup hiding (packageName, cabalVersion) -import Distribution.Utils.NubList -import Distribution.Utils.LogProgress -import Distribution.Utils.MapAccum import qualified Distribution.Client.BuildReports.Storage as BuildReports - ( storeLocal, fromPlanningFailure ) + ( fromPlanningFailure + , storeLocal + ) +import Distribution.Solver.Types.ComponentDeps (ComponentDeps) import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.ComponentDeps (ComponentDeps) -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PkgConfigDb -import Distribution.Solver.Types.ResolverPackage -import Distribution.Solver.Types.SolverId -import Distribution.Solver.Types.SolverPackage -import Distribution.Solver.Types.InstSolverPackage -import Distribution.Solver.Types.SourcePackage -import Distribution.Solver.Types.Settings - -import Distribution.CabalSpecVersion -import Distribution.ModuleName -import Distribution.Package -import Distribution.Types.AnnotatedId -import Distribution.Types.ComponentName -import Distribution.Types.DumpBuildInfo - ( DumpBuildInfo (..) ) -import Distribution.Types.LibraryName -import Distribution.Types.GivenComponent - ( GivenComponent(GivenComponent) ) -import Distribution.Types.PackageVersionConstraint -import Distribution.Types.PkgconfigDependency -import Distribution.Types.UnqualComponentName -import Distribution.System +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.InstSolverPackage +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PkgConfigDb +import Distribution.Solver.Types.ResolverPackage +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.SourcePackage + +import Distribution.CabalSpecVersion + +-- TODO: [code cleanup] eliminate +-- TODO: [code cleanup] eliminate + +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.ModuleName +import Distribution.Package import qualified Distribution.PackageDescription as Cabal import qualified Distribution.PackageDescription as PD import qualified Distribution.PackageDescription.Configuration as PD -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import Distribution.Simple.Compiler -import qualified Distribution.Simple.GHC as GHC --TODO: [code cleanup] eliminate -import qualified Distribution.Simple.GHCJS as GHCJS --TODO: [code cleanup] eliminate -import Distribution.Simple.Program -import Distribution.Simple.Program.Db -import Distribution.Simple.Program.Find -import qualified Distribution.Simple.Setup as Cabal -import Distribution.Simple.Setup - (Flag(..), toFlag, flagToMaybe, flagToList, fromFlagOrDefault) +import Distribution.Simple.Compiler import qualified Distribution.Simple.Configure as Cabal -import qualified Distribution.Simple.LocalBuildInfo as Cabal -import Distribution.Simple.LocalBuildInfo - ( Component(..), pkgComponents, componentBuildInfo - , componentName ) +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHCJS as GHCJS import qualified Distribution.Simple.InstallDirs as InstallDirs -import qualified Distribution.InstalledPackageInfo as IPI - -import Distribution.Backpack.ConfiguredComponent -import Distribution.Backpack.LinkedComponent -import Distribution.Backpack.ComponentsGraph -import Distribution.Backpack.ModuleShape -import Distribution.Backpack.FullUnitId -import Distribution.Backpack -import Distribution.Types.ComponentInclude - -import Distribution.Simple.Utils -import Distribution.Version - +import Distribution.Simple.LocalBuildInfo + ( Component (..) + , componentBuildInfo + , componentName + , pkgComponents + ) +import qualified Distribution.Simple.LocalBuildInfo as Cabal +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import Distribution.Simple.Program +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Find +import Distribution.Simple.Setup + ( Flag (..) + , flagToList + , flagToMaybe + , fromFlagOrDefault + , toFlag + ) +import qualified Distribution.Simple.Setup as Cabal +import Distribution.System +import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentName +import Distribution.Types.DumpBuildInfo + ( DumpBuildInfo (..) + ) +import Distribution.Types.GivenComponent + ( GivenComponent (GivenComponent) + ) +import Distribution.Types.LibraryName +import Distribution.Types.PackageVersionConstraint +import Distribution.Types.PkgconfigDependency +import Distribution.Types.UnqualComponentName + +import Distribution.Backpack +import Distribution.Backpack.ComponentsGraph +import Distribution.Backpack.ConfiguredComponent +import Distribution.Backpack.FullUnitId +import Distribution.Backpack.LinkedComponent +import Distribution.Backpack.ModuleShape +import Distribution.Types.ComponentInclude + +import Distribution.Simple.Utils +import Distribution.Version + +import Distribution.Compat.Graph (IsNode (..)) import qualified Distribution.Compat.Graph as Graph -import Distribution.Compat.Graph(IsNode(..)) -import Data.Foldable (fold) -import Text.PrettyPrint (text, hang, quotes, colon, vcat, ($$), fsep, punctuate, comma) -import qualified Text.PrettyPrint as Disp +import Control.Exception (assert) +import Control.Monad (forM, sequence) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.State as State (State, execState, runState, state) +import Data.Foldable (fold) +import Data.List (deleteBy, groupBy) +import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Set as Set -import Control.Monad (sequence, forM) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.State as State (State, execState, runState, state) -import Control.Exception (assert) -import Data.List (groupBy, deleteBy) -import qualified Data.List.NonEmpty as NE -import System.FilePath +import System.FilePath +import Text.PrettyPrint (colon, comma, fsep, hang, punctuate, quotes, text, vcat, ($$)) +import qualified Text.PrettyPrint as Disp ------------------------------------------------------------------------------ + -- * Elaborated install plan + ------------------------------------------------------------------------------ -- "Elaborated" -- worked out with great care and nicety of detail; @@ -203,11 +222,15 @@ import System.FilePath -- So that means we need a representation of this fully elaborated install -- plan. The representation consists of two parts: -- + -- * A 'ElaboratedInstallPlan'. This is a 'GenericInstallPlan' with a + -- representation of source packages that includes a lot more detail about -- that package's individual configuration -- + -- * A 'ElaboratedSharedConfig'. Some package configuration is the same for + -- every package in a plan. Rather than duplicate that info every entry in -- the 'GenericInstallPlan' we keep that separately. -- @@ -227,214 +250,242 @@ import System.FilePath -- data ElaboratedConfiguredPackage = ... -- data BuildStyle = - -- | Check that an 'ElaboratedConfiguredPackage' actually makes -- sense under some 'ElaboratedSharedConfig'. sanityCheckElaboratedConfiguredPackage - :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> a - -> a -sanityCheckElaboratedConfiguredPackage _sharedConfig - elab@ElaboratedConfiguredPackage{..} = - (case elabPkgOrComp of + :: ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> a + -> a +sanityCheckElaboratedConfiguredPackage + _sharedConfig + elab@ElaboratedConfiguredPackage{..} = + ( case elabPkgOrComp of ElabPackage pkg -> sanityCheckElaboratedPackage elab pkg - ElabComponent comp -> sanityCheckElaboratedComponent elab comp) - - -- The assertion below fails occasionally for unknown reason - -- so it was muted until we figure it out, otherwise it severely - -- hinders our ability to share and test development builds of cabal-install. - -- Tracking issue: https://github.com/haskell/cabal/issues/6006 - -- - -- either a package is being built inplace, or the - -- 'installedPackageId' we assigned is consistent with - -- the 'hashedInstalledPackageId' we would compute from - -- the elaborated configured package - -- . assert (isInplaceBuildStyle elabBuildStyle || - -- elabComponentId == hashedInstalledPackageId - -- (packageHashInputs sharedConfig elab)) - - -- the stanzas explicitly disabled should not be available - . assert (optStanzaSetNull $ - optStanzaKeysFilteredByValue (maybe False not) elabStanzasRequested `optStanzaSetIntersection` elabStanzasAvailable) - - -- either a package is built inplace, or we are not attempting to - -- build any test suites or benchmarks (we never build these - -- for remote packages!) - . assert (isInplaceBuildStyle elabBuildStyle || - optStanzaSetNull elabStanzasAvailable) + ElabComponent comp -> sanityCheckElaboratedComponent elab comp + ) + -- The assertion below fails occasionally for unknown reason + -- so it was muted until we figure it out, otherwise it severely + -- hinders our ability to share and test development builds of cabal-install. + -- Tracking issue: https://github.com/haskell/cabal/issues/6006 + -- + -- either a package is being built inplace, or the + -- 'installedPackageId' we assigned is consistent with + -- the 'hashedInstalledPackageId' we would compute from + -- the elaborated configured package + -- . assert (isInplaceBuildStyle elabBuildStyle || + -- elabComponentId == hashedInstalledPackageId + -- (packageHashInputs sharedConfig elab)) + + -- the stanzas explicitly disabled should not be available + . assert + ( optStanzaSetNull $ + optStanzaKeysFilteredByValue (maybe False not) elabStanzasRequested `optStanzaSetIntersection` elabStanzasAvailable + ) + -- either a package is built inplace, or we are not attempting to + -- build any test suites or benchmarks (we never build these + -- for remote packages!) + . assert + ( isInplaceBuildStyle elabBuildStyle + || optStanzaSetNull elabStanzasAvailable + ) sanityCheckElaboratedComponent - :: ElaboratedConfiguredPackage - -> ElaboratedComponent - -> a - -> a -sanityCheckElaboratedComponent ElaboratedConfiguredPackage{..} - ElaboratedComponent{..} = - + :: ElaboratedConfiguredPackage + -> ElaboratedComponent + -> a + -> a +sanityCheckElaboratedComponent + ElaboratedConfiguredPackage{..} + ElaboratedComponent{..} = -- Should not be building bench or test if not inplace. - assert (isInplaceBuildStyle elabBuildStyle || - case compComponentName of - Nothing -> True - Just (CLibName _) -> True - Just (CExeName _) -> True - -- This is interesting: there's no way to declare a dependency - -- on a foreign library at the moment, but you may still want - -- to install these to the store - Just (CFLibName _) -> True - Just (CBenchName _) -> False - Just (CTestName _) -> False) - + assert + ( isInplaceBuildStyle elabBuildStyle + || case compComponentName of + Nothing -> True + Just (CLibName _) -> True + Just (CExeName _) -> True + -- This is interesting: there's no way to declare a dependency + -- on a foreign library at the moment, but you may still want + -- to install these to the store + Just (CFLibName _) -> True + Just (CBenchName _) -> False + Just (CTestName _) -> False + ) sanityCheckElaboratedPackage - :: ElaboratedConfiguredPackage - -> ElaboratedPackage - -> a - -> a -sanityCheckElaboratedPackage ElaboratedConfiguredPackage{..} - ElaboratedPackage{..} = + :: ElaboratedConfiguredPackage + -> ElaboratedPackage + -> a + -> a +sanityCheckElaboratedPackage + ElaboratedConfiguredPackage{..} + ElaboratedPackage{..} = -- we should only have enabled stanzas that actually can be built -- (according to the solver) assert (pkgStanzasEnabled `optStanzaSetIsSubset` elabStanzasAvailable) - - -- the stanzas that the user explicitly requested should be - -- enabled (by the previous test, they are also available) - . assert (optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested - `optStanzaSetIsSubset` pkgStanzasEnabled) + -- the stanzas that the user explicitly requested should be + -- enabled (by the previous test, they are also available) + . assert + ( optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested + `optStanzaSetIsSubset` pkgStanzasEnabled + ) ------------------------------------------------------------------------------ + -- * Deciding what to do: making an 'ElaboratedInstallPlan' + ------------------------------------------------------------------------------ -- | Return the up-to-date project config and information about the local -- packages within the project. --- -rebuildProjectConfig :: Verbosity - -> HttpTransport - -> DistDirLayout - -> ProjectConfig - -> IO ( ProjectConfig - , [PackageSpecifier UnresolvedSourcePackage] ) -rebuildProjectConfig verbosity - httpTransport - distDirLayout@DistDirLayout { - distProjectRootDirectory, - distDirectory, - distProjectCacheFile, - distProjectCacheDirectory, - distProjectFile - } - cliConfig = do - +rebuildProjectConfig + :: Verbosity + -> HttpTransport + -> DistDirLayout + -> ProjectConfig + -> IO + ( ProjectConfig + , [PackageSpecifier UnresolvedSourcePackage] + ) +rebuildProjectConfig + verbosity + httpTransport + distDirLayout@DistDirLayout + { distProjectRootDirectory + , distDirectory + , distProjectCacheFile + , distProjectCacheDirectory + , distProjectFile + } + cliConfig = do progsearchpath <- liftIO $ getSystemSearchPath let fileMonitorProjectConfig = newFileMonitor (distProjectCacheFile "config") fileMonitorProjectConfigKey <- do configPath <- getConfigFilePath projectConfigConfigFile - return (configPath, distProjectFile "", - (projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg), - progsearchpath, - packageConfigProgramPaths, - packageConfigProgramPathExtra) + return + ( configPath + , distProjectFile "" + , (projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg) + , progsearchpath + , packageConfigProgramPaths + , packageConfigProgramPathExtra + ) (projectConfig, localPackages) <- runRebuild distProjectRootDirectory - $ rerunIfChanged verbosity - fileMonitorProjectConfig - fileMonitorProjectConfigKey -- todo check deps too? - $ do + $ rerunIfChanged + verbosity + fileMonitorProjectConfig + fileMonitorProjectConfigKey -- todo check deps too? + $ do liftIO $ info verbosity "Project settings changed, reconfiguring..." projectConfigSkeleton <- phaseReadProjectConfig let fetchCompiler = do - -- have to create the cache directory before configuring the compiler - liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory - (compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout ((fst $ PD.ignoreConditions projectConfigSkeleton) <> cliConfig) - pure (os, arch, compilerInfo compiler) + -- have to create the cache directory before configuring the compiler + liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory + (compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout ((fst $ PD.ignoreConditions projectConfigSkeleton) <> cliConfig) + pure (os, arch, compilerInfo compiler) projectConfig <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectConfigSkeleton localPackages <- phaseReadLocalPackages (projectConfig <> cliConfig) return (projectConfig, localPackages) - info verbosity - $ unlines - $ ("this build was affected by the following (project) config files:" :) - $ [ "- " ++ path - | Explicit path <- Set.toList $ projectConfigProvenance projectConfig - ] + info verbosity $ + unlines $ + ("this build was affected by the following (project) config files:" :) $ + [ "- " ++ path + | Explicit path <- Set.toList $ projectConfigProvenance projectConfig + ] return (projectConfig <> cliConfig, localPackages) + where + ProjectConfigShared{projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg, projectConfigIgnoreProject, projectConfigConfigFile} = + projectConfigShared cliConfig - where - - ProjectConfigShared { projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg, projectConfigIgnoreProject, projectConfigConfigFile } = - projectConfigShared cliConfig + PackageConfig{packageConfigProgramPaths, packageConfigProgramPathExtra} = + projectConfigLocalPackages cliConfig - PackageConfig { packageConfigProgramPaths, packageConfigProgramPathExtra } = - projectConfigLocalPackages cliConfig + -- Read the cabal.project (or implicit config) and combine it with + -- arguments from the command line + -- + phaseReadProjectConfig :: Rebuild ProjectConfigSkeleton + phaseReadProjectConfig = do + readProjectConfig verbosity httpTransport projectConfigIgnoreProject projectConfigConfigFile distDirLayout - -- Read the cabal.project (or implicit config) and combine it with - -- arguments from the command line - -- - phaseReadProjectConfig :: Rebuild ProjectConfigSkeleton - phaseReadProjectConfig = do - readProjectConfig verbosity httpTransport projectConfigIgnoreProject projectConfigConfigFile distDirLayout + -- Look for all the cabal packages in the project + -- some of which may be local src dirs, tarballs etc + -- + phaseReadLocalPackages + :: ProjectConfig + -> Rebuild [PackageSpecifier UnresolvedSourcePackage] + phaseReadLocalPackages + projectConfig@ProjectConfig + { projectConfigShared + , projectConfigBuildOnly + } = do + pkgLocations <- findProjectPackages distDirLayout projectConfig + -- Create folder only if findProjectPackages did not throw a + -- BadPackageLocations exception. + liftIO $ do + createDirectoryIfMissingVerbose verbosity True distDirectory + createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory + + fetchAndReadSourcePackages + verbosity + distDirLayout + projectConfigShared + projectConfigBuildOnly + pkgLocations + +configureCompiler + :: Verbosity + -> DistDirLayout + -> ProjectConfig + -> Rebuild (Compiler, Platform, ProgramDb) +configureCompiler + verbosity + DistDirLayout + { distProjectCacheFile + } + ProjectConfig + { projectConfigShared = + ProjectConfigShared + { projectConfigHcFlavor + , projectConfigHcPath + , projectConfigHcPkg + } + , projectConfigLocalPackages = + PackageConfig + { packageConfigProgramPaths + , packageConfigProgramPathExtra + } + } = do + let fileMonitorCompiler = newFileMonitor . distProjectCacheFile $ "compiler" - -- Look for all the cabal packages in the project - -- some of which may be local src dirs, tarballs etc - -- - phaseReadLocalPackages :: ProjectConfig - -> Rebuild [PackageSpecifier UnresolvedSourcePackage] - phaseReadLocalPackages projectConfig@ProjectConfig { - projectConfigShared, - projectConfigBuildOnly - } = do - - pkgLocations <- findProjectPackages distDirLayout projectConfig - -- Create folder only if findProjectPackages did not throw a - -- BadPackageLocations exception. - liftIO $ do - createDirectoryIfMissingVerbose verbosity True distDirectory - createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory - - fetchAndReadSourcePackages verbosity distDirLayout - projectConfigShared - projectConfigBuildOnly - pkgLocations - - -configureCompiler :: Verbosity -> - DistDirLayout -> - ProjectConfig -> - Rebuild (Compiler, Platform, ProgramDb) -configureCompiler verbosity - DistDirLayout { - distProjectCacheFile - } - ProjectConfig { - projectConfigShared = ProjectConfigShared { - projectConfigHcFlavor, - projectConfigHcPath, - projectConfigHcPkg - }, - projectConfigLocalPackages = PackageConfig { - packageConfigProgramPaths, - packageConfigProgramPathExtra - } - } = do - let fileMonitorCompiler = newFileMonitor . distProjectCacheFile $ "compiler" - - progsearchpath <- liftIO $ getSystemSearchPath - rerunIfChanged verbosity fileMonitorCompiler - (hcFlavor, hcPath, hcPkg, progsearchpath, - packageConfigProgramPaths, - packageConfigProgramPathExtra) $ do - - liftIO $ info verbosity "Compiler settings changed, reconfiguring..." - result@(_, _, progdb') <- liftIO $ + progsearchpath <- liftIO $ getSystemSearchPath + rerunIfChanged + verbosity + fileMonitorCompiler + ( hcFlavor + , hcPath + , hcPkg + , progsearchpath + , packageConfigProgramPaths + , packageConfigProgramPathExtra + ) + $ do + liftIO $ info verbosity "Compiler settings changed, reconfiguring..." + result@(_, _, progdb') <- + liftIO $ Cabal.configCompilerEx - hcFlavor hcPath hcPkg - progdb verbosity + hcFlavor + hcPath + hcPkg + progdb + verbosity -- Note that we added the user-supplied program locations and args -- for /all/ programs, not just those for the compiler prog and @@ -442,21 +493,23 @@ configureCompiler verbosity -- the compiler will configure (and it does vary between compilers). -- We do know however that the compiler will only configure the -- programs it cares about, and those are the ones we monitor here. - monitorFiles (programsMonitorFiles progdb') + monitorFiles (programsMonitorFiles progdb') - return result - where - hcFlavor = flagToMaybe projectConfigHcFlavor - hcPath = flagToMaybe projectConfigHcPath - hcPkg = flagToMaybe projectConfigHcPkg - progdb = - userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) + return result + where + hcFlavor = flagToMaybe projectConfigHcFlavor + hcPath = flagToMaybe projectConfigHcPath + hcPkg = flagToMaybe projectConfigHcPkg + progdb = + userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) . modifyProgramSearchPath - ([ ProgramSearchPathDir dir - | dir <- fromNubList packageConfigProgramPathExtra ] ++) + ( [ ProgramSearchPathDir dir + | dir <- fromNubList packageConfigProgramPathExtra + ] + ++ + ) $ defaultProgramDb - -- | Return an up-to-date elaborated install plan. -- -- Two variants of the install plan are returned: with and without packages @@ -470,233 +523,295 @@ configureCompiler verbosity -- command needs the source package info to know about flag choices and -- dependencies of executables and setup scripts. -- -rebuildInstallPlan :: Verbosity - -> DistDirLayout -> CabalDirLayout - -> ProjectConfig - -> [PackageSpecifier UnresolvedSourcePackage] - -> Maybe InstalledPackageIndex - -> IO ( ElaboratedInstallPlan -- with store packages - , ElaboratedInstallPlan -- with source packages - , ElaboratedSharedConfig - , IndexUtils.TotalIndexState - , IndexUtils.ActiveRepos - ) - -- ^ @(improvedPlan, elaboratedPlan, _, _, _)@ -rebuildInstallPlan verbosity - distDirLayout@DistDirLayout { - distProjectRootDirectory, - distProjectCacheFile - } - CabalDirLayout { - cabalStoreDirLayout - } = \projectConfig localPackages mbInstalledPackages -> +rebuildInstallPlan + :: Verbosity + -> DistDirLayout + -> CabalDirLayout + -> ProjectConfig + -> [PackageSpecifier UnresolvedSourcePackage] + -> Maybe InstalledPackageIndex + -> IO + ( ElaboratedInstallPlan -- with store packages + , ElaboratedInstallPlan -- with source packages + , ElaboratedSharedConfig + , IndexUtils.TotalIndexState + , IndexUtils.ActiveRepos + ) + -- ^ @(improvedPlan, elaboratedPlan, _, _, _)@ +rebuildInstallPlan + verbosity + distDirLayout@DistDirLayout + { distProjectRootDirectory + , distProjectCacheFile + } + CabalDirLayout + { cabalStoreDirLayout + } = \projectConfig localPackages mbInstalledPackages -> runRebuild distProjectRootDirectory $ do - progsearchpath <- liftIO $ getSystemSearchPath - let projectConfigMonitored = projectConfig { projectConfigBuildOnly = mempty } - - -- The overall improved plan is cached - rerunIfChanged verbosity fileMonitorImprovedPlan - -- react to changes in the project config, - -- the package .cabal files and the path - (projectConfigMonitored, localPackages, progsearchpath) $ do - - -- And so is the elaborated plan that the improved plan based on - (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) <- - rerunIfChanged verbosity fileMonitorElaboratedPlan - (projectConfigMonitored, localPackages, - progsearchpath) $ do - - compilerEtc <- phaseConfigureCompiler projectConfig - _ <- phaseConfigurePrograms projectConfig compilerEtc - (solverPlan, pkgConfigDB, totalIndexState, activeRepos) - <- phaseRunSolver projectConfig - compilerEtc - localPackages - (fromMaybe mempty mbInstalledPackages) - (elaboratedPlan, - elaboratedShared) <- phaseElaboratePlan projectConfig - compilerEtc pkgConfigDB - solverPlan - localPackages - - phaseMaintainPlanOutputs elaboratedPlan elaboratedShared - return (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) - - -- The improved plan changes each time we install something, whereas - -- the underlying elaborated plan only changes when input config - -- changes, so it's worth caching them separately. - improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared - - return (improvedPlan, elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) - - where - fileMonitorSolverPlan = newFileMonitorInCacheDir "solver-plan" - fileMonitorSourceHashes = newFileMonitorInCacheDir "source-hashes" - fileMonitorElaboratedPlan = newFileMonitorInCacheDir "elaborated-plan" - fileMonitorImprovedPlan = newFileMonitorInCacheDir "improved-plan" - - newFileMonitorInCacheDir :: Eq a => FilePath -> FileMonitor a b - newFileMonitorInCacheDir = newFileMonitor . distProjectCacheFile + progsearchpath <- liftIO $ getSystemSearchPath + let projectConfigMonitored = projectConfig{projectConfigBuildOnly = mempty} + + -- The overall improved plan is cached + rerunIfChanged + verbosity + fileMonitorImprovedPlan + -- react to changes in the project config, + -- the package .cabal files and the path + (projectConfigMonitored, localPackages, progsearchpath) + $ do + -- And so is the elaborated plan that the improved plan based on + (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) <- + rerunIfChanged + verbosity + fileMonitorElaboratedPlan + ( projectConfigMonitored + , localPackages + , progsearchpath + ) + $ do + compilerEtc <- phaseConfigureCompiler projectConfig + _ <- phaseConfigurePrograms projectConfig compilerEtc + (solverPlan, pkgConfigDB, totalIndexState, activeRepos) <- + phaseRunSolver + projectConfig + compilerEtc + localPackages + (fromMaybe mempty mbInstalledPackages) + ( elaboratedPlan + , elaboratedShared + ) <- + phaseElaboratePlan + projectConfig + compilerEtc + pkgConfigDB + solverPlan + localPackages + + phaseMaintainPlanOutputs elaboratedPlan elaboratedShared + return (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) + + -- The improved plan changes each time we install something, whereas + -- the underlying elaborated plan only changes when input config + -- changes, so it's worth caching them separately. + improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared + + return (improvedPlan, elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) + where + fileMonitorSolverPlan = newFileMonitorInCacheDir "solver-plan" + fileMonitorSourceHashes = newFileMonitorInCacheDir "source-hashes" + fileMonitorElaboratedPlan = newFileMonitorInCacheDir "elaborated-plan" + fileMonitorImprovedPlan = newFileMonitorInCacheDir "improved-plan" + newFileMonitorInCacheDir :: Eq a => FilePath -> FileMonitor a b + newFileMonitorInCacheDir = newFileMonitor . distProjectCacheFile - -- Configure the compiler we're using. - -- - -- This is moderately expensive and doesn't change that often so we cache - -- it independently. - -- - phaseConfigureCompiler :: ProjectConfig - -> Rebuild (Compiler, Platform, ProgramDb) - phaseConfigureCompiler = configureCompiler verbosity distDirLayout + -- Configure the compiler we're using. + -- + -- This is moderately expensive and doesn't change that often so we cache + -- it independently. + -- + phaseConfigureCompiler + :: ProjectConfig + -> Rebuild (Compiler, Platform, ProgramDb) + phaseConfigureCompiler = configureCompiler verbosity distDirLayout - -- Configuring other programs. - -- - -- Having configred the compiler, now we configure all the remaining - -- programs. This is to check we can find them, and to monitor them for - -- changes. - -- - -- TODO: [required eventually] we don't actually do this yet. - -- - -- We rely on the fact that the previous phase added the program config for - -- all local packages, but that all the programs configured so far are the - -- compiler program or related util programs. - -- - phaseConfigurePrograms :: ProjectConfig - -> (Compiler, Platform, ProgramDb) - -> Rebuild () - phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = do + -- Configuring other programs. + -- + -- Having configred the compiler, now we configure all the remaining + -- programs. This is to check we can find them, and to monitor them for + -- changes. + -- + -- TODO: [required eventually] we don't actually do this yet. + -- + -- We rely on the fact that the previous phase added the program config for + -- all local packages, but that all the programs configured so far are the + -- compiler program or related util programs. + -- + phaseConfigurePrograms + :: ProjectConfig + -> (Compiler, Platform, ProgramDb) + -> Rebuild () + phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = do -- Users are allowed to specify program locations independently for -- each package (e.g. to use a particular version of a pre-processor -- for some packages). However they cannot do this for the compiler -- itself as that's just not going to work. So we check for this. - liftIO $ checkBadPerPackageCompilerPaths - (configuredPrograms compilerprogdb) - (getMapMappend (projectConfigSpecificPackage projectConfig)) - - --TODO: [required eventually] find/configure other programs that the - -- user specifies. + liftIO $ + checkBadPerPackageCompilerPaths + (configuredPrograms compilerprogdb) + (getMapMappend (projectConfigSpecificPackage projectConfig)) - --TODO: [required eventually] find/configure all build-tools - -- but note that some of them may be built as part of the plan. + -- TODO: [required eventually] find/configure other programs that the + -- user specifies. + -- TODO: [required eventually] find/configure all build-tools + -- but note that some of them may be built as part of the plan. - -- Run the solver to get the initial install plan. - -- This is expensive so we cache it independently. - -- - phaseRunSolver + -- Run the solver to get the initial install plan. + -- This is expensive so we cache it independently. + -- + phaseRunSolver :: ProjectConfig -> (Compiler, Platform, ProgramDb) -> [PackageSpecifier UnresolvedSourcePackage] -> InstalledPackageIndex -> Rebuild (SolverInstallPlan, PkgConfigDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos) - phaseRunSolver projectConfig@ProjectConfig { - projectConfigShared, - projectConfigBuildOnly - } - (compiler, platform, progdb) - localPackages - installedPackages = - rerunIfChanged verbosity fileMonitorSolverPlan - (solverSettings, - localPackages, localPackagesEnabledStanzas, - compiler, platform, programDbSignature progdb) $ do - - installedPkgIndex <- getInstalledPackages verbosity - compiler progdb platform - corePackageDbs - (sourcePkgDb, tis, ar) <- getSourcePackages verbosity withRepoCtx - (solverSettingIndexState solverSettings) - (solverSettingActiveRepos solverSettings) - pkgConfigDB <- getPkgConfigDb verbosity progdb - - --TODO: [code cleanup] it'd be better if the Compiler contained the - -- ConfiguredPrograms that it needs, rather than relying on the progdb - -- since we don't need to depend on all the programs here, just the - -- ones relevant for the compiler. - - liftIO $ do - solver <- chooseSolver verbosity - (solverSettingSolver solverSettings) - (compilerInfo compiler) - - notice verbosity "Resolving dependencies..." - planOrError <- foldProgress logMsg (pure . Left) (pure . Right) $ - planPackages verbosity compiler platform solver solverSettings - (installedPackages <> installedPkgIndex) sourcePkgDb pkgConfigDB - localPackages localPackagesEnabledStanzas - case planOrError of - Left msg -> do reportPlanningFailure projectConfig compiler platform localPackages - die' verbosity msg - Right plan -> return (plan, pkgConfigDB, tis, ar) - where - corePackageDbs :: [PackageDB] - corePackageDbs = applyPackageDbFlags [GlobalPackageDB] - (projectConfigPackageDBs projectConfigShared) - - withRepoCtx = projectConfigWithSolverRepoContext verbosity - projectConfigShared - projectConfigBuildOnly - solverSettings = resolveSolverSettings projectConfig - logMsg message rest = debugNoWrap verbosity message >> rest - - localPackagesEnabledStanzas = - Map.fromList - [ (pkgname, stanzas) - | pkg <- localPackages - -- TODO: misnomer: we should separate - -- builtin/global/inplace/local packages - -- and packages explicitly mentioned in the project - -- - , let pkgname = pkgSpecifierTarget pkg - testsEnabled = lookupLocalPackageConfig - packageConfigTests - projectConfig pkgname - benchmarksEnabled = lookupLocalPackageConfig - packageConfigBenchmarks - projectConfig pkgname - isLocal = isJust (shouldBeLocal pkg) - stanzas - | isLocal = Map.fromList $ - [ (TestStanzas, enabled) - | enabled <- flagToList testsEnabled ] ++ - [ (BenchStanzas , enabled) - | enabled <- flagToList benchmarksEnabled ] - | otherwise = Map.fromList [(TestStanzas, False), (BenchStanzas, False) ] - ] - - -- Elaborate the solver's install plan to get a fully detailed plan. This - -- version of the plan has the final nix-style hashed ids. - -- - phaseElaboratePlan :: ProjectConfig - -> (Compiler, Platform, ProgramDb) - -> PkgConfigDb - -> SolverInstallPlan - -> [PackageSpecifier (SourcePackage (PackageLocation loc))] - -> Rebuild ( ElaboratedInstallPlan - , ElaboratedSharedConfig ) - phaseElaboratePlan ProjectConfig { - projectConfigShared, - projectConfigAllPackages, - projectConfigLocalPackages, - projectConfigSpecificPackage, - projectConfigBuildOnly - } - (compiler, platform, progdb) pkgConfigDB - solverPlan localPackages = do - - liftIO $ debug verbosity "Elaborating the install plan..." - - sourcePackageHashes <- - rerunIfChanged verbosity fileMonitorSourceHashes - (packageLocationsSignature solverPlan) $ - getPackageSourceHashes verbosity withRepoCtx solverPlan - - defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler - let installDirs = fmap Cabal.fromFlag $ (fmap Flag defaultInstallDirs) <> (projectConfigInstallDirs projectConfigShared) - (elaboratedPlan, elaboratedShared) - <- liftIO . runLogProgress verbosity $ + phaseRunSolver + projectConfig@ProjectConfig + { projectConfigShared + , projectConfigBuildOnly + } + (compiler, platform, progdb) + localPackages + installedPackages = + rerunIfChanged + verbosity + fileMonitorSolverPlan + ( solverSettings + , localPackages + , localPackagesEnabledStanzas + , compiler + , platform + , programDbSignature progdb + ) + $ do + installedPkgIndex <- + getInstalledPackages + verbosity + compiler + progdb + platform + corePackageDbs + (sourcePkgDb, tis, ar) <- + getSourcePackages + verbosity + withRepoCtx + (solverSettingIndexState solverSettings) + (solverSettingActiveRepos solverSettings) + pkgConfigDB <- getPkgConfigDb verbosity progdb + + -- TODO: [code cleanup] it'd be better if the Compiler contained the + -- ConfiguredPrograms that it needs, rather than relying on the progdb + -- since we don't need to depend on all the programs here, just the + -- ones relevant for the compiler. + + liftIO $ do + solver <- + chooseSolver + verbosity + (solverSettingSolver solverSettings) + (compilerInfo compiler) + + notice verbosity "Resolving dependencies..." + planOrError <- + foldProgress logMsg (pure . Left) (pure . Right) $ + planPackages + verbosity + compiler + platform + solver + solverSettings + (installedPackages <> installedPkgIndex) + sourcePkgDb + pkgConfigDB + localPackages + localPackagesEnabledStanzas + case planOrError of + Left msg -> do + reportPlanningFailure projectConfig compiler platform localPackages + die' verbosity msg + Right plan -> return (plan, pkgConfigDB, tis, ar) + where + corePackageDbs :: [PackageDB] + corePackageDbs = + applyPackageDbFlags + [GlobalPackageDB] + (projectConfigPackageDBs projectConfigShared) + + withRepoCtx = + projectConfigWithSolverRepoContext + verbosity + projectConfigShared + projectConfigBuildOnly + solverSettings = resolveSolverSettings projectConfig + logMsg message rest = debugNoWrap verbosity message >> rest + + localPackagesEnabledStanzas = + Map.fromList + [ (pkgname, stanzas) + | pkg <- localPackages + , -- TODO: misnomer: we should separate + -- builtin/global/inplace/local packages + -- and packages explicitly mentioned in the project + -- + let pkgname = pkgSpecifierTarget pkg + testsEnabled = + lookupLocalPackageConfig + packageConfigTests + projectConfig + pkgname + benchmarksEnabled = + lookupLocalPackageConfig + packageConfigBenchmarks + projectConfig + pkgname + isLocal = isJust (shouldBeLocal pkg) + stanzas + | isLocal = + Map.fromList $ + [ (TestStanzas, enabled) + | enabled <- flagToList testsEnabled + ] + ++ [ (BenchStanzas, enabled) + | enabled <- flagToList benchmarksEnabled + ] + | otherwise = Map.fromList [(TestStanzas, False), (BenchStanzas, False)] + ] + + -- Elaborate the solver's install plan to get a fully detailed plan. This + -- version of the plan has the final nix-style hashed ids. + -- + phaseElaboratePlan + :: ProjectConfig + -> (Compiler, Platform, ProgramDb) + -> PkgConfigDb + -> SolverInstallPlan + -> [PackageSpecifier (SourcePackage (PackageLocation loc))] + -> Rebuild + ( ElaboratedInstallPlan + , ElaboratedSharedConfig + ) + phaseElaboratePlan + ProjectConfig + { projectConfigShared + , projectConfigAllPackages + , projectConfigLocalPackages + , projectConfigSpecificPackage + , projectConfigBuildOnly + } + (compiler, platform, progdb) + pkgConfigDB + solverPlan + localPackages = do + liftIO $ debug verbosity "Elaborating the install plan..." + + sourcePackageHashes <- + rerunIfChanged + verbosity + fileMonitorSourceHashes + (packageLocationsSignature solverPlan) + $ getPackageSourceHashes verbosity withRepoCtx solverPlan + + defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler + let installDirs = fmap Cabal.fromFlag $ (fmap Flag defaultInstallDirs) <> (projectConfigInstallDirs projectConfigShared) + (elaboratedPlan, elaboratedShared) <- + liftIO . runLogProgress verbosity $ elaborateInstallPlan verbosity - platform compiler progdb pkgConfigDB + platform + compiler + progdb + pkgConfigDB distDirLayout cabalStoreDirLayout solverPlan @@ -707,132 +822,154 @@ rebuildInstallPlan verbosity projectConfigAllPackages projectConfigLocalPackages (getMapMappend projectConfigSpecificPackage) - let instantiatedPlan - = instantiateInstallPlan + let instantiatedPlan = + instantiateInstallPlan cabalStoreDirLayout installDirs elaboratedShared elaboratedPlan - liftIO $ debugNoWrap verbosity (showElaboratedInstallPlan instantiatedPlan) - return (instantiatedPlan, elaboratedShared) - where - withRepoCtx = projectConfigWithSolverRepoContext verbosity - projectConfigShared - projectConfigBuildOnly - - -- Update the files we maintain that reflect our current build environment. - -- In particular we maintain a JSON representation of the elaborated - -- install plan (but not the improved plan since that reflects the state - -- of the build rather than just the input environment). - -- - phaseMaintainPlanOutputs :: ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> Rebuild () - phaseMaintainPlanOutputs elaboratedPlan elaboratedShared = liftIO $ do + liftIO $ debugNoWrap verbosity (showElaboratedInstallPlan instantiatedPlan) + return (instantiatedPlan, elaboratedShared) + where + withRepoCtx = + projectConfigWithSolverRepoContext + verbosity + projectConfigShared + projectConfigBuildOnly + + -- Update the files we maintain that reflect our current build environment. + -- In particular we maintain a JSON representation of the elaborated + -- install plan (but not the improved plan since that reflects the state + -- of the build rather than just the input environment). + -- + phaseMaintainPlanOutputs + :: ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> Rebuild () + phaseMaintainPlanOutputs elaboratedPlan elaboratedShared = liftIO $ do debug verbosity "Updating plan.json" writePlanExternalRepresentation distDirLayout elaboratedPlan elaboratedShared - - -- Improve the elaborated install plan. The elaborated plan consists - -- mostly of source packages (with full nix-style hashed ids). Where - -- corresponding installed packages already exist in the store, replace - -- them in the plan. - -- - -- Note that we do monitor the store's package db here, so we will redo - -- this improvement phase when the db changes -- including as a result of - -- executing a plan and installing things. - -- - phaseImprovePlan :: ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> Rebuild ElaboratedInstallPlan - phaseImprovePlan elaboratedPlan elaboratedShared = do - + -- Improve the elaborated install plan. The elaborated plan consists + -- mostly of source packages (with full nix-style hashed ids). Where + -- corresponding installed packages already exist in the store, replace + -- them in the plan. + -- + -- Note that we do monitor the store's package db here, so we will redo + -- this improvement phase when the db changes -- including as a result of + -- executing a plan and installing things. + -- + phaseImprovePlan + :: ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> Rebuild ElaboratedInstallPlan + phaseImprovePlan elaboratedPlan elaboratedShared = do liftIO $ debug verbosity "Improving the install plan..." storePkgIdSet <- getStoreEntries cabalStoreDirLayout compid - let improvedPlan = improveInstallPlanWithInstalledPackages - storePkgIdSet - elaboratedPlan + let improvedPlan = + improveInstallPlanWithInstalledPackages + storePkgIdSet + elaboratedPlan liftIO $ debugNoWrap verbosity (showElaboratedInstallPlan improvedPlan) -- TODO: [nice to have] having checked which packages from the store -- we're using, it may be sensible to sanity check those packages -- by loading up the compiler package db and checking everything -- matches up as expected, e.g. no dangling deps, files deleted. return improvedPlan - where - compid = compilerId (pkgConfigCompiler elaboratedShared) - + where + compid = compilerId (pkgConfigCompiler elaboratedShared) -- | If a 'PackageSpecifier' refers to a single package, return Just that -- package. - - reportPlanningFailure :: ProjectConfig -> Compiler -> Platform -> [PackageSpecifier UnresolvedSourcePackage] -> IO () -reportPlanningFailure projectConfig comp platform pkgSpecifiers = when reportFailure $ - - BuildReports.storeLocal (compilerInfo comp) - (fromNubList $ projectConfigSummaryFile . projectConfigBuildOnly $ projectConfig) - buildReports platform - - -- TODO may want to handle the projectConfigLogFile paramenter here, or just remove it entirely? +reportPlanningFailure projectConfig comp platform pkgSpecifiers = + when reportFailure $ + BuildReports.storeLocal + (compilerInfo comp) + (fromNubList $ projectConfigSummaryFile . projectConfigBuildOnly $ projectConfig) + buildReports + platform where + -- TODO may want to handle the projectConfigLogFile paramenter here, or just remove it entirely? + reportFailure = Cabal.fromFlag . projectConfigReportPlanningFailure . projectConfigBuildOnly $ projectConfig pkgids = mapMaybe theSpecifiedPackage pkgSpecifiers - buildReports = BuildReports.fromPlanningFailure platform - (compilerId comp) pkgids - -- TODO we may want to get more flag assignments and merge them here? - (packageConfigFlagAssignment . projectConfigAllPackages $ projectConfig) + buildReports = + BuildReports.fromPlanningFailure + platform + (compilerId comp) + pkgids + -- TODO we may want to get more flag assignments and merge them here? + (packageConfigFlagAssignment . projectConfigAllPackages $ projectConfig) theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId theSpecifiedPackage pkgSpec = - case pkgSpec of - NamedPackage name [PackagePropertyVersion version] - -> PackageIdentifier name <$> trivialRange version - NamedPackage _ _ -> Nothing - SpecificSourcePackage pkg -> Just $ packageId pkg - -- | If a range includes only a single version, return Just that version. + case pkgSpec of + NamedPackage name [PackagePropertyVersion version] -> + PackageIdentifier name <$> trivialRange version + NamedPackage _ _ -> Nothing + SpecificSourcePackage pkg -> Just $ packageId pkg + -- \| If a range includes only a single version, return Just that version. trivialRange :: VersionRange -> Maybe Version - trivialRange = foldVersionRange + trivialRange = + foldVersionRange Nothing - Just -- "== v" + Just -- "== v" (\_ -> Nothing) (\_ -> Nothing) (\_ _ -> Nothing) (\_ _ -> Nothing) - programsMonitorFiles :: ProgramDb -> [MonitorFilePath] programsMonitorFiles progdb = - [ monitor - | prog <- configuredPrograms progdb - , monitor <- monitorFileSearchPath (programMonitorFiles prog) - (programPath prog) - ] + [ monitor + | prog <- configuredPrograms progdb + , monitor <- + monitorFileSearchPath + (programMonitorFiles prog) + (programPath prog) + ] -- | Select the bits of a 'ProgramDb' to monitor for value changes. -- Use 'programsMonitorFiles' for the files to monitor. --- programDbSignature :: ProgramDb -> [ConfiguredProgram] programDbSignature progdb = - [ prog { programMonitorFiles = [] - , programOverrideEnv = filter ((/="PATH") . fst) - (programOverrideEnv prog) } - | prog <- configuredPrograms progdb ] - -getInstalledPackages :: Verbosity - -> Compiler -> ProgramDb -> Platform - -> PackageDBStack - -> Rebuild InstalledPackageIndex + [ prog + { programMonitorFiles = [] + , programOverrideEnv = + filter + ((/= "PATH") . fst) + (programOverrideEnv prog) + } + | prog <- configuredPrograms progdb + ] + +getInstalledPackages + :: Verbosity + -> Compiler + -> ProgramDb + -> Platform + -> PackageDBStack + -> Rebuild InstalledPackageIndex getInstalledPackages verbosity compiler progdb platform packagedbs = do - monitorFiles . map monitorFileOrDirectory - =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles - verbosity compiler - packagedbs progdb platform) - liftIO $ IndexUtils.getInstalledPackages - verbosity compiler - packagedbs progdb + monitorFiles . map monitorFileOrDirectory + =<< liftIO + ( IndexUtils.getInstalledPackagesMonitorFiles + verbosity + compiler + packagedbs + progdb + platform + ) + liftIO $ + IndexUtils.getInstalledPackages + verbosity + compiler + packagedbs + progdb {- --TODO: [nice to have] use this but for sanity / consistency checking @@ -852,414 +989,447 @@ getPackageDBContents verbosity compiler progdb platform packagedb = do -} getSourcePackages - :: Verbosity - -> (forall a. (RepoContext -> IO a) -> IO a) - -> Maybe IndexUtils.TotalIndexState - -> Maybe IndexUtils.ActiveRepos - -> Rebuild (SourcePackageDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos) + :: Verbosity + -> (forall a. (RepoContext -> IO a) -> IO a) + -> Maybe IndexUtils.TotalIndexState + -> Maybe IndexUtils.ActiveRepos + -> Rebuild (SourcePackageDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos) getSourcePackages verbosity withRepoCtx idxState activeRepos = do - (sourcePkgDbWithTIS, repos) <- - liftIO $ - withRepoCtx $ \repoctx -> do - sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity repoctx idxState activeRepos - return (sourcePkgDbWithTIS, repoContextRepos repoctx) - - traverse_ needIfExists - . IndexUtils.getSourcePackagesMonitorFiles - $ repos - return sourcePkgDbWithTIS + (sourcePkgDbWithTIS, repos) <- + liftIO $ + withRepoCtx $ \repoctx -> do + sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity repoctx idxState activeRepos + return (sourcePkgDbWithTIS, repoContextRepos repoctx) + traverse_ needIfExists + . IndexUtils.getSourcePackagesMonitorFiles + $ repos + return sourcePkgDbWithTIS getPkgConfigDb :: Verbosity -> ProgramDb -> Rebuild PkgConfigDb getPkgConfigDb verbosity progdb = do - dirs <- liftIO $ getPkgConfigDbDirs verbosity progdb - -- Just monitor the dirs so we'll notice new .pc files. - -- Alternatively we could monitor all the .pc files too. - traverse_ monitorDirectoryStatus dirs - liftIO $ readPkgConfigDb verbosity progdb - + dirs <- liftIO $ getPkgConfigDbDirs verbosity progdb + -- Just monitor the dirs so we'll notice new .pc files. + -- Alternatively we could monitor all the .pc files too. + traverse_ monitorDirectoryStatus dirs + liftIO $ readPkgConfigDb verbosity progdb -- | Select the config values to monitor for changes package source hashes. -packageLocationsSignature :: SolverInstallPlan - -> [(PackageId, PackageLocation (Maybe FilePath))] +packageLocationsSignature + :: SolverInstallPlan + -> [(PackageId, PackageLocation (Maybe FilePath))] packageLocationsSignature solverPlan = - [ (packageId pkg, srcpkgSource pkg) - | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg}) - <- SolverInstallPlan.toList solverPlan - ] - + [ (packageId pkg, srcpkgSource pkg) + | SolverInstallPlan.Configured (SolverPackage{solverPkgSource = pkg}) <- + SolverInstallPlan.toList solverPlan + ] -- | Get the 'HashValue' for all the source packages where we use hashes, -- and download any packages required to do so. -- -- Note that we don't get hashes for local unpacked packages. --- -getPackageSourceHashes :: Verbosity - -> (forall a. (RepoContext -> IO a) -> IO a) - -> SolverInstallPlan - -> Rebuild (Map PackageId PackageSourceHash) +getPackageSourceHashes + :: Verbosity + -> (forall a. (RepoContext -> IO a) -> IO a) + -> SolverInstallPlan + -> Rebuild (Map PackageId PackageSourceHash) getPackageSourceHashes verbosity withRepoCtx solverPlan = do + -- Determine if and where to get the package's source hash from. + -- + let allPkgLocations :: [(PackageId, PackageLocation (Maybe FilePath))] + allPkgLocations = + [ (packageId pkg, srcpkgSource pkg) + | SolverInstallPlan.Configured (SolverPackage{solverPkgSource = pkg}) <- + SolverInstallPlan.toList solverPlan + ] - -- Determine if and where to get the package's source hash from. - -- - let allPkgLocations :: [(PackageId, PackageLocation (Maybe FilePath))] - allPkgLocations = - [ (packageId pkg, srcpkgSource pkg) - | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg}) - <- SolverInstallPlan.toList solverPlan ] - - -- Tarballs that were local in the first place. - -- We'll hash these tarball files directly. - localTarballPkgs :: [(PackageId, FilePath)] - localTarballPkgs = - [ (pkgid, tarball) - | (pkgid, LocalTarballPackage tarball) <- allPkgLocations ] - - -- Tarballs from remote URLs. We must have downloaded these already - -- (since we extracted the .cabal file earlier) - remoteTarballPkgs = - [ (pkgid, tarball) - | (pkgid, RemoteTarballPackage _ (Just tarball)) <- allPkgLocations ] - - -- tarballs from source-repository-package stanzas - sourceRepoTarballPkgs = - [ (pkgid, tarball) - | (pkgid, RemoteSourceRepoPackage _ (Just tarball)) <- allPkgLocations ] - - -- Tarballs from repositories, either where the repository provides - -- hashes as part of the repo metadata, or where we will have to - -- download and hash the tarball. - repoTarballPkgsWithMetadataUnvalidated :: [(PackageId, Repo)] - repoTarballPkgsWithoutMetadata :: [(PackageId, Repo)] - (repoTarballPkgsWithMetadataUnvalidated, - repoTarballPkgsWithoutMetadata) = + -- Tarballs that were local in the first place. + -- We'll hash these tarball files directly. + localTarballPkgs :: [(PackageId, FilePath)] + localTarballPkgs = + [ (pkgid, tarball) + | (pkgid, LocalTarballPackage tarball) <- allPkgLocations + ] + + -- Tarballs from remote URLs. We must have downloaded these already + -- (since we extracted the .cabal file earlier) + remoteTarballPkgs = + [ (pkgid, tarball) + | (pkgid, RemoteTarballPackage _ (Just tarball)) <- allPkgLocations + ] + + -- tarballs from source-repository-package stanzas + sourceRepoTarballPkgs = + [ (pkgid, tarball) + | (pkgid, RemoteSourceRepoPackage _ (Just tarball)) <- allPkgLocations + ] + + -- Tarballs from repositories, either where the repository provides + -- hashes as part of the repo metadata, or where we will have to + -- download and hash the tarball. + repoTarballPkgsWithMetadataUnvalidated :: [(PackageId, Repo)] + repoTarballPkgsWithoutMetadata :: [(PackageId, Repo)] + ( repoTarballPkgsWithMetadataUnvalidated + , repoTarballPkgsWithoutMetadata + ) = partitionEithers - [ case repo of - RepoSecure{} -> Left (pkgid, repo) - _ -> Right (pkgid, repo) - | (pkgid, RepoTarballPackage repo _ _) <- allPkgLocations ] - - (repoTarballPkgsWithMetadata, repoTarballPkgsToDownloadWithMeta) <- fmap partitionEithers $ - liftIO $ withRepoCtx $ \repoctx -> forM repoTarballPkgsWithMetadataUnvalidated $ - \x@(pkg, repo) -> verifyFetchedTarball verbosity repoctx repo pkg >>= \b -> case b of - True -> return $ Left x - False -> return $ Right x - - -- For tarballs from repos that do not have hashes available we now have - -- to check if the packages were downloaded already. - -- - (repoTarballPkgsToDownloadWithNoMeta, - repoTarballPkgsDownloaded) - <- fmap partitionEithers $ - liftIO $ sequence - [ do mtarball <- checkRepoTarballFetched repo pkgid - case mtarball of - Nothing -> return (Left (pkgid, repo)) - Just tarball -> return (Right (pkgid, tarball)) - | (pkgid, repo) <- repoTarballPkgsWithoutMetadata ] - - let repoTarballPkgsToDownload = repoTarballPkgsToDownloadWithMeta ++ repoTarballPkgsToDownloadWithNoMeta - (hashesFromRepoMetadata, - repoTarballPkgsNewlyDownloaded) <- - -- Avoid having to initialise the repository (ie 'withRepoCtx') if we - -- don't have to. (The main cost is configuring the http client.) - if null repoTarballPkgsToDownload && null repoTarballPkgsWithMetadata - then return (Map.empty, []) - else liftIO $ withRepoCtx $ \repoctx -> do + [ case repo of + RepoSecure{} -> Left (pkgid, repo) + _ -> Right (pkgid, repo) + | (pkgid, RepoTarballPackage repo _ _) <- allPkgLocations + ] - -- For tarballs from repos that do have hashes available as part of the - -- repo metadata we now load up the index for each repo and retrieve - -- the hashes for the packages - -- - hashesFromRepoMetadata <- - Sec.uncheckClientErrors $ --TODO: [code cleanup] wrap in our own exceptions - fmap (Map.fromList . concat) $ + (repoTarballPkgsWithMetadata, repoTarballPkgsToDownloadWithMeta) <- fmap partitionEithers $ + liftIO $ + withRepoCtx $ \repoctx -> forM repoTarballPkgsWithMetadataUnvalidated $ + \x@(pkg, repo) -> + verifyFetchedTarball verbosity repoctx repo pkg >>= \b -> case b of + True -> return $ Left x + False -> return $ Right x + + -- For tarballs from repos that do not have hashes available we now have + -- to check if the packages were downloaded already. + -- + ( repoTarballPkgsToDownloadWithNoMeta + , repoTarballPkgsDownloaded + ) <- + fmap partitionEithers $ + liftIO $ sequence - -- Reading the repo index is expensive so we group the packages by repo - [ repoContextWithSecureRepo repoctx repo $ \secureRepo -> - Sec.withIndex secureRepo $ \repoIndex -> - sequence - [ do hash <- Sec.trusted <$> -- strip off Trusted tag - Sec.indexLookupHash repoIndex pkgid - -- Note that hackage-security currently uses SHA256 - -- but this API could in principle give us some other - -- choice in future. - return (pkgid, hashFromTUF hash) - | pkgid <- pkgids ] - | (repo, pkgids) <- - map (\grp@((_,repo):|_) -> (repo, map fst (NE.toList grp))) - . NE.groupBy ((==) `on` (remoteRepoName . repoRemote . snd)) - . sortBy (compare `on` (remoteRepoName . repoRemote . snd)) - $ repoTarballPkgsWithMetadata + [ do + mtarball <- checkRepoTarballFetched repo pkgid + case mtarball of + Nothing -> return (Left (pkgid, repo)) + Just tarball -> return (Right (pkgid, tarball)) + | (pkgid, repo) <- repoTarballPkgsWithoutMetadata ] - -- For tarballs from repos that do not have hashes available, download - -- the ones we previously determined we need. - -- - repoTarballPkgsNewlyDownloaded <- - sequence - [ do tarball <- fetchRepoTarball verbosity repoctx repo pkgid - return (pkgid, tarball) - | (pkgid, repo) <- repoTarballPkgsToDownload ] - - return (hashesFromRepoMetadata, - repoTarballPkgsNewlyDownloaded) + let repoTarballPkgsToDownload = repoTarballPkgsToDownloadWithMeta ++ repoTarballPkgsToDownloadWithNoMeta + ( hashesFromRepoMetadata + , repoTarballPkgsNewlyDownloaded + ) <- + -- Avoid having to initialise the repository (ie 'withRepoCtx') if we + -- don't have to. (The main cost is configuring the http client.) + if null repoTarballPkgsToDownload && null repoTarballPkgsWithMetadata + then return (Map.empty, []) + else liftIO $ withRepoCtx $ \repoctx -> do + -- For tarballs from repos that do have hashes available as part of the + -- repo metadata we now load up the index for each repo and retrieve + -- the hashes for the packages + -- + hashesFromRepoMetadata <- + Sec.uncheckClientErrors $ -- TODO: [code cleanup] wrap in our own exceptions + fmap (Map.fromList . concat) $ + sequence + -- Reading the repo index is expensive so we group the packages by repo + [ repoContextWithSecureRepo repoctx repo $ \secureRepo -> + Sec.withIndex secureRepo $ \repoIndex -> + sequence + [ do + hash <- + Sec.trusted + <$> Sec.indexLookupHash repoIndex pkgid -- strip off Trusted tag + + -- Note that hackage-security currently uses SHA256 + -- but this API could in principle give us some other + -- choice in future. + return (pkgid, hashFromTUF hash) + | pkgid <- pkgids + ] + | (repo, pkgids) <- + map (\grp@((_, repo) :| _) -> (repo, map fst (NE.toList grp))) + . NE.groupBy ((==) `on` (remoteRepoName . repoRemote . snd)) + . sortBy (compare `on` (remoteRepoName . repoRemote . snd)) + $ repoTarballPkgsWithMetadata + ] + + -- For tarballs from repos that do not have hashes available, download + -- the ones we previously determined we need. + -- + repoTarballPkgsNewlyDownloaded <- + sequence + [ do + tarball <- fetchRepoTarball verbosity repoctx repo pkgid + return (pkgid, tarball) + | (pkgid, repo) <- repoTarballPkgsToDownload + ] - -- Hash tarball files for packages where we have to do that. This includes - -- tarballs that were local in the first place, plus tarballs from repos, - -- either previously cached or freshly downloaded. - -- - let allTarballFilePkgs :: [(PackageId, FilePath)] - allTarballFilePkgs = localTarballPkgs - ++ remoteTarballPkgs - ++ sourceRepoTarballPkgs - ++ repoTarballPkgsDownloaded - ++ repoTarballPkgsNewlyDownloaded - hashesFromTarballFiles <- liftIO $ + return + ( hashesFromRepoMetadata + , repoTarballPkgsNewlyDownloaded + ) + + -- Hash tarball files for packages where we have to do that. This includes + -- tarballs that were local in the first place, plus tarballs from repos, + -- either previously cached or freshly downloaded. + -- + let allTarballFilePkgs :: [(PackageId, FilePath)] + allTarballFilePkgs = + localTarballPkgs + ++ remoteTarballPkgs + ++ sourceRepoTarballPkgs + ++ repoTarballPkgsDownloaded + ++ repoTarballPkgsNewlyDownloaded + hashesFromTarballFiles <- + liftIO $ fmap Map.fromList $ - sequence - [ do srchash <- readFileHashValue tarball - return (pkgid, srchash) - | (pkgid, tarball) <- allTarballFilePkgs - ] - monitorFiles [ monitorFile tarball - | (_pkgid, tarball) <- allTarballFilePkgs ] + sequence + [ do + srchash <- readFileHashValue tarball + return (pkgid, srchash) + | (pkgid, tarball) <- allTarballFilePkgs + ] + monitorFiles + [ monitorFile tarball + | (_pkgid, tarball) <- allTarballFilePkgs + ] - -- Return the combination - return $! hashesFromRepoMetadata - <> hashesFromTarballFiles + -- Return the combination + return $! + hashesFromRepoMetadata + <> hashesFromTarballFiles -- | Append the given package databases to an existing PackageDBStack. -- A @Nothing@ entry will clear everything before it. applyPackageDbFlags :: PackageDBStack -> [Maybe PackageDB] -> PackageDBStack -applyPackageDbFlags dbs' [] = dbs' -applyPackageDbFlags _ (Nothing:dbs) = applyPackageDbFlags [] dbs -applyPackageDbFlags dbs' (Just db:dbs) = applyPackageDbFlags (dbs' ++ [db]) dbs +applyPackageDbFlags dbs' [] = dbs' +applyPackageDbFlags _ (Nothing : dbs) = applyPackageDbFlags [] dbs +applyPackageDbFlags dbs' (Just db : dbs) = applyPackageDbFlags (dbs' ++ [db]) dbs -- ------------------------------------------------------------ + -- * Installation planning + -- ------------------------------------------------------------ -planPackages :: Verbosity - -> Compiler - -> Platform - -> Solver -> SolverSettings - -> InstalledPackageIndex - -> SourcePackageDb - -> PkgConfigDb - -> [PackageSpecifier UnresolvedSourcePackage] - -> Map PackageName (Map OptionalStanza Bool) - -> Progress String String SolverInstallPlan -planPackages verbosity comp platform solver SolverSettings{..} - installedPkgIndex sourcePkgDb pkgConfigDB - localPackages pkgStanzasEnable = +planPackages + :: Verbosity + -> Compiler + -> Platform + -> Solver + -> SolverSettings + -> InstalledPackageIndex + -> SourcePackageDb + -> PkgConfigDb + -> [PackageSpecifier UnresolvedSourcePackage] + -> Map PackageName (Map OptionalStanza Bool) + -> Progress String String SolverInstallPlan +planPackages + verbosity + comp + platform + solver + SolverSettings{..} + installedPkgIndex + sourcePkgDb + pkgConfigDB + localPackages + pkgStanzasEnable = resolveDependencies - platform (compilerInfo comp) - pkgConfigDB solver + platform + (compilerInfo comp) + pkgConfigDB + solver resolverParams - - where - - --TODO: [nice to have] disable multiple instances restriction in - -- the solver, but then make sure we can cope with that in the - -- output. - resolverParams :: DepResolverParams - resolverParams = - + where + -- TODO: [nice to have] disable multiple instances restriction in + -- the solver, but then make sure we can cope with that in the + -- output. + resolverParams :: DepResolverParams + resolverParams = setMaxBackjumps solverSettingMaxBackjumps - - . setIndependentGoals solverSettingIndependentGoals - - . setReorderGoals solverSettingReorderGoals - - . setCountConflicts solverSettingCountConflicts - - . setFineGrainedConflicts solverSettingFineGrainedConflicts - - . setMinimizeConflictSet solverSettingMinimizeConflictSet - - --TODO: [required eventually] should only be configurable for - --custom installs - -- . setAvoidReinstalls solverSettingAvoidReinstalls - - --TODO: [required eventually] should only be configurable for - --custom installs - -- . setShadowPkgs solverSettingShadowPkgs - - . setStrongFlags solverSettingStrongFlags - - . setAllowBootLibInstalls solverSettingAllowBootLibInstalls - - . setOnlyConstrained solverSettingOnlyConstrained - - . setSolverVerbosity verbosity - - --TODO: [required eventually] decide if we need to prefer - -- installed for global packages, or prefer latest even for - -- global packages. Perhaps should be configurable but with a - -- different name than "upgrade-dependencies". - . setPreferenceDefault - (if Cabal.asBool solverSettingPreferOldest - then PreferAllOldest - else PreferLatestForSelected) - {-(if solverSettingUpgradeDeps - then PreferAllLatest - else PreferLatestForSelected)-} - - . removeLowerBounds solverSettingAllowOlder - . removeUpperBounds solverSettingAllowNewer - - . addDefaultSetupDependencies (defaultSetupDeps comp platform - . PD.packageDescription - . srcpkgDescription) - - . addSetupCabalMinVersionConstraint setupMinCabalVersionConstraint - . addSetupCabalMaxVersionConstraint setupMaxCabalVersionConstraint - - . addPreferences - -- preferences from the config file or command line - [ PackageVersionPreference name ver - | PackageVersionConstraint name ver <- solverSettingPreferences ] - - . addConstraints - -- version constraints from the config file or command line + . setIndependentGoals solverSettingIndependentGoals + . setReorderGoals solverSettingReorderGoals + . setCountConflicts solverSettingCountConflicts + . setFineGrainedConflicts solverSettingFineGrainedConflicts + . setMinimizeConflictSet solverSettingMinimizeConflictSet + -- TODO: [required eventually] should only be configurable for + -- custom installs + -- . setAvoidReinstalls solverSettingAvoidReinstalls + + -- TODO: [required eventually] should only be configurable for + -- custom installs + -- . setShadowPkgs solverSettingShadowPkgs + + . setStrongFlags solverSettingStrongFlags + . setAllowBootLibInstalls solverSettingAllowBootLibInstalls + . setOnlyConstrained solverSettingOnlyConstrained + . setSolverVerbosity verbosity + -- TODO: [required eventually] decide if we need to prefer + -- installed for global packages, or prefer latest even for + -- global packages. Perhaps should be configurable but with a + -- different name than "upgrade-dependencies". + . setPreferenceDefault + ( if Cabal.asBool solverSettingPreferOldest + then PreferAllOldest + else PreferLatestForSelected + ) + {-(if solverSettingUpgradeDeps + then PreferAllLatest + else PreferLatestForSelected)-} + + . removeLowerBounds solverSettingAllowOlder + . removeUpperBounds solverSettingAllowNewer + . addDefaultSetupDependencies + ( defaultSetupDeps comp platform + . PD.packageDescription + . srcpkgDescription + ) + . addSetupCabalMinVersionConstraint setupMinCabalVersionConstraint + . addSetupCabalMaxVersionConstraint setupMaxCabalVersionConstraint + . addPreferences + -- preferences from the config file or command line + [ PackageVersionPreference name ver + | PackageVersionConstraint name ver <- solverSettingPreferences + ] + . addConstraints + -- version constraints from the config file or command line [ LabeledPackageConstraint (userToPackageConstraint pc) src - | (pc, src) <- solverSettingConstraints ] - - . addPreferences - -- enable stanza preference unilaterally, regardless if the user asked - -- accordingly or expressed no preference, to help hint the solver - [ PackageStanzasPreference pkgname stanzas - | pkg <- localPackages - , let pkgname = pkgSpecifierTarget pkg - stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable - stanzas = [ stanza | stanza <- [minBound..maxBound] - , Map.lookup stanza stanzaM /= Just False ] - , not (null stanzas) - ] - - . addConstraints - -- enable stanza constraints where the user asked to enable - [ LabeledPackageConstraint - (PackageConstraint (scopeToplevel pkgname) - (PackagePropertyStanzas stanzas)) + | (pc, src) <- solverSettingConstraints + ] + . addPreferences + -- enable stanza preference unilaterally, regardless if the user asked + -- accordingly or expressed no preference, to help hint the solver + [ PackageStanzasPreference pkgname stanzas + | pkg <- localPackages + , let pkgname = pkgSpecifierTarget pkg + stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable + stanzas = + [ stanza | stanza <- [minBound .. maxBound], Map.lookup stanza stanzaM /= Just False + ] + , not (null stanzas) + ] + . addConstraints + -- enable stanza constraints where the user asked to enable + [ LabeledPackageConstraint + ( PackageConstraint + (scopeToplevel pkgname) + (PackagePropertyStanzas stanzas) + ) ConstraintSourceConfigFlagOrTarget - | pkg <- localPackages - , let pkgname = pkgSpecifierTarget pkg - stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable - stanzas = [ stanza | stanza <- [minBound..maxBound] - , Map.lookup stanza stanzaM == Just True ] - , not (null stanzas) - ] - - . addConstraints - --TODO: [nice to have] should have checked at some point that the - -- package in question actually has these flags. - [ LabeledPackageConstraint - (PackageConstraint (scopeToplevel pkgname) - (PackagePropertyFlags flags)) + | pkg <- localPackages + , let pkgname = pkgSpecifierTarget pkg + stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable + stanzas = + [ stanza | stanza <- [minBound .. maxBound], Map.lookup stanza stanzaM == Just True + ] + , not (null stanzas) + ] + . addConstraints + -- TODO: [nice to have] should have checked at some point that the + -- package in question actually has these flags. + [ LabeledPackageConstraint + ( PackageConstraint + (scopeToplevel pkgname) + (PackagePropertyFlags flags) + ) ConstraintSourceConfigFlagOrTarget - | (pkgname, flags) <- Map.toList solverSettingFlagAssignments ] - - . addConstraints - --TODO: [nice to have] we have user-supplied flags for unspecified - -- local packages (as well as specific per-package flags). For the - -- former we just apply all these flags to all local targets which - -- is silly. We should check if the flags are appropriate. - [ LabeledPackageConstraint - (PackageConstraint (scopeToplevel pkgname) - (PackagePropertyFlags flags)) + | (pkgname, flags) <- Map.toList solverSettingFlagAssignments + ] + . addConstraints + -- TODO: [nice to have] we have user-supplied flags for unspecified + -- local packages (as well as specific per-package flags). For the + -- former we just apply all these flags to all local targets which + -- is silly. We should check if the flags are appropriate. + [ LabeledPackageConstraint + ( PackageConstraint + (scopeToplevel pkgname) + (PackagePropertyFlags flags) + ) ConstraintSourceConfigFlagOrTarget - | let flags = solverSettingFlagAssignment - , not (PD.nullFlagAssignment flags) - , pkg <- localPackages - , let pkgname = pkgSpecifierTarget pkg ] - - $ stdResolverParams - - stdResolverParams :: DepResolverParams - stdResolverParams = - -- Note: we don't use the standardInstallPolicy here, since that uses - -- its own addDefaultSetupDependencies that is not appropriate for us. - basicInstallPolicy - installedPkgIndex sourcePkgDb - localPackages - - -- While we can talk to older Cabal versions (we need to be able to - -- do so for custom Setup scripts that require older Cabal lib - -- versions), we have problems talking to some older versions that - -- don't support certain features. - -- - -- For example, Cabal-1.16 and older do not know about build targets. - -- Even worse, 1.18 and older only supported the --constraint flag - -- with source package ids, not --dependency with installed package - -- ids. That is bad because we cannot reliably select the right - -- dependencies in the presence of multiple instances (i.e. the - -- store). See issue #3932. So we require Cabal 1.20 as a minimum. - -- - -- Moreover, lib:Cabal generally only supports the interface of - -- current and past compilers; in fact recent lib:Cabal versions - -- will warn when they encounter a too new or unknown GHC compiler - -- version (c.f. #415). To avoid running into unsupported - -- configurations we encode the compatibility matrix as lower - -- bounds on lib:Cabal here (effectively corresponding to the - -- respective major Cabal version bundled with the respective GHC - -- release). - -- - -- GHC 9.2 needs Cabal >= 3.6 - -- GHC 9.0 needs Cabal >= 3.4 - -- GHC 8.10 needs Cabal >= 3.2 - -- GHC 8.8 needs Cabal >= 3.0 - -- GHC 8.6 needs Cabal >= 2.4 - -- GHC 8.4 needs Cabal >= 2.2 - -- GHC 8.2 needs Cabal >= 2.0 - -- GHC 8.0 needs Cabal >= 1.24 - -- GHC 7.10 needs Cabal >= 1.22 - -- - -- (NB: we don't need to consider older GHCs as Cabal >= 1.20 is - -- the absolute lower bound) - -- - -- TODO: long-term, this compatibility matrix should be - -- stored as a field inside 'Distribution.Compiler.Compiler' - setupMinCabalVersionConstraint - | isGHC, compVer >= mkVersion [9,6] = mkVersion [3,10] - | isGHC, compVer >= mkVersion [9,4] = mkVersion [3,8] - | isGHC, compVer >= mkVersion [9,2] = mkVersion [3,6] - | isGHC, compVer >= mkVersion [9,0] = mkVersion [3,4] - | isGHC, compVer >= mkVersion [8,10] = mkVersion [3,2] - | isGHC, compVer >= mkVersion [8,8] = mkVersion [3,0] - | isGHC, compVer >= mkVersion [8,6] = mkVersion [2,4] - | isGHC, compVer >= mkVersion [8,4] = mkVersion [2,2] - | isGHC, compVer >= mkVersion [8,2] = mkVersion [2,0] - | isGHC, compVer >= mkVersion [8,0] = mkVersion [1,24] - | isGHC, compVer >= mkVersion [7,10] = mkVersion [1,22] - | otherwise = mkVersion [1,20] - where - isGHC = compFlav `elem` [GHC,GHCJS] - compFlav = compilerFlavor comp - compVer = compilerVersion comp + | let flags = solverSettingFlagAssignment + , not (PD.nullFlagAssignment flags) + , pkg <- localPackages + , let pkgname = pkgSpecifierTarget pkg + ] + $ stdResolverParams + + stdResolverParams :: DepResolverParams + stdResolverParams = + -- Note: we don't use the standardInstallPolicy here, since that uses + -- its own addDefaultSetupDependencies that is not appropriate for us. + basicInstallPolicy + installedPkgIndex + sourcePkgDb + localPackages + + -- While we can talk to older Cabal versions (we need to be able to + -- do so for custom Setup scripts that require older Cabal lib + -- versions), we have problems talking to some older versions that + -- don't support certain features. + -- + -- For example, Cabal-1.16 and older do not know about build targets. + -- Even worse, 1.18 and older only supported the --constraint flag + -- with source package ids, not --dependency with installed package + -- ids. That is bad because we cannot reliably select the right + -- dependencies in the presence of multiple instances (i.e. the + -- store). See issue #3932. So we require Cabal 1.20 as a minimum. + -- + -- Moreover, lib:Cabal generally only supports the interface of + -- current and past compilers; in fact recent lib:Cabal versions + -- will warn when they encounter a too new or unknown GHC compiler + -- version (c.f. #415). To avoid running into unsupported + -- configurations we encode the compatibility matrix as lower + -- bounds on lib:Cabal here (effectively corresponding to the + -- respective major Cabal version bundled with the respective GHC + -- release). + -- + -- GHC 9.2 needs Cabal >= 3.6 + -- GHC 9.0 needs Cabal >= 3.4 + -- GHC 8.10 needs Cabal >= 3.2 + -- GHC 8.8 needs Cabal >= 3.0 + -- GHC 8.6 needs Cabal >= 2.4 + -- GHC 8.4 needs Cabal >= 2.2 + -- GHC 8.2 needs Cabal >= 2.0 + -- GHC 8.0 needs Cabal >= 1.24 + -- GHC 7.10 needs Cabal >= 1.22 + -- + -- (NB: we don't need to consider older GHCs as Cabal >= 1.20 is + -- the absolute lower bound) + -- + -- TODO: long-term, this compatibility matrix should be + -- stored as a field inside 'Distribution.Compiler.Compiler' + setupMinCabalVersionConstraint + | isGHC, compVer >= mkVersion [9, 6] = mkVersion [3, 10] + | isGHC, compVer >= mkVersion [9, 4] = mkVersion [3, 8] + | isGHC, compVer >= mkVersion [9, 2] = mkVersion [3, 6] + | isGHC, compVer >= mkVersion [9, 0] = mkVersion [3, 4] + | isGHC, compVer >= mkVersion [8, 10] = mkVersion [3, 2] + | isGHC, compVer >= mkVersion [8, 8] = mkVersion [3, 0] + | isGHC, compVer >= mkVersion [8, 6] = mkVersion [2, 4] + | isGHC, compVer >= mkVersion [8, 4] = mkVersion [2, 2] + | isGHC, compVer >= mkVersion [8, 2] = mkVersion [2, 0] + | isGHC, compVer >= mkVersion [8, 0] = mkVersion [1, 24] + | isGHC, compVer >= mkVersion [7, 10] = mkVersion [1, 22] + | otherwise = mkVersion [1, 20] + where + isGHC = compFlav `elem` [GHC, GHCJS] + compFlav = compilerFlavor comp + compVer = compilerVersion comp - -- As we can't predict the future, we also place a global upper - -- bound on the lib:Cabal version we know how to interact with: - -- - -- The upper bound is computed by incrementing the current major - -- version twice in order to allow for the current version, as - -- well as the next adjacent major version (one of which will not - -- be released, as only "even major" versions of Cabal are - -- released to Hackage or bundled with proper GHC releases). - -- - -- For instance, if the current version of cabal-install is an odd - -- development version, e.g. Cabal-2.1.0.0, then we impose an - -- upper bound `setup.Cabal < 2.3`; if `cabal-install` is on a - -- stable/release even version, e.g. Cabal-2.2.1.0, the upper - -- bound is `setup.Cabal < 2.4`. This gives us enough flexibility - -- when dealing with development snapshots of Cabal and cabal-install. - -- - setupMaxCabalVersionConstraint = - alterVersion (take 2) $ incVersion 1 $ incVersion 1 cabalVersion + -- As we can't predict the future, we also place a global upper + -- bound on the lib:Cabal version we know how to interact with: + -- + -- The upper bound is computed by incrementing the current major + -- version twice in order to allow for the current version, as + -- well as the next adjacent major version (one of which will not + -- be released, as only "even major" versions of Cabal are + -- released to Hackage or bundled with proper GHC releases). + -- + -- For instance, if the current version of cabal-install is an odd + -- development version, e.g. Cabal-2.1.0.0, then we impose an + -- upper bound `setup.Cabal < 2.3`; if `cabal-install` is on a + -- stable/release even version, e.g. Cabal-2.2.1.0, the upper + -- bound is `setup.Cabal < 2.4`. This gives us enough flexibility + -- when dealing with development snapshots of Cabal and cabal-install. + -- + setupMaxCabalVersionConstraint = + alterVersion (take 2) $ incVersion 1 $ incVersion 1 cabalVersion ------------------------------------------------------------------------------ + -- * Install plan post-processing + ------------------------------------------------------------------------------ -- This phase goes from the InstallPlan we get from the solver and has to @@ -1275,11 +1445,10 @@ planPackages verbosity comp platform solver SolverSettings{..} -- way to calculate the installed package ids used for the replacement step is -- from the elaborated configuration for each package. - - - ------------------------------------------------------------------------------ + -- * Install plan elaboration + ------------------------------------------------------------------------------ -- Note [SolverId to ConfiguredId] @@ -1298,7 +1467,9 @@ planPackages verbosity comp platform solver SolverSettings{..} -- library dependencies on lib-0.2, and executable dependencies on pkg-0.1 -- and alex-0.3 (other components of the package may have different -- dependencies). Note that I've "lost" the knowledge that I depend --- *specifically* on the exe1 executable from pkg. + +-- * specifically* on the exe1 executable from pkg. + -- -- So, we have a this graph of packages, and we need to transform it into -- a graph of components which we are actually going to build. In particular: @@ -1353,15 +1524,17 @@ planPackages verbosity comp platform solver SolverSettings{..} -- like a 'ConfiguredId', in that it incorporates the version choices of its -- dependencies, but less fine grained. - -- | Produce an elaborated install plan using the policy for local builds with -- a nix-style shared store. -- -- In theory should be able to make an elaborated install plan with a policy -- matching that of the classic @cabal install --user@ or @--global@ --- elaborateInstallPlan - :: Verbosity -> Platform -> Compiler -> ProgramDb -> PkgConfigDb + :: Verbosity + -> Platform + -> Compiler + -> ProgramDb + -> PkgConfigDb -> DistDirLayout -> StoreDirLayout -> SolverInstallPlan @@ -1373,762 +1546,884 @@ elaborateInstallPlan -> PackageConfig -> Map PackageName PackageConfig -> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig) -elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB - distDirLayout@DistDirLayout{..} - storeDirLayout@StoreDirLayout{storePackageDBStack} - solverPlan localPackages - sourcePackageHashes - defaultInstallDirs - sharedPackageConfig - allPackagesConfig - localPackagesConfig - perPackageConfig = do +elaborateInstallPlan + verbosity + platform + compiler + compilerprogdb + pkgConfigDB + distDirLayout@DistDirLayout{..} + storeDirLayout@StoreDirLayout{storePackageDBStack} + solverPlan + localPackages + sourcePackageHashes + defaultInstallDirs + sharedPackageConfig + allPackagesConfig + localPackagesConfig + perPackageConfig = do x <- elaboratedInstallPlan return (x, elaboratedSharedConfig) - where - elaboratedSharedConfig = - ElaboratedSharedConfig { - pkgConfigPlatform = platform, - pkgConfigCompiler = compiler, - pkgConfigCompilerProgs = compilerprogdb, - pkgConfigReplOptions = mempty - } - - preexistingInstantiatedPkgs :: Map UnitId FullUnitId - preexistingInstantiatedPkgs = + where + elaboratedSharedConfig = + ElaboratedSharedConfig + { pkgConfigPlatform = platform + , pkgConfigCompiler = compiler + , pkgConfigCompilerProgs = compilerprogdb + , pkgConfigReplOptions = mempty + } + + preexistingInstantiatedPkgs :: Map UnitId FullUnitId + preexistingInstantiatedPkgs = Map.fromList (mapMaybe f (SolverInstallPlan.toList solverPlan)) - where - f (SolverInstallPlan.PreExisting inst) + where + f (SolverInstallPlan.PreExisting inst) | let ipkg = instSolverPkgIPI inst - , not (IPI.indefinite ipkg) - = Just (IPI.installedUnitId ipkg, - (FullUnitId (IPI.installedComponentId ipkg) - (Map.fromList (IPI.instantiatedWith ipkg)))) - f _ = Nothing - - elaboratedInstallPlan :: - LogProgress (InstallPlan.GenericInstallPlan IPI.InstalledPackageInfo ElaboratedConfiguredPackage) - elaboratedInstallPlan = - flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg -> - case planpkg of - SolverInstallPlan.PreExisting pkg -> - return [InstallPlan.PreExisting (instSolverPkgIPI pkg)] - - SolverInstallPlan.Configured pkg -> - let inplace_doc | shouldBuildInplaceOnly pkg = text "inplace" - | otherwise = Disp.empty - in addProgressCtx (text "In the" <+> inplace_doc <+> text "package" <+> - quotes (pretty (packageId pkg))) $ - map InstallPlan.Configured <$> elaborateSolverToComponents mapDep pkg - - -- NB: We don't INSTANTIATE packages at this point. That's - -- a post-pass. This makes it simpler to compute dependencies. - elaborateSolverToComponents + , not (IPI.indefinite ipkg) = + Just + ( IPI.installedUnitId ipkg + , ( FullUnitId + (IPI.installedComponentId ipkg) + (Map.fromList (IPI.instantiatedWith ipkg)) + ) + ) + f _ = Nothing + + elaboratedInstallPlan + :: LogProgress (InstallPlan.GenericInstallPlan IPI.InstalledPackageInfo ElaboratedConfiguredPackage) + elaboratedInstallPlan = + flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg -> + case planpkg of + SolverInstallPlan.PreExisting pkg -> + return [InstallPlan.PreExisting (instSolverPkgIPI pkg)] + SolverInstallPlan.Configured pkg -> + let inplace_doc + | shouldBuildInplaceOnly pkg = text "inplace" + | otherwise = Disp.empty + in addProgressCtx + ( text "In the" + <+> inplace_doc + <+> text "package" + <+> quotes (pretty (packageId pkg)) + ) + $ map InstallPlan.Configured <$> elaborateSolverToComponents mapDep pkg + + -- NB: We don't INSTANTIATE packages at this point. That's + -- a post-pass. This makes it simpler to compute dependencies. + elaborateSolverToComponents :: (SolverId -> [ElaboratedPlanPackage]) -> SolverPackage UnresolvedPkgLoc -> LogProgress [ElaboratedConfiguredPackage] - elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ deps0 exe_deps0) - = case mkComponentsGraph (elabEnabledSpec elab0) pd of - Right g -> do + elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ deps0 exe_deps0) = + case mkComponentsGraph (elabEnabledSpec elab0) pd of + Right g -> do let src_comps = componentsGraphToList g - infoProgress $ hang (text "Component graph for" <+> pretty pkgid <<>> colon) - 4 (dispComponentsWithDeps src_comps) - (_, comps) <- mapAccumM buildComponent - (Map.empty, Map.empty, Map.empty) - (map fst src_comps) + infoProgress $ + hang + (text "Component graph for" <+> pretty pkgid <<>> colon) + 4 + (dispComponentsWithDeps src_comps) + (_, comps) <- + mapAccumM + buildComponent + (Map.empty, Map.empty, Map.empty) + (map fst src_comps) let not_per_component_reasons = why_not_per_component src_comps if null not_per_component_reasons - then return comps - else do checkPerPackageOk comps not_per_component_reasons - return [elaborateSolverToPackage spkg g $ - comps ++ maybeToList setupComponent] - Left cns -> + then return comps + else do + checkPerPackageOk comps not_per_component_reasons + return + [ elaborateSolverToPackage spkg g $ + comps ++ maybeToList setupComponent + ] + Left cns -> dieProgress $ - hang (text "Dependency cycle between the following components:") 4 - (vcat (map (text . componentNameStanza) cns)) - where - -- 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 ++ cuz_coverage - where - cuz reason = [text reason] - -- We have to disable per-component for now with - -- Configure-type scripts in order to prevent parallel - -- invocation of the same `./configure` script. - -- See https://github.com/haskell/cabal/issues/4548 - -- - -- Moreover, at this point in time, only non-Custom setup scripts - -- are supported. Implementing per-component builds with - -- Custom would require us to create a new 'ElabSetup' - -- type, and teach all of the code paths how to handle it. - -- Once you've implemented this, swap it for the code below. - cuz_buildtype = + hang + (text "Dependency cycle between the following components:") + 4 + (vcat (map (text . componentNameStanza) cns)) + where + -- 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 ++ cuz_coverage + where + cuz reason = [text reason] + -- We have to disable per-component for now with + -- Configure-type scripts in order to prevent parallel + -- invocation of the same `./configure` script. + -- See https://github.com/haskell/cabal/issues/4548 + -- + -- Moreover, at this point in time, only non-Custom setup scripts + -- are supported. Implementing per-component builds with + -- Custom would require us to create a new 'ElabSetup' + -- type, and teach all of the code paths how to handle it. + -- Once you've implemented this, swap it for the code below. + cuz_buildtype = case PD.buildType (elabPkgDescription elab0) of - PD.Configure -> cuz "build-type is Configure" - PD.Custom -> cuz "build-type is Custom" - _ -> [] - -- 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 - cuz_spec + PD.Configure -> cuz "build-type is Configure" + PD.Custom -> cuz "build-type is Custom" + _ -> [] + -- 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 + cuz_spec | PD.specVersion pd >= CabalSpecV1_8 = [] | otherwise = cuz "cabal-version is less than 1.8" - -- In the odd corner case that a package has no components at all - -- then keep it as a whole package, since otherwise it turns into - -- 0 component graph nodes and effectively vanishes. We want to - -- keep it around at least for error reporting purposes. - cuz_length + -- In the odd corner case that a package has no components at all + -- then keep it as a whole package, since otherwise it turns into + -- 0 component graph nodes and effectively vanishes. We want to + -- keep it around at least for error reporting purposes. + cuz_length | length g > 0 = [] - | otherwise = cuz "there are no buildable components" - -- For ease of testing, we let per-component builds be toggled - -- at the top level - cuz_flag - | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig) - = [] + | otherwise = cuz "there are no buildable components" + -- For ease of testing, we let per-component builds be toggled + -- at the top level + cuz_flag + | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig) = + [] | otherwise = cuz "you passed --disable-per-component" - -- Enabling program coverage introduces odd runtime dependencies - -- between components. - cuz_coverage - | fromFlagOrDefault False (packageConfigCoverage localPackagesConfig) - = cuz "program coverage is enabled" + -- Enabling program coverage introduces odd runtime dependencies + -- between components. + cuz_coverage + | fromFlagOrDefault False (packageConfigCoverage localPackagesConfig) = + cuz "program coverage is enabled" | otherwise = [] - -- | Sometimes a package may make use of features which are only - -- supported in per-package mode. If this is the case, we should - -- give an error when this occurs. - checkPerPackageOk comps reasons = do + -- \| Sometimes a package may make use of features which are only + -- supported in per-package mode. If this is the case, we should + -- give an error when this occurs. + checkPerPackageOk comps reasons = do let is_sublib (CLibName (LSubLibName _)) = True is_sublib _ = False when (any (matchElabPkg is_sublib) comps) $ - dieProgress $ - text "Internal libraries only supported with per-component builds." $$ - text "Per-component builds were disabled because" <+> - fsep (punctuate comma reasons) - -- TODO: Maybe exclude Backpack too - - elab0 = elaborateSolverToCommon spkg - pkgid = elabPkgSourceId elab0 - pd = elabPkgDescription elab0 - - -- TODO: This is just a skeleton to get elaborateSolverToPackage - -- working correctly - -- TODO: When we actually support building these components, we - -- have to add dependencies on this from all other components - setupComponent :: Maybe ElaboratedConfiguredPackage - setupComponent - | PD.buildType (elabPkgDescription elab0) == PD.Custom - = Just elab0 { - elabModuleShape = emptyModuleShape, - elabUnitId = notImpl "elabUnitId", - elabComponentId = notImpl "elabComponentId", - elabLinkedInstantiatedWith = Map.empty, - elabInstallDirs = notImpl "elabInstallDirs", - elabPkgOrComp = ElabComponent (ElaboratedComponent {..}) - } - | otherwise - = Nothing - where - compSolverName = CD.ComponentSetup - compComponentName = Nothing - dep_pkgs = elaborateLibSolverId mapDep =<< CD.setupDeps deps0 - compLibDependencies - -- MP: No idea what this function does - = map (\cid -> (configuredId cid, False)) dep_pkgs - compLinkedLibDependencies = notImpl "compLinkedLibDependencies" - compOrderLibDependencies = notImpl "compOrderLibDependencies" - -- Not supported: - compExeDependencies = [] - compExeDependencyPaths = [] - compPkgConfigDependencies = [] - - notImpl f = - error $ "Distribution.Client.ProjectPlanning.setupComponent: " ++ - f ++ " not implemented yet" - - - buildComponent - :: (ConfiguredComponentMap, - LinkedComponentMap, - Map ComponentId FilePath) + dieProgress $ + text "Internal libraries only supported with per-component builds." + $$ text "Per-component builds were disabled because" + <+> fsep (punctuate comma reasons) + -- TODO: Maybe exclude Backpack too + + elab0 = elaborateSolverToCommon spkg + pkgid = elabPkgSourceId elab0 + pd = elabPkgDescription elab0 + + -- TODO: This is just a skeleton to get elaborateSolverToPackage + -- working correctly + -- TODO: When we actually support building these components, we + -- have to add dependencies on this from all other components + setupComponent :: Maybe ElaboratedConfiguredPackage + setupComponent + | PD.buildType (elabPkgDescription elab0) == PD.Custom = + Just + elab0 + { elabModuleShape = emptyModuleShape + , elabUnitId = notImpl "elabUnitId" + , elabComponentId = notImpl "elabComponentId" + , elabLinkedInstantiatedWith = Map.empty + , elabInstallDirs = notImpl "elabInstallDirs" + , elabPkgOrComp = ElabComponent (ElaboratedComponent{..}) + } + | otherwise = + Nothing + where + compSolverName = CD.ComponentSetup + compComponentName = Nothing + dep_pkgs = elaborateLibSolverId mapDep =<< CD.setupDeps deps0 + compLibDependencies = + -- MP: No idea what this function does + map (\cid -> (configuredId cid, False)) dep_pkgs + compLinkedLibDependencies = notImpl "compLinkedLibDependencies" + compOrderLibDependencies = notImpl "compOrderLibDependencies" + -- Not supported: + compExeDependencies = [] + compExeDependencyPaths = [] + compPkgConfigDependencies = [] + + notImpl f = + error $ + "Distribution.Client.ProjectPlanning.setupComponent: " + ++ f + ++ " not implemented yet" + + buildComponent + :: ( ConfiguredComponentMap + , LinkedComponentMap + , Map ComponentId FilePath + ) -> Cabal.Component -> LogProgress - ((ConfiguredComponentMap, - LinkedComponentMap, - Map ComponentId FilePath), - ElaboratedConfiguredPackage) - buildComponent (cc_map, lc_map, exe_map) comp = - addProgressCtx (text "In the stanza" <+> - quotes (text (componentNameStanza cname))) $ do - - -- 1. Configure the component, but with a place holder ComponentId. - cc0 <- toConfiguredComponent + ( ( ConfiguredComponentMap + , LinkedComponentMap + , Map ComponentId FilePath + ) + , ElaboratedConfiguredPackage + ) + buildComponent (cc_map, lc_map, exe_map) comp = + addProgressCtx + ( text "In the stanza" + <+> quotes (text (componentNameStanza cname)) + ) + $ do + -- 1. Configure the component, but with a place holder ComponentId. + cc0 <- + toConfiguredComponent pd (error "Distribution.Client.ProjectPlanning.cc_cid: filled in later") (Map.unionWith Map.union external_lib_cc_map cc_map) (Map.unionWith Map.union external_exe_cc_map cc_map) comp - let do_ cid = - let cid' = annotatedIdToConfiguredId . ci_ann_id $ cid - in (cid', False) -- filled in later in pruneInstallPlanPhase2) - -- 2. Read out the dependencies from the ConfiguredComponent cc0 - let compLibDependencies = - -- Nub because includes can show up multiple times - ordNub (map (\cid -> do_ cid ) - (cc_includes cc0)) - compExeDependencies = - map annotatedIdToConfiguredId + let do_ cid = + let cid' = annotatedIdToConfiguredId . ci_ann_id $ cid + in (cid', False) -- filled in later in pruneInstallPlanPhase2) + -- 2. Read out the dependencies from the ConfiguredComponent cc0 + let compLibDependencies = + -- Nub because includes can show up multiple times + ordNub + ( map + (\cid -> do_ cid) + (cc_includes cc0) + ) + compExeDependencies = + map + annotatedIdToConfiguredId (cc_exe_deps cc0) - compExeDependencyPaths = - [ (annotatedIdToConfiguredId aid', path) - | aid' <- cc_exe_deps cc0 - , Just paths <- [Map.lookup (ann_id aid') exe_map1] - , path <- paths ] - elab_comp = ElaboratedComponent {..} - - -- 3. Construct a preliminary ElaboratedConfiguredPackage, - -- and use this to compute the component ID. Fix up cc_id - -- correctly. - let elab1 = elab0 { - elabPkgOrComp = ElabComponent $ elab_comp - } - cid = case elabBuildStyle elab0 of - BuildInplaceOnly {} -> - mkComponentId $ - prettyShow pkgid ++ "-inplace" ++ - (case Cabal.componentNameString cname of + compExeDependencyPaths = + [ (annotatedIdToConfiguredId aid', path) + | aid' <- cc_exe_deps cc0 + , Just paths <- [Map.lookup (ann_id aid') exe_map1] + , path <- paths + ] + elab_comp = ElaboratedComponent{..} + + -- 3. Construct a preliminary ElaboratedConfiguredPackage, + -- and use this to compute the component ID. Fix up cc_id + -- correctly. + let elab1 = + elab0 + { elabPkgOrComp = ElabComponent $ elab_comp + } + cid = case elabBuildStyle elab0 of + BuildInplaceOnly{} -> + mkComponentId $ + prettyShow pkgid + ++ "-inplace" + ++ ( case Cabal.componentNameString cname of Nothing -> "" - Just s -> "-" ++ prettyShow s) - BuildAndInstall -> - hashedInstalledPackageId - (packageHashInputs - elaboratedSharedConfig - elab1) -- knot tied - cc = cc0 { cc_ann_id = fmap (const cid) (cc_ann_id cc0) } - infoProgress $ dispConfiguredComponent cc - - -- 4. Perform mix-in linking - let lookup_uid def_uid = - case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of + Just s -> "-" ++ prettyShow s + ) + BuildAndInstall -> + hashedInstalledPackageId + ( packageHashInputs + elaboratedSharedConfig + elab1 -- knot tied + ) + cc = cc0{cc_ann_id = fmap (const cid) (cc_ann_id cc0)} + infoProgress $ dispConfiguredComponent cc + + -- 4. Perform mix-in linking + let lookup_uid def_uid = + case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of Just full -> full Nothing -> error ("lookup_uid: " ++ prettyShow def_uid) - lc <- toLinkedComponent verbosity False lookup_uid (elabPkgSourceId elab0) - (Map.union external_lc_map lc_map) cc - infoProgress $ dispLinkedComponent lc - -- NB: elab is setup to be the correct form for an - -- indefinite library, or a definite library with no holes. - -- We will modify it in 'instantiateInstallPlan' to handle - -- instantiated packages. - - -- 5. Construct the final ElaboratedConfiguredPackage - let - elab2 = elab1 { - elabModuleShape = lc_shape lc, - elabUnitId = abstractUnitId (lc_uid lc), - elabComponentId = lc_cid lc, - elabLinkedInstantiatedWith = Map.fromList (lc_insts lc), - elabPkgOrComp = ElabComponent $ elab_comp { - compLinkedLibDependencies = ordNub (map ci_id (lc_includes lc)), - compOrderLibDependencies = - ordNub (map (abstractUnitId . ci_id) - (lc_includes lc ++ lc_sig_includes lc)) + lc <- + toLinkedComponent + verbosity + False + lookup_uid + (elabPkgSourceId elab0) + (Map.union external_lc_map lc_map) + cc + infoProgress $ dispLinkedComponent lc + -- NB: elab is setup to be the correct form for an + -- indefinite library, or a definite library with no holes. + -- We will modify it in 'instantiateInstallPlan' to handle + -- instantiated packages. + + -- 5. Construct the final ElaboratedConfiguredPackage + let + elab2 = + elab1 + { elabModuleShape = lc_shape lc + , elabUnitId = abstractUnitId (lc_uid lc) + , elabComponentId = lc_cid lc + , elabLinkedInstantiatedWith = Map.fromList (lc_insts lc) + , elabPkgOrComp = + ElabComponent $ + elab_comp + { compLinkedLibDependencies = ordNub (map ci_id (lc_includes lc)) + , compOrderLibDependencies = + ordNub + ( map + (abstractUnitId . ci_id) + (lc_includes lc ++ lc_sig_includes lc) + ) + } + } + elab = + elab2 + { elabInstallDirs = + computeInstallDirs + storeDirLayout + defaultInstallDirs + elaboratedSharedConfig + elab2 } - } - elab = elab2 { - elabInstallDirs = computeInstallDirs - storeDirLayout - defaultInstallDirs - elaboratedSharedConfig - elab2 - } - -- 6. Construct the updated local maps - let cc_map' = extendConfiguredComponentMap cc cc_map - lc_map' = extendLinkedComponentMap lc lc_map - exe_map' = Map.insert cid (inplace_bin_dir elab) exe_map + -- 6. Construct the updated local maps + let cc_map' = extendConfiguredComponentMap cc cc_map + lc_map' = extendLinkedComponentMap lc lc_map + exe_map' = Map.insert cid (inplace_bin_dir elab) exe_map - return ((cc_map', lc_map', exe_map'), elab) - where - compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies" - compOrderLibDependencies = error "buildComponent: compOrderLibDependencies" - - cname = Cabal.componentName comp - compComponentName = Just cname - compSolverName = CD.componentNameToComponent cname - - -- NB: compLinkedLibDependencies and - -- compOrderLibDependencies are defined when we define - -- 'elab'. - external_lib_dep_sids = CD.select (== compSolverName) deps0 - external_exe_dep_sids = CD.select (== compSolverName) exe_deps0 - - external_lib_dep_pkgs = concatMap mapDep external_lib_dep_sids - - -- Combine library and build-tool dependencies, for backwards - -- compatibility (See issue #5412 and the documentation for - -- InstallPlan.fromSolverInstallPlan), but prefer the versions - -- specified as build-tools. - external_exe_dep_pkgs = + return ((cc_map', lc_map', exe_map'), elab) + where + compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies" + compOrderLibDependencies = error "buildComponent: compOrderLibDependencies" + + cname = Cabal.componentName comp + compComponentName = Just cname + compSolverName = CD.componentNameToComponent cname + + -- NB: compLinkedLibDependencies and + -- compOrderLibDependencies are defined when we define + -- 'elab'. + external_lib_dep_sids = CD.select (== compSolverName) deps0 + external_exe_dep_sids = CD.select (== compSolverName) exe_deps0 + + external_lib_dep_pkgs = concatMap mapDep external_lib_dep_sids + + -- Combine library and build-tool dependencies, for backwards + -- compatibility (See issue #5412 and the documentation for + -- InstallPlan.fromSolverInstallPlan), but prefer the versions + -- specified as build-tools. + external_exe_dep_pkgs = concatMap mapDep $ - ordNubBy (pkgName . packageId) $ - external_exe_dep_sids ++ external_lib_dep_sids - - external_exe_map = Map.fromList $ - [ (getComponentId pkg, paths) - | pkg <- external_exe_dep_pkgs - , let paths = planPackageExePaths pkg ] - exe_map1 = Map.union external_exe_map $ fmap (\x -> [x]) exe_map - - external_lib_cc_map = Map.fromListWith Map.union - $ map mkCCMapping external_lib_dep_pkgs - external_exe_cc_map = Map.fromListWith Map.union - $ map mkCCMapping external_exe_dep_pkgs - external_lc_map = - Map.fromList $ map mkShapeMapping $ - external_lib_dep_pkgs ++ concatMap mapDep external_exe_dep_sids - - compPkgConfigDependencies = - [ (pn, fromMaybe (error $ "compPkgConfigDependencies: impossible! " - ++ prettyShow pn ++ " from " - ++ prettyShow (elabPkgSourceId elab0)) - (pkgConfigDbPkgVersion pkgConfigDB pn)) - | PkgconfigDependency pn _ <- PD.pkgconfigDepends - (Cabal.componentBuildInfo comp) ] - - inplace_bin_dir elab = + ordNubBy (pkgName . packageId) $ + external_exe_dep_sids ++ external_lib_dep_sids + + external_exe_map = + Map.fromList $ + [ (getComponentId pkg, paths) + | pkg <- external_exe_dep_pkgs + , let paths = planPackageExePaths pkg + ] + exe_map1 = Map.union external_exe_map $ fmap (\x -> [x]) exe_map + + external_lib_cc_map = + Map.fromListWith Map.union $ + map mkCCMapping external_lib_dep_pkgs + external_exe_cc_map = + Map.fromListWith Map.union $ + map mkCCMapping external_exe_dep_pkgs + external_lc_map = + Map.fromList $ + map mkShapeMapping $ + external_lib_dep_pkgs ++ concatMap mapDep external_exe_dep_sids + + compPkgConfigDependencies = + [ ( pn + , fromMaybe + ( error $ + "compPkgConfigDependencies: impossible! " + ++ prettyShow pn + ++ " from " + ++ prettyShow (elabPkgSourceId elab0) + ) + (pkgConfigDbPkgVersion pkgConfigDB pn) + ) + | PkgconfigDependency pn _ <- + PD.pkgconfigDepends + (Cabal.componentBuildInfo comp) + ] + + inplace_bin_dir elab = binDirectoryFor - distDirLayout - elaboratedSharedConfig - elab $ - case Cabal.componentNameString cname of - Just n -> prettyShow n - Nothing -> "" - - - -- | Given a 'SolverId' referencing a dependency on a library, return - -- the 'ElaboratedPlanPackage' corresponding to the library. This - -- returns at most one result. - elaborateLibSolverId :: (SolverId -> [ElaboratedPlanPackage]) - -> SolverId -> [ElaboratedPlanPackage] - elaborateLibSolverId mapDep = filter (matchPlanPkg (== (CLibName LMainLibName))) . mapDep - - -- | Given an 'ElaboratedPlanPackage', return the paths to where the - -- executables that this package represents would be installed. - -- The only case where multiple paths can be returned is the inplace - -- monolithic package one, since there can be multiple exes and each one - -- has its own directory. - planPackageExePaths :: ElaboratedPlanPackage -> [FilePath] - planPackageExePaths = + distDirLayout + elaboratedSharedConfig + elab + $ case Cabal.componentNameString cname of + Just n -> prettyShow n + Nothing -> "" + + -- \| Given a 'SolverId' referencing a dependency on a library, return + -- the 'ElaboratedPlanPackage' corresponding to the library. This + -- returns at most one result. + elaborateLibSolverId + :: (SolverId -> [ElaboratedPlanPackage]) + -> SolverId + -> [ElaboratedPlanPackage] + elaborateLibSolverId mapDep = filter (matchPlanPkg (== (CLibName LMainLibName))) . mapDep + + -- \| Given an 'ElaboratedPlanPackage', return the paths to where the + -- executables that this package represents would be installed. + -- The only case where multiple paths can be returned is the inplace + -- monolithic package one, since there can be multiple exes and each one + -- has its own directory. + planPackageExePaths :: ElaboratedPlanPackage -> [FilePath] + planPackageExePaths = -- Pre-existing executables are assumed to be in PATH -- already. In fact, this should be impossible. InstallPlan.foldPlanPackage (const []) $ \elab -> - let - executables :: [FilePath] - executables = - case elabPkgOrComp elab of - -- Monolithic mode: all exes of the package - ElabPackage _ -> unUnqualComponentName . PD.exeName - <$> PD.executables (elabPkgDescription elab) - -- Per-component mode: just the selected exe - ElabComponent comp -> - case fmap Cabal.componentNameString - (compComponentName comp) of - Just (Just n) -> [prettyShow n] - _ -> [""] - in - binDirectoryFor - distDirLayout - elaboratedSharedConfig - elab - <$> executables - - elaborateSolverToPackage :: SolverPackage UnresolvedPkgLoc - -> ComponentsGraph - -> [ElaboratedConfiguredPackage] - -> ElaboratedConfiguredPackage - elaborateSolverToPackage - pkg@(SolverPackage (SourcePackage pkgid _gpd _srcloc _descOverride) - _flags _stanzas _deps0 _exe_deps0) - compGraph comps = - -- Knot tying: the final elab includes the - -- pkgInstalledId, which is calculated by hashing many - -- of the other fields of the elaboratedPackage. - elab - where - elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon pkg - elab1 = elab0 { - elabUnitId = newSimpleUnitId pkgInstalledId, - elabComponentId = pkgInstalledId, - elabLinkedInstantiatedWith = Map.empty, - elabPkgOrComp = ElabPackage $ ElaboratedPackage {..}, - elabModuleShape = modShape - } - elab = elab1 { - elabInstallDirs = - computeInstallDirs storeDirLayout - defaultInstallDirs - elaboratedSharedConfig - elab1 - } - - modShape = case find (matchElabPkg (== (CLibName LMainLibName))) comps of - Nothing -> emptyModuleShape - Just e -> Ty.elabModuleShape e - - pkgInstalledId - | shouldBuildInplaceOnly pkg - = mkComponentId (prettyShow pkgid ++ "-inplace") - - | otherwise - = assert (isJust elabPkgSourceHash) $ - hashedInstalledPackageId - (packageHashInputs - elaboratedSharedConfig - elab) -- recursive use of elab - - -- Need to filter out internal dependencies, because they don't - -- correspond to anything real anymore. - isExt confid = confSrcId confid /= pkgid - filterExt = filter isExt - filterExt' = filter (isExt . fst) - - pkgLibDependencies - = buildComponentDeps (filterExt' . compLibDependencies) - pkgExeDependencies - = buildComponentDeps (filterExt . compExeDependencies) - pkgExeDependencyPaths - = buildComponentDeps (filterExt' . compExeDependencyPaths) - -- TODO: Why is this flat? - pkgPkgConfigDependencies - = CD.flatDeps $ buildComponentDeps compPkgConfigDependencies - - pkgDependsOnSelfLib - = CD.fromList [ (CD.componentNameToComponent cn, [()]) - | Graph.N _ cn _ <- fromMaybe [] mb_closure ] - where - mb_closure = Graph.revClosure compGraph [ k | k <- Graph.keys compGraph, is_lib k ] - -- NB: the sublib case should not occur, because sub-libraries - -- are not supported without per-component builds - is_lib (CLibName _) = True - is_lib _ = False - - buildComponentDeps f - = CD.fromList [ (compSolverName comp, f comp) - | ElaboratedConfiguredPackage{ - elabPkgOrComp = ElabComponent comp - } <- comps - ] - - -- NB: This is not the final setting of 'pkgStanzasEnabled'. - -- See [Sticky enabled testsuites]; we may enable some extra - -- stanzas opportunistically when it is cheap to do so. - -- - -- However, we start off by enabling everything that was - -- requested, so that we can maintain an invariant that - -- pkgStanzasEnabled is a superset of elabStanzasRequested - pkgStanzasEnabled = optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested - - elaborateSolverToCommon :: SolverPackage UnresolvedPkgLoc - -> ElaboratedConfiguredPackage - elaborateSolverToCommon - pkg@(SolverPackage (SourcePackage pkgid gdesc srcloc descOverride) - flags stanzas deps0 _exe_deps0) = - elaboratedPackage - where - elaboratedPackage = ElaboratedConfiguredPackage {..} - - -- These get filled in later - elabUnitId = error "elaborateSolverToCommon: elabUnitId" - elabComponentId = error "elaborateSolverToCommon: elabComponentId" - elabInstantiatedWith = Map.empty - elabLinkedInstantiatedWith = error "elaborateSolverToCommon: elabLinkedInstantiatedWith" - elabPkgOrComp = error "elaborateSolverToCommon: elabPkgOrComp" - elabInstallDirs = error "elaborateSolverToCommon: elabInstallDirs" - elabModuleShape = error "elaborateSolverToCommon: elabModuleShape" - - elabIsCanonical = True - elabPkgSourceId = pkgid - elabPkgDescription = case PD.finalizePD - flags elabEnabledSpec (const True) - platform (compilerInfo compiler) - [] gdesc of - Right (desc, _) -> desc - Left _ -> error "Failed to finalizePD in elaborateSolverToCommon" - elabFlagAssignment = flags - elabFlagDefaults = PD.mkFlagAssignment - [ (Cabal.flagName flag, Cabal.flagDefault flag) - | flag <- PD.genPackageFlags gdesc ] - - elabEnabledSpec = enableStanzas stanzas - elabStanzasAvailable = stanzas - - elabStanzasRequested :: OptionalStanzaMap (Maybe Bool) - elabStanzasRequested = optStanzaTabulate $ \o -> case o of - -- NB: even if a package stanza is requested, if the package - -- doesn't actually have any of that stanza we omit it from - -- the request, to ensure that we don't decide that this - -- package needs to be rebuilt. (It needs to be done here, - -- because the ElaboratedConfiguredPackage is where we test - -- whether or not there have been changes.) - TestStanzas -> listToMaybe [ v | v <- maybeToList tests, _ <- PD.testSuites elabPkgDescription ] - BenchStanzas -> listToMaybe [ v | v <- maybeToList benchmarks, _ <- PD.benchmarks elabPkgDescription ] + let + executables :: [FilePath] + executables = + case elabPkgOrComp elab of + -- Monolithic mode: all exes of the package + ElabPackage _ -> + unUnqualComponentName . PD.exeName + <$> PD.executables (elabPkgDescription elab) + -- Per-component mode: just the selected exe + ElabComponent comp -> + case fmap + Cabal.componentNameString + (compComponentName comp) of + Just (Just n) -> [prettyShow n] + _ -> [""] + in + binDirectoryFor + distDirLayout + elaboratedSharedConfig + elab + <$> executables + + elaborateSolverToPackage + :: SolverPackage UnresolvedPkgLoc + -> ComponentsGraph + -> [ElaboratedConfiguredPackage] + -> ElaboratedConfiguredPackage + elaborateSolverToPackage + pkg@( SolverPackage + (SourcePackage pkgid _gpd _srcloc _descOverride) + _flags + _stanzas + _deps0 + _exe_deps0 + ) + compGraph + comps = + -- Knot tying: the final elab includes the + -- pkgInstalledId, which is calculated by hashing many + -- of the other fields of the elaboratedPackage. + elab where - tests, benchmarks :: Maybe Bool - tests = perPkgOptionMaybe pkgid packageConfigTests - benchmarks = perPkgOptionMaybe pkgid packageConfigBenchmarks - - -- This is a placeholder which will get updated by 'pruneInstallPlanPass1' - -- and 'pruneInstallPlanPass2'. We can't populate it here - -- because whether or not tests/benchmarks should be enabled - -- is heuristically calculated based on whether or not the - -- dependencies of the test suite have already been installed, - -- but this function doesn't know what is installed (since - -- we haven't improved the plan yet), so we do it in another pass. - -- Check the comments of those functions for more details. - elabConfigureTargets = [] - elabBuildTargets = [] - elabTestTargets = [] - elabBenchTargets = [] - elabReplTarget = [] - elabHaddockTargets = [] - - elabBuildHaddocks = - perPkgOptionFlag pkgid False packageConfigDocumentation - - elabPkgSourceLocation = srcloc - elabPkgSourceHash = Map.lookup pkgid sourcePackageHashes - elabLocalToProject = isLocalToProject pkg - elabBuildStyle = if shouldBuildInplaceOnly pkg - then BuildInplaceOnly OnDisk else BuildAndInstall - elabPackageDbs = projectConfigPackageDBs sharedPackageConfig - elabBuildPackageDBStack = buildAndRegisterDbs - elabRegisterPackageDBStack = buildAndRegisterDbs - - elabSetupScriptStyle = packageSetupScriptStyle elabPkgDescription - elabSetupScriptCliVersion = - packageSetupScriptSpecVersion - elabSetupScriptStyle elabPkgDescription libDepGraph deps0 - elabSetupPackageDBStack = buildAndRegisterDbs - - elabInplaceBuildPackageDBStack = inplacePackageDbs - elabInplaceRegisterPackageDBStack = inplacePackageDbs - elabInplaceSetupPackageDBStack = inplacePackageDbs - - buildAndRegisterDbs - | shouldBuildInplaceOnly pkg = inplacePackageDbs - | otherwise = corePackageDbs - - elabPkgDescriptionOverride = descOverride - - elabVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib --TODO: [required feature]: also needs to be handled recursively - elabSharedLib = pkgid `Set.member` pkgsUseSharedLibrary - elabStaticLib = perPkgOptionFlag pkgid False packageConfigStaticLib - elabDynExe = perPkgOptionFlag pkgid False packageConfigDynExe - elabFullyStaticExe = perPkgOptionFlag pkgid False packageConfigFullyStaticExe - elabGHCiLib = perPkgOptionFlag pkgid False packageConfigGHCiLib --TODO: [required feature] needs to default to enabled on windows still - - elabProfExe = perPkgOptionFlag pkgid False packageConfigProf - elabProfLib = pkgid `Set.member` pkgsUseProfilingLibrary - - (elabProfExeDetail, - elabProfLibDetail) = perPkgOptionLibExeFlag pkgid ProfDetailDefault - packageConfigProfDetail - packageConfigProfLibDetail - elabCoverage = perPkgOptionFlag pkgid False packageConfigCoverage - - elabOptimization = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization - elabSplitObjs = perPkgOptionFlag pkgid False packageConfigSplitObjs - elabSplitSections = perPkgOptionFlag pkgid False packageConfigSplitSections - elabStripLibs = perPkgOptionFlag pkgid False packageConfigStripLibs - elabStripExes = perPkgOptionFlag pkgid False packageConfigStripExes - elabDebugInfo = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo - elabDumpBuildInfo = perPkgOptionFlag pkgid NoDumpBuildInfo packageConfigDumpBuildInfo - - -- Combine the configured compiler prog settings with the user-supplied - -- config. For the compiler progs any user-supplied config was taken - -- into account earlier when configuring the compiler so its ok that - -- our configured settings for the compiler override the user-supplied - -- config here. - elabProgramPaths = Map.fromList - [ (programId prog, programPath prog) - | prog <- configuredPrograms compilerprogdb ] - <> perPkgOptionMapLast pkgid packageConfigProgramPaths - elabProgramArgs = Map.fromList - [ (programId prog, args) - | prog <- configuredPrograms compilerprogdb - , let args = programOverrideArgs prog - , not (null args) - ] - <> perPkgOptionMapMappend pkgid packageConfigProgramArgs - elabProgramPathExtra = perPkgOptionNubList pkgid packageConfigProgramPathExtra - elabConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs - elabExtraLibDirs = perPkgOptionList pkgid packageConfigExtraLibDirs - elabExtraLibDirsStatic = perPkgOptionList pkgid packageConfigExtraLibDirsStatic - elabExtraFrameworkDirs = perPkgOptionList pkgid packageConfigExtraFrameworkDirs - elabExtraIncludeDirs = perPkgOptionList pkgid packageConfigExtraIncludeDirs - elabProgPrefix = perPkgOptionMaybe pkgid packageConfigProgPrefix - elabProgSuffix = perPkgOptionMaybe pkgid packageConfigProgSuffix - - - elabHaddockHoogle = perPkgOptionFlag pkgid False packageConfigHaddockHoogle - elabHaddockHtml = perPkgOptionFlag pkgid False packageConfigHaddockHtml - elabHaddockHtmlLocation = perPkgOptionMaybe pkgid packageConfigHaddockHtmlLocation - elabHaddockForeignLibs = perPkgOptionFlag pkgid False packageConfigHaddockForeignLibs - elabHaddockForHackage = perPkgOptionFlag pkgid Cabal.ForDevelopment packageConfigHaddockForHackage - elabHaddockExecutables = perPkgOptionFlag pkgid False packageConfigHaddockExecutables - elabHaddockTestSuites = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites - elabHaddockBenchmarks = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks - elabHaddockInternal = perPkgOptionFlag pkgid False packageConfigHaddockInternal - elabHaddockCss = perPkgOptionMaybe pkgid packageConfigHaddockCss - elabHaddockLinkedSource = perPkgOptionFlag pkgid False packageConfigHaddockLinkedSource - elabHaddockQuickJump = perPkgOptionFlag pkgid False packageConfigHaddockQuickJump - elabHaddockHscolourCss = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss - elabHaddockContents = perPkgOptionMaybe pkgid packageConfigHaddockContents - elabHaddockIndex = perPkgOptionMaybe pkgid packageConfigHaddockIndex - elabHaddockBaseUrl = perPkgOptionMaybe pkgid packageConfigHaddockBaseUrl - elabHaddockLib = perPkgOptionMaybe pkgid packageConfigHaddockLib - elabHaddockOutputDir = perPkgOptionMaybe pkgid packageConfigHaddockOutputDir - - elabTestMachineLog = perPkgOptionMaybe pkgid packageConfigTestMachineLog - elabTestHumanLog = perPkgOptionMaybe pkgid packageConfigTestHumanLog - elabTestShowDetails = perPkgOptionMaybe pkgid packageConfigTestShowDetails - elabTestKeepTix = perPkgOptionFlag pkgid False packageConfigTestKeepTix - elabTestWrapper = perPkgOptionMaybe pkgid packageConfigTestWrapper - elabTestFailWhenNoTestSuites = perPkgOptionFlag pkgid False packageConfigTestFailWhenNoTestSuites - elabTestTestOptions = perPkgOptionList pkgid packageConfigTestTestOptions - - elabBenchmarkOptions = perPkgOptionList pkgid packageConfigBenchmarkOptions - - perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a - perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a - perPkgOptionList :: PackageId -> (PackageConfig -> [a]) -> [a] - - perPkgOptionFlag pkgid def f = fromFlagOrDefault def (lookupPerPkgOption pkgid f) - perPkgOptionMaybe pkgid f = flagToMaybe (lookupPerPkgOption pkgid f) - perPkgOptionList pkgid f = lookupPerPkgOption pkgid f - perPkgOptionNubList pkgid f = fromNubList (lookupPerPkgOption pkgid f) - perPkgOptionMapLast pkgid f = getMapLast (lookupPerPkgOption pkgid f) - perPkgOptionMapMappend pkgid f = getMapMappend (lookupPerPkgOption pkgid f) - - perPkgOptionLibExeFlag pkgid def fboth flib = (exe, lib) - where - exe = fromFlagOrDefault def bothflag - lib = fromFlagOrDefault def (bothflag <> libflag) - - bothflag = lookupPerPkgOption pkgid fboth - libflag = lookupPerPkgOption pkgid flib + elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon pkg + elab1 = + elab0 + { elabUnitId = newSimpleUnitId pkgInstalledId + , elabComponentId = pkgInstalledId + , elabLinkedInstantiatedWith = Map.empty + , elabPkgOrComp = ElabPackage $ ElaboratedPackage{..} + , elabModuleShape = modShape + } + elab = + elab1 + { elabInstallDirs = + computeInstallDirs + storeDirLayout + defaultInstallDirs + elaboratedSharedConfig + elab1 + } - lookupPerPkgOption :: (Package pkg, Monoid m) - => pkg -> (PackageConfig -> m) -> m - lookupPerPkgOption pkg f = + modShape = case find (matchElabPkg (== (CLibName LMainLibName))) comps of + Nothing -> emptyModuleShape + Just e -> Ty.elabModuleShape e + + pkgInstalledId + | shouldBuildInplaceOnly pkg = + mkComponentId (prettyShow pkgid ++ "-inplace") + | otherwise = + assert (isJust elabPkgSourceHash) $ + hashedInstalledPackageId + ( packageHashInputs + elaboratedSharedConfig + elab -- recursive use of elab + ) + + -- Need to filter out internal dependencies, because they don't + -- correspond to anything real anymore. + isExt confid = confSrcId confid /= pkgid + filterExt = filter isExt + filterExt' = filter (isExt . fst) + + pkgLibDependencies = + buildComponentDeps (filterExt' . compLibDependencies) + pkgExeDependencies = + buildComponentDeps (filterExt . compExeDependencies) + pkgExeDependencyPaths = + buildComponentDeps (filterExt' . compExeDependencyPaths) + -- TODO: Why is this flat? + pkgPkgConfigDependencies = + CD.flatDeps $ buildComponentDeps compPkgConfigDependencies + + pkgDependsOnSelfLib = + CD.fromList + [ (CD.componentNameToComponent cn, [()]) + | Graph.N _ cn _ <- fromMaybe [] mb_closure + ] + where + mb_closure = Graph.revClosure compGraph [k | k <- Graph.keys compGraph, is_lib k] + -- NB: the sublib case should not occur, because sub-libraries + -- are not supported without per-component builds + is_lib (CLibName _) = True + is_lib _ = False + + buildComponentDeps f = + CD.fromList + [ (compSolverName comp, f comp) + | ElaboratedConfiguredPackage + { elabPkgOrComp = ElabComponent comp + } <- + comps + ] + + -- NB: This is not the final setting of 'pkgStanzasEnabled'. + -- See [Sticky enabled testsuites]; we may enable some extra + -- stanzas opportunistically when it is cheap to do so. + -- + -- However, we start off by enabling everything that was + -- requested, so that we can maintain an invariant that + -- pkgStanzasEnabled is a superset of elabStanzasRequested + pkgStanzasEnabled = optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested + + elaborateSolverToCommon + :: SolverPackage UnresolvedPkgLoc + -> ElaboratedConfiguredPackage + elaborateSolverToCommon + pkg@( SolverPackage + (SourcePackage pkgid gdesc srcloc descOverride) + flags + stanzas + deps0 + _exe_deps0 + ) = + elaboratedPackage + where + elaboratedPackage = ElaboratedConfiguredPackage{..} + + -- These get filled in later + elabUnitId = error "elaborateSolverToCommon: elabUnitId" + elabComponentId = error "elaborateSolverToCommon: elabComponentId" + elabInstantiatedWith = Map.empty + elabLinkedInstantiatedWith = error "elaborateSolverToCommon: elabLinkedInstantiatedWith" + elabPkgOrComp = error "elaborateSolverToCommon: elabPkgOrComp" + elabInstallDirs = error "elaborateSolverToCommon: elabInstallDirs" + elabModuleShape = error "elaborateSolverToCommon: elabModuleShape" + + elabIsCanonical = True + elabPkgSourceId = pkgid + elabPkgDescription = case PD.finalizePD + flags + elabEnabledSpec + (const True) + platform + (compilerInfo compiler) + [] + gdesc of + Right (desc, _) -> desc + Left _ -> error "Failed to finalizePD in elaborateSolverToCommon" + elabFlagAssignment = flags + elabFlagDefaults = + PD.mkFlagAssignment + [ (Cabal.flagName flag, Cabal.flagDefault flag) + | flag <- PD.genPackageFlags gdesc + ] + + elabEnabledSpec = enableStanzas stanzas + elabStanzasAvailable = stanzas + + elabStanzasRequested :: OptionalStanzaMap (Maybe Bool) + elabStanzasRequested = optStanzaTabulate $ \o -> case o of + -- NB: even if a package stanza is requested, if the package + -- doesn't actually have any of that stanza we omit it from + -- the request, to ensure that we don't decide that this + -- package needs to be rebuilt. (It needs to be done here, + -- because the ElaboratedConfiguredPackage is where we test + -- whether or not there have been changes.) + TestStanzas -> listToMaybe [v | v <- maybeToList tests, _ <- PD.testSuites elabPkgDescription] + BenchStanzas -> listToMaybe [v | v <- maybeToList benchmarks, _ <- PD.benchmarks elabPkgDescription] + where + tests, benchmarks :: Maybe Bool + tests = perPkgOptionMaybe pkgid packageConfigTests + benchmarks = perPkgOptionMaybe pkgid packageConfigBenchmarks + + -- This is a placeholder which will get updated by 'pruneInstallPlanPass1' + -- and 'pruneInstallPlanPass2'. We can't populate it here + -- because whether or not tests/benchmarks should be enabled + -- is heuristically calculated based on whether or not the + -- dependencies of the test suite have already been installed, + -- but this function doesn't know what is installed (since + -- we haven't improved the plan yet), so we do it in another pass. + -- Check the comments of those functions for more details. + elabConfigureTargets = [] + elabBuildTargets = [] + elabTestTargets = [] + elabBenchTargets = [] + elabReplTarget = [] + elabHaddockTargets = [] + + elabBuildHaddocks = + perPkgOptionFlag pkgid False packageConfigDocumentation + + elabPkgSourceLocation = srcloc + elabPkgSourceHash = Map.lookup pkgid sourcePackageHashes + elabLocalToProject = isLocalToProject pkg + elabBuildStyle = + if shouldBuildInplaceOnly pkg + then BuildInplaceOnly OnDisk + else BuildAndInstall + elabPackageDbs = projectConfigPackageDBs sharedPackageConfig + elabBuildPackageDBStack = buildAndRegisterDbs + elabRegisterPackageDBStack = buildAndRegisterDbs + + elabSetupScriptStyle = packageSetupScriptStyle elabPkgDescription + elabSetupScriptCliVersion = + packageSetupScriptSpecVersion + elabSetupScriptStyle + elabPkgDescription + libDepGraph + deps0 + elabSetupPackageDBStack = buildAndRegisterDbs + + elabInplaceBuildPackageDBStack = inplacePackageDbs + elabInplaceRegisterPackageDBStack = inplacePackageDbs + elabInplaceSetupPackageDBStack = inplacePackageDbs + + buildAndRegisterDbs + | shouldBuildInplaceOnly pkg = inplacePackageDbs + | otherwise = corePackageDbs + + elabPkgDescriptionOverride = descOverride + + elabVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib -- TODO: [required feature]: also needs to be handled recursively + elabSharedLib = pkgid `Set.member` pkgsUseSharedLibrary + elabStaticLib = perPkgOptionFlag pkgid False packageConfigStaticLib + elabDynExe = perPkgOptionFlag pkgid False packageConfigDynExe + elabFullyStaticExe = perPkgOptionFlag pkgid False packageConfigFullyStaticExe + elabGHCiLib = perPkgOptionFlag pkgid False packageConfigGHCiLib -- TODO: [required feature] needs to default to enabled on windows still + elabProfExe = perPkgOptionFlag pkgid False packageConfigProf + elabProfLib = pkgid `Set.member` pkgsUseProfilingLibrary + + ( elabProfExeDetail + , elabProfLibDetail + ) = + perPkgOptionLibExeFlag + pkgid + ProfDetailDefault + packageConfigProfDetail + packageConfigProfLibDetail + elabCoverage = perPkgOptionFlag pkgid False packageConfigCoverage + + elabOptimization = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization + elabSplitObjs = perPkgOptionFlag pkgid False packageConfigSplitObjs + elabSplitSections = perPkgOptionFlag pkgid False packageConfigSplitSections + elabStripLibs = perPkgOptionFlag pkgid False packageConfigStripLibs + elabStripExes = perPkgOptionFlag pkgid False packageConfigStripExes + elabDebugInfo = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo + elabDumpBuildInfo = perPkgOptionFlag pkgid NoDumpBuildInfo packageConfigDumpBuildInfo + + -- Combine the configured compiler prog settings with the user-supplied + -- config. For the compiler progs any user-supplied config was taken + -- into account earlier when configuring the compiler so its ok that + -- our configured settings for the compiler override the user-supplied + -- config here. + elabProgramPaths = + Map.fromList + [ (programId prog, programPath prog) + | prog <- configuredPrograms compilerprogdb + ] + <> perPkgOptionMapLast pkgid packageConfigProgramPaths + elabProgramArgs = + Map.fromList + [ (programId prog, args) + | prog <- configuredPrograms compilerprogdb + , let args = programOverrideArgs prog + , not (null args) + ] + <> perPkgOptionMapMappend pkgid packageConfigProgramArgs + elabProgramPathExtra = perPkgOptionNubList pkgid packageConfigProgramPathExtra + elabConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs + elabExtraLibDirs = perPkgOptionList pkgid packageConfigExtraLibDirs + elabExtraLibDirsStatic = perPkgOptionList pkgid packageConfigExtraLibDirsStatic + elabExtraFrameworkDirs = perPkgOptionList pkgid packageConfigExtraFrameworkDirs + elabExtraIncludeDirs = perPkgOptionList pkgid packageConfigExtraIncludeDirs + elabProgPrefix = perPkgOptionMaybe pkgid packageConfigProgPrefix + elabProgSuffix = perPkgOptionMaybe pkgid packageConfigProgSuffix + + elabHaddockHoogle = perPkgOptionFlag pkgid False packageConfigHaddockHoogle + elabHaddockHtml = perPkgOptionFlag pkgid False packageConfigHaddockHtml + elabHaddockHtmlLocation = perPkgOptionMaybe pkgid packageConfigHaddockHtmlLocation + elabHaddockForeignLibs = perPkgOptionFlag pkgid False packageConfigHaddockForeignLibs + elabHaddockForHackage = perPkgOptionFlag pkgid Cabal.ForDevelopment packageConfigHaddockForHackage + elabHaddockExecutables = perPkgOptionFlag pkgid False packageConfigHaddockExecutables + elabHaddockTestSuites = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites + elabHaddockBenchmarks = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks + elabHaddockInternal = perPkgOptionFlag pkgid False packageConfigHaddockInternal + elabHaddockCss = perPkgOptionMaybe pkgid packageConfigHaddockCss + elabHaddockLinkedSource = perPkgOptionFlag pkgid False packageConfigHaddockLinkedSource + elabHaddockQuickJump = perPkgOptionFlag pkgid False packageConfigHaddockQuickJump + elabHaddockHscolourCss = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss + elabHaddockContents = perPkgOptionMaybe pkgid packageConfigHaddockContents + elabHaddockIndex = perPkgOptionMaybe pkgid packageConfigHaddockIndex + elabHaddockBaseUrl = perPkgOptionMaybe pkgid packageConfigHaddockBaseUrl + elabHaddockLib = perPkgOptionMaybe pkgid packageConfigHaddockLib + elabHaddockOutputDir = perPkgOptionMaybe pkgid packageConfigHaddockOutputDir + + elabTestMachineLog = perPkgOptionMaybe pkgid packageConfigTestMachineLog + elabTestHumanLog = perPkgOptionMaybe pkgid packageConfigTestHumanLog + elabTestShowDetails = perPkgOptionMaybe pkgid packageConfigTestShowDetails + elabTestKeepTix = perPkgOptionFlag pkgid False packageConfigTestKeepTix + elabTestWrapper = perPkgOptionMaybe pkgid packageConfigTestWrapper + elabTestFailWhenNoTestSuites = perPkgOptionFlag pkgid False packageConfigTestFailWhenNoTestSuites + elabTestTestOptions = perPkgOptionList pkgid packageConfigTestTestOptions + + elabBenchmarkOptions = perPkgOptionList pkgid packageConfigBenchmarkOptions + + perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a + perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a + perPkgOptionList :: PackageId -> (PackageConfig -> [a]) -> [a] + + perPkgOptionFlag pkgid def f = fromFlagOrDefault def (lookupPerPkgOption pkgid f) + perPkgOptionMaybe pkgid f = flagToMaybe (lookupPerPkgOption pkgid f) + perPkgOptionList pkgid f = lookupPerPkgOption pkgid f + perPkgOptionNubList pkgid f = fromNubList (lookupPerPkgOption pkgid f) + perPkgOptionMapLast pkgid f = getMapLast (lookupPerPkgOption pkgid f) + perPkgOptionMapMappend pkgid f = getMapMappend (lookupPerPkgOption pkgid f) + + perPkgOptionLibExeFlag pkgid def fboth flib = (exe, lib) + where + exe = fromFlagOrDefault def bothflag + lib = fromFlagOrDefault def (bothflag <> libflag) + + bothflag = lookupPerPkgOption pkgid fboth + libflag = lookupPerPkgOption pkgid flib + + lookupPerPkgOption + :: (Package pkg, Monoid m) + => pkg + -> (PackageConfig -> m) + -> m + lookupPerPkgOption pkg f = -- This is where we merge the options from the project config that -- apply to all packages, all project local packages, and to specific -- named packages global `mappend` local `mappend` perpkg - where - global = f allPackagesConfig - local | isLocalToProject pkg - = f localPackagesConfig - | otherwise - = mempty - perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig) - - inplacePackageDbs = corePackageDbs - ++ [ distPackageDB (compilerId compiler) ] - - corePackageDbs = applyPackageDbFlags (storePackageDBStack (compilerId compiler)) - (projectConfigPackageDBs sharedPackageConfig) - - -- For this local build policy, every package that lives in a local source - -- dir (as opposed to a tarball), or depends on such a package, will be - -- built inplace into a shared dist dir. Tarball packages that depend on - -- source dir packages will also get unpacked locally. - shouldBuildInplaceOnly :: SolverPackage loc -> Bool - shouldBuildInplaceOnly pkg = Set.member (packageId pkg) - pkgsToBuildInplaceOnly - - pkgsToBuildInplaceOnly :: Set PackageId - pkgsToBuildInplaceOnly = - Set.fromList - $ map packageId - $ SolverInstallPlan.reverseDependencyClosure - solverPlan - (map PlannedId (Set.toList pkgsLocalToProject)) - - isLocalToProject :: Package pkg => pkg -> Bool - isLocalToProject pkg = Set.member (packageId pkg) - pkgsLocalToProject - - pkgsLocalToProject :: Set PackageId - pkgsLocalToProject = + where + global = f allPackagesConfig + local + | isLocalToProject pkg = + f localPackagesConfig + | otherwise = + mempty + perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig) + + inplacePackageDbs = + corePackageDbs + ++ [distPackageDB (compilerId compiler)] + + corePackageDbs = + applyPackageDbFlags + (storePackageDBStack (compilerId compiler)) + (projectConfigPackageDBs sharedPackageConfig) + + -- For this local build policy, every package that lives in a local source + -- dir (as opposed to a tarball), or depends on such a package, will be + -- built inplace into a shared dist dir. Tarball packages that depend on + -- source dir packages will also get unpacked locally. + shouldBuildInplaceOnly :: SolverPackage loc -> Bool + shouldBuildInplaceOnly pkg = + Set.member + (packageId pkg) + pkgsToBuildInplaceOnly + + pkgsToBuildInplaceOnly :: Set PackageId + pkgsToBuildInplaceOnly = + Set.fromList $ + map packageId $ + SolverInstallPlan.reverseDependencyClosure + solverPlan + (map PlannedId (Set.toList pkgsLocalToProject)) + + isLocalToProject :: Package pkg => pkg -> Bool + isLocalToProject pkg = + Set.member + (packageId pkg) + pkgsLocalToProject + + pkgsLocalToProject :: Set PackageId + pkgsLocalToProject = Set.fromList (catMaybes (map shouldBeLocal localPackages)) - --TODO: localPackages is a misnomer, it's all project packages - -- here is where we decide which ones will be local! + -- TODO: localPackages is a misnomer, it's all project packages + -- here is where we decide which ones will be local! - pkgsUseSharedLibrary :: Set PackageId - pkgsUseSharedLibrary = + pkgsUseSharedLibrary :: Set PackageId + pkgsUseSharedLibrary = packagesWithLibDepsDownwardClosedProperty needsSharedLib - where - needsSharedLib pkg = - fromMaybe compilerShouldUseSharedLibByDefault - (liftM2 (||) pkgSharedLib pkgDynExe) - where - pkgid = packageId pkg - pkgSharedLib = perPkgOptionMaybe pkgid packageConfigSharedLib - pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe - - --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 - GHCJS -> GHCJS.isDynamic compiler - _ -> False - - pkgsUseProfilingLibrary :: Set PackageId - pkgsUseProfilingLibrary = + where + needsSharedLib pkg = + fromMaybe + compilerShouldUseSharedLibByDefault + (liftM2 (||) pkgSharedLib pkgDynExe) + where + pkgid = packageId pkg + pkgSharedLib = perPkgOptionMaybe pkgid packageConfigSharedLib + pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe + + -- 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 + GHCJS -> GHCJS.isDynamic compiler + _ -> False + + pkgsUseProfilingLibrary :: Set PackageId + pkgsUseProfilingLibrary = packagesWithLibDepsDownwardClosedProperty needsProfilingLib - where - needsProfilingLib pkg = + where + needsProfilingLib pkg = fromFlagOrDefault False (profBothFlag <> profLibFlag) - where - pkgid = packageId pkg - profBothFlag = lookupPerPkgOption pkgid packageConfigProf - profLibFlag = lookupPerPkgOption pkgid packageConfigProfLib - --TODO: [code cleanup] unused: the old deprecated packageConfigProfExe - - libDepGraph = Graph.fromDistinctList $ - map NonSetupLibDepSolverPlanPackage - (SolverInstallPlan.toList solverPlan) - - packagesWithLibDepsDownwardClosedProperty property = + where + pkgid = packageId pkg + profBothFlag = lookupPerPkgOption pkgid packageConfigProf + profLibFlag = lookupPerPkgOption pkgid packageConfigProfLib + -- TODO: [code cleanup] unused: the old deprecated packageConfigProfExe + + libDepGraph = + Graph.fromDistinctList $ + map + NonSetupLibDepSolverPlanPackage + (SolverInstallPlan.toList solverPlan) + + packagesWithLibDepsDownwardClosedProperty property = Set.fromList - . map packageId - . fromMaybe [] - $ Graph.closure - libDepGraph - [ Graph.nodeKey pkg - | pkg <- SolverInstallPlan.toList solverPlan - , property 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 - -- package config validation/resolution pass. - - --TODO: [nice to have] config consistency checking: - -- + profiling libs & exes, exe needs lib, recursive - -- + shared libs & exes, exe needs lib, recursive - -- + vanilla libs & exes, exe needs lib, recursive - -- + ghci or shared lib needed by TH, recursive, ghc version dependent + . map packageId + . fromMaybe [] + $ Graph.closure + libDepGraph + [ Graph.nodeKey pkg + | pkg <- SolverInstallPlan.toList solverPlan + , property 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 + -- package config validation/resolution pass. + ] + +-- TODO: [nice to have] config consistency checking: +-- + profiling libs & exes, exe needs lib, recursive +-- + shared libs & exes, exe needs lib, recursive +-- + vanilla libs & exes, exe needs lib, recursive +-- + ghci or shared lib needed by TH, recursive, ghc version dependent -- TODO: Drop matchPlanPkg/matchElabPkg in favor of mkCCMapping shouldBeLocal :: PackageSpecifier (SourcePackage (PackageLocation loc)) -> Maybe PackageId -shouldBeLocal NamedPackage{} = Nothing +shouldBeLocal NamedPackage{} = Nothing shouldBeLocal (SpecificSourcePackage pkg) = case srcpkgSource pkg of - LocalUnpackedPackage _ -> Just (packageId pkg) - _ -> Nothing + LocalUnpackedPackage _ -> Just (packageId pkg) + _ -> Nothing -- | Given a 'ElaboratedPlanPackage', report if it matches a 'ComponentName'. matchPlanPkg :: (ComponentName -> Bool) -> ElaboratedPlanPackage -> Bool @@ -2143,69 +2438,84 @@ ipiComponentName = CLibName . IPI.sourceLibName -- 'ComponentName'. matchElabPkg :: (ComponentName -> Bool) -> ElaboratedConfiguredPackage -> Bool matchElabPkg p elab = - case elabPkgOrComp elab of - ElabComponent comp -> maybe False p (compComponentName comp) - ElabPackage _ -> - -- So, what should we do here? One possibility is to - -- unconditionally return 'True', because whatever it is - -- that we're looking for, it better be in this package. - -- But this is a bit dodgy if the package doesn't actually - -- have, e.g., a library. Fortunately, it's not possible - -- for the build of the library/executables to be toggled - -- by 'pkgStanzasEnabled', so the only thing we have to - -- test is if the component in question is *buildable.* - any (p . componentName) - (Cabal.pkgBuildableComponents (elabPkgDescription elab)) + case elabPkgOrComp elab of + ElabComponent comp -> maybe False p (compComponentName comp) + ElabPackage _ -> + -- So, what should we do here? One possibility is to + -- unconditionally return 'True', because whatever it is + -- that we're looking for, it better be in this package. + -- But this is a bit dodgy if the package doesn't actually + -- have, e.g., a library. Fortunately, it's not possible + -- for the build of the library/executables to be toggled + -- by 'pkgStanzasEnabled', so the only thing we have to + -- test is if the component in question is *buildable.* + any + (p . componentName) + (Cabal.pkgBuildableComponents (elabPkgDescription elab)) -- | Given an 'ElaboratedPlanPackage', generate the mapping from 'PackageName' -- and 'ComponentName' to the 'ComponentId' that should be used -- in this case. -mkCCMapping :: ElaboratedPlanPackage - -> (PackageName, Map ComponentName (AnnotatedId ComponentId)) +mkCCMapping + :: ElaboratedPlanPackage + -> (PackageName, Map ComponentName (AnnotatedId ComponentId)) mkCCMapping = - InstallPlan.foldPlanPackage - (\ipkg -> (packageName ipkg, - Map.singleton (ipiComponentName ipkg) - -- TODO: libify - (AnnotatedId { - ann_id = IPI.installedComponentId ipkg, - ann_pid = packageId ipkg, - ann_cname = IPI.sourceComponentName ipkg - }))) - $ \elab -> - let mk_aid cn = AnnotatedId { - ann_id = elabComponentId elab, - ann_pid = packageId elab, - ann_cname = cn - } - in (packageName elab, - case elabPkgOrComp elab of - ElabComponent comp -> - case compComponentName comp of - Nothing -> Map.empty - Just n -> Map.singleton n (mk_aid n) - ElabPackage _ -> - Map.fromList $ - map (\comp -> let cn = Cabal.componentName comp in (cn, mk_aid cn)) - (Cabal.pkgBuildableComponents (elabPkgDescription elab))) + InstallPlan.foldPlanPackage + ( \ipkg -> + ( packageName ipkg + , Map.singleton + (ipiComponentName ipkg) + -- TODO: libify + ( AnnotatedId + { ann_id = IPI.installedComponentId ipkg + , ann_pid = packageId ipkg + , ann_cname = IPI.sourceComponentName ipkg + } + ) + ) + ) + $ \elab -> + let mk_aid cn = + AnnotatedId + { ann_id = elabComponentId elab + , ann_pid = packageId elab + , ann_cname = cn + } + in ( packageName elab + , case elabPkgOrComp elab of + ElabComponent comp -> + case compComponentName comp of + Nothing -> Map.empty + Just n -> Map.singleton n (mk_aid n) + ElabPackage _ -> + Map.fromList $ + map + (\comp -> let cn = Cabal.componentName comp in (cn, mk_aid cn)) + (Cabal.pkgBuildableComponents (elabPkgDescription elab)) + ) -- | Given an 'ElaboratedPlanPackage', generate the mapping from 'ComponentId' -- to the shape of this package, as per mix-in linking. -mkShapeMapping :: ElaboratedPlanPackage - -> (ComponentId, (OpenUnitId, ModuleShape)) +mkShapeMapping + :: ElaboratedPlanPackage + -> (ComponentId, (OpenUnitId, ModuleShape)) mkShapeMapping dpkg = - (getComponentId dpkg, (indef_uid, shape)) + (getComponentId dpkg, (indef_uid, shape)) where (dcid, shape) = - InstallPlan.foldPlanPackage - -- Uses Monad (->) - (liftM2 (,) IPI.installedComponentId shapeInstalledPackage) - (liftM2 (,) elabComponentId elabModuleShape) - dpkg + InstallPlan.foldPlanPackage + -- Uses Monad (->) + (liftM2 (,) IPI.installedComponentId shapeInstalledPackage) + (liftM2 (,) elabComponentId elabModuleShape) + dpkg indef_uid = - IndefFullUnitId dcid - (Map.fromList [ (req, OpenModuleVar req) - | req <- Set.toList (modShapeRequires shape)]) + IndefFullUnitId + dcid + ( Map.fromList + [ (req, OpenModuleVar req) + | req <- Set.toList (modShapeRequires shape) + ] + ) -- | Get the bin\/ directories that a package's executables should reside in. -- @@ -2223,47 +2533,50 @@ binDirectories layout config package = case elabBuildStyle package of -- to put any executables in it, that will just clog up the PATH _ | noExecutables -> [] BuildAndInstall -> [installedBinDirectory package] - BuildInplaceOnly {} -> map (root) $ case elabPkgOrComp package of + BuildInplaceOnly{} -> map (root ) $ case elabPkgOrComp package of ElabComponent comp -> case compSolverName comp of CD.ComponentExe n -> [prettyShow n] _ -> [] - ElabPackage _ -> map (prettyShow . PD.exeName) - . PD.executables - . elabPkgDescription - $ package + ElabPackage _ -> + map (prettyShow . PD.exeName) + . PD.executables + . elabPkgDescription + $ package where - noExecutables = null . PD.executables . elabPkgDescription $ package - root = distBuildDirectory layout (elabDistDirParams config package) - "build" + noExecutables = null . PD.executables . elabPkgDescription $ package + root = + distBuildDirectory layout (elabDistDirParams config package) + "build" -- | A newtype for 'SolverInstallPlan.SolverPlanPackage' for which the -- dependency graph considers only dependencies on libraries which are -- NOT from setup dependencies. Used to compute the set -- of packages needed for profiling and dynamic libraries. -newtype NonSetupLibDepSolverPlanPackage - = NonSetupLibDepSolverPlanPackage - { unNonSetupLibDepSolverPlanPackage :: SolverInstallPlan.SolverPlanPackage } +newtype NonSetupLibDepSolverPlanPackage = NonSetupLibDepSolverPlanPackage + {unNonSetupLibDepSolverPlanPackage :: SolverInstallPlan.SolverPlanPackage} instance Package NonSetupLibDepSolverPlanPackage where - packageId = packageId . unNonSetupLibDepSolverPlanPackage + packageId = packageId . unNonSetupLibDepSolverPlanPackage instance IsNode NonSetupLibDepSolverPlanPackage where - type Key NonSetupLibDepSolverPlanPackage = SolverId - nodeKey = nodeKey . unNonSetupLibDepSolverPlanPackage - nodeNeighbors (NonSetupLibDepSolverPlanPackage spkg) - = ordNub $ CD.nonSetupDeps (resolverPackageLibDeps spkg) + type Key NonSetupLibDepSolverPlanPackage = SolverId + nodeKey = nodeKey . unNonSetupLibDepSolverPlanPackage + nodeNeighbors (NonSetupLibDepSolverPlanPackage spkg) = + ordNub $ CD.nonSetupDeps (resolverPackageLibDeps spkg) type InstS = Map UnitId ElaboratedPlanPackage type InstM a = State InstS a -getComponentId :: ElaboratedPlanPackage - -> ComponentId +getComponentId + :: ElaboratedPlanPackage + -> ComponentId getComponentId (InstallPlan.PreExisting dipkg) = IPI.installedComponentId dipkg getComponentId (InstallPlan.Configured elab) = elabComponentId elab getComponentId (InstallPlan.Installed elab) = elabComponentId elab -extractElabBuildStyle :: InstallPlan.GenericPlanPackage ipkg ElaboratedConfiguredPackage - -> BuildStyle +extractElabBuildStyle + :: InstallPlan.GenericPlanPackage ipkg ElaboratedConfiguredPackage + -> BuildStyle extractElabBuildStyle (InstallPlan.Configured elab) = elabBuildStyle elab extractElabBuildStyle _ = BuildAndInstall @@ -2313,25 +2626,30 @@ extractElabBuildStyle _ = BuildAndInstall -- instantiateInstallPlan :: StoreDirLayout -> InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedInstallPlan instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = - InstallPlan.new (IndependentGoals False) - (Graph.fromDistinctList (Map.elems ready_map)) + InstallPlan.new + (IndependentGoals False) + (Graph.fromDistinctList (Map.elems ready_map)) where pkgs = InstallPlan.toList plan - cmap = Map.fromList [ (getComponentId pkg, pkg) | pkg <- pkgs ] + cmap = Map.fromList [(getComponentId pkg, pkg) | pkg <- pkgs] - instantiateUnitId :: ComponentId -> Map ModuleName (Module, BuildStyle) - -> InstM (DefUnitId, BuildStyle) + instantiateUnitId + :: ComponentId + -> Map ModuleName (Module, BuildStyle) + -> InstM (DefUnitId, BuildStyle) instantiateUnitId cid insts = state $ \s -> - case Map.lookup uid s of - Nothing -> - -- Knot tied - -- TODO: I don't think the knot tying actually does - -- anything useful - let (r, s') = runState (instantiateComponent uid cid insts) - (Map.insert uid r s) - in ((def_uid, extractElabBuildStyle r), Map.insert uid r s') - Just r -> ((def_uid, extractElabBuildStyle r), s) + case Map.lookup uid s of + Nothing -> + -- Knot tied + -- TODO: I don't think the knot tying actually does + -- anything useful + let (r, s') = + runState + (instantiateComponent uid cid insts) + (Map.insert uid r s) + in ((def_uid, extractElabBuildStyle r), Map.insert uid r s') + Just r -> ((def_uid, extractElabBuildStyle r), s) where def_uid = mkDefUnitId cid (fmap fst insts) uid = unDefUnitId def_uid @@ -2339,133 +2657,156 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = -- No need to InplaceT; the inplace-ness is properly computed for -- the ElaboratedPlanPackage, so that will implicitly pass it on instantiateComponent - :: UnitId -> ComponentId -> Map ModuleName (Module, BuildStyle) - -> InstM ElaboratedPlanPackage + :: UnitId + -> ComponentId + -> Map ModuleName (Module, BuildStyle) + -> InstM ElaboratedPlanPackage instantiateComponent uid cid insts - | Just planpkg <- Map.lookup cid cmap - = case planpkg of - InstallPlan.Configured (elab0@ElaboratedConfiguredPackage - { elabPkgOrComp = ElabComponent comp }) -> do - deps <- - traverse (fmap fst . substUnitId insts) (compLinkedLibDependencies comp) - let build_style = fold (fmap snd insts) - let getDep (Module dep_uid _) = [dep_uid] - elab1 = fixupBuildStyle build_style $ elab0 { - elabUnitId = uid, - elabComponentId = cid, - elabInstantiatedWith = fmap fst insts, - elabIsCanonical = Map.null (fmap fst insts), - elabPkgOrComp = ElabComponent comp { - compOrderLibDependencies = - (if Map.null insts then [] else [newSimpleUnitId cid]) ++ - ordNub (map unDefUnitId - (deps ++ concatMap (getDep . fst) (Map.elems insts))) - } + | Just planpkg <- Map.lookup cid cmap = + case planpkg of + InstallPlan.Configured + ( elab0@ElaboratedConfiguredPackage + { elabPkgOrComp = ElabComponent comp } - elab = elab1 { - elabInstallDirs = computeInstallDirs storeDirLayout - defaultInstallDirs - elaboratedShared - elab1 - } - return $ InstallPlan.Configured elab - _ -> return planpkg + ) -> do + deps <- + traverse (fmap fst . substUnitId insts) (compLinkedLibDependencies comp) + let build_style = fold (fmap snd insts) + let getDep (Module dep_uid _) = [dep_uid] + elab1 = + fixupBuildStyle build_style $ + elab0 + { elabUnitId = uid + , elabComponentId = cid + , elabInstantiatedWith = fmap fst insts + , elabIsCanonical = Map.null (fmap fst insts) + , elabPkgOrComp = + ElabComponent + comp + { compOrderLibDependencies = + (if Map.null insts then [] else [newSimpleUnitId cid]) + ++ ordNub + ( map + unDefUnitId + (deps ++ concatMap (getDep . fst) (Map.elems insts)) + ) + } + } + elab = + elab1 + { elabInstallDirs = + computeInstallDirs + storeDirLayout + defaultInstallDirs + elaboratedShared + elab1 + } + return $ InstallPlan.Configured elab + _ -> return planpkg | otherwise = error ("instantiateComponent: " ++ prettyShow cid) substUnitId :: Map ModuleName (Module, BuildStyle) -> OpenUnitId -> InstM (DefUnitId, BuildStyle) substUnitId _ (DefiniteUnitId uid) = - -- This COULD actually, secretly, be an inplace package, but in - -- that case it doesn't matter as it's already been recorded - -- in the package that depends on this - return (uid, BuildAndInstall) + -- This COULD actually, secretly, be an inplace package, but in + -- that case it doesn't matter as it's already been recorded + -- in the package that depends on this + return (uid, BuildAndInstall) substUnitId subst (IndefFullUnitId cid insts) = do - insts' <- substSubst subst insts - instantiateUnitId cid insts' + insts' <- substSubst subst insts + instantiateUnitId cid insts' -- NB: NOT composition - substSubst :: Map ModuleName (Module, BuildStyle) - -> Map ModuleName OpenModule - -> InstM (Map ModuleName (Module, BuildStyle)) + substSubst + :: Map ModuleName (Module, BuildStyle) + -> Map ModuleName OpenModule + -> InstM (Map ModuleName (Module, BuildStyle)) substSubst subst insts = traverse (substModule subst) insts substModule :: Map ModuleName (Module, BuildStyle) -> OpenModule -> InstM (Module, BuildStyle) substModule subst (OpenModuleVar mod_name) - | Just m <- Map.lookup mod_name subst = return m - | otherwise = error "substModule: non-closing substitution" + | Just m <- Map.lookup mod_name subst = return m + | otherwise = error "substModule: non-closing substitution" substModule subst (OpenModule uid mod_name) = do - (uid', build_style) <- substUnitId subst uid - return (Module uid' mod_name, build_style) + (uid', build_style) <- substUnitId subst uid + return (Module uid' mod_name, build_style) indefiniteUnitId :: ComponentId -> InstM UnitId indefiniteUnitId cid = do - let uid = newSimpleUnitId cid - r <- indefiniteComponent uid cid - state $ \s -> (uid, Map.insert uid r s) + let uid = newSimpleUnitId cid + r <- indefiniteComponent uid cid + state $ \s -> (uid, Map.insert uid r s) indefiniteComponent :: UnitId -> ComponentId -> InstM ElaboratedPlanPackage indefiniteComponent _uid cid -- Only need Configured; this phase happens before improvement, so -- there shouldn't be any Installed packages here. | Just (InstallPlan.Configured epkg) <- Map.lookup cid cmap - , ElabComponent elab_comp <- elabPkgOrComp epkg - = do -- We need to do a little more processing of the includes: some - -- of them are fully definite even without substitution. We - -- want to build those too; see #5634. - -- - -- This code mimics similar code in Distribution.Backpack.ReadyComponent; - -- however, unlike the conversion from LinkedComponent to - -- ReadyComponent, this transformation is done *without* - -- changing the type in question; and what we are simply - -- doing is enforcing tighter invariants on the data - -- structure in question. The new invariant is that there - -- is no IndefFullUnitId in compLinkedLibDependencies that actually - -- has no holes. We couldn't specify this invariant when - -- we initially created the ElaboratedPlanPackage because - -- we have no way of actually reifying the UnitId into a - -- DefiniteUnitId (that's what substUnitId does!) - new_deps <- for (compLinkedLibDependencies elab_comp) $ \uid -> - if Set.null (openUnitIdFreeHoles uid) + , ElabComponent elab_comp <- elabPkgOrComp epkg = + do + -- We need to do a little more processing of the includes: some + -- of them are fully definite even without substitution. We + -- want to build those too; see #5634. + -- + -- This code mimics similar code in Distribution.Backpack.ReadyComponent; + -- however, unlike the conversion from LinkedComponent to + -- ReadyComponent, this transformation is done *without* + -- changing the type in question; and what we are simply + -- doing is enforcing tighter invariants on the data + -- structure in question. The new invariant is that there + -- is no IndefFullUnitId in compLinkedLibDependencies that actually + -- has no holes. We couldn't specify this invariant when + -- we initially created the ElaboratedPlanPackage because + -- we have no way of actually reifying the UnitId into a + -- DefiniteUnitId (that's what substUnitId does!) + new_deps <- for (compLinkedLibDependencies elab_comp) $ \uid -> + if Set.null (openUnitIdFreeHoles uid) then fmap (DefiniteUnitId . fst) (substUnitId Map.empty uid) else return uid - -- NB: no fixupBuildStyle needed here, as if the indefinite - -- component depends on any inplace packages, it itself must - -- be indefinite! There is no substitution here, we can't - -- post facto add inplace deps - return . InstallPlan.Configured $ epkg { - elabPkgOrComp = ElabComponent elab_comp { - compLinkedLibDependencies = new_deps, - -- I think this is right: any new definite unit ids we - -- minted in the phase above need to be built before us. - -- Add 'em in. This doesn't remove any old dependencies - -- on the indefinite package; they're harmless. - compOrderLibDependencies = - ordNub $ compOrderLibDependencies elab_comp ++ - [unDefUnitId d | DefiniteUnitId d <- new_deps] - } - } - | Just planpkg <- Map.lookup cid cmap - = return planpkg + -- NB: no fixupBuildStyle needed here, as if the indefinite + -- component depends on any inplace packages, it itself must + -- be indefinite! There is no substitution here, we can't + -- post facto add inplace deps + return . InstallPlan.Configured $ + epkg + { elabPkgOrComp = + ElabComponent + elab_comp + { compLinkedLibDependencies = new_deps + , -- I think this is right: any new definite unit ids we + -- minted in the phase above need to be built before us. + -- Add 'em in. This doesn't remove any old dependencies + -- on the indefinite package; they're harmless. + compOrderLibDependencies = + ordNub $ + compOrderLibDependencies elab_comp + ++ [unDefUnitId d | DefiniteUnitId d <- new_deps] + } + } + | Just planpkg <- Map.lookup cid cmap = + return planpkg | otherwise = error ("indefiniteComponent: " ++ prettyShow cid) fixupBuildStyle BuildAndInstall elab = elab - fixupBuildStyle _ (elab@ElaboratedConfiguredPackage { elabBuildStyle = BuildInplaceOnly {} }) = elab - fixupBuildStyle t@(BuildInplaceOnly {}) elab = elab { - elabBuildStyle = t, - elabBuildPackageDBStack = elabInplaceBuildPackageDBStack elab, - elabRegisterPackageDBStack = elabInplaceRegisterPackageDBStack elab, - elabSetupPackageDBStack = elabInplaceSetupPackageDBStack elab - } + fixupBuildStyle _ (elab@ElaboratedConfiguredPackage{elabBuildStyle = BuildInplaceOnly{}}) = elab + fixupBuildStyle t@(BuildInplaceOnly{}) elab = + elab + { elabBuildStyle = t + , elabBuildPackageDBStack = elabInplaceBuildPackageDBStack elab + , elabRegisterPackageDBStack = elabInplaceRegisterPackageDBStack elab + , elabSetupPackageDBStack = elabInplaceSetupPackageDBStack elab + } ready_map = execState work Map.empty work = for_ pkgs $ \pkg -> - case pkg of - InstallPlan.Configured elab - | not (Map.null (elabLinkedInstantiatedWith elab)) - -> indefiniteUnitId (elabComponentId elab) - >> return () - _ -> instantiateUnitId (getComponentId pkg) Map.empty - >> return () + case pkg of + InstallPlan.Configured elab + | not (Map.null (elabLinkedInstantiatedWith elab)) -> + indefiniteUnitId (elabComponentId elab) + >> return () + _ -> + instantiateUnitId (getComponentId pkg) Map.empty + >> return () --------------------------- -- Build targets @@ -2509,35 +2850,39 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = -- forcing them to return the @k@ value for the selected targets). -- In particular 'resolveTargets' makes use of this (with @k@ as -- @('UnitId', ComponentName')@) to identify the targets thus selected. --- -data AvailableTarget k = AvailableTarget { - availableTargetPackageId :: PackageId, - availableTargetComponentName :: ComponentName, - availableTargetStatus :: AvailableTargetStatus k, - availableTargetLocalToProject :: Bool - } +data AvailableTarget k = AvailableTarget + { availableTargetPackageId :: PackageId + , availableTargetComponentName :: ComponentName + , availableTargetStatus :: AvailableTargetStatus k + , availableTargetLocalToProject :: Bool + } deriving (Eq, Show, Functor) -- | The status of a an 'AvailableTarget' component. This tells us whether -- it's actually possible to select this component to be built, and if not -- why not. --- -data AvailableTargetStatus k = - TargetDisabledByUser -- ^ When the user does @tests: False@ - | TargetDisabledBySolver -- ^ When the solver could not enable tests - | TargetNotBuildable -- ^ When the component has @buildable: False@ - | TargetNotLocal -- ^ When the component is non-core in a non-local package - | TargetBuildable k TargetRequested -- ^ The target can or should be built +data AvailableTargetStatus k + = -- | When the user does @tests: False@ + TargetDisabledByUser + | -- | When the solver could not enable tests + TargetDisabledBySolver + | -- | When the component has @buildable: False@ + TargetNotBuildable + | -- | When the component is non-core in a non-local package + TargetNotLocal + | -- | The target can or should be built + TargetBuildable k TargetRequested deriving (Eq, Ord, Show, Functor) -- | This tells us whether a target ought to be built by default, or only if -- specifically requested. The policy is that components like libraries and -- executables are built by default by @build@, but test suites and benchmarks -- are not, unless this is overridden in the project configuration. --- -data TargetRequested = - TargetRequestedByDefault -- ^ To be built by default - | TargetNotRequestedByDefault -- ^ Not to be built by default +data TargetRequested + = -- | To be built by default + TargetRequestedByDefault + | -- | Not to be built by default + TargetNotRequestedByDefault deriving (Eq, Ord, Show) -- | Given the install plan, produce the set of 'AvailableTarget's for each @@ -2549,145 +2894,172 @@ data TargetRequested = -- had a plan that contained two instances of the same version of a package. -- This approach makes it relatively easy to select all instances\/variants -- of a component. --- -availableTargets :: ElaboratedInstallPlan - -> Map (PackageId, ComponentName) - [AvailableTarget (UnitId, ComponentName)] +availableTargets + :: ElaboratedInstallPlan + -> Map + (PackageId, ComponentName) + [AvailableTarget (UnitId, ComponentName)] availableTargets installPlan = - let rs = [ (pkgid, cname, fake, target) - | pkg <- InstallPlan.toList installPlan - , (pkgid, cname, fake, target) <- case pkg of - InstallPlan.PreExisting ipkg -> availableInstalledTargets ipkg - InstallPlan.Installed elab -> availableSourceTargets elab - InstallPlan.Configured elab -> availableSourceTargets elab - ] - in Map.union - (Map.fromListWith (++) + let rs = + [ (pkgid, cname, fake, target) + | pkg <- InstallPlan.toList installPlan + , (pkgid, cname, fake, target) <- case pkg of + InstallPlan.PreExisting ipkg -> availableInstalledTargets ipkg + InstallPlan.Installed elab -> availableSourceTargets elab + InstallPlan.Configured elab -> availableSourceTargets elab + ] + in Map.union + ( Map.fromListWith + (++) [ ((pkgid, cname), [target]) - | (pkgid, cname, fake, target) <- rs, not fake]) - (Map.fromList + | (pkgid, cname, fake, target) <- rs + , not fake + ] + ) + ( Map.fromList [ ((pkgid, cname), [target]) - | (pkgid, cname, fake, target) <- rs, fake]) - -- The normal targets mask the fake ones. We get all instances of the - -- normal ones and only one copy of the fake ones (as there are many - -- duplicates of the fake ones). See 'availableSourceTargets' below for - -- more details on this fake stuff is about. - -availableInstalledTargets :: IPI.InstalledPackageInfo - -> [(PackageId, ComponentName, Bool, - AvailableTarget (UnitId, ComponentName))] + | (pkgid, cname, fake, target) <- rs + , fake + ] + ) + +-- The normal targets mask the fake ones. We get all instances of the +-- normal ones and only one copy of the fake ones (as there are many +-- duplicates of the fake ones). See 'availableSourceTargets' below for +-- more details on this fake stuff is about. + +availableInstalledTargets + :: IPI.InstalledPackageInfo + -> [ ( PackageId + , ComponentName + , Bool + , AvailableTarget (UnitId, ComponentName) + ) + ] availableInstalledTargets ipkg = - let unitid = installedUnitId ipkg - cname = CLibName LMainLibName - status = TargetBuildable (unitid, cname) TargetRequestedByDefault - target = AvailableTarget (packageId ipkg) cname status False - fake = False - in [(packageId ipkg, cname, fake, target)] - -availableSourceTargets :: ElaboratedConfiguredPackage - -> [(PackageId, ComponentName, Bool, - AvailableTarget (UnitId, ComponentName))] + let unitid = installedUnitId ipkg + cname = CLibName LMainLibName + status = TargetBuildable (unitid, cname) TargetRequestedByDefault + target = AvailableTarget (packageId ipkg) cname status False + fake = False + in [(packageId ipkg, cname, fake, target)] + +availableSourceTargets + :: ElaboratedConfiguredPackage + -> [ ( PackageId + , ComponentName + , Bool + , AvailableTarget (UnitId, ComponentName) + ) + ] availableSourceTargets elab = - -- We have a somewhat awkward problem here. We need to know /all/ the - -- components from /all/ the packages because these are the things that - -- users could refer to. Unfortunately, at this stage the elaborated install - -- plan does /not/ contain all components: some components have already - -- been deleted because they cannot possibly be built. This is the case - -- for components that are marked @buildable: False@ in their .cabal files. - -- (It's not unreasonable that the unbuildable components have been pruned - -- as the plan invariant is considerably simpler if all nodes can be built) - -- - -- We can recover the missing components but it's not exactly elegant. For - -- a graph node corresponding to a component we still have the information - -- about the package that it came from, and this includes the names of - -- /all/ the other components in the package. So in principle this lets us - -- find the names of all components, plus full details of the buildable - -- components. - -- - -- Consider for example a package with 3 exe components: foo, bar and baz - -- where foo and bar are buildable, but baz is not. So the plan contains - -- nodes for the components foo and bar. Now we look at each of these two - -- nodes and look at the package they come from and the names of the - -- components in this package. This will give us the names foo, bar and - -- baz, twice (once for each of the two buildable components foo and bar). - -- - -- We refer to these reconstructed missing components as fake targets. - -- It is an invariant that they are not available to be built. - -- - -- To produce the final set of targets we put the fake targets in a finite - -- map (thus eliminating the duplicates) and then we overlay that map with - -- the normal buildable targets. (This is done above in 'availableTargets'.) - -- - [ (packageId elab, cname, fake, target) - | component <- pkgComponents (elabPkgDescription elab) - , let cname = componentName component - status = componentAvailableTargetStatus component - target = AvailableTarget { - availableTargetPackageId = packageId elab, - availableTargetComponentName = cname, - availableTargetStatus = status, - availableTargetLocalToProject = elabLocalToProject elab - } - fake = isFakeTarget cname - - -- TODO: The goal of this test is to exclude "instantiated" - -- packages as available targets. This means that you can't - -- ask for a particular instantiated component to be built; - -- it will only get built by a dependency. Perhaps the - -- correct way to implement this is to run selection - -- prior to instantiating packages. If you refactor - -- this, then you can delete this test. - , elabIsCanonical elab - - -- Filter out some bogus parts of the cross product that are never needed - , case status of - TargetBuildable{} | fake -> False - _ -> True - ] + -- We have a somewhat awkward problem here. We need to know /all/ the + -- components from /all/ the packages because these are the things that + -- users could refer to. Unfortunately, at this stage the elaborated install + -- plan does /not/ contain all components: some components have already + -- been deleted because they cannot possibly be built. This is the case + -- for components that are marked @buildable: False@ in their .cabal files. + -- (It's not unreasonable that the unbuildable components have been pruned + -- as the plan invariant is considerably simpler if all nodes can be built) + -- + -- We can recover the missing components but it's not exactly elegant. For + -- a graph node corresponding to a component we still have the information + -- about the package that it came from, and this includes the names of + -- /all/ the other components in the package. So in principle this lets us + -- find the names of all components, plus full details of the buildable + -- components. + -- + -- Consider for example a package with 3 exe components: foo, bar and baz + -- where foo and bar are buildable, but baz is not. So the plan contains + -- nodes for the components foo and bar. Now we look at each of these two + -- nodes and look at the package they come from and the names of the + -- components in this package. This will give us the names foo, bar and + -- baz, twice (once for each of the two buildable components foo and bar). + -- + -- We refer to these reconstructed missing components as fake targets. + -- It is an invariant that they are not available to be built. + -- + -- To produce the final set of targets we put the fake targets in a finite + -- map (thus eliminating the duplicates) and then we overlay that map with + -- the normal buildable targets. (This is done above in 'availableTargets'.) + -- + [ (packageId elab, cname, fake, target) + | component <- pkgComponents (elabPkgDescription elab) + , let cname = componentName component + status = componentAvailableTargetStatus component + target = + AvailableTarget + { availableTargetPackageId = packageId elab + , availableTargetComponentName = cname + , availableTargetStatus = status + , availableTargetLocalToProject = elabLocalToProject elab + } + fake = isFakeTarget cname + , -- TODO: The goal of this test is to exclude "instantiated" + -- packages as available targets. This means that you can't + -- ask for a particular instantiated component to be built; + -- it will only get built by a dependency. Perhaps the + -- correct way to implement this is to run selection + -- prior to instantiating packages. If you refactor + -- this, then you can delete this test. + elabIsCanonical elab + , -- Filter out some bogus parts of the cross product that are never needed + case status of + TargetBuildable{} | fake -> False + _ -> True + ] where isFakeTarget cname = case elabPkgOrComp elab of - ElabPackage _ -> False - ElabComponent elabComponent -> compComponentName elabComponent - /= Just cname + ElabPackage _ -> False + ElabComponent elabComponent -> + compComponentName elabComponent + /= Just cname componentAvailableTargetStatus :: Component -> AvailableTargetStatus (UnitId, ComponentName) componentAvailableTargetStatus component = - case componentOptionalStanza $ CD.componentNameToComponent cname of - -- it is not an optional stanza, so a library, exe or foreign lib - Nothing - | not buildable -> TargetNotBuildable - | otherwise -> TargetBuildable (elabUnitId elab, cname) - TargetRequestedByDefault - - -- it is not an optional stanza, so a testsuite or benchmark - Just stanza -> - case (optStanzaLookup stanza (elabStanzasRequested elab), -- TODO - optStanzaSetMember stanza (elabStanzasAvailable elab)) of - _ | not withinPlan -> TargetNotLocal - (Just False, _) -> TargetDisabledByUser - (Nothing, False) -> TargetDisabledBySolver - _ | not buildable -> TargetNotBuildable - (Just True, True) -> TargetBuildable (elabUnitId elab, cname) - TargetRequestedByDefault - (Nothing, True) -> TargetBuildable (elabUnitId elab, cname) - TargetNotRequestedByDefault - (Just True, False) -> - error $ "componentAvailableTargetStatus: impossible; cname=" ++ prettyShow cname + case componentOptionalStanza $ CD.componentNameToComponent cname of + -- it is not an optional stanza, so a library, exe or foreign lib + Nothing + | not buildable -> TargetNotBuildable + | otherwise -> + TargetBuildable + (elabUnitId elab, cname) + TargetRequestedByDefault + -- it is not an optional stanza, so a testsuite or benchmark + Just stanza -> + case ( optStanzaLookup stanza (elabStanzasRequested elab) -- TODO + , optStanzaSetMember stanza (elabStanzasAvailable elab) + ) of + _ | not withinPlan -> TargetNotLocal + (Just False, _) -> TargetDisabledByUser + (Nothing, False) -> TargetDisabledBySolver + _ | not buildable -> TargetNotBuildable + (Just True, True) -> + TargetBuildable + (elabUnitId elab, cname) + TargetRequestedByDefault + (Nothing, True) -> + TargetBuildable + (elabUnitId elab, cname) + TargetNotRequestedByDefault + (Just True, False) -> + error $ "componentAvailableTargetStatus: impossible; cname=" ++ prettyShow cname where - cname = componentName component - buildable = PD.buildable (componentBuildInfo component) - withinPlan = elabLocalToProject elab - || case elabPkgOrComp elab of - ElabComponent elabComponent -> - compComponentName elabComponent == Just cname - ElabPackage _ -> - case componentName component of - CLibName (LMainLibName) -> True - CExeName _ -> True - --TODO: what about sub-libs and foreign libs? - _ -> False + cname = componentName component + buildable = PD.buildable (componentBuildInfo component) + withinPlan = + elabLocalToProject elab + || case elabPkgOrComp elab of + ElabComponent elabComponent -> + compComponentName elabComponent == Just cname + ElabPackage _ -> + case componentName component of + CLibName (LMainLibName) -> True + CExeName _ -> True + -- TODO: what about sub-libs and foreign libs? + _ -> False -- | Merge component targets that overlap each other. Specially when we have -- multiple targets for the same component and one of them refers to the whole @@ -2696,78 +3068,80 @@ availableSourceTargets elab = -- -- We also allow for information associated with each component target, and -- whenever we targets subsume each other we aggregate their associated info. --- nubComponentTargets :: [(ComponentTarget, a)] -> [(ComponentTarget, NonEmpty a)] nubComponentTargets = - concatMap (wholeComponentOverrides . map snd) - . groupBy ((==) `on` fst) - . sortBy (compare `on` fst) - . map (\t@((ComponentTarget cname _, _)) -> (cname, t)) - . map compatSubComponentTargets + concatMap (wholeComponentOverrides . map snd) + . groupBy ((==) `on` fst) + . sortBy (compare `on` fst) + . map (\t@((ComponentTarget cname _, _)) -> (cname, t)) + . map compatSubComponentTargets where -- If we're building the whole component then that the only target all we -- need, otherwise we can have several targets within the component. - wholeComponentOverrides :: [(ComponentTarget, a )] - -> [(ComponentTarget, NonEmpty a)] + wholeComponentOverrides + :: [(ComponentTarget, a)] + -> [(ComponentTarget, NonEmpty a)] wholeComponentOverrides ts = - case [ ta | ta@(ComponentTarget _ WholeComponent, _) <- ts ] of - ((t, x):_) -> - let - -- Delete tuple (t, x) from original list to avoid duplicates. - -- Use 'deleteBy', to avoid additional Class constraint on 'nubComponentTargets'. - ts' = deleteBy (\(t1, _) (t2, _) -> t1 == t2) (t, x) ts - in - [ (t, x :| map snd ts') ] - [] -> [ (t, x :| []) | (t,x) <- ts ] + case [ta | ta@(ComponentTarget _ WholeComponent, _) <- ts] of + ((t, x) : _) -> + let + -- Delete tuple (t, x) from original list to avoid duplicates. + -- Use 'deleteBy', to avoid additional Class constraint on 'nubComponentTargets'. + ts' = deleteBy (\(t1, _) (t2, _) -> t1 == t2) (t, x) ts + in + [(t, x :| map snd ts')] + [] -> [(t, x :| []) | (t, x) <- ts] -- Not all Cabal Setup.hs versions support sub-component targets, so switch -- them over to the whole component compatSubComponentTargets :: (ComponentTarget, a) -> (ComponentTarget, a) compatSubComponentTargets target@(ComponentTarget cname _subtarget, x) - | not setupHsSupportsSubComponentTargets - = (ComponentTarget cname WholeComponent, x) + | not setupHsSupportsSubComponentTargets = + (ComponentTarget cname WholeComponent, x) | otherwise = target -- Actually the reality is that no current version of Cabal's Setup.hs -- build command actually support building specific files or modules. setupHsSupportsSubComponentTargets = False - -- TODO: when that changes, adjust this test, e.g. - -- | pkgSetupScriptCliVersion >= Version [x,y] [] + +-- TODO: when that changes, adjust this test, e.g. +-- \| pkgSetupScriptCliVersion >= Version [x,y] [] pkgHasEphemeralBuildTargets :: ElaboratedConfiguredPackage -> Bool pkgHasEphemeralBuildTargets elab = - (not . null) (elabReplTarget elab) - || (not . null) (elabTestTargets elab) - || (not . null) (elabBenchTargets elab) - || (not . null) (elabHaddockTargets elab) - || (not . null) [ () | ComponentTarget _ subtarget <- elabBuildTargets elab - , subtarget /= WholeComponent ] + (not . null) (elabReplTarget elab) + || (not . null) (elabTestTargets elab) + || (not . null) (elabBenchTargets elab) + || (not . null) (elabHaddockTargets elab) + || (not . null) + [ () | ComponentTarget _ subtarget <- elabBuildTargets elab, subtarget /= WholeComponent + ] -- | The components that we'll build all of, meaning that after they're built -- we can skip building them again (unlike with building just some modules or -- other files within a component). --- -elabBuildTargetWholeComponents :: ElaboratedConfiguredPackage - -> Set ComponentName +elabBuildTargetWholeComponents + :: ElaboratedConfiguredPackage + -> Set ComponentName elabBuildTargetWholeComponents elab = - Set.fromList - [ cname | ComponentTarget cname WholeComponent <- elabBuildTargets elab ] - - + Set.fromList + [cname | ComponentTarget cname WholeComponent <- elabBuildTargets elab] ------------------------------------------------------------------------------ + -- * Install plan pruning + ------------------------------------------------------------------------------ -- | How 'pruneInstallPlanToTargets' should interpret the per-package -- 'ComponentTarget's: as build, repl or haddock targets. --- -data TargetAction = TargetActionConfigure - | TargetActionBuild - | TargetActionRepl - | TargetActionTest - | TargetActionBench - | TargetActionHaddock +data TargetAction + = TargetActionConfigure + | TargetActionBuild + | TargetActionRepl + | TargetActionTest + | TargetActionBench + | TargetActionHaddock -- | Given a set of per-package\/per-component targets, take the subset of the -- install plan needed to build those targets. Also, update the package config @@ -2777,20 +3151,21 @@ data TargetAction = TargetActionConfigure -- NB: Pruning happens after improvement, which is important because we -- will prune differently depending on what is already installed (to -- implement "sticky" test suite enabling behavior). --- -pruneInstallPlanToTargets :: TargetAction - -> Map UnitId [ComponentTarget] - -> ElaboratedInstallPlan -> ElaboratedInstallPlan +pruneInstallPlanToTargets + :: TargetAction + -> Map UnitId [ComponentTarget] + -> ElaboratedInstallPlan + -> ElaboratedInstallPlan pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan = - InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan) - . Graph.fromDistinctList + InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan) + . Graph.fromDistinctList -- We have to do the pruning in two passes - . pruneInstallPlanPass2 - . pruneInstallPlanPass1 + . pruneInstallPlanPass2 + . pruneInstallPlanPass1 -- Set the targets that will be the roots for pruning - . setRootTargets targetActionType perPkgTargetsMap - . InstallPlan.toList - $ elaboratedPlan + . setRootTargets targetActionType perPkgTargetsMap + . InstallPlan.toList + $ elaboratedPlan -- | This is a temporary data type, where we temporarily -- override the graph dependencies of an 'ElaboratedPackage', @@ -2802,61 +3177,70 @@ pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan = data PrunedPackage = PrunedPackage ElaboratedConfiguredPackage [UnitId] instance Package PrunedPackage where - packageId (PrunedPackage elab _) = packageId elab + packageId (PrunedPackage elab _) = packageId elab instance HasUnitId PrunedPackage where - installedUnitId = nodeKey + installedUnitId = nodeKey instance IsNode PrunedPackage where - type Key PrunedPackage = UnitId - nodeKey (PrunedPackage elab _) = nodeKey elab - nodeNeighbors (PrunedPackage _ deps) = deps + type Key PrunedPackage = UnitId + nodeKey (PrunedPackage elab _) = nodeKey elab + nodeNeighbors (PrunedPackage _ deps) = deps fromPrunedPackage :: PrunedPackage -> ElaboratedConfiguredPackage fromPrunedPackage (PrunedPackage elab _) = elab -- | Set the build targets based on the user targets (but not rev deps yet). -- This is required before we can prune anything. --- -setRootTargets :: TargetAction - -> Map UnitId [ComponentTarget] - -> [ElaboratedPlanPackage] - -> [ElaboratedPlanPackage] +setRootTargets + :: TargetAction + -> Map UnitId [ComponentTarget] + -> [ElaboratedPlanPackage] + -> [ElaboratedPlanPackage] setRootTargets targetAction perPkgTargetsMap = - assert (not (Map.null perPkgTargetsMap)) $ + assert (not (Map.null perPkgTargetsMap)) $ assert (all (not . null) (Map.elems perPkgTargetsMap)) $ - - map (mapConfiguredPackage setElabBuildTargets) + map (mapConfiguredPackage setElabBuildTargets) where -- Set the targets we'll build for this package/component. This is just -- based on the root targets from the user, not targets implied by reverse -- dependencies. Those comes in the second pass once we know the rev deps. -- setElabBuildTargets elab = - case (Map.lookup (installedUnitId elab) perPkgTargetsMap, - targetAction) of - (Nothing, _) -> elab - (Just tgts, TargetActionConfigure) -> elab { elabConfigureTargets = tgts } - (Just tgts, TargetActionBuild) -> elab { elabBuildTargets = tgts } - (Just tgts, TargetActionTest) -> elab { elabTestTargets = tgts } - (Just tgts, TargetActionBench) -> elab { elabBenchTargets = tgts } - (Just tgts, TargetActionRepl) -> elab { elabReplTarget = tgts - , elabBuildHaddocks = False - , elabBuildStyle = BuildInplaceOnly InMemory } - (Just tgts, TargetActionHaddock) -> - foldr setElabHaddockTargets (elab { elabHaddockTargets = tgts - , elabBuildHaddocks = True }) tgts + case ( Map.lookup (installedUnitId elab) perPkgTargetsMap + , targetAction + ) of + (Nothing, _) -> elab + (Just tgts, TargetActionConfigure) -> elab{elabConfigureTargets = tgts} + (Just tgts, TargetActionBuild) -> elab{elabBuildTargets = tgts} + (Just tgts, TargetActionTest) -> elab{elabTestTargets = tgts} + (Just tgts, TargetActionBench) -> elab{elabBenchTargets = tgts} + (Just tgts, TargetActionRepl) -> + elab + { elabReplTarget = tgts + , elabBuildHaddocks = False + , elabBuildStyle = BuildInplaceOnly InMemory + } + (Just tgts, TargetActionHaddock) -> + foldr + setElabHaddockTargets + ( elab + { elabHaddockTargets = tgts + , elabBuildHaddocks = True + } + ) + tgts setElabHaddockTargets tgt elab - | isTestComponentTarget tgt = elab { elabHaddockTestSuites = True } - | isBenchComponentTarget tgt = elab { elabHaddockBenchmarks = True } - | isForeignLibComponentTarget tgt = elab { elabHaddockForeignLibs = True } - | isExeComponentTarget tgt = elab { elabHaddockExecutables = True } - | isSubLibComponentTarget tgt = elab { elabHaddockInternal = True } - | otherwise = elab + | isTestComponentTarget tgt = elab{elabHaddockTestSuites = True} + | isBenchComponentTarget tgt = elab{elabHaddockBenchmarks = True} + | isForeignLibComponentTarget tgt = elab{elabHaddockForeignLibs = True} + | isExeComponentTarget tgt = elab{elabHaddockExecutables = True} + | isSubLibComponentTarget tgt = elab{elabHaddockInternal = True} + | otherwise = elab minVersionReplFlagFile :: Version -minVersionReplFlagFile = mkVersion [3,9] +minVersionReplFlagFile = mkVersion [3, 9] -- | Assuming we have previously set the root build targets (i.e. the user -- targets but not rev deps yet), the first pruning pass does two things: @@ -2866,25 +3250,25 @@ minVersionReplFlagFile = mkVersion [3,9] -- * Take the dependency closure using pruned dependencies. We prune deps that -- are used only by unneeded optional stanzas. These pruned deps are only -- used for the dependency closure and are not persisted in this pass. --- -pruneInstallPlanPass1 :: [ElaboratedPlanPackage] - -> [ElaboratedPlanPackage] +pruneInstallPlanPass1 + :: [ElaboratedPlanPackage] + -> [ElaboratedPlanPackage] pruneInstallPlanPass1 pkgs - -- if there are repl targets, we need to do a bit more work - -- See Note [Pruning for Multi Repl] - | anyReplTarget = final_final_graph - - -- otherwise we'll do less - | otherwise = pruned_packages + -- if there are repl targets, we need to do a bit more work + -- See Note [Pruning for Multi Repl] + | anyReplTarget = final_final_graph + -- otherwise we'll do less + | otherwise = pruned_packages where pkgs' :: [InstallPlan.GenericPlanPackage IPI.InstalledPackageInfo PrunedPackage] pkgs' = map (mapConfiguredPackage prune) pkgs prune :: ElaboratedConfiguredPackage -> PrunedPackage prune elab = PrunedPackage elab' (pruneOptionalDependencies elab') - where elab' = - setDocumentation - $ addOptionalStanzas elab + where + elab' = + setDocumentation $ + addOptionalStanzas elab graph = Graph.fromDistinctList pkgs' @@ -2893,18 +3277,19 @@ pruneInstallPlanPass1 pkgs -- Make a closed graph by calculating the closure from the roots pruned_packages :: [ElaboratedPlanPackage] - pruned_packages = map (mapConfiguredPackage fromPrunedPackage) (fromMaybe [] $ Graph.closure graph roots) + pruned_packages = map (mapConfiguredPackage fromPrunedPackage) (fromMaybe [] $ Graph.closure graph roots) closed_graph :: Graph.Graph ElaboratedPlanPackage closed_graph = Graph.fromDistinctList pruned_packages -- whether any package has repl targets enabled. anyReplTarget :: Bool - anyReplTarget = any is_repl_gpp pkgs' where - is_repl_gpp (InstallPlan.Configured pkg) = is_repl_pp pkg - is_repl_gpp _ = False + anyReplTarget = any is_repl_gpp pkgs' + where + is_repl_gpp (InstallPlan.Configured pkg) = is_repl_pp pkg + is_repl_gpp _ = False - is_repl_pp (PrunedPackage elab _) = not (null (elabReplTarget elab)) + is_repl_pp (PrunedPackage elab _) = not (null (elabReplTarget elab)) -- Anything which is inplace and left after pruning could be a repl target, then just need to check the -- reverse closure after calculating roots to capture dependencies which are on the path between roots. @@ -2913,44 +3298,52 @@ pruneInstallPlanPass1 pkgs all_desired_repl_targets = Set.fromList [elabUnitId cp | InstallPlan.Configured cp <- fromMaybe [] $ Graph.revClosure closed_graph roots] add_repl_target :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage - add_repl_target ecp | elabUnitId ecp `Set.member` all_desired_repl_targets - = ecp { elabReplTarget = maybeToList (ComponentTarget <$> (elabComponentName ecp) <*> pure WholeComponent) - , elabBuildStyle = BuildInplaceOnly InMemory } - | otherwise = ecp + add_repl_target ecp + | elabUnitId ecp `Set.member` all_desired_repl_targets = + ecp + { elabReplTarget = maybeToList (ComponentTarget <$> (elabComponentName ecp) <*> pure WholeComponent) + , elabBuildStyle = BuildInplaceOnly InMemory + } + | otherwise = ecp -- Add the repl target information to the ElaboratedPlanPackages graph_with_repl_targets | anyReplTarget = map (mapConfiguredPackage add_repl_target) (Graph.toList closed_graph) - | otherwise = Graph.toList closed_graph + | otherwise = Graph.toList closed_graph -- But check that all the InMemory targets have a new enough version of Cabal, -- otherwise we will confuse Setup.hs by passing new arguments which it doesn't understand -- later down the line. We try to remove just these edges, if it doesn't break the overall structure -- then we just report to the user that their target will not be loaded for this reason. - (bad -- Nodes which we wanted to build InMemory but lack new enough version of Cabal + ( bad -- Nodes which we wanted to build InMemory but lack new enough version of Cabal , _good -- Nodes we want to build in memory. ) = partitionEithers (map go graph_with_repl_targets) - where - go :: ElaboratedPlanPackage -> Either UnitId ElaboratedPlanPackage - go (InstallPlan.Configured cp) - | BuildInplaceOnly InMemory <- elabBuildStyle cp - , elabSetupScriptCliVersion cp < minVersionReplFlagFile = Left (elabUnitId cp) - go (InstallPlan.Configured c) = Right (InstallPlan.Configured c) - go c = Right c + where + go :: ElaboratedPlanPackage -> Either UnitId ElaboratedPlanPackage + go (InstallPlan.Configured cp) + | BuildInplaceOnly InMemory <- elabBuildStyle cp + , elabSetupScriptCliVersion cp < minVersionReplFlagFile = + Left (elabUnitId cp) + go (InstallPlan.Configured c) = Right (InstallPlan.Configured c) + go c = Right c -- Now take the upwards closure from the bad nodes, and find the other `BuildInplaceOnly InMemory` packages that clobbers, -- disables those and issue a warning to the user. Because we aren't going to be able to load those into memory as well -- because the thing it depends on is not going to be in memory. disabled_repl_targets = - [ c | InstallPlan.Configured c <- fromMaybe [] $ Graph.revClosure (Graph.fromDistinctList graph_with_repl_targets) bad - , BuildInplaceOnly InMemory <- [elabBuildStyle c] ] + [ c | InstallPlan.Configured c <- fromMaybe [] $ Graph.revClosure (Graph.fromDistinctList graph_with_repl_targets) bad, BuildInplaceOnly InMemory <- [elabBuildStyle c] + ] remove_repl_target :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage - remove_repl_target ecp | ecp `elem` disabled_repl_targets = ecp { elabReplTarget = [] - , elabBuildStyle = BuildInplaceOnly OnDisk } - | otherwise = ecp + remove_repl_target ecp + | ecp `elem` disabled_repl_targets = + ecp + { elabReplTarget = [] + , elabBuildStyle = BuildInplaceOnly OnDisk + } + | otherwise = ecp final_graph_with_repl_targets = map (mapConfiguredPackage remove_repl_target) graph_with_repl_targets @@ -2962,23 +3355,24 @@ pruneInstallPlanPass1 pkgs -- TODO: Can probably just remove them directly in remove_repl_target. final_final_graph = fromMaybe [] $ Graph.closure (Graph.fromDistinctList final_graph_with_repl_targets) new_roots - is_root :: PrunedPackage -> Maybe UnitId is_root (PrunedPackage elab _) = - if not $ and [ null (elabConfigureTargets elab) - , null (elabBuildTargets elab) - , null (elabTestTargets elab) - , null (elabBenchTargets elab) - , null (elabReplTarget elab) - , null (elabHaddockTargets elab) - ] - then Just (installedUnitId elab) - else Nothing + if not $ + and + [ null (elabConfigureTargets elab) + , null (elabBuildTargets elab) + , null (elabTestTargets elab) + , null (elabBenchTargets elab) + , null (elabReplTarget elab) + , null (elabHaddockTargets elab) + ] + then Just (installedUnitId elab) + else Nothing find_root (InstallPlan.Configured pkg) = is_root pkg -- When using the extra-packages stanza we need to -- look at installed packages as well. - find_root (InstallPlan.Installed pkg) = is_root pkg + find_root (InstallPlan.Installed pkg) = is_root pkg find_root _ = Nothing -- Note [Sticky enabled testsuites] @@ -3000,46 +3394,45 @@ pruneInstallPlanPass1 pkgs -- Decide whether or not to enable testsuites and benchmarks. -- See [Sticky enabled testsuites] addOptionalStanzas :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage - addOptionalStanzas elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } = - elab { - elabPkgOrComp = ElabPackage (pkg { pkgStanzasEnabled = stanzas }) + addOptionalStanzas elab@ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage pkg} = + elab + { elabPkgOrComp = ElabPackage (pkg{pkgStanzasEnabled = stanzas}) } where stanzas :: OptionalStanzaSet - -- By default, we enabled all stanzas requested by the user, - -- as per elabStanzasRequested, done in - -- 'elaborateSolverToPackage' - stanzas = pkgStanzasEnabled pkg - -- optionalStanzasRequiredByTargets has to be done at - -- prune-time because it depends on 'elabTestTargets' - -- et al, which is done by 'setRootTargets' at the - -- beginning of pruning. - <> optionalStanzasRequiredByTargets elab - -- optionalStanzasWithDepsAvailable has to be done at - -- prune-time because it depends on what packages are - -- installed, which is not known until after improvement - -- (pruning is done after improvement) - <> optionalStanzasWithDepsAvailable availablePkgs elab pkg + -- By default, we enabled all stanzas requested by the user, + -- as per elabStanzasRequested, done in + -- 'elaborateSolverToPackage' + stanzas = + pkgStanzasEnabled pkg + -- optionalStanzasRequiredByTargets has to be done at + -- prune-time because it depends on 'elabTestTargets' + -- et al, which is done by 'setRootTargets' at the + -- beginning of pruning. + <> optionalStanzasRequiredByTargets elab + -- optionalStanzasWithDepsAvailable has to be done at + -- prune-time because it depends on what packages are + -- installed, which is not known until after improvement + -- (pruning is done after improvement) + <> optionalStanzasWithDepsAvailable availablePkgs elab pkg addOptionalStanzas elab = elab setDocumentation :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage - setDocumentation elab@ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } = - elab { - elabBuildHaddocks = + setDocumentation elab@ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent comp} = + elab + { elabBuildHaddocks = elabBuildHaddocks elab && documentationEnabled (compSolverName comp) elab - } - + } where documentationEnabled c = case c of - CD.ComponentLib -> const True + CD.ComponentLib -> const True CD.ComponentSubLib _ -> elabHaddockInternal - CD.ComponentFLib _ -> elabHaddockForeignLibs - CD.ComponentExe _ -> elabHaddockExecutables - CD.ComponentTest _ -> elabHaddockTestSuites - CD.ComponentBench _ -> elabHaddockBenchmarks - CD.ComponentSetup -> const False - + CD.ComponentFLib _ -> elabHaddockForeignLibs + CD.ComponentExe _ -> elabHaddockExecutables + CD.ComponentTest _ -> elabHaddockTestSuites + CD.ComponentBench _ -> elabHaddockBenchmarks + CD.ComponentSetup -> const False setDocumentation elab = elab -- Calculate package dependencies but cut out those needed only by @@ -3049,35 +3442,39 @@ pruneInstallPlanPass1 pkgs -- stanzas in the next pass. -- pruneOptionalDependencies :: ElaboratedConfiguredPackage -> [UnitId] - pruneOptionalDependencies elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabComponent _ } - = InstallPlan.depends elab -- no pruning - pruneOptionalDependencies ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } - = (CD.flatDeps . CD.filterDeps keepNeeded) (pkgOrderDependencies pkg) + pruneOptionalDependencies elab@ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent _} = + InstallPlan.depends elab -- no pruning + pruneOptionalDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage pkg} = + (CD.flatDeps . CD.filterDeps keepNeeded) (pkgOrderDependencies pkg) where - keepNeeded (CD.ComponentTest _) _ = TestStanzas `optStanzaSetMember` stanzas + keepNeeded (CD.ComponentTest _) _ = TestStanzas `optStanzaSetMember` stanzas keepNeeded (CD.ComponentBench _) _ = BenchStanzas `optStanzaSetMember` stanzas - keepNeeded _ _ = True + keepNeeded _ _ = True stanzas = pkgStanzasEnabled pkg - optionalStanzasRequiredByTargets :: ElaboratedConfiguredPackage - -> OptionalStanzaSet + optionalStanzasRequiredByTargets + :: ElaboratedConfiguredPackage + -> OptionalStanzaSet optionalStanzasRequiredByTargets pkg = optStanzaSetFromList [ stanza - | ComponentTarget cname _ <- elabBuildTargets pkg - ++ elabTestTargets pkg - ++ elabBenchTargets pkg - ++ elabReplTarget pkg - ++ elabHaddockTargets pkg - , stanza <- maybeToList $ - componentOptionalStanza $ - CD.componentNameToComponent cname + | ComponentTarget cname _ <- + elabBuildTargets pkg + ++ elabTestTargets pkg + ++ elabBenchTargets pkg + ++ elabReplTarget pkg + ++ elabHaddockTargets pkg + , stanza <- + maybeToList $ + componentOptionalStanza $ + CD.componentNameToComponent cname ] availablePkgs = Set.fromList [ installedUnitId pkg - | InstallPlan.PreExisting pkg <- pkgs ] + | InstallPlan.PreExisting pkg <- pkgs + ] {- Note [Pruning for Multi Repl] @@ -3088,7 +3485,7 @@ it is required to uphold the so-called *closure property*. This property, whose exact Note you can read in the GHC codebase, states roughly: -* If a component you want to load into a repl session transitively depends on a +\* If a component you want to load into a repl session transitively depends on a component which transitively depends on another component you want to load into the repl, then this component needs to be loaded into the repl session as well. @@ -3117,32 +3514,38 @@ arguments to `./Setup`. -- to implement "sticky" testsuites, where once we have installed -- all of the deps needed for the test suite, we go ahead and -- enable it always. -optionalStanzasWithDepsAvailable :: Set UnitId - -> ElaboratedConfiguredPackage - -> ElaboratedPackage - -> OptionalStanzaSet +optionalStanzasWithDepsAvailable + :: Set UnitId + -> ElaboratedConfiguredPackage + -> ElaboratedPackage + -> OptionalStanzaSet optionalStanzasWithDepsAvailable availablePkgs elab pkg = - optStanzaSetFromList - [ stanza - | stanza <- optStanzaSetToList (elabStanzasAvailable elab) - , let deps :: [UnitId] - deps = CD.select (optionalStanzaDeps stanza) - -- TODO: probably need to select other - -- dep types too eventually - (pkgOrderDependencies pkg) - , all (`Set.member` availablePkgs) deps - ] + optStanzaSetFromList + [ stanza + | stanza <- optStanzaSetToList (elabStanzasAvailable elab) + , let deps :: [UnitId] + deps = + CD.select + (optionalStanzaDeps stanza) + -- TODO: probably need to select other + -- dep types too eventually + (pkgOrderDependencies pkg) + , all (`Set.member` availablePkgs) deps + ] where - optionalStanzaDeps TestStanzas (CD.ComponentTest _) = True + optionalStanzaDeps TestStanzas (CD.ComponentTest _) = True optionalStanzaDeps BenchStanzas (CD.ComponentBench _) = True - optionalStanzaDeps _ _ = False - + optionalStanzaDeps _ _ = False -- The second pass does three things: -- + -- * A second go at deciding which optional stanzas to enable. + -- * Prune the dependencies based on the final choice of optional stanzas. + -- * Extend the targets within each package to build, now we know the reverse + -- dependencies, ie we know which libs are needed as deps by other packages. -- -- Achieving sticky behaviour with enabling\/disabling optional stanzas is @@ -3165,35 +3568,37 @@ optionalStanzasWithDepsAvailable availablePkgs elab pkg = -- first or second pass) doesn't mean that we build all (or even any) of them. -- That depends on which targets we picked in the first pass. -- -pruneInstallPlanPass2 :: [ElaboratedPlanPackage] - -> [ElaboratedPlanPackage] +pruneInstallPlanPass2 + :: [ElaboratedPlanPackage] + -> [ElaboratedPlanPackage] pruneInstallPlanPass2 pkgs = - map (mapConfiguredPackage setStanzasDepsAndTargets) pkgs + map (mapConfiguredPackage setStanzasDepsAndTargets) pkgs where setStanzasDepsAndTargets elab = - - elab { - elabBuildTargets = ordNub - $ elabBuildTargets elab - ++ libTargetsRequiredForRevDeps - ++ exeTargetsRequiredForRevDeps, - elabPkgOrComp = + elab + { elabBuildTargets = + ordNub $ + elabBuildTargets elab + ++ libTargetsRequiredForRevDeps + ++ exeTargetsRequiredForRevDeps + , elabPkgOrComp = case elabPkgOrComp elab of ElabPackage pkg -> - let stanzas = pkgStanzasEnabled pkg - <> optionalStanzasWithDepsAvailable availablePkgs elab pkg - keepNeeded (CD.ComponentTest _) _ = TestStanzas `optStanzaSetMember` stanzas + let stanzas = + pkgStanzasEnabled pkg + <> optionalStanzasWithDepsAvailable availablePkgs elab pkg + keepNeeded (CD.ComponentTest _) _ = TestStanzas `optStanzaSetMember` stanzas keepNeeded (CD.ComponentBench _) _ = BenchStanzas `optStanzaSetMember` stanzas - keepNeeded _ _ = True - - in ElabPackage $ pkg { - pkgStanzasEnabled = stanzas, - pkgLibDependencies = CD.mapDeps (\_ -> map addInternal) $ CD.filterDeps keepNeeded (pkgLibDependencies pkg), - pkgExeDependencies = CD.filterDeps keepNeeded (pkgExeDependencies pkg), - pkgExeDependencyPaths = CD.filterDeps keepNeeded (pkgExeDependencyPaths pkg) - } + keepNeeded _ _ = True + in ElabPackage $ + pkg + { pkgStanzasEnabled = stanzas + , pkgLibDependencies = CD.mapDeps (\_ -> map addInternal) $ CD.filterDeps keepNeeded (pkgLibDependencies pkg) + , pkgExeDependencies = CD.filterDeps keepNeeded (pkgExeDependencies pkg) + , pkgExeDependencyPaths = CD.filterDeps keepNeeded (pkgExeDependencyPaths pkg) + } (ElabComponent comp) -> - ElabComponent $ comp { compLibDependencies = map addInternal (compLibDependencies comp) } + ElabComponent $ comp{compLibDependencies = map addInternal (compLibDependencies comp)} } where -- We initially assume that all the dependencies are external (hence the boolean is always @@ -3204,45 +3609,53 @@ pruneInstallPlanPass2 pkgs = [ c | installedUnitId elab `Set.member` hasReverseLibDeps , let c = ComponentTarget (CLibName Cabal.defaultLibName) WholeComponent - -- Don't enable building for anything which is being build in memory - , elabBuildStyle elab /= BuildInplaceOnly InMemory + , -- Don't enable building for anything which is being build in memory + elabBuildStyle elab /= BuildInplaceOnly InMemory ] exeTargetsRequiredForRevDeps = -- TODO: allow requesting executable with different name -- than package name - [ ComponentTarget (Cabal.CExeName - $ packageNameToUnqualComponentName - $ packageName $ elabPkgSourceId elab) - WholeComponent + [ ComponentTarget + ( Cabal.CExeName $ + packageNameToUnqualComponentName $ + packageName $ + elabPkgSourceId elab + ) + WholeComponent | installedUnitId elab `Set.member` hasReverseExeDeps ] - availablePkgs :: Set UnitId availablePkgs = Set.fromList (map installedUnitId pkgs) inMemoryTargets :: Set ConfiguredId inMemoryTargets = do - Set.fromList [ configuredId pkg - | InstallPlan.Configured pkg <- pkgs - , BuildInplaceOnly InMemory <- [elabBuildStyle pkg] ] - + Set.fromList + [ configuredId pkg + | InstallPlan.Configured pkg <- pkgs + , BuildInplaceOnly InMemory <- [elabBuildStyle pkg] + ] hasReverseLibDeps :: Set UnitId hasReverseLibDeps = - Set.fromList [ depid - | InstallPlan.Configured pkg <- pkgs - , depid <- elabOrderLibDependencies pkg ] + Set.fromList + [ depid + | InstallPlan.Configured pkg <- pkgs + , depid <- elabOrderLibDependencies pkg + ] hasReverseExeDeps :: Set UnitId hasReverseExeDeps = - Set.fromList [ depid - | InstallPlan.Configured pkg <- pkgs - , depid <- elabOrderExeDependencies pkg ] + Set.fromList + [ depid + | InstallPlan.Configured pkg <- pkgs + , depid <- elabOrderExeDependencies pkg + ] -mapConfiguredPackage :: (srcpkg -> srcpkg') - -> InstallPlan.GenericPlanPackage ipkg srcpkg - -> InstallPlan.GenericPlanPackage ipkg srcpkg' +mapConfiguredPackage + :: (srcpkg -> srcpkg') + -> InstallPlan.GenericPlanPackage ipkg srcpkg + -> InstallPlan.GenericPlanPackage ipkg srcpkg' mapConfiguredPackage f (InstallPlan.Configured pkg) = InstallPlan.Configured (f pkg) mapConfiguredPackage f (InstallPlan.Installed pkg) = @@ -3257,40 +3670,46 @@ mapConfiguredPackage _ (InstallPlan.PreExisting pkg) = -- | Try to remove the given targets from the install plan. -- -- This is not always possible. --- -pruneInstallPlanToDependencies :: Set UnitId - -> ElaboratedInstallPlan - -> Either CannotPruneDependencies - ElaboratedInstallPlan +pruneInstallPlanToDependencies + :: Set UnitId + -> ElaboratedInstallPlan + -> Either + CannotPruneDependencies + ElaboratedInstallPlan pruneInstallPlanToDependencies pkgTargets installPlan = - assert (all (isJust . InstallPlan.lookup installPlan) - (Set.toList pkgTargets)) $ - - fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan)) - . checkBrokenDeps - . Graph.fromDistinctList - . filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets) - . InstallPlan.toList - $ installPlan - where - -- Our strategy is to remove the packages we don't want and then check - -- if the remaining graph is broken or not, ie any packages with dangling - -- dependencies. If there are then we cannot prune the given targets. - checkBrokenDeps :: Graph.Graph ElaboratedPlanPackage - -> Either CannotPruneDependencies - (Graph.Graph ElaboratedPlanPackage) - checkBrokenDeps graph = - case Graph.broken graph of - [] -> Right graph - brokenPackages -> - Left $ CannotPruneDependencies - [ (pkg, missingDeps) - | (pkg, missingDepIds) <- brokenPackages - , let missingDeps = mapMaybe lookupDep missingDepIds - ] - where - -- lookup in the original unpruned graph - lookupDep = InstallPlan.lookup installPlan + assert + ( all + (isJust . InstallPlan.lookup installPlan) + (Set.toList pkgTargets) + ) + $ fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan)) + . checkBrokenDeps + . Graph.fromDistinctList + . filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets) + . InstallPlan.toList + $ installPlan + where + -- Our strategy is to remove the packages we don't want and then check + -- if the remaining graph is broken or not, ie any packages with dangling + -- dependencies. If there are then we cannot prune the given targets. + checkBrokenDeps + :: Graph.Graph ElaboratedPlanPackage + -> Either + CannotPruneDependencies + (Graph.Graph ElaboratedPlanPackage) + checkBrokenDeps graph = + case Graph.broken graph of + [] -> Right graph + brokenPackages -> + Left $ + CannotPruneDependencies + [ (pkg, missingDeps) + | (pkg, missingDepIds) <- brokenPackages + , let missingDeps = mapMaybe lookupDep missingDepIds + ] + where + -- lookup in the original unpruned graph + lookupDep = InstallPlan.lookup installPlan -- | It is not always possible to prune to only the dependencies of a set of -- targets. It may be the case that removing a package leaves something else @@ -3298,13 +3717,14 @@ pruneInstallPlanToDependencies pkgTargets installPlan = -- -- This lists all the packages that would be broken, and their dependencies -- that would be missing if we did prune. --- -newtype CannotPruneDependencies = - CannotPruneDependencies [(ElaboratedPlanPackage, - [ElaboratedPlanPackage])] +newtype CannotPruneDependencies + = CannotPruneDependencies + [ ( ElaboratedPlanPackage + , [ElaboratedPlanPackage] + ) + ] deriving (Show) - --------------------------- -- Setup.hs script policy -- @@ -3335,33 +3755,31 @@ newtype CannotPruneDependencies = -- data SetupScriptStyle = ... -- see ProjectPlanning.Types -- | Work out the 'SetupScriptStyle' given the package description. --- packageSetupScriptStyle :: PD.PackageDescription -> SetupScriptStyle packageSetupScriptStyle pkg | buildType == PD.Custom , Just setupbi <- PD.setupBuildInfo pkg -- does have a custom-setup stanza - , not (PD.defaultSetupDepends setupbi) -- but not one we added internally - = SetupCustomExplicitDeps - + , not (PD.defaultSetupDepends setupbi) -- but not one we added internally + = + SetupCustomExplicitDeps | buildType == PD.Custom , Just setupbi <- PD.setupBuildInfo pkg -- we get this case post-solver as - , PD.defaultSetupDepends setupbi -- the solver fills in the deps - = SetupCustomImplicitDeps - + , PD.defaultSetupDepends setupbi -- the solver fills in the deps + = + SetupCustomImplicitDeps | buildType == PD.Custom - , Nothing <- PD.setupBuildInfo pkg -- we get this case pre-solver - = SetupCustomImplicitDeps - + , Nothing <- PD.setupBuildInfo pkg -- we get this case pre-solver + = + SetupCustomImplicitDeps -- here we should fail. - | PD.specVersion pkg > cabalSpecLatest -- one cabal-install is built against - = SetupNonCustomExternalLib - - | otherwise - = SetupNonCustomInternalLib + | PD.specVersion pkg > cabalSpecLatest -- one cabal-install is built against + = + SetupNonCustomExternalLib + | otherwise = + SetupNonCustomInternalLib where buildType = PD.buildType pkg - -- | Part of our Setup.hs handling policy is implemented by getting the solver -- to work out setup dependencies for packages. The solver already handles -- packages that explicitly specify setup dependencies, but we can also tell @@ -3380,56 +3798,61 @@ packageSetupScriptStyle pkg -- Note in addition to adding default setup deps, we also use -- 'addSetupCabalMinVersionConstraint' (in 'planPackages') to require -- @Cabal >= 1.20@ for Setup scripts. --- -defaultSetupDeps :: Compiler -> Platform - -> PD.PackageDescription - -> Maybe [Dependency] +defaultSetupDeps + :: Compiler + -> Platform + -> PD.PackageDescription + -> Maybe [Dependency] defaultSetupDeps compiler platform pkg = - case packageSetupScriptStyle pkg of - - -- For packages with build type custom that do not specify explicit - -- setup dependencies, we add a dependency on Cabal and a number - -- of other packages. - SetupCustomImplicitDeps -> - Just $ + case packageSetupScriptStyle pkg of + -- For packages with build type custom that do not specify explicit + -- setup dependencies, we add a dependency on Cabal and a number + -- of other packages. + SetupCustomImplicitDeps -> + Just $ [ Dependency depPkgname anyVersion mainLibSet - | depPkgname <- legacyCustomSetupPkgs compiler platform ] ++ + | depPkgname <- legacyCustomSetupPkgs compiler platform + ] + ++ [ Dependency cabalPkgname cabalConstraint mainLibSet + | packageName pkg /= cabalPkgname + ] + where + -- The Cabal dep is slightly special: + -- \* We omit the dep for the Cabal lib itself, since it bootstraps. + -- \* We constrain it to be < 1.25 + -- + -- Note: we also add a global constraint to require Cabal >= 1.20 + -- for Setup scripts (see use addSetupCabalMinVersionConstraint). + -- + cabalConstraint = + orLaterVersion (csvToVersion (PD.specVersion pkg)) + `intersectVersionRanges` earlierVersion cabalCompatMaxVer + -- The idea here is that at some point we will make significant + -- breaking changes to the Cabal API that Setup.hs scripts use. + -- So for old custom Setup scripts that do not specify explicit + -- constraints, we constrain them to use a compatible Cabal version. + cabalCompatMaxVer = mkVersion [1, 25] + + -- 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. + SetupNonCustomExternalLib -> + Just [ Dependency cabalPkgname cabalConstraint mainLibSet - | packageName pkg /= cabalPkgname ] - where - -- The Cabal dep is slightly special: - -- * We omit the dep for the Cabal lib itself, since it bootstraps. - -- * We constrain it to be < 1.25 - -- - -- Note: we also add a global constraint to require Cabal >= 1.20 - -- for Setup scripts (see use addSetupCabalMinVersionConstraint). - -- - cabalConstraint = orLaterVersion (csvToVersion (PD.specVersion pkg)) - `intersectVersionRanges` - earlierVersion cabalCompatMaxVer - -- The idea here is that at some point we will make significant - -- breaking changes to the Cabal API that Setup.hs scripts use. - -- So for old custom Setup scripts that do not specify explicit - -- constraints, we constrain them to use a compatible Cabal version. - cabalCompatMaxVer = mkVersion [1,25] - - -- 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. - SetupNonCustomExternalLib -> - Just [ Dependency cabalPkgname cabalConstraint mainLibSet - , Dependency basePkgname anyVersion mainLibSet] - where - cabalConstraint = orLaterVersion (csvToVersion (PD.specVersion pkg)) - - -- The internal setup wrapper method has no deps at all. - SetupNonCustomInternalLib -> Just [] - - -- This case gets ruled out by the caller, planPackages, see the note - -- above in the SetupCustomImplicitDeps case. - SetupCustomExplicitDeps -> - error $ "defaultSetupDeps: called for a package with explicit " - ++ "setup deps: " ++ prettyShow (packageId pkg) + , Dependency basePkgname anyVersion mainLibSet + ] + where + cabalConstraint = orLaterVersion (csvToVersion (PD.specVersion pkg)) + + -- The internal setup wrapper method has no deps at all. + SetupNonCustomInternalLib -> Just [] + -- This case gets ruled out by the caller, planPackages, see the note + -- above in the SetupCustomImplicitDeps case. + SetupCustomExplicitDeps -> + error $ + "defaultSetupDeps: called for a package with explicit " + ++ "setup deps: " + ++ prettyShow (packageId pkg) where -- we require one less -- @@ -3443,58 +3866,65 @@ defaultSetupDeps compiler platform pkg = -- This depends somewhat on the 'SetupScriptStyle' but most cases are a result -- of what the solver picked for us, based on the explicit setup deps or the -- ones added implicitly by 'defaultSetupDeps'. --- -packageSetupScriptSpecVersion :: SetupScriptStyle - -> PD.PackageDescription - -> Graph.Graph NonSetupLibDepSolverPlanPackage - -> ComponentDeps [SolverId] - -> Version - +packageSetupScriptSpecVersion + :: SetupScriptStyle + -> PD.PackageDescription + -> Graph.Graph NonSetupLibDepSolverPlanPackage + -> ComponentDeps [SolverId] + -> Version -- We're going to be using the internal Cabal library, so the spec version of -- that is simply the version of the Cabal library that cabal-install has been -- built with. packageSetupScriptSpecVersion SetupNonCustomInternalLib _ _ _ = - cabalVersion - + cabalVersion -- If we happen to be building the Cabal lib itself then because that -- bootstraps itself then we use the version of the lib we're building. packageSetupScriptSpecVersion SetupCustomImplicitDeps pkg _ _ - | packageName pkg == cabalPkgname - = packageVersion pkg - + | packageName pkg == cabalPkgname = + packageVersion pkg -- In all other cases we have a look at what version of the Cabal lib the -- solver picked. Or if it didn't depend on Cabal at all (which is very rare) -- then we look at the .cabal file to see what spec version it declares. packageSetupScriptSpecVersion _ pkg libDepGraph deps = - case find ((cabalPkgname ==) . packageName) setupLibDeps of - Just dep -> packageVersion dep - Nothing -> mkVersion (cabalSpecMinimumLibraryVersion (PD.specVersion pkg)) + case find ((cabalPkgname ==) . packageName) setupLibDeps of + Just dep -> packageVersion dep + Nothing -> mkVersion (cabalSpecMinimumLibraryVersion (PD.specVersion pkg)) where - setupLibDeps = map packageId $ fromMaybe [] $ - Graph.closure libDepGraph (CD.setupDeps deps) - + setupLibDeps = + map packageId $ + fromMaybe [] $ + Graph.closure libDepGraph (CD.setupDeps deps) cabalPkgname, basePkgname :: PackageName cabalPkgname = mkPackageName "Cabal" -basePkgname = mkPackageName "base" - +basePkgname = mkPackageName "base" legacyCustomSetupPkgs :: Compiler -> Platform -> [PackageName] legacyCustomSetupPkgs compiler (Platform _ os) = - map mkPackageName $ - [ "array", "base", "binary", "bytestring", "containers" - , "deepseq", "directory", "filepath", "pretty" - , "process", "time", "transformers" ] - ++ [ "Win32" | os == Windows ] - ++ [ "unix" | os /= Windows ] - ++ [ "ghc-prim" | isGHC ] - ++ [ "template-haskell" | isGHC ] - ++ [ "old-time" | notGHC710 ] + map mkPackageName $ + [ "array" + , "base" + , "binary" + , "bytestring" + , "containers" + , "deepseq" + , "directory" + , "filepath" + , "pretty" + , "process" + , "time" + , "transformers" + ] + ++ ["Win32" | os == Windows] + ++ ["unix" | os /= Windows] + ++ ["ghc-prim" | isGHC] + ++ ["template-haskell" | isGHC] + ++ ["old-time" | notGHC710] where isGHC = compilerCompatFlavor GHC compiler notGHC710 = case compilerCompatVersion GHC compiler of - Nothing -> False - Just v -> v <= mkVersion [7,9] + Nothing -> False + Just v -> v <= mkVersion [7, 9] -- The other aspects of our Setup.hs policy lives here where we decide on -- the 'SetupScriptOptions'. @@ -3506,443 +3936,481 @@ legacyCustomSetupPkgs compiler (Platform _ os) = -- be tricky since we would have to allow the Setup access to all the packages -- in the store and local dbs. -setupHsScriptOptions :: ElaboratedReadyPackage - -> ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> DistDirLayout - -> FilePath - -> FilePath - -> Bool - -> Lock - -> SetupScriptOptions +setupHsScriptOptions + :: ElaboratedReadyPackage + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> DistDirLayout + -> FilePath + -> FilePath + -> Bool + -> Lock + -> SetupScriptOptions -- TODO: Fix this so custom is a separate component. Custom can ALWAYS -- be a separate component!!! -setupHsScriptOptions (ReadyPackage elab@ElaboratedConfiguredPackage{..}) - plan ElaboratedSharedConfig{..} distdir srcdir builddir - isParallelBuild cacheLock = - SetupScriptOptions { - useCabalVersion = thisVersion elabSetupScriptCliVersion, - useCabalSpecVersion = Just elabSetupScriptCliVersion, - useCompiler = Just pkgConfigCompiler, - usePlatform = Just pkgConfigPlatform, - usePackageDB = elabSetupPackageDBStack, - usePackageIndex = Nothing, - useDependencies = [ (uid, srcid) - | (ConfiguredId srcid (Just (CLibName LMainLibName)) uid, _) - <- elabSetupDependencies elab ], - useDependenciesExclusive = True, - useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps, - useProgramDb = pkgConfigCompilerProgs, - useDistPref = builddir, - useLoggingHandle = Nothing, -- this gets set later - useWorkingDir = Just srcdir, - useExtraPathEnv = elabExeDependencyPaths elab, - useExtraEnvOverrides = dataDirsEnvironmentForPlan distdir plan, - useWin32CleanHack = False, --TODO: [required eventually] - forceExternalSetupMethod = isParallelBuild, - setupCacheLock = Just cacheLock, - isInteractive = False - } - +setupHsScriptOptions + (ReadyPackage elab@ElaboratedConfiguredPackage{..}) + plan + ElaboratedSharedConfig{..} + distdir + srcdir + builddir + isParallelBuild + cacheLock = + SetupScriptOptions + { useCabalVersion = thisVersion elabSetupScriptCliVersion + , useCabalSpecVersion = Just elabSetupScriptCliVersion + , useCompiler = Just pkgConfigCompiler + , usePlatform = Just pkgConfigPlatform + , usePackageDB = elabSetupPackageDBStack + , usePackageIndex = Nothing + , useDependencies = + [ (uid, srcid) + | (ConfiguredId srcid (Just (CLibName LMainLibName)) uid, _) <- + elabSetupDependencies elab + ] + , useDependenciesExclusive = True + , useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps + , useProgramDb = pkgConfigCompilerProgs + , useDistPref = builddir + , useLoggingHandle = Nothing -- this gets set later + , useWorkingDir = Just srcdir + , useExtraPathEnv = elabExeDependencyPaths elab + , useExtraEnvOverrides = dataDirsEnvironmentForPlan distdir plan + , useWin32CleanHack = False -- TODO: [required eventually] + , forceExternalSetupMethod = isParallelBuild + , setupCacheLock = Just cacheLock + , isInteractive = False + } -- | To be used for the input for elaborateInstallPlan. -- -- TODO: [code cleanup] make InstallDirs.defaultInstallDirs pure. --- -userInstallDirTemplates :: Compiler - -> IO InstallDirs.InstallDirTemplates +userInstallDirTemplates + :: Compiler + -> IO InstallDirs.InstallDirTemplates userInstallDirTemplates compiler = do - InstallDirs.defaultInstallDirs - (compilerFlavor compiler) - True -- user install - False -- unused - -storePackageInstallDirs :: StoreDirLayout - -> CompilerId - -> InstalledPackageId - -> InstallDirs.InstallDirs FilePath + InstallDirs.defaultInstallDirs + (compilerFlavor compiler) + True -- user install + False -- unused + +storePackageInstallDirs + :: StoreDirLayout + -> CompilerId + -> InstalledPackageId + -> InstallDirs.InstallDirs FilePath storePackageInstallDirs storeDirLayout compid ipkgid = storePackageInstallDirs' storeDirLayout compid $ newSimpleUnitId ipkgid -storePackageInstallDirs' :: StoreDirLayout - -> CompilerId - -> UnitId - -> InstallDirs.InstallDirs FilePath -storePackageInstallDirs' StoreDirLayout{ storePackageDirectory - , storeDirectory } - compid unitid = - InstallDirs.InstallDirs {..} - where - store = storeDirectory compid - prefix = storePackageDirectory compid unitid - bindir = prefix "bin" - libdir = prefix "lib" - libsubdir = "" - -- Note: on macOS, we place libraries into - -- @store/lib@ to work around the load - -- command size limit of macOSs mach-o linker. - -- See also @PackageHash.hashedInstalledPackageIdVeryShort@ - dynlibdir | buildOS == OSX = store "lib" - | otherwise = libdir - flibdir = libdir - libexecdir = prefix "libexec" - libexecsubdir= "" - includedir = libdir "include" - datadir = prefix "share" - datasubdir = "" - docdir = datadir "doc" - mandir = datadir "man" - htmldir = docdir "html" - haddockdir = htmldir - sysconfdir = prefix "etc" - - -computeInstallDirs :: StoreDirLayout - -> InstallDirs.InstallDirTemplates - -> ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> InstallDirs.InstallDirs FilePath -computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab - | isInplaceBuildStyle (elabBuildStyle elab) - -- use the ordinary default install dirs - = (InstallDirs.absoluteInstallDirs - (elabPkgSourceId elab) - (elabUnitId elab) - (compilerInfo (pkgConfigCompiler elaboratedShared)) - InstallDirs.NoCopyDest - (pkgConfigPlatform elaboratedShared) - defaultInstallDirs) { - - -- absoluteInstallDirs sets these as 'undefined' but we have - -- to use them as "Setup.hs configure" args - InstallDirs.libsubdir = "", - InstallDirs.libexecsubdir = "", - InstallDirs.datasubdir = "" +storePackageInstallDirs' + :: StoreDirLayout + -> CompilerId + -> UnitId + -> InstallDirs.InstallDirs FilePath +storePackageInstallDirs' + StoreDirLayout + { storePackageDirectory + , storeDirectory } - - | otherwise - -- use special simplified install dirs - = storePackageInstallDirs' - storeDirLayout - (compilerId (pkgConfigCompiler elaboratedShared)) - (elabUnitId elab) - - ---TODO: [code cleanup] perhaps reorder this code + compid + unitid = + InstallDirs.InstallDirs{..} + where + store = storeDirectory compid + prefix = storePackageDirectory compid unitid + bindir = prefix "bin" + libdir = prefix "lib" + libsubdir = "" + -- Note: on macOS, we place libraries into + -- @store/lib@ to work around the load + -- command size limit of macOSs mach-o linker. + -- See also @PackageHash.hashedInstalledPackageIdVeryShort@ + dynlibdir + | buildOS == OSX = store "lib" + | otherwise = libdir + flibdir = libdir + libexecdir = prefix "libexec" + libexecsubdir = "" + includedir = libdir "include" + datadir = prefix "share" + datasubdir = "" + docdir = datadir "doc" + mandir = datadir "man" + htmldir = docdir "html" + haddockdir = htmldir + sysconfdir = prefix "etc" + +computeInstallDirs + :: StoreDirLayout + -> InstallDirs.InstallDirTemplates + -> ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> InstallDirs.InstallDirs FilePath +computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab + | isInplaceBuildStyle (elabBuildStyle elab) = + -- use the ordinary default install dirs + ( InstallDirs.absoluteInstallDirs + (elabPkgSourceId elab) + (elabUnitId elab) + (compilerInfo (pkgConfigCompiler elaboratedShared)) + InstallDirs.NoCopyDest + (pkgConfigPlatform elaboratedShared) + defaultInstallDirs + ) + { -- absoluteInstallDirs sets these as 'undefined' but we have + -- to use them as "Setup.hs configure" args + InstallDirs.libsubdir = "" + , InstallDirs.libexecsubdir = "" + , InstallDirs.datasubdir = "" + } + | otherwise = + -- use special simplified install dirs + storePackageInstallDirs' + storeDirLayout + (compilerId (pkgConfigCompiler elaboratedShared)) + (elabUnitId elab) + +-- TODO: [code cleanup] perhaps reorder this code -- based on the ElaboratedInstallPlan + ElaboratedSharedConfig, -- make the various Setup.hs {configure,build,copy} flags +setupHsConfigureFlags + :: ElaboratedReadyPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.ConfigFlags +setupHsConfigureFlags + (ReadyPackage elab@ElaboratedConfiguredPackage{..}) + sharedConfig@ElaboratedSharedConfig{..} + verbosity + builddir = + sanityCheckElaboratedConfiguredPackage + sharedConfig + elab + (Cabal.ConfigFlags{..}) + where + 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 + configIPID = case elabPkgOrComp of + ElabPackage pkg -> toFlag (prettyShow (pkgInstalledId pkg)) + ElabComponent _ -> mempty + configCID = case elabPkgOrComp of + ElabPackage _ -> mempty + ElabComponent _ -> toFlag elabComponentId + + configProgramPaths = Map.toList elabProgramPaths + configProgramArgs + | {- elabSetupScriptCliVersion < mkVersion [1,24,3] -} True = + -- workaround for + -- + -- It turns out, that even with Cabal 2.0, there's still cases such as e.g. + -- custom Setup.hs scripts calling out to GHC even when going via + -- @runProgram ghcProgram@, as e.g. happy does in its + -- + -- (see also ) + -- + -- So for now, let's pass the rather harmless and idempotent + -- `-hide-all-packages` flag to all invocations (which has + -- the benefit that every GHC invocation starts with a + -- consistently well-defined clean slate) until we find a + -- better way. + Map.toList $ + Map.insertWith + (++) + "ghc" + ["-hide-all-packages"] + elabProgramArgs + configProgramPathExtra = toNubList elabProgramPathExtra + configHcFlavor = toFlag (compilerFlavor pkgConfigCompiler) + configHcPath = mempty -- we use configProgramPaths instead + configHcPkg = mempty -- we use configProgramPaths instead + configVanillaLib = toFlag elabVanillaLib + configSharedLib = toFlag elabSharedLib + configStaticLib = toFlag elabStaticLib + + configDynExe = toFlag elabDynExe + configFullyStaticExe = toFlag elabFullyStaticExe + configGHCiLib = toFlag elabGHCiLib + configProfExe = mempty + configProfLib = toFlag elabProfLib + configProf = toFlag elabProfExe + + -- configProfDetail is for exe+lib, but overridden by configProfLibDetail + -- so we specify both so we can specify independently + configProfDetail = toFlag elabProfExeDetail + configProfLibDetail = toFlag elabProfLibDetail + + configCoverage = toFlag elabCoverage + configLibCoverage = mempty + + configOptimization = toFlag elabOptimization + configSplitSections = toFlag elabSplitSections + configSplitObjs = toFlag elabSplitObjs + configStripExes = toFlag elabStripExes + configStripLibs = toFlag elabStripLibs + configDebugInfo = toFlag elabDebugInfo + configDumpBuildInfo = toFlag elabDumpBuildInfo + + configConfigurationsFlags = elabFlagAssignment + configConfigureArgs = elabConfigureScriptArgs + configExtraLibDirs = elabExtraLibDirs + configExtraLibDirsStatic = elabExtraLibDirsStatic + configExtraFrameworkDirs = elabExtraFrameworkDirs + configExtraIncludeDirs = elabExtraIncludeDirs + configProgPrefix = maybe mempty toFlag elabProgPrefix + configProgSuffix = maybe mempty toFlag elabProgSuffix + + configInstallDirs = + fmap + (toFlag . InstallDirs.toPathTemplate) + elabInstallDirs + + -- we only use configDependencies, unless we're talking to an old Cabal + -- in which case we use configConstraints + -- NB: This does NOT use InstallPlan.depends, which includes executable + -- dependencies which should NOT be fed in here (also you don't have + -- enough info anyway) + -- + configDependencies = + [ cidToGivenComponent cid + | (cid, is_internal) <- elabLibDependencies elab + , not is_internal + ] -setupHsConfigureFlags :: ElaboratedReadyPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.ConfigFlags -setupHsConfigureFlags (ReadyPackage elab@ElaboratedConfiguredPackage{..}) - sharedConfig@ElaboratedSharedConfig{..} - verbosity builddir = - sanityCheckElaboratedConfiguredPackage sharedConfig elab - (Cabal.ConfigFlags {..}) - where - 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 - configIPID = case elabPkgOrComp of - ElabPackage pkg -> toFlag (prettyShow (pkgInstalledId pkg)) - ElabComponent _ -> mempty - configCID = case elabPkgOrComp of - ElabPackage _ -> mempty - ElabComponent _ -> toFlag elabComponentId - - configProgramPaths = Map.toList elabProgramPaths - configProgramArgs - | {- elabSetupScriptCliVersion < mkVersion [1,24,3] -} True - -- workaround for - -- - -- It turns out, that even with Cabal 2.0, there's still cases such as e.g. - -- custom Setup.hs scripts calling out to GHC even when going via - -- @runProgram ghcProgram@, as e.g. happy does in its - -- - -- (see also ) - -- - -- So for now, let's pass the rather harmless and idempotent - -- `-hide-all-packages` flag to all invocations (which has - -- the benefit that every GHC invocation starts with a - -- consistently well-defined clean slate) until we find a - -- better way. - = Map.toList $ - Map.insertWith (++) "ghc" ["-hide-all-packages"] - elabProgramArgs - configProgramPathExtra = toNubList elabProgramPathExtra - configHcFlavor = toFlag (compilerFlavor pkgConfigCompiler) - configHcPath = mempty -- we use configProgramPaths instead - configHcPkg = mempty -- we use configProgramPaths instead - - configVanillaLib = toFlag elabVanillaLib - configSharedLib = toFlag elabSharedLib - configStaticLib = toFlag elabStaticLib - - configDynExe = toFlag elabDynExe - configFullyStaticExe = toFlag elabFullyStaticExe - configGHCiLib = toFlag elabGHCiLib - configProfExe = mempty - configProfLib = toFlag elabProfLib - configProf = toFlag elabProfExe - - -- configProfDetail is for exe+lib, but overridden by configProfLibDetail - -- so we specify both so we can specify independently - configProfDetail = toFlag elabProfExeDetail - configProfLibDetail = toFlag elabProfLibDetail - - configCoverage = toFlag elabCoverage - configLibCoverage = mempty - - configOptimization = toFlag elabOptimization - configSplitSections = toFlag elabSplitSections - configSplitObjs = toFlag elabSplitObjs - configStripExes = toFlag elabStripExes - configStripLibs = toFlag elabStripLibs - configDebugInfo = toFlag elabDebugInfo - configDumpBuildInfo = toFlag elabDumpBuildInfo - - configConfigurationsFlags = elabFlagAssignment - configConfigureArgs = elabConfigureScriptArgs - configExtraLibDirs = elabExtraLibDirs - configExtraLibDirsStatic = elabExtraLibDirsStatic - configExtraFrameworkDirs = elabExtraFrameworkDirs - configExtraIncludeDirs = elabExtraIncludeDirs - configProgPrefix = maybe mempty toFlag elabProgPrefix - configProgSuffix = maybe mempty toFlag elabProgSuffix - - configInstallDirs = fmap (toFlag . InstallDirs.toPathTemplate) - elabInstallDirs - - -- we only use configDependencies, unless we're talking to an old Cabal - -- in which case we use configConstraints - -- NB: This does NOT use InstallPlan.depends, which includes executable - -- dependencies which should NOT be fed in here (also you don't have - -- enough info anyway) - -- - configDependencies = [ cidToGivenComponent cid - | (cid, is_internal) <- elabLibDependencies elab - , not is_internal - ] - - configPromisedDependencies= [ cidToGivenComponent cid - | (cid, is_internal) <- elabLibDependencies elab - , is_internal - ] + configPromisedDependencies = + [ cidToGivenComponent cid + | (cid, is_internal) <- elabLibDependencies elab + , is_internal + ] - configConstraints = + configConstraints = case elabPkgOrComp of - ElabPackage _ -> - [ thisPackageVersionConstraint srcid - | (ConfiguredId srcid _ _uid, _) <- elabLibDependencies elab ] - 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 - configBenchmarks = case elabPkgOrComp of - ElabPackage pkg -> toFlag (BenchStanzas `optStanzaSetMember` pkgStanzasEnabled pkg) - ElabComponent _ -> mempty - - configExactConfiguration = toFlag True - configFlagError = mempty --TODO: [research required] appears not to be implemented - configRelocatable = mempty --TODO: [research required] ??? - configScratchDir = mempty -- never use - configUserInstall = mempty -- don't rely on defaults - configPrograms_ = mempty -- never use, shouldn't exist - configUseResponseFiles = mempty - configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported pkgConfigCompiler - - cidToGivenComponent :: ConfiguredId -> GivenComponent - cidToGivenComponent (ConfiguredId srcid mb_cn cid) = GivenComponent (packageName srcid) ln cid - where - ln = case mb_cn of - Just (CLibName lname) -> lname - Just _ -> error "non-library dependency" - Nothing -> LMainLibName - -setupHsConfigureArgs :: ElaboratedConfiguredPackage - -> [String] -setupHsConfigureArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ }) = [] -setupHsConfigureArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp }) = - [showComponentTarget (packageId elab) (ComponentTarget cname WholeComponent)] + ElabPackage _ -> + [ thisPackageVersionConstraint srcid + | (ConfiguredId srcid _ _uid, _) <- elabLibDependencies elab + ] + 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 + configBenchmarks = case elabPkgOrComp of + ElabPackage pkg -> toFlag (BenchStanzas `optStanzaSetMember` pkgStanzasEnabled pkg) + ElabComponent _ -> mempty + + configExactConfiguration = toFlag True + configFlagError = mempty -- TODO: [research required] appears not to be implemented + configRelocatable = mempty -- TODO: [research required] ??? + configScratchDir = mempty -- never use + configUserInstall = mempty -- don't rely on defaults + configPrograms_ = mempty -- never use, shouldn't exist + configUseResponseFiles = mempty + configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported pkgConfigCompiler + + cidToGivenComponent :: ConfiguredId -> GivenComponent + cidToGivenComponent (ConfiguredId srcid mb_cn cid) = GivenComponent (packageName srcid) ln cid + where + ln = case mb_cn of + Just (CLibName lname) -> lname + Just _ -> error "non-library dependency" + Nothing -> LMainLibName + +setupHsConfigureArgs + :: ElaboratedConfiguredPackage + -> [String] +setupHsConfigureArgs (ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage _}) = [] +setupHsConfigureArgs elab@(ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent comp}) = + [showComponentTarget (packageId elab) (ComponentTarget cname WholeComponent)] where - cname = fromMaybe (error "setupHsConfigureArgs: trying to configure setup") - (compComponentName comp) - -setupHsBuildFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.BuildFlags + cname = + fromMaybe + (error "setupHsConfigureArgs: trying to configure setup") + (compComponentName comp) + +setupHsBuildFlags + :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.BuildFlags setupHsBuildFlags _ _ verbosity builddir = - Cabal.BuildFlags { - 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), - buildArgs = mempty, -- unused, passed via args not flags - buildCabalFilePath= mempty + Cabal.BuildFlags + { 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), + , buildArgs = mempty -- unused, passed via args not flags + , buildCabalFilePath = mempty } - setupHsBuildArgs :: ElaboratedConfiguredPackage -> [String] -setupHsBuildArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ }) - -- Fix for #3335, don't pass build arguments if it's not supported - | elabSetupScriptCliVersion elab >= mkVersion [1,17] - = map (showComponentTarget (packageId elab)) (elabBuildTargets elab) - | otherwise - = [] -setupHsBuildArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent _ }) - = [] - - -setupHsTestFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.TestFlags -setupHsTestFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = Cabal.TestFlags - { testDistPref = toFlag builddir - , testVerbosity = toFlag verbosity - , testMachineLog = maybe mempty toFlag elabTestMachineLog - , testHumanLog = maybe mempty toFlag elabTestHumanLog +setupHsBuildArgs elab@(ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage _}) + -- Fix for #3335, don't pass build arguments if it's not supported + | elabSetupScriptCliVersion elab >= mkVersion [1, 17] = + map (showComponentTarget (packageId elab)) (elabBuildTargets elab) + | otherwise = + [] +setupHsBuildArgs (ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent _}) = + [] + +setupHsTestFlags + :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.TestFlags +setupHsTestFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = + Cabal.TestFlags + { testDistPref = toFlag builddir + , testVerbosity = toFlag verbosity + , testMachineLog = maybe mempty toFlag elabTestMachineLog + , testHumanLog = maybe mempty toFlag elabTestHumanLog , testShowDetails = maybe (Flag Cabal.Always) toFlag elabTestShowDetails - , testKeepTix = toFlag elabTestKeepTix - , testWrapper = maybe mempty toFlag elabTestWrapper + , testKeepTix = toFlag elabTestKeepTix + , testWrapper = maybe mempty toFlag elabTestWrapper , testFailWhenNoTestSuites = toFlag elabTestFailWhenNoTestSuites - , testOptions = elabTestTestOptions + , testOptions = elabTestTestOptions } setupHsTestArgs :: ElaboratedConfiguredPackage -> [String] -- TODO: Does the issue #3335 affects test as well setupHsTestArgs elab = - mapMaybe (showTestComponentTarget (packageId elab)) (elabTestTargets elab) - + mapMaybe (showTestComponentTarget (packageId elab)) (elabTestTargets elab) -setupHsBenchFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.BenchmarkFlags -setupHsBenchFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = Cabal.BenchmarkFlags - { benchmarkDistPref = toFlag builddir +setupHsBenchFlags + :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.BenchmarkFlags +setupHsBenchFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = + Cabal.BenchmarkFlags + { benchmarkDistPref = toFlag builddir , benchmarkVerbosity = toFlag verbosity - , benchmarkOptions = elabBenchmarkOptions + , benchmarkOptions = elabBenchmarkOptions } setupHsBenchArgs :: ElaboratedConfiguredPackage -> [String] setupHsBenchArgs elab = - mapMaybe (showBenchComponentTarget (packageId elab)) (elabBenchTargets elab) + mapMaybe (showBenchComponentTarget (packageId elab)) (elabBenchTargets elab) - -setupHsReplFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.ReplFlags +setupHsReplFlags + :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.ReplFlags setupHsReplFlags _ sharedConfig verbosity builddir = - Cabal.ReplFlags { - 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 + Cabal.ReplFlags + { 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 } - setupHsReplArgs :: ElaboratedConfiguredPackage -> [String] setupHsReplArgs elab = - map (\t -> showComponentTarget (packageId elab) t) (elabReplTarget elab) + map (\t -> showComponentTarget (packageId elab) t) (elabReplTarget elab) -setupHsCopyFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> FilePath - -> Cabal.CopyFlags +setupHsCopyFlags + :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> FilePath + -> Cabal.CopyFlags setupHsCopyFlags _ _ verbosity builddir destdir = - Cabal.CopyFlags { - copyArgs = [], -- TODO: could use this to only copy what we enabled - copyDest = toFlag (InstallDirs.CopyTo destdir), - copyDistPref = toFlag builddir, - copyVerbosity = toFlag verbosity, - copyCabalFilePath = mempty + Cabal.CopyFlags + { copyArgs = [] -- TODO: could use this to only copy what we enabled + , copyDest = toFlag (InstallDirs.CopyTo destdir) + , copyDistPref = toFlag builddir + , copyVerbosity = toFlag verbosity + , copyCabalFilePath = mempty } -setupHsRegisterFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> FilePath - -> Cabal.RegisterFlags -setupHsRegisterFlags ElaboratedConfiguredPackage{..} _ - verbosity builddir pkgConfFile = - Cabal.RegisterFlags { - regPackageDB = mempty, -- misfeature - regGenScript = mempty, -- never use - regGenPkgConf = toFlag (Just pkgConfFile), - regInPlace = case elabBuildStyle of - BuildInplaceOnly {} -> toFlag True - BuildAndInstall -> toFlag False, - regPrintId = mempty, -- never use - regDistPref = toFlag builddir, - regArgs = [], - regVerbosity = toFlag verbosity, - regCabalFilePath = mempty - } +setupHsRegisterFlags + :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> FilePath + -> Cabal.RegisterFlags +setupHsRegisterFlags + ElaboratedConfiguredPackage{..} + _ + verbosity + builddir + pkgConfFile = + Cabal.RegisterFlags + { regPackageDB = mempty -- misfeature + , regGenScript = mempty -- never use + , regGenPkgConf = toFlag (Just 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 - -> Cabal.HaddockFlags +setupHsHaddockFlags + :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.HaddockFlags setupHsHaddockFlags (ElaboratedConfiguredPackage{..}) (ElaboratedSharedConfig{..}) verbosity builddir = - Cabal.HaddockFlags { - haddockProgramPaths = + 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 + 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 } setupHsHaddockArgs :: ElaboratedConfiguredPackage -> [String] @@ -3962,7 +4430,9 @@ setupHsTestFlags _ _ verbosity builddir = -} ------------------------------------------------------------------------------ + -- * Sharing installed packages + ------------------------------------------------------------------------------ -- @@ -4003,103 +4473,112 @@ setupHsTestFlags _ _ verbosity builddir = -- TODO: [required eventually] for safety of concurrent installs, we must make sure we register but -- not replace installed packages with ghc-pkg. -packageHashInputs :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> PackageHashInputs packageHashInputs - pkgshared - elab@(ElaboratedConfiguredPackage { - elabPkgSourceHash = Just srchash - }) = - PackageHashInputs { - pkgHashPkgId = packageId elab, - pkgHashComponent = - case elabPkgOrComp elab of - ElabPackage _ -> Nothing - ElabComponent comp -> Just (compSolverName comp), - pkgHashSourceHash = srchash, - pkgHashPkgConfigDeps = Set.fromList (elabPkgConfigDependencies elab), - pkgHashDirectDeps = - case elabPkgOrComp elab of - ElabPackage (ElaboratedPackage{..}) -> - Set.fromList $ - [ confInstId dep - | (dep, _) <- CD.select relevantDeps pkgLibDependencies ] ++ - [ confInstId dep - | dep <- CD.select relevantDeps pkgExeDependencies ] - ElabComponent comp -> - Set.fromList (map confInstId ((map fst $ compLibDependencies comp) - ++ compExeDependencies comp)), - pkgHashOtherConfig = packageHashConfigInputs pkgshared elab - } - where - -- Obviously the main deps are relevant - relevantDeps CD.ComponentLib = True - relevantDeps (CD.ComponentSubLib _) = True - relevantDeps (CD.ComponentFLib _) = True - relevantDeps (CD.ComponentExe _) = True - -- Setup deps can affect the Setup.hs behaviour and thus what is built - relevantDeps CD.ComponentSetup = True - -- However testsuites and benchmarks do not get installed and should not - -- affect the result, so we do not include them. - relevantDeps (CD.ComponentTest _) = False - relevantDeps (CD.ComponentBench _) = False - + :: ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> PackageHashInputs +packageHashInputs + pkgshared + elab@( ElaboratedConfiguredPackage + { elabPkgSourceHash = Just srchash + } + ) = + PackageHashInputs + { pkgHashPkgId = packageId elab + , pkgHashComponent = + case elabPkgOrComp elab of + ElabPackage _ -> Nothing + ElabComponent comp -> Just (compSolverName comp) + , pkgHashSourceHash = srchash + , pkgHashPkgConfigDeps = Set.fromList (elabPkgConfigDependencies elab) + , pkgHashDirectDeps = + case elabPkgOrComp elab of + ElabPackage (ElaboratedPackage{..}) -> + Set.fromList $ + [ confInstId dep + | (dep, _) <- CD.select relevantDeps pkgLibDependencies + ] + ++ [ confInstId dep + | dep <- CD.select relevantDeps pkgExeDependencies + ] + ElabComponent comp -> + Set.fromList + ( map + confInstId + ( (map fst $ compLibDependencies comp) + ++ compExeDependencies comp + ) + ) + , pkgHashOtherConfig = packageHashConfigInputs pkgshared elab + } + where + -- Obviously the main deps are relevant + relevantDeps CD.ComponentLib = True + relevantDeps (CD.ComponentSubLib _) = True + relevantDeps (CD.ComponentFLib _) = True + relevantDeps (CD.ComponentExe _) = True + -- Setup deps can affect the Setup.hs behaviour and thus what is built + relevantDeps CD.ComponentSetup = True + -- However testsuites and benchmarks do not get installed and should not + -- affect the result, so we do not include them. + relevantDeps (CD.ComponentTest _) = False + relevantDeps (CD.ComponentBench _) = False packageHashInputs _ pkg = - error $ "packageHashInputs: only for packages with source hashes. " - ++ prettyShow (packageId pkg) + error $ + "packageHashInputs: only for packages with source hashes. " + ++ prettyShow (packageId pkg) -packageHashConfigInputs :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> PackageHashConfigInputs +packageHashConfigInputs + :: ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> PackageHashConfigInputs packageHashConfigInputs shared@ElaboratedSharedConfig{..} pkg = - PackageHashConfigInputs { - pkgHashCompilerId = compilerId pkgConfigCompiler, - pkgHashPlatform = pkgConfigPlatform, - pkgHashFlagAssignment = elabFlagAssignment, - pkgHashConfigureScriptArgs = elabConfigureScriptArgs, - pkgHashVanillaLib = elabVanillaLib, - pkgHashSharedLib = elabSharedLib, - pkgHashDynExe = elabDynExe, - pkgHashFullyStaticExe = elabFullyStaticExe, - pkgHashGHCiLib = elabGHCiLib, - pkgHashProfLib = elabProfLib, - pkgHashProfExe = elabProfExe, - pkgHashProfLibDetail = elabProfLibDetail, - pkgHashProfExeDetail = elabProfExeDetail, - pkgHashCoverage = elabCoverage, - pkgHashOptimization = elabOptimization, - pkgHashSplitSections = elabSplitSections, - pkgHashSplitObjs = elabSplitObjs, - pkgHashStripLibs = elabStripLibs, - pkgHashStripExes = elabStripExes, - pkgHashDebugInfo = elabDebugInfo, - pkgHashProgramArgs = elabProgramArgs, - pkgHashExtraLibDirs = elabExtraLibDirs, - pkgHashExtraLibDirsStatic = elabExtraLibDirsStatic, - pkgHashExtraFrameworkDirs = elabExtraFrameworkDirs, - pkgHashExtraIncludeDirs = elabExtraIncludeDirs, - pkgHashProgPrefix = elabProgPrefix, - pkgHashProgSuffix = elabProgSuffix, - pkgHashPackageDbs = elabPackageDbs, - - pkgHashDocumentation = elabBuildHaddocks, - pkgHashHaddockHoogle = elabHaddockHoogle, - pkgHashHaddockHtml = elabHaddockHtml, - pkgHashHaddockHtmlLocation = elabHaddockHtmlLocation, - pkgHashHaddockForeignLibs = elabHaddockForeignLibs, - pkgHashHaddockExecutables = elabHaddockExecutables, - pkgHashHaddockTestSuites = elabHaddockTestSuites, - pkgHashHaddockBenchmarks = elabHaddockBenchmarks, - pkgHashHaddockInternal = elabHaddockInternal, - pkgHashHaddockCss = elabHaddockCss, - pkgHashHaddockLinkedSource = elabHaddockLinkedSource, - pkgHashHaddockQuickJump = elabHaddockQuickJump, - pkgHashHaddockContents = elabHaddockContents, - pkgHashHaddockIndex = elabHaddockIndex, - pkgHashHaddockBaseUrl = elabHaddockBaseUrl, - pkgHashHaddockLib = elabHaddockLib, - pkgHashHaddockOutputDir = elabHaddockOutputDir + PackageHashConfigInputs + { pkgHashCompilerId = compilerId pkgConfigCompiler + , pkgHashPlatform = pkgConfigPlatform + , pkgHashFlagAssignment = elabFlagAssignment + , pkgHashConfigureScriptArgs = elabConfigureScriptArgs + , pkgHashVanillaLib = elabVanillaLib + , pkgHashSharedLib = elabSharedLib + , pkgHashDynExe = elabDynExe + , pkgHashFullyStaticExe = elabFullyStaticExe + , pkgHashGHCiLib = elabGHCiLib + , pkgHashProfLib = elabProfLib + , pkgHashProfExe = elabProfExe + , pkgHashProfLibDetail = elabProfLibDetail + , pkgHashProfExeDetail = elabProfExeDetail + , pkgHashCoverage = elabCoverage + , pkgHashOptimization = elabOptimization + , pkgHashSplitSections = elabSplitSections + , pkgHashSplitObjs = elabSplitObjs + , pkgHashStripLibs = elabStripLibs + , pkgHashStripExes = elabStripExes + , pkgHashDebugInfo = elabDebugInfo + , pkgHashProgramArgs = elabProgramArgs + , pkgHashExtraLibDirs = elabExtraLibDirs + , pkgHashExtraLibDirsStatic = elabExtraLibDirsStatic + , pkgHashExtraFrameworkDirs = elabExtraFrameworkDirs + , pkgHashExtraIncludeDirs = elabExtraIncludeDirs + , pkgHashProgPrefix = elabProgPrefix + , pkgHashProgSuffix = elabProgSuffix + , pkgHashPackageDbs = elabPackageDbs + , pkgHashDocumentation = elabBuildHaddocks + , pkgHashHaddockHoogle = elabHaddockHoogle + , pkgHashHaddockHtml = elabHaddockHtml + , pkgHashHaddockHtmlLocation = elabHaddockHtmlLocation + , pkgHashHaddockForeignLibs = elabHaddockForeignLibs + , pkgHashHaddockExecutables = elabHaddockExecutables + , pkgHashHaddockTestSuites = elabHaddockTestSuites + , pkgHashHaddockBenchmarks = elabHaddockBenchmarks + , pkgHashHaddockInternal = elabHaddockInternal + , pkgHashHaddockCss = elabHaddockCss + , pkgHashHaddockLinkedSource = elabHaddockLinkedSource + , pkgHashHaddockQuickJump = elabHaddockQuickJump + , pkgHashHaddockContents = elabHaddockContents + , pkgHashHaddockIndex = elabHaddockIndex + , pkgHashHaddockBaseUrl = elabHaddockBaseUrl + , pkgHashHaddockLib = elabHaddockLib + , pkgHashHaddockOutputDir = elabHaddockOutputDir } where ElaboratedConfiguredPackage{..} = normaliseConfiguredPackage shared pkg @@ -4107,22 +4586,22 @@ packageHashConfigInputs shared@ElaboratedSharedConfig{..} pkg = -- | Given the 'InstalledPackageIndex' for a nix-style package store, and an -- 'ElaboratedInstallPlan', replace configured source packages by installed -- packages from the store whenever they exist. --- -improveInstallPlanWithInstalledPackages :: Set UnitId - -> ElaboratedInstallPlan - -> ElaboratedInstallPlan +improveInstallPlanWithInstalledPackages + :: Set UnitId + -> ElaboratedInstallPlan + -> ElaboratedInstallPlan improveInstallPlanWithInstalledPackages installedPkgIdSet = - InstallPlan.installed canPackageBeImproved + InstallPlan.installed canPackageBeImproved where canPackageBeImproved pkg = installedUnitId pkg `Set.member` installedPkgIdSet - --TODO: sanity checks: - -- * the installed package must have the expected deps etc - -- * the installed package must not be broken, valid dep closure - --TODO: decide what to do if we encounter broken installed packages, - -- since overwriting is never safe. +-- TODO: sanity checks: +-- \* the installed package must have the expected deps etc +-- \* the installed package must not be broken, valid dep closure +-- TODO: decide what to do if we encounter broken installed packages, +-- since overwriting is never safe. -- Path construction ------ @@ -4142,7 +4621,7 @@ binDirectoryFor -> FilePath binDirectoryFor layout config package exe = case elabBuildStyle package of BuildAndInstall -> installedBinDirectory package - BuildInplaceOnly {} -> inplaceBinRoot layout config package exe + BuildInplaceOnly{} -> inplaceBinRoot layout config package exe -- package has been built and installed. installedBinDirectory :: ElaboratedConfiguredPackage -> FilePath @@ -4154,6 +4633,6 @@ inplaceBinRoot -> ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> FilePath -inplaceBinRoot layout config package - = distBuildDirectory layout (elabDistDirParams config package) - "build" +inplaceBinRoot layout config package = + distBuildDirectory layout (elabDistDirParams config package) + "build" diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index 3efb7fa9783..28af81774eb 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -1,121 +1,124 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-} -- | Types used while planning how to build everything in a project. -- -- Primarily this is the 'ElaboratedInstallPlan'. --- -module Distribution.Client.ProjectPlanning.Types ( - SolverInstallPlan, +module Distribution.Client.ProjectPlanning.Types + ( SolverInstallPlan -- * Elaborated install plan types - ElaboratedInstallPlan, - normaliseConfiguredPackage, - ElaboratedConfiguredPackage(..), - showElaboratedInstallPlan, - - elabDistDirParams, - elabExeDependencyPaths, - elabLibDependencies, - elabOrderLibDependencies, - elabExeDependencies, - elabOrderExeDependencies, - elabSetupDependencies, - elabPkgConfigDependencies, - elabInplaceDependencyBuildCacheFiles, - elabRequiresRegistration, - dataDirsEnvironmentForPlan, - - elabPlanPackageName, - elabConfiguredName, - elabComponentName, - - ElaboratedPackageOrComponent(..), - ElaboratedComponent(..), - ElaboratedPackage(..), - pkgOrderDependencies, - ElaboratedPlanPackage, - ElaboratedSharedConfig(..), - ElaboratedReadyPackage, - BuildStyle(..), - MemoryOrDisk(..), - isInplaceBuildStyle, - CabalFileText, + , ElaboratedInstallPlan + , normaliseConfiguredPackage + , ElaboratedConfiguredPackage (..) + , showElaboratedInstallPlan + , elabDistDirParams + , elabExeDependencyPaths + , elabLibDependencies + , elabOrderLibDependencies + , elabExeDependencies + , elabOrderExeDependencies + , elabSetupDependencies + , elabPkgConfigDependencies + , elabInplaceDependencyBuildCacheFiles + , elabRequiresRegistration + , dataDirsEnvironmentForPlan + , elabPlanPackageName + , elabConfiguredName + , elabComponentName + , ElaboratedPackageOrComponent (..) + , ElaboratedComponent (..) + , ElaboratedPackage (..) + , pkgOrderDependencies + , ElaboratedPlanPackage + , ElaboratedSharedConfig (..) + , ElaboratedReadyPackage + , BuildStyle (..) + , MemoryOrDisk (..) + , isInplaceBuildStyle + , CabalFileText -- * Build targets - ComponentTarget(..), - showComponentTarget, - showTestComponentTarget, - showBenchComponentTarget, - SubComponentTarget(..), - - isSubLibComponentTarget, - isForeignLibComponentTarget, - isExeComponentTarget, - isTestComponentTarget, - isBenchComponentTarget, - - componentOptionalStanza, + , ComponentTarget (..) + , showComponentTarget + , showTestComponentTarget + , showBenchComponentTarget + , SubComponentTarget (..) + , isSubLibComponentTarget + , isForeignLibComponentTarget + , isExeComponentTarget + , isTestComponentTarget + , isBenchComponentTarget + , componentOptionalStanza -- * Setup script - SetupScriptStyle(..), + , SetupScriptStyle (..) ) where -import Distribution.Client.Compat.Prelude -import Prelude () +import Distribution.Client.Compat.Prelude +import Prelude () -import Distribution.Client.TargetSelector - ( SubComponentTarget(..) ) -import Distribution.Client.PackageHash +import Distribution.Client.PackageHash +import Distribution.Client.TargetSelector + ( SubComponentTarget (..) + ) -import Distribution.Client.Types +import Distribution.Client.DistDirLayout +import Distribution.Client.InstallPlan + ( GenericInstallPlan + , GenericPlanPackage (..) + ) import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.InstallPlan - ( GenericInstallPlan, GenericPlanPackage(..) ) -import Distribution.Client.SolverInstallPlan - ( SolverInstallPlan ) -import Distribution.Client.DistDirLayout - -import Distribution.Backpack -import Distribution.Backpack.ModuleShape - -import Distribution.Verbosity (normal) -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.PkgconfigVersion -import Distribution.Types.PackageDescription (PackageDescription(..)) -import Distribution.Package -import Distribution.System +import Distribution.Client.SolverInstallPlan + ( SolverInstallPlan + ) +import Distribution.Client.Types + +import Distribution.Backpack +import Distribution.Backpack.ModuleShape + +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import Distribution.ModuleName (ModuleName) +import Distribution.Package import qualified Distribution.PackageDescription as Cabal -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import Distribution.Simple.Compiler -import Distribution.Simple.Build.PathsModule (pkgPathEnvVar) +import Distribution.Simple.Build.PathsModule (pkgPathEnvVar) import qualified Distribution.Simple.BuildTarget as Cabal -import Distribution.Simple.Program -import Distribution.ModuleName (ModuleName) -import Distribution.Simple.LocalBuildInfo - ( ComponentName(..), LibraryName(..) ) +import Distribution.Simple.Compiler +import Distribution.Simple.InstallDirs (PathTemplate) import qualified Distribution.Simple.InstallDirs as InstallDirs -import Distribution.Simple.InstallDirs (PathTemplate) -import Distribution.Simple.Setup - ( HaddockTarget, TestShowDetails, DumpBuildInfo (..), ReplOptions ) -import Distribution.Version - +import Distribution.Simple.LocalBuildInfo + ( ComponentName (..) + , LibraryName (..) + ) +import Distribution.Simple.Program +import Distribution.Simple.Setup + ( DumpBuildInfo (..) + , HaddockTarget + , ReplOptions + , TestShowDetails + ) +import Distribution.System +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.PackageDescription (PackageDescription (..)) +import Distribution.Types.PkgconfigVersion +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.ComponentDeps (ComponentDeps) -import Distribution.Solver.Types.OptionalStanza -import Distribution.Compat.Graph (IsNode(..)) -import Distribution.Simple.Utils (ordNub) +import Distribution.Solver.Types.OptionalStanza -import qualified Data.Map as Map import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map as Map import qualified Data.Monoid as Mon -import System.FilePath (()) -import Text.PrettyPrint ( hsep, parens, text ) - +import System.FilePath (()) +import Text.PrettyPrint (hsep, parens, text) -- | The combination of an elaborated install plan plus a -- 'ElaboratedSharedConfig' contains all the details necessary to be able @@ -123,255 +126,234 @@ import Text.PrettyPrint ( hsep, parens, text ) -- -- It does not include dynamic elements such as resources (such as http -- connections). --- -type ElaboratedInstallPlan - = GenericInstallPlan InstalledPackageInfo - ElaboratedConfiguredPackage +type ElaboratedInstallPlan = + GenericInstallPlan + InstalledPackageInfo + ElaboratedConfiguredPackage -type ElaboratedPlanPackage - = GenericPlanPackage InstalledPackageInfo - ElaboratedConfiguredPackage +type ElaboratedPlanPackage = + GenericPlanPackage + InstalledPackageInfo + ElaboratedConfiguredPackage -- | User-friendly display string for an 'ElaboratedPlanPackage'. elabPlanPackageName :: Verbosity -> ElaboratedPlanPackage -> String elabPlanPackageName verbosity (PreExisting ipkg) - | verbosity <= normal = prettyShow (packageName ipkg) - | otherwise = prettyShow (installedUnitId ipkg) -elabPlanPackageName verbosity (Configured elab) - = elabConfiguredName verbosity elab -elabPlanPackageName verbosity (Installed elab) - = elabConfiguredName verbosity elab + | verbosity <= normal = prettyShow (packageName ipkg) + | otherwise = prettyShow (installedUnitId ipkg) +elabPlanPackageName verbosity (Configured elab) = + elabConfiguredName verbosity elab +elabPlanPackageName verbosity (Installed elab) = + elabConfiguredName verbosity elab showElaboratedInstallPlan :: ElaboratedInstallPlan -> String showElaboratedInstallPlan = InstallPlan.showInstallPlan_gen showNode where - showNode pkg = InstallPlan.ShowPlanNode { InstallPlan.showPlanHerald = herald - , InstallPlan.showPlanNeighbours = deps } + showNode pkg = + InstallPlan.ShowPlanNode + { InstallPlan.showPlanHerald = herald + , InstallPlan.showPlanNeighbours = deps + } where - herald = (hsep [ text (InstallPlan.showPlanPackageTag pkg) - , InstallPlan.foldPlanPackage (const mempty) in_mem pkg - , pretty (packageId pkg) - , parens (pretty (nodeKey pkg))]) + herald = + ( hsep + [ text (InstallPlan.showPlanPackageTag pkg) + , InstallPlan.foldPlanPackage (const mempty) in_mem pkg + , pretty (packageId pkg) + , parens (pretty (nodeKey pkg)) + ] + ) in_mem elab = case elabBuildStyle elab of - BuildInplaceOnly InMemory -> parens (text "In Memory") - _ -> mempty + BuildInplaceOnly InMemory -> parens (text "In Memory") + _ -> mempty deps = InstallPlan.foldPlanPackage installed_deps local_deps pkg installed_deps = map pretty . nodeNeighbors - local_deps cfg = [ (if internal then text "+" else mempty) <> pretty (confInstId uid) | (uid, internal) <- elabLibDependencies cfg ] + local_deps cfg = [(if internal then text "+" else mempty) <> pretty (confInstId uid) | (uid, internal) <- elabLibDependencies cfg] ---TODO: [code cleanup] decide if we really need this, there's not much in it, and in principle +-- TODO: [code cleanup] decide if we really need this, there's not much in it, and in principle -- even platform and compiler could be different if we're building things -- like a server + client with ghc + ghcjs -data ElaboratedSharedConfig - = ElaboratedSharedConfig { - - pkgConfigPlatform :: Platform, - pkgConfigCompiler :: Compiler, --TODO: [code cleanup] replace with CompilerInfo - -- | The programs that the compiler configured (e.g. for GHC, the progs - -- ghc & ghc-pkg). Once constructed, only the 'configuredPrograms' are - -- used. - pkgConfigCompilerProgs :: ProgramDb, - pkgConfigReplOptions :: ReplOptions - } +data ElaboratedSharedConfig = ElaboratedSharedConfig + { pkgConfigPlatform :: Platform + , pkgConfigCompiler :: Compiler -- TODO: [code cleanup] replace with CompilerInfo + , pkgConfigCompilerProgs :: ProgramDb + -- ^ The programs that the compiler configured (e.g. for GHC, the progs + -- ghc & ghc-pkg). Once constructed, only the 'configuredPrograms' are + -- used. + , pkgConfigReplOptions :: ReplOptions + } deriving (Show, Generic, Typeable) - --TODO: [code cleanup] no Eq instance + +-- TODO: [code cleanup] no Eq instance instance Binary ElaboratedSharedConfig instance Structured ElaboratedSharedConfig -data ElaboratedConfiguredPackage - = ElaboratedConfiguredPackage { - -- | The 'UnitId' which uniquely identifies this item in a build plan - elabUnitId :: UnitId, - - elabComponentId :: ComponentId, - elabInstantiatedWith :: Map ModuleName Module, - elabLinkedInstantiatedWith :: Map ModuleName OpenModule, - - -- | This is true if this is an indefinite package, or this is a - -- package with no signatures. (Notably, it's not true for instantiated - -- packages.) The motivation for this is if you ask to build - -- @foo-indef@, this probably means that you want to typecheck - -- it, NOT that you want to rebuild all of the various - -- instantiations of it. - elabIsCanonical :: Bool, - - -- | The 'PackageId' of the originating package - elabPkgSourceId :: PackageId, - - -- | Shape of the package/component, for Backpack. - elabModuleShape :: ModuleShape, - - -- | A total flag assignment for the package. - -- TODO: Actually this can be per-component if we drop - -- all flags that don't affect a component. - elabFlagAssignment :: Cabal.FlagAssignment, - - -- | The original default flag assignment, used only for reporting. - elabFlagDefaults :: Cabal.FlagAssignment, - - elabPkgDescription :: Cabal.PackageDescription, - - -- | Where the package comes from, e.g. tarball, local dir etc. This - -- is not the same as where it may be unpacked to for the build. - elabPkgSourceLocation :: PackageLocation (Maybe FilePath), - - -- | The hash of the source, e.g. the tarball. We don't have this for - -- local source dir packages. - elabPkgSourceHash :: Maybe PackageSourceHash, - - -- | Is this package one of the ones specified by location in the - -- project file? (As opposed to a dependency, or a named package pulled - -- in) - elabLocalToProject :: Bool, - - -- | Are we going to build and install this package to the store, or are - -- we going to build it and register it locally. - elabBuildStyle :: BuildStyle, - - -- | Another way of phrasing 'pkgStanzasAvailable'. - elabEnabledSpec :: ComponentRequestedSpec, - - -- | Which optional stanzas (ie testsuites, benchmarks) can be built. - -- This means the solver produced a plan that has them available. - -- This doesn't necessary mean we build them by default. - elabStanzasAvailable :: OptionalStanzaSet, - - -- | Which optional stanzas the user explicitly asked to enable or - -- to disable. This tells us which ones we build by default, and - -- helps with error messages when the user asks to build something - -- they explicitly disabled. - -- - -- TODO: The 'Bool' here should be refined into an ADT with three - -- cases: NotRequested, ExplicitlyRequested and - -- ImplicitlyRequested. A stanza is explicitly requested if - -- the user asked, for this *specific* package, that the stanza - -- be enabled; it's implicitly requested if the user asked for - -- all global packages to have this stanza enabled. The - -- difference between an explicit and implicit request is - -- error reporting behavior: if a user asks for tests to be - -- enabled for a specific package that doesn't have any tests, - -- we should warn them about it, but we shouldn't complain - -- 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.) - elabStanzasRequested :: OptionalStanzaMap (Maybe Bool), - - elabPackageDbs :: [Maybe PackageDB], - elabSetupPackageDBStack :: PackageDBStack, - elabBuildPackageDBStack :: PackageDBStack, - elabRegisterPackageDBStack :: PackageDBStack, - - elabInplaceSetupPackageDBStack :: PackageDBStack, - elabInplaceBuildPackageDBStack :: PackageDBStack, - elabInplaceRegisterPackageDBStack :: PackageDBStack, - - elabPkgDescriptionOverride :: Maybe CabalFileText, - - -- TODO: make per-component variants of these flags - elabVanillaLib :: Bool, - elabSharedLib :: Bool, - elabStaticLib :: Bool, - elabDynExe :: Bool, - elabFullyStaticExe :: Bool, - elabGHCiLib :: Bool, - elabProfLib :: Bool, - elabProfExe :: Bool, - elabProfLibDetail :: ProfDetailLevel, - elabProfExeDetail :: ProfDetailLevel, - elabCoverage :: Bool, - elabOptimization :: OptimisationLevel, - elabSplitObjs :: Bool, - elabSplitSections :: Bool, - elabStripLibs :: Bool, - elabStripExes :: Bool, - elabDebugInfo :: DebugInfoLevel, - elabDumpBuildInfo :: DumpBuildInfo, - - elabProgramPaths :: Map String FilePath, - elabProgramArgs :: Map String [String], - elabProgramPathExtra :: [FilePath], - elabConfigureScriptArgs :: [String], - elabExtraLibDirs :: [FilePath], - elabExtraLibDirsStatic :: [FilePath], - elabExtraFrameworkDirs :: [FilePath], - elabExtraIncludeDirs :: [FilePath], - elabProgPrefix :: Maybe PathTemplate, - elabProgSuffix :: Maybe PathTemplate, - - elabInstallDirs :: InstallDirs.InstallDirs FilePath, - - elabHaddockHoogle :: Bool, - elabHaddockHtml :: Bool, - elabHaddockHtmlLocation :: Maybe String, - elabHaddockForeignLibs :: Bool, - elabHaddockForHackage :: HaddockTarget, - elabHaddockExecutables :: Bool, - elabHaddockTestSuites :: Bool, - elabHaddockBenchmarks :: Bool, - elabHaddockInternal :: Bool, - elabHaddockCss :: Maybe FilePath, - elabHaddockLinkedSource :: Bool, - elabHaddockQuickJump :: Bool, - elabHaddockHscolourCss :: Maybe FilePath, - elabHaddockContents :: Maybe PathTemplate, - elabHaddockIndex :: Maybe PathTemplate, - elabHaddockBaseUrl :: Maybe String, - elabHaddockLib :: Maybe String, - elabHaddockOutputDir :: Maybe FilePath, - - elabTestMachineLog :: Maybe PathTemplate, - elabTestHumanLog :: Maybe PathTemplate, - elabTestShowDetails :: Maybe TestShowDetails, - elabTestKeepTix :: Bool, - elabTestWrapper :: Maybe FilePath, - elabTestFailWhenNoTestSuites :: Bool, - elabTestTestOptions :: [PathTemplate], - - elabBenchmarkOptions :: [PathTemplate], - - -- Setup.hs related things: - - -- | One of four modes for how we build and interact with the Setup.hs - -- script, based on whether it's a build-type Custom, with or without - -- explicit deps and the cabal spec version the .cabal file needs. - elabSetupScriptStyle :: SetupScriptStyle, - - -- | The version of the Cabal command line interface that we are using - -- for this package. This is typically the version of the Cabal lib - -- that the Setup.hs is built against. - -- - -- TODO: We might want to turn this into a enum, - -- yet different enum than 'CabalSpecVersion'. - elabSetupScriptCliVersion :: Version, - - -- Build time related: - elabConfigureTargets :: [ComponentTarget], - elabBuildTargets :: [ComponentTarget], - elabTestTargets :: [ComponentTarget], - elabBenchTargets :: [ComponentTarget], - elabReplTarget :: [ComponentTarget], - elabHaddockTargets :: [ComponentTarget], - - elabBuildHaddocks :: Bool, - - --pkgSourceDir ? -- currently passed in later because they can use temp locations - --pkgBuildDir ? -- but could in principle still have it here, with optional instr to use temp loc - - -- | Component/package specific information - elabPkgOrComp :: ElaboratedPackageOrComponent - } +data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage + { elabUnitId :: UnitId + -- ^ The 'UnitId' which uniquely identifies this item in a build plan + , elabComponentId :: ComponentId + , elabInstantiatedWith :: Map ModuleName Module + , elabLinkedInstantiatedWith :: Map ModuleName OpenModule + , elabIsCanonical :: Bool + -- ^ This is true if this is an indefinite package, or this is a + -- package with no signatures. (Notably, it's not true for instantiated + -- packages.) The motivation for this is if you ask to build + -- @foo-indef@, this probably means that you want to typecheck + -- it, NOT that you want to rebuild all of the various + -- instantiations of it. + , elabPkgSourceId :: PackageId + -- ^ The 'PackageId' of the originating package + , elabModuleShape :: ModuleShape + -- ^ Shape of the package/component, for Backpack. + , elabFlagAssignment :: Cabal.FlagAssignment + -- ^ A total flag assignment for the package. + -- TODO: Actually this can be per-component if we drop + -- all flags that don't affect a component. + , elabFlagDefaults :: Cabal.FlagAssignment + -- ^ The original default flag assignment, used only for reporting. + , elabPkgDescription :: Cabal.PackageDescription + , elabPkgSourceLocation :: PackageLocation (Maybe FilePath) + -- ^ Where the package comes from, e.g. tarball, local dir etc. This + -- is not the same as where it may be unpacked to for the build. + , elabPkgSourceHash :: Maybe PackageSourceHash + -- ^ The hash of the source, e.g. the tarball. We don't have this for + -- local source dir packages. + , elabLocalToProject :: Bool + -- ^ Is this package one of the ones specified by location in the + -- project file? (As opposed to a dependency, or a named package pulled + -- in) + , elabBuildStyle :: BuildStyle + -- ^ Are we going to build and install this package to the store, or are + -- we going to build it and register it locally. + , elabEnabledSpec :: ComponentRequestedSpec + -- ^ Another way of phrasing 'pkgStanzasAvailable'. + , elabStanzasAvailable :: OptionalStanzaSet + -- ^ Which optional stanzas (ie testsuites, benchmarks) can be built. + -- This means the solver produced a plan that has them available. + -- This doesn't necessary mean we build them by default. + , elabStanzasRequested :: OptionalStanzaMap (Maybe Bool) + -- ^ Which optional stanzas the user explicitly asked to enable or + -- to disable. This tells us which ones we build by default, and + -- helps with error messages when the user asks to build something + -- they explicitly disabled. + -- + -- TODO: The 'Bool' here should be refined into an ADT with three + -- cases: NotRequested, ExplicitlyRequested and + -- ImplicitlyRequested. A stanza is explicitly requested if + -- the user asked, for this *specific* package, that the stanza + -- be enabled; it's implicitly requested if the user asked for + -- all global packages to have this stanza enabled. The + -- difference between an explicit and implicit request is + -- error reporting behavior: if a user asks for tests to be + -- enabled for a specific package that doesn't have any tests, + -- we should warn them about it, but we shouldn't complain + -- 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 + , elabPkgDescriptionOverride :: Maybe CabalFileText + , -- TODO: make per-component variants of these flags + elabVanillaLib :: Bool + , elabSharedLib :: Bool + , elabStaticLib :: Bool + , elabDynExe :: Bool + , elabFullyStaticExe :: Bool + , elabGHCiLib :: Bool + , elabProfLib :: Bool + , elabProfExe :: Bool + , elabProfLibDetail :: ProfDetailLevel + , elabProfExeDetail :: ProfDetailLevel + , elabCoverage :: Bool + , elabOptimization :: OptimisationLevel + , elabSplitObjs :: Bool + , elabSplitSections :: Bool + , elabStripLibs :: Bool + , elabStripExes :: Bool + , elabDebugInfo :: DebugInfoLevel + , elabDumpBuildInfo :: DumpBuildInfo + , elabProgramPaths :: Map String FilePath + , elabProgramArgs :: Map String [String] + , elabProgramPathExtra :: [FilePath] + , elabConfigureScriptArgs :: [String] + , elabExtraLibDirs :: [FilePath] + , elabExtraLibDirsStatic :: [FilePath] + , elabExtraFrameworkDirs :: [FilePath] + , elabExtraIncludeDirs :: [FilePath] + , elabProgPrefix :: Maybe PathTemplate + , elabProgSuffix :: Maybe PathTemplate + , elabInstallDirs :: InstallDirs.InstallDirs FilePath + , elabHaddockHoogle :: Bool + , elabHaddockHtml :: Bool + , elabHaddockHtmlLocation :: Maybe String + , elabHaddockForeignLibs :: Bool + , elabHaddockForHackage :: HaddockTarget + , elabHaddockExecutables :: Bool + , elabHaddockTestSuites :: Bool + , elabHaddockBenchmarks :: Bool + , elabHaddockInternal :: Bool + , elabHaddockCss :: Maybe FilePath + , elabHaddockLinkedSource :: Bool + , elabHaddockQuickJump :: Bool + , elabHaddockHscolourCss :: Maybe FilePath + , elabHaddockContents :: Maybe PathTemplate + , elabHaddockIndex :: Maybe PathTemplate + , elabHaddockBaseUrl :: Maybe String + , elabHaddockLib :: Maybe String + , elabHaddockOutputDir :: Maybe FilePath + , elabTestMachineLog :: Maybe PathTemplate + , elabTestHumanLog :: Maybe PathTemplate + , elabTestShowDetails :: Maybe TestShowDetails + , elabTestKeepTix :: Bool + , elabTestWrapper :: Maybe FilePath + , elabTestFailWhenNoTestSuites :: Bool + , elabTestTestOptions :: [PathTemplate] + , elabBenchmarkOptions :: [PathTemplate] + , -- Setup.hs related things: + + elabSetupScriptStyle :: SetupScriptStyle + -- ^ One of four modes for how we build and interact with the Setup.hs + -- script, based on whether it's a build-type Custom, with or without + -- explicit deps and the cabal spec version the .cabal file needs. + , elabSetupScriptCliVersion :: Version + -- ^ The version of the Cabal command line interface that we are using + -- for this package. This is typically the version of the Cabal lib + -- that the Setup.hs is built against. + -- + -- TODO: We might want to turn this into a enum, + -- yet different enum than 'CabalSpecVersion'. + , -- Build time related: + elabConfigureTargets :: [ComponentTarget] + , elabBuildTargets :: [ComponentTarget] + , elabTestTargets :: [ComponentTarget] + , elabBenchTargets :: [ComponentTarget] + , elabReplTarget :: [ComponentTarget] + , elabHaddockTargets :: [ComponentTarget] + , elabBuildHaddocks :: Bool + , -- pkgSourceDir ? -- currently passed in later because they can use temp locations + -- pkgBuildDir ? -- but could in principle still have it here, with optional instr to use temp loc + + elabPkgOrComp :: ElaboratedPackageOrComponent + -- ^ Component/package specific information + } deriving (Eq, Show, Generic, Typeable) -normaliseConfiguredPackage :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> ElaboratedConfiguredPackage +normaliseConfiguredPackage + :: ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> ElaboratedConfiguredPackage normaliseConfiguredPackage ElaboratedSharedConfig{pkgConfigCompilerProgs} pkg = - pkg { elabProgramArgs = Map.mapMaybeWithKey lookupFilter (elabProgramArgs pkg) } + pkg{elabProgramArgs = Map.mapMaybeWithKey lookupFilter (elabProgramArgs pkg)} where knownProgramDb = addKnownPrograms builtinPrograms pkgConfigCompilerProgs @@ -384,8 +366,8 @@ normaliseConfiguredPackage ElaboratedSharedConfig{pkgConfigCompilerProgs} pkg = lookupFilter :: String -> [String] -> Maybe [String] lookupFilter n args = removeEmpty $ case lookupKnownProgram n knownProgramDb of - Just p -> programNormaliseArgs p (getVersion p) pkgDesc args - Nothing -> args + Just p -> programNormaliseArgs p (getVersion p) pkgDesc args + Nothing -> args getVersion :: Program -> Maybe Version getVersion p = lookupProgram p knownProgramDb >>= programVersion @@ -393,50 +375,57 @@ normaliseConfiguredPackage ElaboratedSharedConfig{pkgConfigCompilerProgs} pkg = -- | The package/component contains/is a library and so must be registered elabRequiresRegistration :: ElaboratedConfiguredPackage -> Bool elabRequiresRegistration elab = - case elabPkgOrComp elab of - ElabComponent comp -> - case compComponentName comp of - Just cn -> is_lib cn && build_target - _ -> False - ElabPackage pkg -> - -- Tricky! Not only do we have to test if the user selected - -- a library as a build target, we also have to test if - -- the library was TRANSITIVELY depended upon, since we will - -- also require a register in this case. - -- - -- NB: It would have been far nicer to just unconditionally - -- register in all cases, but some Custom Setups will fall - -- over if you try to do that, ESPECIALLY if there actually is - -- a library but they hadn't built it. - -- - -- However, as the case of `cpphs-1.20.8` has shown in - -- #5379, in cases when a monolithic package gets - -- installed due to its executable components - -- (i.e. exe:cpphs) into the store we *have* to register - -- if there's a buildable public library (i.e. lib:cpphs) - -- that was built and installed into the same store folder - -- as otherwise this will cause build failures once a - -- target actually depends on lib:cpphs. - build_target || (elabBuildStyle elab == BuildAndInstall && - Cabal.hasPublicLib (elabPkgDescription elab)) - -- the next sub-condition below is currently redundant - -- (see discussion in #5604 for more details), but it's - -- being kept intentionally here as a safeguard because if - -- internal libraries ever start working with - -- non-per-component builds this condition won't be - -- redundant anymore. - || any (depends_on_lib pkg) (elabBuildTargets elab) + case elabPkgOrComp elab of + ElabComponent comp -> + case compComponentName comp of + Just cn -> is_lib cn && build_target + _ -> False + ElabPackage pkg -> + -- Tricky! Not only do we have to test if the user selected + -- a library as a build target, we also have to test if + -- the library was TRANSITIVELY depended upon, since we will + -- also require a register in this case. + -- + -- NB: It would have been far nicer to just unconditionally + -- register in all cases, but some Custom Setups will fall + -- over if you try to do that, ESPECIALLY if there actually is + -- a library but they hadn't built it. + -- + -- However, as the case of `cpphs-1.20.8` has shown in + -- #5379, in cases when a monolithic package gets + -- installed due to its executable components + -- (i.e. exe:cpphs) into the store we *have* to register + -- if there's a buildable public library (i.e. lib:cpphs) + -- that was built and installed into the same store folder + -- as otherwise this will cause build failures once a + -- target actually depends on lib:cpphs. + build_target + || ( elabBuildStyle elab == BuildAndInstall + && Cabal.hasPublicLib (elabPkgDescription elab) + ) + -- the next sub-condition below is currently redundant + -- (see discussion in #5604 for more details), but it's + -- being kept intentionally here as a safeguard because if + -- internal libraries ever start working with + -- non-per-component builds this condition won't be + -- redundant anymore. + || any (depends_on_lib pkg) (elabBuildTargets elab) where depends_on_lib pkg (ComponentTarget cn _) = - not (null (CD.select (== CD.componentNameToComponent cn) - (pkgDependsOnSelfLib pkg))) + not + ( null + ( CD.select + (== CD.componentNameToComponent cn) + (pkgDependsOnSelfLib pkg) + ) + ) build_target = - if not (null (elabBuildTargets elab)) - then any is_lib_target (elabBuildTargets elab) - -- Empty build targets mean we build /everything/; - -- that means we have to look more carefully to see - -- if there is anything to register - else Cabal.hasLibs (elabPkgDescription elab) + if not (null (elabBuildTargets elab)) + then any is_lib_target (elabBuildTargets elab) + else -- Empty build targets mean we build /everything/; + -- that means we have to look more carefully to see + -- if there is anything to register + Cabal.hasLibs (elabPkgDescription elab) -- NB: this means we DO NOT reregister if you just built a -- single file is_lib_target (ComponentTarget cn WholeComponent) = is_lib cn @@ -447,14 +436,18 @@ elabRequiresRegistration elab = -- | Construct the environment needed for the data files to work. -- This consists of a separate @*_datadir@ variable for each -- inplace package in the plan. -dataDirsEnvironmentForPlan :: DistDirLayout - -> ElaboratedInstallPlan - -> [(String, Maybe FilePath)] -dataDirsEnvironmentForPlan distDirLayout = catMaybes - . fmap (InstallPlan.foldPlanPackage - (const Nothing) - (dataDirEnvVarForPackage distDirLayout)) - . InstallPlan.toList +dataDirsEnvironmentForPlan + :: DistDirLayout + -> ElaboratedInstallPlan + -> [(String, Maybe FilePath)] +dataDirsEnvironmentForPlan distDirLayout = + catMaybes + . fmap + ( InstallPlan.foldPlanPackage + (const Nothing) + (dataDirEnvVarForPackage distDirLayout) + ) + . InstallPlan.toList -- | Construct an environment variable that points -- the package's datadir to its correct location. @@ -463,16 +456,20 @@ dataDirsEnvironmentForPlan distDirLayout = catMaybes -- for inplace packages. -- * 'Nothing' for packages installed in the store (the path was -- already included in the package at install/build time). -dataDirEnvVarForPackage :: DistDirLayout - -> ElaboratedConfiguredPackage - -> Maybe (String, Maybe FilePath) +dataDirEnvVarForPackage + :: DistDirLayout + -> ElaboratedConfiguredPackage + -> Maybe (String, Maybe FilePath) dataDirEnvVarForPackage distDirLayout pkg = - case elabBuildStyle pkg - of BuildAndInstall -> Nothing - BuildInplaceOnly {} -> Just - ( pkgPathEnvVar (elabPkgDescription pkg) "datadir" - , Just $ srcPath (elabPkgSourceLocation pkg) - dataDir (elabPkgDescription pkg)) + case elabBuildStyle pkg of + BuildAndInstall -> Nothing + BuildInplaceOnly{} -> + Just + ( pkgPathEnvVar (elabPkgDescription pkg) "datadir" + , Just $ + srcPath (elabPkgSourceLocation pkg) + dataDir (elabPkgDescription pkg) + ) where srcPath (LocalUnpackedPackage path) = path srcPath (LocalTarballPackage _path) = unpackedPath @@ -480,8 +477,9 @@ dataDirEnvVarForPackage distDirLayout pkg = srcPath (RepoTarballPackage _repo _packageId _localTar) = unpackedPath srcPath (RemoteSourceRepoPackage _sourceRepo (Just localCheckout)) = localCheckout -- TODO: see https://github.com/haskell/cabal/wiki/Potential-Refactors#unresolvedpkgloc - srcPath (RemoteSourceRepoPackage _sourceRepo Nothing) = error - "calling dataDirEnvVarForPackage on a not-downloaded repo is an error" + srcPath (RemoteSourceRepoPackage _sourceRepo Nothing) = + error + "calling dataDirEnvVarForPackage on a not-downloaded repo is an error" unpackedPath = distUnpackedSrcDirectory distDirLayout $ elabPkgSourceId pkg @@ -496,16 +494,16 @@ instance HasUnitId ElaboratedConfiguredPackage where installedUnitId = elabUnitId instance IsNode ElaboratedConfiguredPackage where - type Key ElaboratedConfiguredPackage = UnitId - nodeKey = elabUnitId - nodeNeighbors = elabOrderDependencies + type Key ElaboratedConfiguredPackage = UnitId + nodeKey = elabUnitId + nodeNeighbors = elabOrderDependencies instance Binary ElaboratedConfiguredPackage instance Structured ElaboratedConfiguredPackage data ElaboratedPackageOrComponent - = ElabPackage ElaboratedPackage - | ElabComponent ElaboratedComponent + = ElabPackage ElaboratedPackage + | ElabComponent ElaboratedComponent deriving (Eq, Show, Generic) instance Binary ElaboratedPackageOrComponent @@ -513,36 +511,38 @@ instance Structured ElaboratedPackageOrComponent elabComponentName :: ElaboratedConfiguredPackage -> Maybe ComponentName elabComponentName elab = - case elabPkgOrComp elab of - ElabPackage _ -> Just $ CLibName LMainLibName -- there could be more, but default this - ElabComponent comp -> compComponentName comp + case elabPkgOrComp elab of + ElabPackage _ -> Just $ CLibName LMainLibName -- there could be more, but default this + ElabComponent comp -> compComponentName comp -- | A user-friendly descriptor for an 'ElaboratedConfiguredPackage'. elabConfiguredName :: Verbosity -> ElaboratedConfiguredPackage -> String elabConfiguredName verbosity elab - | verbosity <= normal - = (case elabPkgOrComp elab of - ElabPackage _ -> "" - ElabComponent comp -> + | verbosity <= normal = + ( case elabPkgOrComp elab of + ElabPackage _ -> "" + ElabComponent comp -> case compComponentName comp of - Nothing -> "setup from " - Just (CLibName LMainLibName) -> "" - Just cname -> prettyShow cname ++ " from ") - ++ prettyShow (packageId elab) - | otherwise - = prettyShow (elabUnitId elab) + Nothing -> "setup from " + Just (CLibName LMainLibName) -> "" + Just cname -> prettyShow cname ++ " from " + ) + ++ prettyShow (packageId elab) + | otherwise = + prettyShow (elabUnitId elab) elabDistDirParams :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> DistDirParams -elabDistDirParams shared elab = DistDirParams { - distParamUnitId = installedUnitId elab, - distParamComponentId = elabComponentId elab, - distParamPackageId = elabPkgSourceId elab, - distParamComponentName = case elabPkgOrComp elab of - ElabComponent comp -> compComponentName comp - ElabPackage _ -> Nothing, - distParamCompilerId = compilerId (pkgConfigCompiler shared), - distParamPlatform = pkgConfigPlatform shared, - distParamOptimization = elabOptimization elab +elabDistDirParams shared elab = + DistDirParams + { distParamUnitId = installedUnitId elab + , distParamComponentId = elabComponentId elab + , distParamPackageId = elabPkgSourceId elab + , distParamComponentName = case elabPkgOrComp elab of + ElabComponent comp -> compComponentName comp + ElabPackage _ -> Nothing + , distParamCompilerId = compilerId (pkgConfigCompiler shared) + , distParamPlatform = pkgConfigPlatform shared + , distParamOptimization = elabOptimization elab } -- | The full set of dependencies which dictate what order we @@ -556,44 +556,46 @@ elabDistDirParams shared elab = DistDirParams { -- NB: this method DOES include setup deps. elabOrderDependencies :: ElaboratedConfiguredPackage -> [UnitId] elabOrderDependencies elab = - case elabPkgOrComp elab of - -- Important not to have duplicates: otherwise InstallPlan gets - -- confused. - ElabPackage pkg -> ordNub (CD.flatDeps (pkgOrderDependencies pkg)) - ElabComponent comp -> compOrderDependencies comp + case elabPkgOrComp elab of + -- Important not to have duplicates: otherwise InstallPlan gets + -- confused. + ElabPackage pkg -> ordNub (CD.flatDeps (pkgOrderDependencies pkg)) + ElabComponent comp -> compOrderDependencies comp -- | Like 'elabOrderDependencies', but only returns dependencies on -- libraries. elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [UnitId] elabOrderLibDependencies elab = - case elabPkgOrComp elab of - ElabPackage pkg -> map (newSimpleUnitId . confInstId) $ - ordNub $ CD.flatDeps (map fst <$> pkgLibDependencies pkg) - ElabComponent comp -> compOrderLibDependencies comp + case elabPkgOrComp elab of + ElabPackage pkg -> + map (newSimpleUnitId . confInstId) $ + ordNub $ + CD.flatDeps (map fst <$> pkgLibDependencies pkg) + ElabComponent comp -> compOrderLibDependencies comp -- | The library dependencies (i.e., the libraries we depend on, NOT -- the dependencies of the library), NOT including setup dependencies. -- These are passed to the @Setup@ script via @--dependency@ or @--promised-dependency@. elabLibDependencies :: ElaboratedConfiguredPackage -> [(ConfiguredId, Bool)] elabLibDependencies elab = - case elabPkgOrComp elab of - ElabPackage pkg -> ordNub (CD.nonSetupDeps (pkgLibDependencies pkg)) - ElabComponent comp -> compLibDependencies comp + case elabPkgOrComp elab of + ElabPackage pkg -> ordNub (CD.nonSetupDeps (pkgLibDependencies pkg)) + ElabComponent comp -> compLibDependencies comp -- | Like 'elabOrderDependencies', but only returns dependencies on -- executables. (This coincides with 'elabExeDependencies'.) elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [UnitId] elabOrderExeDependencies = - map newSimpleUnitId . elabExeDependencies + map newSimpleUnitId . elabExeDependencies -- | The executable dependencies (i.e., the executables we depend on); -- these are the executables we must add to the PATH before we invoke -- the setup script. elabExeDependencies :: ElaboratedConfiguredPackage -> [ComponentId] elabExeDependencies elab = map confInstId $ - case elabPkgOrComp elab of - ElabPackage pkg -> CD.nonSetupDeps (pkgExeDependencies pkg) - ElabComponent comp -> compExeDependencies comp + case elabPkgOrComp elab of + ElabPackage pkg -> CD.nonSetupDeps (pkgExeDependencies pkg) + ElabComponent comp -> compExeDependencies comp -- | This returns the paths of all the executables we depend on; we -- must add these paths to PATH before invoking the setup script. @@ -601,26 +603,26 @@ elabExeDependencies elab = map confInstId $ -- actually want to build something.) elabExeDependencyPaths :: ElaboratedConfiguredPackage -> [FilePath] elabExeDependencyPaths elab = - case elabPkgOrComp elab of - ElabPackage pkg -> map snd $ CD.nonSetupDeps (pkgExeDependencyPaths pkg) - ElabComponent comp -> map snd (compExeDependencyPaths comp) + case elabPkgOrComp elab of + ElabPackage pkg -> map snd $ CD.nonSetupDeps (pkgExeDependencyPaths pkg) + ElabComponent comp -> map snd (compExeDependencyPaths comp) -- | The setup dependencies (the library dependencies of the setup executable; -- note that it is not legal for setup scripts to have executable -- dependencies at the moment.) elabSetupDependencies :: ElaboratedConfiguredPackage -> [(ConfiguredId, Bool)] elabSetupDependencies elab = - case elabPkgOrComp elab of - ElabPackage pkg -> CD.setupDeps (pkgLibDependencies pkg) - -- TODO: Custom setups not supported for components yet. When - -- they are, need to do this differently - ElabComponent _ -> [] + case elabPkgOrComp elab of + ElabPackage pkg -> CD.setupDeps (pkgLibDependencies pkg) + -- TODO: Custom setups not supported for components yet. When + -- they are, need to do this differently + ElabComponent _ -> [] elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PkgconfigName, Maybe PkgconfigVersion)] -elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage pkg } - = pkgPkgConfigDependencies pkg -elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } - = compPkgConfigDependencies comp +elabPkgConfigDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage pkg} = + pkgPkgConfigDependencies pkg +elabPkgConfigDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent comp} = + compPkgConfigDependencies comp -- | The cache files of all our inplace dependencies which, -- when updated, require us to rebuild. See #4202 for @@ -643,17 +645,17 @@ elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabComp -- here will never work if we want to implement unchanging -- rebuilds. elabInplaceDependencyBuildCacheFiles - :: DistDirLayout - -> ElaboratedSharedConfig - -> ElaboratedInstallPlan - -> ElaboratedConfiguredPackage - -> [FilePath] + :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedConfiguredPackage + -> [FilePath] elabInplaceDependencyBuildCacheFiles layout sconf plan root_elab = - go =<< InstallPlan.directDeps plan (nodeKey root_elab) + go =<< InstallPlan.directDeps plan (nodeKey root_elab) where go = InstallPlan.foldPlanPackage (const []) $ \elab -> do - guard (isInplaceBuildStyle (elabBuildStyle elab)) - return $ distPackageCacheFile layout (elabDistDirParams sconf elab) "build" + guard (isInplaceBuildStyle (elabBuildStyle elab)) + return $ distPackageCacheFile layout (elabDistDirParams sconf elab) "build" -- | Some extra metadata associated with an -- 'ElaboratedConfiguredPackage' which indicates that the "package" @@ -662,43 +664,42 @@ elabInplaceDependencyBuildCacheFiles layout sconf plan root_elab = -- package work items and component work items, but I've structured -- it this way to minimize change to the existing code (which I -- don't feel qualified to rewrite.) -data ElaboratedComponent - = ElaboratedComponent { - -- | The name of the component to be built according to the solver - compSolverName :: CD.Component, - -- | The name of the component to be built. Nothing if - -- it's a setup dep. - compComponentName :: Maybe ComponentName, - -- | The *external* library dependencies of this component. We - -- pass this to the configure script. The Bool indicates whether the - -- dependency is a promised dependency (True) or not (False). - compLibDependencies :: [(ConfiguredId, Bool)], - -- | In a component prior to instantiation, this list specifies - -- the 'OpenUnitId's which, after instantiation, are the - -- actual dependencies of this package. Note that this does - -- NOT include signature packages, which do not turn into real - -- ordering dependencies when we instantiate. This is intended to be - -- a purely temporary field, to carry some information to the - -- instantiation phase. It's more precise than - -- 'compLibDependencies', and also stores information about internal - -- dependencies. - compLinkedLibDependencies :: [OpenUnitId], - -- | The executable dependencies of this component (including - -- internal executables). - compExeDependencies :: [ConfiguredId], - -- | The @pkg-config@ dependencies of the component - compPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)], - -- | The paths all our executable dependencies will be installed - -- to once they are installed. - compExeDependencyPaths :: [(ConfiguredId, FilePath)], - -- | The UnitIds of the libraries (identifying elaborated packages/ - -- components) that must be built before this project. This - -- is used purely for ordering purposes. It can contain both - -- references to definite and indefinite packages; an indefinite - -- UnitId indicates that we must typecheck that indefinite package - -- before we can build this one. - compOrderLibDependencies :: [UnitId] - } +data ElaboratedComponent = ElaboratedComponent + { compSolverName :: CD.Component + -- ^ The name of the component to be built according to the solver + , compComponentName :: Maybe ComponentName + -- ^ The name of the component to be built. Nothing if + -- it's a setup dep. + , compLibDependencies :: [(ConfiguredId, Bool)] + -- ^ The *external* library dependencies of this component. We + -- pass this to the configure script. The Bool indicates whether the + -- dependency is a promised dependency (True) or not (False). + , compLinkedLibDependencies :: [OpenUnitId] + -- ^ In a component prior to instantiation, this list specifies + -- the 'OpenUnitId's which, after instantiation, are the + -- actual dependencies of this package. Note that this does + -- NOT include signature packages, which do not turn into real + -- ordering dependencies when we instantiate. This is intended to be + -- a purely temporary field, to carry some information to the + -- instantiation phase. It's more precise than + -- 'compLibDependencies', and also stores information about internal + -- dependencies. + , compExeDependencies :: [ConfiguredId] + -- ^ The executable dependencies of this component (including + -- internal executables). + , compPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)] + -- ^ The @pkg-config@ dependencies of the component + , compExeDependencyPaths :: [(ConfiguredId, FilePath)] + -- ^ The paths all our executable dependencies will be installed + -- to once they are installed. + , compOrderLibDependencies :: [UnitId] + -- ^ The UnitIds of the libraries (identifying elaborated packages/ + -- components) that must be built before this project. This + -- is used purely for ordering purposes. It can contain both + -- references to definite and indefinite packages; an indefinite + -- UnitId indicates that we must typecheck that indefinite package + -- before we can build this one. + } deriving (Eq, Show, Generic) instance Binary ElaboratedComponent @@ -707,48 +708,37 @@ instance Structured ElaboratedComponent -- | See 'elabOrderDependencies'. compOrderDependencies :: ElaboratedComponent -> [UnitId] compOrderDependencies comp = - compOrderLibDependencies comp - ++ compOrderExeDependencies comp + compOrderLibDependencies comp + ++ compOrderExeDependencies comp -- | See 'elabOrderExeDependencies'. compOrderExeDependencies :: ElaboratedComponent -> [UnitId] compOrderExeDependencies = map (newSimpleUnitId . confInstId) . compExeDependencies -data ElaboratedPackage - = ElaboratedPackage { - pkgInstalledId :: InstalledPackageId, - - -- | The exact dependencies (on other plan packages) - -- The boolean value indicates whether the dependency is a promised dependency - -- or not. - pkgLibDependencies :: ComponentDeps [(ConfiguredId, Bool)], - - -- | Components which depend (transitively) on an internally - -- defined library. These are used by 'elabRequiresRegistration', - -- to determine if a user-requested build is going to need - -- a library registration - -- - pkgDependsOnSelfLib :: ComponentDeps [()], - - -- | Dependencies on executable packages. - -- - pkgExeDependencies :: ComponentDeps [ConfiguredId], - - -- | Paths where executable dependencies live. - -- - pkgExeDependencyPaths :: ComponentDeps [(ConfiguredId, FilePath)], - - -- | Dependencies on @pkg-config@ packages. - -- NB: this is NOT per-component (although it could be) - -- because Cabal library does not track per-component - -- pkg-config depends; it always does them all at once. - -- - pkgPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)], - - -- | Which optional stanzas (ie testsuites, benchmarks) will actually - -- be enabled during the package configure step. - pkgStanzasEnabled :: OptionalStanzaSet - } +data ElaboratedPackage = ElaboratedPackage + { pkgInstalledId :: InstalledPackageId + , pkgLibDependencies :: ComponentDeps [(ConfiguredId, Bool)] + -- ^ The exact dependencies (on other plan packages) + -- The boolean value indicates whether the dependency is a promised dependency + -- or not. + , pkgDependsOnSelfLib :: ComponentDeps [()] + -- ^ Components which depend (transitively) on an internally + -- defined library. These are used by 'elabRequiresRegistration', + -- to determine if a user-requested build is going to need + -- a library registration + , pkgExeDependencies :: ComponentDeps [ConfiguredId] + -- ^ Dependencies on executable packages. + , pkgExeDependencyPaths :: ComponentDeps [(ConfiguredId, FilePath)] + -- ^ Paths where executable dependencies live. + , pkgPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)] + -- ^ Dependencies on @pkg-config@ packages. + -- NB: this is NOT per-component (although it could be) + -- because Cabal library does not track per-component + -- pkg-config depends; it always does them all at once. + , pkgStanzasEnabled :: OptionalStanzaSet + -- ^ Which optional stanzas (ie testsuites, benchmarks) will actually + -- be enabled during the package configure step. + } deriving (Eq, Show, Generic) instance Binary ElaboratedPackage @@ -758,21 +748,19 @@ instance Structured ElaboratedPackage -- which can be useful in some circumstances. pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [UnitId] pkgOrderDependencies pkg = - fmap (map (newSimpleUnitId . confInstId)) (map fst <$> pkgLibDependencies pkg) `Mon.mappend` - fmap (map (newSimpleUnitId . confInstId)) (pkgExeDependencies pkg) + fmap (map (newSimpleUnitId . confInstId)) (map fst <$> pkgLibDependencies pkg) + `Mon.mappend` fmap (map (newSimpleUnitId . confInstId)) (pkgExeDependencies pkg) -- | This is used in the install plan to indicate how the package will be -- built. --- -data BuildStyle = - -- | The classic approach where the package is built, then the files +data BuildStyle + = -- | The classic approach where the package is built, then the files -- installed into some location and the result registered in a package db. -- -- If the package came from a tarball then it's built in a temp dir and -- the results discarded. BuildAndInstall - - -- | For 'OnDisk': The package is built, but the files are not installed anywhere, + | -- | For 'OnDisk': The package is built, but the files are not installed anywhere, -- rather the build dir is kept and the package is registered inplace. -- -- Such packages can still subsequently be installed. @@ -788,19 +776,19 @@ data BuildStyle = -- -- We use single constructor 'BuildInplaceOnly' as for most cases -- inplace packages are handled similarly. - -- - | BuildInplaceOnly MemoryOrDisk + BuildInplaceOnly MemoryOrDisk deriving (Eq, Ord, Show, Generic) -- | How 'BuildInplaceOnly' component is built. data MemoryOrDisk - = OnDisk - | InMemory deriving (Eq, Ord, Show, Generic) + = OnDisk + | InMemory + deriving (Eq, Ord, Show, Generic) -- Note: order of 'BuildStyle' and 'MemoryOrDisk' matters for 'Semigroup' / 'Monoid' instances isInplaceBuildStyle :: BuildStyle -> Bool -isInplaceBuildStyle (BuildInplaceOnly {}) = True +isInplaceBuildStyle (BuildInplaceOnly{}) = True isInplaceBuildStyle BuildAndInstall = False instance Binary MemoryOrDisk @@ -820,14 +808,12 @@ type CabalFileText = LBS.ByteString type ElaboratedReadyPackage = GenericReadyPackage ElaboratedConfiguredPackage - --------------------------- -- Build targets -- -- | Specific targets within a package or component to act on e.g. to build, -- haddock or open a repl. --- data ComponentTarget = ComponentTarget ComponentName SubComponentTarget deriving (Eq, Ord, Show, Generic) @@ -838,14 +824,14 @@ instance Structured ComponentTarget -- to a Cabal Setup script. showComponentTarget :: PackageId -> ComponentTarget -> String showComponentTarget pkgid = - Cabal.showBuildTarget pkgid . toBuildTarget + Cabal.showBuildTarget pkgid . toBuildTarget where toBuildTarget :: ComponentTarget -> Cabal.BuildTarget toBuildTarget (ComponentTarget cname subtarget) = case subtarget of - WholeComponent -> Cabal.BuildTargetComponent cname - ModuleTarget mname -> Cabal.BuildTargetModule cname mname - FileTarget fname -> Cabal.BuildTargetFile cname fname + WholeComponent -> Cabal.BuildTargetComponent cname + ModuleTarget mname -> Cabal.BuildTargetModule cname mname + FileTarget fname -> Cabal.BuildTargetFile cname fname showTestComponentTarget :: PackageId -> ComponentTarget -> Maybe String showTestComponentTarget _ (ComponentTarget (CTestName n) _) = Just $ prettyShow n @@ -853,7 +839,7 @@ showTestComponentTarget _ _ = Nothing isTestComponentTarget :: ComponentTarget -> Bool isTestComponentTarget (ComponentTarget (CTestName _) _) = True -isTestComponentTarget _ = False +isTestComponentTarget _ = False showBenchComponentTarget :: PackageId -> ComponentTarget -> Maybe String showBenchComponentTarget _ (ComponentTarget (CBenchName n) _) = Just $ prettyShow n @@ -861,24 +847,24 @@ showBenchComponentTarget _ _ = Nothing isBenchComponentTarget :: ComponentTarget -> Bool isBenchComponentTarget (ComponentTarget (CBenchName _) _) = True -isBenchComponentTarget _ = False +isBenchComponentTarget _ = False isForeignLibComponentTarget :: ComponentTarget -> Bool isForeignLibComponentTarget (ComponentTarget (CFLibName _) _) = True -isForeignLibComponentTarget _ = False +isForeignLibComponentTarget _ = False isExeComponentTarget :: ComponentTarget -> Bool -isExeComponentTarget (ComponentTarget (CExeName _) _ ) = True -isExeComponentTarget _ = False +isExeComponentTarget (ComponentTarget (CExeName _) _) = True +isExeComponentTarget _ = False isSubLibComponentTarget :: ComponentTarget -> Bool isSubLibComponentTarget (ComponentTarget (CLibName (LSubLibName _)) _) = True -isSubLibComponentTarget _ = False +isSubLibComponentTarget _ = False componentOptionalStanza :: CD.Component -> Maybe OptionalStanza -componentOptionalStanza (CD.ComponentTest _) = Just TestStanzas +componentOptionalStanza (CD.ComponentTest _) = Just TestStanzas componentOptionalStanza (CD.ComponentBench _) = Just BenchStanzas -componentOptionalStanza _ = Nothing +componentOptionalStanza _ = Nothing --------------------------- -- Setup.hs script policy @@ -900,11 +886,11 @@ componentOptionalStanza _ = Nothing -- while in case 4 we can use the internal library API. In case 3 we also have -- to build an external Setup.hs script because the package needs a later -- Cabal lib version than we can support internally. --- -data SetupScriptStyle = SetupCustomExplicitDeps - | SetupCustomImplicitDeps - | SetupNonCustomExternalLib - | SetupNonCustomInternalLib +data SetupScriptStyle + = SetupCustomExplicitDeps + | SetupCustomImplicitDeps + | SetupNonCustomExternalLib + | SetupNonCustomInternalLib deriving (Eq, Show, Generic, Typeable) instance Binary SetupScriptStyle diff --git a/cabal-install/src/Distribution/Client/ReplFlags.hs b/cabal-install/src/Distribution/Client/ReplFlags.hs index d6c7399e52c..a7136aa572d 100644 --- a/cabal-install/src/Distribution/Client/ReplFlags.hs +++ b/cabal-install/src/Distribution/Client/ReplFlags.hs @@ -1,23 +1,37 @@ -module Distribution.Client.ReplFlags (EnvFlags(..), ReplFlags(..), topReplOptions, multiReplOption, defaultReplFlags) where +module Distribution.Client.ReplFlags (EnvFlags (..), ReplFlags (..), topReplOptions, multiReplOption, defaultReplFlags) where -import Prelude () import Distribution.Client.Compat.Prelude - +import Prelude () import Distribution.Client.Setup - ( liftOptions ) -import Distribution.Simple.Setup - ( ReplOptions(..), replOptions - , Flag(..), toFlag, falseArg, boolOpt, trueArg ) -import Distribution.Simple.Command - ( option - , ShowOrParseArgs, OptionField, reqArg, liftOption ) + ( liftOptions + ) import Distribution.Parsec - ( parsecCommaList ) + ( parsecCommaList + ) import Distribution.ReadE - ( ReadE, parsecToReadE ) + ( ReadE + , parsecToReadE + ) +import Distribution.Simple.Command + ( OptionField + , ShowOrParseArgs + , liftOption + , option + , reqArg + ) +import Distribution.Simple.Setup + ( Flag (..) + , ReplOptions (..) + , boolOpt + , falseArg + , replOptions + , toFlag + , trueArg + ) import Distribution.Types.Dependency - ( Dependency(..) ) + ( Dependency (..) + ) data EnvFlags = EnvFlags { envPackages :: [Dependency] @@ -31,13 +45,14 @@ instance Monoid EnvFlags where mempty = defaultEnvFlags defaultEnvFlags :: EnvFlags -defaultEnvFlags = EnvFlags - { envPackages = [] - , envIncludeTransitive = toFlag True - } +defaultEnvFlags = + EnvFlags + { envPackages = [] + , envIncludeTransitive = toFlag True + } -data ReplFlags = ReplFlags { - configureReplOptions :: ReplOptions +data ReplFlags = ReplFlags + { configureReplOptions :: ReplOptions , replEnvFlags :: EnvFlags , replUseMulti :: Flag Bool , replKeepTempFiles :: Flag Bool @@ -50,50 +65,63 @@ instance Monoid ReplFlags where mempty = defaultReplFlags defaultReplFlags :: ReplFlags -defaultReplFlags = ReplFlags { configureReplOptions = mempty - , replEnvFlags = defaultEnvFlags - , replUseMulti = NoFlag - , replKeepTempFiles = NoFlag - } +defaultReplFlags = + ReplFlags + { configureReplOptions = mempty + , replEnvFlags = defaultEnvFlags + , replUseMulti = NoFlag + , replKeepTempFiles = NoFlag + } topReplOptions :: ShowOrParseArgs -> [OptionField ReplFlags] topReplOptions showOrParseArgs = - liftOptions configureReplOptions set1 (replOptions showOrParseArgs) ++ - liftOptions replEnvFlags set2 (envOptions showOrParseArgs) ++ - [ liftOption replUseMulti set3 multiReplOption - - -- keeping temporary files is important functionality for HLS, - -- which runs @cabal repl@ with fake GHC to get cli arguments. - -- It will need the temporary files (incl. multi unit repl response files) - -- to stay, even after the @cabal repl@ command exits. - -- - , option [] ["keep-temp-files"] - "Keep temporary files" - replKeepTempFiles (\b flags -> flags { replKeepTempFiles = b }) - trueArg - ] - where - set1 a x = x { configureReplOptions = a } - set2 a x = x { replEnvFlags = a } - set3 a x = x { replUseMulti = a } + liftOptions configureReplOptions set1 (replOptions showOrParseArgs) + ++ liftOptions replEnvFlags set2 (envOptions showOrParseArgs) + ++ [ liftOption replUseMulti set3 multiReplOption + , -- keeping temporary files is important functionality for HLS, + -- which runs @cabal repl@ with fake GHC to get cli arguments. + -- It will need the temporary files (incl. multi unit repl response files) + -- to stay, even after the @cabal repl@ command exits. + -- + option + [] + ["keep-temp-files"] + "Keep temporary files" + replKeepTempFiles + (\b flags -> flags{replKeepTempFiles = b}) + trueArg + ] + where + set1 a x = x{configureReplOptions = a} + set2 a x = x{replEnvFlags = a} + set3 a x = x{replUseMulti = a} multiReplOption :: OptionField (Flag Bool) multiReplOption = - option [] ["multi-repl"] - "multi-component repl sessions" - id (\v _ -> v) - (boolOpt [] []) + option + [] + ["multi-repl"] + "multi-component repl sessions" + id + (\v _ -> v) + (boolOpt [] []) envOptions :: ShowOrParseArgs -> [OptionField EnvFlags] envOptions _ = - [ option ['b'] ["build-depends"] - "Include additional packages in the environment presented to GHCi." - envPackages (\p flags -> flags { envPackages = p ++ envPackages flags }) - (reqArg "DEPENDENCIES" dependenciesReadE (fmap prettyShow :: [Dependency] -> [String])) - , option [] ["no-transitive-deps"] - "Don't automatically include transitive dependencies of requested packages." - envIncludeTransitive (\p flags -> flags { envIncludeTransitive = p }) - falseArg + [ option + ['b'] + ["build-depends"] + "Include additional packages in the environment presented to GHCi." + envPackages + (\p flags -> flags{envPackages = p ++ envPackages flags}) + (reqArg "DEPENDENCIES" dependenciesReadE (fmap prettyShow :: [Dependency] -> [String])) + , option + [] + ["no-transitive-deps"] + "Don't automatically include transitive dependencies of requested packages." + envIncludeTransitive + (\p flags -> flags{envIncludeTransitive = p}) + falseArg ] where dependenciesReadE :: ReadE [Dependency] diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs index ce64c8a5ef6..f25ab462b53 100644 --- a/cabal-install/src/Distribution/Client/ScriptUtils.hs +++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs @@ -4,120 +4,206 @@ {-# LANGUAGE RecordWildCards #-} -- | Utilities to help commands with scripts --- -module Distribution.Client.ScriptUtils ( - getScriptHash, getScriptCacheDirectory, ensureScriptCacheDirectory, - withContextAndSelectors, AcceptNoTargets(..), TargetContext(..), - updateContextAndWriteProjectFile, updateContextAndWriteProjectFile', - fakeProjectSourcePackage, lSrcpkgDescription, - movedExePath +module Distribution.Client.ScriptUtils + ( getScriptHash + , getScriptCacheDirectory + , ensureScriptCacheDirectory + , withContextAndSelectors + , AcceptNoTargets (..) + , TargetContext (..) + , updateContextAndWriteProjectFile + , updateContextAndWriteProjectFile' + , fakeProjectSourcePackage + , lSrcpkgDescription + , movedExePath ) where -import Prelude () import Distribution.Client.Compat.Prelude hiding (toList) +import Prelude () import Distribution.Compat.Lens import qualified Distribution.Types.Lens as L import Distribution.CabalSpecVersion - ( CabalSpecVersion (..), cabalSpecLatest) -import Distribution.Client.ProjectOrchestration + ( CabalSpecVersion (..) + , cabalSpecLatest + ) import Distribution.Client.Config - ( defaultScriptBuildsDir ) + ( defaultScriptBuildsDir + ) import Distribution.Client.DistDirLayout - ( DistDirLayout(..), DistDirParams(..) ) + ( DistDirLayout (..) + , DistDirParams (..) + ) import Distribution.Client.HashValue - ( hashValue, showHashValueBase64 ) + ( hashValue + , showHashValueBase64 + ) import Distribution.Client.HttpUtils - ( HttpTransport, configureTransport ) + ( HttpTransport + , configureTransport + ) import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..) ) + ( NixStyleFlags (..) + ) import Distribution.Client.ProjectConfig - ( ProjectConfig(..), ProjectConfigShared(..), PackageConfig(..) - , reportParseResult, withGlobalConfig, withProjectOrGlobalConfig - , projectConfigHttpTransport ) + ( PackageConfig (..) + , ProjectConfig (..) + , ProjectConfigShared (..) + , projectConfigHttpTransport + , reportParseResult + , withGlobalConfig + , withProjectOrGlobalConfig + ) import Distribution.Client.ProjectConfig.Legacy - ( ProjectConfigSkeleton - , parseProjectSkeleton, instantiateProjectConfigSkeletonFetchingCompiler ) + ( ProjectConfigSkeleton + , instantiateProjectConfigSkeletonFetchingCompiler + , parseProjectSkeleton + ) import Distribution.Client.ProjectFlags - ( flagIgnoreProject ) + ( flagIgnoreProject + ) +import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning - ( ElaboratedSharedConfig(..), ElaboratedConfiguredPackage(..) ) + ( ElaboratedConfiguredPackage (..) + , ElaboratedSharedConfig (..) + , configureCompiler + ) import Distribution.Client.RebuildMonad - ( runRebuild ) + ( runRebuild + ) import Distribution.Client.Setup - ( ConfigFlags(..), GlobalFlags(..) ) + ( ConfigFlags (..) + , GlobalFlags (..) + ) import Distribution.Client.TargetSelector - ( TargetSelectorProblem(..), TargetString(..) ) + ( TargetSelectorProblem (..) + , TargetString (..) + ) import Distribution.Client.Types - ( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage ) + ( PackageLocation (..) + , PackageSpecifier (..) + , UnresolvedSourcePackage + ) import Distribution.Compiler - ( CompilerId(..), perCompilerFlavorToList ) + ( CompilerId (..) + , perCompilerFlavorToList + ) import Distribution.FieldGrammar - ( parseFieldGrammar, takeFields ) + ( parseFieldGrammar + , takeFields + ) import Distribution.Fields - ( ParseResult, parseFatalFailure, readFields ) + ( ParseResult + , parseFatalFailure + , readFields + ) import Distribution.PackageDescription - ( ignoreConditions ) + ( ignoreConditions + ) import Distribution.PackageDescription.FieldGrammar - ( executableFieldGrammar ) + ( executableFieldGrammar + ) import Distribution.PackageDescription.PrettyPrint - ( showGenericPackageDescription ) + ( showGenericPackageDescription + ) import Distribution.Parsec - ( Position(..) ) + ( Position (..) + ) +import qualified Distribution.SPDX.License as SPDX +import Distribution.Simple.Compiler + ( Compiler (..) + , OptimisationLevel (..) + , compilerInfo + ) import Distribution.Simple.Flag - ( fromFlagOrDefault, flagToMaybe ) + ( flagToMaybe + , fromFlagOrDefault + ) import Distribution.Simple.PackageDescription - ( parseString ) + ( parseString + ) import Distribution.Simple.Setup - ( Flag(..) ) -import Distribution.Simple.Compiler - ( Compiler(..), OptimisationLevel(..), compilerInfo ) + ( Flag (..) + ) import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, createTempDirectory, die', handleDoesNotExist, readUTF8File, warn, writeUTF8File ) -import qualified Distribution.SPDX.License as SPDX + ( createDirectoryIfMissingVerbose + , createTempDirectory + , die' + , handleDoesNotExist + , readUTF8File + , warn + , writeUTF8File + ) import Distribution.Solver.Types.SourcePackage as SP - ( SourcePackage(..) ) + ( SourcePackage (..) + ) import Distribution.System - ( Platform(..) ) + ( Platform (..) + ) import Distribution.Types.BuildInfo - ( BuildInfo(..) ) + ( BuildInfo (..) + ) import Distribution.Types.ComponentId - ( mkComponentId ) + ( mkComponentId + ) import Distribution.Types.CondTree - ( CondTree(..) ) + ( CondTree (..) + ) import Distribution.Types.Executable - ( Executable(..) ) + ( Executable (..) + ) import Distribution.Types.GenericPackageDescription as GPD - ( GenericPackageDescription(..), emptyGenericPackageDescription ) + ( GenericPackageDescription (..) + , emptyGenericPackageDescription + ) import Distribution.Types.PackageDescription - ( PackageDescription(..), emptyPackageDescription ) + ( PackageDescription (..) + , emptyPackageDescription + ) import Distribution.Types.PackageName.Magic - ( fakePackageCabalFileName, fakePackageId ) + ( fakePackageCabalFileName + , fakePackageId + ) import Distribution.Types.UnitId - ( newSimpleUnitId ) + ( newSimpleUnitId + ) import Distribution.Types.UnqualComponentName - ( UnqualComponentName ) + ( UnqualComponentName + ) import Distribution.Utils.NubList - ( fromNubList ) -import Distribution.Client.ProjectPlanning - ( configureCompiler ) + ( fromNubList + ) import Distribution.Verbosity - ( normal ) + ( normal + ) import Language.Haskell.Extension - ( Language(..) ) + ( Language (..) + ) import Control.Concurrent.MVar - ( newEmptyMVar, putMVar, tryTakeMVar ) + ( newEmptyMVar + , putMVar + , tryTakeMVar + ) import Control.Exception - ( bracket ) + ( bracket + ) import qualified Data.ByteString.Char8 as BS import Data.ByteString.Lazy () import qualified Data.Set as S import System.Directory - ( canonicalizePath, doesFileExist, getTemporaryDirectory, removeDirectoryRecursive ) + ( canonicalizePath + , doesFileExist + , getTemporaryDirectory + , removeDirectoryRecursive + ) import System.FilePath - ( (), makeRelative, takeDirectory, takeFileName ) + ( makeRelative + , takeDirectory + , takeFileName + , () + ) import qualified Text.Parsec as P -- A note on multi-module script support #6787: @@ -136,12 +222,16 @@ import qualified Text.Parsec as P -- Two hashes will be the same as long as the absolute paths -- are the same. getScriptHash :: FilePath -> IO String -getScriptHash script +getScriptHash script = -- Base64 is shorter than Base16, which helps avoid long path issues on windows -- but it can contain /'s which aren't valid in file paths so replace them with -- %'s. 26 chars / 130 bits is enough to practically avoid collisions. - = map (\c -> if c == '/' then '%' else c) . take 26 - . showHashValueBase64 . hashValue . fromString <$> canonicalizePath script + map (\c -> if c == '/' then '%' else c) + . take 26 + . showHashValueBase64 + . hashValue + . fromString + <$> canonicalizePath script -- | Get the directory for caching a script build. -- @@ -162,17 +252,21 @@ ensureScriptCacheDirectory verbosity script = do -- | What your command should do when no targets are found. data AcceptNoTargets - = RejectNoTargets -- ^ die on 'TargetSelectorNoTargetsInProject' - | AcceptNoTargets -- ^ return a default 'TargetSelector' + = -- | die on 'TargetSelectorNoTargetsInProject' + RejectNoTargets + | -- | return a default 'TargetSelector' + AcceptNoTargets deriving (Eq, Show) -- | Information about the context in which we found the 'TargetSelector's. data TargetContext - = ProjectContext -- ^ The target selectors are part of a project. - | GlobalContext -- ^ The target selectors are from the global context. - | ScriptContext FilePath Executable - -- ^ The target selectors refer to a script. Contains the path to the script and - -- the executable metadata parsed from the script + = -- | The target selectors are part of a project. + ProjectContext + | -- | The target selectors are from the global context. + GlobalContext + | -- | The target selectors refer to a script. Contains the path to the script and + -- the executable metadata parsed from the script + ScriptContext FilePath Executable deriving (Eq, Show) -- | Determine whether the targets represent regular targets or a script @@ -182,40 +276,47 @@ data TargetContext -- In the case that the context refers to a temporary directory, -- delete it after the action finishes. withContextAndSelectors - :: AcceptNoTargets -- ^ What your command should do when no targets are found. - -> Maybe ComponentKind -- ^ A target filter - -> NixStyleFlags a -- ^ Command line flags - -> [String] -- ^ Target strings or a script and args. - -> GlobalFlags -- ^ Global flags. - -> CurrentCommand -- ^ Current Command (usually for error reporting). + :: AcceptNoTargets + -- ^ What your command should do when no targets are found. + -> Maybe ComponentKind + -- ^ A target filter + -> NixStyleFlags a + -- ^ Command line flags + -> [String] + -- ^ Target strings or a script and args. + -> GlobalFlags + -- ^ Global flags. + -> CurrentCommand + -- ^ Current Command (usually for error reporting). -> (TargetContext -> ProjectBaseContext -> [TargetSelector] -> IO b) -- ^ The body of your command action. -> IO b -withContextAndSelectors noTargets kind flags@NixStyleFlags {..} targetStrings globalFlags cmd act - = withTemporaryTempDirectory $ \mkTmpDir -> do +withContextAndSelectors noTargets kind flags@NixStyleFlags{..} targetStrings globalFlags cmd act = + withTemporaryTempDirectory $ \mkTmpDir -> do (tc, ctx) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject (withoutProject mkTmpDir) (tc', ctx', sels) <- case targetStrings of -- Only script targets may contain spaces and or end with ':'. -- Trying to readTargetSelectors such a target leads to a parse error. [target] | any (\c -> isSpace c) target || ":" `isSuffixOf` target -> do - scriptOrError target [TargetSelectorNoScript $ TargetString1 target] - _ -> do + scriptOrError target [TargetSelectorNoScript $ TargetString1 target] + _ -> do -- In the case where a selector is both a valid target and script, assume it is a target, -- because you can disambiguate the script with "./script" readTargetSelectors (localPackages ctx) kind targetStrings >>= \case - Left err@(TargetSelectorNoTargetsInProject:_) + Left err@(TargetSelectorNoTargetsInProject : _) | [] <- targetStrings - , AcceptNoTargets <- noTargets -> return (tc, ctx, defaultTarget) - | (script:_) <- targetStrings -> scriptOrError script err - Left err@(TargetSelectorNoSuch t _:_) - | TargetString1 script <- t -> scriptOrError script err - Left err@(TargetSelectorExpected t _ _:_) - | TargetString1 script <- t -> scriptOrError script err - Left err@(MatchingInternalError _ _ _:_) -- Handle ':' in middle of script name. - | [script] <- targetStrings -> scriptOrError script err - Left err -> reportTargetSelectorProblems verbosity err - Right sels -> return (tc, ctx, sels) + , AcceptNoTargets <- noTargets -> + return (tc, ctx, defaultTarget) + | (script : _) <- targetStrings -> scriptOrError script err + Left err@(TargetSelectorNoSuch t _ : _) + | TargetString1 script <- t -> scriptOrError script err + Left err@(TargetSelectorExpected t _ _ : _) + | TargetString1 script <- t -> scriptOrError script err + Left err@(MatchingInternalError _ _ _ : _) -- Handle ':' in middle of script name. + | [script] <- targetStrings -> scriptOrError script err + Left err -> reportTargetSelectorProblems verbosity err + Right sels -> return (tc, ctx, sels) act tc' ctx' sels where @@ -234,7 +335,7 @@ withContextAndSelectors noTargets kind flags@NixStyleFlags {..} targetStrings gl return (GlobalContext, ctx) scriptBaseCtx script globalConfig = do - let noDistDir = mempty { projectConfigShared = mempty { projectConfigDistDir = Flag "" } } + let noDistDir = mempty{projectConfigShared = mempty{projectConfigDistDir = Flag ""}} let cfg = noDistDir <> globalConfig <> cliConfig rootDir <- ensureScriptCacheDirectory verbosity script distDirLayout <- establishDummyDistDirLayout verbosity cfg rootDir @@ -242,40 +343,44 @@ withContextAndSelectors noTargets kind flags@NixStyleFlags {..} targetStrings gl scriptOrError script err = do exists <- doesFileExist script - if exists then do - ctx <- withGlobalConfig verbosity globalConfigFlag (scriptBaseCtx script) + if exists + then do + ctx <- withGlobalConfig verbosity globalConfigFlag (scriptBaseCtx script) - let projectRoot = distProjectRootDirectory $ distDirLayout ctx - writeFile (projectRoot "scriptlocation") =<< canonicalizePath script + let projectRoot = distProjectRootDirectory $ distDirLayout ctx + writeFile (projectRoot "scriptlocation") =<< canonicalizePath script - scriptContents <- BS.readFile script - executable <- readExecutableBlockFromScript verbosity scriptContents + scriptContents <- BS.readFile script + executable <- readExecutableBlockFromScript verbosity scriptContents + httpTransport <- + configureTransport + verbosity + (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig) + (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig) - httpTransport <- configureTransport verbosity - (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig) - (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig) + projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout ctx) (takeFileName script) scriptContents - projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout ctx) (takeFileName script) scriptContents + createDirectoryIfMissingVerbose verbosity True (distProjectCacheDirectory $ distDirLayout ctx) + (compiler, platform@(Platform arch os), _) <- runRebuild projectRoot $ configureCompiler verbosity (distDirLayout ctx) (fst (ignoreConditions projectCfgSkeleton) <> projectConfig ctx) - createDirectoryIfMissingVerbose verbosity True (distProjectCacheDirectory $ distDirLayout ctx) - (compiler, platform@(Platform arch os), _) <- runRebuild projectRoot $ configureCompiler verbosity (distDirLayout ctx) (fst (ignoreConditions projectCfgSkeleton) <> projectConfig ctx) + projectCfg <- instantiateProjectConfigSkeletonFetchingCompiler (pure (os, arch, compilerInfo compiler)) mempty projectCfgSkeleton - projectCfg <- instantiateProjectConfigSkeletonFetchingCompiler (pure (os, arch, compilerInfo compiler)) mempty projectCfgSkeleton + let ctx' = ctx & lProjectConfig %~ (<> projectCfg) - let ctx' = ctx & lProjectConfig %~ (<> projectCfg) + build_dir = distBuildDirectory (distDirLayout ctx') $ (scriptDistDirParams script) ctx' compiler platform + exePath = build_dir "bin" scriptExeFileName script + exePathRel = makeRelative projectRoot exePath - build_dir = distBuildDirectory (distDirLayout ctx') $ (scriptDistDirParams script) ctx' compiler platform - exePath = build_dir "bin" scriptExeFileName script - exePathRel = makeRelative projectRoot exePath + executable' = + executable + & L.buildInfo . L.defaultLanguage %~ maybe (Just Haskell2010) Just + & L.buildInfo . L.options %~ fmap (setExePath exePathRel) - executable' = executable & L.buildInfo . L.defaultLanguage %~ maybe (Just Haskell2010) Just - & L.buildInfo . L.options %~ fmap (setExePath exePathRel) + createDirectoryIfMissingVerbose verbosity True (takeDirectory exePath) - createDirectoryIfMissingVerbose verbosity True (takeDirectory exePath) - - return (ScriptContext script executable', ctx', defaultTarget) - else reportTargetSelectorProblems verbosity err + return (ScriptContext script executable', ctx', defaultTarget) + else reportTargetSelectorProblems verbosity err withTemporaryTempDirectory :: (IO FilePath -> IO a) -> IO a withTemporaryTempDirectory act = newEmptyMVar >>= \m -> bracket (getMkTmp m) (rmTmp m) act @@ -294,47 +399,51 @@ scriptComponenetName :: IsString s => FilePath -> s scriptComponenetName scriptPath = fromString cname where cname = "script-" ++ map censor (takeFileName scriptPath) - censor c | c `S.member` ccNamecore = c - | otherwise = '_' + censor c + | c `S.member` ccNamecore = c + | otherwise = '_' scriptExeFileName :: FilePath -> FilePath scriptExeFileName scriptPath = "cabal-script-" ++ takeFileName scriptPath scriptDistDirParams :: FilePath -> ProjectBaseContext -> Compiler -> Platform -> DistDirParams -scriptDistDirParams scriptPath ctx compiler platform = DistDirParams - { distParamUnitId = newSimpleUnitId cid - , distParamPackageId = fakePackageId - , distParamComponentId = cid - , distParamComponentName = Just $ CExeName cn - , distParamCompilerId = compilerId compiler - , distParamPlatform = platform - , distParamOptimization = fromFlagOrDefault NormalOptimisation optimization - } +scriptDistDirParams scriptPath ctx compiler platform = + DistDirParams + { distParamUnitId = newSimpleUnitId cid + , distParamPackageId = fakePackageId + , distParamComponentId = cid + , distParamComponentName = Just $ CExeName cn + , distParamCompilerId = compilerId compiler + , distParamPlatform = platform + , distParamOptimization = fromFlagOrDefault NormalOptimisation optimization + } where - cn = scriptComponenetName scriptPath - cid = mkComponentId $ prettyShow fakePackageId <> "-inplace-" <> prettyShow cn - optimization = (packageConfigOptimization . projectConfigLocalPackages . projectConfig) ctx + cn = scriptComponenetName scriptPath + cid = mkComponentId $ prettyShow fakePackageId <> "-inplace-" <> prettyShow cn + optimization = (packageConfigOptimization . projectConfigLocalPackages . projectConfig) ctx setExePath :: FilePath -> [String] -> [String] setExePath exePath options | "-o" `notElem` options = "-o" : exePath : options - | otherwise = options + | otherwise = options -- | Add the 'SourcePackage' to the context and use it to write a .cabal file. updateContextAndWriteProjectFile' :: ProjectBaseContext -> SourcePackage (PackageLocation (Maybe FilePath)) -> IO ProjectBaseContext updateContextAndWriteProjectFile' ctx srcPkg = do - let projectRoot = distProjectRootDirectory $ distDirLayout ctx - packageFile = projectRoot fakePackageCabalFileName - contents = showGenericPackageDescription (srcpkgDescription srcPkg) + let projectRoot = distProjectRootDirectory $ distDirLayout ctx + packageFile = projectRoot fakePackageCabalFileName + contents = showGenericPackageDescription (srcpkgDescription srcPkg) writePackageFile = writeUTF8File packageFile contents -- TODO This is here to prevent reconfiguration of cached repl packages. -- It's worth investigating why it's needed in the first place. packageFileExists <- doesFileExist packageFile - if packageFileExists then do - cached <- force <$> readUTF8File packageFile - when (cached /= contents) - writePackageFile - else writePackageFile + if packageFileExists + then do + cached <- force <$> readUTF8File packageFile + when + (cached /= contents) + writePackageFile + else writePackageFile return (ctx & lLocalPackages %~ (++ [SpecificSourcePackage srcPkg])) -- | Add add the executable metadata to the context and write a .cabal file. @@ -344,23 +453,26 @@ updateContextAndWriteProjectFile ctx scriptPath scriptExecutable = do absScript <- canonicalizePath scriptPath let - sourcePackage = fakeProjectSourcePackage projectRoot - & lSrcpkgDescription . L.condExecutables - .~ [(scriptComponenetName scriptPath, CondNode executable (targetBuildDepends $ buildInfo executable) [])] - executable = scriptExecutable - & L.modulePath .~ absScript + sourcePackage = + fakeProjectSourcePackage projectRoot + & lSrcpkgDescription . L.condExecutables + .~ [(scriptComponenetName scriptPath, CondNode executable (targetBuildDepends $ buildInfo executable) [])] + executable = + scriptExecutable + & L.modulePath .~ absScript updateContextAndWriteProjectFile' ctx sourcePackage parseScriptBlock :: BS.ByteString -> ParseResult Executable parseScriptBlock str = - case readFields str of - Right fs -> do - let (fields, _) = takeFields fs - parseFieldGrammar cabalSpecLatest fields (executableFieldGrammar "script") - Left perr -> parseFatalFailure pos (show perr) where - ppos = P.errorPos perr - pos = Position (P.sourceLine ppos) (P.sourceColumn ppos) + case readFields str of + Right fs -> do + let (fields, _) = takeFields fs + parseFieldGrammar cabalSpecLatest fields (executableFieldGrammar "script") + Left perr -> parseFatalFailure pos (show perr) + where + ppos = P.errorPos perr + pos = Position (P.sourceLine ppos) (P.sourceColumn ppos) readScriptBlock :: Verbosity -> BS.ByteString -> IO Executable readScriptBlock verbosity = parseString parseScriptBlock verbosity "script block" @@ -375,11 +487,11 @@ readScriptBlock verbosity = parseString parseScriptBlock verbosity "script block -- Return the metadata. readExecutableBlockFromScript :: Verbosity -> BS.ByteString -> IO Executable readExecutableBlockFromScript verbosity str = do - str' <- case extractScriptBlock "cabal" str of - Left e -> die' verbosity $ "Failed extracting script block: " ++ e - Right x -> return x - when (BS.all isSpace str') $ warn verbosity "Empty script block" - readScriptBlock verbosity str' + str' <- case extractScriptBlock "cabal" str of + Left e -> die' verbosity $ "Failed extracting script block: " ++ e + Right x -> return x + when (BS.all isSpace str') $ warn verbosity "Empty script block" + readScriptBlock verbosity str' -- | Extract the first encountered project metadata block started and -- terminated by the below tokens. @@ -391,10 +503,11 @@ readExecutableBlockFromScript verbosity str = do -- Return the metadata. readProjectBlockFromScript :: Verbosity -> HttpTransport -> DistDirLayout -> String -> BS.ByteString -> IO ProjectConfigSkeleton readProjectBlockFromScript verbosity httpTransport DistDirLayout{distDownloadSrcDirectory} scriptName str = do - case extractScriptBlock "project" str of - Left _ -> return mempty - Right x -> reportParseResult verbosity "script" scriptName - =<< parseProjectSkeleton distDownloadSrcDirectory httpTransport verbosity [] scriptName x + case extractScriptBlock "project" str of + Left _ -> return mempty + Right x -> + reportParseResult verbosity "script" scriptName + =<< parseProjectSkeleton distDownloadSrcDirectory httpTransport verbosity [] scriptName x -- | Extract the first encountered script metadata block started end -- terminated by the tokens @@ -412,42 +525,46 @@ extractScriptBlock :: BS.ByteString -> BS.ByteString -> Either String BS.ByteStr extractScriptBlock header str = goPre (BS.lines str) where isStartMarker = (== startMarker) . stripTrailSpace - isEndMarker = (== endMarker) . stripTrailSpace + isEndMarker = (== endMarker) . stripTrailSpace stripTrailSpace = fst . BS.spanEnd isSpace -- before start marker goPre ls = case dropWhile (not . isStartMarker) ls of - [] -> Left $ "`" ++ BS.unpack startMarker ++ "` start marker not found" - (_:ls') -> goBody [] ls' + [] -> Left $ "`" ++ BS.unpack startMarker ++ "` start marker not found" + (_ : ls') -> goBody [] ls' goBody _ [] = Left $ "`" ++ BS.unpack endMarker ++ "` end marker not found" - goBody acc (l:ls) + goBody acc (l : ls) | isEndMarker l = Right $! BS.unlines $ reverse acc - | otherwise = goBody (l:acc) ls + | otherwise = goBody (l : acc) ls startMarker, endMarker :: BS.ByteString startMarker = "{- " <> header <> ":" - endMarker = "-}" + endMarker = "-}" -- | The base for making a 'SourcePackage' for a fake project. -- It needs a 'Distribution.Types.Library.Library' or 'Executable' depending on the command. fakeProjectSourcePackage :: FilePath -> SourcePackage (PackageLocation loc) fakeProjectSourcePackage projectRoot = sourcePackage where - sourcePackage = SourcePackage - { srcpkgPackageId = fakePackageId - , srcpkgDescription = genericPackageDescription - , srcpkgSource = LocalUnpackedPackage projectRoot - , srcpkgDescrOverride = Nothing - } - genericPackageDescription = emptyGenericPackageDescription - { GPD.packageDescription = packageDescription } - packageDescription = emptyPackageDescription - { package = fakePackageId - , specVersion = CabalSpecV2_2 - , licenseRaw = Left SPDX.NONE - } + sourcePackage = + SourcePackage + { srcpkgPackageId = fakePackageId + , srcpkgDescription = genericPackageDescription + , srcpkgSource = LocalUnpackedPackage projectRoot + , srcpkgDescrOverride = Nothing + } + genericPackageDescription = + emptyGenericPackageDescription + { GPD.packageDescription = packageDescription + } + packageDescription = + emptyPackageDescription + { package = fakePackageId + , specVersion = CabalSpecV2_2 + , licenseRaw = Left SPDX.NONE + } -- | Find the path of an exe that has been relocated with a "-o" option movedExePath :: UnqualComponentName -> DistDirLayout -> ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> Maybe FilePath @@ -459,25 +576,26 @@ movedExePath selectedComponent distDirLayout elabShared elabConfigured = do fmap (projectRoot ) . lookup "-o" $ reverse (zip opts (drop 1 opts)) -- Lenses + -- | A lens for the 'srcpkgDescription' field of 'SourcePackage' lSrcpkgDescription :: Lens' (SourcePackage loc) GenericPackageDescription -lSrcpkgDescription f s = fmap (\x -> s { srcpkgDescription = x }) (f (srcpkgDescription s)) -{-# inline lSrcpkgDescription #-} +lSrcpkgDescription f s = fmap (\x -> s{srcpkgDescription = x}) (f (srcpkgDescription s)) +{-# INLINE lSrcpkgDescription #-} lLocalPackages :: Lens' ProjectBaseContext [PackageSpecifier UnresolvedSourcePackage] -lLocalPackages f s = fmap (\x -> s { localPackages = x }) (f (localPackages s)) -{-# inline lLocalPackages #-} +lLocalPackages f s = fmap (\x -> s{localPackages = x}) (f (localPackages s)) +{-# INLINE lLocalPackages #-} lProjectConfig :: Lens' ProjectBaseContext ProjectConfig -lProjectConfig f s = fmap (\x -> s { projectConfig = x }) (f (projectConfig s)) -{-# inline lProjectConfig #-} +lProjectConfig f s = fmap (\x -> s{projectConfig = x}) (f (projectConfig s)) +{-# INLINE lProjectConfig #-} -- Character classes -- Transcribed from "templates/Lexer.x" ccSpace, ccCtrlchar, ccPrintable, ccSymbol', ccParen, ccNamecore :: Set Char -ccSpace = S.fromList " " -ccCtrlchar = S.fromList $ [chr 0x0 .. chr 0x1f] ++ [chr 0x7f] +ccSpace = S.fromList " " +ccCtrlchar = S.fromList $ [chr 0x0 .. chr 0x1f] ++ [chr 0x7f] ccPrintable = S.fromList [chr 0x0 .. chr 0xff] S.\\ ccCtrlchar -ccSymbol' = S.fromList ",=<>+*&|!$%^@#?/\\~" -ccParen = S.fromList "()[]" -ccNamecore = ccPrintable S.\\ S.unions [ccSpace, S.fromList ":\"{}", ccParen, ccSymbol'] +ccSymbol' = S.fromList ",=<>+*&|!$%^@#?/\\~" +ccParen = S.fromList "()[]" +ccNamecore = ccPrintable S.\\ S.unions [ccSpace, S.fromList ":\"{}", ccParen, ccSymbol'] diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index ce64c8a5ef6..f550c6e36e8 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -1,483 +1,3469 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} --- | Utilities to help commands with scripts +----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Client.Setup +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like -- -module Distribution.Client.ScriptUtils ( - getScriptHash, getScriptCacheDirectory, ensureScriptCacheDirectory, - withContextAndSelectors, AcceptNoTargets(..), TargetContext(..), - updateContextAndWriteProjectFile, updateContextAndWriteProjectFile', - fakeProjectSourcePackage, lSrcpkgDescription, - movedExePath +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +module Distribution.Client.Setup + ( globalCommand + , GlobalFlags (..) + , defaultGlobalFlags + , RepoContext (..) + , withRepoContext + , configureCommand + , ConfigFlags (..) + , configureOptions + , filterConfigureFlags + , configPackageDB' + , configCompilerAux' + , configureExCommand + , ConfigExFlags (..) + , defaultConfigExFlags + , buildCommand + , BuildFlags (..) + , filterTestFlags + , replCommand + , testCommand + , benchmarkCommand + , testOptions + , benchmarkOptions + , configureExOptions + , reconfigureCommand + , installCommand + , InstallFlags (..) + , installOptions + , defaultInstallFlags + , filterHaddockArgs + , filterHaddockFlags + , haddockOptions + , defaultSolver + , defaultMaxBackjumps + , listCommand + , ListFlags (..) + , listNeedsCompiler + , UpdateFlags (..) + , defaultUpdateFlags + , infoCommand + , InfoFlags (..) + , fetchCommand + , FetchFlags (..) + , freezeCommand + , FreezeFlags (..) + , genBoundsCommand + , getCommand + , unpackCommand + , GetFlags (..) + , checkCommand + , formatCommand + , uploadCommand + , UploadFlags (..) + , IsCandidate (..) + , reportCommand + , ReportFlags (..) + , runCommand + , initCommand + , initOptions + , IT.InitFlags (..) + , actAsSetupCommand + , ActAsSetupFlags (..) + , userConfigCommand + , UserConfigFlags (..) + , manpageCommand + , haddockCommand + , cleanCommand + , copyCommand + , registerCommand + , liftOptions + , yesNoOpt ) where +import Distribution.Client.Compat.Prelude hiding (get) import Prelude () -import Distribution.Client.Compat.Prelude hiding (toList) - -import Distribution.Compat.Lens -import qualified Distribution.Types.Lens as L - -import Distribution.CabalSpecVersion - ( CabalSpecVersion (..), cabalSpecLatest) -import Distribution.Client.ProjectOrchestration -import Distribution.Client.Config - ( defaultScriptBuildsDir ) -import Distribution.Client.DistDirLayout - ( DistDirLayout(..), DistDirParams(..) ) -import Distribution.Client.HashValue - ( hashValue, showHashValueBase64 ) -import Distribution.Client.HttpUtils - ( HttpTransport, configureTransport ) -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (..) ) -import Distribution.Client.ProjectConfig - ( ProjectConfig(..), ProjectConfigShared(..), PackageConfig(..) - , reportParseResult, withGlobalConfig, withProjectOrGlobalConfig - , projectConfigHttpTransport ) -import Distribution.Client.ProjectConfig.Legacy - ( ProjectConfigSkeleton - , parseProjectSkeleton, instantiateProjectConfigSkeletonFetchingCompiler ) -import Distribution.Client.ProjectFlags - ( flagIgnoreProject ) -import Distribution.Client.ProjectPlanning - ( ElaboratedSharedConfig(..), ElaboratedConfiguredPackage(..) ) -import Distribution.Client.RebuildMonad - ( runRebuild ) -import Distribution.Client.Setup - ( ConfigFlags(..), GlobalFlags(..) ) -import Distribution.Client.TargetSelector - ( TargetSelectorProblem(..), TargetString(..) ) -import Distribution.Client.Types - ( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage ) -import Distribution.Compiler - ( CompilerId(..), perCompilerFlavorToList ) -import Distribution.FieldGrammar - ( parseFieldGrammar, takeFields ) -import Distribution.Fields - ( ParseResult, parseFatalFailure, readFields ) + +import Distribution.Client.Types.AllowNewer (AllowNewer (..), AllowOlder (..), RelaxDeps (..)) +import Distribution.Client.Types.Credentials (Password (..), Username (..)) +import Distribution.Client.Types.Repo (LocalRepo (..), RemoteRepo (..)) +import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy + +import Distribution.Client.BuildReports.Types + ( ReportLevel (..) + ) +import Distribution.Client.Dependency.Types + ( PreSolver (..) + ) +import Distribution.Client.IndexUtils.ActiveRepos + ( ActiveRepos + ) +import Distribution.Client.IndexUtils.IndexState + ( TotalIndexState + , headTotalIndexState + ) +import qualified Distribution.Client.Init.Defaults as IT +import qualified Distribution.Client.Init.Types as IT +import Distribution.Client.Targets + ( UserConstraint + , readUserConstraint + ) +import Distribution.Utils.NubList + ( NubList + , fromNubList + , toNubList + ) + +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.Settings + +import Distribution.Client.GlobalFlags + ( GlobalFlags (..) + , RepoContext (..) + , defaultGlobalFlags + , withRepoContext + ) +import Distribution.Client.ManpageFlags (ManpageFlags, defaultManpageFlags, manpageOptions) +import qualified Distribution.Compat.CharParsing as P +import Distribution.FieldGrammar.Newtypes (SpecVersion (..)) import Distribution.PackageDescription - ( ignoreConditions ) -import Distribution.PackageDescription.FieldGrammar - ( executableFieldGrammar ) -import Distribution.PackageDescription.PrettyPrint - ( showGenericPackageDescription ) + ( BuildType (..) + , Dependency + , LibraryName (..) + , RepoKind (..) + ) import Distribution.Parsec - ( Position(..) ) + ( parsecCommaList + ) +import Distribution.ReadE + ( ReadE (..) + , parsecToReadE + , parsecToReadEErr + , succeedReadE + , unexpectMsgString + ) +import Distribution.Simple.Command hiding (boolOpt, boolOpt') +import qualified Distribution.Simple.Command as Command +import Distribution.Simple.Compiler (Compiler, PackageDB, PackageDBStack) +import Distribution.Simple.Configure + ( computeEffectiveProfiling + , configCompilerAuxEx + , interpretPackageDbFlags + ) import Distribution.Simple.Flag - ( fromFlagOrDefault, flagToMaybe ) -import Distribution.Simple.PackageDescription - ( parseString ) + ( Flag (..) + , flagElim + , flagToList + , flagToMaybe + , fromFlagOrDefault + , maybeToFlag + , toFlag + ) +import Distribution.Simple.InstallDirs + ( InstallDirs (..) + , PathTemplate + , combinePathTemplate + , fromPathTemplate + , toPathTemplate + ) +import Distribution.Simple.Program (ProgramDb, defaultProgramDb) import Distribution.Simple.Setup - ( Flag(..) ) -import Distribution.Simple.Compiler - ( Compiler(..), OptimisationLevel(..), compilerInfo ) + ( BenchmarkFlags + , BooleanFlag (..) + , BuildFlags (..) + , CleanFlags (..) + , ConfigFlags (..) + , CopyFlags (..) + , HaddockFlags (..) + , RegisterFlags (..) + , ReplFlags + , TestFlags + , boolOpt + , boolOpt' + , falseArg + , optionNumJobs + , optionVerbosity + , readPackageDbList + , showPackageDbList + , trueArg + ) +import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, createTempDirectory, die', handleDoesNotExist, readUTF8File, warn, writeUTF8File ) -import qualified Distribution.SPDX.License as SPDX -import Distribution.Solver.Types.SourcePackage as SP - ( SourcePackage(..) ) -import Distribution.System - ( Platform(..) ) -import Distribution.Types.BuildInfo - ( BuildInfo(..) ) -import Distribution.Types.ComponentId - ( mkComponentId ) -import Distribution.Types.CondTree - ( CondTree(..) ) -import Distribution.Types.Executable - ( Executable(..) ) -import Distribution.Types.GenericPackageDescription as GPD - ( GenericPackageDescription(..), emptyGenericPackageDescription ) -import Distribution.Types.PackageDescription - ( PackageDescription(..), emptyPackageDescription ) -import Distribution.Types.PackageName.Magic - ( fakePackageCabalFileName, fakePackageId ) -import Distribution.Types.UnitId - ( newSimpleUnitId ) + ( wrapText + ) +import Distribution.System (Platform) +import Distribution.Types.GivenComponent + ( GivenComponent (..) + ) +import Distribution.Types.PackageVersionConstraint + ( PackageVersionConstraint (..) + ) import Distribution.Types.UnqualComponentName - ( UnqualComponentName ) -import Distribution.Utils.NubList - ( fromNubList ) -import Distribution.Client.ProjectPlanning - ( configureCompiler ) + ( unqualComponentNameToPackageName + ) import Distribution.Verbosity - ( normal ) -import Language.Haskell.Extension - ( Language(..) ) + ( lessVerbose + , normal + , verboseNoFlags + , verboseNoTimestamp + ) +import Distribution.Version + ( Version + , mkVersion + ) -import Control.Concurrent.MVar - ( newEmptyMVar, putMVar, tryTakeMVar ) import Control.Exception - ( bracket ) -import qualified Data.ByteString.Char8 as BS -import Data.ByteString.Lazy () -import qualified Data.Set as S -import System.Directory - ( canonicalizePath, doesFileExist, getTemporaryDirectory, removeDirectoryRecursive ) + ( assert + ) +import Data.List + ( deleteFirstsBy + ) import System.FilePath - ( (), makeRelative, takeDirectory, takeFileName ) -import qualified Text.Parsec as P - --- A note on multi-module script support #6787: --- Multi-module scripts are not supported and support is non-trivial. --- What you want to do is pass the absolute path to the script's directory in hs-source-dirs, --- but hs-source-dirs only accepts relative paths. This leaves you with several options none --- of which are particularly appealing. --- 1) Loosen the requirement that hs-source-dirs take relative paths --- 2) Add a field to BuildInfo that acts like an hs-source-dir, but accepts an absolute path --- 3) Use a path relative to the project root in hs-source-dirs, and pass extra flags to the --- repl to deal with the fact that the repl is relative to the working directory and not --- the project root. - --- | Get the hash of a script's absolute path) --- --- Two hashes will be the same as long as the absolute paths --- are the same. -getScriptHash :: FilePath -> IO String -getScriptHash script - -- Base64 is shorter than Base16, which helps avoid long path issues on windows - -- but it can contain /'s which aren't valid in file paths so replace them with - -- %'s. 26 chars / 130 bits is enough to practically avoid collisions. - = map (\c -> if c == '/' then '%' else c) . take 26 - . showHashValueBase64 . hashValue . fromString <$> canonicalizePath script - --- | Get the directory for caching a script build. --- --- The only identity of a script is it's absolute path, so append the --- hashed path to the @script-builds@ dir to get the cache directory. -getScriptCacheDirectory :: FilePath -> IO FilePath -getScriptCacheDirectory script = () <$> defaultScriptBuildsDir <*> getScriptHash script + ( () + ) --- | Get the directory for caching a script build and ensure it exists. --- --- The only identity of a script is it's absolute path, so append the --- hashed path to the @script-builds@ dir to get the cache directory. -ensureScriptCacheDirectory :: Verbosity -> FilePath -> IO FilePath -ensureScriptCacheDirectory verbosity script = do - cacheDir <- getScriptCacheDirectory script - createDirectoryIfMissingVerbose verbosity True cacheDir - return cacheDir - --- | What your command should do when no targets are found. -data AcceptNoTargets - = RejectNoTargets -- ^ die on 'TargetSelectorNoTargetsInProject' - | AcceptNoTargets -- ^ return a default 'TargetSelector' - deriving (Eq, Show) - --- | Information about the context in which we found the 'TargetSelector's. -data TargetContext - = ProjectContext -- ^ The target selectors are part of a project. - | GlobalContext -- ^ The target selectors are from the global context. - | ScriptContext FilePath Executable - -- ^ The target selectors refer to a script. Contains the path to the script and - -- the executable metadata parsed from the script - deriving (Eq, Show) - --- | Determine whether the targets represent regular targets or a script --- and return the proper context and target selectors. --- Die with an error message if selectors are valid as neither regular targets or as a script. --- --- In the case that the context refers to a temporary directory, --- delete it after the action finishes. -withContextAndSelectors - :: AcceptNoTargets -- ^ What your command should do when no targets are found. - -> Maybe ComponentKind -- ^ A target filter - -> NixStyleFlags a -- ^ Command line flags - -> [String] -- ^ Target strings or a script and args. - -> GlobalFlags -- ^ Global flags. - -> CurrentCommand -- ^ Current Command (usually for error reporting). - -> (TargetContext -> ProjectBaseContext -> [TargetSelector] -> IO b) - -- ^ The body of your command action. - -> IO b -withContextAndSelectors noTargets kind flags@NixStyleFlags {..} targetStrings globalFlags cmd act - = withTemporaryTempDirectory $ \mkTmpDir -> do - (tc, ctx) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject (withoutProject mkTmpDir) - - (tc', ctx', sels) <- case targetStrings of - -- Only script targets may contain spaces and or end with ':'. - -- Trying to readTargetSelectors such a target leads to a parse error. - [target] | any (\c -> isSpace c) target || ":" `isSuffixOf` target -> do - scriptOrError target [TargetSelectorNoScript $ TargetString1 target] - _ -> do - -- In the case where a selector is both a valid target and script, assume it is a target, - -- because you can disambiguate the script with "./script" - readTargetSelectors (localPackages ctx) kind targetStrings >>= \case - Left err@(TargetSelectorNoTargetsInProject:_) - | [] <- targetStrings - , AcceptNoTargets <- noTargets -> return (tc, ctx, defaultTarget) - | (script:_) <- targetStrings -> scriptOrError script err - Left err@(TargetSelectorNoSuch t _:_) - | TargetString1 script <- t -> scriptOrError script err - Left err@(TargetSelectorExpected t _ _:_) - | TargetString1 script <- t -> scriptOrError script err - Left err@(MatchingInternalError _ _ _:_) -- Handle ':' in middle of script name. - | [script] <- targetStrings -> scriptOrError script err - Left err -> reportTargetSelectorProblems verbosity err - Right sels -> return (tc, ctx, sels) - - act tc' ctx' sels +globalCommand :: [Command action] -> CommandUI GlobalFlags +globalCommand commands = + CommandUI + { commandName = "" + , commandSynopsis = + "Command line interface to the Haskell Cabal infrastructure." + , commandUsage = \pname -> + "See http://www.haskell.org/cabal/ for more information.\n" + ++ "\n" + ++ "Usage: " + ++ pname + ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n" + , commandDescription = Just $ \pname -> + let + commands' = commands ++ [commandAddAction helpCommandUI undefined] + cmdDescs = getNormalCommandDescriptions commands' + -- if new commands are added, we want them to appear even if they + -- are not included in the custom listing below. Thus, we calculate + -- the `otherCmds` list and append it under the `other` category. + -- Alternatively, a new testcase could be added that ensures that + -- the set of commands listed here is equal to the set of commands + -- that are actually available. + otherCmds = + deleteFirstsBy + (==) + (map fst cmdDescs) + [ "help" + , "update" + , "install" + , "fetch" + , "list" + , "info" + , "user-config" + , "get" + , "unpack" + , "init" + , "configure" + , "build" + , "clean" + , "run" + , "repl" + , "test" + , "bench" + , "check" + , "sdist" + , "upload" + , "report" + , "freeze" + , "gen-bounds" + , "outdated" + , "haddock" + , "hscolour" + , "exec" + , "new-build" + , "new-configure" + , "new-repl" + , "new-freeze" + , "new-run" + , "new-test" + , "new-bench" + , "new-haddock" + , "new-exec" + , "new-update" + , "new-install" + , "new-clean" + , "new-sdist" + , "list-bin" + , -- v1 commands, stateful style + "v1-build" + , "v1-configure" + , "v1-repl" + , "v1-freeze" + , "v1-run" + , "v1-test" + , "v1-bench" + , "v1-haddock" + , "v1-exec" + , "v1-update" + , "v1-install" + , "v1-clean" + , "v1-sdist" + , "v1-doctest" + , "v1-copy" + , "v1-register" + , "v1-reconfigure" + , -- v2 commands, nix-style + "v2-build" + , "v2-configure" + , "v2-repl" + , "v2-freeze" + , "v2-run" + , "v2-test" + , "v2-bench" + , "v2-haddock" + , "v2-exec" + , "v2-update" + , "v2-install" + , "v2-clean" + , "v2-sdist" + ] + maxlen = maximum $ [length name | (name, _) <- cmdDescs] + align str = str ++ replicate (maxlen - length str) ' ' + startGroup n = " [" ++ n ++ "]" + par = "" + addCmd n = case lookup n cmdDescs of + Nothing -> "" + Just d -> " " ++ align n ++ " " ++ d + in + "Commands:\n" + ++ unlines + ( [ startGroup "global" + , addCmd "user-config" + , addCmd "help" + , par + , startGroup "package database" + , addCmd "update" + , addCmd "list" + , addCmd "info" + , par + , startGroup "initialization and download" + , addCmd "init" + , addCmd "fetch" + , addCmd "get" + , par + , startGroup "project configuration" + , addCmd "configure" + , addCmd "freeze" + , addCmd "gen-bounds" + , addCmd "outdated" + , par + , startGroup "project building and installing" + , addCmd "build" + , addCmd "install" + , addCmd "haddock" + , addCmd "haddock-project" + , addCmd "clean" + , par + , startGroup "running and testing" + , addCmd "list-bin" + , addCmd "repl" + , addCmd "run" + , addCmd "bench" + , addCmd "test" + , addCmd "exec" + , par + , startGroup "sanity checks and shipping" + , addCmd "check" + , addCmd "sdist" + , addCmd "upload" + , addCmd "report" + , par + , startGroup "deprecated" + , addCmd "unpack" + , addCmd "hscolour" + , par + , startGroup "new-style projects (forwards-compatible aliases)" + , addCmd "v2-build" + , addCmd "v2-configure" + , addCmd "v2-repl" + , addCmd "v2-run" + , addCmd "v2-test" + , addCmd "v2-bench" + , addCmd "v2-freeze" + , addCmd "v2-haddock" + , addCmd "v2-exec" + , addCmd "v2-update" + , addCmd "v2-install" + , addCmd "v2-clean" + , addCmd "v2-sdist" + , par + , startGroup "legacy command aliases" + , addCmd "v1-build" + , addCmd "v1-configure" + , addCmd "v1-repl" + , addCmd "v1-run" + , addCmd "v1-test" + , addCmd "v1-bench" + , addCmd "v1-freeze" + , addCmd "v1-haddock" + , addCmd "v1-install" + , addCmd "v1-clean" + , addCmd "v1-copy" + , addCmd "v1-register" + , addCmd "v1-reconfigure" + ] + ++ if null otherCmds + then [] + else + par + : startGroup "other" + : [addCmd n | n <- otherCmds] + ) + ++ "\n" + ++ "For more information about a command use:\n" + ++ " " + ++ pname + ++ " COMMAND --help\n" + ++ "or " + ++ pname + ++ " help COMMAND\n" + ++ "\n" + ++ "To install Cabal packages from hackage use:\n" + ++ " " + ++ pname + ++ " install foo [--dry-run]\n" + ++ "\n" + ++ "Occasionally you need to update the list of available packages:\n" + ++ " " + ++ pname + ++ " update\n" + , commandNotes = Nothing + , commandDefaultFlags = mempty + , commandOptions = args + } where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - ignoreProject = flagIgnoreProject projectFlags - cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty - globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) - defaultTarget = [TargetPackage TargetExplicitNamed [fakePackageId] Nothing] + args :: ShowOrParseArgs -> [OptionField GlobalFlags] + args ShowArgs = argsShown + args ParseArgs = argsShown ++ argsNotShown - withProject = do - ctx <- establishProjectBaseContext verbosity cliConfig cmd - return (ProjectContext, ctx) - withoutProject mkTmpDir globalConfig = do - distDirLayout <- establishDummyDistDirLayout verbosity (globalConfig <> cliConfig) =<< mkTmpDir - ctx <- establishDummyProjectBaseContext verbosity (globalConfig <> cliConfig) distDirLayout [] cmd - return (GlobalContext, ctx) + -- arguments we want to show in the help + argsShown :: [OptionField GlobalFlags] + argsShown = + [ option + ['V'] + ["version"] + "Print version information" + globalVersion + (\v flags -> flags{globalVersion = v}) + trueArg + , option + [] + ["numeric-version"] + "Print just the version number" + globalNumericVersion + (\v flags -> flags{globalNumericVersion = v}) + trueArg + , option + [] + ["config-file"] + "Set an alternate location for the config file" + globalConfigFile + (\v flags -> flags{globalConfigFile = v}) + (reqArgFlag "FILE") + , option + [] + ["ignore-expiry"] + "Ignore expiry dates on signed metadata (use only in exceptional circumstances)" + globalIgnoreExpiry + (\v flags -> flags{globalIgnoreExpiry = v}) + trueArg + , option + [] + ["http-transport"] + "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')" + globalHttpTransport + (\v flags -> flags{globalHttpTransport = v}) + (reqArgFlag "HttpTransport") + , multiOption + "nix" + globalNix + (\v flags -> flags{globalNix = v}) + [ optArg' + "(True or False)" + (maybeToFlag . (readMaybe =<<)) + ( \case + Flag True -> [Just "enable"] + Flag False -> [Just "disable"] + NoFlag -> [] + ) + "" + ["nix"] -- Must be empty because we need to return PP.empty from viewAsFieldDescr + "Nix integration: run commands through nix-shell if a 'shell.nix' file exists (default is False)" + , noArg + (Flag True) + [] + ["enable-nix"] + "Enable Nix integration: run commands through nix-shell if a 'shell.nix' file exists" + , noArg + (Flag False) + [] + ["disable-nix"] + "Disable Nix integration" + ] + , option + [] + ["store-dir", "storedir"] + "The location of the build store" + globalStoreDir + (\v flags -> flags{globalStoreDir = v}) + (reqArgFlag "DIR") + , option + [] + ["active-repositories"] + "The active package repositories (set to ':none' to disable all repositories)" + globalActiveRepos + (\v flags -> flags{globalActiveRepos = v}) + ( reqArg + "REPOS" + ( parsecToReadE + (\err -> "Error parsing active-repositories: " ++ err) + (toFlag `fmap` parsec) + ) + (map prettyShow . flagToList) + ) + ] - scriptBaseCtx script globalConfig = do - let noDistDir = mempty { projectConfigShared = mempty { projectConfigDistDir = Flag "" } } - let cfg = noDistDir <> globalConfig <> cliConfig - rootDir <- ensureScriptCacheDirectory verbosity script - distDirLayout <- establishDummyDistDirLayout verbosity cfg rootDir - establishDummyProjectBaseContext verbosity cfg distDirLayout [] cmd + -- arguments we don't want shown in the help + -- the remote repo flags are not useful compared to the more general "active-repositories" flag. + -- the global logs directory was only used in v1, while in v2 we have specific project config logs dirs + -- default-user-config is support for a relatively obscure workflow for v1-freeze. + argsNotShown :: [OptionField GlobalFlags] + argsNotShown = + [ option + [] + ["remote-repo"] + "The name and url for a remote repository" + globalRemoteRepos + (\v flags -> flags{globalRemoteRepos = v}) + (reqArg' "NAME:URL" (toNubList . maybeToList . readRemoteRepo) (map showRemoteRepo . fromNubList)) + , option + [] + ["local-no-index-repo"] + "The name and a path for a local no-index repository" + globalLocalNoIndexRepos + (\v flags -> flags{globalLocalNoIndexRepos = v}) + (reqArg' "NAME:PATH" (toNubList . maybeToList . readLocalRepo) (map showLocalRepo . fromNubList)) + , option + [] + ["remote-repo-cache"] + "The location where downloads from all remote repos are cached" + globalCacheDir + (\v flags -> flags{globalCacheDir = v}) + (reqArgFlag "DIR") + , option + [] + ["logs-dir", "logsdir"] + "The location to put log files" + globalLogsDir + (\v flags -> flags{globalLogsDir = v}) + (reqArgFlag "DIR") + , option + [] + ["default-user-config"] + "Set a location for a cabal.config file for projects without their own cabal.config freeze file." + globalConstraintsFile + (\v flags -> flags{globalConstraintsFile = v}) + (reqArgFlag "FILE") + ] - scriptOrError script err = do - exists <- doesFileExist script - if exists then do - ctx <- withGlobalConfig verbosity globalConfigFlag (scriptBaseCtx script) +-- ------------------------------------------------------------ - let projectRoot = distProjectRootDirectory $ distDirLayout ctx - writeFile (projectRoot "scriptlocation") =<< canonicalizePath script +-- * Config flags - scriptContents <- BS.readFile script - executable <- readExecutableBlockFromScript verbosity scriptContents +-- ------------------------------------------------------------ +configureCommand :: CommandUI ConfigFlags +configureCommand = + c + { commandName = "configure" + , commandDefaultFlags = mempty + , commandDescription = Just $ \_ -> + wrapText $ + "Configure how the package is built by setting " + ++ "package (and other) flags.\n" + ++ "\n" + ++ "The configuration affects several other commands, " + ++ "including v1-build, v1-test, v1-bench, v1-run, v1-repl.\n" + , commandUsage = \pname -> + "Usage: " ++ pname ++ " v1-configure [FLAGS]\n" + , commandNotes = Just $ \pname -> + (Cabal.programFlagsDescription defaultProgramDb ++ "\n") + ++ "Examples:\n" + ++ " " + ++ pname + ++ " v1-configure\n" + ++ " Configure with defaults;\n" + ++ " " + ++ pname + ++ " v1-configure --enable-tests -fcustomflag\n" + ++ " Configure building package including tests,\n" + ++ " with some package-specific flag.\n" + } + where + c = Cabal.configureCommand defaultProgramDb + +configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] +configureOptions = commandOptions configureCommand - httpTransport <- configureTransport verbosity - (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig) - (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig) +-- | 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 +-- flags into a form that will be accepted by the older +-- Setup script. Generally speaking, this just means filtering +-- out flags that the old Cabal library doesn't understand, but +-- in some cases it may also mean "emulating" a feature using +-- some more legacy flags. +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 + -- 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 + -- these flags work for; version of introduction is a more + -- natural metric. + | cabalLibVersion < mkVersion [1, 3, 10] = flags_1_3_10 + | cabalLibVersion < mkVersion [1, 10, 0] = flags_1_10_0 + | cabalLibVersion < mkVersion [1, 12, 0] = flags_1_12_0 + | cabalLibVersion < mkVersion [1, 14, 0] = flags_1_14_0 + | cabalLibVersion < mkVersion [1, 18, 0] = flags_1_18_0 + | cabalLibVersion < mkVersion [1, 19, 1] = flags_1_19_1 + | cabalLibVersion < mkVersion [1, 19, 2] = flags_1_19_2 + | cabalLibVersion < mkVersion [1, 21, 1] = flags_1_21_1 + | cabalLibVersion < mkVersion [1, 22, 0] = flags_1_22_0 + | cabalLibVersion < mkVersion [1, 22, 1] = flags_1_22_1 + | cabalLibVersion < mkVersion [1, 23, 0] = flags_1_23_0 + | cabalLibVersion < mkVersion [1, 25, 0] = flags_1_25_0 + | cabalLibVersion < mkVersion [2, 1, 0] = flags_2_1_0 + | 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 + | otherwise = error "the impossible just happened" -- see first guard + where + flags_latest = + flags + { -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'. + -- Note: this is not in the wrong place. configConstraints gets + -- repopulated in flags_1_19_1 but it needs to be set to empty for + -- newer versions first. + configConstraints = [] + } - projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout ctx) (takeFileName script) scriptContents + flags_3_11_0 = + flags_latest + { -- 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 + -- enabled, so this should never trigger. + configPromisedDependencies = assert (null $ configPromisedDependencies flags) [] + } - createDirectoryIfMissingVerbose verbosity True (distProjectCacheDirectory $ distDirLayout ctx) - (compiler, platform@(Platform arch os), _) <- runRebuild projectRoot $ configureCompiler verbosity (distDirLayout ctx) (fst (ignoreConditions projectCfgSkeleton) <> projectConfig ctx) + flags_3_7_0 = + flags_3_11_0 + { -- Cabal < 3.7 does not know about --extra-lib-dirs-static + configExtraLibDirsStatic = [] + , -- Cabal < 3.7 does not understand '--enable-build-info' or '--disable-build-info' + configDumpBuildInfo = NoFlag + } - projectCfg <- instantiateProjectConfigSkeletonFetchingCompiler (pure (os, arch, compilerInfo compiler)) mempty projectCfgSkeleton + flags_2_5_0 = + flags_3_7_0 + { -- Cabal < 2.5 does not understand --dependency=pkg:component=cid + -- (public sublibraries), so we convert it to the legacy + -- --dependency=pkg_or_internal_component=cid + configDependencies = + let convertToLegacyInternalDep (GivenComponent _ (LSubLibName cn) cid) = + Just $ + GivenComponent + (unqualComponentNameToPackageName cn) + LMainLibName + cid + convertToLegacyInternalDep (GivenComponent pn LMainLibName cid) = + Just $ GivenComponent pn LMainLibName cid + in catMaybes $ convertToLegacyInternalDep <$> configDependencies flags + , -- Cabal < 2.5 doesn't know about '--allow-depending-on-private-libs'. + configAllowDependingOnPrivateLibs = NoFlag + , -- Cabal < 2.5 doesn't know about '--enable/disable-executable-static'. + configFullyStaticExe = NoFlag + } - let ctx' = ctx & lProjectConfig %~ (<> projectCfg) + 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 + configStaticLib = NoFlag + , configSplitSections = NoFlag + } - build_dir = distBuildDirectory (distDirLayout ctx') $ (scriptDistDirParams script) ctx' compiler platform - exePath = build_dir "bin" scriptExeFileName script - exePathRel = makeRelative projectRoot exePath + flags_1_25_0 = + 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 + } + configInstallDirs_1_25_0 = + let dirs = configInstallDirs flags + in dirs + { dynlibdir = NoFlag + , libexecsubdir = NoFlag + , libexecdir = + maybeToFlag $ + combinePathTemplate + <$> flagToMaybe (libexecdir dirs) + <*> flagToMaybe (libexecsubdir dirs) + } + -- 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 + flags_1_23_0 = + flags_1_25_0 + { configProfDetail = NoFlag + , configProfLibDetail = NoFlag + , configIPID = NoFlag + , configProf = NoFlag + , configProfExe = Flag tryExeProfiling + , configProfLib = Flag tryLibProfiling + } - executable' = executable & L.buildInfo . L.defaultLanguage %~ maybe (Just Haskell2010) Just - & L.buildInfo . L.options %~ fmap (setExePath exePathRel) + -- Cabal == 1.22.0.* had a discontinuity (see #5946 or e9a8d48a3adce34d) + -- due to temporary amnesia of the --*-executable-profiling flags + flags_1_22_1 = + flags_1_23_0 + { configDebugInfo = NoFlag + , configProfExe = NoFlag + } - createDirectoryIfMissingVerbose verbosity True (takeDirectory exePath) + -- Cabal < 1.22 doesn't know about '--disable-debug-info'. + flags_1_22_0 = flags_1_23_0{configDebugInfo = NoFlag} - return (ScriptContext script executable', ctx', defaultTarget) - else reportTargetSelectorProblems verbosity err + -- Cabal < 1.21.1 doesn't know about 'disable-relocatable' + -- Cabal < 1.21.1 doesn't know about 'enable-profiling' + -- (but we already dealt with it in flags_1_23_0) + flags_1_21_1 = + flags_1_22_0 + { configRelocatable = NoFlag + , configCoverage = NoFlag + , configLibCoverage = configCoverage flags + } + -- Cabal < 1.19.2 doesn't know about '--exact-configuration' and + -- '--enable-library-stripping'. + flags_1_19_2 = + flags_1_21_1 + { configExactConfiguration = NoFlag + , configStripLibs = NoFlag + } + -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'. + flags_1_19_1 = + flags_1_19_2 + { configDependencies = [] + , configConstraints = configConstraints flags + } + -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir. + flags_1_18_0 = + flags_1_19_1 + { configProgramPathExtra = toNubList [] + , configInstallDirs = configInstallDirs_1_18_0 + } + configInstallDirs_1_18_0 = (configInstallDirs flags_1_19_1){sysconfdir = NoFlag} + -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'. + flags_1_14_0 = flags_1_18_0{configBenchmarks = NoFlag} + -- Cabal < 1.12.0 doesn't know about '--enable/disable-executable-dynamic' + -- and '--enable/disable-library-coverage'. + flags_1_12_0 = + flags_1_14_0 + { configLibCoverage = NoFlag + , configDynExe = NoFlag + } + -- Cabal < 1.10.0 doesn't know about '--disable-tests'. + flags_1_10_0 = flags_1_12_0{configTests = NoFlag} + -- Cabal < 1.3.10 does not grok the '--constraints' flag. + flags_1_3_10 = flags_1_10_0{configConstraints = []} -withTemporaryTempDirectory :: (IO FilePath -> IO a) -> IO a -withTemporaryTempDirectory act = newEmptyMVar >>= \m -> bracket (getMkTmp m) (rmTmp m) act +-- | Get the package database settings from 'ConfigFlags', accounting for +-- @--package-db@ and @--user@ flags. +configPackageDB' :: ConfigFlags -> PackageDBStack +configPackageDB' cfg = + interpretPackageDbFlags userInstall (configPackageDBs cfg) where - -- We return an (IO Filepath) instead of a FilePath for two reasons: - -- 1) To give the consumer the discretion to not create the tmpDir, - -- 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." - putMVar m tmpDir - return tmpDir - rmTmp m _ = tryTakeMVar m >>= maybe (return ()) (handleDoesNotExist () . removeDirectoryRecursive) - -scriptComponenetName :: IsString s => FilePath -> s -scriptComponenetName scriptPath = fromString cname + userInstall = Cabal.fromFlagOrDefault True (configUserInstall cfg) + +-- | Configure the compiler, but reduce verbosity during this step. +configCompilerAux' :: ConfigFlags -> IO (Compiler, Platform, ProgramDb) +configCompilerAux' configFlags = + configCompilerAuxEx + configFlags + { -- FIXME: make configCompilerAux use a sensible verbosity + configVerbosity = fmap lessVerbose (configVerbosity configFlags) + } + +-- ------------------------------------------------------------ + +-- * Config extra flags + +-- ------------------------------------------------------------ + +-- | cabal configure takes some extra flags beyond runghc Setup configure +data ConfigExFlags = ConfigExFlags + { configCabalVersion :: Flag Version + , configAppend :: Flag Bool + , configBackup :: Flag Bool + , configExConstraints :: [(UserConstraint, ConstraintSource)] + , configPreferences :: [PackageVersionConstraint] + , configSolver :: Flag PreSolver + , configAllowNewer :: Maybe AllowNewer + , configAllowOlder :: Maybe AllowOlder + , configWriteGhcEnvironmentFilesPolicy + :: Flag WriteGhcEnvironmentFilesPolicy + } + deriving (Eq, Show, Generic) + +defaultConfigExFlags :: ConfigExFlags +defaultConfigExFlags = mempty{configSolver = Flag defaultSolver} + +configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags) +configureExCommand = + configureCommand + { commandDefaultFlags = (mempty, defaultConfigExFlags) + , commandOptions = \showOrParseArgs -> + liftOptions + fst + setFst + ( filter + ( (`notElem` ["constraint", "dependency", "promised-dependency", "exact-configuration"]) + . optionName + ) + $ configureOptions showOrParseArgs + ) + ++ liftOptions + snd + setSnd + (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag) + } where - cname = "script-" ++ map censor (takeFileName scriptPath) - censor c | c `S.member` ccNamecore = c - | otherwise = '_' - -scriptExeFileName :: FilePath -> FilePath -scriptExeFileName scriptPath = "cabal-script-" ++ takeFileName scriptPath - -scriptDistDirParams :: FilePath -> ProjectBaseContext -> Compiler -> Platform -> DistDirParams -scriptDistDirParams scriptPath ctx compiler platform = DistDirParams - { distParamUnitId = newSimpleUnitId cid - , distParamPackageId = fakePackageId - , distParamComponentId = cid - , distParamComponentName = Just $ CExeName cn - , distParamCompilerId = compilerId compiler - , distParamPlatform = platform - , distParamOptimization = fromFlagOrDefault NormalOptimisation optimization + setFst a (_, b) = (a, b) + setSnd b (a, _) = (a, b) + +configureExOptions + :: ShowOrParseArgs + -> ConstraintSource + -> [OptionField ConfigExFlags] +configureExOptions _showOrParseArgs src = + [ option + [] + ["cabal-lib-version"] + ( "Select which version of the Cabal lib to use to build packages " + ++ "(useful for testing)." + ) + configCabalVersion + (\v flags -> flags{configCabalVersion = v}) + ( reqArg + "VERSION" + ( parsecToReadE + ("Cannot parse cabal lib version: " ++) + (fmap toFlag parsec) + ) + (map prettyShow . flagToList) + ) + , option + "" + ["append"] + "appending the new config to the old config file" + configAppend + (\v flags -> flags{configAppend = v}) + (boolOpt [] []) + , option + "" + ["backup"] + "the backup of the config file before any alterations" + configBackup + (\v flags -> flags{configBackup = v}) + (boolOpt [] []) + , option + "c" + ["constraint"] + "Specify constraints on a package (version, installed/source, flags)" + configExConstraints + (\v flags -> flags{configExConstraints = v}) + ( reqArg + "CONSTRAINT" + ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint) + (map $ prettyShow . fst) + ) + , option + [] + ["preference"] + "Specify preferences (soft constraints) on the version of a package" + configPreferences + (\v flags -> flags{configPreferences = v}) + ( reqArg + "CONSTRAINT" + ( parsecToReadE + (const "dependency expected") + (fmap (\x -> [x]) parsec) + ) + (map prettyShow) + ) + , optionSolver configSolver (\v flags -> flags{configSolver = v}) + , option + [] + ["allow-older"] + ("Ignore lower bounds in all dependencies or DEPS") + (fmap unAllowOlder . configAllowOlder) + (\v flags -> flags{configAllowOlder = fmap AllowOlder v}) + ( optArg + "DEPS" + (parsecToReadEErr unexpectMsgString relaxDepsParser) + (Just RelaxDepsAll) + relaxDepsPrinter + ) + , option + [] + ["allow-newer"] + ("Ignore upper bounds in all dependencies or DEPS") + (fmap unAllowNewer . configAllowNewer) + (\v flags -> flags{configAllowNewer = fmap AllowNewer v}) + ( optArg + "DEPS" + (parsecToReadEErr unexpectMsgString relaxDepsParser) + (Just RelaxDepsAll) + relaxDepsPrinter + ) + , option + [] + ["write-ghc-environment-files"] + ( "Whether to create a .ghc.environment file after a successful build" + ++ " (v2-build only)" + ) + configWriteGhcEnvironmentFilesPolicy + (\v flags -> flags{configWriteGhcEnvironmentFilesPolicy = v}) + ( reqArg + "always|never|ghc8.4.4+" + writeGhcEnvironmentFilesPolicyParser + writeGhcEnvironmentFilesPolicyPrinter + ) + ] + +writeGhcEnvironmentFilesPolicyParser :: ReadE (Flag WriteGhcEnvironmentFilesPolicy) +writeGhcEnvironmentFilesPolicyParser = ReadE $ \case + "always" -> Right $ Flag AlwaysWriteGhcEnvironmentFiles + "never" -> Right $ Flag NeverWriteGhcEnvironmentFiles + "ghc8.4.4+" -> Right $ Flag WriteGhcEnvironmentFilesOnlyForGhc844AndNewer + policy -> + Left $ + "Cannot parse the GHC environment file write policy '" + <> policy + <> "'" + +writeGhcEnvironmentFilesPolicyPrinter + :: Flag WriteGhcEnvironmentFilesPolicy -> [String] +writeGhcEnvironmentFilesPolicyPrinter = \case + (Flag AlwaysWriteGhcEnvironmentFiles) -> ["always"] + (Flag NeverWriteGhcEnvironmentFiles) -> ["never"] + (Flag WriteGhcEnvironmentFilesOnlyForGhc844AndNewer) -> ["ghc8.4.4+"] + NoFlag -> [] + +relaxDepsParser :: CabalParsing m => m (Maybe RelaxDeps) +relaxDepsParser = do + rs <- P.sepBy parsec (P.char ',') + if null rs + then + fail $ + "empty argument list is not allowed. " + ++ "Note: use --allow-newer without the equals sign to permit all " + ++ "packages to use newer versions." + else return . Just . RelaxDepsSome . toList $ rs + +relaxDepsPrinter :: (Maybe RelaxDeps) -> [Maybe String] +relaxDepsPrinter Nothing = [] +relaxDepsPrinter (Just RelaxDepsAll) = [Nothing] +relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . prettyShow) $ pkgs + +instance Monoid ConfigExFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup ConfigExFlags where + (<>) = gmappend + +reconfigureCommand :: CommandUI (ConfigFlags, ConfigExFlags) +reconfigureCommand = + configureExCommand + { commandName = "reconfigure" + , commandSynopsis = "Reconfigure the package if necessary." + , commandDescription = Just $ \pname -> + wrapText $ + "Run `configure` with the most recently used flags, or append FLAGS " + ++ "to the most recently used configuration. " + ++ "Accepts the same flags as `" + ++ pname + ++ " v1-configure'. " + ++ "If the package has never been configured, the default flags are " + ++ "used." + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " + ++ pname + ++ " v1-reconfigure\n" + ++ " Configure with the most recently used flags.\n" + ++ " " + ++ pname + ++ " v1-reconfigure -w PATH\n" + ++ " Reconfigure with the most recently used flags,\n" + ++ " but use the compiler at PATH.\n\n" + , commandUsage = usageAlternatives "v1-reconfigure" ["[FLAGS]"] + , commandDefaultFlags = mempty + } + +-- ------------------------------------------------------------ + +-- * Build flags + +-- ------------------------------------------------------------ + +buildCommand :: CommandUI BuildFlags +buildCommand = + parent + { commandName = "build" + , commandDescription = Just $ \_ -> + wrapText $ + "Components encompass executables, tests, and benchmarks.\n" + ++ "\n" + ++ "Affected by configuration options, see `v1-configure`.\n" + , commandDefaultFlags = commandDefaultFlags parent + , commandUsage = + usageAlternatives "v1-build" $ + ["[FLAGS]", "COMPONENTS [FLAGS]"] + , commandOptions = commandOptions parent + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " + ++ pname + ++ " v1-build " + ++ " All the components in the package\n" + ++ " " + ++ pname + ++ " v1-build foo " + ++ " A component (i.e. lib, exe, test suite)\n\n" + ++ Cabal.programFlagsDescription defaultProgramDb + } + where + parent = Cabal.buildCommand defaultProgramDb + +-- ------------------------------------------------------------ + +-- * Test flags + +-- ------------------------------------------------------------ + +-- | Given some 'TestFlags' 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 +-- flags into a form that will be accepted by the older +-- Setup script. Generally speaking, this just means filtering +-- out flags that the old Cabal library doesn't understand, but +-- in some cases it may also mean "emulating" a feature using +-- some more legacy flags. +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 + -- 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 + -- these flags work for; version of introduction is a more + -- natural metric. + | cabalLibVersion < mkVersion [3, 0, 0] = flags_3_0_0 + | otherwise = error "the impossible just happened" -- see first guard + where + flags_latest = flags + flags_3_0_0 = + flags_latest + { -- Cabal < 3.0 doesn't know about --test-wrapper + Cabal.testWrapper = NoFlag + } + +-- ------------------------------------------------------------ + +-- * Repl command + +-- ------------------------------------------------------------ + +replCommand :: CommandUI ReplFlags +replCommand = + parent + { commandName = "repl" + , commandDescription = Just $ \pname -> + wrapText $ + "If the current directory contains no package, ignores COMPONENT " + ++ "parameters and opens an interactive interpreter session;\n" + ++ "\n" + ++ "Otherwise, (re)configures with the given or default flags, and " + ++ "loads the interpreter with the relevant modules. For executables, " + ++ "tests and benchmarks, loads the main module (and its " + ++ "dependencies); for libraries all exposed/other modules.\n" + ++ "\n" + ++ "The default component is the library itself, or the executable " + ++ "if that is the only component.\n" + ++ "\n" + ++ "Support for loading specific modules is planned but not " + ++ "implemented yet. For certain scenarios, `" + ++ pname + ++ " v1-exec -- ghci :l Foo` may be used instead. Note that `v1-exec` will " + ++ "not (re)configure and you will have to specify the location of " + ++ "other modules, if required.\n" + , commandUsage = \pname -> "Usage: " ++ pname ++ " v1-repl [COMPONENT] [FLAGS]\n" + , commandDefaultFlags = commandDefaultFlags parent + , commandOptions = commandOptions parent + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " + ++ pname + ++ " v1-repl " + ++ " The first component in the package\n" + ++ " " + ++ pname + ++ " v1-repl foo " + ++ " A named component (i.e. lib, exe, test suite)\n" + ++ " " + ++ pname + ++ " v1-repl --ghc-options=\"-lstdc++\"" + ++ " Specifying flags for interpreter\n" + } + where + parent = Cabal.replCommand defaultProgramDb + +-- ------------------------------------------------------------ + +-- * Test command + +-- ------------------------------------------------------------ + +testCommand :: CommandUI (BuildFlags, TestFlags) +testCommand = + parent + { commandName = "test" + , commandDescription = Just $ \pname -> + wrapText $ + "If necessary (re)configures with `--enable-tests` flag and builds" + ++ " the test suite.\n" + ++ "\n" + ++ "Remember that the tests' dependencies must be installed if there" + ++ " are additional ones; e.g. with `" + ++ pname + ++ " v1-install --only-dependencies --enable-tests`.\n" + ++ "\n" + ++ "By defining UserHooks in a custom Setup.hs, the package can" + ++ " define actions to be executed before and after running tests.\n" + , commandUsage = + usageAlternatives + "v1-test" + ["[FLAGS]", "TESTCOMPONENTS [FLAGS]"] + , commandDefaultFlags = (Cabal.defaultBuildFlags, commandDefaultFlags parent) + , commandOptions = + \showOrParseArgs -> + liftOptions + get1 + set1 + (Cabal.buildOptions progDb showOrParseArgs) + ++ liftOptions + get2 + set2 + (commandOptions parent showOrParseArgs) + } + where + get1 (a, _) = a + set1 a (_, b) = (a, b) + get2 (_, b) = b + set2 b (a, _) = (a, b) + + parent = Cabal.testCommand + progDb = defaultProgramDb + +-- ------------------------------------------------------------ + +-- * Bench command + +-- ------------------------------------------------------------ + +benchmarkCommand :: CommandUI (BuildFlags, BenchmarkFlags) +benchmarkCommand = + parent + { commandName = "bench" + , commandUsage = + usageAlternatives + "v1-bench" + ["[FLAGS]", "BENCHCOMPONENTS [FLAGS]"] + , commandDescription = Just $ \pname -> + wrapText $ + "If necessary (re)configures with `--enable-benchmarks` flag and" + ++ " builds the benchmarks.\n" + ++ "\n" + ++ "Remember that the benchmarks' dependencies must be installed if" + ++ " there are additional ones; e.g. with `" + ++ pname + ++ " v1-install --only-dependencies --enable-benchmarks`.\n" + ++ "\n" + ++ "By defining UserHooks in a custom Setup.hs, the package can" + ++ " define actions to be executed before and after running" + ++ " benchmarks.\n" + , commandDefaultFlags = (Cabal.defaultBuildFlags, commandDefaultFlags parent) + , commandOptions = + \showOrParseArgs -> + liftOptions + get1 + set1 + (Cabal.buildOptions progDb showOrParseArgs) + ++ liftOptions + get2 + set2 + (commandOptions parent showOrParseArgs) + } + where + get1 (a, _) = a + set1 a (_, b) = (a, b) + get2 (_, b) = b + set2 b (a, _) = (a, b) + + parent = Cabal.benchmarkCommand + progDb = defaultProgramDb + +-- ------------------------------------------------------------ + +-- * Fetch command + +-- ------------------------------------------------------------ + +data FetchFlags = FetchFlags + { -- fetchOutput :: Flag FilePath, + fetchDeps :: Flag Bool + , fetchDryRun :: Flag Bool + , fetchSolver :: Flag PreSolver + , fetchMaxBackjumps :: Flag Int + , fetchReorderGoals :: Flag ReorderGoals + , fetchCountConflicts :: Flag CountConflicts + , fetchFineGrainedConflicts :: Flag FineGrainedConflicts + , fetchMinimizeConflictSet :: Flag MinimizeConflictSet + , fetchIndependentGoals :: Flag IndependentGoals + , fetchPreferOldest :: Flag PreferOldest + , fetchShadowPkgs :: Flag ShadowPkgs + , fetchStrongFlags :: Flag StrongFlags + , fetchAllowBootLibInstalls :: Flag AllowBootLibInstalls + , fetchOnlyConstrained :: Flag OnlyConstrained + , fetchTests :: Flag Bool + , fetchBenchmarks :: Flag Bool + , fetchVerbosity :: Flag Verbosity + } + +defaultFetchFlags :: FetchFlags +defaultFetchFlags = + FetchFlags + { -- fetchOutput = mempty, + fetchDeps = toFlag True + , fetchDryRun = toFlag False + , fetchSolver = Flag defaultSolver + , fetchMaxBackjumps = Flag defaultMaxBackjumps + , fetchReorderGoals = Flag (ReorderGoals False) + , fetchCountConflicts = Flag (CountConflicts True) + , fetchFineGrainedConflicts = Flag (FineGrainedConflicts True) + , fetchMinimizeConflictSet = Flag (MinimizeConflictSet False) + , fetchIndependentGoals = Flag (IndependentGoals False) + , fetchPreferOldest = Flag (PreferOldest False) + , fetchShadowPkgs = Flag (ShadowPkgs False) + , fetchStrongFlags = Flag (StrongFlags False) + , fetchAllowBootLibInstalls = Flag (AllowBootLibInstalls False) + , fetchOnlyConstrained = Flag OnlyConstrainedNone + , fetchTests = toFlag False + , fetchBenchmarks = toFlag False + , fetchVerbosity = toFlag normal + } + +fetchCommand :: CommandUI FetchFlags +fetchCommand = + CommandUI + { commandName = "fetch" + , commandSynopsis = "Downloads packages for later installation." + , commandUsage = + usageAlternatives + "fetch" + [ "[FLAGS] PACKAGES" + ] + , commandDescription = Just $ \_ -> + "Note that it currently is not possible to fetch the dependencies for a\n" + ++ "package in the current directory.\n" + , commandNotes = Nothing + , commandDefaultFlags = defaultFetchFlags + , commandOptions = \showOrParseArgs -> + [ optionVerbosity fetchVerbosity (\v flags -> flags{fetchVerbosity = v}) + , -- , option "o" ["output"] + -- "Put the package(s) somewhere specific rather than the usual cache." + -- fetchOutput (\v flags -> flags { fetchOutput = v }) + -- (reqArgFlag "PATH") + + option + [] + ["dependencies", "deps"] + "Resolve and fetch dependencies (default)" + fetchDeps + (\v flags -> flags{fetchDeps = v}) + trueArg + , option + [] + ["no-dependencies", "no-deps"] + "Ignore dependencies" + fetchDeps + (\v flags -> flags{fetchDeps = v}) + falseArg + , option + [] + ["dry-run"] + "Do not install anything, only print what would be installed." + fetchDryRun + (\v flags -> flags{fetchDryRun = v}) + trueArg + , option + "" + ["tests"] + "dependency checking and compilation for test suites listed in the package description file." + fetchTests + (\v flags -> flags{fetchTests = v}) + (boolOpt [] []) + , option + "" + ["benchmarks"] + "dependency checking and compilation for benchmarks listed in the package description file." + fetchBenchmarks + (\v flags -> flags{fetchBenchmarks = v}) + (boolOpt [] []) + ] + ++ optionSolver fetchSolver (\v flags -> flags{fetchSolver = v}) + : optionSolverFlags + showOrParseArgs + fetchMaxBackjumps + (\v flags -> flags{fetchMaxBackjumps = v}) + fetchReorderGoals + (\v flags -> flags{fetchReorderGoals = v}) + fetchCountConflicts + (\v flags -> flags{fetchCountConflicts = v}) + fetchFineGrainedConflicts + (\v flags -> flags{fetchFineGrainedConflicts = v}) + fetchMinimizeConflictSet + (\v flags -> flags{fetchMinimizeConflictSet = v}) + fetchIndependentGoals + (\v flags -> flags{fetchIndependentGoals = v}) + fetchPreferOldest + (\v flags -> flags{fetchPreferOldest = v}) + fetchShadowPkgs + (\v flags -> flags{fetchShadowPkgs = v}) + fetchStrongFlags + (\v flags -> flags{fetchStrongFlags = v}) + fetchAllowBootLibInstalls + (\v flags -> flags{fetchAllowBootLibInstalls = v}) + fetchOnlyConstrained + (\v flags -> flags{fetchOnlyConstrained = v}) + } + +-- ------------------------------------------------------------ + +-- * Freeze command + +-- ------------------------------------------------------------ + +data FreezeFlags = FreezeFlags + { freezeDryRun :: Flag Bool + , freezeTests :: Flag Bool + , freezeBenchmarks :: Flag Bool + , freezeSolver :: Flag PreSolver + , freezeMaxBackjumps :: Flag Int + , freezeReorderGoals :: Flag ReorderGoals + , freezeCountConflicts :: Flag CountConflicts + , freezeFineGrainedConflicts :: Flag FineGrainedConflicts + , freezeMinimizeConflictSet :: Flag MinimizeConflictSet + , freezeIndependentGoals :: Flag IndependentGoals + , freezePreferOldest :: Flag PreferOldest + , freezeShadowPkgs :: Flag ShadowPkgs + , freezeStrongFlags :: Flag StrongFlags + , freezeAllowBootLibInstalls :: Flag AllowBootLibInstalls + , freezeOnlyConstrained :: Flag OnlyConstrained + , freezeVerbosity :: Flag Verbosity } + +defaultFreezeFlags :: FreezeFlags +defaultFreezeFlags = + FreezeFlags + { freezeDryRun = toFlag False + , freezeTests = toFlag False + , freezeBenchmarks = toFlag False + , freezeSolver = Flag defaultSolver + , freezeMaxBackjumps = Flag defaultMaxBackjumps + , freezeReorderGoals = Flag (ReorderGoals False) + , freezeCountConflicts = Flag (CountConflicts True) + , freezeFineGrainedConflicts = Flag (FineGrainedConflicts True) + , freezeMinimizeConflictSet = Flag (MinimizeConflictSet False) + , freezeIndependentGoals = Flag (IndependentGoals False) + , freezePreferOldest = Flag (PreferOldest False) + , freezeShadowPkgs = Flag (ShadowPkgs False) + , freezeStrongFlags = Flag (StrongFlags False) + , freezeAllowBootLibInstalls = Flag (AllowBootLibInstalls False) + , freezeOnlyConstrained = Flag OnlyConstrainedNone + , freezeVerbosity = toFlag normal + } + +freezeCommand :: CommandUI FreezeFlags +freezeCommand = + CommandUI + { commandName = "freeze" + , commandSynopsis = "Freeze dependencies." + , commandDescription = Just $ \_ -> + wrapText $ + "Calculates a valid set of dependencies and their exact versions. " + ++ "If successful, saves the result to the file `cabal.config`.\n" + ++ "\n" + ++ "The package versions specified in `cabal.config` will be used for " + ++ "any future installs.\n" + ++ "\n" + ++ "An existing `cabal.config` is ignored and overwritten.\n" + , commandNotes = Nothing + , commandUsage = usageFlags "freeze" + , commandDefaultFlags = defaultFreezeFlags + , commandOptions = \showOrParseArgs -> + [ optionVerbosity + freezeVerbosity + (\v flags -> flags{freezeVerbosity = v}) + , option + [] + ["dry-run"] + "Do not freeze anything, only print what would be frozen" + freezeDryRun + (\v flags -> flags{freezeDryRun = v}) + trueArg + , option + [] + ["tests"] + ( "freezing of the dependencies of any tests suites " + ++ "in the package description file." + ) + freezeTests + (\v flags -> flags{freezeTests = v}) + (boolOpt [] []) + , option + [] + ["benchmarks"] + ( "freezing of the dependencies of any benchmarks suites " + ++ "in the package description file." + ) + freezeBenchmarks + (\v flags -> flags{freezeBenchmarks = v}) + (boolOpt [] []) + ] + ++ optionSolver + freezeSolver + (\v flags -> flags{freezeSolver = v}) + : optionSolverFlags + showOrParseArgs + freezeMaxBackjumps + (\v flags -> flags{freezeMaxBackjumps = v}) + freezeReorderGoals + (\v flags -> flags{freezeReorderGoals = v}) + freezeCountConflicts + (\v flags -> flags{freezeCountConflicts = v}) + freezeFineGrainedConflicts + (\v flags -> flags{freezeFineGrainedConflicts = v}) + freezeMinimizeConflictSet + (\v flags -> flags{freezeMinimizeConflictSet = v}) + freezeIndependentGoals + (\v flags -> flags{freezeIndependentGoals = v}) + freezePreferOldest + (\v flags -> flags{freezePreferOldest = v}) + freezeShadowPkgs + (\v flags -> flags{freezeShadowPkgs = v}) + freezeStrongFlags + (\v flags -> flags{freezeStrongFlags = v}) + freezeAllowBootLibInstalls + (\v flags -> flags{freezeAllowBootLibInstalls = v}) + freezeOnlyConstrained + (\v flags -> flags{freezeOnlyConstrained = v}) + } + +-- ------------------------------------------------------------ + +-- * 'gen-bounds' command + +-- ------------------------------------------------------------ + +genBoundsCommand :: CommandUI FreezeFlags +genBoundsCommand = + CommandUI + { commandName = "gen-bounds" + , commandSynopsis = "Generate dependency bounds." + , commandDescription = Just $ \_ -> + wrapText $ + "Generates bounds for all dependencies that do not currently have them. " + ++ "Generated bounds are printed to stdout. " + ++ "You can then paste them into your .cabal file.\n" + ++ "\n" + , commandNotes = Nothing + , commandUsage = usageFlags "gen-bounds" + , commandDefaultFlags = defaultFreezeFlags + , commandOptions = \_ -> + [ optionVerbosity freezeVerbosity (\v flags -> flags{freezeVerbosity = v}) + ] + } + +-- ------------------------------------------------------------ + +-- * Update command + +-- ------------------------------------------------------------ + +data UpdateFlags = UpdateFlags + { updateVerbosity :: Flag Verbosity + , updateIndexState :: Flag TotalIndexState + } + deriving (Generic) + +defaultUpdateFlags :: UpdateFlags +defaultUpdateFlags = + UpdateFlags + { updateVerbosity = toFlag normal + , updateIndexState = toFlag headTotalIndexState + } + +-- ------------------------------------------------------------ + +-- * Other commands + +-- ------------------------------------------------------------ + +cleanCommand :: CommandUI CleanFlags +cleanCommand = + Cabal.cleanCommand + { commandUsage = \pname -> + "Usage: " ++ pname ++ " v1-clean [FLAGS]\n" + } + +checkCommand :: CommandUI (Flag Verbosity) +checkCommand = + CommandUI + { commandName = "check" + , commandSynopsis = "Check the package for common mistakes." + , commandDescription = Just $ \_ -> + wrapText $ + "Expects a .cabal package file in the current directory.\n" + ++ "\n" + ++ "Some checks correspond to the requirements to packages on Hackage. " + ++ "If no `Error` is reported, Hackage should accept the " + ++ "package. If errors are present, `check` exits with 1 and Hackage " + ++ "will refuse the package.\n" + , commandNotes = Nothing + , commandUsage = usageFlags "check" + , commandDefaultFlags = toFlag normal + , commandOptions = \_ -> [optionVerbosity id const] + } + +formatCommand :: CommandUI (Flag Verbosity) +formatCommand = + CommandUI + { commandName = "format" + , commandSynopsis = "Reformat the .cabal file using the standard style." + , commandDescription = Nothing + , commandNotes = Nothing + , commandUsage = usageAlternatives "format" ["[FILE]"] + , commandDefaultFlags = toFlag normal + , commandOptions = \_ -> [] + } + +manpageCommand :: CommandUI ManpageFlags +manpageCommand = + CommandUI + { commandName = "man" + , commandSynopsis = "Outputs manpage source." + , commandDescription = Just $ \_ -> + "Output manpage source to STDOUT.\n" + , commandNotes = Nothing + , commandUsage = usageFlags "man" + , commandDefaultFlags = defaultManpageFlags + , commandOptions = manpageOptions + } + +runCommand :: CommandUI BuildFlags +runCommand = + CommandUI + { commandName = "run" + , commandSynopsis = "Builds and runs an executable." + , commandDescription = Just $ \pname -> + wrapText $ + "Builds and then runs the specified executable. If no executable is " + ++ "specified, but the package contains just one executable, that one " + ++ "is built and executed.\n" + ++ "\n" + ++ "Use `" + ++ pname + ++ " v1-test --show-details=streaming` to run a " + ++ "test-suite and get its full output.\n" + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " + ++ pname + ++ " v1-run\n" + ++ " Run the only executable in the current package;\n" + ++ " " + ++ pname + ++ " v1-run foo -- --fooflag\n" + ++ " Works similar to `./foo --fooflag`.\n" + , commandUsage = + usageAlternatives + "v1-run" + ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"] + , commandDefaultFlags = mempty + , commandOptions = commandOptions parent + } where - cn = scriptComponenetName scriptPath - cid = mkComponentId $ prettyShow fakePackageId <> "-inplace-" <> prettyShow cn - optimization = (packageConfigOptimization . projectConfigLocalPackages . projectConfig) ctx - -setExePath :: FilePath -> [String] -> [String] -setExePath exePath options - | "-o" `notElem` options = "-o" : exePath : options - | otherwise = options - --- | Add the 'SourcePackage' to the context and use it to write a .cabal file. -updateContextAndWriteProjectFile' :: ProjectBaseContext -> SourcePackage (PackageLocation (Maybe FilePath)) -> IO ProjectBaseContext -updateContextAndWriteProjectFile' ctx srcPkg = do - let projectRoot = distProjectRootDirectory $ distDirLayout ctx - packageFile = projectRoot fakePackageCabalFileName - contents = showGenericPackageDescription (srcpkgDescription srcPkg) - writePackageFile = writeUTF8File packageFile contents - -- TODO This is here to prevent reconfiguration of cached repl packages. - -- It's worth investigating why it's needed in the first place. - packageFileExists <- doesFileExist packageFile - if packageFileExists then do - cached <- force <$> readUTF8File packageFile - when (cached /= contents) - writePackageFile - else writePackageFile - return (ctx & lLocalPackages %~ (++ [SpecificSourcePackage srcPkg])) - --- | Add 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 - let - sourcePackage = fakeProjectSourcePackage projectRoot - & lSrcpkgDescription . L.condExecutables - .~ [(scriptComponenetName scriptPath, CondNode executable (targetBuildDepends $ buildInfo executable) [])] - executable = scriptExecutable - & L.modulePath .~ absScript - - updateContextAndWriteProjectFile' ctx sourcePackage - -parseScriptBlock :: BS.ByteString -> ParseResult Executable -parseScriptBlock str = - case readFields str of - Right fs -> do - let (fields, _) = takeFields fs - parseFieldGrammar cabalSpecLatest fields (executableFieldGrammar "script") - Left perr -> parseFatalFailure pos (show perr) where - ppos = P.errorPos perr - pos = Position (P.sourceLine ppos) (P.sourceColumn ppos) - -readScriptBlock :: Verbosity -> BS.ByteString -> IO Executable -readScriptBlock verbosity = parseString parseScriptBlock verbosity "script block" - --- | Extract the first encountered executable metadata block started and --- terminated by the below tokens or die. --- --- * @{- cabal:@ --- --- * @-}@ --- --- Return the metadata. -readExecutableBlockFromScript :: Verbosity -> BS.ByteString -> IO Executable -readExecutableBlockFromScript verbosity str = do - str' <- case extractScriptBlock "cabal" str of - Left e -> die' verbosity $ "Failed extracting script block: " ++ e - Right x -> return x - when (BS.all isSpace str') $ warn verbosity "Empty script block" - readScriptBlock verbosity str' - --- | Extract the first encountered project metadata block started and --- terminated by the below tokens. --- --- * @{- project:@ --- --- * @-}@ --- --- Return the metadata. -readProjectBlockFromScript :: Verbosity -> HttpTransport -> DistDirLayout -> String -> BS.ByteString -> IO ProjectConfigSkeleton -readProjectBlockFromScript verbosity httpTransport DistDirLayout{distDownloadSrcDirectory} scriptName str = do - case extractScriptBlock "project" str of - Left _ -> return mempty - Right x -> reportParseResult verbosity "script" scriptName - =<< parseProjectSkeleton distDownloadSrcDirectory httpTransport verbosity [] scriptName x - --- | Extract the first encountered script metadata block started end --- terminated by the tokens --- --- * @{-
:@ --- --- * @-}@ --- --- appearing alone on lines (while tolerating trailing whitespace). --- These tokens are not part of the 'Right' result. --- --- In case of missing or unterminated blocks a 'Left'-error is --- returned. -extractScriptBlock :: BS.ByteString -> BS.ByteString -> Either String BS.ByteString -extractScriptBlock header str = goPre (BS.lines str) + parent = Cabal.buildCommand defaultProgramDb + +-- ------------------------------------------------------------ + +-- * Report flags + +-- ------------------------------------------------------------ + +data ReportFlags = ReportFlags + { reportUsername :: Flag Username + , reportPassword :: Flag Password + , reportVerbosity :: Flag Verbosity + } + deriving (Generic) + +defaultReportFlags :: ReportFlags +defaultReportFlags = + ReportFlags + { reportUsername = mempty + , reportPassword = mempty + , reportVerbosity = toFlag normal + } + +reportCommand :: CommandUI ReportFlags +reportCommand = + CommandUI + { commandName = "report" + , commandSynopsis = "Upload build reports to a remote server." + , commandDescription = Nothing + , commandNotes = Just $ \_ -> + "You can store your Hackage login in the ~/.config/cabal/config file\n" + , commandUsage = usageAlternatives "report" ["[FLAGS]"] + , commandDefaultFlags = defaultReportFlags + , commandOptions = \_ -> + [ optionVerbosity reportVerbosity (\v flags -> flags{reportVerbosity = v}) + , option + ['u'] + ["username"] + "Hackage username." + reportUsername + (\v flags -> flags{reportUsername = v}) + ( reqArg' + "USERNAME" + (toFlag . Username) + (flagToList . fmap unUsername) + ) + , option + ['p'] + ["password"] + "Hackage password." + reportPassword + (\v flags -> flags{reportPassword = v}) + ( reqArg' + "PASSWORD" + (toFlag . Password) + (flagToList . fmap unPassword) + ) + ] + } + +instance Monoid ReportFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup ReportFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ + +-- * Get flags + +-- ------------------------------------------------------------ + +data GetFlags = GetFlags + { getDestDir :: Flag FilePath + , getOnlyPkgDescr :: Flag Bool + , getPristine :: Flag Bool + , getIndexState :: Flag TotalIndexState + , getActiveRepos :: Flag ActiveRepos + , getSourceRepository :: Flag (Maybe RepoKind) + , getVerbosity :: Flag Verbosity + } + deriving (Generic) + +defaultGetFlags :: GetFlags +defaultGetFlags = + GetFlags + { getDestDir = mempty + , getOnlyPkgDescr = mempty + , getPristine = mempty + , getIndexState = mempty + , getActiveRepos = mempty + , getSourceRepository = mempty + , getVerbosity = toFlag normal + } + +getCommand :: CommandUI GetFlags +getCommand = + CommandUI + { commandName = "get" + , commandSynopsis = "Download/Extract a package's source code (repository)." + , commandDescription = Just $ \_ -> wrapText $ unlines descriptionOfGetCommand + , commandNotes = Just $ \pname -> unlines $ notesOfGetCommand "get" pname + , commandUsage = usagePackages "get" + , commandDefaultFlags = defaultGetFlags + , commandOptions = \_ -> + [ optionVerbosity getVerbosity (\v flags -> flags{getVerbosity = v}) + , option + "d" + ["destdir"] + "Where to place the package source, defaults to the current directory." + getDestDir + (\v flags -> flags{getDestDir = v}) + (reqArgFlag "PATH") + , option + "s" + ["source-repository"] + "Copy the package's source repository (ie git clone, darcs get, etc as appropriate)." + getSourceRepository + (\v flags -> flags{getSourceRepository = v}) + ( optArg + "[head|this|...]" + ( parsecToReadE + (const "invalid source-repository") + (fmap (toFlag . Just) parsec) + ) + (Flag Nothing) + (map (fmap show) . flagToList) + ) + , option + [] + ["index-state"] + ( "Use source package index state as it existed at a previous time. " + ++ "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " + ++ "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD'). " + ++ "This determines which package versions are available as well as " + ++ ".cabal file revision is selected (unless --pristine is used)." + ) + getIndexState + (\v flags -> flags{getIndexState = v}) + ( reqArg + "STATE" + ( parsecToReadE + ( const $ + "index-state must be a " + ++ "unix-timestamps (e.g. '@1474732068'), " + ++ "a ISO8601 UTC timestamp " + ++ "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'" + ) + (toFlag `fmap` parsec) + ) + (flagToList . fmap prettyShow) + ) + , option + [] + ["only-package-description"] + "Unpack only the package description file." + getOnlyPkgDescr + (\v flags -> flags{getOnlyPkgDescr = v}) + trueArg + , option + [] + ["package-description-only"] + "A synonym for --only-package-description." + getOnlyPkgDescr + (\v flags -> flags{getOnlyPkgDescr = v}) + trueArg + , option + [] + ["pristine"] + ( "Unpack the original pristine tarball, rather than updating the " + ++ ".cabal file with the latest revision from the package archive." + ) + getPristine + (\v flags -> flags{getPristine = v}) + trueArg + ] + } + +-- | List of lines describing command @get@. +descriptionOfGetCommand :: [String] +descriptionOfGetCommand = + [ "Creates a local copy of a package's source code. By default it gets the source" + , "tarball and unpacks it in a local subdirectory. Alternatively, with -s it will" + , "get the code from the source repository specified by the package." + ] + +-- | Notes for the command @get@. +notesOfGetCommand + :: String + -- ^ Either @"get"@ or @"unpack"@. + -> String + -- ^ E.g. @"cabal"@. + -> [String] + -- ^ List of lines. +notesOfGetCommand cmd pname = + [ "Examples:" + , " " ++ unwords [pname, cmd, "hlint"] + , " Download the latest stable version of hlint;" + , " " ++ unwords [pname, cmd, "lens --source-repository=head"] + , " Download the source repository of lens (i.e. git clone from github)." + ] + +-- 'cabal unpack' is a deprecated alias for 'cabal get'. +unpackCommand :: CommandUI GetFlags +unpackCommand = + getCommand + { commandName = "unpack" + , commandSynopsis = synopsis + , commandNotes = Just $ \pname -> + unlines $ + notesOfGetCommand "unpack" pname + , commandUsage = usagePackages "unpack" + } + where + synopsis = "Deprecated alias for 'get'." + +instance Monoid GetFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup GetFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ + +-- * List flags + +-- ------------------------------------------------------------ + +data ListFlags = ListFlags + { listInstalled :: Flag Bool + , listSimpleOutput :: Flag Bool + , listCaseInsensitive :: Flag Bool + , listVerbosity :: Flag Verbosity + , listPackageDBs :: [Maybe PackageDB] + , listHcPath :: Flag FilePath + } + deriving (Generic) + +defaultListFlags :: ListFlags +defaultListFlags = + ListFlags + { listInstalled = Flag False + , listSimpleOutput = Flag False + , listCaseInsensitive = Flag True + , listVerbosity = toFlag normal + , listPackageDBs = [] + , listHcPath = mempty + } + +listCommand :: CommandUI ListFlags +listCommand = + CommandUI + { commandName = "list" + , commandSynopsis = "List packages matching a search string." + , commandDescription = Just $ \_ -> + wrapText $ + "List all packages, or all packages matching one of the search" + ++ " strings.\n" + ++ "\n" + ++ "Use the package database specified with --package-db. " + ++ "If not specified, use the user package database.\n" + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " + ++ pname + ++ " list pandoc\n" + ++ " Will find pandoc, pandoc-citeproc, pandoc-lens, ...\n" + , commandUsage = + usageAlternatives + "list" + [ "[FLAGS]" + , "[FLAGS] STRINGS" + ] + , commandDefaultFlags = defaultListFlags + , commandOptions = const listOptions + } + +listOptions :: [OptionField ListFlags] +listOptions = + [ optionVerbosity listVerbosity (\v flags -> flags{listVerbosity = v}) + , option + [] + ["installed"] + "Only print installed packages" + listInstalled + (\v flags -> flags{listInstalled = v}) + trueArg + , option + [] + ["simple-output"] + "Print in a easy-to-parse format" + listSimpleOutput + (\v flags -> flags{listSimpleOutput = v}) + trueArg + , option + ['i'] + ["ignore-case"] + "Ignore case distinctions" + listCaseInsensitive + (\v flags -> flags{listCaseInsensitive = v}) + (boolOpt' (['i'], ["ignore-case"]) (['I'], ["strict-case"])) + , option + "" + ["package-db"] + ( "Append the given package database to the list of package" + ++ " databases used (to satisfy dependencies and register into)." + ++ " May be a specific file, 'global' or 'user'. The initial list" + ++ " is ['global'], ['global', 'user']," + ++ " depending on context. Use 'clear' to reset the list to empty." + ++ " See the user guide for details." + ) + listPackageDBs + (\v flags -> flags{listPackageDBs = v}) + (reqArg' "DB" readPackageDbList showPackageDbList) + , option + "w" + ["with-compiler"] + "give the path to a particular compiler" + listHcPath + (\v flags -> flags{listHcPath = v}) + (reqArgFlag "PATH") + ] + +listNeedsCompiler :: ListFlags -> Bool +listNeedsCompiler f = + flagElim False (const True) (listHcPath f) + || fromFlagOrDefault False (listInstalled f) + +instance Monoid ListFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup ListFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ + +-- * Info flags + +-- ------------------------------------------------------------ + +data InfoFlags = InfoFlags + { infoVerbosity :: Flag Verbosity + , infoPackageDBs :: [Maybe PackageDB] + } + deriving (Generic) + +defaultInfoFlags :: InfoFlags +defaultInfoFlags = + InfoFlags + { infoVerbosity = toFlag normal + , infoPackageDBs = [] + } + +infoCommand :: CommandUI InfoFlags +infoCommand = + CommandUI + { commandName = "info" + , commandSynopsis = "Display detailed information about a particular package." + , commandDescription = Just $ \_ -> + wrapText $ + "Use the package database specified with --package-db. " + ++ "If not specified, use the user package database.\n" + , commandNotes = Nothing + , commandUsage = usageAlternatives "info" ["[FLAGS] PACKAGES"] + , commandDefaultFlags = defaultInfoFlags + , commandOptions = \_ -> + [ optionVerbosity infoVerbosity (\v flags -> flags{infoVerbosity = v}) + , option + "" + ["package-db"] + ( "Append the given package database to the list of package" + ++ " databases used (to satisfy dependencies and register into)." + ++ " May be a specific file, 'global' or 'user'. The initial list" + ++ " is ['global'], ['global', 'user']," + ++ " depending on context. Use 'clear' to reset the list to empty." + ++ " See the user guide for details." + ) + infoPackageDBs + (\v flags -> flags{infoPackageDBs = v}) + (reqArg' "DB" readPackageDbList showPackageDbList) + ] + } + +instance Monoid InfoFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup InfoFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ + +-- * Install flags + +-- ------------------------------------------------------------ + +-- | Install takes the same flags as configure along with a few extras. +data InstallFlags = InstallFlags + { installDocumentation :: Flag Bool + , installHaddockIndex :: Flag PathTemplate + , installDest :: Flag Cabal.CopyDest + , installDryRun :: Flag Bool + , installOnlyDownload :: Flag Bool + , installMaxBackjumps :: Flag Int + , installReorderGoals :: Flag ReorderGoals + , installCountConflicts :: Flag CountConflicts + , installFineGrainedConflicts :: Flag FineGrainedConflicts + , installMinimizeConflictSet :: Flag MinimizeConflictSet + , installIndependentGoals :: Flag IndependentGoals + , installPreferOldest :: Flag PreferOldest + , installShadowPkgs :: Flag ShadowPkgs + , installStrongFlags :: Flag StrongFlags + , installAllowBootLibInstalls :: Flag AllowBootLibInstalls + , installOnlyConstrained :: Flag OnlyConstrained + , installReinstall :: Flag Bool + , installAvoidReinstalls :: Flag AvoidReinstalls + , installOverrideReinstall :: Flag Bool + , installUpgradeDeps :: Flag Bool + , installOnly :: Flag Bool + , installOnlyDeps :: Flag Bool + , installIndexState :: Flag TotalIndexState + , installRootCmd :: Flag String + , installSummaryFile :: NubList PathTemplate + , installLogFile :: Flag PathTemplate + , installBuildReports :: Flag ReportLevel + , installReportPlanningFailure :: Flag Bool + , -- Note: symlink-bindir is no longer used by v2-install and can be removed + -- when removing v1 commands + installSymlinkBinDir :: Flag FilePath + , installPerComponent :: Flag Bool + , installNumJobs :: Flag (Maybe Int) + , installKeepGoing :: Flag Bool + , installRunTests :: Flag Bool + , installOfflineMode :: Flag Bool + } + deriving (Eq, Show, Generic) + +instance Binary InstallFlags + +defaultInstallFlags :: InstallFlags +defaultInstallFlags = + InstallFlags + { installDocumentation = Flag False + , installHaddockIndex = Flag docIndexFile + , installDest = Flag Cabal.NoCopyDest + , installDryRun = Flag False + , installOnlyDownload = Flag False + , installMaxBackjumps = Flag defaultMaxBackjumps + , installReorderGoals = Flag (ReorderGoals False) + , installCountConflicts = Flag (CountConflicts True) + , installFineGrainedConflicts = Flag (FineGrainedConflicts True) + , installMinimizeConflictSet = Flag (MinimizeConflictSet False) + , installIndependentGoals = Flag (IndependentGoals False) + , installPreferOldest = Flag (PreferOldest False) + , installShadowPkgs = Flag (ShadowPkgs False) + , installStrongFlags = Flag (StrongFlags False) + , installAllowBootLibInstalls = Flag (AllowBootLibInstalls False) + , installOnlyConstrained = Flag OnlyConstrainedNone + , installReinstall = Flag False + , installAvoidReinstalls = Flag (AvoidReinstalls False) + , installOverrideReinstall = Flag False + , installUpgradeDeps = Flag False + , installOnly = Flag False + , installOnlyDeps = Flag False + , installIndexState = mempty + , installRootCmd = mempty + , installSummaryFile = mempty + , installLogFile = mempty + , installBuildReports = Flag NoReports + , installReportPlanningFailure = Flag False + , installSymlinkBinDir = mempty + , installPerComponent = Flag True + , installNumJobs = mempty + , installKeepGoing = Flag False + , installRunTests = mempty + , installOfflineMode = Flag False + } where - isStartMarker = (== startMarker) . stripTrailSpace - isEndMarker = (== endMarker) . stripTrailSpace + docIndexFile = + toPathTemplate + ( "$datadir" + "doc" + "$arch-$os-$compiler" + "index.html" + ) - stripTrailSpace = fst . BS.spanEnd isSpace +defaultMaxBackjumps :: Int +defaultMaxBackjumps = 4000 - -- before start marker - goPre ls = case dropWhile (not . isStartMarker) ls of - [] -> Left $ "`" ++ BS.unpack startMarker ++ "` start marker not found" - (_:ls') -> goBody [] ls' +defaultSolver :: PreSolver +defaultSolver = AlwaysModular - goBody _ [] = Left $ "`" ++ BS.unpack endMarker ++ "` end marker not found" - goBody acc (l:ls) - | isEndMarker l = Right $! BS.unlines $ reverse acc - | otherwise = goBody (l:acc) ls +allSolvers :: String +allSolvers = intercalate ", " (map prettyShow ([minBound .. maxBound] :: [PreSolver])) + +installCommand + :: CommandUI + ( ConfigFlags + , ConfigExFlags + , InstallFlags + , HaddockFlags + , TestFlags + , BenchmarkFlags + ) +installCommand = + CommandUI + { commandName = "install" + , commandSynopsis = "Install packages." + , commandUsage = + usageAlternatives + "v1-install" + [ "[FLAGS]" + , "[FLAGS] PACKAGES" + ] + , commandDescription = Just $ \_ -> + wrapText $ + "Installs one or more packages. By default, the installed package" + ++ " will be registered in the user's package database." + ++ "\n" + ++ "If PACKAGES are specified, downloads and installs those packages." + ++ " Otherwise, install the package in the current directory (and/or its" + ++ " dependencies) (there must be exactly one .cabal file in the current" + ++ " directory).\n" + ++ "\n" + ++ "The flags to `v1-install` are saved and" + ++ " affect future commands such as `v1-build` and `v1-repl`. See the help for" + ++ " `v1-configure` for a list of commands being affected.\n" + ++ "\n" + ++ "Installed executables will by default" + ++ " be put into `~/.local/bin/`." + ++ " If you want installed executable to be available globally, make" + ++ " sure that the PATH environment variable contains that directory.\n" + ++ "\n" + , commandNotes = Just $ \pname -> + ( case commandNotes $ + Cabal.configureCommand defaultProgramDb of + Just desc -> desc pname ++ "\n" + Nothing -> "" + ) + ++ "Examples:\n" + ++ " " + ++ pname + ++ " v1-install " + ++ " Package in the current directory\n" + ++ " " + ++ pname + ++ " v1-install foo " + ++ " Package from the hackage server\n" + ++ " " + ++ pname + ++ " v1-install foo-1.0 " + ++ " Specific version of a package\n" + ++ " " + ++ pname + ++ " v1-install 'foo < 2' " + ++ " Constrained package version\n" + ++ " " + ++ pname + ++ " v1-install haddock --bindir=$HOME/hask-bin/ --datadir=$HOME/hask-data/\n" + ++ " " + ++ (map (const ' ') pname) + ++ " " + ++ " Change installation destination\n" + , commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, mempty) + , commandOptions = \showOrParseArgs -> + liftOptions + get1 + set1 + -- Note: [Hidden Flags] + -- hide "constraint", "dependency", "promised-dependency" and + -- "exact-configuration" from the configure options. + ( filter + ( ( `notElem` + [ "constraint" + , "dependency" + , "promised-dependency" + , "exact-configuration" + ] + ) + . optionName + ) + $ configureOptions showOrParseArgs + ) + ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag) + ++ liftOptions + get3 + set3 + -- hide "target-package-db" flag from the + -- install options. + ( filter + ( (`notElem` ["target-package-db"]) + . optionName + ) + $ installOptions showOrParseArgs + ) + ++ liftOptions get4 set4 (haddockOptions showOrParseArgs) + ++ liftOptions get5 set5 (testOptions showOrParseArgs) + ++ liftOptions get6 set6 (benchmarkOptions showOrParseArgs) + } + where + get1 (a, _, _, _, _, _) = a + set1 a (_, b, c, d, e, f) = (a, b, c, d, e, f) + get2 (_, b, _, _, _, _) = b + set2 b (a, _, c, d, e, f) = (a, b, c, d, e, f) + get3 (_, _, c, _, _, _) = c + set3 c (a, b, _, d, e, f) = (a, b, c, d, e, f) + get4 (_, _, _, d, _, _) = d + set4 d (a, b, c, _, e, f) = (a, b, c, d, e, f) + get5 (_, _, _, _, e, _) = e + set5 e (a, b, c, d, _, f) = (a, b, c, d, e, f) + get6 (_, _, _, _, _, f) = f + set6 f (a, b, c, d, e, _) = (a, b, c, d, e, f) - startMarker, endMarker :: BS.ByteString - startMarker = "{- " <> header <> ":" - endMarker = "-}" +haddockCommand :: CommandUI HaddockFlags +haddockCommand = + Cabal.haddockCommand + { commandUsage = + usageAlternatives "v1-haddock" $ + ["[FLAGS]", "COMPONENTS [FLAGS]"] + } --- | The base for making a 'SourcePackage' for a fake project. --- It needs a 'Distribution.Types.Library.Library' or 'Executable' depending on the command. -fakeProjectSourcePackage :: FilePath -> SourcePackage (PackageLocation loc) -fakeProjectSourcePackage projectRoot = sourcePackage +filterHaddockArgs :: [String] -> Version -> [String] +filterHaddockArgs args cabalLibVersion + | cabalLibVersion >= mkVersion [2, 3, 0] = args_latest + | cabalLibVersion < mkVersion [2, 3, 0] = args_2_3_0 + | otherwise = args_latest where - sourcePackage = SourcePackage - { srcpkgPackageId = fakePackageId - , srcpkgDescription = genericPackageDescription - , srcpkgSource = LocalUnpackedPackage projectRoot - , srcpkgDescrOverride = Nothing - } - genericPackageDescription = emptyGenericPackageDescription - { GPD.packageDescription = packageDescription } - packageDescription = emptyPackageDescription - { package = fakePackageId - , specVersion = CabalSpecV2_2 - , licenseRaw = Left SPDX.NONE + args_latest = args + + -- Cabal < 2.3 doesn't know about per-component haddock + args_2_3_0 = [] + +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 + where + flags_latest = flags + + flags_2_3_0 = + flags_latest + { -- Cabal < 2.3 doesn't know about per-component haddock + haddockArgs = [] + } + +haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags] +haddockOptions showOrParseArgs = + [ opt + { optionName = "haddock-" ++ name + , optionDescr = + [ fmapOptFlags (\(_, lflags) -> ([], map ("haddock-" ++) lflags)) descr + | descr <- optionDescr opt + ] + } + | opt <- commandOptions Cabal.haddockCommand showOrParseArgs + , let name = optionName opt + , name + `elem` [ "hoogle" + , "html" + , "html-location" + , "executables" + , "tests" + , "benchmarks" + , "all" + , "internal" + , "css" + , "hyperlink-source" + , "quickjump" + , "hscolour-css" + , "contents-location" + , "use-index" + , "for-hackage" + , "base-url" + , "lib" + , "output-dir" + ] + ] + +testOptions :: ShowOrParseArgs -> [OptionField TestFlags] +testOptions showOrParseArgs = + [ opt + { optionName = prefixTest name + , optionDescr = + [ fmapOptFlags (\(_, lflags) -> ([], map prefixTest lflags)) descr + | descr <- optionDescr opt + ] + } + | opt <- commandOptions Cabal.testCommand showOrParseArgs + , let name = optionName opt + , name + `elem` [ "log" + , "machine-log" + , "show-details" + , "keep-tix-files" + , "fail-when-no-test-suites" + , "test-options" + , "test-option" + , "test-wrapper" + ] + ] + where + prefixTest name + | "test-" `isPrefixOf` name = name + | otherwise = "test-" ++ name + +benchmarkOptions :: ShowOrParseArgs -> [OptionField BenchmarkFlags] +benchmarkOptions showOrParseArgs = + [ opt + { optionName = prefixBenchmark name + , optionDescr = + [ fmapOptFlags (\(_, lflags) -> ([], map prefixBenchmark lflags)) descr + | descr <- optionDescr opt + ] + } + | opt <- commandOptions Cabal.benchmarkCommand showOrParseArgs + , let name = optionName opt + , name `elem` ["benchmark-options", "benchmark-option"] + ] + where + prefixBenchmark name + | "benchmark-" `isPrefixOf` name = name + | otherwise = "benchmark-" ++ name + +fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a +fmapOptFlags modify (ReqArg d f p r w) = ReqArg d (modify f) p r w +fmapOptFlags modify (OptArg d f p r i w) = OptArg d (modify f) p r i w +fmapOptFlags modify (ChoiceOpt xs) = ChoiceOpt [(d, modify f, i, w) | (d, f, i, w) <- xs] +fmapOptFlags modify (BoolOpt d f1 f2 r w) = BoolOpt d (modify f1) (modify f2) r w + +installOptions :: ShowOrParseArgs -> [OptionField InstallFlags] +installOptions showOrParseArgs = + [ option + "" + ["documentation"] + "building of documentation" + installDocumentation + (\v flags -> flags{installDocumentation = v}) + (boolOpt [] []) + , option + [] + ["doc-index-file"] + "A central index of haddock API documentation (template cannot use $pkgid)" + installHaddockIndex + (\v flags -> flags{installHaddockIndex = v}) + ( reqArg' + "TEMPLATE" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate) + ) + , option + [] + ["dry-run"] + "Do not install anything, only print what would be installed." + installDryRun + (\v flags -> flags{installDryRun = v}) + trueArg + , option + [] + ["only-download"] + "Do not build anything, only fetch the packages." + installOnlyDownload + (\v flags -> flags{installOnlyDownload = v}) + trueArg + , option + "" + ["target-package-db"] + "package database to install into. Required when using ${pkgroot} prefix." + installDest + (\v flags -> flags{installDest = v}) + ( reqArg + "DATABASE" + (succeedReadE (Flag . Cabal.CopyToDb)) + (\f -> case f of Flag (Cabal.CopyToDb p) -> [p]; _ -> []) + ) + ] + ++ optionSolverFlags + showOrParseArgs + installMaxBackjumps + (\v flags -> flags{installMaxBackjumps = v}) + installReorderGoals + (\v flags -> flags{installReorderGoals = v}) + installCountConflicts + (\v flags -> flags{installCountConflicts = v}) + installFineGrainedConflicts + (\v flags -> flags{installFineGrainedConflicts = v}) + installMinimizeConflictSet + (\v flags -> flags{installMinimizeConflictSet = v}) + installIndependentGoals + (\v flags -> flags{installIndependentGoals = v}) + installPreferOldest + (\v flags -> flags{installPreferOldest = v}) + installShadowPkgs + (\v flags -> flags{installShadowPkgs = v}) + installStrongFlags + (\v flags -> flags{installStrongFlags = v}) + installAllowBootLibInstalls + (\v flags -> flags{installAllowBootLibInstalls = v}) + installOnlyConstrained + (\v flags -> flags{installOnlyConstrained = v}) + ++ [ option + [] + ["reinstall"] + "Install even if it means installing the same version again." + installReinstall + (\v flags -> flags{installReinstall = v}) + (yesNoOpt showOrParseArgs) + , option + [] + ["avoid-reinstalls"] + "Do not select versions that would destructively overwrite installed packages." + (fmap asBool . installAvoidReinstalls) + (\v flags -> flags{installAvoidReinstalls = fmap AvoidReinstalls v}) + (yesNoOpt showOrParseArgs) + , option + [] + ["force-reinstalls"] + "Reinstall packages even if they will most likely break other installed packages." + installOverrideReinstall + (\v flags -> flags{installOverrideReinstall = v}) + (yesNoOpt showOrParseArgs) + , option + [] + ["upgrade-dependencies"] + "Pick the latest version for all dependencies, rather than trying to pick an installed version." + installUpgradeDeps + (\v flags -> flags{installUpgradeDeps = v}) + (yesNoOpt showOrParseArgs) + , option + [] + ["only-dependencies"] + "Install only the dependencies necessary to build the given packages" + installOnlyDeps + (\v flags -> flags{installOnlyDeps = v}) + (yesNoOpt showOrParseArgs) + , option + [] + ["dependencies-only"] + "A synonym for --only-dependencies" + installOnlyDeps + (\v flags -> flags{installOnlyDeps = v}) + (yesNoOpt showOrParseArgs) + , option + [] + ["index-state"] + ( "Use source package index state as it existed at a previous time. " + ++ "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " + ++ "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD')." + ) + installIndexState + (\v flags -> flags{installIndexState = v}) + ( reqArg + "STATE" + ( parsecToReadE + ( const $ + "index-state must be a " + ++ "unix-timestamps (e.g. '@1474732068'), " + ++ "a ISO8601 UTC timestamp " + ++ "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'" + ) + (toFlag `fmap` parsec) + ) + (flagToList . fmap prettyShow) + ) + , option + [] + ["root-cmd"] + "(No longer supported, do not use.)" + installRootCmd + (\v flags -> flags{installRootCmd = v}) + (reqArg' "COMMAND" toFlag flagToList) + , option + [] + ["symlink-bindir"] + "Add symlinks to installed executables into this directory." + installSymlinkBinDir + (\v flags -> flags{installSymlinkBinDir = v}) + (reqArgFlag "DIR") + , option + [] + ["build-summary"] + "Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)" + installSummaryFile + (\v flags -> flags{installSummaryFile = v}) + (reqArg' "TEMPLATE" (\x -> toNubList [toPathTemplate x]) (map fromPathTemplate . fromNubList)) + , option + [] + ["build-log"] + "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)" + installLogFile + (\v flags -> flags{installLogFile = v}) + ( reqArg' + "TEMPLATE" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate) + ) + , option + [] + ["remote-build-reporting"] + "Generate build reports to send to a remote server (none, anonymous or detailed)." + installBuildReports + (\v flags -> flags{installBuildReports = v}) + ( reqArg + "LEVEL" + ( parsecToReadE + ( const $ + "report level must be 'none', " + ++ "'anonymous' or 'detailed'" + ) + (toFlag `fmap` parsec) + ) + (flagToList . fmap prettyShow) + ) + , option + [] + ["report-planning-failure"] + "Generate build reports when the dependency solver fails. This is used by the Hackage build bot." + installReportPlanningFailure + (\v flags -> flags{installReportPlanningFailure = v}) + trueArg + , option + "" + ["per-component"] + "Per-component builds when possible" + installPerComponent + (\v flags -> flags{installPerComponent = v}) + (boolOpt [] []) + , option + [] + ["run-tests"] + "Run package test suites during installation." + installRunTests + (\v flags -> flags{installRunTests = v}) + trueArg + , optionNumJobs + installNumJobs + (\v flags -> flags{installNumJobs = v}) + , option + [] + ["keep-going"] + "After a build failure, continue to build other unaffected packages." + installKeepGoing + (\v flags -> flags{installKeepGoing = v}) + trueArg + , option + [] + ["offline"] + "Don't download packages from the Internet." + installOfflineMode + (\v flags -> flags{installOfflineMode = v}) + (yesNoOpt showOrParseArgs) + ] + ++ case showOrParseArgs of -- TODO: remove when "cabal install" + -- avoids + ParseArgs -> + [ option + [] + ["only"] + "Only installs the package in the current directory." + installOnly + (\v flags -> flags{installOnly = v}) + trueArg + ] + _ -> [] + +instance Monoid InstallFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup InstallFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ + +-- * Upload flags + +-- ------------------------------------------------------------ + +-- | Is this a candidate package or a package to be published? +data IsCandidate = IsCandidate | IsPublished + deriving (Eq) + +data UploadFlags = UploadFlags + { uploadCandidate :: Flag IsCandidate + , uploadDoc :: Flag Bool + , uploadUsername :: Flag Username + , uploadPassword :: Flag Password + , uploadPasswordCmd :: Flag [String] + , uploadVerbosity :: Flag Verbosity + } + deriving (Generic) + +defaultUploadFlags :: UploadFlags +defaultUploadFlags = + UploadFlags + { uploadCandidate = toFlag IsCandidate + , uploadDoc = toFlag False + , uploadUsername = mempty + , uploadPassword = mempty + , uploadPasswordCmd = mempty + , uploadVerbosity = toFlag normal + } + +uploadCommand :: CommandUI UploadFlags +uploadCommand = + CommandUI + { commandName = "upload" + , commandSynopsis = "Uploads source packages or documentation to Hackage." + , commandDescription = Nothing + , commandNotes = Just $ \_ -> + "You can store your Hackage login in the ~/.config/cabal/config file\n" + ++ relevantConfigValuesText ["username", "password", "password-command"] + , commandUsage = \pname -> + "Usage: " ++ pname ++ " upload [FLAGS] TARFILES\n" + , commandDefaultFlags = defaultUploadFlags + , commandOptions = \_ -> + [ optionVerbosity + uploadVerbosity + (\v flags -> flags{uploadVerbosity = v}) + , option + [] + ["publish"] + "Publish the package instead of uploading it as a candidate." + uploadCandidate + (\v flags -> flags{uploadCandidate = v}) + (noArg (Flag IsPublished)) + , option + ['d'] + ["documentation"] + ( "Upload documentation instead of a source package. " + ++ "By default, this uploads documentation for a package candidate. " + ++ "To upload documentation for " + ++ "a published package, combine with --publish." + ) + uploadDoc + (\v flags -> flags{uploadDoc = v}) + trueArg + , option + ['u'] + ["username"] + "Hackage username." + uploadUsername + (\v flags -> flags{uploadUsername = v}) + ( reqArg' + "USERNAME" + (toFlag . Username) + (flagToList . fmap unUsername) + ) + , option + ['p'] + ["password"] + "Hackage password." + uploadPassword + (\v flags -> flags{uploadPassword = v}) + ( reqArg' + "PASSWORD" + (toFlag . Password) + (flagToList . fmap unPassword) + ) + , option + ['P'] + ["password-command"] + "Command to get Hackage password." + uploadPasswordCmd + (\v flags -> flags{uploadPasswordCmd = v}) + (reqArg' "PASSWORD" (Flag . words) (fromMaybe [] . flagToMaybe)) + ] + } + +instance Monoid UploadFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup UploadFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ + +-- * Init flags + +-- ------------------------------------------------------------ + +initCommand :: CommandUI IT.InitFlags +initCommand = + CommandUI + { commandName = "init" + , commandSynopsis = "Create a new cabal package." + , commandDescription = Just $ \_ -> + wrapText $ + "Create a .cabal, CHANGELOG.md, minimal initial Haskell code and optionally a LICENSE file.\n" + ++ "\n" + ++ "Calling init with no arguments runs interactive mode, " + ++ "which will try to guess as much as possible and prompt you for the rest.\n" + ++ "Non-interactive mode can be invoked by the -n/--non-interactive flag, " + ++ "which will let you specify the options via flags and will use the defaults for the rest.\n" + ++ "It is also possible to call init with a single argument, which denotes the project's desired " + ++ "root directory.\n" + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " init [PROJECT ROOT] [FLAGS]\n" + , commandDefaultFlags = IT.defaultInitFlags + , commandOptions = initOptions + } + +initOptions :: ShowOrParseArgs -> [OptionField IT.InitFlags] +initOptions _ = + [ option + ['i'] + ["interactive"] + "interactive mode." + IT.interactive + (\v flags -> flags{IT.interactive = v}) + (boolOpt' (['i'], ["interactive"]) (['n'], ["non-interactive"])) + , option + ['q'] + ["quiet"] + "Do not generate log messages to stdout." + IT.quiet + (\v flags -> flags{IT.quiet = v}) + trueArg + , option + [] + ["no-comments"] + "Do not generate explanatory comments in the .cabal file." + IT.noComments + (\v flags -> flags{IT.noComments = v}) + trueArg + , option + ['m'] + ["minimal"] + "Generate a minimal .cabal file, that is, do not include extra empty fields. Also implies --no-comments." + IT.minimal + (\v flags -> flags{IT.minimal = v}) + trueArg + , option + [] + ["overwrite"] + "Overwrite any existing .cabal, LICENSE, or Setup.hs files without warning." + IT.overwrite + (\v flags -> flags{IT.overwrite = v}) + trueArg + , option + [] + ["package-dir", "packagedir"] + "Root directory of the package (default = current directory)." + IT.packageDir + (\v flags -> flags{IT.packageDir = v}) + (reqArgFlag "DIRECTORY") + , option + ['p'] + ["package-name"] + "Name of the Cabal package to create." + IT.packageName + (\v flags -> flags{IT.packageName = v}) + ( reqArg + "PACKAGE" + ( parsecToReadE + ("Cannot parse package name: " ++) + (toFlag `fmap` parsec) + ) + (flagToList . fmap prettyShow) + ) + , option + [] + ["version"] + "Initial version of the package." + IT.version + (\v flags -> flags{IT.version = v}) + ( reqArg + "VERSION" + ( parsecToReadE + ("Cannot parse package version: " ++) + (toFlag `fmap` parsec) + ) + (flagToList . fmap prettyShow) + ) + , option + [] + ["cabal-version"] + "Version of the Cabal specification." + IT.cabalVersion + (\v flags -> flags{IT.cabalVersion = v}) + ( reqArg + "CABALSPECVERSION" + ( parsecToReadE + ("Cannot parse Cabal specification version: " ++) + (fmap (toFlag . getSpecVersion) parsec) + ) + (flagToList . fmap (prettyShow . SpecVersion)) + ) + , option + ['l'] + ["license"] + "Project license." + IT.license + (\v flags -> flags{IT.license = v}) + ( reqArg + "LICENSE" + ( parsecToReadE + ("Cannot parse license: " ++) + (toFlag `fmap` parsec) + ) + (flagToList . fmap prettyShow) + ) + , option + ['a'] + ["author"] + "Name of the project's author." + IT.author + (\v flags -> flags{IT.author = v}) + (reqArgFlag "NAME") + , option + ['e'] + ["email"] + "Email address of the maintainer." + IT.email + (\v flags -> flags{IT.email = v}) + (reqArgFlag "EMAIL") + , option + ['u'] + ["homepage"] + "Project homepage and/or repository." + IT.homepage + (\v flags -> flags{IT.homepage = v}) + (reqArgFlag "URL") + , option + ['s'] + ["synopsis"] + "Short project synopsis." + IT.synopsis + (\v flags -> flags{IT.synopsis = v}) + (reqArgFlag "TEXT") + , option + ['c'] + ["category"] + "Project category." + IT.category + (\v flags -> flags{IT.category = v}) + (reqArgFlag "CATEGORY") + , option + ['x'] + ["extra-source-file"] + "Extra source file to be distributed with tarball." + IT.extraSrc + (\v flags -> flags{IT.extraSrc = mergeListFlag (IT.extraSrc flags) v}) + ( reqArg' + "FILE" + (Flag . (: [])) + (fromFlagOrDefault []) + ) + , option + [] + ["extra-doc-file"] + "Extra doc file to be distributed with tarball." + IT.extraDoc + (\v flags -> flags{IT.extraDoc = mergeListFlag (IT.extraDoc flags) v}) + (reqArg' "FILE" (Flag . (: [])) (fromFlagOrDefault [])) + , option + [] + ["lib", "is-library"] + "Build a library." + IT.packageType + (\v flags -> flags{IT.packageType = v}) + (noArg (Flag IT.Library)) + , option + [] + ["exe", "is-executable"] + "Build an executable." + IT.packageType + (\v flags -> flags{IT.packageType = v}) + (noArg (Flag IT.Executable)) + , option + [] + ["libandexe", "is-libandexe"] + "Build a library and an executable." + IT.packageType + (\v flags -> flags{IT.packageType = v}) + (noArg (Flag IT.LibraryAndExecutable)) + , option + [] + ["tests"] + "Generate a test suite, standalone or for a library." + IT.initializeTestSuite + (\v flags -> flags{IT.initializeTestSuite = v}) + trueArg + , option + [] + ["test-dir"] + "Directory containing tests." + IT.testDirs + ( \v flags -> + flags{IT.testDirs = mergeListFlag (IT.testDirs flags) v} + ) + ( reqArg' + "DIR" + (Flag . (: [])) + (fromFlagOrDefault []) + ) + , option + [] + ["simple"] + "Create a simple project with sensible defaults." + IT.simpleProject + (\v flags -> flags{IT.simpleProject = v}) + trueArg + , option + [] + ["main-is"] + "Specify the main module." + IT.mainIs + (\v flags -> flags{IT.mainIs = v}) + (reqArgFlag "FILE") + , option + [] + ["language"] + "Specify the default language." + IT.language + (\v flags -> flags{IT.language = v}) + ( reqArg + "LANGUAGE" + ( parsecToReadE + ("Cannot parse language: " ++) + (toFlag `fmap` parsec) + ) + (flagToList . fmap prettyShow) + ) + , option + ['o'] + ["expose-module"] + "Export a module from the package." + IT.exposedModules + ( \v flags -> + flags + { IT.exposedModules = + mergeListFlag (IT.exposedModules flags) v + } + ) + ( reqArg + "MODULE" + ( parsecToReadE + ("Cannot parse module name: " ++) + (Flag . (: []) <$> parsec) + ) + (flagElim [] (fmap prettyShow)) + ) + , option + [] + ["extension"] + "Use a LANGUAGE extension (in the other-extensions field)." + IT.otherExts + ( \v flags -> + flags + { IT.otherExts = + mergeListFlag (IT.otherExts flags) v + } + ) + ( reqArg + "EXTENSION" + ( parsecToReadE + ("Cannot parse extension: " ++) + (Flag . (: []) <$> parsec) + ) + (flagElim [] (fmap prettyShow)) + ) + , option + ['d'] + ["dependency"] + "Package dependencies. Permits comma separated list of dependencies." + IT.dependencies + ( \v flags -> + flags + { IT.dependencies = + mergeListFlag (IT.dependencies flags) v + } + ) + ( reqArg + "DEPENDENCIES" + (fmap Flag dependenciesReadE) + (fmap prettyShow . fromFlagOrDefault []) + ) + , option + [] + ["application-dir"] + "Directory containing package application executable." + IT.applicationDirs + ( \v flags -> + flags + { IT.applicationDirs = + mergeListFlag (IT.applicationDirs flags) v + } + ) + ( reqArg' + "DIR" + (Flag . (: [])) + (fromFlagOrDefault []) + ) + , option + [] + ["source-dir", "sourcedir"] + "Directory containing package library source." + IT.sourceDirs + ( \v flags -> + flags + { IT.sourceDirs = + mergeListFlag (IT.sourceDirs flags) v + } + ) + ( reqArg' + "DIR" + (Flag . (: [])) + (fromFlagOrDefault []) + ) + , option + [] + ["build-tool"] + "Required external build tool." + IT.buildTools + ( \v flags -> + flags + { IT.buildTools = + mergeListFlag (IT.buildTools flags) v + } + ) + ( reqArg' + "TOOL" + (Flag . (: [])) + (fromFlagOrDefault []) + ) + , option + "w" + ["with-compiler"] + "give the path to a particular compiler. For 'init', this flag is used \ + \to set the bounds inferred for the 'base' package." + IT.initHcPath + (\v flags -> flags{IT.initHcPath = v}) + (reqArgFlag "PATH") + , optionVerbosity IT.initVerbosity (\v flags -> flags{IT.initVerbosity = v}) + ] + where + dependenciesReadE :: ReadE [Dependency] + dependenciesReadE = + parsecToReadE + ("Cannot parse dependencies: " ++) + (parsecCommaList parsec) + + mergeListFlag :: Flag [a] -> Flag [a] -> Flag [a] + mergeListFlag currentFlags v = + Flag $ concat (flagToList currentFlags ++ flagToList v) + +-- ------------------------------------------------------------ + +-- * Copy and Register + +-- ------------------------------------------------------------ + +copyCommand :: CommandUI CopyFlags +copyCommand = + Cabal.copyCommand + { commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " + ++ pname + ++ " v1-copy " + ++ " All the components in the package\n" + ++ " " + ++ pname + ++ " v1-copy foo " + ++ " A component (i.e. lib, exe, test suite)" + , commandUsage = + usageAlternatives "v1-copy" $ + [ "[FLAGS]" + , "COMPONENTS [FLAGS]" + ] + } + +registerCommand :: CommandUI RegisterFlags +registerCommand = + Cabal.registerCommand + { commandUsage = \pname -> "Usage: " ++ pname ++ " v1-register [FLAGS]\n" + } + +-- ------------------------------------------------------------ + +-- * ActAsSetup flags + +-- ------------------------------------------------------------ + +data ActAsSetupFlags = ActAsSetupFlags + { actAsSetupBuildType :: Flag BuildType + } + deriving (Generic) + +defaultActAsSetupFlags :: ActAsSetupFlags +defaultActAsSetupFlags = + ActAsSetupFlags + { actAsSetupBuildType = toFlag Simple + } + +actAsSetupCommand :: CommandUI ActAsSetupFlags +actAsSetupCommand = + CommandUI + { commandName = "act-as-setup" + , commandSynopsis = "Run as-if this was a Setup.hs" + , commandDescription = Nothing + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " act-as-setup\n" + , commandDefaultFlags = defaultActAsSetupFlags + , commandOptions = \_ -> + [ option + "" + ["build-type"] + "Use the given build type." + actAsSetupBuildType + (\v flags -> flags{actAsSetupBuildType = v}) + ( reqArg + "BUILD-TYPE" + ( parsecToReadE + ("Cannot parse build type: " ++) + (fmap toFlag parsec) + ) + (map prettyShow . flagToList) + ) + ] + } + +instance Monoid ActAsSetupFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup ActAsSetupFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ + +-- * UserConfig flags + +-- ------------------------------------------------------------ + +data UserConfigFlags = UserConfigFlags + { userConfigVerbosity :: Flag Verbosity + , userConfigForce :: Flag Bool + , userConfigAppendLines :: Flag [String] + } + deriving (Generic) + +instance Monoid UserConfigFlags where + mempty = + UserConfigFlags + { userConfigVerbosity = toFlag normal + , userConfigForce = toFlag False + , userConfigAppendLines = toFlag [] } + mappend = (<>) + +instance Semigroup UserConfigFlags where + (<>) = gmappend + +userConfigCommand :: CommandUI UserConfigFlags +userConfigCommand = + CommandUI + { commandName = "user-config" + , commandSynopsis = "Display and update the user's global cabal configuration." + , commandDescription = Just $ \_ -> + wrapText $ + "When upgrading cabal, the set of configuration keys and their default" + ++ " values may change. This command provides means to merge the existing" + ++ " config in ~/.config/cabal/config" + ++ " (i.e. all bindings that are actually defined and not commented out)" + ++ " and the default config of the new version.\n" + ++ "\n" + ++ "init: Creates a new config file at either ~/.config/cabal/config or as" + ++ " specified by --config-file, if given. An existing file won't be " + ++ " overwritten unless -f or --force is given.\n" + ++ "diff: Shows a pseudo-diff of the user's ~/.config/cabal/config file and" + ++ " the default configuration that would be created by cabal if the" + ++ " config file did not exist.\n" + ++ "update: Applies the pseudo-diff to the configuration that would be" + ++ " created by default, and write the result back to ~/.config/cabal/config." + , commandNotes = Nothing + , commandUsage = usageAlternatives "user-config" ["init", "diff", "update"] + , commandDefaultFlags = mempty + , commandOptions = \_ -> + [ optionVerbosity userConfigVerbosity (\v flags -> flags{userConfigVerbosity = v}) + , option + ['f'] + ["force"] + "Overwrite the config file if it already exists." + userConfigForce + (\v flags -> flags{userConfigForce = v}) + trueArg + , option + ['a'] + ["augment"] + "Additional setting to augment the config file (replacing a previous setting if it existed)." + userConfigAppendLines + ( \v flags -> + flags + { userConfigAppendLines = + Flag $ concat (flagToList (userConfigAppendLines flags) ++ flagToList v) + } + ) + (reqArg' "CONFIGLINE" (Flag . (: [])) (fromMaybe [] . flagToMaybe)) + ] + } + +-- ------------------------------------------------------------ + +-- * GetOpt Utils + +-- ------------------------------------------------------------ + +reqArgFlag + :: ArgPlaceHolder + -> MkOptDescr (b -> Flag String) (Flag String -> b -> b) b +reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList + +liftOptions + :: (b -> a) + -> (a -> b -> b) + -> [OptionField a] + -> [OptionField b] +liftOptions get set = map (liftOption get set) + +yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b +yesNoOpt ShowArgs sf lf = trueArg sf lf +yesNoOpt _ sf lf = Command.boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf + +optionSolver + :: (flags -> Flag PreSolver) + -> (Flag PreSolver -> flags -> flags) + -> OptionField flags +optionSolver get set = + option + [] + ["solver"] + ("Select dependency solver to use (default: " ++ prettyShow defaultSolver ++ "). Choices: " ++ allSolvers ++ ".") + get + set + ( reqArg + "SOLVER" + ( parsecToReadE + (const $ "solver must be one of: " ++ allSolvers) + (toFlag `fmap` parsec) + ) + (flagToList . fmap prettyShow) + ) + +optionSolverFlags + :: ShowOrParseArgs + -> (flags -> Flag Int) + -> (Flag Int -> flags -> flags) + -> (flags -> Flag ReorderGoals) + -> (Flag ReorderGoals -> flags -> flags) + -> (flags -> Flag CountConflicts) + -> (Flag CountConflicts -> flags -> flags) + -> (flags -> Flag FineGrainedConflicts) + -> (Flag FineGrainedConflicts -> flags -> flags) + -> (flags -> Flag MinimizeConflictSet) + -> (Flag MinimizeConflictSet -> flags -> flags) + -> (flags -> Flag IndependentGoals) + -> (Flag IndependentGoals -> flags -> flags) + -> (flags -> Flag PreferOldest) + -> (Flag PreferOldest -> flags -> flags) + -> (flags -> Flag ShadowPkgs) + -> (Flag ShadowPkgs -> flags -> flags) + -> (flags -> Flag StrongFlags) + -> (Flag StrongFlags -> flags -> flags) + -> (flags -> Flag AllowBootLibInstalls) + -> (Flag AllowBootLibInstalls -> flags -> flags) + -> (flags -> Flag OnlyConstrained) + -> (Flag OnlyConstrained -> flags -> flags) + -> [OptionField flags] +optionSolverFlags + showOrParseArgs + getmbj + setmbj + getrg + setrg + getcc + setcc + getfgc + setfgc + getmc + setmc + getig + setig + getpo + setpo + getsip + setsip + getstrfl + setstrfl + getib + setib + getoc + setoc = + [ option + [] + ["max-backjumps"] + ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.") + getmbj + setmbj + ( reqArg + "NUM" + (parsecToReadE ("Cannot parse number: " ++) (fmap toFlag P.signedIntegral)) + (map show . flagToList) + ) + , option + [] + ["reorder-goals"] + "Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages." + (fmap asBool . getrg) + (setrg . fmap ReorderGoals) + (yesNoOpt showOrParseArgs) + , option + [] + ["count-conflicts"] + "Try to speed up solving by preferring goals that are involved in a lot of conflicts (default)." + (fmap asBool . getcc) + (setcc . fmap CountConflicts) + (yesNoOpt showOrParseArgs) + , option + [] + ["fine-grained-conflicts"] + "Skip a version of a package if it does not resolve the conflicts encountered in the last version, as a solver optimization (default)." + (fmap asBool . getfgc) + (setfgc . fmap FineGrainedConflicts) + (yesNoOpt showOrParseArgs) + , option + [] + ["minimize-conflict-set"] + ( "When there is no solution, try to improve the error message by finding " + ++ "a minimal conflict set (default: false). May increase run time " + ++ "significantly." + ) + (fmap asBool . getmc) + (setmc . fmap MinimizeConflictSet) + (yesNoOpt showOrParseArgs) + , option + [] + ["independent-goals"] + "Treat several goals on the command line as independent. If several goals depend on the same package, different versions can be chosen." + (fmap asBool . getig) + (setig . fmap IndependentGoals) + (yesNoOpt showOrParseArgs) + , option + [] + ["prefer-oldest"] + "Prefer the oldest (instead of the latest) versions of packages available. Useful to determine lower bounds in the build-depends section." + (fmap asBool . getpo) + (setpo . fmap PreferOldest) + (yesNoOpt showOrParseArgs) + , option + [] + ["shadow-installed-packages"] + "If multiple package instances of the same version are installed, treat all but one as shadowed." + (fmap asBool . getsip) + (setsip . fmap ShadowPkgs) + (yesNoOpt showOrParseArgs) + , option + [] + ["strong-flags"] + "Do not defer flag choices (this used to be the default in cabal-install <= 1.20)." + (fmap asBool . getstrfl) + (setstrfl . fmap StrongFlags) + (yesNoOpt showOrParseArgs) + , option + [] + ["allow-boot-library-installs"] + "Allow cabal to install base, ghc-prim, integer-simple, integer-gmp, and template-haskell." + (fmap asBool . getib) + (setib . fmap AllowBootLibInstalls) + (yesNoOpt showOrParseArgs) + , option + [] + ["reject-unconstrained-dependencies"] + "Require these packages to have constraints on them if they are to be selected (default: none)." + getoc + setoc + ( reqArg + "none|all" + ( parsecToReadE + (const "reject-unconstrained-dependencies must be 'none' or 'all'") + (toFlag `fmap` parsec) + ) + (flagToList . fmap prettyShow) + ) + ] + +usagePackages :: String -> String -> String +usagePackages name pname = + "Usage: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n" + +usageFlags :: String -> String -> String +usageFlags name pname = + "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n" + +-- ------------------------------------------------------------ + +-- * Repo helpers + +-- ------------------------------------------------------------ + +showRemoteRepo :: RemoteRepo -> String +showRemoteRepo = prettyShow + +readRemoteRepo :: String -> Maybe RemoteRepo +readRemoteRepo = simpleParsec + +showLocalRepo :: LocalRepo -> String +showLocalRepo = prettyShow + +readLocalRepo :: String -> Maybe LocalRepo +readLocalRepo = simpleParsec + +-- ------------------------------------------------------------ + +-- * Helpers for Documentation + +-- ------------------------------------------------------------ --- | Find the path of an exe that has been relocated with a "-o" option -movedExePath :: UnqualComponentName -> DistDirLayout -> ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> Maybe FilePath -movedExePath selectedComponent distDirLayout elabShared elabConfigured = do - exe <- find ((== selectedComponent) . exeName) . executables $ elabPkgDescription elabConfigured - let CompilerId flavor _ = (compilerId . pkgConfigCompiler) elabShared - opts <- lookup flavor (perCompilerFlavorToList . options $ buildInfo exe) - let projectRoot = distProjectRootDirectory distDirLayout - fmap (projectRoot ) . lookup "-o" $ reverse (zip opts (drop 1 opts)) - --- Lenses --- | A lens for the 'srcpkgDescription' field of 'SourcePackage' -lSrcpkgDescription :: Lens' (SourcePackage loc) GenericPackageDescription -lSrcpkgDescription f s = fmap (\x -> s { srcpkgDescription = x }) (f (srcpkgDescription s)) -{-# inline lSrcpkgDescription #-} - -lLocalPackages :: Lens' ProjectBaseContext [PackageSpecifier UnresolvedSourcePackage] -lLocalPackages f s = fmap (\x -> s { localPackages = x }) (f (localPackages s)) -{-# inline lLocalPackages #-} - -lProjectConfig :: Lens' ProjectBaseContext ProjectConfig -lProjectConfig f s = fmap (\x -> s { projectConfig = x }) (f (projectConfig s)) -{-# inline lProjectConfig #-} - --- Character classes --- Transcribed from "templates/Lexer.x" -ccSpace, ccCtrlchar, ccPrintable, ccSymbol', ccParen, ccNamecore :: Set Char -ccSpace = S.fromList " " -ccCtrlchar = S.fromList $ [chr 0x0 .. chr 0x1f] ++ [chr 0x7f] -ccPrintable = S.fromList [chr 0x0 .. chr 0xff] S.\\ ccCtrlchar -ccSymbol' = S.fromList ",=<>+*&|!$%^@#?/\\~" -ccParen = S.fromList "()[]" -ccNamecore = ccPrintable S.\\ S.unions [ccSpace, S.fromList ":\"{}", ccParen, ccSymbol'] +relevantConfigValuesText :: [String] -> String +relevantConfigValuesText vs = + "Relevant global configuration keys:\n" + ++ concat [" " ++ v ++ "\n" | v <- vs] diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 80c62de3e35..b1108d77701 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -1,1518 +1,1001 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} - --- | Handling project configuration. --- -module Distribution.Client.ProjectConfig ( - - -- * Types for project config - ProjectConfig(..), - ProjectConfigBuildOnly(..), - ProjectConfigShared(..), - ProjectConfigProvenance(..), - PackageConfig(..), - MapLast(..), - MapMappend(..), - - -- * Project root - findProjectRoot, - ProjectRoot(..), - BadProjectRoot, - - -- * Project config files - readProjectConfig, - readGlobalConfig, - readProjectLocalExtraConfig, - readProjectLocalFreezeConfig, - reportParseResult, - showProjectConfig, - withGlobalConfig, - withProjectOrGlobalConfig, - writeProjectLocalExtraConfig, - writeProjectLocalFreezeConfig, - writeProjectConfigFile, - commandLineFlagsToProjectConfig, - - -- * Packages within projects - ProjectPackageLocation(..), - BadPackageLocations(..), - BadPackageLocation(..), - BadPackageLocationMatch(..), - findProjectPackages, - fetchAndReadSourcePackages, - - -- * Resolving configuration - lookupLocalPackageConfig, - projectConfigWithBuilderRepoContext, - projectConfigWithSolverRepoContext, - SolverSettings(..), - resolveSolverSettings, - BuildTimeSettings(..), - resolveBuildTimeSettings, - - -- * Checking configuration - checkBadPerPackageCompilerPaths, - BadPerPackageCompilerPaths(..) - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.ProjectConfig.Types -import Distribution.Client.ProjectConfig.Legacy -import Distribution.Client.RebuildMonad -import Distribution.Client.Glob - ( isTrivialFilePathGlob ) -import Distribution.Client.VCS - ( validateSourceRepos, SourceRepoProblem(..) - , VCS(..), knownVCSs, configureVCS, syncSourceRepos ) +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- simplifier goes nuts otherwise +#if __GLASGOW_HASKELL__ < 806 +{-# OPTIONS_GHC -funfolding-use-threshold=30 #-} +#endif -import Distribution.Client.Types -import Distribution.Client.DistDirLayout - ( DistDirLayout(..), CabalDirLayout(..), ProjectRoot(..), defaultProjectFile ) -import Distribution.Client.GlobalFlags - ( RepoContext(..), withRepoContext' ) -import Distribution.Client.BuildReports.Types - ( ReportLevel(..) ) -import Distribution.Client.Config - ( loadConfig, getConfigFilePath ) -import Distribution.Client.HttpUtils - ( HttpTransport, configureTransport, transportCheckHttps - , downloadURI ) -import Distribution.Client.Utils.Parsec (renderParseError) - -import Distribution.Solver.Types.SourcePackage -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.PackageConstraint - ( PackageProperty(..) ) +module UnitTests.Distribution.Client.ProjectConfig (tests) where -import Distribution.Package - ( PackageName, PackageId, UnitId, packageId ) -import Distribution.Types.PackageVersionConstraint - ( PackageVersionConstraint(..) ) -import Distribution.System - ( Platform ) -import Distribution.Types.GenericPackageDescription - ( GenericPackageDescription ) -import Distribution.PackageDescription.Parsec - ( parseGenericPackageDescription ) -import Distribution.Fields - ( runParseResult, PError, PWarning, showPWarning) -import Distribution.Types.SourceRepo - ( RepoType(..) ) -import Distribution.Client.Types.SourceRepo - ( SourceRepoList, SourceRepositoryPackage (..), srpFanOut ) -import Distribution.Simple.Compiler - ( Compiler, compilerInfo ) -import Distribution.Simple.Program - ( ConfiguredProgram(..) ) -import Distribution.Simple.Setup - ( Flag(Flag), toFlag, flagToMaybe, flagToList - , fromFlag, fromFlagOrDefault ) -import Distribution.Client.Setup - ( defaultSolver, defaultMaxBackjumps ) -import Distribution.Simple.InstallDirs - ( PathTemplate, fromPathTemplate - , toPathTemplate, substPathTemplate, initialPathTemplateEnv ) -import Distribution.Simple.Utils - ( die', warn, notice, info, createDirectoryIfMissingVerbose, maybeExit, rawSystemIOWithEnv ) -import Distribution.Client.Utils - ( determineNumJobs ) -import Distribution.Utils.NubList - ( fromNubList ) -import Distribution.Verbosity - ( modifyVerbosity, verbose ) -import Distribution.Version - ( Version ) -import qualified Distribution.Deprecated.ParseUtils as OldParser - ( ParseResult(..), locatedErrorMsg, showPWarning ) -import Distribution.Client.SrcDist - ( packageDirToSdist ) - -import qualified Codec.Archive.Tar as Tar -import qualified Codec.Archive.Tar.Entry as Tar -import qualified Distribution.Client.Tar as Tar -import qualified Distribution.Client.GZipUtils as GZipUtils - -import Control.Monad.Trans (liftIO) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS +#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_) +import Data.List (intercalate, isPrefixOf, (\\)) +import Data.Map (Map) import qualified Data.Map as Map -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as Set -import qualified Data.Hashable as Hashable -import Numeric (showHex) - -import System.FilePath hiding (combine) -import System.IO - ( withBinaryFile, IOMode(ReadMode) ) -import System.Directory -import Network.URI - ( URI(..), URIAuth(..), parseAbsoluteURI, uriToString ) - - ----------------------------------------- --- Resolving configuration to settings --- - --- | Look up a 'PackageConfig' field in the 'ProjectConfig' for a specific --- 'PackageName'. This returns the configuration that applies to all local --- packages plus any package-specific configuration for this package. --- -lookupLocalPackageConfig - :: (Semigroup a, Monoid a) - => (PackageConfig -> a) -> ProjectConfig -> PackageName - -> a -lookupLocalPackageConfig field ProjectConfig { - projectConfigLocalPackages, - projectConfigSpecificPackage - } pkgname = - field projectConfigLocalPackages - <> maybe mempty field - (Map.lookup pkgname (getMapMappend projectConfigSpecificPackage)) - - --- | Use a 'RepoContext' based on the 'BuildTimeSettings'. --- -projectConfigWithBuilderRepoContext :: Verbosity - -> BuildTimeSettings - -> (RepoContext -> IO a) -> IO a -projectConfigWithBuilderRepoContext verbosity BuildTimeSettings{..} = - withRepoContext' - verbosity - buildSettingRemoteRepos - buildSettingLocalNoIndexRepos - buildSettingCacheDir - buildSettingHttpTransport - (Just buildSettingIgnoreExpiry) - buildSettingProgPathExtra - - --- | Use a 'RepoContext', but only for the solver. The solver does not use the --- full facilities of the 'RepoContext' so we can get away with making one --- that doesn't have an http transport. And that avoids having to have access --- to the 'BuildTimeSettings' --- -projectConfigWithSolverRepoContext - :: Verbosity -> ProjectConfigShared -> ProjectConfigBuildOnly - -> (RepoContext -> IO a) - -> IO a -projectConfigWithSolverRepoContext verbosity - ProjectConfigShared{..} - ProjectConfigBuildOnly{..} = - withRepoContext' - verbosity - (fromNubList projectConfigRemoteRepos) - (fromNubList projectConfigLocalNoIndexRepos) - (fromFlagOrDefault - (error - "projectConfigWithSolverRepoContext: projectConfigCacheDir") - projectConfigCacheDir) - (flagToMaybe projectConfigHttpTransport) - (flagToMaybe projectConfigIgnoreExpiry) - (fromNubList projectConfigProgPathExtra) - - --- | Resolve the project configuration, with all its optional fields, into --- 'SolverSettings' with no optional fields (by applying defaults). --- -resolveSolverSettings :: ProjectConfig -> SolverSettings -resolveSolverSettings ProjectConfig{ - projectConfigShared, - projectConfigLocalPackages, - projectConfigSpecificPackage - } = - SolverSettings {..} - where - --TODO: [required eventually] some of these settings need validation, e.g. - -- the flag assignments need checking. - solverSettingRemoteRepos = fromNubList projectConfigRemoteRepos - solverSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos - solverSettingConstraints = projectConfigConstraints - solverSettingPreferences = projectConfigPreferences - solverSettingFlagAssignment = packageConfigFlagAssignment projectConfigLocalPackages - solverSettingFlagAssignments = fmap packageConfigFlagAssignment - (getMapMappend projectConfigSpecificPackage) - solverSettingCabalVersion = flagToMaybe projectConfigCabalVersion - solverSettingSolver = fromFlag projectConfigSolver - solverSettingAllowOlder = fromMaybe mempty projectConfigAllowOlder - solverSettingAllowNewer = fromMaybe mempty projectConfigAllowNewer - solverSettingMaxBackjumps = case fromFlag projectConfigMaxBackjumps of - n | n < 0 -> Nothing - | otherwise -> Just n - solverSettingReorderGoals = fromFlag projectConfigReorderGoals - solverSettingCountConflicts = fromFlag projectConfigCountConflicts - solverSettingFineGrainedConflicts = fromFlag projectConfigFineGrainedConflicts - solverSettingMinimizeConflictSet = fromFlag projectConfigMinimizeConflictSet - solverSettingStrongFlags = fromFlag projectConfigStrongFlags - solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls - solverSettingOnlyConstrained = fromFlag projectConfigOnlyConstrained - solverSettingIndexState = flagToMaybe projectConfigIndexState - solverSettingActiveRepos = flagToMaybe projectConfigActiveRepos - solverSettingIndependentGoals = fromFlag projectConfigIndependentGoals - solverSettingPreferOldest = fromFlag projectConfigPreferOldest - --solverSettingShadowPkgs = fromFlag projectConfigShadowPkgs - --solverSettingReinstall = fromFlag projectConfigReinstall - --solverSettingAvoidReinstalls = fromFlag projectConfigAvoidReinstalls - --solverSettingOverrideReinstall = fromFlag projectConfigOverrideReinstall - --solverSettingUpgradeDeps = fromFlag projectConfigUpgradeDeps - - ProjectConfigShared {..} = defaults <> projectConfigShared - - defaults = mempty { - projectConfigSolver = Flag defaultSolver, - projectConfigAllowOlder = Just (AllowOlder mempty), - projectConfigAllowNewer = Just (AllowNewer mempty), - projectConfigMaxBackjumps = Flag defaultMaxBackjumps, - projectConfigReorderGoals = Flag (ReorderGoals False), - projectConfigCountConflicts = Flag (CountConflicts True), - projectConfigFineGrainedConflicts = Flag (FineGrainedConflicts True), - projectConfigMinimizeConflictSet = Flag (MinimizeConflictSet False), - projectConfigStrongFlags = Flag (StrongFlags False), - projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False), - projectConfigOnlyConstrained = Flag OnlyConstrainedNone, - projectConfigIndependentGoals = Flag (IndependentGoals False), - projectConfigPreferOldest = Flag (PreferOldest False) - --projectConfigShadowPkgs = Flag False, - --projectConfigReinstall = Flag False, - --projectConfigAvoidReinstalls = Flag False, - --projectConfigOverrideReinstall = Flag False, - --projectConfigUpgradeDeps = Flag False - } - +import Data.Maybe (fromMaybe) +import Network.URI (URI) +import System.Directory (canonicalizePath, withCurrentDirectory) +import System.FilePath +import System.IO.Unsafe (unsafePerformIO) --- | Resolve the project configuration, with all its optional fields, into --- 'BuildTimeSettings' with no optional fields (by applying defaults). --- -resolveBuildTimeSettings :: Verbosity - -> CabalDirLayout - -> ProjectConfig - -> BuildTimeSettings -resolveBuildTimeSettings verbosity - CabalDirLayout { - cabalLogsDirectory - } - ProjectConfig { - projectConfigShared = ProjectConfigShared { - projectConfigRemoteRepos, - projectConfigLocalNoIndexRepos, - projectConfigProgPathExtra - }, - projectConfigBuildOnly - } = - BuildTimeSettings {..} - where - buildSettingDryRun = fromFlag projectConfigDryRun - buildSettingOnlyDeps = fromFlag projectConfigOnlyDeps - buildSettingOnlyDownload = fromFlag projectConfigOnlyDownload - buildSettingSummaryFile = fromNubList projectConfigSummaryFile - --buildSettingLogFile -- defined below, more complicated - --buildSettingLogVerbosity -- defined below, more complicated - buildSettingBuildReports = fromFlag projectConfigBuildReports - buildSettingSymlinkBinDir = flagToList projectConfigSymlinkBinDir - buildSettingNumJobs = determineNumJobs projectConfigNumJobs - buildSettingKeepGoing = fromFlag projectConfigKeepGoing - buildSettingOfflineMode = fromFlag projectConfigOfflineMode - buildSettingKeepTempFiles = fromFlag projectConfigKeepTempFiles - buildSettingRemoteRepos = fromNubList projectConfigRemoteRepos - buildSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos - buildSettingCacheDir = fromFlag projectConfigCacheDir - buildSettingHttpTransport = flagToMaybe projectConfigHttpTransport - buildSettingIgnoreExpiry = fromFlag projectConfigIgnoreExpiry - buildSettingReportPlanningFailure - = fromFlag projectConfigReportPlanningFailure - buildSettingProgPathExtra = fromNubList projectConfigProgPathExtra - buildSettingHaddockOpen = False - - ProjectConfigBuildOnly{..} = defaults - <> projectConfigBuildOnly - - defaults = mempty { - projectConfigDryRun = toFlag False, - projectConfigOnlyDeps = toFlag False, - projectConfigOnlyDownload = toFlag False, - projectConfigBuildReports = toFlag NoReports, - projectConfigReportPlanningFailure = toFlag False, - projectConfigKeepGoing = toFlag False, - projectConfigOfflineMode = toFlag False, - projectConfigKeepTempFiles = toFlag False, - projectConfigIgnoreExpiry = toFlag False - } +import Distribution.Deprecated.ParseUtils +import qualified Distribution.Deprecated.ReadP as Parse - -- The logging logic: what log file to use and what verbosity. - -- - -- If the user has specified --remote-build-reporting=detailed, use the - -- default log file location. If the --build-log option is set, use the - -- provided location. Otherwise don't use logging, unless building in - -- parallel (in which case the default location is used). - -- - buildSettingLogFile :: Maybe (Compiler -> Platform - -> PackageId -> UnitId -> FilePath) - buildSettingLogFile - | useDefaultTemplate = Just (substLogFileName defaultTemplate) - | otherwise = fmap substLogFileName givenTemplate - - defaultTemplate = toPathTemplate $ - cabalLogsDirectory - "$compiler" "$libname" <.> "log" - givenTemplate = flagToMaybe projectConfigLogFile - - useDefaultTemplate - | buildSettingBuildReports == DetailedReports = True - | isJust givenTemplate = False - | isParallelBuild = True - | otherwise = False - - isParallelBuild = buildSettingNumJobs >= 2 - - substLogFileName :: PathTemplate - -> Compiler -> Platform - -> PackageId -> UnitId -> FilePath - substLogFileName template compiler platform pkgid uid = - fromPathTemplate (substPathTemplate env template) - where - env = initialPathTemplateEnv - pkgid uid (compilerInfo compiler) platform - - -- If the user has specified --remote-build-reporting=detailed or - -- --build-log, use more verbose logging. - -- - buildSettingLogVerbosity :: Verbosity - buildSettingLogVerbosity - | overrideVerbosity = modifyVerbosity (max verbose) verbosity - | otherwise = verbosity - - overrideVerbosity :: Bool - overrideVerbosity - | buildSettingBuildReports == DetailedReports = True - | isJust givenTemplate = True - | isParallelBuild = False - | otherwise = False - - ---------------------------------------------- --- Reading and writing project config files --- - --- | Find the root of this project. --- --- The project directory will be one of the following: --- 1. @mprojectDir@ when present --- 2. The first directory containing @mprojectFile@/@cabal.project@, starting from the current directory --- and recursively checking parent directories --- 3. The current directory --- -findProjectRoot - :: Verbosity - -> Maybe FilePath -- ^ Explicit project directory - -> Maybe FilePath -- ^ Explicit project file - -> IO (Either BadProjectRoot ProjectRoot) -findProjectRoot verbosity mprojectDir mprojectFile = do - case mprojectDir of - Nothing - | Just file <- mprojectFile, isAbsolute file -> do - warn verbosity $ - "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 - - | otherwise -> probeProjectRoot mprojectFile - - Just dir -> doesDirectoryExist dir >>= \case - False -> left (BadProjectRootDir dir) - True -> do - projectDir <- canonicalizePath dir - - case mprojectFile of - Nothing -> pure $ Right (ProjectRootExplicit projectDir defaultProjectFile) - - Just projectFile - | isAbsolute projectFile -> doesFileExist projectFile >>= \case - False -> left (BadProjectRootAbsoluteFile projectFile) - True -> Right . ProjectRootExplicitAbsolute dir <$> canonicalizePath projectFile - - | otherwise -> doesFileExist (projectDir projectFile) >>= \case - False -> left (BadProjectRootDirFile dir projectFile) - True -> projectRoot projectDir projectFile - where - left = pure . Left - - projectRoot projectDir projectFile = - pure $ Right (ProjectRootExplicit projectDir projectFile) - -probeProjectRoot :: Maybe FilePath -> IO (Either BadProjectRoot ProjectRoot) -probeProjectRoot mprojectFile = do - startdir <- getCurrentDirectory - homedir <- getHomeDirectory - probe startdir homedir - where - projectFileName :: String - projectFileName = fromMaybe defaultProjectFile mprojectFile +import Distribution.Compiler +import Distribution.Package +import Distribution.PackageDescription +import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Types +import Distribution.Simple.Utils (toUTF8BS) +import Distribution.Types.PackageVersionConstraint +import Distribution.Version - -- Search upwards. If we get to the users home dir or the filesystem root, - -- then use the current dir - probe :: FilePath -> String -> IO (Either BadProjectRoot ProjectRoot) - probe startdir homedir = go startdir - where - go :: FilePath -> IO (Either BadProjectRoot ProjectRoot) - go dir | isDrive dir || dir == homedir = - case mprojectFile of - Nothing -> return (Right (ProjectRootImplicit startdir)) - Just file -> return (Left (BadProjectRootExplicitFile file)) - go dir = do - exists <- doesFileExist (dir projectFileName) - if exists - then return (Right (ProjectRootExplicit dir projectFileName)) - else go (takeDirectory dir) - --- | 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 +import Distribution.Parsec +import Distribution.Pretty -instance Exception BadProjectRoot where -#if MIN_VERSION_base(4,8,0) - displayException = renderBadProjectRoot -#endif +import Distribution.Client.CmdInstall.ClientInstallFlags +import Distribution.Client.Dependency.Types +import Distribution.Client.DistDirLayout (defaultProjectFile) +import Distribution.Client.Targets +import Distribution.Client.Types +import Distribution.Client.Types.SourceRepo +import Distribution.Utils.NubList +import Distribution.Verbosity (silent) -renderBadProjectRoot :: BadProjectRoot -> String -renderBadProjectRoot = \case - BadProjectRootExplicitFile projectFile -> - "The given project file '" ++ projectFile ++ "' does not exist." - - BadProjectRootDir dir -> - "The given project directory '" <> dir <> "' does not exist." - - BadProjectRootAbsoluteFile file -> - "The given project file '" <> file <> "' does not exist." - - BadProjectRootDirFile dir file -> - "The given project directory/file combination '" <> dir file <> "' does not exist." - -withGlobalConfig - :: Verbosity -- ^ verbosity - -> Flag FilePath -- ^ @--cabal-config@ - -> (ProjectConfig -> IO a) -- ^ with global - -> IO a -withGlobalConfig verbosity gcf with = do - globalConfig <- runRebuild "" $ readGlobalConfig verbosity gcf - with globalConfig - -withProjectOrGlobalConfig - :: Verbosity -- ^ verbosity - -> Flag Bool -- ^ whether to ignore local project (--ignore-project flag) - -> Flag FilePath -- ^ @--cabal-config@ - -> IO a -- ^ with project - -> (ProjectConfig -> IO a) -- ^ without project - -> IO a -withProjectOrGlobalConfig verbosity (Flag True) gcf _with without = do - globalConfig <- runRebuild "" $ readGlobalConfig verbosity gcf - without globalConfig -withProjectOrGlobalConfig verbosity _ignorePrj gcf with without = - withProjectOrGlobalConfig' verbosity gcf with without - -withProjectOrGlobalConfig' - :: Verbosity - -> Flag FilePath - -> IO a - -> (ProjectConfig -> IO a) - -> IO a -withProjectOrGlobalConfig' verbosity globalConfigFlag with without = do - globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag - - catch with - $ \case - (BadPackageLocations prov locs) - | prov == Set.singleton Implicit - , let - isGlobErr (BadLocGlobEmptyMatch _) = True - isGlobErr _ = False - , any isGlobErr locs -> - without globalConfig - err -> throwIO err - --- | Read all the config relevant for a project. This includes the project --- file if any, plus other global config. --- -readProjectConfig :: Verbosity - -> HttpTransport - -> Flag Bool -- ^ @--ignore-project@ - -> Flag FilePath - -> DistDirLayout - -> Rebuild ProjectConfigSkeleton -readProjectConfig verbosity httpTransport ignoreProjectFlag configFileFlag distDirLayout = do - global <- singletonProjectConfigSkeleton <$> readGlobalConfig verbosity configFileFlag - local <- readProjectLocalConfigOrDefault verbosity httpTransport distDirLayout - freeze <- readProjectLocalFreezeConfig verbosity httpTransport distDirLayout - extra <- readProjectLocalExtraConfig verbosity httpTransport distDirLayout - if ignoreProjectFlag == Flag True then return (global <> (singletonProjectConfigSkeleton defaultProject)) - else return (global <> local <> freeze <> extra) - where - defaultProject :: ProjectConfig - defaultProject = mempty { - projectPackages = ["./"] - } +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.Settings --- | Reads an explicit @cabal.project@ file in the given project root dir, --- or returns the default project config for an implicitly defined project. --- -readProjectLocalConfigOrDefault :: Verbosity - -> HttpTransport - -> DistDirLayout - -> Rebuild ProjectConfigSkeleton -readProjectLocalConfigOrDefault verbosity httpTransport distDirLayout = do - usesExplicitProjectRoot <- liftIO $ doesFileExist projectFile - if usesExplicitProjectRoot - then do - readProjectFileSkeleton verbosity httpTransport distDirLayout "" "project file" - else do - monitorFiles [monitorNonExistentFile projectFile] - return (singletonProjectConfigSkeleton defaultImplicitProjectConfig) +import Distribution.Client.ProjectConfig +import Distribution.Client.ProjectConfig.Legacy +import UnitTests.Distribution.Client.ArbitraryInstances +import UnitTests.Distribution.Client.TreeDiffInstances () + +import Data.TreeDiff.Class +import Data.TreeDiff.QuickCheck +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +tests :: [TestTree] +tests = + [ testGroup "ProjectConfig <-> LegacyProjectConfig round trip" $ + [ testProperty "packages" prop_roundtrip_legacytypes_packages + , testProperty "buildonly" prop_roundtrip_legacytypes_buildonly + , testProperty "specific" prop_roundtrip_legacytypes_specific + ] + ++ + -- a couple tests seem to trigger a RTS fault in ghc-7.6 and older + -- unclear why as of yet + concat + [ [ testProperty "shared" prop_roundtrip_legacytypes_shared + , testProperty "local" prop_roundtrip_legacytypes_local + , testProperty "all" prop_roundtrip_legacytypes_all + ] + | not usingGhc76orOlder + ] + , testGroup + "individual parser tests" + [ testProperty "package location" prop_parsePackageLocationTokenQ + , testProperty "RelaxedDep" prop_roundtrip_printparse_RelaxedDep + , testProperty "RelaxDeps" prop_roundtrip_printparse_RelaxDeps + , testProperty "RelaxDeps'" prop_roundtrip_printparse_RelaxDeps' + ] + , testGroup + "ProjectConfig printing/parsing round trip" + [ testProperty "packages" prop_roundtrip_printparse_packages + , testProperty "buildonly" prop_roundtrip_printparse_buildonly + , testProperty "shared" prop_roundtrip_printparse_shared + , testProperty "local" prop_roundtrip_printparse_local + , testProperty "specific" prop_roundtrip_printparse_specific + , testProperty "all" prop_roundtrip_printparse_all + ] + , testFindProjectRoot + ] where - projectFile :: FilePath - projectFile = distProjectFile distDirLayout "" - defaultImplicitProjectConfig :: ProjectConfig - defaultImplicitProjectConfig = mempty { - -- We expect a package in the current directory. - projectPackages = [ "./*.cabal" ], - - projectConfigProvenance = Set.singleton Implicit - } - --- | Reads a @cabal.project.local@ file in the given project root dir, --- or returns empty. This file gets written by @cabal configure@, or in --- principle can be edited manually or by other tools. --- -readProjectLocalExtraConfig :: Verbosity -> HttpTransport -> DistDirLayout - -> Rebuild ProjectConfigSkeleton -readProjectLocalExtraConfig verbosity httpTransport distDirLayout = - readProjectFileSkeleton verbosity httpTransport distDirLayout "local" - "project local configuration file" - --- | Reads a @cabal.project.freeze@ file in the given project root dir, --- or returns empty. This file gets written by @cabal freeze@, or in --- principle can be edited manually or by other tools. --- -readProjectLocalFreezeConfig :: Verbosity -> HttpTransport ->DistDirLayout - -> Rebuild ProjectConfigSkeleton -readProjectLocalFreezeConfig verbosity httpTransport distDirLayout = - readProjectFileSkeleton verbosity httpTransport distDirLayout "freeze" - "project freeze file" - --- | Reads a named extended (with imports and conditionals) config file in the given project root dir, or returns empty. --- -readProjectFileSkeleton :: Verbosity -> HttpTransport -> DistDirLayout -> String -> String -> Rebuild ProjectConfigSkeleton -readProjectFileSkeleton verbosity httpTransport DistDirLayout{distProjectFile, distDownloadSrcDirectory} - extensionName extensionDescription = do - exists <- liftIO $ doesFileExist extensionFile - if exists - then do monitorFiles [monitorFileHashed extensionFile] - pcs <- liftIO readExtensionFile - monitorFiles $ map monitorFileHashed (projectSkeletonImports pcs) - pure pcs - else do monitorFiles [monitorNonExistentFile extensionFile] - return mempty + usingGhc76orOlder = + case buildCompilerId of + CompilerId GHC v -> v < mkVersion [7, 7] + _ -> False + +testFindProjectRoot :: TestTree +testFindProjectRoot = + testGroup + "findProjectRoot" + [ test "defaults" (cd dir) Nothing Nothing (succeeds dir file) + , test "defaults in lib" (cd libDir) Nothing Nothing (succeeds dir file) + , test "explicit file" (cd dir) Nothing (Just file) (succeeds dir file) + , 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) + , -- Deprecated use-case + test "absolute file" Nothing Nothing (Just absFile) (succeeds dir file) + , test "nested file" (cd dir) Nothing (Just nixFile) (succeeds dir nixFile) + , test "nested file in lib" (cd libDir) Nothing (Just nixFile) (succeeds dir nixFile) + , test "explicit dir" Nothing (Just dir) Nothing (succeeds dir file) + , test "explicit dir & file" Nothing (Just dir) (Just file) (succeeds dir file) + , test "explicit dir & nested file" Nothing (Just dir) (Just nixFile) (succeeds dir nixFile) + , test "explicit dir & nested other file" Nothing (Just dir) (Just nixOther) (succeeds dir nixOther) + , test "explicit dir & absolute file" Nothing (Just dir) (Just absFile) (succeedsWith ProjectRootExplicitAbsolute dir absFile) + ] where - extensionFile = distProjectFile extensionName + dir = fixturesDir "project-root" + libDir = dir "lib" - readExtensionFile = - reportParseResult verbosity extensionDescription extensionFile - =<< parseProjectSkeleton distDownloadSrcDirectory httpTransport verbosity [] extensionFile - =<< BS.readFile extensionFile + file = defaultProjectFile + fileOther = file <.> "other" + absFile = dir file --- | Render the 'ProjectConfig' format. --- --- For the moment this is implemented in terms of a pretty printer for the --- legacy configuration types, plus a conversion. --- -showProjectConfig :: ProjectConfig -> String -showProjectConfig = - showLegacyProjectConfig . convertToLegacyProjectConfig + nixFile = "nix" file + nixOther = nixFile <.> "other" + missing path = Just (path <.> "does_not_exist") --- | Write a @cabal.project.local@ file in the given project root dir. --- -writeProjectLocalExtraConfig :: DistDirLayout -> ProjectConfig -> IO () -writeProjectLocalExtraConfig DistDirLayout{distProjectFile} = - writeProjectConfigFile (distProjectFile "local") + test name wrap projectDir projectFile validate = + testCaseSteps name $ \step -> fromMaybe id wrap $ do + result <- findProjectRoot silent projectDir projectFile + _ <- validate result + when (isRight result) $ do + for_ projectDir $ \path -> do + step "missing project dir" + fails =<< findProjectRoot silent (missing path) projectFile --- | Write a @cabal.project.freeze@ file in the given project root dir. --- -writeProjectLocalFreezeConfig :: DistDirLayout -> ProjectConfig -> IO () -writeProjectLocalFreezeConfig DistDirLayout{distProjectFile} = - writeProjectConfigFile (distProjectFile "freeze") + for_ projectFile $ \path -> do + step "missing project file" + fails =<< findProjectRoot silent projectDir (missing path) + cd d = Just (withCurrentDirectory d) --- | Write in the @cabal.project@ format to the given file. --- -writeProjectConfigFile :: FilePath -> ProjectConfig -> IO () -writeProjectConfigFile file = - writeFile file . showProjectConfig + succeeds = succeedsWith ProjectRootExplicit + succeedsWith mk projectDir projectFile result = case result of + Left err -> assertFailure $ "Expected ProjectRoot, but found " <> show err + Right pr -> pr @?= mk projectDir projectFile --- | Read the user's cabal-install config file. --- -readGlobalConfig :: Verbosity -> Flag FilePath -> Rebuild ProjectConfig -readGlobalConfig verbosity configFileFlag = do - config <- liftIO (loadConfig verbosity configFileFlag) - configFile <- liftIO (getConfigFilePath configFileFlag) - monitorFiles [monitorFileHashed configFile] - return (convertLegacyGlobalConfig config) - -reportParseResult :: Verbosity -> String -> FilePath -> OldParser.ParseResult ProjectConfigSkeleton -> IO ProjectConfigSkeleton -reportParseResult verbosity _filetype filename (OldParser.ParseOk warnings x) = do - unless (null warnings) $ - let msg = unlines (map (OldParser.showPWarning (intercalate ", " $ filename : projectSkeletonImports x)) warnings) - in warn verbosity msg - return x -reportParseResult verbosity filetype filename (OldParser.ParseFailed err) = - let (line, msg) = OldParser.locatedErrorMsg err - in die' verbosity $ "Error parsing " ++ filetype ++ " " ++ filename - ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg - - ---------------------------------------------- --- Finding packages in the project --- + fails result = case result of + Left _ -> pure () + Right x -> assertFailure $ "Expected an error, but found " <> show x --- | The location of a package as part of a project. Local file paths are --- either absolute (if the user specified it as such) or they are relative --- to the project root. --- -data ProjectPackageLocation = - ProjectPackageLocalCabalFile FilePath - | ProjectPackageLocalDirectory FilePath FilePath -- dir and .cabal file - | ProjectPackageLocalTarball FilePath - | ProjectPackageRemoteTarball URI - | ProjectPackageRemoteRepo SourceRepoList - | ProjectPackageNamed PackageVersionConstraint - deriving Show +fixturesDir :: FilePath +fixturesDir = + unsafePerformIO $ + canonicalizePath ("tests" "fixtures") +{-# NOINLINE fixturesDir #-} - --- | Exception thrown by 'findProjectPackages'. +------------------------------------------------ +-- Round trip: conversion to/from legacy types -- -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 -instance Exception BadPackageLocations where -#if MIN_VERSION_base(4,8,0) - displayException = renderBadPackageLocations -#endif ---TODO: [nice to have] custom exception subclass for Doc rendering, colour etc - -data BadPackageLocation - = BadPackageLocationFile BadPackageLocationMatch - | BadLocGlobEmptyMatch String - | BadLocGlobBadMatches String [BadPackageLocationMatch] - | BadLocUnexpectedUriScheme String - | BadLocUnrecognisedUri String - | BadLocUnrecognised String - deriving Show - -data BadPackageLocationMatch - = BadLocUnexpectedFile String - | BadLocNonexistantFile String - | BadLocDirNoCabalFile String - | BadLocDirManyCabalFiles String - deriving Show - -renderBadPackageLocations :: BadPackageLocations -> String -renderBadPackageLocations (BadPackageLocations provenance bpls) - -- There is no provenance information, - -- render standard bad package error information. - | Set.null provenance = renderErrors renderBadPackageLocation - - -- The configuration is implicit, render bad package locations - -- using possibly specialized error messages. - | Set.singleton Implicit == provenance = - renderErrors renderImplicitBadPackageLocation - - -- The configuration contains both implicit and explicit provenance. - -- This should not occur, and a message is output to assist debugging. - | Implicit `Set.member` provenance = - "Warning: both implicit and explicit configuration is present." - ++ renderExplicit - - -- The configuration was read from one or more explicit path(s), - -- list the locations and render the bad package error information. - -- The intent is to supersede this with the relevant location information - -- per package error. - | otherwise = renderExplicit +roundtrip :: (Eq a, ToExpr a, Show b) => (a -> b) -> (b -> a) -> a -> Property +roundtrip f f_inv x = + counterexample (show y) $ + x `ediffEq` f_inv y -- no counterexample with y, as they not have ToExpr where - renderErrors f = unlines (map f bpls) - - renderExplicit = - "When using configuration(s) from " - ++ intercalate ", " (mapMaybe getExplicit (Set.toList provenance)) - ++ ", the following errors occurred:\n" - ++ renderErrors renderBadPackageLocation - - getExplicit (Explicit path) = Just path - getExplicit Implicit = Nothing - ---TODO: [nice to have] keep track of the config file (and src loc) packages --- were listed, to use in error messages - --- | Render bad package location error information for the implicit --- @cabal.project@ configuration. --- --- TODO: This is currently not fully realized, with only one of the implicit --- cases handled. More cases should be added with informative help text --- about the issues related specifically when having no project configuration --- is present. -renderImplicitBadPackageLocation :: BadPackageLocation -> String -renderImplicitBadPackageLocation bpl = case bpl of - BadLocGlobEmptyMatch pkglocstr -> - "No cabal.project file or cabal file matching the default glob '" - ++ pkglocstr ++ "' was found.\n" - ++ "Please create a package description file .cabal " - ++ "or a cabal.project file referencing the packages you " - ++ "want to build." - _ -> renderBadPackageLocation bpl - -renderBadPackageLocation :: BadPackageLocation -> String -renderBadPackageLocation bpl = case bpl of - BadPackageLocationFile badmatch -> - renderBadPackageLocationMatch badmatch - BadLocGlobEmptyMatch pkglocstr -> - "The package location glob '" ++ pkglocstr - ++ "' does not match any files or directories." - BadLocGlobBadMatches pkglocstr failures -> - "The package location glob '" ++ pkglocstr ++ "' does not match any " - ++ "recognised forms of package. " - ++ concatMap ((' ':) . renderBadPackageLocationMatch) failures - BadLocUnexpectedUriScheme pkglocstr -> - "The package location URI '" ++ pkglocstr ++ "' does not use a " - ++ "supported URI scheme. The supported URI schemes are http, https and " - ++ "file." - BadLocUnrecognisedUri pkglocstr -> - "The package location URI '" ++ pkglocstr ++ "' does not appear to " - ++ "be a valid absolute URI." - BadLocUnrecognised pkglocstr -> - "The package location syntax '" ++ pkglocstr ++ "' is not recognised." - -renderBadPackageLocationMatch :: BadPackageLocationMatch -> String -renderBadPackageLocationMatch bplm = case bplm of - BadLocUnexpectedFile pkglocstr -> - "The package location '" ++ pkglocstr ++ "' is not recognised. The " - ++ "supported file targets are .cabal files, .tar.gz tarballs or package " - ++ "directories (i.e. directories containing a .cabal file)." - BadLocNonexistantFile pkglocstr -> - "The package location '" ++ pkglocstr ++ "' does not exist." - BadLocDirNoCabalFile pkglocstr -> - "The package directory '" ++ pkglocstr ++ "' does not contain any " - ++ ".cabal file." - BadLocDirManyCabalFiles pkglocstr -> - "The package directory '" ++ pkglocstr ++ "' contains multiple " - ++ ".cabal files (which is not currently supported)." - --- | Given the project config, --- --- Throws 'BadPackageLocations'. --- -findProjectPackages :: DistDirLayout -> ProjectConfig - -> Rebuild [ProjectPackageLocation] -findProjectPackages DistDirLayout{distProjectRootDirectory} - ProjectConfig{..} = do + y = f x + +roundtrip_legacytypes :: ProjectConfig -> Property +roundtrip_legacytypes = + roundtrip + convertToLegacyProjectConfig + convertLegacyProjectConfig + +prop_roundtrip_legacytypes_all :: ProjectConfig -> Property +prop_roundtrip_legacytypes_all config = + roundtrip_legacytypes + config + { projectConfigProvenance = mempty + } - requiredPkgs <- findPackageLocations True projectPackages - optionalPkgs <- findPackageLocations False projectPackagesOptional - let repoPkgs = map ProjectPackageRemoteRepo projectPackagesRepo - namedPkgs = map ProjectPackageNamed projectPackagesNamed +prop_roundtrip_legacytypes_packages :: ProjectConfig -> Property +prop_roundtrip_legacytypes_packages config = + roundtrip_legacytypes + config + { projectConfigBuildOnly = mempty + , projectConfigShared = mempty + , projectConfigProvenance = mempty + , projectConfigLocalPackages = mempty + , projectConfigSpecificPackage = mempty + } - return (concat [requiredPkgs, optionalPkgs, repoPkgs, namedPkgs]) +prop_roundtrip_legacytypes_buildonly :: ProjectConfigBuildOnly -> Property +prop_roundtrip_legacytypes_buildonly config = + roundtrip_legacytypes + mempty{projectConfigBuildOnly = config} + +prop_roundtrip_legacytypes_shared :: ProjectConfigShared -> Property +prop_roundtrip_legacytypes_shared config = + roundtrip_legacytypes + mempty{projectConfigShared = config} + +prop_roundtrip_legacytypes_local :: PackageConfig -> Property +prop_roundtrip_legacytypes_local config = + roundtrip_legacytypes + mempty{projectConfigLocalPackages = config} + +prop_roundtrip_legacytypes_specific :: Map PackageName PackageConfig -> Property +prop_roundtrip_legacytypes_specific config = + roundtrip_legacytypes + mempty{projectConfigSpecificPackage = MapMappend config} + +-------------------------------------------- +-- Round trip: printing and parsing config +-- + +roundtrip_printparse :: ProjectConfig -> Property +roundtrip_printparse config = + case fmap convertLegacyProjectConfig (parseLegacyProjectConfig "unused" (toUTF8BS str)) of + ParseOk _ x -> + counterexample ("shown:\n" ++ str) $ + x `ediffEq` config{projectConfigProvenance = mempty} + ParseFailed err -> counterexample ("shown:\n" ++ str ++ "\nERROR: " ++ show err) False where - findPackageLocations :: Bool -> [String] -> Rebuild [ProjectPackageLocation] - findPackageLocations required pkglocstr = do - (problems, pkglocs) <- - partitionEithers <$> traverse (findPackageLocation required) pkglocstr - unless (null problems) $ - liftIO $ throwIO $ BadPackageLocations projectConfigProvenance problems - return (concat pkglocs) - - - findPackageLocation :: Bool -> String - -> Rebuild (Either BadPackageLocation - [ProjectPackageLocation]) - findPackageLocation _required@True pkglocstr = - -- strategy: try first as a file:// or http(s):// URL. - -- then as a file glob (usually encompassing single file) - -- finally as a single file, for files that fail to parse as globs - checkIsUriPackage pkglocstr - `mplusMaybeT` checkIsFileGlobPackage pkglocstr - `mplusMaybeT` checkIsSingleFilePackage pkglocstr - >>= maybe (return (Left (BadLocUnrecognised pkglocstr))) return - - - findPackageLocation _required@False pkglocstr = do - -- just globs for optional case - res <- checkIsFileGlobPackage pkglocstr - case res of - Nothing -> return (Left (BadLocUnrecognised pkglocstr)) - Just (Left _) -> return (Right []) -- it's optional - Just (Right pkglocs) -> return (Right pkglocs) - - - checkIsUriPackage, checkIsFileGlobPackage, checkIsSingleFilePackage - :: String -> Rebuild (Maybe (Either BadPackageLocation - [ProjectPackageLocation])) - checkIsUriPackage pkglocstr = - case parseAbsoluteURI pkglocstr of - Just uri@URI { - uriScheme = scheme, - uriAuthority = Just URIAuth { uriRegName = host }, - uriPath = path, - uriQuery = query, - uriFragment = frag - } - | recognisedScheme && not (null host) -> - return (Just (Right [ProjectPackageRemoteTarball uri])) - - | scheme == "file:" && null host && null query && null frag -> - checkIsSingleFilePackage path - - | not recognisedScheme && not (null host) -> - return (Just (Left (BadLocUnexpectedUriScheme pkglocstr))) - - | recognisedScheme && null host -> - return (Just (Left (BadLocUnrecognisedUri pkglocstr))) - where - recognisedScheme = scheme == "http:" || scheme == "https:" - || scheme == "file:" - - _ -> return Nothing - - - checkIsFileGlobPackage pkglocstr = - case simpleParsec pkglocstr of - Nothing -> return Nothing - Just glob -> liftM Just $ do - matches <- matchFileGlob glob - case matches of - [] | isJust (isTrivialFilePathGlob glob) - -> return (Left (BadPackageLocationFile - (BadLocNonexistantFile pkglocstr))) - - [] -> return (Left (BadLocGlobEmptyMatch pkglocstr)) - - _ -> do - (failures, pkglocs) <- partitionEithers <$> - traverse checkFilePackageMatch matches - return $! case (failures, pkglocs) of - ([failure], []) | isJust (isTrivialFilePathGlob glob) - -> Left (BadPackageLocationFile failure) - (_, []) -> Left (BadLocGlobBadMatches pkglocstr failures) - _ -> Right pkglocs - - - checkIsSingleFilePackage pkglocstr = do - let filename = distProjectRootDirectory pkglocstr - isFile <- liftIO $ doesFileExist filename - isDir <- liftIO $ doesDirectoryExist filename - if isFile || isDir - then checkFilePackageMatch pkglocstr - >>= either (return . Just . Left . BadPackageLocationFile) - (return . Just . Right . (\x->[x])) - else return Nothing - - - checkFilePackageMatch :: String -> Rebuild (Either BadPackageLocationMatch - ProjectPackageLocation) - checkFilePackageMatch pkglocstr = do - -- The pkglocstr may be absolute or may be relative to the project root. - -- Either way, does the right thing here. We return relative paths if - -- they were relative in the first place. - let abspath = distProjectRootDirectory pkglocstr - isFile <- liftIO $ doesFileExist abspath - isDir <- liftIO $ doesDirectoryExist abspath - parentDirExists <- case takeDirectory abspath of - [] -> return False - dir -> liftIO $ doesDirectoryExist dir - case () of - _ | isDir - -> do matches <- matchFileGlob (globStarDotCabal pkglocstr) - case matches of - [cabalFile] - -> return (Right (ProjectPackageLocalDirectory - pkglocstr cabalFile)) - [] -> return (Left (BadLocDirNoCabalFile pkglocstr)) - _ -> return (Left (BadLocDirManyCabalFiles pkglocstr)) - - | extensionIsTarGz pkglocstr - -> return (Right (ProjectPackageLocalTarball pkglocstr)) - - | takeExtension pkglocstr == ".cabal" - -> return (Right (ProjectPackageLocalCabalFile pkglocstr)) - - | isFile - -> return (Left (BadLocUnexpectedFile pkglocstr)) - - | parentDirExists - -> return (Left (BadLocNonexistantFile pkglocstr)) - - | otherwise - -> return (Left (BadLocUnexpectedFile pkglocstr)) - - - extensionIsTarGz f = takeExtension f == ".gz" - && takeExtension (dropExtension f) == ".tar" - - --- | A glob to find all the cabal files in a directory. --- --- For a directory @some/dir/@, this is a glob of the form @some/dir/\*.cabal@. --- The directory part can be either absolute or relative. --- -globStarDotCabal :: FilePath -> FilePathGlob -globStarDotCabal dir = - FilePathGlob - (if isAbsolute dir then FilePathRoot root else FilePathRelative) - (foldr (\d -> GlobDir [Literal d]) - (GlobFile [WildCard, Literal ".cabal"]) dirComponents) - where - (root, dirComponents) = fmap splitDirectories (splitDrive dir) - - ---TODO: [code cleanup] use sufficiently recent transformers package -mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a) -mplusMaybeT ma mb = do - mx <- ma - case mx of - Nothing -> mb - Just x -> return (Just x) + str :: String + str = showLegacyProjectConfig (convertToLegacyProjectConfig config) + +prop_roundtrip_printparse_all :: ProjectConfig -> Property +prop_roundtrip_printparse_all config = + roundtrip_printparse + config + { projectConfigBuildOnly = + hackProjectConfigBuildOnly (projectConfigBuildOnly config) + , projectConfigShared = + hackProjectConfigShared (projectConfigShared config) + } +prop_roundtrip_printparse_packages + :: [PackageLocationString] + -> [PackageLocationString] + -> [SourceRepoList] + -> [PackageVersionConstraint] + -> Property +prop_roundtrip_printparse_packages pkglocstrs1 pkglocstrs2 repos named = + roundtrip_printparse + mempty + { projectPackages = map getPackageLocationString pkglocstrs1 + , projectPackagesOptional = map getPackageLocationString pkglocstrs2 + , projectPackagesRepo = repos + , projectPackagesNamed = named + } -------------------------------------------------- --- Fetching and reading packages in the project --- +prop_roundtrip_printparse_buildonly :: ProjectConfigBuildOnly -> Property +prop_roundtrip_printparse_buildonly config = + roundtrip_printparse + mempty + { projectConfigBuildOnly = hackProjectConfigBuildOnly config + } --- | Read the @.cabal@ files for a set of packages. For remote tarballs and --- VCS source repos this also fetches them if needed. --- --- Note here is where we convert from project-root relative paths to absolute --- paths. --- -fetchAndReadSourcePackages - :: Verbosity - -> DistDirLayout - -> ProjectConfigShared - -> ProjectConfigBuildOnly - -> [ProjectPackageLocation] - -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] -fetchAndReadSourcePackages verbosity distDirLayout - projectConfigShared - projectConfigBuildOnly - pkgLocations = do - - pkgsLocalDirectory <- - sequenceA - [ readSourcePackageLocalDirectory verbosity dir cabalFile - | location <- pkgLocations - , (dir, cabalFile) <- projectPackageLocal location ] - - pkgsLocalTarball <- - sequenceA - [ readSourcePackageLocalTarball verbosity path - | ProjectPackageLocalTarball path <- pkgLocations ] - - pkgsRemoteTarball <- do - getTransport <- delayInitSharedResource $ - configureTransport verbosity progPathExtra - preferredHttpTransport - sequenceA - [ fetchAndReadSourcePackageRemoteTarball verbosity distDirLayout - getTransport uri - | ProjectPackageRemoteTarball uri <- pkgLocations ] - - pkgsRemoteRepo <- - syncAndReadSourcePackagesRemoteRepos - verbosity distDirLayout - projectConfigShared - [ repo | ProjectPackageRemoteRepo repo <- pkgLocations ] - - let pkgsNamed = - [ NamedPackage pkgname [PackagePropertyVersion verrange] - | ProjectPackageNamed (PackageVersionConstraint pkgname verrange) <- pkgLocations ] - - return $ concat - [ pkgsLocalDirectory - , pkgsLocalTarball - , pkgsRemoteTarball - , pkgsRemoteRepo - , pkgsNamed - ] - where - projectPackageLocal (ProjectPackageLocalDirectory dir file) = [(dir, file)] - projectPackageLocal (ProjectPackageLocalCabalFile file) = [(dir, file)] - where dir = takeDirectory file - projectPackageLocal _ = [] - - progPathExtra = fromNubList (projectConfigProgPathExtra projectConfigShared) - preferredHttpTransport = - flagToMaybe (projectConfigHttpTransport projectConfigBuildOnly) - --- | A helper for 'fetchAndReadSourcePackages' to handle the case of --- 'ProjectPackageLocalDirectory' and 'ProjectPackageLocalCabalFile'. --- We simply read the @.cabal@ file. --- -readSourcePackageLocalDirectory - :: Verbosity - -> FilePath -- ^ The package directory - -> FilePath -- ^ The package @.cabal@ file - -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) -readSourcePackageLocalDirectory verbosity dir cabalFile = do - monitorFiles [monitorFileHashed cabalFile] - root <- askRoot - let location = LocalUnpackedPackage (root dir) - liftIO $ fmap (mkSpecificSourcePackage location) - . readSourcePackageCabalFile verbosity cabalFile - =<< BS.readFile (root cabalFile) - - --- | A helper for 'fetchAndReadSourcePackages' to handle the case of --- 'ProjectPackageLocalTarball'. We scan through the @.tar.gz@ file to find --- the @.cabal@ file and read that. --- -readSourcePackageLocalTarball - :: Verbosity - -> FilePath - -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) -readSourcePackageLocalTarball verbosity tarballFile = do - monitorFiles [monitorFile tarballFile] - root <- askRoot - let location = LocalTarballPackage (root tarballFile) - liftIO $ fmap (mkSpecificSourcePackage location) - . uncurry (readSourcePackageCabalFile verbosity) - =<< extractTarballPackageCabalFile (root tarballFile) - --- | A helper for 'fetchAndReadSourcePackages' to handle the case of --- 'ProjectPackageRemoteTarball'. We download the tarball to the dist src dir --- and after that handle it like the local tarball case. --- -fetchAndReadSourcePackageRemoteTarball - :: Verbosity - -> DistDirLayout - -> Rebuild HttpTransport - -> URI - -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) -fetchAndReadSourcePackageRemoteTarball verbosity - DistDirLayout { - distDownloadSrcDirectory - } - getTransport - tarballUri = - -- The tarball download is expensive so we use another layer of file - -- monitor to avoid it whenever possible. - rerunIfChanged verbosity monitor tarballUri $ do - - -- Download - transport <- getTransport - liftIO $ do - transportCheckHttps verbosity transport tarballUri - notice verbosity ("Downloading " ++ show tarballUri) - createDirectoryIfMissingVerbose verbosity True - distDownloadSrcDirectory - _ <- downloadURI transport verbosity tarballUri tarballFile - return () - - -- Read - monitorFiles [monitorFile tarballFile] - let location = RemoteTarballPackage tarballUri tarballFile - liftIO $ fmap (mkSpecificSourcePackage location) - . uncurry (readSourcePackageCabalFile verbosity) - =<< extractTarballPackageCabalFile tarballFile - where - tarballStem :: FilePath - tarballStem = distDownloadSrcDirectory - localFileNameForRemoteTarball tarballUri - tarballFile :: FilePath - tarballFile = tarballStem <.> "tar.gz" +hackProjectConfigBuildOnly :: ProjectConfigBuildOnly -> ProjectConfigBuildOnly +hackProjectConfigBuildOnly config = + config + { -- These fields are only command line transitory things, not + -- something to be recorded persistently in a config file + projectConfigOnlyDeps = mempty + , projectConfigOnlyDownload = mempty + , projectConfigDryRun = mempty + } - monitor :: FileMonitor URI (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) - monitor = newFileMonitor (tarballStem <.> "cache") +prop_roundtrip_printparse_shared :: ProjectConfigShared -> Property +prop_roundtrip_printparse_shared config = + roundtrip_printparse + mempty + { projectConfigShared = hackProjectConfigShared config + } +hackProjectConfigShared :: ProjectConfigShared -> ProjectConfigShared +hackProjectConfigShared config = + config + { projectConfigProjectFile = mempty -- not present within project files + , projectConfigProjectDir = mempty -- ditto + , projectConfigConfigFile = mempty -- ditto + , projectConfigConstraints = + -- TODO: [required eventually] parse ambiguity in constraint + -- "pkgname -any" as either any version or disabled flag "any". + let ambiguous (UserConstraint _ (PackagePropertyFlags flags), _) = + (not . null) + [ () | (name, False) <- unFlagAssignment flags, "any" `isPrefixOf` unFlagName name + ] + ambiguous _ = False + in filter (not . ambiguous) (projectConfigConstraints config) + } --- | A helper for 'fetchAndReadSourcePackages' to handle all the cases of --- 'ProjectPackageRemoteRepo'. --- -syncAndReadSourcePackagesRemoteRepos - :: Verbosity - -> DistDirLayout - -> ProjectConfigShared - -> [SourceRepoList] - -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] -syncAndReadSourcePackagesRemoteRepos verbosity - DistDirLayout{distDownloadSrcDirectory} - ProjectConfigShared { - projectConfigProgPathExtra - } - repos = do - - repos' <- either reportSourceRepoProblems return $ - validateSourceRepos repos - - -- All 'SourceRepo's grouped by referring to the "same" remote repo - -- instance. So same location but can differ in commit/tag/branch/subdir. - let reposByLocation :: Map (RepoType, String) - [(SourceRepoList, RepoType)] - reposByLocation = Map.fromListWith (++) - [ ((rtype, rloc), [(repo, vcsRepoType vcs)]) - | (repo, rloc, rtype, vcs) <- repos' ] - - --TODO: pass progPathExtra on to 'configureVCS' - let _progPathExtra = fromNubList projectConfigProgPathExtra - getConfiguredVCS <- delayInitSharedResources $ \repoType -> - let vcs = Map.findWithDefault (error $ "Unknown VCS: " ++ prettyShow repoType) repoType knownVCSs in - configureVCS verbosity {-progPathExtra-} vcs - - concat <$> sequenceA - [ rerunIfChanged verbosity monitor repoGroup' $ do - vcs' <- getConfiguredVCS repoType - syncRepoGroupAndReadSourcePackages vcs' pathStem repoGroup' - | repoGroup@((primaryRepo, repoType):_) <- Map.elems reposByLocation - , let repoGroup' = map fst repoGroup - pathStem = distDownloadSrcDirectory - localFileNameForRemoteRepo primaryRepo - monitor :: FileMonitor - [SourceRepoList] - [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] - monitor = newFileMonitor (pathStem <.> "cache") - ] - where - syncRepoGroupAndReadSourcePackages - :: VCS ConfiguredProgram - -> FilePath - -> [SourceRepoList] - -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] - syncRepoGroupAndReadSourcePackages vcs pathStem repoGroup = do - liftIO $ createDirectoryIfMissingVerbose verbosity False - distDownloadSrcDirectory - - -- For syncing we don't care about different 'SourceRepo' values that - -- are just different subdirs in the same repo. - syncSourceRepos verbosity vcs - [ (repo, repoPath) - | (repo, _, repoPath) <- repoGroupWithPaths ] - - -- Run post-checkout-command if it is specified - for_ repoGroupWithPaths $ \(repo, _, repoPath) -> - for_ (nonEmpty (srpCommand repo)) $ \(cmd :| args) -> liftIO $ do - maybeExit $ rawSystemIOWithEnv verbosity cmd args (Just repoPath) Nothing Nothing Nothing Nothing - - -- But for reading we go through each 'SourceRepo' including its subdir - -- value and have to know which path each one ended up in. - sequenceA - [ readPackageFromSourceRepo repoWithSubdir repoPath - | (_, reposWithSubdir, repoPath) <- repoGroupWithPaths - , repoWithSubdir <- NE.toList reposWithSubdir ] - where - -- So to do both things above, we pair them up here. - repoGroupWithPaths - :: [(SourceRepositoryPackage Proxy, NonEmpty (SourceRepositoryPackage Maybe), FilePath)] - repoGroupWithPaths = - zipWith (\(x, y) z -> (x,y,z)) - (mapGroup - [ (repo { srpSubdir = Proxy }, repo) - | repo <- foldMap (NE.toList . srpFanOut) repoGroup - ]) - repoPaths - - mapGroup :: Ord k => [(k, v)] -> [(k, NonEmpty v)] - mapGroup = Map.toList . Map.fromListWith (<>) . map (\(k, v) -> (k, pure v)) - - -- The repos in a group are given distinct names by simple enumeration - -- foo, foo-2, foo-3 etc - repoPaths :: [FilePath] - repoPaths = pathStem - : [ pathStem ++ "-" ++ show (i :: Int) | i <- [2..] ] - - readPackageFromSourceRepo - :: SourceRepositoryPackage Maybe - -> FilePath - -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) - readPackageFromSourceRepo repo repoPath = do - let packageDir :: FilePath - packageDir = maybe repoPath (repoPath ) (srpSubdir repo) - - entries <- liftIO $ getDirectoryContents packageDir - --TODO: dcoutts 2018-06-23: wrap exceptions - case filter (\e -> takeExtension e == ".cabal") entries of - [] -> liftIO $ throwIO $ NoCabalFileFound packageDir - (_:_:_) -> liftIO $ throwIO $ MultipleCabalFilesFound packageDir - [cabalFileName] -> do - let cabalFilePath = packageDir cabalFileName - monitorFiles [monitorFileHashed cabalFilePath] - gpd <- liftIO $ readSourcePackageCabalFile verbosity cabalFilePath =<< BS.readFile cabalFilePath - - -- write sdist tarball, to repoPath-pgkid - tarball <- liftIO $ packageDirToSdist verbosity gpd packageDir - let tarballPath = repoPath ++ "-" ++ prettyShow (packageId gpd) ++ ".tar.gz" - liftIO $ LBS.writeFile tarballPath tarball - - let location = RemoteSourceRepoPackage repo tarballPath - return $ mkSpecificSourcePackage location gpd - - reportSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> Rebuild a - reportSourceRepoProblems = liftIO . die' verbosity . renderSourceRepoProblems - - renderSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> String - renderSourceRepoProblems = unlines . map show -- "TODO: the repo problems" - - --- | Utility used by all the helpers of 'fetchAndReadSourcePackages' to make an --- appropriate @'PackageSpecifier' ('SourcePackage' (..))@ for a given package --- from a given location. --- -mkSpecificSourcePackage :: PackageLocation FilePath - -> GenericPackageDescription - -> PackageSpecifier (SourcePackage UnresolvedPkgLoc) -mkSpecificSourcePackage location pkg = - SpecificSourcePackage SourcePackage - { srcpkgPackageId = packageId pkg - , srcpkgDescription = pkg - , srcpkgSource = fmap Just location - , srcpkgDescrOverride = Nothing +prop_roundtrip_printparse_local :: PackageConfig -> Property +prop_roundtrip_printparse_local config = + roundtrip_printparse + mempty + { projectConfigLocalPackages = config } +prop_roundtrip_printparse_specific + :: Map PackageName (NonMEmpty PackageConfig) + -> Property +prop_roundtrip_printparse_specific config = + roundtrip_printparse + mempty + { projectConfigSpecificPackage = MapMappend (fmap getNonMEmpty config) + } --- | Errors reported upon failing to parse a @.cabal@ file. +---------------------------- +-- Individual Parser tests -- -data CabalFileParseError = CabalFileParseError - FilePath -- ^ @.cabal@ file path - BS.ByteString -- ^ @.cabal@ file contents - (NonEmpty PError) -- ^ errors - (Maybe Version) -- ^ We might discover the spec version the package needs - [PWarning] -- ^ warnings - deriving (Typeable) - --- | Manual instance which skips file contents -instance Show CabalFileParseError where - showsPrec d (CabalFileParseError fp _ es mv ws) = showParen (d > 10) - $ showString "CabalFileParseError" - . showChar ' ' . showsPrec 11 fp - . showChar ' ' . showsPrec 11 ("" :: String) - . showChar ' ' . showsPrec 11 es - . showChar ' ' . showsPrec 11 mv - . showChar ' ' . showsPrec 11 ws - -instance Exception CabalFileParseError -#if MIN_VERSION_base(4,8,0) - where - displayException = renderCabalFileParseError -#endif -renderCabalFileParseError :: CabalFileParseError -> String -renderCabalFileParseError (CabalFileParseError filePath contents errors _ warnings) = - renderParseError filePath contents errors warnings - --- | Wrapper for the @.cabal@ file parser. It reports warnings on higher --- verbosity levels and throws 'CabalFileParseError' on failure. +-- | Helper to parse a given string -- -readSourcePackageCabalFile :: Verbosity - -> FilePath - -> BS.ByteString - -> IO GenericPackageDescription -readSourcePackageCabalFile verbosity pkgfilename content = - case runParseResult (parseGenericPackageDescription content) of - (warnings, Right pkg) -> do - unless (null warnings) $ - info verbosity (formatWarnings warnings) - return pkg - - (warnings, Left (mspecVersion, errors)) -> - throwIO $ CabalFileParseError pkgfilename content errors mspecVersion warnings - where - formatWarnings warnings = - "The package description file " ++ pkgfilename - ++ " has warnings: " - ++ unlines (map (showPWarning pkgfilename) warnings) +-- Succeeds only if there is a unique complete parse +runReadP :: Parse.ReadP a a -> String -> Maybe a +runReadP parser s = case [x | (x, "") <- Parse.readP_to_S parser s] of + [x'] -> Just x' + _ -> Nothing +prop_parsePackageLocationTokenQ :: PackageLocationString -> Bool +prop_parsePackageLocationTokenQ (PackageLocationString str) = + runReadP parsePackageLocationTokenQ (renderPackageLocationToken str) == Just str --- | When looking for a package's @.cabal@ file we can find none, or several, --- both of which are failures. --- -data CabalFileSearchFailure - = NoCabalFileFound FilePath - | MultipleCabalFilesFound FilePath - deriving (Show, Typeable) - -instance Exception CabalFileSearchFailure +prop_roundtrip_printparse_RelaxedDep :: RelaxedDep -> Property +prop_roundtrip_printparse_RelaxedDep rdep = + counterexample (prettyShow rdep) $ + eitherParsec (prettyShow rdep) == Right rdep +prop_roundtrip_printparse_RelaxDeps :: RelaxDeps -> Property +prop_roundtrip_printparse_RelaxDeps rdep = + counterexample (prettyShow rdep) $ + Right rdep `ediffEq` eitherParsec (prettyShow rdep) --- | Find the @.cabal@ file within a tarball file and return it by value. --- --- Can fail with a 'Tar.FormatError' or 'CabalFileSearchFailure' exception. --- -extractTarballPackageCabalFile :: FilePath -> IO (FilePath, BS.ByteString) -extractTarballPackageCabalFile tarballFile = - withBinaryFile tarballFile ReadMode $ \hnd -> do - content <- LBS.hGetContents hnd - case extractTarballPackageCabalFilePure tarballFile content of - Left (Left e) -> throwIO e - Left (Right e) -> throwIO e - Right (fileName, fileContent) -> - (,) fileName <$> evaluate (LBS.toStrict fileContent) - - --- | Scan through a tar file stream and collect the @.cabal@ file, or fail. --- -extractTarballPackageCabalFilePure :: FilePath - -> LBS.ByteString - -> Either (Either Tar.FormatError - CabalFileSearchFailure) - (FilePath, LBS.ByteString) -extractTarballPackageCabalFilePure tarballFile = - check - . accumEntryMap - . Tar.filterEntries isCabalFile - . Tar.read - . GZipUtils.maybeDecompress +prop_roundtrip_printparse_RelaxDeps' :: RelaxDeps -> Property +prop_roundtrip_printparse_RelaxDeps' rdep = + counterexample rdep' $ + Right rdep `ediffEq` eitherParsec rdep' where - accumEntryMap = Tar.foldlEntries - (\m e -> Map.insert (Tar.entryTarPath e) e m) - Map.empty - - check (Left (e, _m)) = Left (Left e) - check (Right m) = case Map.elems m of - [] -> Left (Right $ NoCabalFileFound tarballFile) - [file] -> case Tar.entryContent file of - Tar.NormalFile content _ -> Right (Tar.entryPath file, content) - _ -> Left (Right $ NoCabalFileFound tarballFile) - _files -> Left (Right $ MultipleCabalFilesFound tarballFile) - - isCabalFile e = case splitPath (Tar.entryPath e) of - [ _dir, file] -> takeExtension file == ".cabal" - [".", _dir, file] -> takeExtension file == ".cabal" - _ -> False - - --- | The name to use for a local file for a remote tarball 'SourceRepo'. --- This is deterministic based on the remote tarball URI, and is intended --- to produce non-clashing file names for different tarballs. --- -localFileNameForRemoteTarball :: URI -> FilePath -localFileNameForRemoteTarball uri = - mangleName uri - ++ "-" ++ showHex locationHash "" - where - mangleName = truncateString 10 . dropExtension . dropExtension - . takeFileName . dropTrailingPathSeparator . uriPath - - locationHash :: Word - locationHash = fromIntegral (Hashable.hash (uriToString id uri "")) - + rdep' = go (prettyShow rdep) + + -- replace 'all' tokens by '*' + go :: String -> String + go [] = [] + go "all" = "*" + go ('a' : 'l' : 'l' : c : rest) | c `elem` ":," = '*' : go (c : rest) + go rest = + let (x, y) = break (`elem` ":,") rest + (x', y') = span (`elem` ":,^") y + in x ++ x' ++ go y' + +------------------------ +-- Arbitrary instances +-- + +instance Arbitrary ProjectConfig where + arbitrary = + ProjectConfig + <$> (map getPackageLocationString <$> arbitrary) + <*> (map getPackageLocationString <$> arbitrary) + <*> shortListOf 3 arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> ( MapMappend . fmap getNonMEmpty . Map.fromList + <$> shortListOf 3 arbitrary + ) + + -- package entries with no content are equivalent to + -- the entry not existing at all, so exclude empty + + shrink + ProjectConfig + { projectPackages = x0 + , projectPackagesOptional = x1 + , projectPackagesRepo = x2 + , projectPackagesNamed = x3 + , projectConfigBuildOnly = x4 + , projectConfigShared = x5 + , projectConfigProvenance = x6 + , projectConfigLocalPackages = x7 + , projectConfigSpecificPackage = x8 + , projectConfigAllPackages = x9 + } = + [ ProjectConfig + { projectPackages = x0' + , projectPackagesOptional = x1' + , projectPackagesRepo = x2' + , projectPackagesNamed = x3' + , projectConfigBuildOnly = x4' + , projectConfigShared = x5' + , projectConfigProvenance = x6' + , projectConfigLocalPackages = x7' + , projectConfigSpecificPackage = + ( MapMappend + (fmap getNonMEmpty x8') + ) + , projectConfigAllPackages = x9' + } + | ((x0', x1', x2', x3'), (x4', x5', x6', x7', x8', x9')) <- + shrink + ( (x0, x1, x2, x3) + , (x4, x5, x6, x7, fmap NonMEmpty (getMapMappend x8), x9) + ) + ] --- | 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 "" +newtype PackageLocationString = PackageLocationString {getPackageLocationString :: String} + deriving (Show) + +instance Arbitrary PackageLocationString where + arbitrary = + PackageLocationString + <$> oneof + [ show . getNonEmpty <$> (arbitrary :: Gen (NonEmptyList String)) + , arbitraryGlobLikeStr + , show <$> (arbitrary :: Gen URI) + ] + `suchThat` (\xs -> not ("{" `isPrefixOf` xs)) + +arbitraryGlobLikeStr :: Gen String +arbitraryGlobLikeStr = outerTerm where - mangleName = truncateString 10 . dropExtension - . takeFileName . dropTrailingPathSeparator - - -- just the parts that make up the "identity" of the repo - locationHash :: Word - locationHash = - fromIntegral (Hashable.hash (show srpType, srpLocation)) - - --- | Truncate a string, with a visual indication that it is truncated. -truncateString :: Int -> String -> String -truncateString n s | length s <= n = s - | otherwise = take (n-1) s ++ "_" - - --- TODO: add something like this, here or in the project planning --- Based on the package location, which packages will be built inplace in the --- build tree vs placed in the store. This has various implications on what we --- can do with the package, e.g. can we run tests, ghci etc. --- --- packageIsLocalToProject :: ProjectPackageLocation -> Bool - - ---------------------------------------------- --- Checking configuration sanity --- - -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 - -instance Exception BadPerPackageCompilerPaths where -#if MIN_VERSION_base(4,8,0) - displayException = renderBadPerPackageCompilerPaths -#endif ---TODO: [nice to have] custom exception subclass for Doc rendering, colour etc - -renderBadPerPackageCompilerPaths :: BadPerPackageCompilerPaths -> String -renderBadPerPackageCompilerPaths - (BadPerPackageCompilerPaths ((pkgname, progname) : _)) = - "The path to the compiler program (or programs used by the compiler) " - ++ "cannot be specified on a per-package basis in the cabal.project file " - ++ "(i.e. setting the '" ++ progname ++ "-location' for package '" - ++ prettyShow pkgname ++ "'). All packages have to use the same compiler, so " - ++ "specify the path in a global 'program-locations' section." - --TODO: [nice to have] better format control so we can pretty-print the - -- offending part of the project file. Currently the line wrapping breaks any - -- formatting. -renderBadPerPackageCompilerPaths _ = error "renderBadPerPackageCompilerPaths" - --- | The project configuration is not allowed to specify program locations for --- programs used by the compiler as these have to be the same for each set of --- packages. --- --- We cannot check this until we know which programs the compiler uses, which --- in principle is not until we've configured the compiler. --- --- Throws 'BadPerPackageCompilerPaths' --- -checkBadPerPackageCompilerPaths :: [ConfiguredProgram] - -> Map PackageName PackageConfig - -> IO () -checkBadPerPackageCompilerPaths compilerPrograms packagesConfig = - case [ (pkgname, progname) - | let compProgNames = Set.fromList (map programId compilerPrograms) - , (pkgname, pkgconf) <- Map.toList packagesConfig - , progname <- Map.keys (getMapLast (packageConfigProgramPaths pkgconf)) - , progname `Set.member` compProgNames ] of - [] -> return () - ps -> throwIO (BadPerPackageCompilerPaths ps) + outerTerm = + concat + <$> shortListOf1 + 4 + ( frequency + [ (2, token) + , (1, braces <$> innerTerm) + ] + ) + innerTerm = + intercalate "," + <$> shortListOf1 + 3 + ( frequency + [ (3, token) + , (1, braces <$> innerTerm) + ] + ) + token = shortListOf1 4 (elements (['#' .. '~'] \\ "{,}")) + braces s = "{" ++ s ++ "}" + +instance Arbitrary ClientInstallFlags where + arbitrary = + ClientInstallFlags + <$> arbitrary + <*> arbitraryFlag arbitraryShortToken + <*> arbitrary + <*> arbitrary + <*> arbitraryFlag arbitraryShortToken + +instance Arbitrary ProjectConfigBuildOnly where + arbitrary = + ProjectConfigBuildOnly + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> (toNubList <$> shortListOf 2 arbitrary) + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> (fmap getShortToken <$> arbitrary) + <*> arbitraryNumJobs + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> (fmap getShortToken <$> arbitrary) + <*> arbitrary + <*> (fmap getShortToken <$> arbitrary) + <*> (fmap getShortToken <$> arbitrary) + <*> arbitrary + where + arbitraryNumJobs = fmap (fmap getPositive) <$> arbitrary + + shrink + ProjectConfigBuildOnly + { projectConfigVerbosity = x00 + , projectConfigDryRun = x01 + , projectConfigOnlyDeps = x02 + , projectConfigOnlyDownload = x18 + , projectConfigSummaryFile = x03 + , projectConfigLogFile = x04 + , projectConfigBuildReports = x05 + , projectConfigReportPlanningFailure = x06 + , projectConfigSymlinkBinDir = x07 + , projectConfigNumJobs = x09 + , projectConfigKeepGoing = x10 + , projectConfigOfflineMode = x11 + , projectConfigKeepTempFiles = x12 + , projectConfigHttpTransport = x13 + , projectConfigIgnoreExpiry = x14 + , projectConfigCacheDir = x15 + , projectConfigLogsDir = x16 + , projectConfigClientInstallFlags = x17 + } = + [ ProjectConfigBuildOnly + { projectConfigVerbosity = x00' + , projectConfigDryRun = x01' + , projectConfigOnlyDeps = x02' + , projectConfigOnlyDownload = x18' + , projectConfigSummaryFile = x03' + , projectConfigLogFile = x04' + , projectConfigBuildReports = x05' + , projectConfigReportPlanningFailure = x06' + , projectConfigSymlinkBinDir = x07' + , projectConfigNumJobs = postShrink_NumJobs x09' + , projectConfigKeepGoing = x10' + , projectConfigOfflineMode = x11' + , projectConfigKeepTempFiles = x12' + , projectConfigHttpTransport = x13 + , projectConfigIgnoreExpiry = x14' + , projectConfigCacheDir = x15 + , projectConfigLogsDir = x16 + , projectConfigClientInstallFlags = x17' + } + | ( (x00', x01', x02', x03', x04') + , (x05', x06', x07', x09') + , (x10', x11', x12', x14') + , (x17', x18') + ) <- + shrink + ( (x00, x01, x02, x03, x04) + , (x05, x06, x07, preShrink_NumJobs x09) + , (x10, x11, x12, x14) + , (x17, x18) + ) + ] + where + preShrink_NumJobs = fmap (fmap Positive) + postShrink_NumJobs = fmap (fmap getPositive) + +instance Arbitrary ProjectConfigShared where + arbitrary = do + projectConfigDistDir <- arbitraryFlag arbitraryShortToken + projectConfigConfigFile <- arbitraryFlag arbitraryShortToken + projectConfigProjectDir <- arbitraryFlag arbitraryShortToken + projectConfigProjectFile <- arbitraryFlag arbitraryShortToken + projectConfigIgnoreProject <- arbitrary + projectConfigHcFlavor <- arbitrary + projectConfigHcPath <- arbitraryFlag arbitraryShortToken + projectConfigHcPkg <- arbitraryFlag arbitraryShortToken + projectConfigHaddockIndex <- arbitrary + projectConfigInstallDirs <- fixInstallDirs <$> arbitrary + projectConfigPackageDBs <- shortListOf 2 arbitrary + projectConfigRemoteRepos <- arbitrary + projectConfigLocalNoIndexRepos <- arbitrary + projectConfigActiveRepos <- arbitrary + projectConfigIndexState <- arbitrary + projectConfigStoreDir <- arbitraryFlag arbitraryShortToken + projectConfigConstraints <- arbitraryConstraints + projectConfigPreferences <- shortListOf 2 arbitrary + projectConfigCabalVersion <- arbitrary + projectConfigSolver <- arbitrary + projectConfigAllowOlder <- arbitrary + projectConfigAllowNewer <- arbitrary + projectConfigWriteGhcEnvironmentFilesPolicy <- arbitrary + projectConfigMaxBackjumps <- arbitrary + projectConfigReorderGoals <- arbitrary + projectConfigCountConflicts <- arbitrary + projectConfigFineGrainedConflicts <- arbitrary + projectConfigMinimizeConflictSet <- arbitrary + projectConfigStrongFlags <- arbitrary + projectConfigAllowBootLibInstalls <- arbitrary + projectConfigOnlyConstrained <- arbitrary + projectConfigPerComponent <- arbitrary + projectConfigIndependentGoals <- arbitrary + projectConfigPreferOldest <- arbitrary + projectConfigProgPathExtra <- toNubList <$> listOf arbitraryShortToken + projectConfigMultiRepl <- arbitrary + return ProjectConfigShared{..} + where + arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)] + arbitraryConstraints = + fmap (\uc -> (uc, projectConfigConstraintSource)) <$> arbitrary + fixInstallDirs x = x{InstallDirs.includedir = mempty, InstallDirs.mandir = mempty, InstallDirs.flibdir = mempty} + + shrink ProjectConfigShared{..} = + runShrinker $ + pure ProjectConfigShared + <*> shrinker projectConfigDistDir + <*> shrinker projectConfigConfigFile + <*> shrinker projectConfigProjectDir + <*> shrinker projectConfigProjectFile + <*> shrinker projectConfigIgnoreProject + <*> shrinker projectConfigHcFlavor + <*> shrinkerAla (fmap NonEmpty) projectConfigHcPath + <*> shrinkerAla (fmap NonEmpty) projectConfigHcPkg + <*> shrinker projectConfigHaddockIndex + <*> shrinker projectConfigInstallDirs + <*> shrinker projectConfigPackageDBs + <*> shrinker projectConfigRemoteRepos + <*> shrinker projectConfigLocalNoIndexRepos + <*> shrinker projectConfigActiveRepos + <*> shrinker projectConfigIndexState + <*> shrinker projectConfigStoreDir + <*> shrinkerPP preShrink_Constraints postShrink_Constraints projectConfigConstraints + <*> shrinker projectConfigPreferences + <*> shrinker projectConfigCabalVersion + <*> shrinker projectConfigSolver + <*> shrinker projectConfigAllowOlder + <*> shrinker projectConfigAllowNewer + <*> shrinker projectConfigWriteGhcEnvironmentFilesPolicy + <*> shrinker projectConfigMaxBackjumps + <*> shrinker projectConfigReorderGoals + <*> shrinker projectConfigCountConflicts + <*> shrinker projectConfigFineGrainedConflicts + <*> shrinker projectConfigMinimizeConflictSet + <*> shrinker projectConfigStrongFlags + <*> shrinker projectConfigAllowBootLibInstalls + <*> shrinker projectConfigOnlyConstrained + <*> shrinker projectConfigPerComponent + <*> shrinker projectConfigIndependentGoals + <*> shrinker projectConfigPreferOldest + <*> shrinker projectConfigProgPathExtra + <*> shrinker projectConfigMultiRepl + where + preShrink_Constraints = map fst + postShrink_Constraints = map (\uc -> (uc, projectConfigConstraintSource)) + +projectConfigConstraintSource :: ConstraintSource +projectConfigConstraintSource = + ConstraintSourceProjectConfig "unused" + +instance Arbitrary ProjectConfigProvenance where + arbitrary = elements [Implicit, Explicit "cabal.project"] + +instance Arbitrary PackageConfig where + arbitrary = + PackageConfig + <$> ( MapLast . Map.fromList + <$> shortListOf + 10 + ( (,) + <$> arbitraryProgramName + <*> arbitraryShortToken + ) + ) + <*> ( MapMappend . Map.fromList + <$> shortListOf + 10 + ( (,) + <$> arbitraryProgramName + <*> listOf arbitraryShortToken + ) + ) + <*> (toNubList <$> listOf arbitraryShortToken) + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> shortListOf 5 arbitraryShortToken + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> shortListOf 5 arbitraryShortToken + <*> shortListOf 5 arbitraryShortToken + <*> shortListOf 5 arbitraryShortToken + <*> shortListOf 5 arbitraryShortToken + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitraryFlag arbitraryShortToken + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitraryFlag arbitraryShortToken + <*> arbitrary + <*> arbitrary + <*> arbitraryFlag arbitraryShortToken + <*> arbitrary + <*> arbitrary + <*> arbitraryFlag arbitraryShortToken + <*> arbitraryFlag arbitraryShortToken + <*> arbitraryFlag arbitraryShortToken + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitraryFlag arbitraryShortToken + <*> arbitrary + <*> shortListOf 5 arbitrary + <*> shortListOf 5 arbitrary + where + arbitraryProgramName :: Gen String + arbitraryProgramName = + elements + [ programName prog + | (prog, _) <- knownPrograms (defaultProgramDb) + ] + + shrink + PackageConfig + { packageConfigProgramPaths = x00 + , packageConfigProgramArgs = x01 + , packageConfigProgramPathExtra = x02 + , packageConfigFlagAssignment = x03 + , packageConfigVanillaLib = x04 + , packageConfigSharedLib = x05 + , packageConfigStaticLib = x42 + , packageConfigDynExe = x06 + , packageConfigFullyStaticExe = x50 + , packageConfigProf = x07 + , packageConfigProfLib = x08 + , packageConfigProfExe = x09 + , packageConfigProfDetail = x10 + , packageConfigProfLibDetail = x11 + , packageConfigConfigureArgs = x12 + , packageConfigOptimization = x13 + , packageConfigProgPrefix = x14 + , packageConfigProgSuffix = x15 + , packageConfigExtraLibDirs = x16 + , packageConfigExtraLibDirsStatic = x53 + , packageConfigExtraFrameworkDirs = x17 + , packageConfigExtraIncludeDirs = x18 + , packageConfigGHCiLib = x19 + , packageConfigSplitSections = x20 + , packageConfigSplitObjs = x20_1 + , packageConfigStripExes = x21 + , packageConfigStripLibs = x22 + , packageConfigTests = x23 + , packageConfigBenchmarks = x24 + , packageConfigCoverage = x25 + , packageConfigRelocatable = x26 + , packageConfigDebugInfo = x27 + , packageConfigDumpBuildInfo = x27_1 + , packageConfigRunTests = x28 + , packageConfigDocumentation = x29 + , packageConfigHaddockHoogle = x30 + , packageConfigHaddockHtml = x31 + , packageConfigHaddockHtmlLocation = x32 + , packageConfigHaddockForeignLibs = x33 + , packageConfigHaddockExecutables = x33_1 + , packageConfigHaddockTestSuites = x34 + , packageConfigHaddockBenchmarks = x35 + , packageConfigHaddockInternal = x36 + , packageConfigHaddockCss = x37 + , packageConfigHaddockLinkedSource = x38 + , packageConfigHaddockQuickJump = x43 + , packageConfigHaddockHscolourCss = x39 + , packageConfigHaddockContents = x40 + , packageConfigHaddockForHackage = x41 + , packageConfigHaddockIndex = x54 + , packageConfigHaddockBaseUrl = x55 + , packageConfigHaddockLib = x56 + , packageConfigHaddockOutputDir = x57 + , packageConfigTestHumanLog = x44 + , packageConfigTestMachineLog = x45 + , packageConfigTestShowDetails = x46 + , packageConfigTestKeepTix = x47 + , packageConfigTestWrapper = x48 + , packageConfigTestFailWhenNoTestSuites = x49 + , packageConfigTestTestOptions = x51 + , packageConfigBenchmarkOptions = x52 + } = + [ PackageConfig + { packageConfigProgramPaths = postShrink_Paths x00' + , packageConfigProgramArgs = postShrink_Args x01' + , packageConfigProgramPathExtra = x02' + , packageConfigFlagAssignment = x03' + , packageConfigVanillaLib = x04' + , packageConfigSharedLib = x05' + , packageConfigStaticLib = x42' + , packageConfigDynExe = x06' + , packageConfigFullyStaticExe = x50' + , packageConfigProf = x07' + , packageConfigProfLib = x08' + , packageConfigProfExe = x09' + , packageConfigProfDetail = x10' + , packageConfigProfLibDetail = x11' + , packageConfigConfigureArgs = map getNonEmpty x12' + , packageConfigOptimization = x13' + , packageConfigProgPrefix = x14' + , packageConfigProgSuffix = x15' + , packageConfigExtraLibDirs = map getNonEmpty x16' + , packageConfigExtraLibDirsStatic = map getNonEmpty x53' + , packageConfigExtraFrameworkDirs = map getNonEmpty x17' + , packageConfigExtraIncludeDirs = map getNonEmpty x18' + , packageConfigGHCiLib = x19' + , packageConfigSplitSections = x20' + , packageConfigSplitObjs = x20_1' + , packageConfigStripExes = x21' + , packageConfigStripLibs = x22' + , packageConfigTests = x23' + , packageConfigBenchmarks = x24' + , packageConfigCoverage = x25' + , packageConfigRelocatable = x26' + , packageConfigDebugInfo = x27' + , packageConfigDumpBuildInfo = x27_1' + , packageConfigRunTests = x28' + , packageConfigDocumentation = x29' + , packageConfigHaddockHoogle = x30' + , packageConfigHaddockHtml = x31' + , packageConfigHaddockHtmlLocation = x32' + , packageConfigHaddockForeignLibs = x33' + , packageConfigHaddockExecutables = x33_1' + , packageConfigHaddockTestSuites = x34' + , packageConfigHaddockBenchmarks = x35' + , packageConfigHaddockInternal = x36' + , packageConfigHaddockCss = fmap getNonEmpty x37' + , packageConfigHaddockLinkedSource = x38' + , packageConfigHaddockQuickJump = x43' + , packageConfigHaddockHscolourCss = fmap getNonEmpty x39' + , packageConfigHaddockContents = x40' + , packageConfigHaddockForHackage = x41' + , packageConfigHaddockIndex = x54' + , packageConfigHaddockBaseUrl = x55' + , packageConfigHaddockLib = x56' + , packageConfigHaddockOutputDir = x57' + , packageConfigTestHumanLog = x44' + , packageConfigTestMachineLog = x45' + , packageConfigTestShowDetails = x46' + , packageConfigTestKeepTix = x47' + , packageConfigTestWrapper = x48' + , packageConfigTestFailWhenNoTestSuites = x49' + , packageConfigTestTestOptions = x51' + , packageConfigBenchmarkOptions = x52' + } + | ( ( (x00', x01', x02', x03', x04') + , (x05', x42', x06', x50', x07', x08', x09') + , (x10', x11', x12', x13', x14') + , (x15', x16', x53', x17', x18', x19') + ) + , ( (x20', x20_1', x21', x22', x23', x24') + , (x25', x26', x27', x27_1', x28', x29') + , (x30', x31', x32', (x33', x33_1'), x34') + , (x35', x36', x37', x38', x43', x39') + , (x40', x41') + , (x44', x45', x46', x47', x48', x49', x51', x52', x54', x55') + , x56' + , x57' + ) + ) <- + shrink + ( + ( (preShrink_Paths x00, preShrink_Args x01, x02, x03, x04) + , (x05, x42, x06, x50, x07, x08, x09) + , (x10, x11, map NonEmpty x12, x13, x14) + , + ( x15 + , map NonEmpty x16 + , map NonEmpty x53 + , map NonEmpty x17 + , map NonEmpty x18 + , x19 + ) + ) + , + ( (x20, x20_1, x21, x22, x23, x24) + , (x25, x26, x27, x27_1, x28, x29) + , (x30, x31, x32, (x33, x33_1), x34) + , (x35, x36, fmap NonEmpty x37, x38, x43, fmap NonEmpty x39) + , (x40, x41) + , (x44, x45, x46, x47, x48, x49, x51, x52, x54, x55) + , x56 + , x57 + ) + ) + ] + where + preShrink_Paths = + Map.map NonEmpty + . Map.mapKeys NoShrink + . getMapLast + postShrink_Paths = + MapLast + . Map.map getNonEmpty + . Map.mapKeys getNoShrink + preShrink_Args = + Map.map (NonEmpty . map NonEmpty) + . Map.mapKeys NoShrink + . getMapMappend + postShrink_Args = + MapMappend + . Map.map (map getNonEmpty . getNonEmpty) + . Map.mapKeys getNoShrink + +instance f ~ [] => Arbitrary (SourceRepositoryPackage f) where + arbitrary = + SourceRepositoryPackage + <$> arbitrary + <*> (getShortToken <$> arbitrary) + <*> (fmap getShortToken <$> arbitrary) + <*> (fmap getShortToken <$> arbitrary) + <*> (fmap getShortToken <$> shortListOf 3 arbitrary) + <*> (fmap getShortToken <$> shortListOf 3 arbitrary) + + shrink SourceRepositoryPackage{..} = + runShrinker $ + pure SourceRepositoryPackage + <*> shrinker srpType + <*> shrinkerAla ShortToken srpLocation + <*> shrinkerAla (fmap ShortToken) srpTag + <*> shrinkerAla (fmap ShortToken) srpBranch + <*> shrinkerAla (fmap ShortToken) srpSubdir + <*> shrinkerAla (fmap ShortToken) srpCommand + +instance Arbitrary RemoteRepo where + arbitrary = + RemoteRepo + <$> arbitrary + <*> arbitrary -- URI + <*> arbitrary + <*> listOf arbitraryRootKey + <*> fmap getNonNegative arbitrary + <*> pure False + where + arbitraryRootKey = + shortListOf1 + 5 + ( oneof + [ choose ('0', '9') + , choose ('a', 'f') + ] + ) + +instance Arbitrary LocalRepo where + arbitrary = + LocalRepo + <$> arbitrary + <*> elements ["/tmp/foo", "/tmp/bar"] -- TODO: generate valid absolute paths + <*> arbitrary + +instance Arbitrary PreSolver where + arbitrary = elements [minBound .. maxBound] + +instance Arbitrary ReorderGoals where + arbitrary = ReorderGoals <$> arbitrary + +instance Arbitrary CountConflicts where + arbitrary = CountConflicts <$> arbitrary + +instance Arbitrary FineGrainedConflicts where + arbitrary = FineGrainedConflicts <$> arbitrary + +instance Arbitrary MinimizeConflictSet where + arbitrary = MinimizeConflictSet <$> arbitrary + +instance Arbitrary IndependentGoals where + arbitrary = IndependentGoals <$> arbitrary + +instance Arbitrary PreferOldest where + arbitrary = PreferOldest <$> arbitrary + +instance Arbitrary StrongFlags where + arbitrary = StrongFlags <$> arbitrary + +instance Arbitrary AllowBootLibInstalls where + arbitrary = AllowBootLibInstalls <$> arbitrary + +instance Arbitrary OnlyConstrained where + arbitrary = + oneof + [ pure OnlyConstrainedAll + , pure OnlyConstrainedNone + ] diff --git a/test/IntegrationTests2/config/default-config b/test/IntegrationTests2/config/default-config new file mode 100644 index 00000000000..8e3aa02742c --- /dev/null +++ b/test/IntegrationTests2/config/default-config @@ -0,0 +1,246 @@ +-- This is the configuration file for the 'cabal' command line tool. +-- +-- The available configuration options are listed below. +-- Some of them have default values listed. +-- +-- Lines (like this one) beginning with '--' are comments. +-- Be careful with spaces and indentation because they are +-- used to indicate layout for nested sections. +-- +-- This config file was generated using the following versions +-- of Cabal and cabal-install: +-- Cabal library version: 3.11.0.0 +-- cabal-install version: 3.11 + + +repository hackage.haskell.org + url: http://hackage.haskell.org/ + -- secure: True + -- root-keys: + -- key-threshold: 3 + +-- ignore-expiry: False +-- http-transport: +-- nix: +-- store-dir: +-- active-repositories: +-- local-no-index-repo: +remote-repo-cache: /home/colton/.cabal/packages +-- logs-dir: /home/colton/.cabal/logs +-- default-user-config: +-- verbose: 1 +-- compiler: ghc +-- cabal-file: +-- with-compiler: +-- with-hc-pkg: +-- program-prefix: +-- program-suffix: +-- library-vanilla: True +-- library-profiling: +-- shared: +-- static: +-- executable-dynamic: False +-- executable-static: False +-- profiling: +-- executable-profiling: +-- profiling-detail: +-- library-profiling-detail: +-- optimization: True +-- debug-info: False +-- build-info: +-- library-for-ghci: +-- split-sections: False +-- split-objs: False +-- executable-stripping: +-- library-stripping: +-- configure-option: +-- user-install: True +-- package-db: +-- flags: +-- extra-include-dirs: +-- deterministic: +-- cid: +-- extra-lib-dirs: +-- extra-lib-dirs-static: +-- extra-framework-dirs: +extra-prog-path: /home/colton/.cabal/bin +-- instantiate-with: +-- tests: False +-- coverage: False +-- library-coverage: +-- exact-configuration: False +-- benchmarks: False +-- relocatable: False +-- response-files: +-- allow-depending-on-private-libs: +-- cabal-lib-version: +-- append: +-- backup: +-- constraint: +-- preference: +-- solver: modular +-- allow-older: False +-- allow-newer: False +-- write-ghc-environment-files: +-- documentation: False +-- doc-index-file: $datadir/doc/$arch-$os-$compiler/index.html +-- only-download: False +-- target-package-db: +-- max-backjumps: 4000 +-- reorder-goals: False +-- count-conflicts: True +-- fine-grained-conflicts: True +-- minimize-conflict-set: False +-- independent-goals: False +-- prefer-oldest: False +-- shadow-installed-packages: False +-- strong-flags: False +-- allow-boot-library-installs: False +-- reject-unconstrained-dependencies: none +-- reinstall: False +-- avoid-reinstalls: False +-- force-reinstalls: False +-- upgrade-dependencies: False +-- index-state: +-- root-cmd: +-- symlink-bindir: +build-summary: /home/colton/.cabal/logs/build.log +-- build-log: +remote-build-reporting: none +-- report-planning-failure: False +-- per-component: True +-- run-tests: +jobs: $ncpus +-- keep-going: False +-- offline: False +-- lib: False +-- package-env: +-- overwrite-policy: +-- install-method: +installdir: /home/colton/.cabal/bin +-- username: +-- password: +-- password-command: +-- builddir: + +haddock + -- keep-temp-files: False + -- hoogle: False + -- html: False + -- html-location: + -- executables: False + -- tests: False + -- benchmarks: False + -- foreign-libraries: False + -- all: + -- internal: False + -- css: + -- hyperlink-source: False + -- quickjump: False + -- hscolour-css: + -- contents-location: + -- index-location: + -- base-url: + -- lib: + -- output-dir: + +init + -- interactive: False + -- quiet: False + -- no-comments: False + -- minimal: False + -- cabal-version: 3.0 + -- license: + -- extra-doc-file: + -- tests: + -- test-dir: + -- simple: False + -- language: Haskell2010 + -- application-dir: app + -- source-dir: src + +install-dirs user + -- prefix: /home/colton/.cabal + -- bindir: $prefix/bin + -- libdir: $prefix/lib + -- libsubdir: $abi/$libname + -- dynlibdir: $libdir/$abi + -- libexecdir: $prefix/libexec + -- libexecsubdir: $abi/$pkgid + -- datadir: $prefix/share + -- datasubdir: $abi/$pkgid + -- docdir: $datadir/doc/$abi/$pkgid + -- htmldir: $docdir/html + -- haddockdir: $htmldir + -- sysconfdir: $prefix/etc + +install-dirs global + -- prefix: /usr/local + -- bindir: $prefix/bin + -- libdir: $prefix/lib + -- libsubdir: $abi/$libname + -- dynlibdir: $libdir/$abi + -- libexecdir: $prefix/libexec + -- libexecsubdir: $abi/$pkgid + -- datadir: $prefix/share + -- datasubdir: $abi/$pkgid + -- docdir: $datadir/doc/$abi/$pkgid + -- htmldir: $docdir/html + -- haddockdir: $htmldir + -- sysconfdir: $prefix/etc + +program-locations + -- alex-location: + -- ar-location: + -- c2hs-location: + -- cpphs-location: + -- doctest-location: + -- gcc-location: + -- ghc-location: + -- ghc-pkg-location: + -- ghcjs-location: + -- ghcjs-pkg-location: + -- greencard-location: + -- haddock-location: + -- happy-location: + -- haskell-suite-location: + -- haskell-suite-pkg-location: + -- hmake-location: + -- hpc-location: + -- hsc2hs-location: + -- hscolour-location: + -- jhc-location: + -- ld-location: + -- pkg-config-location: + -- runghc-location: + -- strip-location: + -- tar-location: + -- uhc-location: + +program-default-options + -- alex-options: + -- ar-options: + -- c2hs-options: + -- cpphs-options: + -- doctest-options: + -- gcc-options: + -- ghc-options: + -- ghc-pkg-options: + -- ghcjs-options: + -- ghcjs-pkg-options: + -- greencard-options: + -- haddock-options: + -- happy-options: + -- haskell-suite-options: + -- haskell-suite-pkg-options: + -- hmake-options: + -- hpc-options: + -- hsc2hs-options: + -- hscolour-options: + -- jhc-options: + -- ld-options: + -- pkg-config-options: + -- runghc-options: + -- strip-options: + -- tar-options: + -- uhc-options: diff --git a/test/IntegrationTests2/nix-config/default-config b/test/IntegrationTests2/nix-config/default-config new file mode 100644 index 00000000000..8e3aa02742c --- /dev/null +++ b/test/IntegrationTests2/nix-config/default-config @@ -0,0 +1,246 @@ +-- This is the configuration file for the 'cabal' command line tool. +-- +-- The available configuration options are listed below. +-- Some of them have default values listed. +-- +-- Lines (like this one) beginning with '--' are comments. +-- Be careful with spaces and indentation because they are +-- used to indicate layout for nested sections. +-- +-- This config file was generated using the following versions +-- of Cabal and cabal-install: +-- Cabal library version: 3.11.0.0 +-- cabal-install version: 3.11 + + +repository hackage.haskell.org + url: http://hackage.haskell.org/ + -- secure: True + -- root-keys: + -- key-threshold: 3 + +-- ignore-expiry: False +-- http-transport: +-- nix: +-- store-dir: +-- active-repositories: +-- local-no-index-repo: +remote-repo-cache: /home/colton/.cabal/packages +-- logs-dir: /home/colton/.cabal/logs +-- default-user-config: +-- verbose: 1 +-- compiler: ghc +-- cabal-file: +-- with-compiler: +-- with-hc-pkg: +-- program-prefix: +-- program-suffix: +-- library-vanilla: True +-- library-profiling: +-- shared: +-- static: +-- executable-dynamic: False +-- executable-static: False +-- profiling: +-- executable-profiling: +-- profiling-detail: +-- library-profiling-detail: +-- optimization: True +-- debug-info: False +-- build-info: +-- library-for-ghci: +-- split-sections: False +-- split-objs: False +-- executable-stripping: +-- library-stripping: +-- configure-option: +-- user-install: True +-- package-db: +-- flags: +-- extra-include-dirs: +-- deterministic: +-- cid: +-- extra-lib-dirs: +-- extra-lib-dirs-static: +-- extra-framework-dirs: +extra-prog-path: /home/colton/.cabal/bin +-- instantiate-with: +-- tests: False +-- coverage: False +-- library-coverage: +-- exact-configuration: False +-- benchmarks: False +-- relocatable: False +-- response-files: +-- allow-depending-on-private-libs: +-- cabal-lib-version: +-- append: +-- backup: +-- constraint: +-- preference: +-- solver: modular +-- allow-older: False +-- allow-newer: False +-- write-ghc-environment-files: +-- documentation: False +-- doc-index-file: $datadir/doc/$arch-$os-$compiler/index.html +-- only-download: False +-- target-package-db: +-- max-backjumps: 4000 +-- reorder-goals: False +-- count-conflicts: True +-- fine-grained-conflicts: True +-- minimize-conflict-set: False +-- independent-goals: False +-- prefer-oldest: False +-- shadow-installed-packages: False +-- strong-flags: False +-- allow-boot-library-installs: False +-- reject-unconstrained-dependencies: none +-- reinstall: False +-- avoid-reinstalls: False +-- force-reinstalls: False +-- upgrade-dependencies: False +-- index-state: +-- root-cmd: +-- symlink-bindir: +build-summary: /home/colton/.cabal/logs/build.log +-- build-log: +remote-build-reporting: none +-- report-planning-failure: False +-- per-component: True +-- run-tests: +jobs: $ncpus +-- keep-going: False +-- offline: False +-- lib: False +-- package-env: +-- overwrite-policy: +-- install-method: +installdir: /home/colton/.cabal/bin +-- username: +-- password: +-- password-command: +-- builddir: + +haddock + -- keep-temp-files: False + -- hoogle: False + -- html: False + -- html-location: + -- executables: False + -- tests: False + -- benchmarks: False + -- foreign-libraries: False + -- all: + -- internal: False + -- css: + -- hyperlink-source: False + -- quickjump: False + -- hscolour-css: + -- contents-location: + -- index-location: + -- base-url: + -- lib: + -- output-dir: + +init + -- interactive: False + -- quiet: False + -- no-comments: False + -- minimal: False + -- cabal-version: 3.0 + -- license: + -- extra-doc-file: + -- tests: + -- test-dir: + -- simple: False + -- language: Haskell2010 + -- application-dir: app + -- source-dir: src + +install-dirs user + -- prefix: /home/colton/.cabal + -- bindir: $prefix/bin + -- libdir: $prefix/lib + -- libsubdir: $abi/$libname + -- dynlibdir: $libdir/$abi + -- libexecdir: $prefix/libexec + -- libexecsubdir: $abi/$pkgid + -- datadir: $prefix/share + -- datasubdir: $abi/$pkgid + -- docdir: $datadir/doc/$abi/$pkgid + -- htmldir: $docdir/html + -- haddockdir: $htmldir + -- sysconfdir: $prefix/etc + +install-dirs global + -- prefix: /usr/local + -- bindir: $prefix/bin + -- libdir: $prefix/lib + -- libsubdir: $abi/$libname + -- dynlibdir: $libdir/$abi + -- libexecdir: $prefix/libexec + -- libexecsubdir: $abi/$pkgid + -- datadir: $prefix/share + -- datasubdir: $abi/$pkgid + -- docdir: $datadir/doc/$abi/$pkgid + -- htmldir: $docdir/html + -- haddockdir: $htmldir + -- sysconfdir: $prefix/etc + +program-locations + -- alex-location: + -- ar-location: + -- c2hs-location: + -- cpphs-location: + -- doctest-location: + -- gcc-location: + -- ghc-location: + -- ghc-pkg-location: + -- ghcjs-location: + -- ghcjs-pkg-location: + -- greencard-location: + -- haddock-location: + -- happy-location: + -- haskell-suite-location: + -- haskell-suite-pkg-location: + -- hmake-location: + -- hpc-location: + -- hsc2hs-location: + -- hscolour-location: + -- jhc-location: + -- ld-location: + -- pkg-config-location: + -- runghc-location: + -- strip-location: + -- tar-location: + -- uhc-location: + +program-default-options + -- alex-options: + -- ar-options: + -- c2hs-options: + -- cpphs-options: + -- doctest-options: + -- gcc-options: + -- ghc-options: + -- ghc-pkg-options: + -- ghcjs-options: + -- ghcjs-pkg-options: + -- greencard-options: + -- haddock-options: + -- happy-options: + -- haskell-suite-options: + -- haskell-suite-pkg-options: + -- hmake-options: + -- hpc-options: + -- hsc2hs-options: + -- hscolour-options: + -- jhc-options: + -- ld-options: + -- pkg-config-options: + -- runghc-options: + -- strip-options: + -- tar-options: + -- uhc-options: