Cabal 3.12.1.0 → 3.18.1.0
raw patch · 136 files changed
Files
- Cabal.cabal +55/−32
- ChangeLog.md +20/−2
- LICENSE +1/−1
- src/Distribution/Backpack/Configure.hs +93/−30
- src/Distribution/Backpack/ConfiguredComponent.hs +1/−3
- src/Distribution/Backpack/Id.hs +2/−1
- src/Distribution/Backpack/LinkedComponent.hs +15/−7
- src/Distribution/Backpack/MixLink.hs +3/−4
- src/Distribution/Backpack/ModuleScope.hs +0/−2
- src/Distribution/Backpack/ModuleShape.hs +1/−2
- src/Distribution/Backpack/PreExistingComponent.hs +3/−3
- src/Distribution/Backpack/PreModuleShape.hs +0/−1
- src/Distribution/Backpack/ReadyComponent.hs +5/−6
- src/Distribution/Backpack/UnifyM.hs +2/−4
- src/Distribution/Compat/Async.hs +2/−13
- src/Distribution/Compat/CopyFile.hs +17/−137
- src/Distribution/Compat/Directory.hs +0/−48
- src/Distribution/Compat/Environment.hs +2/−59
- src/Distribution/Compat/FilePath.hs +0/−26
- src/Distribution/Compat/GetShortPathName.hs +17/−45
- src/Distribution/Compat/Internal/TempFile.hs +19/−108
- src/Distribution/Compat/ResponseFile.hs +11/−66
- src/Distribution/Compat/SnocList.hs +0/−34
- src/Distribution/Compat/Stack.hs +7/−86
- src/Distribution/Compat/SysInfo.hs +15/−0
- src/Distribution/Compat/Time.hs +7/−149
- src/Distribution/GetOpt.hs +5/−5
- src/Distribution/Make.hs +0/−187
- src/Distribution/PackageDescription/Check.hs +127/−60
- src/Distribution/PackageDescription/Check/Common.hs +15/−15
- src/Distribution/PackageDescription/Check/Conditional.hs +34/−44
- src/Distribution/PackageDescription/Check/Monad.hs +20/−7
- src/Distribution/PackageDescription/Check/Paths.hs +1/−0
- src/Distribution/PackageDescription/Check/Target.hs +85/−47
- src/Distribution/PackageDescription/Check/Warning.hs +97/−40
- src/Distribution/Simple.hs +628/−313
- src/Distribution/Simple/Bench.hs +52/−13
- src/Distribution/Simple/Build.hs +410/−229
- src/Distribution/Simple/Build/Inputs.hs +6/−6
- src/Distribution/Simple/Build/Macros.hs +1/−1
- src/Distribution/Simple/Build/PackageInfoModule.hs +11/−16
- src/Distribution/Simple/Build/PackageInfoModule/Z.hs +25/−9
- src/Distribution/Simple/Build/PathsModule.hs +1/−11
- src/Distribution/Simple/Build/PathsModule/Z.hs +88/−49
- src/Distribution/Simple/BuildPaths.hs +214/−37
- src/Distribution/Simple/BuildTarget.hs +36/−29
- src/Distribution/Simple/BuildToolDepends.hs +1/−2
- src/Distribution/Simple/BuildWay.hs +21/−0
- src/Distribution/Simple/Command.hs +20/−6
- src/Distribution/Simple/Compiler.hs +220/−41
- src/Distribution/Simple/Configure.hs +3094/−2633
- src/Distribution/Simple/ConfigureScript.hs +61/−37
- src/Distribution/Simple/Errors.hs +72/−65
- src/Distribution/Simple/FileMonitor/Types.hs +218/−0
- src/Distribution/Simple/Flag.hs +16/−48
- src/Distribution/Simple/GHC.hs +403/−257
- src/Distribution/Simple/GHC/Build.hs +106/−59
- src/Distribution/Simple/GHC/Build/ExtraSources.hs +171/−135
- src/Distribution/Simple/GHC/Build/Link.hs +339/−245
- src/Distribution/Simple/GHC/Build/Modules.hs +187/−97
- src/Distribution/Simple/GHC/Build/Utils.hs +79/−20
- src/Distribution/Simple/GHC/EnvironmentParser.hs +8/−13
- src/Distribution/Simple/GHC/ImplInfo.hs +11/−37
- src/Distribution/Simple/GHC/Internal.hs +272/−302
- src/Distribution/Simple/GHCJS.hs +209/−190
- src/Distribution/Simple/Glob.hs +436/−42
- src/Distribution/Simple/Glob/Internal.hs +17/−376
- src/Distribution/Simple/Haddock.hs +1636/−1224
- src/Distribution/Simple/HaskellSuite.hs +0/−267
- src/Distribution/Simple/Hpc.hs +35/−26
- src/Distribution/Simple/Install.hs +137/−80
- src/Distribution/Simple/InstallDirs.hs +110/−13
- src/Distribution/Simple/InstallDirs/Internal.hs +8/−3
- src/Distribution/Simple/LocalBuildInfo.hs +62/−27
- src/Distribution/Simple/PackageDescription.hs +54/−29
- src/Distribution/Simple/PackageIndex.hs +61/−27
- src/Distribution/Simple/PreProcess.hs +235/−225
- src/Distribution/Simple/PreProcess/Types.hs +20/−6
- src/Distribution/Simple/Program.hs +65/−6
- src/Distribution/Simple/Program/Ar.hs +40/−31
- src/Distribution/Simple/Program/Builtin.hs +34/−82
- src/Distribution/Simple/Program/Db.hs +125/−24
- src/Distribution/Simple/Program/Find.hs +15/−26
- src/Distribution/Simple/Program/GHC.hs +220/−109
- src/Distribution/Simple/Program/HcPkg.hs +219/−209
- src/Distribution/Simple/Program/Hpc.hs +34/−30
- src/Distribution/Simple/Program/Internal.hs +13/−6
- src/Distribution/Simple/Program/Ld.hs +39/−35
- src/Distribution/Simple/Program/ResponseFile.hs +9/−6
- src/Distribution/Simple/Program/Run.hs +42/−4
- src/Distribution/Simple/Program/Script.hs +1/−1
- src/Distribution/Simple/Program/Strip.hs +6/−2
- src/Distribution/Simple/Program/Types.hs +4/−5
- src/Distribution/Simple/Register.hs +146/−116
- src/Distribution/Simple/Setup.hs +38/−22
- src/Distribution/Simple/Setup/Benchmark.hs +76/−50
- src/Distribution/Simple/Setup/Build.hs +61/−42
- src/Distribution/Simple/Setup/Clean.hs +55/−29
- src/Distribution/Simple/Setup/Common.hs +144/−18
- src/Distribution/Simple/Setup/Config.hs +164/−112
- src/Distribution/Simple/Setup/Copy.hs +80/−57
- src/Distribution/Simple/Setup/Global.hs +21/−5
- src/Distribution/Simple/Setup/Haddock.hs +358/−324
- src/Distribution/Simple/Setup/Hscolour.hs +105/−81
- src/Distribution/Simple/Setup/Install.hs +60/−34
- src/Distribution/Simple/Setup/Register.hs +127/−105
- src/Distribution/Simple/Setup/Repl.hs +81/−46
- src/Distribution/Simple/Setup/SDist.hs +71/−43
- src/Distribution/Simple/Setup/Test.hs +157/−126
- src/Distribution/Simple/SetupHooks/Errors.hs +215/−0
- src/Distribution/Simple/SetupHooks/HooksMain.hs +407/−0
- src/Distribution/Simple/SetupHooks/Internal.hs +1299/−0
- src/Distribution/Simple/SetupHooks/Rule.hs +1193/−0
- src/Distribution/Simple/ShowBuildInfo.hs +15/−13
- src/Distribution/Simple/SrcDist.hs +120/−83
- src/Distribution/Simple/Test.hs +41/−26
- src/Distribution/Simple/Test/ExeV10.hs +58/−48
- src/Distribution/Simple/Test/LibV09.hs +45/−46
- src/Distribution/Simple/UHC.hs +53/−43
- src/Distribution/Simple/UserHooks.hs +3/−3
- src/Distribution/Simple/Utils.hs +608/−281
- src/Distribution/Types/ComponentLocalBuildInfo.hs +13/−2
- src/Distribution/Types/DumpBuildInfo.hs +12/−2
- src/Distribution/Types/GivenComponent.hs +20/−2
- src/Distribution/Types/LocalBuildConfig.hs +30/−24
- src/Distribution/Types/LocalBuildInfo.hs +88/−20
- src/Distribution/Types/ParStrat.hs +7/−0
- src/Distribution/Utils/IOData.hs +1/−1
- src/Distribution/Utils/LogProgress.hs +20/−9
- src/Distribution/Utils/MapAccum.hs +3/−4
- src/Distribution/Utils/NubList.hs +4/−2
- src/Distribution/Utils/Progress.hs +1/−2
- src/Distribution/Utils/UnionFind.hs +14/−16
- src/Distribution/Verbosity.hs +174/−98
- src/Distribution/Verbosity/Internal.hs +4/−3
- src/Distribution/ZinzaPrelude.hs +3/−1
Cabal.cabal view
@@ -1,7 +1,7 @@-cabal-version: 3.0+cabal-version: 3.8 name: Cabal-version: 3.12.1.0-copyright: 2003-2024, Cabal Development Team (see AUTHORS file)+version: 3.18.1.0+copyright: 2003-2026, Cabal Development Team (see AUTHORS file) license: BSD-3-Clause license-file: LICENSE author: Cabal Development Team <cabal-devel@haskell.org>@@ -13,7 +13,7 @@ The Haskell Common Architecture for Building Applications and Libraries: a framework defining a common interface for authors to more easily build their Haskell applications in a portable way.- .+ The Haskell Cabal is part of a larger infrastructure for distributing, organizing, and cataloging Haskell libraries and tools. category: Distribution@@ -29,38 +29,60 @@ location: https://github.com/haskell/cabal/ subdir: Cabal +flag git-rev+ description: include Git revision hash in version+ default: False+ manual: True+ library default-language: Haskell2010 hs-source-dirs: src build-depends:- Cabal-syntax ^>= 3.12.1.0,- array >= 0.4.0.1 && < 0.6,- base >= 4.11 && < 5,- bytestring >= 0.10.0.0 && < 0.13,- containers >= 0.5.0.0 && < 0.8,- deepseq >= 1.3.0.1 && < 1.6,- directory >= 1.2 && < 1.4,- filepath >= 1.3.0.1 && < 1.6,- pretty >= 1.1.1 && < 1.2,- process >= 1.2.1.0 && < 1.7,- time >= 1.4.0.1 && < 1.15+ , Cabal-syntax ^>= 3.18+ , array >= 0.4.0.1 && < 0.6+ , base >= 4.17 && < 5+ , bytestring >= 0.10.8 && < 0.13+ , containers >= 0.5.8.2 && < 0.9+ , deepseq >= 1.4 && < 1.7+ , directory >= 1.2.7 && < 1.4+ , filepath >= 1.4.2 && < 1.6+ , pretty >= 1.1.1 && < 1.2+ , process >= 1.6.20.0 && < 1.6.24 || == 1.6.26.0 || >= 1.6.26.2 && < 1.7+ , time >= 1.4.0.1 && < 1.17 if os(windows)- build-depends: Win32 >= 2.3.0.0 && < 2.15+ build-depends:+ , Win32 >= 2.4.0.0 && < 2.15 else- build-depends: unix >= 2.6.0.0 && < 2.9+ build-depends:+ , unix >= 2.8.6.0 && < 2.9 - ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates+ if os(darwin)+ build-depends:+ , process >= 1.6.29.0 + if flag(git-rev)+ build-depends:+ , githash ^>= 0.1.7.0+ cpp-options: -DGIT_REV++ ghc-options:+ -Wall+ -fno-ignore-asserts+ -Wtabs+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wno-unticked-promoted-constructors+ if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances if impl(ghc >= 8.0) && impl(ghc < 8.8) ghc-options: -Wnoncanonical-monadfail-instances - if impl(ghc >= 8.10)- ghc-options: -Wunused-packages+ if impl(ghc >= 9.14)+ ghc-options: -Wno-pattern-namespace-specifier -Wno-incomplete-record-selectors exposed-modules: Distribution.Backpack.Configure@@ -76,16 +98,14 @@ Distribution.Utils.LogProgress Distribution.Utils.MapAccum Distribution.Compat.CreatePipe- Distribution.Compat.Directory Distribution.Compat.Environment- Distribution.Compat.FilePath Distribution.Compat.Internal.TempFile Distribution.Compat.ResponseFile Distribution.Compat.Prelude.Internal Distribution.Compat.Process Distribution.Compat.Stack+ Distribution.Compat.SysInfo Distribution.Compat.Time- Distribution.Make Distribution.PackageDescription.Check Distribution.ReadE Distribution.Simple@@ -98,18 +118,19 @@ Distribution.Simple.BuildPaths Distribution.Simple.BuildTarget Distribution.Simple.BuildToolDepends+ Distribution.Simple.BuildWay Distribution.Simple.CCompiler Distribution.Simple.Command Distribution.Simple.Compiler Distribution.Simple.Configure Distribution.Simple.Errors+ Distribution.Simple.FileMonitor.Types Distribution.Simple.Flag Distribution.Simple.GHC Distribution.Simple.GHCJS Distribution.Simple.Haddock Distribution.Simple.Glob Distribution.Simple.Glob.Internal- Distribution.Simple.HaskellSuite Distribution.Simple.Hpc Distribution.Simple.Install Distribution.Simple.InstallDirs@@ -145,6 +166,10 @@ Distribution.Simple.Test.Log Distribution.Simple.UHC Distribution.Simple.UserHooks+ Distribution.Simple.SetupHooks.Errors+ Distribution.Simple.SetupHooks.HooksMain+ Distribution.Simple.SetupHooks.Internal+ Distribution.Simple.SetupHooks.Rule Distribution.Simple.Utils Distribution.TestSuite Distribution.Types.AnnotatedId@@ -175,13 +200,11 @@ Distribution.Compat.Exception, Distribution.Compat.Graph, Distribution.Compat.Lens,- Distribution.Compat.MonadFail, Distribution.Compat.Newtype, Distribution.Compat.NonEmptySet, Distribution.Compat.Parsing, Distribution.Compat.Prelude, Distribution.Compat.Semigroup,- Distribution.Compat.Typeable, Distribution.Compiler, Distribution.FieldGrammar, Distribution.FieldGrammar.Class,@@ -241,6 +264,7 @@ Distribution.Types.ConfVar, Distribution.Types.Dependency, Distribution.Types.DependencyMap,+ Distribution.Types.DependencySatisfaction, Distribution.Types.ExeDependency, Distribution.Types.Executable, Distribution.Types.Executable.Lens,@@ -264,6 +288,8 @@ Distribution.Types.Library.Lens, Distribution.Types.LibraryName, Distribution.Types.LibraryVisibility,+ Distribution.Types.MissingDependency,+ Distribution.Types.MissingDependencyReason, Distribution.Types.Mixin, Distribution.Types.Module, Distribution.Types.ModuleReexport,@@ -307,11 +333,9 @@ -- Parsec parser-related modules build-depends:- -- transformers-0.4.0.0 doesn't have record syntax e.g. for Identity- -- See also https://github.com/ekmett/transformers-compat/issues/35- transformers (>= 0.3 && < 0.4) || (>=0.4.1.0 && <0.7),- mtl >= 2.1 && < 2.4,- parsec >= 3.1.13.0 && < 3.2+ , transformers >= 0.5.6 && < 0.7+ , mtl >= 2.1 && < 2.4+ , parsec >= 3.1.13.0 && < 3.2 other-modules: Distribution.Backpack.PreExistingComponent@@ -324,7 +348,6 @@ Distribution.Compat.Async Distribution.Compat.CopyFile Distribution.Compat.GetShortPathName- Distribution.Compat.SnocList Distribution.GetOpt Distribution.Lex Distribution.PackageDescription.Check.Common
ChangeLog.md view
@@ -1,3 +1,21 @@+# 3.18.1.0 [Artem Pelenitsyn](mailto:a@pelenitsyn.top) July 2026+* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.18.1.0.md++# 3.16.1.0 [Artem Pelenitsyn](mailto:a@pelenitsyn.top) December 2025+* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.16.1.0.md++# 3.16.0.0 [Artem Pelenitsyn](mailto:a@pelenitsyn.top) July 2025+* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.16.0.0.md++# 3.14.2.0 [Mikolaj Konarski](mailto:mikolaj@well-typed.com) April 2025+* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.14.2.0.md++# 3.14.1.0 [Hécate](mailto:hecate+github@glitchbra.in) November 2024+* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.14.1.0.md++# 3.14.0.0 [Hécate](mailto:hecate+github@glitchbra.in) September 2024+* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.14.0.0.md+ # 3.12.1.0 [Artem Pelenitsyn](mailto:a.pelenitsyn@gmail.com) June 2024 * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.12.1.0.md @@ -574,7 +592,7 @@ * Support module thinning and renaming (#2038). * Add a new license type: UnspecifiedLicense (#2141). * Remove support for Hugs and nhc98 (#2168).- * Invoke `tar` with `--formar ustar` if possible in `sdist` (#1903).+ * Invoke `tar` with `--format ustar` if possible in `sdist` (#1903). * Replace `--enable-library-coverage` with `--enable-coverage`, which enables program coverage for all components (#1945). * Suggest that `ExitFailure 9` is probably due to memory@@ -767,7 +785,7 @@ * Many checks added for common mistakes * New `--package-db=` option for specific package databases * Many internal changes to support cabal-install- * Stricter parsing for version strings, eg dissalows "1.05"+ * Stricter parsing for version strings, eg disallows "1.05" * Improved user guide introduction * Programatica support removed * New options `--program-prefix/suffix` allows eg versioned programs
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2003-2024, Cabal Development Team.+Copyright (c) 2003-2026, Cabal Development Team. See the AUTHORS file for the full list of copyright holders. See */LICENSE for the copyright holders of the subcomponents.
src/Distribution/Backpack/Configure.hs view
@@ -1,8 +1,6 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoMonoLocalBinds #-}@@ -33,11 +31,12 @@ import Distribution.InstalledPackageInfo ( InstalledPackageInfo , emptyInstalledPackageInfo+ , requiredSignatures ) import qualified Distribution.InstalledPackageInfo as Installed import Distribution.ModuleName import Distribution.Package-import Distribution.PackageDescription+import Distribution.PackageDescription (FlagAssignment, PackageDescription (..), libName) import Distribution.Simple.Compiler import Distribution.Simple.Flag import Distribution.Simple.LocalBuildInfo@@ -70,7 +69,7 @@ -> Flag String -- configIPID -> Flag ComponentId -- configCID -> PackageDescription- -> ([PreExistingComponent], [PromisedComponent])+ -> ([PreExistingComponent], [ConfiguredPromisedComponent]) -> FlagAssignment -- configConfigurationsFlags -> [(ModuleName, Module)] -- configInstantiateWith -> InstalledPackageIndex@@ -103,6 +102,8 @@ let conf_pkg_map = Map.fromListWith Map.union+ $+ -- Normal dependencies [ ( pc_pkgname pkg , Map.singleton (pc_compname pkg)@@ -115,10 +116,10 @@ ) | pkg <- prePkgDeps ]- `Map.union` Map.fromListWith- Map.union+ +++ -- Promised dependencies [ (pkg, Map.singleton (ann_cname aid) aid)- | PromisedComponent pkg aid <- promisedPkgDeps+ | ConfiguredPromisedComponent pkg aid <- promisedPkgDeps ] graph1 <- toConfiguredComponents@@ -151,7 +152,7 @@ , emptyModuleShape ) )- | PromisedComponent _ aid <- promisedPkgDeps+ | ConfiguredPromisedComponent _ aid <- promisedPkgDeps ] uid_lookup def_uid | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid =@@ -208,7 +209,7 @@ toComponentLocalBuildInfos :: Compiler -> InstalledPackageIndex -- FULL set- -> [PromisedComponent]+ -> [ConfiguredPromisedComponent] -> PackageDescription -> [PreExistingComponent] -- external package deps -> [ReadyComponent]@@ -261,6 +262,19 @@ packageDependsIndex = PackageIndex.fromList (lefts local_graph) fullIndex = Graph.fromDistinctList local_graph + let+ -- Map from dependency UnitId to its PackageId, built from includes+ -- of all ready components. Used to resolve opaque hashed UnitIds+ -- in broken-package error messages.+ depPkgMap :: Map UnitId PackageId+ depPkgMap =+ Map.fromList+ [ (unDefUnitId (ci_id ci), ci_pkgid ci)+ | rc <- graph+ , Right instc <- [rc_i rc]+ , ci <- instc_includes instc+ ]+ case Graph.broken fullIndex of [] -> return () -- If there are promised dependencies, we don't know what the dependencies@@ -270,26 +284,33 @@ 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- ]+ dieProgress $+ text "The following packages are broken because other"+ <+> text "packages they depend on are missing. These broken"+ <+> text "packages must be rebuilt before they can be used."+ $$ nest+ 2+ ( vcat $+ [ hang+ (text "installed package" <+> pretty (packageId pkg))+ 4+ ( text "is broken due to missing package"+ <+> hsep (punctuate comma (map pretty deps))+ )+ | (Left pkg, deps) <- broken+ ]+ ++ [ hang+ (text "planned package" <+> pretty (packageId pkg))+ 4+ ( vcat $+ text "is broken due to missing package"+ : [ nest 2 (dispMissingDep installedPackageSet depPkgMap dep)+ | dep <- 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@@ -338,6 +359,48 @@ -- forM clbis $ \(clbi,deps) -> info verbosity $ "UNIT" ++ hashUnitId (componentUnitId clbi) ++ "\n" ++ intercalate "\n" (map hashUnitId deps) return (clbis, packageDependsIndex) +-- | Pretty-print a missing dependency, resolving opaque hashed 'UnitId's+-- to their human-readable package id and signature info when possible.+--+-- When an indefinite Backpack package is installed separately (e.g. via+-- nix callCabal2nix), only the indefinite variant (with unfilled signatures)+-- exists in the package DB. The consumer needs an instantiated variant+-- which was never built. The fix is to add both packages to the same+-- cabal project so cabal can fill the signatures.+dispMissingDep+ :: InstalledPackageIndex+ -- ^ all installed packages+ -> Map UnitId PackageId+ -- ^ dep UnitId to its PackageId (from includes)+ -> UnitId+ -- ^ the missing dependency+ -> Doc+dispMissingDep installedPkgSet depPkgMap uid =+ case Map.lookup uid depPkgMap of+ Just pkgid ->+ let ipiSigs =+ [ sigs+ | ipi <- PackageIndex.lookupSourcePackageId installedPkgSet pkgid+ , let sigs = requiredSignatures ipi+ , not (Set.null sigs)+ ]+ in case ipiSigs of+ (sigs : _) ->+ pretty pkgid+ <+> parens+ ( text "has unfilled"+ <+> (if Set.size sigs > 1 then text "signatures:" else text "signature:")+ <+> hsep (punctuate comma (map pretty (Set.toList sigs)))+ )+ $$ nest+ 2+ ( text "The package is installed as indefinite."+ $$ text "To use it, rebuild it in the same cabal project as the"+ <+> text "consumer so cabal can fill the signatures."+ )+ [] -> pretty pkgid <+> parens (pretty uid)+ Nothing -> pretty uid+ -- Build ComponentLocalBuildInfo for each component we are going -- to build. --@@ -353,7 +416,7 @@ go rc = case rc_component rc of CLib lib ->- let convModuleExport (modname', (Module uid modname))+ let convModuleExport (modname', Module uid modname) | this_uid == unDefUnitId uid , modname' == modname = Installed.ExposedModule modname' Nothing
src/Distribution/Backpack/ConfiguredComponent.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE PatternGuards #-}- -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst> module Distribution.Backpack.ConfiguredComponent ( ConfiguredComponent (..)@@ -85,7 +83,7 @@ (text "component" <+> pretty (cc_cid cc)) 4 ( vcat- [ hsep $+ [ hsep [ text "include" , pretty (ci_id incl) , pretty (ci_renaming incl)
src/Distribution/Backpack/Id.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>@@ -13,7 +14,7 @@ import Distribution.PackageDescription import Distribution.Simple.Compiler-import Distribution.Simple.Flag (Flag (..))+import Distribution.Simple.Flag (Flag, pattern Flag, pattern NoFlag) import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.LocalBuildInfo import Distribution.Types.ComponentId
src/Distribution/Backpack/LinkedComponent.hs view
@@ -161,9 +161,7 @@ lookupUid :: ComponentId -> (OpenUnitId, ModuleShape) lookupUid cid =- fromMaybe- (error "linkComponent: lookupUid")- (Map.lookup cid pkg_map)+ Map.findWithDefault (error "linkComponent: lookupUid") cid pkg_map let orErr (Right x) = return x orErr (Left [err]) = dieProgress err@@ -260,7 +258,17 @@ hang (text "Non-library component has unfilled requirements:") 4- (vcat [pretty req | req <- Set.toList reqs])+ ( vcat+ [ case Map.lookup req (modScopeRequires linked_shape0) of+ Just srcs@(_ : _) ->+ hang+ (pretty req)+ 4+ (vcat [text "brought into scope by" <+> dispModuleSource (getSource src) | src <- srcs])+ _ -> 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@@ -290,7 +298,7 @@ (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+ 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 -- Make sure there is at least one candidate@@ -331,7 +339,7 @@ -- 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]+ [(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]@@ -373,7 +381,7 @@ , lc_component = component , lc_public = is_public , -- These must be executables- lc_exe_deps = map (fmap (\cid -> IndefFullUnitId cid Map.empty)) exe_deps+ lc_exe_deps = map (fmap (`IndefFullUnitId` Map.empty)) exe_deps , lc_shape = final_linked_shape , lc_includes = linked_includes , lc_sig_includes = linked_sig_includes
src/Distribution/Backpack/MixLink.hs view
@@ -115,10 +115,9 @@ reqs_doc | null reqs = dispModuleSource (getSource req) | otherwise =- ( text " "- <+> dispModuleSource (getSource req)- $$ vcat [text "and" <+> dispModuleSource (getSource r) | r <- reqs]- )+ text " "+ <+> dispModuleSource (getSource req)+ $$ vcat [text "and" <+> dispModuleSource (getSource r) | r <- reqs] linkProvision _ _ _ = error "linkProvision" -----------------------------------------------------------------------
src/Distribution/Backpack/ModuleScope.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
src/Distribution/Backpack/ModuleShape.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>@@ -31,7 +30,7 @@ { modShapeProvides :: OpenModuleSubst , modShapeRequires :: Set ModuleName }- deriving (Eq, Show, Generic, Typeable)+ deriving (Eq, Show, Generic) instance Binary ModuleShape instance Structured ModuleShape
src/Distribution/Backpack/PreExistingComponent.hs view
@@ -1,7 +1,7 @@ -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst> module Distribution.Backpack.PreExistingComponent ( PreExistingComponent (..)- , PromisedComponent (..)+ , ConfiguredPromisedComponent (..) , ipiToPreExistingComponent ) where @@ -24,12 +24,12 @@ -- 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+data ConfiguredPromisedComponent = ConfiguredPromisedComponent { pr_pkgname :: PackageName , pr_cid :: AnnotatedId ComponentId } -instance Package PromisedComponent where+instance Package ConfiguredPromisedComponent where packageId = packageId . pr_cid -- | Stripped down version of 'LinkedComponent' for things
src/Distribution/Backpack/PreModuleShape.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module Distribution.Backpack.PreModuleShape
src/Distribution/Backpack/ReadyComponent.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>@@ -210,7 +211,7 @@ in (f x, s') instance Applicative InstM where- pure a = InstM $ \s -> (a, s)+ pure a = InstM (a,) InstM f <*> InstM x = InstM $ \s -> let (f', s') = f s (x', s'') = x s'@@ -402,11 +403,9 @@ -- Top-level instantiation per subst0 | not (Map.null subst0) , [lc] <- filter lc_public (Map.elems cmap) =- do- _ <- instantiateUnitId (lc_cid lc) subst0- return ()+ void $ instantiateUnitId (lc_cid lc) subst0 | 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 void $ instantiateUnitId (lc_cid lc) Map.empty+ else void $ indefiniteUnitId (lc_cid lc)
src/Distribution/Backpack/UnifyM.hs view
@@ -186,7 +186,7 @@ failIfErrs = do env <- getUnifEnv errs <- liftST $ readSTRef (unify_errs env)- when (not (null errs)) failM+ unless (null errs) failM tryM :: UnifyM s a -> UnifyM s (Maybe a) tryM m =@@ -535,9 +535,7 @@ <+> vcat (map pretty (v : vs)) return v - let req_rename_fn k = case Map.lookup k req_rename of- Nothing -> k- Just v -> v+ let req_rename_fn k = Map.findWithDefault k k req_rename -- Requirement substitution. --
src/Distribution/Compat/Async.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}- -- | 'Async', yet using 'MVar's. -- -- Adopted from @async@ library@@ -29,6 +26,8 @@ ( BlockedIndefinitelyOnMVar (..) , Exception (..) , SomeException (..)+ , asyncExceptionFromException+ , asyncExceptionToException , catch , evaluate , mask@@ -38,13 +37,8 @@ , 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)-#endif- -- | Async, but based on 'MVar', as we don't depend on @stm@. data AsyncM a = Async { asyncThreadId :: {-# UNPACK #-} !ThreadId@@ -145,18 +139,13 @@ deriving ( Show , Eq- , Typeable ) -{- FOURMOLU_DISABLE -} instance Exception AsyncCancelled where-#if MIN_VERSION_base(4,7,0) -- wraps in SomeAsyncException -- See https://github.com/ghc/ghc/commit/756a970eacbb6a19230ee3ba57e24999e4157b09 fromException = asyncExceptionFromException toException = asyncExceptionToException-#endif-{- FOURMOLU_ENABLE -} -- | Cancel an asynchronous action --
src/Distribution/Compat/CopyFile.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} +{- HLINT ignore "Use fewer imports" -}+ module Distribution.Compat.CopyFile ( copyFile , copyFileChanged@@ -15,23 +17,29 @@ import Distribution.Compat.Prelude import Prelude () -#ifndef mingw32_HOST_OS-import Distribution.Compat.Internal.TempFile+import qualified Data.ByteString.Lazy as BSL+import System.Directory+ ( doesFileExist+ )+import System.IO+ ( IOMode (ReadMode)+ , hFileSize+ , withBinaryFile+ ) +#ifndef mingw32_HOST_OS import Control.Exception ( bracketOnError )-import qualified Data.ByteString.Lazy as BSL import Data.Bits ( (.|.) ) import System.IO.Error ( ioeSetLocation ) import System.Directory- ( doesFileExist, renameFile, removeFile )+ ( renameFile, removeFile ) import System.FilePath ( takeDirectory ) import System.IO- ( IOMode(ReadMode), hClose, hGetBuf, hPutBuf, hFileSize- , withBinaryFile )+ ( hClose, hGetBuf, hPutBuf, openBinaryTempFile ) import Foreign ( allocaBytes ) @@ -42,28 +50,9 @@ #else /* else mingw32_HOST_OS */ -import qualified Data.ByteString.Lazy as BSL-import System.IO.Error- ( ioeSetLocation ) import System.Directory- ( doesFileExist )-import System.FilePath- ( addTrailingPathSeparator- , hasTrailingPathSeparator- , isPathSeparator- , isRelative- , joinDrive- , joinPath- , pathSeparator- , pathSeparators- , splitDirectories- , splitDrive- )-import System.IO- ( IOMode(ReadMode), hFileSize- , withBinaryFile )+ ( copyFileWithMetadata ) -import qualified System.Win32.File as Win32 ( copyFile ) #endif /* mingw32_HOST_OS */ copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO ()@@ -91,11 +80,11 @@ -- | Copies a file to a new destination. -- Often you should use `copyFileChanged` instead. copyFile :: FilePath -> FilePath -> IO ()+#ifndef mingw32_HOST_OS copyFile fromFPath toFPath = copy `catchIO` (\ioe -> throwIO (ioeSetLocation ioe "copyFile")) where-#ifndef mingw32_HOST_OS copy = withBinaryFile fromFPath ReadMode $ \hFrom -> bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) -> do allocaBytes bufferSize $ copyContents hFrom hTmp@@ -113,116 +102,7 @@ hPutBuf hTo buffer count copyContents hFrom hTo buffer #else- copy = Win32.copyFile (toExtendedLengthPath fromFPath)- (toExtendedLengthPath toFPath)- False---- NOTE: Shamelessly lifted from System.Directory.Internal.Windows---- | Add the @"\\\\?\\"@ prefix if necessary or possible. The path remains--- unchanged if the prefix is not added. This function can sometimes be used--- to bypass the @MAX_PATH@ length restriction in Windows API calls.------ See Note [Path normalization].-toExtendedLengthPath :: FilePath -> FilePath-toExtendedLengthPath path- | isRelative path = path- | otherwise =- case normalisedPath of- '\\' : '?' : '?' : '\\' : _ -> normalisedPath- '\\' : '\\' : '?' : '\\' : _ -> normalisedPath- '\\' : '\\' : '.' : '\\' : _ -> normalisedPath- '\\' : subpath@('\\' : _) -> "\\\\?\\UNC" <> subpath- _ -> "\\\\?\\" <> normalisedPath- where normalisedPath = simplifyWindows path---- | Similar to 'normalise' but:------ * empty paths stay empty,--- * parent dirs (@..@) are expanded, and--- * paths starting with @\\\\?\\@ are preserved.------ The goal is to preserve the meaning of paths better than 'normalise'.------ Note [Path normalization]--- 'normalise' doesn't simplify path names but will convert / into \\--- this would normally not be a problem as once the path hits the RTS we would--- have simplified the path then. However since we're calling the WIn32 API--- directly we have to do the simplification before the call. Without this the--- path Z:// would become Z:\\\\ and when converted to a device path the path--- becomes \\?\Z:\\\\ which is an invalid path.------ This is not a bug in normalise as it explicitly states that it won't simplify--- a FilePath.-simplifyWindows :: FilePath -> FilePath-simplifyWindows "" = ""-simplifyWindows path =- case drive' of- "\\\\?\\" -> drive' <> subpath- _ -> simplifiedPath- where- simplifiedPath = joinDrive drive' subpath'- (drive, subpath) = splitDrive path- drive' = upperDrive (normaliseTrailingSep (normalisePathSeps drive))- subpath' = appendSep . avoidEmpty . prependSep . joinPath .- stripPardirs . expandDots . skipSeps .- splitDirectories $ subpath-- upperDrive d = case d of- c : ':' : s | isAlpha c && all isPathSeparator s -> toUpper c : ':' : s- _ -> d- skipSeps = filter (not . (`elem` (pure <$> pathSeparators)))- stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== "..")- | otherwise = id- prependSep | subpathIsAbsolute = (pathSeparator :)- | otherwise = id- avoidEmpty | not pathIsAbsolute- && (null drive || hasTrailingPathSep) -- prefer "C:" over "C:."- = emptyToCurDir- | otherwise = id- appendSep p | hasTrailingPathSep- && not (pathIsAbsolute && null p)- = addTrailingPathSeparator p- | otherwise = p- pathIsAbsolute = not (isRelative path)- subpathIsAbsolute = any isPathSeparator (take 1 subpath)- hasTrailingPathSep = hasTrailingPathSeparator subpath---- | Given a list of path segments, expand @.@ and @..@. The path segments--- must not contain path separators.-expandDots :: [FilePath] -> [FilePath]-expandDots = reverse . go []- where- go ys' xs' =- case xs' of- [] -> ys'- x : xs ->- case x of- "." -> go ys' xs- ".." ->- case ys' of- [] -> go (x : ys') xs- ".." : _ -> go (x : ys') xs- _ : ys -> go ys xs- _ -> go (x : ys') xs---- | Convert to the right kind of slashes.-normalisePathSeps :: FilePath -> FilePath-normalisePathSeps p = (\ c -> if isPathSeparator c then pathSeparator else c) <$> p---- | Remove redundant trailing slashes and pick the right kind of slash.-normaliseTrailingSep :: FilePath -> FilePath-normaliseTrailingSep path = do- let path' = reverse path- let (sep, path'') = span isPathSeparator path'- let addSep = if null sep then id else (pathSeparator :)- reverse (addSep path'')---- | Convert empty paths to the current directory, otherwise leave it--- unchanged.-emptyToCurDir :: FilePath -> FilePath-emptyToCurDir "" = "."-emptyToCurDir path = path+copyFile = copyFileWithMetadata #endif /* mingw32_HOST_OS */ -- | Like `copyFile`, but does not touch the target if source and destination
− src/Distribution/Compat/Directory.hs
@@ -1,48 +0,0 @@-{-# LANGUAGE CPP #-}--module Distribution.Compat.Directory- ( listDirectory- , makeAbsolute- , doesPathExist- ) where--#if MIN_VERSION_directory(1,2,7)-import System.Directory as Dir hiding (doesPathExist)-import System.Directory (doesPathExist)-#else-import System.Directory as Dir-#endif-#if !MIN_VERSION_directory(1,2,2)-import System.FilePath as Path-#endif--#if !MIN_VERSION_directory(1,2,5)--listDirectory :: FilePath -> IO [FilePath]-listDirectory path =- filter f `fmap` Dir.getDirectoryContents path- where f filename = filename /= "." && filename /= ".."--#endif--#if !MIN_VERSION_directory(1,2,2)--makeAbsolute :: FilePath -> IO FilePath-makeAbsolute p | Path.isAbsolute p = return p- | otherwise = do- cwd <- Dir.getCurrentDirectory- return $ cwd </> p--#endif--#if !MIN_VERSION_directory(1,2,7)--doesPathExist :: FilePath -> IO Bool-doesPathExist path = do- -- not using Applicative, as this way we can do less IO- e <- doesDirectoryExist path- if e- then return True- else doesFileExist path--#endif
src/Distribution/Compat/Environment.hs view
@@ -1,6 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-} {-# OPTIONS_HADDOCK hide #-} module Distribution.Compat.Environment (getEnvironment, lookupEnv, setEnv, unsetEnv)@@ -8,22 +6,10 @@ import Distribution.Compat.Prelude import Prelude ()-import qualified Prelude import System.Environment (lookupEnv, unsetEnv) import qualified System.Environment as System--import Distribution.Compat.Stack--#ifdef mingw32_HOST_OS-import Foreign.C-import GHC.Windows-#else-import Foreign.C.Types-import Foreign.C.String-import Foreign.C.Error (throwErrnoIfMinus1_)-import System.Posix.Internals ( withFilePath )-#endif /* mingw32_HOST_OS */+import qualified System.Environment.Blank as Blank (setEnv) getEnvironment :: IO [(String, String)] #ifdef mingw32_HOST_OS@@ -39,48 +25,5 @@ #endif -- | @setEnv name value@ sets the specified environment variable to @value@.------ Throws `Control.Exception.IOException` if either @name@ or @value@ is the--- empty string or contains an equals sign. setEnv :: String -> String -> IO ()-setEnv key value_ = setEnv_ key value- where- -- NOTE: Anything that follows NUL is ignored on both POSIX and Windows. We- -- still strip it manually so that the null check above succeeds if a value- -- starts with NUL.- value = takeWhile (/= '\NUL') value_--setEnv_ :: String -> String -> IO ()--#ifdef mingw32_HOST_OS--setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do- success <- c_SetEnvironmentVariable k v- unless success (throwGetLastError "setEnv")- where- _ = callStack -- TODO: attach CallStack to exception--{- FOURMOLU_DISABLE -}-# if defined(i386_HOST_ARCH)-# define WINDOWS_CCONV stdcall-# elif defined(x86_64_HOST_ARCH)-# define WINDOWS_CCONV ccall-# else-# error Unknown mingw32 arch-# endif /* i386_HOST_ARCH */--foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW"- c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> Prelude.IO Bool-#else-setEnv_ key value = do- withFilePath key $ \ keyP ->- withFilePath value $ \ valueP ->- throwErrnoIfMinus1_ "setenv" $- c_setenv keyP valueP (fromIntegral (fromEnum True))- where- _ = callStack -- TODO: attach CallStack to exception--foreign import ccall unsafe "setenv"- c_setenv :: CString -> CString -> CInt -> Prelude.IO CInt-#endif /* mingw32_HOST_OS */-{- FOURMOLU_ENABLE -}+setEnv key value = Blank.setEnv key value True
− src/Distribution/Compat/FilePath.hs
@@ -1,26 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-}--module Distribution.Compat.FilePath- ( isExtensionOf- , stripExtension- ) where--import Data.List (isSuffixOf, stripPrefix)-import System.FilePath--#if !MIN_VERSION_filepath(1,4,2)-isExtensionOf :: String -> FilePath -> Bool-isExtensionOf ext@('.':_) = isSuffixOf ext . takeExtensions-isExtensionOf ext = isSuffixOf ('.':ext) . takeExtensions-#endif--#if !MIN_VERSION_filepath(1,4,1)-stripExtension :: String -> FilePath -> Maybe FilePath-stripExtension [] path = Just path-stripExtension ext@(x:_) path = stripSuffix dotExt path- where- dotExt = if isExtSeparator x then ext else '.':ext- stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]- stripSuffix xs ys = fmap reverse $ stripPrefix (reverse xs) (reverse ys)-#endif
src/Distribution/Compat/GetShortPathName.hs view
@@ -1,56 +1,29 @@ {-# LANGUAGE CPP #-} ---------------------------------------------------------------------------------- |--- Module : Distribution.Compat.GetShortPathName+-- | Win32 API 'GetShortPathName' function, which returns MS DOS short path name+-- (up to 8 characters for file name + 3 for file extension). ----- Maintainer : cabal-devel@haskell.org--- Portability : Windows-only+-- What's going on here? Why do we care about MS DOS?+-- In practice the short name serves as an alternative name,+-- which does not contain spaces even if the original name does.+-- Some applications (including certain versions of Autoconf) do not like+-- spaces in filenames, so getting a short path name gives us+-- a chance to work around it. That's not bullet proof though:+-- some objects might not have a short name. ----- Win32 API 'GetShortPathName' function.+-- Writing this comment in 2026, I don't know whether the aforementioned+-- issue with Autoconf and spaces remains relevant. It's possible+-- that things have improved during the last 10 years+-- since https://github.com/haskell/cabal/issues/3185 was merged.+--+-- Compare to the similar functionality in Stack:+-- https://hackage.haskell.org/package/stack-3.3.1/docs/src/Stack.Config.html#local-6989586621679973356 module Distribution.Compat.GetShortPathName (getShortPathName) where -import Distribution.Compat.Prelude-import Prelude ()- #ifdef mingw32_HOST_OS -import qualified Prelude-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-#define WINAPI stdcall-#endif--foreign import WINAPI unsafe "windows.h GetShortPathNameW"- c_GetShortPathName :: LPCTSTR -> LPTSTR -> DWORD -> Prelude.IO DWORD---- | On Windows, retrieves the short path form of the specified path. On--- non-Windows, does nothing. See https://github.com/haskell/cabal/issues/3185.------ From MS's GetShortPathName docs:------ Passing NULL for [the second] parameter and zero for cchBuffer--- will always return the required buffer size for a--- specified lpszLongPath.----getShortPathName :: FilePath -> IO FilePath-getShortPathName path =- Win32.withTString path $ \c_path -> do- c_len <- Win32.failIfZero "GetShortPathName #1 failed!" $- c_GetShortPathName c_path Win32.nullPtr 0- let arr_len = fromIntegral c_len- allocaArray arr_len $ \c_out -> do- void $ Win32.failIfZero "GetShortPathName #2 failed!" $- c_GetShortPathName c_path c_out c_len- Win32.peekTString c_out+import System.Win32.Info (getShortPathName) #else @@ -58,4 +31,3 @@ getShortPathName path = return path #endif-{- FOURMOLU_ENABLE -}
src/Distribution/Compat/Internal/TempFile.hs view
@@ -10,21 +10,11 @@ import Distribution.Compat.Exception +import GHC.IORef (IORef, atomicModifyIORef'_, newIORef) import System.FilePath ((</>))--import System.IO (Handle, openBinaryTempFile, openTempFile)-#if defined(__IO_MANAGER_WINIO__)-import System.IO (openBinaryTempFileWithDefaultPermissions)-#else-import Control.Exception (onException)-import Data.Bits ((.|.))-import Foreign.C (CInt, eEXIST, getErrno, errnoToIOError)-import GHC.IO.Handle.FD (fdToHandle)-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 (Handle, openBinaryTempFile, openBinaryTempFileWithDefaultPermissions, openTempFile) import System.IO.Error (isAlreadyExistsError)+import System.IO.Unsafe (unsafePerformIO) import System.Posix.Internals (c_getpid) #if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)@@ -33,106 +23,27 @@ import qualified System.Posix #endif --- ---------------------------------------------------------------- * temporary files---- ---------------------------------------------------------------- This is here for Haskell implementations that do not come with--- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9.--- TODO: This file should probably be removed.---- This is a copy/paste of the openBinaryTempFile definition, but--- it uses 666 rather than 600 for the permissions. Newer versions--- of base have a new function with this behavior which we use on--- 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.-#if defined(__IO_MANAGER_WINIO__)- openBinaryTempFileWithDefaultPermissions dir template-#else- pid <- c_getpid- findTempName pid- where- -- We split off the last extension, so we can use .foo.ext files- -- for temporary files (hidden on Unix OSes). Unfortunately we're- -- below file path in the hierarchy here.- (prefix,suffix) =- case break (== '.') $ reverse template of- -- First case: template contains no '.'s. Just re-reverse it.- (rev_suffix, "") -> (reverse rev_suffix, "")- -- Second case: template contains at least one '.'. Strip the- -- dot from the prefix and prepend it to the suffix (if we don't- -- do this, the unique number will get added after the '.' and- -- thus be part of the extension, which is wrong.)- (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)- -- Otherwise, something is wrong, because (break (== '.')) should- -- always return a pair with either the empty string or a string- -- beginning with '.' as the second component.- _ -> error "bug in System.IO.openTempFile"-- oflags = rw_flags .|. o_EXCL .|. o_BINARY-- findTempName x = do- fd <- withFilePath filepath $ \ f ->- c_open f oflags 0o666- if fd < 0- then do- errno <- getErrno- if errno == eEXIST- then findTempName (x+1)- else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))- else do- -- TODO: We want to tell fdToHandle what the file path is,- -- as any exceptions etc will only be able to report the- -- FD currently- h <- fdToHandle fd `onException` c_close fd- return (filepath, h)- where- filename = prefix ++ show x ++ suffix- filepath = dir `combine` filename-- -- FIXME: bits copied from System.FilePath- combine a b- | null b = a- | null a = b- | last a == pathSeparator = a ++ b- | otherwise = a ++ [pathSeparator] ++ b---- FIXME: Copied from GHC.Handle-std_flags, output_flags, rw_flags :: CInt-std_flags = o_NONBLOCK .|. o_NOCTTY-output_flags = std_flags .|. o_CREAT-rw_flags = output_flags .|. o_RDWR---- FIXME: Should use System.FilePath library-pathSeparator :: Char-#ifdef mingw32_HOST_OS-pathSeparator = '\\'-#else-pathSeparator = '/'-#endif--- /* __IO_MANAGER_WINIO__ */-#endif+openNewBinaryFile = openBinaryTempFileWithDefaultPermissions createTempDirectory :: FilePath -> String -> IO FilePath createTempDirectory dir template = do pid <- c_getpid- findTempName pid- where- findTempName x = do- let dirpath = dir </> template ++ "-" ++ show x- r <- tryIO $ mkPrivateDir dirpath- case r of- Right _ -> return dirpath- Left e- | isAlreadyExistsError e -> findTempName (x + 1)- | otherwise -> ioError e+ let findTempName = do+ (counter, _) <- atomicModifyIORef'_ tempDirectoryCounter (+ 1)+ let relpath = template ++ "-" ++ show pid ++ show counter+ dirpath = dir </> relpath+ r <- tryIO $ mkPrivateDir dirpath+ case r of+ Right _ -> pure relpath+ Left e+ | isAlreadyExistsError e -> findTempName+ | otherwise -> ioError e+ findTempName++tempDirectoryCounter :: IORef Word+tempDirectoryCounter = unsafePerformIO $ newIORef 0+{-# NOINLINE tempDirectoryCounter #-} mkPrivateDir :: String -> IO () #if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)
src/Distribution/Compat/ResponseFile.hs view
@@ -1,76 +1,21 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}---- Compatibility layer for GHC.ResponseFile--- Implementation from base 4.12.0 is used.--- http://hackage.haskell.org/package/base-4.12.0.0/src/LICENSE module Distribution.Compat.ResponseFile (expandResponse, escapeArgs) where import Distribution.Compat.Prelude++import GHC.ResponseFile (escapeArgs, unescapeArgs)+ import Prelude () import System.FilePath import System.IO (hPutStrLn, stderr) import System.IO.Error -#if MIN_VERSION_base(4,12,0)-import GHC.ResponseFile (unescapeArgs, escapeArgs)-#else--unescapeArgs :: String -> [String]-unescapeArgs = filter (not . null) . unescape--data Quoting = NoneQ | SngQ | DblQ--unescape :: String -> [String]-unescape args = reverse . map reverse $ go args NoneQ False [] []- where- -- n.b., the order of these cases matters; these are cribbed from gcc- -- case 1: end of input- go [] _q _bs a as = a:as- -- case 2: back-slash escape in progress- go (c:cs) q True a as = go cs q False (c:a) as- -- case 3: no back-slash escape in progress, but got a back-slash- go (c:cs) q False a as- | '\\' == c = go cs q True a as- -- case 4: single-quote escaping in progress- go (c:cs) SngQ False a as- | '\'' == c = go cs NoneQ False a as- | otherwise = go cs SngQ False (c:a) as- -- case 5: double-quote escaping in progress- go (c:cs) DblQ False a as- | '"' == c = go cs NoneQ False a as- | otherwise = go cs DblQ False (c:a) as- -- case 6: no escaping is in progress- go (c:cs) NoneQ False a as- | isSpace c = go cs NoneQ False [] (a:as)- | '\'' == c = go cs SngQ False a as- | '"' == c = go cs DblQ False a as- | otherwise = go cs NoneQ False (c:a) as--escapeArgs :: [String] -> String-escapeArgs = unlines . map escapeArg--escapeArg :: String -> String-escapeArg = reverse . foldl' escape []--escape :: String -> Char -> String-escape cs c- | isSpace c- || '\\' == c- || '\'' == c- || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result- | otherwise = c:cs--#endif---- | The arg file / response file parser.------ This is not a well-documented capability, and is a bit eccentric--- (try @cabal \@foo \@bar@ to see what that does), but is crucial--- for allowing complex arguments to cabal and cabal-install when--- using command prompts with strongly-limited argument length.+-- | This is a more elaborate version of 'GHC.ResponseFile.expandResponse',+-- which not only substitute @\@foo@ with the contents of file @foo@,+-- but performs such substitution recursively.+-- In doing so we keep closer to the reference implementation+-- of @expandargv@ in @argv.c@ from @binutils@, although this additional functionality+-- likely remains unused by Haskell tooling. expandResponse :: [String] -> IO [String] expandResponse = go recursionLimit "." where@@ -82,8 +27,8 @@ | 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 (return [arg]) expand _n _dir x = return [x] readRecursively :: Int -> FilePath -> IO [String]- readRecursively n f = go (n - 1) (takeDirectory f) =<< unescapeArgs <$> readFile f+ readRecursively n f = go (n - 1) (takeDirectory f) . unescapeArgs =<< readFile f
− src/Distribution/Compat/SnocList.hs
@@ -1,34 +0,0 @@---------------------------------------------------------------------------------- |--- Module : Distribution.Compat.SnocList--- License : BSD3------ Maintainer : cabal-dev@haskell.org--- Stability : experimental--- Portability : portable------ A very reversed list. Has efficient `snoc`-module Distribution.Compat.SnocList- ( SnocList- , runSnocList- , snoc- ) where--import Distribution.Compat.Prelude-import Prelude ()--newtype SnocList a = SnocList [a]--snoc :: SnocList a -> a -> SnocList a-snoc (SnocList xs) x = SnocList (x : xs)--runSnocList :: SnocList a -> [a]-runSnocList (SnocList xs) = reverse xs--instance Semigroup (SnocList a) where- SnocList xs <> SnocList ys = SnocList (ys <> xs)--instance Monoid (SnocList a) where- mempty = SnocList []- mappend = (<>)
src/Distribution/Compat/Stack.hs view
@@ -1,11 +1,9 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE RankNTypes #-} module Distribution.Compat.Stack ( WithCallStack , CallStack- , annotateCallStackIO , withFrozenCallStack , withLexicalCallStack , callStack@@ -13,103 +11,26 @@ , parentSrcLocPrefix ) where -import System.IO.Error--#ifdef MIN_VERSION_base-#if MIN_VERSION_base(4,8,1)-#define GHC_STACK_SUPPORTED 1-#endif-#endif--#ifdef GHC_STACK_SUPPORTED import GHC.Stack-#endif -#ifdef GHC_STACK_SUPPORTED--#if MIN_VERSION_base(4,9,0) type WithCallStack a = HasCallStack => a-#elif MIN_VERSION_base(4,8,1)-type WithCallStack a = (?callStack :: CallStack) => a-#endif -#if !MIN_VERSION_base(4,9,0)--- NB: Can't say WithCallStack (WithCallStack a -> a);--- Haskell doesn't support this kind of implicit parameter!--- See https://mail.haskell.org/pipermail/ghc-devs/2016-January/011096.html--- Since this function doesn't do anything, it's OK to--- give it a less good type.-withFrozenCallStack :: WithCallStack (a -> a)-withFrozenCallStack x = x--callStack :: (?callStack :: CallStack) => CallStack-callStack = ?callStack--prettyCallStack :: CallStack -> String-prettyCallStack = showCallStack-#endif- -- | Give the *parent* of the person who invoked this; -- so it's most suitable for being called from a utility function. -- You probably want to call this using 'withFrozenCallStack'; otherwise--- it's not very useful. We didn't implement this for base-4.8.1--- because we cannot rely on freezing to have taken place.---+-- it's not very useful. parentSrcLocPrefix :: WithCallStack String-#if MIN_VERSION_base(4,9,0) parentSrcLocPrefix = case getCallStack callStack of- (_:(_, loc):_) -> showLoc loc+ (_ : (_, loc) : _) -> showLoc loc [(_, loc)] -> showLoc loc [] -> error "parentSrcLocPrefix: empty call stack"- where- showLoc loc =- srcLocFile loc ++ ":" ++ show (srcLocStartLine loc) ++ ": "-#else-parentSrcLocPrefix = "Call sites not available with base < 4.9.0.0 (GHC 8.0): "-#endif+ where+ showLoc loc =+ srcLocFile loc ++ ":" ++ show (srcLocStartLine loc) ++ ": " -- Yeah, this uses skivvy implementation details. withLexicalCallStack :: (a -> WithCallStack (IO b)) -> WithCallStack (a -> IO b) withLexicalCallStack f =- let stk = ?callStack- in \x -> let ?callStack = stk in f x--#else--data CallStack = CallStack- deriving (Eq, Show)--type WithCallStack a = a--withFrozenCallStack :: a -> a-withFrozenCallStack x = x--callStack :: CallStack-callStack = CallStack--prettyCallStack :: CallStack -> String-prettyCallStack _ = "Call stacks not available with base < 4.8.1.0 (GHC 7.10)"--parentSrcLocPrefix :: String-parentSrcLocPrefix = "Call sites not available with base < 4.9.0.0 (GHC 8.0): "--withLexicalCallStack :: (a -> IO b) -> a -> IO b-withLexicalCallStack f = f--#endif---- | This function is for when you *really* want to add a call--- stack to raised IO, but you don't have a--- 'Distribution.Verbosity.Verbosity' so you can't use--- 'Distribution.Simple.Utils.annotateIO'. If you have a 'Verbosity',--- please use that function instead.-annotateCallStackIO :: WithCallStack (IO a -> IO a)-annotateCallStackIO = modifyIOError f- where- f ioe =- ioeSetErrorString ioe- . wrapCallStack- $ ioeGetErrorString ioe- wrapCallStack s =- prettyCallStack callStack ++ "\n" ++ s+ let stk = ?callStack+ in \x -> let ?callStack = stk in f x
+ src/Distribution/Compat/SysInfo.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE CPP #-}++module Distribution.Compat.SysInfo+ ( fullCompilerVersion+ ) where++import Data.Version (Version)+import qualified System.Info as SI++fullCompilerVersion :: Version+#if MIN_VERSION_base(4,15,0)+fullCompilerVersion = SI.fullCompilerVersion+#else+fullCompilerVersion = SI.compilerVersion+#endif
src/Distribution/Compat/Time.hs view
@@ -1,18 +1,11 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-} module Distribution.Compat.Time- ( ModTime (..) -- Needed for testing+ ( ModTime , getModTime , getFileAge , getCurTime- , posixSecondsToModTime- , calibrateMtimeChangeDelay ) where @@ -21,44 +14,13 @@ import System.Directory (getModificationTime) -import Distribution.Simple.Utils (withTempDirectory)-import Distribution.Verbosity (silent)--import System.FilePath- import Data.Time (diffUTCTime, getCurrentTime)-import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixDayLength)--#if defined mingw32_HOST_OS--import qualified Prelude-import Data.Bits ((.|.), unsafeShiftL)-#if MIN_VERSION_base(4,7,0)-import Data.Bits (finiteBitSize)-#else-import Data.Bits (bitSize)-#endif--import Foreign ( allocaBytes, peekByteOff )-import System.IO.Error ( mkIOError, doesNotExistErrorType )-import System.Win32.Types ( BOOL, DWORD, LPCTSTR, LPVOID, withTString )--#else--import System.Posix.Files ( FileStatus, getFileStatus )--#if MIN_VERSION_unix(2,6,0)-import System.Posix.Files ( modificationTimeHiRes )-#else-import System.Posix.Files ( modificationTime )-#endif--#endif+import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixDayLength, utcTimeToPOSIXSeconds) --- | An opaque type representing a file's modification time, represented+-- | 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) instance Structured ModTime @@ -68,89 +30,14 @@ instance Read ModTime where readsPrec p str = map (first ModTime) (readsPrec p str) --- | Return modification time of the given file. Works around the low clock--- resolution problem that 'getModificationTime' has on GHC < 7.8.------ This is a modified version of the code originally written for Shake by Neil--- Mitchell. See module Development.Shake.FileInfo.+-- | Return modification time of the given file. getModTime :: FilePath -> IO ModTime--#if defined mingw32_HOST_OS---- Directly against the Win32 API.-getModTime path = allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA $ \info -> do- res <- getFileAttributesEx path info- if not res- then do- let err = mkIOError doesNotExistErrorType- "Distribution.Compat.Time.getModTime"- Nothing (Just path)- ioError err- else do- dwLow <- peekByteOff info- index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime- dwHigh <- peekByteOff info- index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime-#if MIN_VERSION_base(4,7,0)- let qwTime =- (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` finiteBitSize dwHigh)- .|. (fromIntegral (dwLow :: DWORD))-#else- let qwTime =- (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` bitSize dwHigh)- .|. (fromIntegral (dwLow :: DWORD))-#endif- return $! ModTime (qwTime :: Word64)--{- FOURMOLU_DISABLE -}-#ifdef x86_64_HOST_ARCH-#define CALLCONV ccall-#else-#define CALLCONV stdcall-#endif--foreign import CALLCONV "windows.h GetFileAttributesExW"- c_getFileAttributesEx :: LPCTSTR -> Int32 -> LPVOID -> Prelude.IO BOOL--getFileAttributesEx :: String -> LPVOID -> IO BOOL-getFileAttributesEx path lpFileInformation =- withTString path $ \c_path ->- c_getFileAttributesEx c_path getFileExInfoStandard lpFileInformation--getFileExInfoStandard :: Int32-getFileExInfoStandard = 0--size_WIN32_FILE_ATTRIBUTE_DATA :: Int-size_WIN32_FILE_ATTRIBUTE_DATA = 36--index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime :: Int-index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20--index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime :: Int-index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime = 24--#else---- Directly against the unix library.-getModTime path = do- st <- getFileStatus path- return $! (extractFileTime st)--extractFileTime :: FileStatus -> ModTime-extractFileTime x = posixTimeToModTime (modificationTimeHiRes x)--#endif-{- FOURMOLU_ENABLE -}+getModTime = fmap (posixTimeToModTime . utcTimeToPOSIXSeconds) . getModificationTime windowsTick, secToUnixEpoch :: Word64 windowsTick = 10000000 secToUnixEpoch = 11644473600 --- | Convert POSIX seconds to ModTime.-posixSecondsToModTime :: Int64 -> ModTime-posixSecondsToModTime s =- ModTime $ ((fromIntegral s :: Word64) + secToUnixEpoch) * windowsTick- -- | Convert 'POSIXTime' to 'ModTime'. posixTimeToModTime :: POSIXTime -> ModTime posixTimeToModTime p =@@ -167,33 +54,4 @@ -- | Return the current time as 'ModTime'. getCurTime :: IO ModTime-getCurTime = posixTimeToModTime `fmap` getPOSIXTime -- Uses 'gettimeofday'.---- | Based on code written by Neil Mitchell for Shake. See--- 'sleepFileTimeCalibrate' in 'Test.Type'. Returns a pair--- of microsecond values: first, the maximum delay seen, and the--- recommended delay to use before testing for file modification change.--- The returned delay is never smaller--- than 10 ms, but never larger than 1 second.-calibrateMtimeChangeDelay :: IO (Int, Int)-calibrateMtimeChangeDelay =- withTempDirectory silent "." "calibration-" $ \dir -> do- let fileName = dir </> "probe"- mtimes <- for [1 .. 25] $ \(i :: Int) -> time $ do- writeFile fileName $ show i- t0 <- getModTime fileName- let spin j = do- writeFile fileName $ show (i, j)- t1 <- getModTime fileName- unless (t0 < t1) (spin $ j + 1)- spin (0 :: Int)- let mtimeChange = maximum mtimes- mtimeChange' = min 1000000 $ (max 10000 mtimeChange) * 2- return (mtimeChange, mtimeChange')- where- time :: IO () -> IO Int- time act = do- t0 <- getCurrentTime- act- t1 <- getCurrentTime- return . ceiling $! (t1 `diffUTCTime` t0) * 1e6 -- microseconds+getCurTime = posixTimeToModTime `fmap` getPOSIXTime
src/Distribution/GetOpt.hs view
@@ -134,11 +134,11 @@ -- | Pretty printing of short options. -- * With required arguments can be given as: -- @-w PATH or -wPATH (but not -w=PATH)@--- This is dislayed as:+-- This is displayed as: -- @-w PATH or -wPATH@ -- * With optional but default arguments can be given as: -- @-j or -jNUM (but not -j=NUM or -j NUM)@--- This is dislayed as:+-- This is displayed as: -- @-j[NUM]@ fmtShort :: ArgDescr a -> Char -> String fmtShort (NoArg _) so = "-" ++ [so]@@ -152,11 +152,11 @@ -- | Pretty printing of long options. -- * With required arguments can be given as: -- @--with-compiler=PATH (but not --with-compiler PATH)@--- This is dislayed as:+-- This is displayed as: -- @--with-compiler=PATH@ -- * With optional but default arguments can be given as: -- @--jobs or --jobs=NUM (but not --jobs NUM)@--- This is dislayed as:+-- This is displayed as: -- @--jobs[=NUM]@ fmtLong :: ArgDescr a -> String -> String fmtLong (NoArg _) lo = "--" ++ lo@@ -230,7 +230,7 @@ -- 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 ['-', '-'] 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)
− src/Distribution/Make.hs
@@ -1,187 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}----------------------------------------------------------------------------------- copy :--- $(MAKE) install prefix=$(destdir)/$(prefix) \--- bindir=$(destdir)/$(bindir) \---- |--- Module : Distribution.Make--- Copyright : Martin Sjögren 2004--- License : BSD3------ Maintainer : cabal-devel@haskell.org--- Portability : portable------ This is an alternative build system that delegates everything to the @make@--- program. All the commands just end up calling @make@ with appropriate--- arguments. The intention was to allow preexisting packages that used--- makefiles to be wrapped into Cabal packages. In practice essentially all--- such packages were converted over to the \"Simple\" build system instead.--- Consequently this module is not used much and it certainly only sees cursory--- maintenance and no testing. Perhaps at some point we should stop pretending--- that it works.------ Uses the parsed command-line from "Distribution.Simple.Setup" in order to build--- Haskell tools using a back-end build system based on make. Obviously we--- assume that there is a configure script, and that after the ConfigCmd has--- been run, there is a Makefile. Further assumptions:------ [ConfigCmd] We assume the configure script accepts--- @--with-hc@,--- @--with-hc-pkg@,--- @--prefix@,--- @--bindir@,--- @--libdir@,--- @--libexecdir@,--- @--datadir@.------ [BuildCmd] We assume that the default Makefile target will build everything.------ [InstallCmd] We assume there is an @install@ target. Note that we assume that--- this does *not* register the package!------ [CopyCmd] We assume there is a @copy@ target, and a variable @$(destdir)@.--- The @copy@ target should probably just invoke @make install@--- recursively (e.g. @$(MAKE) install prefix=$(destdir)\/$(prefix)--- bindir=$(destdir)\/$(bindir)@. The reason we can\'t invoke @make--- install@ directly here is that we don\'t know the value of @$(prefix)@.------ [SDistCmd] We assume there is a @dist@ target.------ [RegisterCmd] We assume there is a @register@ target and a variable @$(user)@.------ [UnregisterCmd] We assume there is an @unregister@ target.------ [HaddockCmd] We assume there is a @docs@ or @doc@ target.-module Distribution.Make- ( module Distribution.Package- , License (..)- , Version- , defaultMain- , defaultMainArgs- ) where--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.Utils--import Distribution.License-import Distribution.Pretty-import Distribution.Version--import System.Environment (getArgs, getProgName)--defaultMain :: IO ()-defaultMain = getArgs >>= defaultMainArgs--defaultMainArgs :: [String] -> IO ()-defaultMainArgs = defaultMainHelper--defaultMainHelper :: [String] -> IO ()-defaultMainHelper args = do- command <- commandsRun (globalCommand commands) commands args- case command of- CommandHelp help -> printHelp help- CommandList opts -> printOptionsList opts- CommandErrors errs -> printErrors errs- CommandReadyToGo (flags, commandParse) ->- case commandParse of- _- | fromFlag (globalVersion flags) -> printVersion- | fromFlag (globalNumericVersion flags) -> printNumericVersion- CommandHelp help -> printHelp help- CommandList opts -> printOptionsList opts- CommandErrors errs -> printErrors errs- CommandReadyToGo action -> action- where- printHelp help = getProgName >>= putStr . help- printOptionsList = putStr . unlines- printErrors errs = do- putStr (intercalate "\n" errs)- exitWith (ExitFailure 1)- printNumericVersion = putStrLn $ 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- ]--configureAction :: ConfigFlags -> [String] -> IO ()-configureAction flags args = do- noExtraFlags args- let verbosity = fromFlag (configVerbosity flags)- rawSystemExit verbosity "sh" $- "configure"- : 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"-- rawSystemExit (fromFlag $ copyVerbosity flags) "make" destArgs--installAction :: InstallFlags -> [String] -> IO ()-installAction flags args = do- noExtraFlags args- rawSystemExit (fromFlag $ installVerbosity flags) "make" ["install"]- rawSystemExit (fromFlag $ installVerbosity flags) "make" ["register"]--haddockAction :: HaddockFlags -> [String] -> IO ()-haddockAction flags args = do- noExtraFlags args- rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["docs"]- `catchIO` \_ ->- rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"]--buildAction :: BuildFlags -> [String] -> IO ()-buildAction flags args = do- noExtraFlags args- rawSystemExit (fromFlag $ buildVerbosity flags) "make" []--cleanAction :: CleanFlags -> [String] -> IO ()-cleanAction flags args = do- noExtraFlags args- rawSystemExit (fromFlag $ cleanVerbosity flags) "make" ["clean"]--sdistAction :: SDistFlags -> [String] -> IO ()-sdistAction flags args = do- noExtraFlags args- rawSystemExit (fromFlag $ sDistVerbosity flags) "make" ["dist"]--registerAction :: RegisterFlags -> [String] -> IO ()-registerAction flags args = do- noExtraFlags args- rawSystemExit (fromFlag $ regVerbosity flags) "make" ["register"]--unregisterAction :: RegisterFlags -> [String] -> IO ()-unregisterAction flags args = do- noExtraFlags args- rawSystemExit (fromFlag $ regVerbosity flags) "make" ["unregister"]
src/Distribution/PackageDescription/Check.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} -- |@@ -46,10 +47,13 @@ import Prelude () import Data.List (group)+import qualified Data.List as L import Distribution.CabalSpecVersion import Distribution.Compat.Lens import Distribution.Compiler+import Distribution.FieldGrammar.Parsec (freeTextIgnoreDotlineVers) import Distribution.License+import Distribution.ModuleName (toFilePath) import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Check.Common@@ -70,25 +74,23 @@ import Distribution.Simple.Utils hiding (findPackageDesc, notice) import Distribution.Utils.Generic (isAscii) import Distribution.Utils.Path- ( LicenseFile- , PackageDir- , SymbolicPath- , getSymbolicPath- ) import Distribution.Verbosity import Distribution.Version-import System.FilePath (splitExtension, takeFileName, (<.>), (</>))+import System.FilePath (splitExtension, takeFileName) import qualified Data.ByteString.Lazy as BS import qualified Distribution.SPDX as SPDX import qualified System.Directory as System -import qualified System.Directory (getDirectoryContents)+import qualified System.Directory (listDirectory) 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.Utils.String as String +import qualified Distribution.Compat.Lens as L+import qualified Distribution.Types.BuildInfo.Lens as L import qualified Distribution.Types.GenericPackageDescription.Lens as L import Control.Monad@@ -175,16 +177,17 @@ CheckPackageContentOps { doesFileExist = System.doesFileExist . relative , doesDirectoryExist = System.doesDirectoryExist . relative- , getDirectoryContents = System.Directory.getDirectoryContents . relative+ , listDirectory = System.Directory.listDirectory . relative , getFileContents = BS.readFile . relative } checkPreIO = CheckPreDistributionOps { runDirFileGlobM = \fp g -> runDirFileGlob verbosity (Just . specVersion $ packageDescription gpd) (root </> fp) g- , getDirectoryContentsM = System.Directory.getDirectoryContents . relative+ , listDirectoryM = System.Directory.listDirectory . relative } + relative :: FilePath -> FilePath relative path = root </> path -- | Same as 'checkPackageFilesGPD', but working with 'PackageDescription'.@@ -242,7 +245,7 @@ -- Targets should be present... let condAllLibraries = maybeToList condLibrary_- ++ (map snd condSubLibraries_)+ ++ map snd condSubLibraries_ checkP ( and [ null condExecutables_@@ -271,8 +274,6 @@ checkP (not . null $ dups names) (PackageBuildImpossible $ DuplicateSections dupes)- -- PackageDescription checks.- checkPackageDescription packageDescription_ -- Flag names. mapM_ checkFlagName genPackageFlags_ @@ -353,6 +354,18 @@ -- Duplicate modules. mapM_ tellP (checkDuplicateModules gpd)++ -- Module name checks (path validity on Windows and tar).+ -- We collect all unique module names from the GPD and check each+ -- once, rather than re-checking in every conditional branch.+ let allModuleNames =+ Set.fromList $+ maybe [] (explicitLibModules . ignoreConditions) condLibrary_+ ++ concatMap (explicitLibModules . ignoreConditions . snd) condSubLibraries_+ ++ concatMap (exeModules . ignoreConditions . snd) condExecutables_+ ++ concatMap (testModules . ignoreConditions . snd) condTestSuites_+ ++ concatMap (benchmarkModules . ignoreConditions . snd) condBenchmarks_+ mapM_ (\m -> checkPackageFileNamesWithGlob PathKindFile (toFilePath m)) allModuleNames where -- todo is this caught at parse time? checkFlagName :: Monad m => PackageFlag -> CheckM m ()@@ -412,6 +425,7 @@ extraSrcFiles_ extraTmpFiles_ extraDocFiles_+ extraFiles_ ) = do -- § Sanity checks. checkPackageId package_@@ -427,7 +441,7 @@ -- But it is OK for executables to have the same name. nsubs <- asksCM (pnSubLibs . ccNames) checkP- (any (== prettyShow pn) (prettyShow <$> nsubs))+ (prettyShow pn `elem` (prettyShow <$> nsubs)) (PackageBuildImpossible $ IllegalLibraryName pn) -- § Fields check.@@ -455,27 +469,45 @@ ) (PackageDistSuspicious ShortDesc) + -- § Freeform fields no longer include "dotlines". Generally taken from+ -- Distribution.PackageDescription.FieldGrammar fields that use some+ -- freeTextField parser.+ checkDotline "author" _author_+ checkDotline "bug-reports" _bugReports_+ checkDotline "category" category_+ checkDotline "copyright" _copyright_+ checkDotline "description" description_+ checkDotline "homepage" _homepage_+ checkDotline "maintainer" maintainer_+ checkDotline "package-url" _pkgUrl_+ checkDotline "stability" _stability_+ checkDotline "synopsis" synopsis_+ -- § Paths.- mapM_ (checkPath False "extra-source-files" PathKindGlob) extraSrcFiles_- mapM_ (checkPath False "extra-tmp-files" PathKindFile) extraTmpFiles_- mapM_ (checkPath False "extra-doc-files" PathKindGlob) extraDocFiles_- mapM_ (checkPath False "data-files" PathKindGlob) dataFiles_- checkPath True "data-dir" PathKindDirectory dataDir_+ mapM_ (checkPath False "extra-source-files" PathKindGlob . getSymbolicPath) extraSrcFiles_+ mapM_ (checkPath False "extra-tmp-files" PathKindFile . getSymbolicPath) extraTmpFiles_+ mapM_ (checkPath False "extra-doc-files" PathKindGlob . getSymbolicPath) extraDocFiles_+ mapM_ (checkPath False "extra-files" PathKindGlob . getSymbolicPath) extraFiles_+ mapM_ (checkPath False "data-files" PathKindGlob . getSymbolicPath) dataFiles_+ let rawDataDir = getSymbolicPath dataDir_+ checkPath True "data-dir" PathKindDirectory rawDataDir let licPaths = map getSymbolicPath licenseFiles_ mapM_ (checkPath False "license-file" PathKindFile) licPaths mapM_ checkLicFileExist licenseFiles_ -- § Globs.- dataGlobs <- mapM (checkGlob "data-files") dataFiles_- extraGlobs <- mapM (checkGlob "extra-source-files") extraSrcFiles_- docGlobs <- mapM (checkGlob "extra-doc-files") extraDocFiles_+ dataGlobs <- mapM (checkGlob "data-files" . getSymbolicPath) dataFiles_+ extraSrcGlobs <- mapM (checkGlob "extra-source-files" . getSymbolicPath) extraSrcFiles_+ docGlobs <- mapM (checkGlob "extra-doc-files" . getSymbolicPath) extraDocFiles_+ extraGlobs <- mapM (checkGlob "extra-files" . getSymbolicPath) extraFiles_ -- We collect globs to feed them to checkMissingDocs. -- § Missing documentation. checkMissingDocs (catMaybes dataGlobs)- (catMaybes extraGlobs)+ (catMaybes extraSrcGlobs) (catMaybes docGlobs)+ (catMaybes extraGlobs) -- § Datafield checks. checkSetupBuildInfo setupBuildInfo_@@ -507,21 +539,22 @@ ( isNothing setupBuildInfo_ && buildTypeRaw_ == Just Custom )- (PackageDistSuspiciousWarn CVExpliticDepsCustomSetup)+ (PackageDistSuspiciousWarn CVExplicitDepsCustomSetup) checkP (isNothing buildTypeRaw_ && specVersion_ < CabalSpecV2_2) (PackageBuildWarning NoBuildType) checkP- (isJust setupBuildInfo_ && buildType pkg /= Custom)+ (isJust setupBuildInfo_ && buildType pkg `notElem` [Custom, Hooks]) (PackageBuildWarning NoCustomSetup) -- Contents. checkConfigureExists (buildType pkg) checkSetupExists (buildType pkg) checkCabalFile (packageName pkg)- mapM_ (checkGlobFile specVersion_ "." "extra-source-files") extraSrcFiles_- mapM_ (checkGlobFile specVersion_ "." "extra-doc-files") extraDocFiles_- mapM_ (checkGlobFile specVersion_ dataDir_ "data-files") dataFiles_+ mapM_ (checkGlobFile specVersion_ "." "extra-source-files" . getSymbolicPath) extraSrcFiles_+ mapM_ (checkGlobFile specVersion_ "." "extra-doc-files" . getSymbolicPath) extraDocFiles_+ mapM_ (checkGlobFile specVersion_ "." "extra-files" . getSymbolicPath) extraFiles_+ mapM_ (checkGlobFile specVersion_ rawDataDir "data-files" . getSymbolicPath) dataFiles_ where checkNull :: Monad m@@ -556,6 +589,19 @@ in tellP (PackageDistInexcusable (InvalidTestWith dep)) ) +-- | Issue a warning if the text contains any "dotlines".+checkDotline :: Monad m => String -> ShortText.ShortText -> CheckM m ()+checkDotline fieldName fieldVal = do+ checkSpecVerGte+ freeTextIgnoreDotlineVers+ (hasDotline fieldVal)+ (PackageDistSuspiciousWarn $ FreeTextDotline fieldName)+ where+ hasDotline =+ L.any ((== ".") . String.trim)+ . L.lines+ . ShortText.fromShortText+ checkSetupBuildInfo :: Monad m => Maybe SetupBuildInfo -> CheckM m () checkSetupBuildInfo Nothing = return () checkSetupBuildInfo (Just (SetupBuildInfo ds _)) = do@@ -565,16 +611,27 @@ rck = PackageDistSuspiciousWarn . MissingUpperBounds CETSetup- checkPVP ick is- checkPVPs rck rs+ leuck =+ PackageDistSuspiciousWarn+ . LEUpperBounds CETSetup+ tzuck =+ PackageDistSuspiciousWarn+ . TrailingZeroUpperBounds CETSetup+ gtlck =+ PackageDistSuspiciousWarn+ . GTLowerBounds CETSetup+ checkPVP (checkDependencyVersionRange $ not . hasUpperBound) ick is+ checkPVPs (checkDependencyVersionRange $ not . hasUpperBound) rck rs+ checkPVPs (checkDependencyVersionRange hasLEUpperBound) leuck ds+ checkPVPs (checkDependencyVersionRange hasTrailingZeroUpperBound) tzuck ds+ checkPVPs (checkDependencyVersionRange hasGTLowerBound) gtlck ds checkPackageId :: Monad m => PackageIdentifier -> CheckM m () checkPackageId (PackageIdentifier pkgName_ _pkgVersion_) = do checkP (not . FilePath.Windows.isValid . prettyShow $ pkgName_) (PackageDistInexcusable $ InvalidNameWin pkgName_)- checkP (isPrefixOf "z-" . prettyShow $ pkgName_) $- (PackageDistInexcusable ZPrefix)+ checkP (isPrefixOf "z-" . prettyShow $ pkgName_) (PackageDistInexcusable ZPrefix) checkNewLicense :: Monad m => SPDX.License -> CheckM m () checkNewLicense lic = do@@ -616,7 +673,7 @@ -- licenses so don't need license files. nullLicFiles )- $ (PackageDistSuspicious NoLicenseFile)+ (PackageDistSuspicious NoLicenseFile) case unknownLicenseVersion lic of Just knownVersions -> tellP@@ -681,6 +738,7 @@ checkP (isNothing repoLocation_) (PackageDistInexcusable MissingLocation)+ checkGitProtocol repoLocation_ checkP ( repoType_ == Just (KnownRepoType CVS) && isNothing repoModule_@@ -692,7 +750,7 @@ checkP (any isAbsoluteOnAnyPlatform repoSubdir_) (PackageDistInexcusable SubdirRelPath)- case join . fmap isGoodRelativeDirectoryPath $ repoSubdir_ of+ case isGoodRelativeDirectoryPath =<< repoSubdir_ of Just err -> tellP (PackageDistInexcusable $ SubdirGoodRelPath err)@@ -719,6 +777,17 @@ repoTypeDirname Monotone = ["_MTN"] repoTypeDirname Pijul = [".pijul"] +-- git:// lacks TLS or other encryption, see+-- https://git-scm.com/book/en/v2/Git-on-the-Server-The-Protocols#_the_cons_4+checkGitProtocol+ :: Monad m+ => Maybe String -- Repository location+ -> CheckM m ()+checkGitProtocol mloc =+ checkP+ (fmap (isPrefixOf "git://") mloc == Just True)+ (PackageBuildWarning GitProtocol)+ -- ------------------------------------------------------------ -- Package and distribution checks -- ------------------------------------------------------------@@ -729,7 +798,7 @@ findPackageDesc :: Monad m => CheckPackageContentOps m -> m [FilePath] findPackageDesc ops = do let dir = "."- files <- getDirectoryContents ops dir+ files <- listDirectory ops dir -- to make sure we do not mistake a ~/.cabal/ dir for a <name>.cabal -- file we filter to exclude dirs and null base file names: cabalFiles <-@@ -786,7 +855,7 @@ checkLicFileExist :: Monad m- => SymbolicPath PackageDir LicenseFile+ => RelativePath Pkg File -> CheckM m () checkLicFileExist sp = do let fp = getSymbolicPath sp@@ -808,7 +877,9 @@ ( \ops -> do ba <- doesFileExist ops "Setup.hs" bb <- doesFileExist ops "Setup.lhs"- return (not $ ba || bb)+ bc <- doesFileExist ops "SetupHooks.hs"+ bd <- doesFileExist ops "SetupHooks.lhs"+ return (not $ ba || bb || bc || bd) ) (PackageDistInexcusable MissingSetupFile) @@ -857,7 +928,7 @@ -- one). -> [GlobResult FilePath] -- List of glob results. -> [PackageCheck]-checkGlobResult title fp rs = dirCheck ++ catMaybes (map getWarning rs)+checkGlobResult title fp rs = dirCheck ++ mapMaybe getWarning rs where dirCheck | all (not . withoutNoMatchesWarning) rs =@@ -911,14 +982,14 @@ -- each of those branch will be checked one by one. extractAssocDeps :: UnqualComponentName -- Name of the target library- -> CondTree ConfVar [Dependency] Library+ -> CondTree ConfVar Library -> AssocDep extractAssocDeps n ct = let a = ignoreConditions ct in -- Merging is fine here, remember the specific -- library dependencies will be checked branch -- by branch.- (n, snd a)+ (n, L.view L.targetBuildDepends a) -- | August 2022: this function is an oddity due to the historical -- GenericPackageDescription/PackageDescription split (check@@ -954,8 +1025,8 @@ } -- From target to simple, unconditional CondTree.- t2c :: a -> CondTree ConfVar [Dependency] a- t2c a = CondNode a [] []+ t2c :: a -> CondTree ConfVar a+ t2c a = CondNode a [] -- From named target to unconditional CondTree. Notice we have -- a function to extract the name *and* a function to modify@@ -965,7 +1036,7 @@ :: (a -> UnqualComponentName) -> (a -> a) -> a- -> (UnqualComponentName, CondTree ConfVar [Dependency] a)+ -> (UnqualComponentName, CondTree ConfVar a) t2cName nf mf a = (nf a, t2c . mf $ a) ln :: Library -> UnqualComponentName@@ -987,8 +1058,9 @@ => [Glob] -- data-files globs. -> [Glob] -- extra-source-files globs. -> [Glob] -- extra-doc-files globs.+ -> [Glob] -- extra-files globs. -> CheckM m ()-checkMissingDocs dgs esgs edgs = do+checkMissingDocs dgs esgs edgs efgs = do extraDocSupport <- (>= CabalSpecV1_18) <$> asksCM ccSpecVersion -- Everything in this block uses CheckPreDistributionOps interface.@@ -996,8 +1068,8 @@ ciPreDistOps ( \ops -> do -- 1. Get root files, see if they are interesting to us.- rootContents <- getDirectoryContentsM ops "."- -- Recall getDirectoryContentsM arg is relative to root path.+ rootContents <- listDirectoryM ops "."+ -- Recall listDirectoryM arg is relative to root path. let des = filter isDesirableExtraDocFile rootContents -- 2. Realise Globs.@@ -1007,9 +1079,10 @@ rgs <- realGlob dgs res <- realGlob esgs red <- realGlob edgs+ ref <- realGlob efgs -- 3. Check if anything in 1. is missing in 2.- let mcs = checkDoc extraDocSupport des (rgs ++ res ++ red)+ let mcs = checkDoc extraDocSupport des (rgs ++ res ++ red ++ ref) -- 4. Check if files are present but in the wrong field. let pcsData = checkDocMove extraDocSupport "data-files" des rgs@@ -1033,13 +1106,10 @@ -> [FilePath] -- Actuals. -> [PackageCheck] checkDoc b ds as =- let fds = map ("." </>) $ filter (flip notElem as) ds- in if null fds- then []- else- [ PackageDistSuspiciousWarn $- MissingExpectedDocFiles b fds- ]+ [ PackageDistSuspiciousWarn $ MissingExpectedDocFiles b fds+ | let fds = map ("." </>) $ filter (`notElem` as) ds+ , not (null fds)+ ] checkDocMove :: Bool -- Cabal spec ≥ 1.18?@@ -1048,13 +1118,10 @@ -> [FilePath] -- Actuals. -> [PackageCheck] checkDocMove b field ds as =- let fds = filter (flip elem as) ds- in if null fds- then []- else- [ PackageDistSuspiciousWarn $- WrongFieldForExpectedDocFiles b field fds- ]+ [ PackageDistSuspiciousWarn $ WrongFieldForExpectedDocFiles b field fds+ | let fds = filter (`elem` as) ds+ , not (null fds)+ ] -- Predicate for desirable documentation file on Hackage server. isDesirableExtraDocFile :: FilePath -> Bool
src/Distribution/PackageDescription/Check/Common.hs view
@@ -16,6 +16,7 @@ , partitionDeps , checkPVP , checkPVPs+ , checkDependencyVersionRange ) where import Distribution.Compat.Prelude@@ -25,6 +26,7 @@ import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Check.Monad+import Distribution.Simple.Utils (ordNub) import Distribution.Utils.Generic (isAscii) import Distribution.Version @@ -60,7 +62,7 @@ -- be used together with checkPVP. Important: usually “base” or “Cabal”, -- as the error is slightly different. -- Note that `partitionDeps` will also filter out dependencies which are--- already present in a inherithed fashion (e.g. an exe which imports the+-- already present in a inherited fashion (e.g. an exe which imports the -- main library will not need to specify upper bounds on shared dependencies, -- hence we do not return those). --@@ -79,7 +81,7 @@ -- shared targets that match fads = filter (flip elem dqs . fst) ads -- the names of such targets- inNam = nub $ map fst fads :: [UnqualComponentName]+ inName = ordNub $ map fst fads :: [UnqualComponentName] -- the dependencies of such targets inDep = concatMap snd fads :: [Dependency] @@ -96,7 +98,7 @@ -- text, ← no warning, inherited -- monadacme ← warning! let fFun d =- notElem (unqualName d) inNam+ notElem (unqualName d) inName && notElem (unqualName d) (map unqualName inDep)@@ -116,34 +118,32 @@ -- for important dependencies like base). checkPVP :: Monad m- => (String -> PackageCheck) -- Warn message dependend on name+ => (Dependency -> Bool)+ -> (String -> PackageCheck) -- Warn message depends on name -- (e.g. "base", "Cabal"). -> [Dependency] -> CheckM m ()-checkPVP ckf ds = do- let ods = checkPVPPrim ds+checkPVP p ckf ds = do+ let ods = filter p ds mapM_ (tellP . ckf . unPackageName . depPkgName) ods -- PVP dependency check for a list of dependencies. Some code duplication -- is sadly needed to provide more ergonimic error messages. checkPVPs :: Monad m- => ( [String]+ => (Dependency -> Bool)+ -> ( [String] -> PackageCheck -- Grouped error message, depends on a -- set of names. ) -> [Dependency] -- Deps to analyse. -> CheckM m ()-checkPVPs cf ds+checkPVPs p cf ds | null ns = return () | otherwise = tellP (cf ns) where- ods = checkPVPPrim ds+ ods = filter p ds ns = map (unPackageName . depPkgName) ods --- Returns dependencies without upper bounds.-checkPVPPrim :: [Dependency] -> [Dependency]-checkPVPPrim ds = filter withoutUpper ds- where- withoutUpper :: Dependency -> Bool- withoutUpper (Dependency _ ver _) = not . hasUpperBound $ ver+checkDependencyVersionRange :: (VersionRange -> Bool) -> Dependency -> Bool+checkDependencyVersionRange p (Dependency _ ver _) = p ver
src/Distribution/PackageDescription/Check/Conditional.hs view
@@ -1,4 +1,6 @@+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} -- | -- Module : Distribution.PackageDescription.Check.Conditional@@ -21,7 +23,6 @@ import Distribution.Compiler import Distribution.ModuleName (ModuleName)-import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Check.Monad import Distribution.System@@ -61,21 +62,18 @@ . (Eq a, Monoid a) => [PackageFlag] -- User flags. -> TargetAnnotation a- -> CondTree ConfVar [Dependency] a- -> CondTree ConfVar [Dependency] (TargetAnnotation a)-annotateCondTree fs ta (CondNode a c bs) =+ -> CondTree ConfVar a+ -> CondTree ConfVar (TargetAnnotation a)+annotateCondTree fs ta (CondNode a bs) = let ta' = updateTargetAnnotation a ta bs' = map (annotateBranch ta') bs bs'' = crossAnnotateBranches defTrueFlags bs'- in CondNode ta' c bs''+ in CondNode ta' bs'' where annotateBranch :: TargetAnnotation a- -> CondBranch ConfVar [Dependency] a- -> CondBranch- ConfVar- [Dependency]- (TargetAnnotation a)+ -> CondBranch ConfVar a+ -> CondBranch ConfVar (TargetAnnotation a) annotateBranch wta (CondBranch k t mf) = let uf = isPkgFlagCond k wta' = wta{taPackageFlag = taPackageFlag wta || uf}@@ -92,7 +90,7 @@ -- \*off* by default. isPkgFlagCond :: Condition ConfVar -> Bool isPkgFlagCond (Lit _) = False- isPkgFlagCond (Var (PackageFlag f)) = elem f defOffFlags+ isPkgFlagCond (Var (PackageFlag f)) = f `elem` defOffFlags isPkgFlagCond (Var _) = False isPkgFlagCond (CNot cn) = not (isPkgFlagCond cn) isPkgFlagCond (CAnd ca cb) = isPkgFlagCond ca || isPkgFlagCond cb@@ -117,13 +115,13 @@ :: forall a . (Eq a, Monoid a) => [PackageFlag] -- `default: true` flags.- -> [CondBranch ConfVar [Dependency] (TargetAnnotation a)]- -> [CondBranch ConfVar [Dependency] (TargetAnnotation a)]+ -> [CondBranch ConfVar (TargetAnnotation a)]+ -> [CondBranch ConfVar (TargetAnnotation a)] crossAnnotateBranches fs bs = map crossAnnBranch bs where crossAnnBranch- :: CondBranch ConfVar [Dependency] (TargetAnnotation a)- -> CondBranch ConfVar [Dependency] (TargetAnnotation a)+ :: CondBranch ConfVar (TargetAnnotation a)+ -> CondBranch ConfVar (TargetAnnotation a) crossAnnBranch wr = let rs = filter (/= wr) bs@@ -131,24 +129,23 @@ in updateTargetAnnBranch (mconcat ts) wr - realiseBranch :: CondBranch ConfVar [Dependency] (TargetAnnotation a) -> Maybe a+ realiseBranch :: CondBranch ConfVar (TargetAnnotation a) -> Maybe a realiseBranch b = let -- We are only interested in True by default package flags. realiseBranchFunction :: ConfVar -> Either ConfVar Bool realiseBranchFunction (PackageFlag n) | elem n (map flagName fs) = Right True realiseBranchFunction _ = Right False- ms = simplifyCondBranch realiseBranchFunction (fmap taTarget b) in- fmap snd ms+ simplifyCondBranch realiseBranchFunction (fmap taTarget b) updateTargetAnnBranch :: a- -> CondBranch ConfVar [Dependency] (TargetAnnotation a)- -> CondBranch ConfVar [Dependency] (TargetAnnotation a)+ -> CondBranch ConfVar (TargetAnnotation a)+ -> CondBranch ConfVar (TargetAnnotation a) updateTargetAnnBranch a (CondBranch k t mt) =- let updateTargetAnnTree (CondNode ka c wbs) =- (CondNode (updateTargetAnnotation a ka) c wbs)+ let updateTargetAnnTree (CondNode ka wbs) =+ CondNode (updateTargetAnnotation a ka) wbs in CondBranch k (updateTargetAnnTree t) (updateTargetAnnTree <$> mt) -- | A conditional target is a library, exe, benchmark etc., destructured@@ -163,7 +160,7 @@ -- Naming function (some targets -- need to have their name -- spoonfed to them.- -> (UnqualComponentName, CondTree ConfVar [Dependency] a)+ -> (UnqualComponentName, CondTree ConfVar a) -- Target name/condtree. -> CheckM m () checkCondTarget fs cf nf (unqualName, ct) =@@ -172,9 +169,9 @@ -- Walking the tree. Remember that CondTree is not a binary -- tree but a /rose/tree. wTree- :: CondTree ConfVar [Dependency] (TargetAnnotation a)+ :: CondTree ConfVar (TargetAnnotation a) -> CheckM m ()- wTree (CondNode ta _ bs)+ wTree (CondNode ta bs) -- There are no branches ([] == True) *or* every branch -- is “simple” (i.e. missing a 'condBranchIfFalse' part). -- This is convenient but not necessarily correct in all@@ -190,13 +187,13 @@ mapM_ wBranch bs isSimple- :: CondBranch ConfVar [Dependency] (TargetAnnotation a)+ :: CondBranch ConfVar (TargetAnnotation a) -> Bool isSimple (CondBranch _ _ Nothing) = True isSimple (CondBranch _ _ (Just _)) = False wBranch- :: CondBranch ConfVar [Dependency] (TargetAnnotation a)+ :: CondBranch ConfVar (TargetAnnotation a) -> CheckM m () wBranch (CondBranch k t mf) = do checkCondVars k@@ -228,38 +225,31 @@ 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 (checkExe . snd) (condExecutables pkg)+ ++ concatMap (checkTest . snd) (condTestSuites pkg)+ ++ concatMap (checkBench . 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- checkDups :: String -> (a -> [ModuleName]) -> CondTree v c a -> [PackageCheck]+ checkDups :: String -> (a -> [ModuleName]) -> CondTree v a -> [PackageCheck] 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 :: Map ModuleName (Int, Int) libMap = foldCondTree Map.empty- (\(_, v) -> Map.fromListWith sumPair . map (\x -> (x, (1, 1))) $ getModules v)+ (\v -> Map.fromListWith sumPair . map (,(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 []+ in if+ | not (null dupLibsLax) -> [PackageBuildImpossible (DuplicateModule s dupLibsLax)]+ | not (null dupLibsStrict) -> [PackageDistSuspicious (PotentialDupModule s dupLibsStrict)]+ | otherwise -> []
src/Distribution/PackageDescription/Check/Monad.hs view
@@ -39,6 +39,7 @@ , liftInt , tellP , checkSpecVer+ , checkSpecVerGte ) where import Distribution.Compat.Prelude@@ -92,7 +93,7 @@ data CheckPackageContentOps m = CheckPackageContentOps { doesFileExist :: FilePath -> m Bool , doesDirectoryExist :: FilePath -> m Bool- , getDirectoryContents :: FilePath -> m [FilePath]+ , listDirectory :: FilePath -> m [FilePath] , getFileContents :: FilePath -> m BS.ByteString } @@ -102,7 +103,7 @@ -- (e.g. a VCS work tree). data CheckPreDistributionOps m = CheckPreDistributionOps { runDirFileGlobM :: FilePath -> Glob -> m [GlobResult FilePath]- , getDirectoryContentsM :: FilePath -> m [FilePath]+ , listDirectoryM :: FilePath -> m [FilePath] } -- | Context to perform checks (will be the Reader part in your monad).@@ -135,8 +136,7 @@ -- | Creates a pristing 'CheckCtx'. With pristine we mean everything that -- can be deduced by GPD but *not* user flags information. pristineCheckCtx- :: Monad m- => CheckInterface m+ :: CheckInterface m -> GenericPackageDescription -> CheckCtx m pristineCheckCtx ci gpd =@@ -150,7 +150,7 @@ -- | Adds useful bits to 'CheckCtx' (as now, whether we are operating under -- a user off-by-default flag).-initCheckCtx :: Monad m => TargetAnnotation a -> CheckCtx m -> CheckCtx m+initCheckCtx :: TargetAnnotation a -> CheckCtx m -> CheckCtx m initCheckCtx t c = c{ccFlag = taPackageFlag t} -- | 'TargetAnnotation' collects contextual information on the target we are@@ -242,7 +242,7 @@ -- There are some errors which, even though severe, will -- be allowed by Hackage *if* under a non-default flag. isErrAllowable :: PackageCheck -> Bool- isErrAllowable c = case extractCheckExplantion c of+ isErrAllowable c = case extractCheckExplanation c of (WErrorUnneeded _) -> True (JUnneeded _) -> True (FDeferTypeErrorsUnneeded _) -> True@@ -322,7 +322,7 @@ po <- asksCM (acc . ccInterface) maybe (return ()) (lc . mck) po where- lc :: Monad m => m (Maybe PackageCheck) -> CheckM m ()+ lc :: m (Maybe PackageCheck) -> CheckM m () lc wmck = do b <- liftCM wmck maybe (return ()) (check True) b@@ -369,3 +369,16 @@ checkSpecVer vc cond c = do vp <- asksCM ccSpecVersion unless (vp >= vc) (checkP cond c)++-- | Like 'checkSpecVer', except performs the check when our+-- spec version >= the param.+checkSpecVerGte+ :: Monad m+ => CabalSpecVersion -- Perform this check only if our+ -- spec version is >= than this.+ -> Bool -- Check condition.+ -> PackageCheck -- Check message.+ -> CheckM m ()+checkSpecVerGte vc cond c = do+ vp <- asksCM ccSpecVersion+ when (vp >= vc) (checkP cond c)
src/Distribution/PackageDescription/Check/Paths.hs view
@@ -10,6 +10,7 @@ module Distribution.PackageDescription.Check.Paths ( checkGlob , checkPath+ , checkPackageFileNamesWithGlob , fileExtensionSupportedLanguage , isGoodRelativeDirectoryPath , isGoodRelativeFilePath
src/Distribution/PackageDescription/Check/Target.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+ -- | -- Module : Distribution.PackageDescription.Check.Target -- Copyright : Lennart Kolmodin 2008, Francesco Ariis 2023@@ -77,7 +79,7 @@ checkP ( not $ all- (flip elem (explicitLibModules lib))+ (`elem` explicitLibModules lib) (libModulesAutogen lib) ) (PackageBuildImpossible AutogenNotExposed)@@ -86,10 +88,10 @@ checkP ( not $ all- (flip elem (allExplicitIncludes lib))+ (flip elem (allExplicitIncludes lib) . getSymbolicPath) (view L.autogenIncludes lib) )- $ (PackageBuildImpossible AutogenIncludesNotIncluded)+ (PackageBuildImpossible AutogenIncludesNotIncluded) -- § Build infos. checkBuildInfo@@ -107,8 +109,8 @@ where allExplicitIncludes :: L.HasBuildInfo a => a -> [FilePath] allExplicitIncludes x =- view L.includes x- ++ view L.installIncludes x+ map getSymbolicPath (view L.includes x)+ ++ map getSymbolicPath (view L.installIncludes x) checkForeignLib :: Monad m => ForeignLib -> CheckM m () checkForeignLib@@ -136,12 +138,13 @@ ads exe@( Executable exeName_- modulePath_+ symbolicModulePath_ _exeScope_ buildInfo_ ) = do -- Target type/name (exe). let cet = CETExecutable exeName_+ modulePath_ = getSymbolicPath symbolicModulePath_ -- § Exe specific checks checkP@@ -152,7 +155,7 @@ checkP ( pid /= fakePackageId && not (null modulePath_)- && not (fileExtensionSupportedLanguage $ modulePath_)+ && not (fileExtensionSupportedLanguage modulePath_) ) (PackageBuildImpossible NoHsLhsMain) @@ -167,12 +170,12 @@ -- Alas exeModules ad exeModulesAutogen (exported from -- Distribution.Types.Executable) take `Executable` as a parameter. checkP- (not $ all (flip elem (exeModules exe)) (exeModulesAutogen exe))+ (not $ all (`elem` exeModules exe) (exeModulesAutogen exe)) (PackageBuildImpossible $ AutogenNoOther cet) checkP ( not $ all- (flip elem (view L.includes exe))+ (flip elem (view L.includes exe) . relativeSymbolicPath) (view L.autogenIncludes exe) ) (PackageBuildImpossible AutogenIncludesNotIncludedExe)@@ -210,14 +213,14 @@ checkP ( not $ all- (flip elem (testModules ts))+ (`elem` testModules ts) (testModulesAutogen ts) ) (PackageBuildImpossible $ AutogenNoOther cet) checkP ( not $ all- (flip elem (view L.includes ts))+ (flip elem (view L.includes ts) . relativeSymbolicPath) (view L.autogenIncludes ts) ) (PackageBuildImpossible AutogenIncludesNotIncludedExe)@@ -233,12 +236,12 @@ where mainIsWrongExt = case testInterface_ of- TestSuiteExeV10 _ f -> not (fileExtensionSupportedLanguage f)+ TestSuiteExeV10 _ f -> not (fileExtensionSupportedLanguage $ getSymbolicPath f) _ -> False mainIsNotHsExt = case testInterface_ of- TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]+ TestSuiteExeV10 _ f -> takeExtension (getSymbolicPath f) `notElem` [".hs", ".lhs"] _ -> False checkBenchmark@@ -270,7 +273,7 @@ checkP ( not $ all- (flip elem (benchmarkModules bm))+ (`elem` benchmarkModules bm) (benchmarkModulesAutogen bm) ) (PackageBuildImpossible $ AutogenNoOther cet)@@ -278,7 +281,7 @@ checkP ( not $ all- (flip elem (view L.includes bm))+ (flip elem (view L.includes bm) . relativeSymbolicPath) (view L.autogenIncludes bm) ) (PackageBuildImpossible AutogenIncludesNotIncludedExe)@@ -290,7 +293,7 @@ -- they are different. mainIsWrongExt = case benchmarkInterface_ of- BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]+ BenchmarkExeV10 _ f -> takeExtension (getSymbolicPath f) `notElem` [".hs", ".lhs"] _ -> False -- ------------------------------------------------------------@@ -330,30 +333,43 @@ checkAutogenModules ams bi -- PVP: we check for base and all other deps.+ let ds = mergeDependencies $ targetBuildDepends bi (ids, rds) <- partitionDeps ads [mkUnqualComponentName "base"]- (mergeDependencies $ targetBuildDepends bi)+ ds let ick = const (PackageDistInexcusable BaseNoUpperBounds) rck = PackageDistSuspiciousWarn . MissingUpperBounds cet- checkPVP ick ids+ leuck = PackageDistSuspiciousWarn . LEUpperBounds cet+ tzuck = PackageDistSuspiciousWarn . TrailingZeroUpperBounds cet+ gtlck = PackageDistSuspiciousWarn . GTLowerBounds cet+ checkPVP (checkDependencyVersionRange $ not . hasUpperBound) ick ids unless (isInternalTarget cet)- (checkPVPs rck rds)+ (checkPVPs (checkDependencyVersionRange $ not . hasUpperBound) rck rds)+ unless+ (isInternalTarget cet)+ (checkPVPs (checkDependencyVersionRange hasLEUpperBound) leuck ds)+ unless+ (isInternalTarget cet)+ (checkPVPs (checkDependencyVersionRange hasTrailingZeroUpperBound) tzuck ds)+ unless+ (isInternalTarget cet)+ (checkPVPs (checkDependencyVersionRange hasGTLowerBound) gtlck ds) -- Custom fields well-formedness (ASCII). mapM_ checkCustomField (customFieldsBI bi) -- Content.- mapM_ (checkLocalPathExist "extra-lib-dirs") (extraLibDirs bi)+ mapM_ (checkLocalPathExist "extra-lib-dirs" . getSymbolicPath) (extraLibDirs bi) mapM_- (checkLocalPathExist "extra-lib-dirs-static")+ (checkLocalPathExist "extra-lib-dirs-static" . getSymbolicPath) (extraLibDirsStatic bi) mapM_- (checkLocalPathExist "extra-framework-dirs")+ (checkLocalPathExist "extra-framework-dirs" . getSymbolicPath) (extraFrameworkDirs bi)- mapM_ (checkLocalPathExist "include-dirs") (includeDirs bi)+ mapM_ (checkLocalPathExist "include-dirs" . getSymbolicPath) (includeDirs bi) mapM_ (checkLocalPathExist "hs-source-dirs" . getSymbolicPath) (hsSourceDirs bi)@@ -367,7 +383,7 @@ mapM_ checkIntDep (targetBuildDepends bi) df <- asksCM ccDesugar -- This way we can use the same function for legacy&non exedeps.- let ds = buildToolDepends bi ++ catMaybes (map df $ buildTools bi)+ let ds = buildToolDepends bi ++ mapMaybe df (buildTools bi) mapM_ checkBTDep ds where checkLang :: Monad m => Language -> CheckM m ()@@ -431,27 +447,27 @@ -- Paths well-formedness check for BuildInfo. checkBuildInfoPathsWellFormedness :: Monad m => BuildInfo -> CheckM m () checkBuildInfoPathsWellFormedness bi = do- mapM_ (checkPath False "asm-sources" PathKindFile) (asmSources bi)- mapM_ (checkPath False "cmm-sources" PathKindFile) (cmmSources bi)- mapM_ (checkPath False "c-sources" PathKindFile) (cSources bi)- mapM_ (checkPath False "cxx-sources" PathKindFile) (cxxSources bi)- mapM_ (checkPath False "js-sources" PathKindFile) (jsSources bi)+ mapM_ (checkPath False "asm-sources" PathKindFile . getSymbolicPath) (asmSources bi)+ mapM_ (checkPath False "cmm-sources" PathKindFile . getSymbolicPath) (cmmSources bi)+ mapM_ (checkPath False "c-sources" PathKindFile . getSymbolicPath) (cSources bi)+ mapM_ (checkPath False "cxx-sources" PathKindFile . getSymbolicPath) (cxxSources bi)+ mapM_ (checkPath False "js-sources" PathKindFile . getSymbolicPath) (jsSources bi) mapM_- (checkPath False "install-includes" PathKindFile)+ (checkPath False "install-includes" PathKindFile . getSymbolicPath) (installIncludes bi) mapM_ (checkPath False "hs-source-dirs" PathKindDirectory . getSymbolicPath) (hsSourceDirs bi) -- Possibly absolute paths.- mapM_ (checkPath True "includes" PathKindFile) (includes bi)+ mapM_ (checkPath True "includes" PathKindFile . getSymbolicPath) (includes bi) mapM_- (checkPath True "include-dirs" PathKindDirectory)+ (checkPath True "include-dirs" PathKindDirectory . getSymbolicPath) (includeDirs bi) mapM_- (checkPath True "extra-lib-dirs" PathKindDirectory)+ (checkPath True "extra-lib-dirs" PathKindDirectory . getSymbolicPath) (extraLibDirs bi) mapM_- (checkPath True "extra-lib-dirs-static" PathKindDirectory)+ (checkPath True "extra-lib-dirs-static" PathKindDirectory . getSymbolicPath) (extraLibDirsStatic bi) mapM_ checkOptionPath (perCompilerFlavorToList $ options bi) where@@ -501,8 +517,8 @@ (PackageBuildWarning CVExtensionsDeprecated) -- asm-sources, cmm-sources and friends only w/ spec ≥ 1.10- checkCVSources (asmSources bi)- checkCVSources (cmmSources bi)+ checkCVSources (map getSymbolicPath $ asmSources bi)+ checkCVSources (map getSymbolicPath $ cmmSources bi) checkCVSources (extraBundledLibs bi) checkCVSources (extraLibFlavours bi) @@ -512,8 +528,7 @@ (not . null $ extraDynLibFlavours bi) (PackageDistInexcusable $ CVExtraDynamic [extraDynLibFlavours bi]) -- virtual-modules requires ≥ 2.2- checkSpecVer CabalSpecV2_2 (not . null $ virtualModules bi) $- (PackageDistInexcusable CVVirtualModules)+ checkSpecVer CabalSpecV2_2 (not . null $ virtualModules bi) (PackageDistInexcusable CVVirtualModules) -- Check use of thinning and renaming. checkSpecVer CabalSpecV2_0@@ -544,8 +559,8 @@ checkBuildInfoExtensions :: Monad m => BuildInfo -> CheckM m () checkBuildInfoExtensions bi = do let exts = allExtensions bi- extCabal1_2 = nub $ filter (`elem` compatExtensionsExtra) exts- extCabal1_4 = nub $ filter (`notElem` compatExtensions) exts+ extCabal1_2 = ordNub $ filter (`elem` compatExtensionsExtra) exts+ extCabal1_4 = ordNub $ filter (`notElem` compatExtensions) exts -- As of Cabal-1.4 we can add new extensions without worrying -- about breaking old versions of cabal. checkSpecVer@@ -627,9 +642,7 @@ , DeriveDataTypeable , ConstrainedClassMethods ]- ++ map- DisableExtension- [MonoPatBinds]+ ++ [DisableExtension MonoPatBinds] -- Autogenerated modules (Paths_, PackageInfo_) checks. We could pass this -- function something more specific than the whole BuildInfo, but it would be@@ -664,7 +677,7 @@ -- PackageBuildImpossible and not merely PackageDistInexcusable. checkSpecVer CabalSpecV3_12- (elem autoInfoModuleName allModsForAuto)+ (autoInfoModuleName `elem` allModsForAuto) (PackageBuildImpossible CVAutogenPackageInfoGuard) where allModsForAuto :: [ModuleName]@@ -786,6 +799,7 @@ checkCLikeOptions LangC "cc-options" (ccOptions bi) ldOpts checkCLikeOptions LangCPlusPlus "cxx-options" (cxxOptions bi) ldOpts checkCPPOptions (cppOptions bi)+ checkJSPOptions (jsppOptions bi) -- | Checks GHC options for commonly misused or non-portable flags. checkGHCOptions@@ -824,9 +838,10 @@ checkFlags ["-prof"] (PackageBuildWarning $ OptProf title)- -- Does not apply to scripts.- -- Why do we need this? See #8963. pid <- asksCM (pnPackageId . ccNames)+ -- Scripts add the -o flag in the fake-package.cabal in order to have the+ -- executable name match the script name even when there are characters+ -- in the script name which are illegal to have as a target name. unless (pid == fakePackageId) $ checkFlags ["-o"]@@ -877,6 +892,12 @@ ) checkAlternatives title+ "jspp-options"+ ( [(flag, flag) | flag@('-' : 'D' : _) <- ghcNoRts]+ ++ [(flag, flag) | flag@('-' : 'U' : _) <- ghcNoRts]+ )+ checkAlternatives+ title "include-dirs" [(flag, dir) | flag@('-' : 'I' : dir) <- ghcNoRts] checkAlternatives@@ -934,7 +955,7 @@ ) (PackageDistInexcusable . DynamicUnneeded) checkFlagsP- ( \opt -> case opt of+ ( \case "-j" -> True ('-' : 'j' : d : _) -> isDigit d _ -> False@@ -1062,5 +1083,22 @@ checkP (not $ any (`isPrefixOf` opt) ["-D", "-U", "-I"]) (PackageBuildWarning (COptCPP opt))+ )+ opts++checkJSPOptions+ :: Monad m+ => [String] -- Options in String form.+ -> CheckM m ()+checkJSPOptions opts = do+ checkAlternatives+ "jspp-options"+ "include-dirs"+ [(flag, dir) | flag@('-' : 'I' : dir) <- opts]+ mapM_+ ( \opt ->+ checkP+ (not $ any (`isPrefixOf` opt) ["-D", "-U", "-I"])+ (PackageBuildWarning (OptJSPP opt)) ) opts
src/Distribution/PackageDescription/Check/Warning.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -24,7 +24,7 @@ , ppPackageCheck , ppCheckExplanationId , isHackageDistError- , extractCheckExplantion+ , extractCheckExplanation , filterPackageChecksById , filterPackageChecksByIdString ) where@@ -46,12 +46,7 @@ import Distribution.Types.TestType (TestType, knownTestTypes) import Distribution.Types.UnqualComponentName import Distribution.Types.Version (Version)-import Distribution.Utils.Path- ( LicenseFile- , PackageDir- , SymbolicPath- , getSymbolicPath- )+import Distribution.Utils.Path (FileOrDir (..), Pkg, RelativePath, getSymbolicPath) import Language.Haskell.Extension (Extension) import qualified Data.Either as Either@@ -128,7 +123,7 @@ ff c = flip notElem is . checkExplanationId- . extractCheckExplantion+ . extractCheckExplanation $ c -- | Filter Package Check by Check explanation /string/.@@ -175,6 +170,7 @@ | UnknownExtensions [String] | LanguagesAsExtension [String] | DeprecatedExtensions [(Extension, Maybe Extension)]+ | FreeTextDotline String | MissingFieldCategory | MissingFieldMaintainer | MissingFieldSynopsis@@ -197,6 +193,7 @@ | UnrecognisedSourceRepo String | MissingType | MissingLocation+ | GitProtocol | MissingModule | MissingTag | SubdirRelPath@@ -218,6 +215,7 @@ | OptWithRts String | COptONumber String WarnLang | COptCPP String+ | OptJSPP String | OptAlternatives String String [(String, String)] | RelativeOutside String FilePath | AbsolutePath String FilePath@@ -247,7 +245,7 @@ | CVSourceRepository | CVExtensions CabalSpecVersion [Extension] | CVCustomSetup- | CVExpliticDepsCustomSetup+ | CVExplicitDepsCustomSetup | CVAutogenPaths | CVAutogenPackageInfo | CVAutogenPackageInfoGuard@@ -259,6 +257,9 @@ | UnknownCompiler [String] | BaseNoUpperBounds | MissingUpperBounds CEType [String]+ | LEUpperBounds CEType [String]+ | TrailingZeroUpperBounds CEType [String]+ | GTLowerBounds CEType [String] | SuspiciousFlagName [String] | DeclaredUsedFlags (Set.Set FlagName) (Set.Set FlagName) | NonASCIICustomField [String]@@ -276,7 +277,7 @@ | NotPackageName FilePath String | NoDesc | MultiDesc [String]- | UnknownFile String (SymbolicPath PackageDir LicenseFile)+ | UnknownFile String (RelativePath Pkg File) | MissingSetupFile | MissingConfigureScript | UnknownDirectory String FilePath@@ -296,14 +297,14 @@ -- to be a ad hoc monoid. -- Convenience.-extractCheckExplantion :: PackageCheck -> CheckExplanation-extractCheckExplantion (PackageBuildImpossible e) = e-extractCheckExplantion (PackageBuildWarning e) = e-extractCheckExplantion (PackageDistSuspicious e) = e-extractCheckExplantion (PackageDistSuspiciousWarn e) = e-extractCheckExplantion (PackageDistInexcusable e) = e+extractCheckExplanation :: PackageCheck -> CheckExplanation+extractCheckExplanation (PackageBuildImpossible e) = e+extractCheckExplanation (PackageBuildWarning e) = e+extractCheckExplanation (PackageDistSuspicious e) = e+extractCheckExplanation (PackageDistSuspiciousWarn e) = e+extractCheckExplanation (PackageDistInexcusable e) = e --- | Identifier for the speficic 'CheckExplanation'. This ensures `--ignore`+-- | Identifier for the specific 'CheckExplanation'. This ensures `--ignore` -- can output a warning on unrecognised values. -- ☞ N.B.: should be kept in sync with 'CheckExplanation'. data CheckExplanationID@@ -337,6 +338,7 @@ | CIUnknownExtensions | CILanguagesAsExtension | CIDeprecatedExtensions+ | CIFreeTextDotline | CIMissingFieldCategory | CIMissingFieldMaintainer | CIMissingFieldSynopsis@@ -359,6 +361,7 @@ | CIUnrecognisedSourceRepo | CIMissingType | CIMissingLocation+ | CIGitProtocol | CIMissingModule | CIMissingTag | CISubdirRelPath@@ -380,6 +383,7 @@ | CIOptWithRts | CICOptONumber | CICOptCPP+ | CIOptJSPP | CIOptAlternatives | CIRelativeOutside | CIAbsolutePath@@ -409,7 +413,7 @@ | CICVSourceRepository | CICVExtensions | CICVCustomSetup- | CICVExpliticDepsCustomSetup+ | CICVExplicitDepsCustomSetup | CICVAutogenPaths | CICVAutogenPackageInfo | CICVAutogenPackageInfoGuard@@ -421,6 +425,9 @@ | CIUnknownCompiler | CIBaseNoUpperBounds | CIMissingUpperBounds+ | CILEUpperBounds+ | CITrailingZeroUpperBounds+ | CIGTLowerBounds | CISuspiciousFlagName | CIDeclaredUsedFlags | CINonASCIICustomField@@ -478,6 +485,7 @@ checkExplanationId (UnknownExtensions{}) = CIUnknownExtensions checkExplanationId (LanguagesAsExtension{}) = CILanguagesAsExtension checkExplanationId (DeprecatedExtensions{}) = CIDeprecatedExtensions+checkExplanationId (FreeTextDotline{}) = CIFreeTextDotline checkExplanationId (MissingFieldCategory{}) = CIMissingFieldCategory checkExplanationId (MissingFieldMaintainer{}) = CIMissingFieldMaintainer checkExplanationId (MissingFieldSynopsis{}) = CIMissingFieldSynopsis@@ -500,6 +508,7 @@ checkExplanationId (UnrecognisedSourceRepo{}) = CIUnrecognisedSourceRepo checkExplanationId (MissingType{}) = CIMissingType checkExplanationId (MissingLocation{}) = CIMissingLocation+checkExplanationId (GitProtocol{}) = CIGitProtocol checkExplanationId (MissingModule{}) = CIMissingModule checkExplanationId (MissingTag{}) = CIMissingTag checkExplanationId (SubdirRelPath{}) = CISubdirRelPath@@ -521,6 +530,7 @@ checkExplanationId (OptWithRts{}) = CIOptWithRts checkExplanationId (COptONumber{}) = CICOptONumber checkExplanationId (COptCPP{}) = CICOptCPP+checkExplanationId (OptJSPP{}) = CIOptJSPP checkExplanationId (OptAlternatives{}) = CIOptAlternatives checkExplanationId (RelativeOutside{}) = CIRelativeOutside checkExplanationId (AbsolutePath{}) = CIAbsolutePath@@ -550,7 +560,7 @@ checkExplanationId (CVSourceRepository{}) = CICVSourceRepository checkExplanationId (CVExtensions{}) = CICVExtensions checkExplanationId (CVCustomSetup{}) = CICVCustomSetup-checkExplanationId (CVExpliticDepsCustomSetup{}) = CICVExpliticDepsCustomSetup+checkExplanationId (CVExplicitDepsCustomSetup{}) = CICVExplicitDepsCustomSetup checkExplanationId (CVAutogenPaths{}) = CICVAutogenPaths checkExplanationId (CVAutogenPackageInfo{}) = CICVAutogenPackageInfo checkExplanationId (CVAutogenPackageInfoGuard{}) = CICVAutogenPackageInfoGuard@@ -562,6 +572,9 @@ checkExplanationId (UnknownCompiler{}) = CIUnknownCompiler checkExplanationId (BaseNoUpperBounds{}) = CIBaseNoUpperBounds checkExplanationId (MissingUpperBounds{}) = CIMissingUpperBounds+checkExplanationId (LEUpperBounds{}) = CILEUpperBounds+checkExplanationId (TrailingZeroUpperBounds{}) = CITrailingZeroUpperBounds+checkExplanationId (GTLowerBounds{}) = CIGTLowerBounds checkExplanationId (SuspiciousFlagName{}) = CISuspiciousFlagName checkExplanationId (DeclaredUsedFlags{}) = CIDeclaredUsedFlags checkExplanationId (NonASCIICustomField{}) = CINonASCIICustomField@@ -589,11 +602,13 @@ type CheckExplanationIDString = String --- A one-word identifier for each CheckExplanation------ ☞ N.B: if you modify anything here, remeber to change the documentation--- in @doc/cabal-commands.rst@!+-- | A one-word identifier for each @CheckExplanation@. ppCheckExplanationId :: CheckExplanationID -> CheckExplanationIDString+-- NOTE: If you modify anything here, remember to change the documentation+-- in @doc/cabal-commands.rst@!+-- NOTE: These strings will have to satisfy a test that these messages don't+-- have too many dashes:+-- $ cabal run Cabal-tests:unit-tests -- --pattern=Parsimonious ppCheckExplanationId CIParseWarning = "parser-warning" ppCheckExplanationId CINoNameField = "no-name-field" ppCheckExplanationId CINoVersionField = "no-version-field"@@ -624,6 +639,7 @@ ppCheckExplanationId CIUnknownExtensions = "unknown-extension" ppCheckExplanationId CILanguagesAsExtension = "languages-as-extensions" ppCheckExplanationId CIDeprecatedExtensions = "deprecated-extensions"+ppCheckExplanationId CIFreeTextDotline = "free-text-dotline" ppCheckExplanationId CIMissingFieldCategory = "no-category" ppCheckExplanationId CIMissingFieldMaintainer = "no-maintainer" ppCheckExplanationId CIMissingFieldSynopsis = "no-synopsis"@@ -646,6 +662,7 @@ ppCheckExplanationId CIUnrecognisedSourceRepo = "unrecognised-repo-type" ppCheckExplanationId CIMissingType = "repo-no-type" ppCheckExplanationId CIMissingLocation = "repo-no-location"+ppCheckExplanationId CIGitProtocol = "git-protocol" ppCheckExplanationId CIMissingModule = "repo-no-module" ppCheckExplanationId CIMissingTag = "repo-no-tag" ppCheckExplanationId CISubdirRelPath = "repo-relative-dir"@@ -667,6 +684,7 @@ ppCheckExplanationId CIOptWithRts = "option-with-rtsopts" ppCheckExplanationId CICOptONumber = "option-opt-c" ppCheckExplanationId CICOptCPP = "cpp-options"+ppCheckExplanationId CIOptJSPP = "jspp-options" ppCheckExplanationId CIOptAlternatives = "misplaced-c-opt" ppCheckExplanationId CIRelativeOutside = "relative-path-outside" ppCheckExplanationId CIAbsolutePath = "absolute-path"@@ -696,7 +714,7 @@ ppCheckExplanationId CICVSourceRepository = "source-repository" ppCheckExplanationId CICVExtensions = "incompatible-extension" ppCheckExplanationId CICVCustomSetup = "no-setup-depends"-ppCheckExplanationId CICVExpliticDepsCustomSetup = "dependencies-setup"+ppCheckExplanationId CICVExplicitDepsCustomSetup = "dependencies-setup" ppCheckExplanationId CICVAutogenPaths = "no-autogen-paths" ppCheckExplanationId CICVAutogenPackageInfo = "no-autogen-pinfo" ppCheckExplanationId CICVAutogenPackageInfoGuard = "autogen-guard"@@ -708,6 +726,9 @@ ppCheckExplanationId CIUnknownCompiler = "unknown-compiler" ppCheckExplanationId CIBaseNoUpperBounds = "missing-bounds-important" ppCheckExplanationId CIMissingUpperBounds = "missing-upper-bounds"+ppCheckExplanationId CILEUpperBounds = "le-upper-bounds"+ppCheckExplanationId CITrailingZeroUpperBounds = "tz-upper-bounds"+ppCheckExplanationId CIGTLowerBounds = "gt-lower-bounds" ppCheckExplanationId CISuspiciousFlagName = "suspicious-flag" ppCheckExplanationId CIDeclaredUsedFlags = "unused-flag" ppCheckExplanationId CINonASCIICustomField = "non-ascii"@@ -893,6 +914,11 @@ ++ "'." | (ext, Just replacement) <- ourDeprecatedExtensions ]+ppExplanation (FreeTextDotline field) =+ "Empty lines with a dot '.' in field '"+ ++ field+ ++ "' are unnecessary for creating newlines "+ ++ "(and treated literally) in cabal 3.0+" ppExplanation MissingFieldCategory = "No 'category' field." ppExplanation MissingFieldMaintainer = "No 'maintainer' field." ppExplanation MissingFieldSynopsis = "No 'synopsis' field."@@ -909,7 +935,8 @@ ++ "(e.g. 'cabal info', Haddock, Hackage) below the 'synopsis' which " ++ "serves as a headline. " ++ "Please refer to <https://cabal.readthedocs.io/en/stable/"- ++ "cabal-package.html#package-properties> for more details."+ ++ "cabal-package-description-file.html#package-properties> "+ ++ "for more details." ppExplanation (InvalidTestWith testedWithImpossibleRanges) = "Invalid 'tested-with' version range: " ++ commaSep (map prettyShow testedWithImpossibleRanges)@@ -968,6 +995,10 @@ "The source-repository 'type' is a required field." ppExplanation MissingLocation = "The source-repository 'location' is a required field."+ppExplanation GitProtocol =+ "Cloning over git:// might lead to an arbitrary code execution "+ ++ "vulnerability. Furthermore, popular forges like GitHub do "+ ++ "not support it. Use https:// or ssh:// instead." ppExplanation MissingModule = "For a CVS source-repository, the 'module' is a required field." ppExplanation MissingTag =@@ -1069,6 +1100,8 @@ ++ " --disable-optimization flag." ppExplanation (COptCPP opt) = "'cpp-options: " ++ opt ++ "' is not a portable C-preprocessor flag."+ppExplanation (OptJSPP opt) =+ "'jspp-options: " ++ opt ++ "' is not a portable JavaScript-preprocessor flag." ppExplanation (OptAlternatives badField goodField flags) = "Instead of " ++ quote (badField ++ ": " ++ unwords badFlags)@@ -1117,9 +1150,9 @@ ++ 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$\"."+ ++ "names cannot contain any of the characters \":*?<>|\", and there "+ ++ "are a few reserved names including \"aux\", \"nul\", \"con\", "+ ++ "\"prn\", \"com{1-9}\", \"lpt{1-9}\" and \"clock$\"." where quotes [failed] = "path " ++ quote failed ++ " is" quotes failed =@@ -1225,7 +1258,7 @@ ++ "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 =+ppExplanation CVExplicitDepsCustomSetup = "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' "@@ -1297,15 +1330,33 @@ ++ "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 (MissingUpperBounds ct names) =- let separator = "\n - "- in "On "- ++ ppCET ct- ++ ", "- ++ "these packages miss upper bounds:"- ++ separator- ++ List.intercalate separator names- ++ "\n"- ++ "Please add them. There is more information at https://pvp.haskell.org/"+ "On "+ ++ ppCET ct+ ++ ", "+ ++ "these packages miss upper bounds:"+ ++ listSep names+ ++ "Please add them. There is more information at https://pvp.haskell.org/"+ppExplanation (LEUpperBounds ct names) =+ "On "+ ++ ppCET ct+ ++ ", "+ ++ "these packages have less than or equals (<=) upper bounds:"+ ++ listSep names+ ++ "Please use less than (<) for upper bounds."+ppExplanation (TrailingZeroUpperBounds ct names) =+ "On "+ ++ ppCET ct+ ++ ", "+ ++ "these packages have upper bounds with trailing zeros:"+ ++ listSep names+ ++ "Please avoid trailing zeros for upper bounds."+ppExplanation (GTLowerBounds ct names) =+ "On "+ ++ ppCET ct+ ++ ", "+ ++ "these packages have greater than (>) lower bounds:"+ ++ listSep names+ ++ "Please use greater than or equals (>=) for lower bounds." ppExplanation (SuspiciousFlagName invalidFlagNames) = "Suspicious flag names: " ++ unwords invalidFlagNames@@ -1422,7 +1473,8 @@ ++ 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 or SetupHooks.hs "+ ++ "or SetupHooks.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."@@ -1466,6 +1518,11 @@ else "extra-source-files" -- * Formatting utilities++listSep :: [String] -> String+listSep names =+ let separator = "\n - "+ in separator ++ List.intercalate separator names ++ "\n" commaSep :: [String] -> String commaSep = List.intercalate ", "
src/Distribution/Simple.hs view
@@ -1,7 +1,10 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- {- Work around this warning:@@ -10,7 +13,7 @@ (imported from Distribution.Simple.UserHooks): Deprecated: "Please use the new testing interface instead!" -}-{-# OPTIONS_GHC -fno-warn-deprecations #-}+{-# OPTIONS_GHC -Wno-deprecations #-} -- | -- Module : Distribution.Simple@@ -35,8 +38,7 @@ -- simple software. -- -- 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.+-- presented the same compatible command line interfaces. module Distribution.Simple ( module Distribution.Package , module Distribution.Version@@ -48,24 +50,45 @@ , defaultMain , defaultMainNoRead , defaultMainArgs+ , defaultMainArgsWithHandles -- * Customization , UserHooks (..) , Args , defaultMainWithHooks+ , defaultMainWithSetupHooks+ , defaultMainWithSetupHooksArgs , defaultMainWithHooksArgs , defaultMainWithHooksNoRead , defaultMainWithHooksNoReadArgs -- ** Standard sets of hooks , simpleUserHooks+ , simpleUserHooksWithHandles , autoconfUserHooks+ , autoconfSetupHooks , emptyUserHooks++ -- ** Simple actions (library interface)+ , configureAction+ , buildAction+ , replAction+ , installAction+ , copyAction+ , haddockAction+ , cleanAction+ , sdistAction+ , hscolourAction+ , registerAction+ , unregisterAction+ , testAction+ , benchAction ) where import Control.Exception (try) import Distribution.Compat.Prelude+import Distribution.Compat.ResponseFile (expandResponse) import Prelude () -- local@@ -79,6 +102,7 @@ import Distribution.Simple.PreProcess import Distribution.Simple.Program import Distribution.Simple.Setup+import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks import Distribution.Simple.UserHooks import Distribution.Simple.Build@@ -91,30 +115,27 @@ import Distribution.Pretty import Distribution.Simple.Bench import Distribution.Simple.BuildPaths-import Distribution.Simple.ConfigureScript+import Distribution.Simple.ConfigureScript (runConfigureScript) import Distribution.Simple.Errors import Distribution.Simple.Haddock import Distribution.Simple.Install import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.SetupHooks.Internal+ ( SetupHooks+ ) import Distribution.Simple.Test import Distribution.Simple.Utils+import qualified Distribution.Types.LocalBuildConfig as LBC+import Distribution.Utils.Path import Distribution.Verbosity import Distribution.Version import Language.Haskell.Extension -- Base--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 System.Directory (removePathForcibly)+import System.Environment (getArgs, getProgName)+import System.IO (hPutStr, hPutStrLn) -- | A simple implementation of @main@ for a Cabal setup script. -- It reads the package description file using IO, and performs the@@ -127,6 +148,138 @@ defaultMainArgs :: [String] -> IO () defaultMainArgs = defaultMainHelper simpleUserHooks +-- | A version of 'defaultMainArgs' that allows passing explicit verbosity handles.+defaultMainArgsWithHandles :: VerbosityHandles -> [String] -> IO ()+defaultMainArgsWithHandles verbHandles =+ defaultMainHelperWithHandles verbHandles simpleUserHooks++defaultMainWithSetupHooks :: SetupHooks -> IO ()+defaultMainWithSetupHooks setupHooks =+ getArgs >>= defaultMainWithSetupHooksArgs setupHooks defaultVerbosityHandles++defaultMainWithSetupHooksArgs :: SetupHooks -> VerbosityHandles -> [String] -> IO ()+defaultMainWithSetupHooksArgs setupHooks verbHandles =+ defaultMainHelper $+ simpleUserHooks+ { confHook = setup_confHook+ , buildHook = setup_buildHook+ , copyHook = setup_copyHook+ , instHook = setup_installHook+ , replHook = setup_replHook+ , haddockHook = setup_haddockHook+ , hscolourHook = setup_hscolourHook+ }+ where+ preBuildHook =+ case SetupHooks.preBuildComponentRules (SetupHooks.buildHooks setupHooks) of+ Nothing -> const $ return []+ Just pbcRules -> \pbci -> runPreBuildHooks verbHandles pbci pbcRules+ postBuildHook =+ case SetupHooks.postBuildComponentHook (SetupHooks.buildHooks setupHooks) of+ Nothing -> const $ return ()+ Just hk -> hk++ setup_confHook+ :: (GenericPackageDescription, HookedBuildInfo)+ -> ConfigFlags+ -> IO LocalBuildInfo+ setup_confHook p =+ configure_setupHooks+ (SetupHooks.configureHooks setupHooks)+ p+ verbHandles++ setup_buildHook+ :: PackageDescription+ -> LocalBuildInfo+ -> UserHooks+ -> BuildFlags+ -> IO ()+ setup_buildHook pkg_descr lbi hooks flags =+ void $+ build_setupHooks+ (preBuildHook, postBuildHook)+ verbHandles+ pkg_descr+ lbi+ flags+ (allSuffixHandlers hooks)++ setup_copyHook+ :: PackageDescription+ -> LocalBuildInfo+ -> UserHooks+ -> CopyFlags+ -> IO ()+ setup_copyHook pkg_descr lbi _hooks flags =+ install_setupHooks+ (SetupHooks.installHooks setupHooks)+ verbHandles+ pkg_descr+ lbi+ flags++ setup_installHook+ :: PackageDescription+ -> LocalBuildInfo+ -> UserHooks+ -> InstallFlags+ -> IO ()+ setup_installHook =+ defaultInstallHook_setupHooks+ (SetupHooks.installHooks setupHooks)+ verbHandles++ setup_replHook+ :: PackageDescription+ -> LocalBuildInfo+ -> UserHooks+ -> ReplFlags+ -> [String]+ -> IO ()+ setup_replHook pkg_descr lbi hooks flags args =+ void $+ repl_setupHooks+ preBuildHook+ verbHandles+ pkg_descr+ lbi+ flags+ (allSuffixHandlers hooks)+ args++ setup_haddockHook+ :: PackageDescription+ -> LocalBuildInfo+ -> UserHooks+ -> HaddockFlags+ -> IO ()+ setup_haddockHook pkg_descr lbi hooks flags =+ void $+ haddock_setupHooks+ preBuildHook+ verbHandles+ pkg_descr+ lbi+ (allSuffixHandlers hooks)+ flags++ setup_hscolourHook+ :: PackageDescription+ -> LocalBuildInfo+ -> UserHooks+ -> HscolourFlags+ -> IO ()+ setup_hscolourHook pkg_descr lbi hooks flags =+ void $+ hscolour_setupHooks+ preBuildHook+ verbHandles+ pkg_descr+ lbi+ (allSuffixHandlers hooks)+ flags+ -- | A customizable version of 'defaultMain'. defaultMainWithHooks :: UserHooks -> IO () defaultMainWithHooks hooks = getArgs >>= defaultMainHelper hooks@@ -166,50 +319,74 @@ -- getting 'CommandParse' data back, which is then pattern-matched into -- IO actions for execution, with arguments applied by the parser. defaultMainHelper :: UserHooks -> Args -> IO ()-defaultMainHelper hooks args = topHandler $ do- args' <- expandResponse args- command <- commandsRun (globalCommand commands) commands args'- case command of- CommandHelp help -> printHelp help- CommandList opts -> printOptionsList opts- CommandErrors errs -> printErrors errs- CommandReadyToGo (flags, commandParse) ->- case commandParse of- _- | fromFlag (globalVersion flags) -> printVersion- | fromFlag (globalNumericVersion flags) -> printNumericVersion- CommandHelp help -> printHelp help- CommandList opts -> printOptionsList opts- CommandErrors errs -> printErrors errs- CommandReadyToGo action -> action+defaultMainHelper = defaultMainHelperWithHandles defaultVerbosityHandles++-- | A version of 'defaultMainHelper' that allows setting the logging handles.+defaultMainHelperWithHandles :: VerbosityHandles -> UserHooks -> Args -> IO ()+defaultMainHelperWithHandles verbHandles hooks args =+ topHandler (isUserException (Proxy @(VerboseException CabalException))) $ do+ args' <- expandResponse args+ command <- commandsRun (globalCommand commands) commands args'+ case command of+ CommandHelp help -> printHelp help+ CommandList opts -> printOptionsList opts+ CommandErrors errs -> printErrors errs+ CommandReadyToGo (globalFlags, commandParse) ->+ case commandParse of+ _+ | fromFlag (globalVersion globalFlags) -> printVersion+ | fromFlag (globalFullVersion globalFlags) -> printFullVersion+ | fromFlag (globalNumericVersion globalFlags) -> printNumericVersion+ CommandHelp help -> printHelp help+ CommandList opts -> printOptionsList opts+ CommandErrors errs -> printErrors errs+ CommandReadyToGo action -> action globalFlags where- printHelp help = getProgName >>= putStr . help- printOptionsList = putStr . unlines+ outHandle = vStdoutHandle verbHandles+ printHelp help = getProgName >>= hPutStr outHandle . help+ printOptionsList = hPutStr outHandle . unlines printErrors errs = do- putStr (intercalate "\n" errs)+ hPutStr outHandle (intercalate "\n" errs) exitWith (ExitFailure 1)- printNumericVersion = putStrLn $ prettyShow cabalVersion+ printNumericVersion =+ hPutStrLn outHandle $ prettyShow cabalVersion printVersion =- putStrLn $+ hPutStrLn outHandle $ "Cabal library version " ++ prettyShow cabalVersion-+ printFullVersion =+ hPutStrLn outHandle $+ "Cabal library version "+ ++ prettyShow cabalVersion+ ++ cabalGitInfo'+ ++ "\nwith "+ ++ cabalCompilerInfo+ cabalGitInfo'+ | null cabalGitInfo = []+ | otherwise = ' ' : cabalGitInfo progs = addKnownPrograms (hookedPrograms hooks) defaultProgramDb+ addAction+ :: CommandUI flags+ -> (VerbosityHandles -> GlobalFlags -> UserHooks -> flags -> [String] -> IO res)+ -> Command (GlobalFlags -> IO ())+ addAction cmd action =+ cmd `commandAddAction` \flags as globalFlags ->+ void $ action verbHandles globalFlags hooks flags as+ commands :: [Command (GlobalFlags -> IO ())] 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 `addAction` configureAction+ , buildCommand progs `addAction` buildAction+ , replCommand progs `addAction` replAction+ , installCommand `addAction` installAction+ , copyCommand `addAction` copyAction+ , haddockCommand `addAction` haddockAction+ , cleanCommand `addAction` cleanAction+ , sdistCommand `addAction` sdistAction+ , hscolourCommand `addAction` hscolourAction+ , registerCommand `addAction` registerAction+ , unregisterCommand `addAction` unregisterAction+ , testCommand `addAction` testAction+ , benchmarkCommand `addAction` benchAction ] -- | Combine the preprocessors in the given hooks with the@@ -223,14 +400,22 @@ 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' =+configureAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo+configureAction verbHandles globalFlags hooks flags args = do+ distPref <- findDistPrefOrDefault (setupDistPref $ configCommonFlags flags)+ let commonFlags = configCommonFlags flags+ commonFlags' =+ commonFlags+ { setupDistPref = toFlag distPref+ , setupWorkingDir = globalWorkingDir globalFlags <> setupWorkingDir commonFlags+ , setupTargets = args+ }+ flags' = flags- { configDistPref = toFlag distPref- , configArgs = args+ { configCommonFlags = commonFlags' }+ mbWorkDir = flagToMaybe $ setupWorkingDir commonFlags'+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity commonFlags') -- See docs for 'HookedBuildInfo' pbi <- preConf hooks args flags'@@ -239,55 +424,76 @@ confPkgDescr hooks verbosity- (flagToMaybe (configCabalFilePath flags))+ mbWorkDir+ (flagToMaybe (setupCabalFilePath commonFlags')) let epkg_descr = (pkg_descr0, pbi) - localbuildinfo0 <- confHook hooks epkg_descr flags'+ lbi1 <- confHook hooks epkg_descr flags' -- remember the .cabal filename if we know it -- and all the extra command line args let localbuildinfo =- localbuildinfo0+ lbi1 { pkgDescrFile = mb_pd_file , extraConfigArgs = args }- writePersistBuildConfig distPref localbuildinfo+ writePersistBuildConfig mbWorkDir distPref 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 hooks verbosity mb_path = do+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -> Maybe (SymbolicPath Pkg File)+ -> IO (Maybe (SymbolicPath Pkg File), GenericPackageDescription)+confPkgDescr hooks verbosity cwd mb_path = do mdescr <- readDesc hooks case mdescr of Just descr -> return (Nothing, descr) Nothing -> do pdfile <- case mb_path of- Nothing -> defaultPackageDesc verbosity+ Nothing -> relativeSymbolicPath <$> tryFindPackageDesc verbosity cwd Just path -> return path info verbosity "Using Parsec parser"- descr <- readGenericPackageDescription verbosity pdfile+ descr <- readGenericPackageDescription verbosity cwd 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)- }+getCommonFlags+ :: VerbosityHandles+ -> GlobalFlags+ -> UserHooks+ -> CommonSetupFlags+ -> Args+ -> IO (LocalBuildInfo, CommonSetupFlags)+getCommonFlags verbHandles globalFlags hooks commonFlags args = do+ distPref <- findDistPrefOrDefault (setupDistPref commonFlags)+ let verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity commonFlags)+ lbi <- getBuildConfig globalFlags hooks verbosity distPref+ let common' = configCommonFlags $ configFlags lbi+ return+ ( lbi+ , commonFlags+ { setupDistPref = toFlag distPref+ , setupCabalFilePath = setupCabalFilePath common' <> setupCabalFilePath commonFlags+ , setupWorkingDir =+ globalWorkingDir globalFlags+ <> setupWorkingDir common'+ <> setupWorkingDir commonFlags+ , setupTargets = args+ }+ ) +buildAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> BuildFlags -> Args -> IO ()+buildAction verbHandles globalFlags hooks flags args = do+ let common = buildCommonFlags flags+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ (lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args+ let flags' = flags{buildCommonFlags = common'}+ progs <- reconfigurePrograms verbosity@@ -302,16 +508,15 @@ postBuild (return lbi{withPrograms = progs}) hooks- flags'{buildArgs = args}+ flags' 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}-- lbi <- getBuildConfig hooks verbosity distPref+replAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> ReplFlags -> Args -> IO ()+replAction verbHandles globalFlags hooks flags args = do+ let common = replCommonFlags flags+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ (lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args+ let flags' = flags{replCommonFlags = common'} progs <- reconfigurePrograms verbosity@@ -334,37 +539,30 @@ 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)- }+hscolourAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> HscolourFlags -> Args -> IO ()+hscolourAction verbHandles globalFlags hooks flags args = do+ let common = hscolourCommonFlags flags+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args+ let flags' = flags{hscolourCommonFlags = common'}+ distPref = fromFlag $ setupDistPref common' hookedAction verbosity preHscolour hscolourHook postHscolour- (getBuildConfig hooks verbosity distPref)+ (getBuildConfig globalFlags 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)- }+haddockAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> HaddockFlags -> Args -> IO ()+haddockAction verbHandles globalFlags hooks flags args = do+ let common = haddockCommonFlags flags+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ (lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args+ let flags' = flags{haddockCommonFlags = common'} progs <- reconfigurePrograms@@ -380,25 +578,42 @@ postHaddock (return lbi{withPrograms = progs}) hooks- flags'{haddockArgs = args}+ flags' 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)+cleanAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> CleanFlags -> Args -> IO ()+cleanAction verbHandles globalFlags hooks flags args = do+ let common = cleanCommonFlags flags+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ distPref <- findDistPrefOrDefault (setupDistPref common)+ elbi <- tryGetBuildConfig globalFlags hooks verbosity distPref+ let common' =+ common+ { setupDistPref = toFlag distPref+ , setupWorkingDir = case elbi of+ Left _ ->+ globalWorkingDir globalFlags+ <> setupWorkingDir common+ Right lbi ->+ globalWorkingDir globalFlags+ <> setupWorkingDir (configCommonFlags $ configFlags lbi)+ <> setupWorkingDir common+ , setupCabalFilePath = case elbi of+ Left _ -> setupCabalFilePath common+ Right lbi ->+ setupCabalFilePath common+ <> setupCabalFilePath (configCommonFlags $ configFlags lbi)+ , setupTargets = args }+ flags' =+ flags{cleanCommonFlags = common'} + mbWorkDirFlag = cleanWorkingDir flags'+ mbWorkDir = flagToMaybe mbWorkDirFlag+ pbi <- preClean hooks args flags' - (_, ppd) <- confPkgDescr hooks verbosity Nothing+ (_, ppd) <- confPkgDescr hooks verbosity mbWorkDir 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@@ -413,125 +628,115 @@ 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)- }+copyAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> CopyFlags -> Args -> IO ()+copyAction verbHandles globalFlags hooks flags args = do+ let common = copyCommonFlags flags+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args+ let flags' = flags{copyCommonFlags = common'}+ distPref = fromFlag $ setupDistPref common' hookedAction verbosity preCopy copyHook postCopy- (getBuildConfig hooks verbosity distPref)+ (getBuildConfig globalFlags hooks verbosity distPref) hooks- flags'{copyArgs = args}+ flags' 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)- }+installAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> InstallFlags -> Args -> IO ()+installAction verbHandles globalFlags hooks flags args = do+ let common = installCommonFlags flags+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args+ let flags' = flags{installCommonFlags = common'}+ distPref = fromFlag $ setupDistPref common' hookedAction verbosity preInst instHook postInst- (getBuildConfig hooks verbosity distPref)+ (getBuildConfig globalFlags 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+sdistAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> SDistFlags -> Args -> IO ()+sdistAction verbHandles _globalFlags _hooks flags _args = do+ let mbWorkDir = flagToMaybe $ sDistWorkingDir flags+ (_, ppd) <- confPkgDescr emptyUserHooks verbosity mbWorkDir Nothing let pkg_descr = flattenPackageDescription ppd- sdist pkg_descr flags srcPref knownSuffixHandlers+ sdist verbHandles 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}+ verbosity = mkVerbosity verbHandles $ fromFlag (setupVerbosity $ sDistCommonFlags flags) +testAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> TestFlags -> Args -> IO ()+testAction verbHandles globalFlags hooks flags args = do+ let common = testCommonFlags flags+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args+ let flags' = flags{testCommonFlags = common'}+ distPref = fromFlag $ setupDistPref common' hookedActionWithArgs verbosity preTest testHook postTest- (getBuildConfig hooks verbosity distPref)+ (getBuildConfig globalFlags 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}+benchAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> BenchmarkFlags -> Args -> IO ()+benchAction verbHandles globalFlags hooks flags args = do+ let common = benchmarkCommonFlags flags+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args+ let flags' = flags{benchmarkCommonFlags = common'}+ distPref = fromFlag $ setupDistPref common' hookedActionWithArgs verbosity preBench benchHook postBench- (getBuildConfig hooks verbosity distPref)+ (getBuildConfig globalFlags 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)- }+registerAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> RegisterFlags -> Args -> IO ()+registerAction verbHandles globalFlags hooks flags args = do+ let common = registerCommonFlags flags+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args+ let flags' = flags{registerCommonFlags = common'}+ distPref = fromFlag $ setupDistPref common' hookedAction verbosity preReg regHook postReg- (getBuildConfig hooks verbosity distPref)+ (getBuildConfig globalFlags hooks verbosity distPref) hooks- flags'{regArgs = args}+ flags' 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)- }+unregisterAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> RegisterFlags -> Args -> IO ()+unregisterAction verbHandles globalFlags hooks flags args = do+ let common = registerCommonFlags flags+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args+ let flags' = flags{registerCommonFlags = common'}+ distPref = fromFlag $ setupDistPref common' hookedAction verbosity preUnreg unregHook postUnreg- (getBuildConfig hooks verbosity distPref)+ (getBuildConfig globalFlags hooks verbosity distPref) hooks flags' args@@ -613,28 +818,34 @@ verbosity (PackageDescription{library = Nothing}) (Just _, _) =- dieWithException verbosity $ NoLibraryForPackage+ dieWithException verbosity NoLibraryForPackage sanityCheckHookedBuildInfo verbosity pkg_descr (_, hookExes)- | exe1 : _ <- nonExistant =+ | exe1 : _ <- nonExistent = dieWithException verbosity $ SanityCheckHookedBuildInfo exe1 where- pkgExeNames = nub (map exeName (executables pkg_descr))- hookExeNames = nub (map fst hookExes)- nonExistant = hookExeNames \\ pkgExeNames+ pkgExeNames = ordNub (map exeName (executables pkg_descr))+ hookExeNames = ordNub (map fst hookExes)+ nonExistent = hookExeNames \\ pkgExeNames sanityCheckHookedBuildInfo _ _ _ = return () -- | Try to read the 'localBuildInfoFile' tryGetBuildConfig- :: UserHooks+ :: GlobalFlags+ -> UserHooks -> Verbosity- -> FilePath+ -> SymbolicPath Pkg (Dir Dist) -> IO (Either ConfigStateFileError LocalBuildInfo)-tryGetBuildConfig u v = try . getBuildConfig u v+tryGetBuildConfig g u v = try . getBuildConfig g 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+getBuildConfig+ :: GlobalFlags+ -> UserHooks+ -> Verbosity+ -> SymbolicPath Pkg (Dir Dist)+ -> IO LocalBuildInfo+getBuildConfig globalFlags hooks verbosity distPref = do+ lbi_wo_programs <- getPersistBuildConfig mbWorkDir distPref -- Restore info about unconfigured programs, since it is not serialized let lbi = lbi_wo_programs@@ -647,15 +858,16 @@ case pkgDescrFile lbi of Nothing -> return lbi Just pkg_descr_file -> do- outdated <- checkPersistBuildConfigOutdated distPref pkg_descr_file+ outdated <- checkPersistBuildConfigOutdated mbWorkDir distPref pkg_descr_file if outdated then reconfigure pkg_descr_file lbi else return lbi where- reconfigure :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo+ mbWorkDir = flagToMaybe $ globalWorkingDir globalFlags+ reconfigure :: SymbolicPath Pkg File -> LocalBuildInfo -> IO LocalBuildInfo reconfigure pkg_descr_file lbi = do notice verbosity $- pkg_descr_file+ getSymbolicPath pkg_descr_file ++ " has been changed. " ++ "Re-configuring with most recently used options. " ++ "If this fails, please run configure manually.\n"@@ -671,44 +883,42 @@ (builtinPrograms ++ hookedPrograms hooks) ) `fmap` configPrograms_ cFlags- , -- Use the current, not saved verbosity level:- configVerbosity = Flag verbosity+ , configCommonFlags =+ (configCommonFlags cFlags)+ { -- Use the current, not saved verbosity level:+ setupVerbosity = Flag $ verbosityFlags verbosity+ } }- configureAction hooks cFlags' (extraConfigArgs lbi)+ configureAction (verbosityHandles verbosity) globalFlags hooks cFlags' (extraConfigArgs lbi) -- -------------------------------------------------------------------------- -- Cleaning -clean :: PackageDescription -> CleanFlags -> IO ()-clean pkg_descr flags = do- let distPref = fromFlagOrDefault defaultDistPref $ cleanDistPref flags+clean :: VerbosityHandles -> PackageDescription -> CleanFlags -> IO ()+clean verbHandles pkg_descr flags = do+ let common = cleanCommonFlags flags+ verbosity = mkVerbosity verbHandles (fromFlag (setupVerbosity common))+ distPref = fromFlagOrDefault defaultDistPref $ setupDistPref common+ mbWorkDir = flagToMaybe $ setupWorkingDir common+ i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path+ distPath = i distPref notice verbosity "cleaning..." maybeConfig <- if fromFlag (cleanSaveConf flags)- then maybeGetPersistBuildConfig distPref+ then maybeGetPersistBuildConfig mbWorkDir distPref else return Nothing -- 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)+ chattyTry verbosity "removing dist/" $ do+ removePathForcibly distPath -- Any extra files the user wants to remove- traverse_ removeFileOrDirectory (extraTmpFiles pkg_descr)+ traverse_ (removePathForcibly . i) (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)+ traverse_ (writePersistBuildConfig mbWorkDir distPref) maybeConfig -- -------------------------------------------------------------------------- -- Default hooks@@ -716,28 +926,38 @@ -- | Hooks that correspond to a plain instantiation of the -- \"simple\" build system simpleUserHooks :: UserHooks-simpleUserHooks =+simpleUserHooks = simpleUserHooksWithHandles defaultVerbosityHandles++-- | A version of 'simpleUserHooks' that allows setting custom logging handles.+simpleUserHooksWithHandles :: VerbosityHandles -> UserHooks+simpleUserHooksWithHandles verbHandles = emptyUserHooks- { confHook = configure+ { confHook = \p -> configure_setupHooks SetupHooks.noConfigureHooks p verbHandles , postConf = finalChecks- , buildHook = defaultBuildHook- , replHook = defaultReplHook- , copyHook = \desc lbi _ f -> install desc lbi f+ , buildHook = defaultBuildHook verbHandles+ , replHook = defaultReplHook verbHandles+ , copyHook = \desc lbi _ f -> install_setupHooks SetupHooks.noInstallHooks verbHandles 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+ instHook = defaultInstallHook verbHandles+ , testHook = defaultTestHook verbHandles+ , benchHook = defaultBenchHook verbHandles+ , cleanHook = \p _ _ f -> clean verbHandles p f+ , hscolourHook = \p l h f -> void $ hscolour_setupHooks noBuildHooks verbHandles p l (allSuffixHandlers h) f+ , haddockHook = \p l h f -> void $ haddock_setupHooks noBuildHooks verbHandles p l (allSuffixHandlers h) f+ , regHook = defaultRegHook verbHandles+ , unregHook = \p l _ f -> unregisterWithHandles verbHandles p l f } where+ noBuildHooks pbci@(SetupHooks.PreBuildComponentInputs{SetupHooks.localBuildInfo = lbi}) =+ builtinPreBuildHooks+ (buildType (localPkgDescr lbi))+ pbci finalChecks _args flags pkg_descr lbi =- checkForeignDeps pkg_descr lbi (lessVerbose verbosity)+ checkForeignDeps pkg_descr lbi (modifyVerbosityFlags lessVerbose verbosity) where- verbosity = fromFlag (configVerbosity flags)+ verbosity =+ mkVerbosity verbHandles $+ fromFlag (setupVerbosity $ configCommonFlags flags) -- | Basic autoconf 'UserHooks': --@@ -752,17 +972,17 @@ autoconfUserHooks = simpleUserHooks { postConf = defaultPostConf- , preBuild = readHookWithArgs buildVerbosity buildDistPref- , preRepl = readHookWithArgs replVerbosity replDistPref- , 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- , preTest = readHookWithArgs testVerbosity testDistPref- , preBench = readHookWithArgs benchmarkVerbosity benchmarkDistPref+ , preBuild = readHookWithArgs buildCommonFlags+ , preRepl = readHookWithArgs replCommonFlags+ , preCopy = readHookWithArgs copyCommonFlags+ , preClean = readHook cleanCommonFlags+ , preInst = readHook installCommonFlags+ , preHscolour = readHook hscolourCommonFlags+ , preHaddock = readHookWithArgs haddockCommonFlags+ , preReg = readHook registerCommonFlags+ , preUnreg = readHook registerCommonFlags+ , preTest = readHookWithArgs testCommonFlags+ , preBench = readHookWithArgs benchmarkCommonFlags } where defaultPostConf@@ -773,133 +993,228 @@ -> 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 dieWithException verbosity ConfigureScriptNotFound-- pbi <- getHookedBuildInfo verbosity (buildDir lbi)+ let common = configCommonFlags flags+ verbosity = mkVerbosity defaultVerbosityHandles (fromFlag $ setupVerbosity common)+ mbWorkDir = flagToMaybe $ setupWorkingDir common+ runConfigureScript+ defaultVerbosityHandles+ flags+ (flagAssignment lbi)+ (withPrograms lbi)+ (hostPlatform lbi)+ pbi <- getHookedBuildInfo verbosity mbWorkDir (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)+ :: (flags -> CommonSetupFlags) -> Args- -> a+ -> flags -> 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)+ readHookWithArgs get_common_flags _args flags = do+ let common = get_common_flags flags+ verbosity = mkVerbosity defaultVerbosityHandles (fromFlag (setupVerbosity common))+ mbWorkDir = flagToMaybe $ setupWorkingDir common+ distPref = setupDistPref common+ dist_dir <- findDistPrefOrDefault distPref+ getHookedBuildInfo verbosity mbWorkDir (dist_dir </> makeRelativePathEx "build") readHook- :: (a -> Flag Verbosity)- -> (a -> Flag FilePath)+ :: (flags -> CommonSetupFlags) -> Args- -> a+ -> flags -> 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)+ readHook get_common_flags args flags = do+ let common = get_common_flags flags+ verbosity = mkVerbosity defaultVerbosityHandles (fromFlag (setupVerbosity common))+ mbWorkDir = flagToMaybe $ setupWorkingDir common+ distPref = setupDistPref common+ noExtraFlags args+ dist_dir <- findDistPrefOrDefault distPref+ getHookedBuildInfo verbosity mbWorkDir (dist_dir </> makeRelativePathEx "build") -getHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo-getHookedBuildInfo verbosity build_dir = do- maybe_infoFile <- findHookedPackageDesc verbosity build_dir+getHookedBuildInfo+ :: Verbosity+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -> SymbolicPath Pkg (Dir Build)+ -> IO HookedBuildInfo+getHookedBuildInfo verbosity mbWorkDir build_dir = do+ maybe_infoFile <- findHookedPackageDesc verbosity mbWorkDir build_dir case maybe_infoFile of Nothing -> return emptyHookedBuildInfo Just infoFile -> do- info verbosity $ "Reading parameters from " ++ infoFile- readHookedBuildInfo verbosity infoFile+ info verbosity $ "Reading parameters from " ++ getSymbolicPath infoFile+ readHookedBuildInfo verbosity mbWorkDir infoFile +autoconfSetupHooks :: SetupHooks+autoconfSetupHooks =+ SetupHooks.noSetupHooks+ { SetupHooks.configureHooks =+ SetupHooks.noConfigureHooks+ { SetupHooks.postConfPackageHook = Just post_conf_pkg+ , SetupHooks.preConfComponentHook = Just pre_conf_comp+ }+ }+ where+ post_conf_pkg+ :: SetupHooks.PostConfPackageInputs+ -> IO ()+ post_conf_pkg+ ( SetupHooks.PostConfPackageInputs+ { SetupHooks.localBuildConfig =+ LBC.LocalBuildConfig{LBC.withPrograms = progs}+ , SetupHooks.packageBuildDescr =+ LBC.PackageBuildDescr+ { LBC.configFlags = cfg+ , LBC.flagAssignment = flags+ , LBC.hostPlatform = plat+ }+ }+ ) = runConfigureScript defaultVerbosityHandles cfg flags progs plat++ pre_conf_comp+ :: SetupHooks.PreConfComponentInputs+ -> IO SetupHooks.PreConfComponentOutputs+ pre_conf_comp+ ( SetupHooks.PreConfComponentInputs+ { SetupHooks.packageBuildDescr =+ LBC.PackageBuildDescr+ { LBC.configFlags = cfg+ , localPkgDescr = pkg_descr+ }+ , SetupHooks.component = component+ }+ ) = do+ let verbosity = mkVerbosity defaultVerbosityHandles (fromFlag $ configVerbosity cfg)+ mbWorkDir = flagToMaybe $ configWorkingDir cfg+ distPref = configDistPref cfg+ dist_dir <- findDistPrefOrDefault distPref+ -- Read the ".buildinfo" file and use that to update+ -- the components (main library + executables only).+ hbi <- getHookedBuildInfo verbosity mbWorkDir (dist_dir </> makeRelativePathEx "build")+ sanityCheckHookedBuildInfo verbosity pkg_descr hbi+ -- SetupHooks TODO: we are reading getHookedBuildInfo once+ -- for each component. I think this is inherent to the SetupHooks+ -- approach.+ let comp_name = componentName component+ diff <- case SetupHooks.hookedBuildInfoComponentDiff_maybe hbi comp_name of+ Nothing -> return $ SetupHooks.emptyComponentDiff comp_name+ Just do_diff -> do_diff+ return $+ SetupHooks.PreConfComponentOutputs+ { SetupHooks.componentDiff = diff+ }+ defaultTestHook- :: Args+ :: VerbosityHandles+ -> Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO ()-defaultTestHook args pkg_descr localbuildinfo _ flags =- test args pkg_descr localbuildinfo flags+defaultTestHook verbHandles args pkg_descr localbuildinfo _ flags =+ test args verbHandles pkg_descr localbuildinfo flags defaultBenchHook- :: Args+ :: VerbosityHandles+ -> Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> BenchmarkFlags -> IO ()-defaultBenchHook args pkg_descr localbuildinfo _ flags =- bench args pkg_descr localbuildinfo flags+defaultBenchHook verbHandles args pkg_descr localbuildinfo _ flags =+ bench args verbHandles pkg_descr localbuildinfo flags defaultInstallHook- :: PackageDescription+ :: VerbosityHandles+ -> PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO ()-defaultInstallHook pkg_descr localbuildinfo _ flags = do+defaultInstallHook verbHandles =+ defaultInstallHook_setupHooks SetupHooks.noInstallHooks verbHandles++defaultInstallHook_setupHooks+ :: SetupHooks.InstallHooks+ -> VerbosityHandles+ -> PackageDescription+ -> LocalBuildInfo+ -> UserHooks+ -> InstallFlags+ -> IO ()+defaultInstallHook_setupHooks inst_hooks verbHandles pkg_descr localbuildinfo _ flags = do let copyFlags = defaultCopyFlags- { copyDistPref = installDistPref flags- , copyDest = installDest flags- , copyVerbosity = installVerbosity flags+ { copyDest = installDest flags+ , copyCommonFlags = installCommonFlags flags }- install pkg_descr localbuildinfo copyFlags+ install_setupHooks inst_hooks verbHandles pkg_descr localbuildinfo copyFlags let registerFlags = defaultRegisterFlags- { regDistPref = installDistPref flags- , regInPlace = installInPlace flags+ { regInPlace = installInPlace flags , regPackageDB = installPackageDB flags- , regVerbosity = installVerbosity flags+ , registerCommonFlags = installCommonFlags flags }- when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags+ when (hasLibs pkg_descr) $+ registerWithHandles verbHandles pkg_descr localbuildinfo registerFlags defaultBuildHook- :: PackageDescription+ :: VerbosityHandles+ -> PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()-defaultBuildHook pkg_descr localbuildinfo hooks flags =- build pkg_descr localbuildinfo flags (allSuffixHandlers hooks)+defaultBuildHook verbHandles pkg_descr localbuildinfo hooks flags =+ void $+ build_setupHooks+ (builtinPreBuildHooks (buildType pkg_descr), const $ pure ())+ verbHandles+ pkg_descr+ localbuildinfo+ flags+ (allSuffixHandlers hooks) defaultReplHook- :: PackageDescription+ :: VerbosityHandles+ -> PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO ()-defaultReplHook pkg_descr localbuildinfo hooks flags args =- repl pkg_descr localbuildinfo flags (allSuffixHandlers hooks) args+defaultReplHook verbHandles pkg_descr localbuildinfo hooks flags args =+ void $+ repl_setupHooks+ (builtinPreBuildHooks (buildType pkg_descr))+ verbHandles+ pkg_descr+ localbuildinfo+ flags+ (allSuffixHandlers hooks)+ args defaultRegHook- :: PackageDescription+ :: VerbosityHandles+ -> PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO ()-defaultRegHook pkg_descr localbuildinfo _ flags =- if hasLibs pkg_descr- then register pkg_descr localbuildinfo flags- else+defaultRegHook verbHandles pkg_descr localbuildinfo _ flags+ | hasLibs pkg_descr =+ registerWithHandles verbHandles pkg_descr localbuildinfo flags+ | otherwise = setupMessage- (fromFlag (regVerbosity flags))+ verbosity "Package contains no library to register:" (packageId pkg_descr)+ where+ verbosity =+ mkVerbosity verbHandles $+ fromFlag (setupVerbosity $ registerCommonFlags flags)
src/Distribution/Simple/Bench.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -23,25 +24,32 @@ import qualified Distribution.PackageDescription as PD import Distribution.Pretty+import Distribution.Simple.Build (addInternalBuildTools) import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler-import Distribution.Simple.Flag (fromFlag)+import Distribution.Simple.Errors import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI+import Distribution.Simple.Program.Db+import Distribution.Simple.Program.Find+import Distribution.Simple.Program.Run import Distribution.Simple.Setup.Benchmark+import Distribution.Simple.Setup.Common import Distribution.Simple.UserHooks import Distribution.Simple.Utils-+import Distribution.System (Platform (Platform))+import Distribution.Types.Benchmark (Benchmark (benchmarkBuildInfo)) import Distribution.Types.UnqualComponentName+import Distribution.Utils.Path+import Distribution.Verbosity -import Distribution.Simple.Errors import System.Directory (doesFileExist)-import System.FilePath ((<.>), (</>)) -- | Perform the \"@.\/setup bench@\" action. bench :: Args -- ^ positional command-line arguments+ -> VerbosityHandles -> PD.PackageDescription -- ^ information from the .cabal file -> LBI.LocalBuildInfo@@ -49,20 +57,34 @@ -> BenchmarkFlags -- ^ flags sent to benchmark -> IO ()-bench args pkg_descr lbi flags = do- let verbosity = fromFlag $ benchmarkVerbosity flags+bench args verbHandles pkg_descr lbi flags = do+ curDir <- LBI.absoluteWorkingDirLBI lbi+ let verbosity = mkVerbosity verbHandles (fromFlag $ benchmarkVerbosity flags) benchmarkNames = args pkgBenchmarks = PD.benchmarks pkg_descr- enabledBenchmarks = map fst (LBI.enabledBenchLBIs pkg_descr lbi)+ enabledBenchmarks = LBI.enabledBenchLBIs pkg_descr lbi+ mbWorkDir = flagToMaybe $ benchmarkWorkingDir flags+ i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path -- Run the benchmark- doBench :: PD.Benchmark -> IO ExitCode- doBench bm =+ doBench :: (PD.Benchmark, LBI.ComponentLocalBuildInfo) -> IO ExitCode+ doBench (bm, clbi) = do+ let lbiForBench =+ lbi+ { -- Include any build-tool-depends on build tools internal to the current package.+ LBI.withPrograms =+ addInternalBuildTools+ curDir+ pkg_descr+ lbi+ (benchmarkBuildInfo bm)+ (LBI.withPrograms lbi)+ } case PD.benchmarkInterface bm of PD.BenchmarkExeV10 _ _ -> do- let cmd = LBI.buildDir lbi </> name </> name <.> exeExtension (LBI.hostPlatform lbi)+ let cmd = i $ LBI.buildDir lbiForBench </> makeRelativePathEx (name </> name <.> exeExtension (LBI.hostPlatform lbi)) options =- map (benchOption pkg_descr lbi bm) $+ map (benchOption pkg_descr lbiForBench bm) $ benchmarkOptions flags -- Check that the benchmark executable exists. exists <- doesFileExist cmd@@ -70,10 +92,26 @@ dieWithException verbosity $ NoBenchMarkProgram cmd + -- Compute the appropriate environment for running the benchmark+ let progDb = LBI.withPrograms lbiForBench+ pathVar = progSearchPath progDb+ envOverrides = progOverrideEnv progDb+ newPath <- programSearchPathAsPATHVar pathVar+ shellEnv <- getFullEnvironment ([("PATH", Just newPath)] ++ envOverrides)++ -- Add (DY)LD_LIBRARY_PATH if needed+ shellEnv' <-+ if LBI.withDynExe lbiForBench+ then do+ let (Platform _ os) = LBI.hostPlatform lbiForBench+ paths <- LBI.depLibraryPaths True False lbiForBench clbi+ return (addLibraryPath os paths shellEnv)+ else return shellEnv+ notice verbosity $ startMessage name -- This will redirect the child process -- stdout/stderr to the parent process.- exitcode <- rawSystemExitCode verbosity cmd options+ exitcode <- rawSystemExitCode verbosity mbWorkDir cmd options (Just shellEnv') notice verbosity $ finishMessage name exitcode return exitcode _ -> do@@ -98,7 +136,7 @@ [] -> return enabledBenchmarks names -> for names $ \bmName -> let benchmarkMap = zip enabledNames enabledBenchmarks- enabledNames = map PD.benchmarkName enabledBenchmarks+ enabledNames = map (PD.benchmarkName . fst) enabledBenchmarks allNames = map PD.benchmarkName pkgBenchmarks in case lookup (mkUnqualComponentName bmName) benchmarkMap of Just t -> return t@@ -110,6 +148,7 @@ 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
src/Distribution/Simple/Build.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} @@ -22,13 +25,18 @@ module Distribution.Simple.Build ( -- * Build build+ , build_setupHooks+ , buildComponent -- * Repl , repl+ , repl_setupHooks , startInterpreter -- * Build preparation , preBuildComponent+ , runPreBuildHooks+ , builtinPreBuildHooks , AutogenFile (..) , AutogenFileContents , writeBuiltinAutogenFiles@@ -40,6 +48,9 @@ -- * Internal package database creation , createInternalPackageDB++ -- * Handling of internal build tools+ , addInternalBuildTools ) where import Distribution.Compat.Prelude@@ -65,13 +76,12 @@ import Distribution.Package import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS-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.PackageInfoModule (generatePackageInfoModule)-import Distribution.Simple.Build.PathsModule (generatePathsModule)+import Distribution.Simple.Build.PathsModule (generatePathsModule, pkgPathEnvVar) import qualified Distribution.Simple.Program.HcPkg as HcPkg import Distribution.InstalledPackageInfo (InstalledPackageInfo)@@ -85,17 +95,25 @@ import Distribution.Simple.BuildTarget import Distribution.Simple.BuildToolDepends import Distribution.Simple.Configure+import Distribution.Simple.Errors import Distribution.Simple.Flag import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PreProcess import Distribution.Simple.Program-import Distribution.Simple.Program.Builtin (haskellSuiteProgram)+import Distribution.Simple.Program.Db import qualified Distribution.Simple.Program.GHC as GHC import Distribution.Simple.Program.Types import Distribution.Simple.Register import Distribution.Simple.Setup.Build+import Distribution.Simple.Setup.Common import Distribution.Simple.Setup.Config import Distribution.Simple.Setup.Repl+import Distribution.Simple.SetupHooks.Internal+ ( BuildingWhat (..)+ , buildingWhatVerbosity+ )+import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks+import qualified Distribution.Simple.SetupHooks.Rule as SetupHooks import Distribution.Simple.ShowBuildInfo import Distribution.Simple.Test.LibV09 import Distribution.Simple.Utils@@ -112,10 +130,9 @@ import Control.Monad import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as Map-import Distribution.Simple.Errors-import System.Directory (doesFileExist, getCurrentDirectory, removeFile)-import System.FilePath (takeDirectory, (<.>), (</>)) +import System.FilePath (takeDirectory)+ -- ----------------------------------------------------------------------------- -- | Build the libraries and executables in this package.@@ -129,75 +146,115 @@ -> [PPSuffixHandler] -- ^ preprocessors to run before compiling -> IO ()-build pkg_descr lbi flags suffixes = do- checkSemaphoreSupport verbosity (compiler lbi) flags- 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- )+build pkg lbi flags pps =+ void $ build_setupHooks noHooks defaultVerbosityHandles pkg lbi flags pps+ where+ noHooks = (const $ return [], const $ return ()) - when (null targets) $- -- Only bother with this message if we're building the whole package- setupMessage verbosity "Building" (packageId pkg_descr)+build_setupHooks+ :: ( SetupHooks.PreBuildComponentInputs -> IO [SetupHooks.MonitorFilePath]+ , SetupHooks.PostBuildComponentInputs -> IO ()+ )+ -- ^ build hooks+ -> VerbosityHandles+ -> 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 [SetupHooks.MonitorFilePath]+build_setupHooks+ (preBuildHook, postBuildHook)+ verbHandles+ pkg_descr+ lbi+ flags+ suffixHandlers = do+ let verbosity = mkVerbosity verbHandles (fromFlag $ buildVerbosity flags)+ distPref = fromFlag $ buildDistPref flags+ checkSemaphoreSupport verbosity (compiler lbi) flags - internalPackageDB <- createInternalPackageDB verbosity lbi distPref+ targets <- readTargetInfos verbosity pkg_descr lbi (buildTargets flags) - -- Before the actual building, dump out build-information.- -- This way, if the actual compilation failed, the options have still been- -- dumped.- dumpBuildInfo verbosity distPref (configDumpBuildInfo (configFlags lbi)) pkg_descr lbi flags+ let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets)+ info verbosity $+ "Component build order: "+ ++ intercalate+ ", "+ ( map+ (showComponentName . componentLocalName . targetCLBI)+ componentsToBuild+ ) - -- Now do the actual building- (\f -> foldM_ f (installedPkgs lbi) componentsToBuild) $ \index target -> do- preBuildComponent verbosity lbi target- let comp = targetComponent target- clbi = targetCLBI target- bi = componentBuildInfo comp- progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)- lbi' =- lbi- { withPrograms = progs'- , withPackageDB = withPackageDB lbi ++ [internalPackageDB]- , installedPkgs = index- }- par_strat <-- toFlag <$> case buildUseSemaphore flags of- Flag sem_name -> case buildNumJobs flags of- Flag{} -> do- warn verbosity $ "Ignoring -j due to --semaphore"- return $ UseSem sem_name- NoFlag -> return $ UseSem sem_name- NoFlag -> return $ case buildNumJobs flags of- Flag n -> NumJobs n- NoFlag -> Serial- mb_ipi <-- buildComponent- flags- par_strat- pkg_descr- lbi'- suffixes- comp- clbi- distPref- return (maybe index (Index.insert `flip` index) mb_ipi)+ when (null targets) $+ -- Only bother with this message if we're building the whole package+ setupMessage verbosity "Building" (packageId pkg_descr) - return ()- where- distPref = fromFlag (buildDistPref flags)- verbosity = fromFlag (buildVerbosity flags)+ internalPackageDB <- createInternalPackageDB verbosity lbi distPref + -- Before the actual building, dump out build-information.+ -- This way, if the actual compilation failed, the options have still been+ -- dumped.+ dumpBuildInfo verbosity distPref (configDumpBuildInfo (configFlags lbi)) pkg_descr lbi flags++ curDir <- absoluteWorkingDirLBI lbi++ -- Now do the actual building+ (mons, _) <- (\f -> foldM f ([], installedPkgs lbi) componentsToBuild) $ \(monsAcc, index) target -> do+ let comp = targetComponent target+ clbi = targetCLBI target+ bi = componentBuildInfo comp+ -- Include any build-tool-depends on build tools internal to the current package.+ progs' = addInternalBuildTools curDir pkg_descr lbi bi (withPrograms lbi)+ lbi' =+ lbi+ { withPrograms = progs'+ , withPackageDB = withPackageDB lbi ++ [internalPackageDB]+ , installedPkgs = index+ }+ pbci = SetupHooks.PreBuildComponentInputs (BuildNormal flags) lbi' target+ mons <- preBuildComponent (preBuildHook pbci) verbosity lbi' target+ let numJobs = buildNumJobs flags+ par_strat <-+ toFlag <$> case buildUseSemaphore flags of+ Flag sem_name -> case numJobs of+ Flag{} -> do+ warn verbosity "Ignoring -j due to --semaphore"+ return $ UseSem sem_name+ NoFlag -> return $ UseSem sem_name+ NoFlag -> return $ case numJobs of+ Flag n -> NumJobs n+ NoFlag -> Serial+ mb_ipi <-+ buildComponent+ verbHandles+ flags+ par_strat+ pkg_descr+ lbi'+ suffixHandlers+ comp+ clbi+ distPref+ let postBuildInputs =+ SetupHooks.PostBuildComponentInputs+ { SetupHooks.buildFlags = flags+ , SetupHooks.localBuildInfo = lbi'+ , SetupHooks.targetInfo = target+ }+ postBuildHook postBuildInputs+ return (monsAcc <> mons, maybe index (`Index.insert` index) mb_ipi)++ return mons+ -- | Check for conditions that would prevent the build from succeeding. checkSemaphoreSupport :: Verbosity -> Compiler -> BuildFlags -> IO () checkSemaphoreSupport verbosity comp flags = do- unless (jsemSupported comp || (isNothing (flagToMaybe (buildUseSemaphore flags)))) $+ unless (jsemSupported comp || isNothing (flagToMaybe (buildUseSemaphore flags))) $ dieWithException verbosity CheckSemaphoreSupport -- | Write available build information for 'LocalBuildInfo' to disk.@@ -208,7 +265,7 @@ -- lib:Cabal made sure that dependencies are up-to-date. dumpBuildInfo :: Verbosity- -> FilePath+ -> SymbolicPath Pkg (Dir Dist) -- ^ To which directory should the build-info be dumped? -> Flag DumpBuildInfo -- ^ Should we dump detailed build information for this component?@@ -232,26 +289,26 @@ (showComponentName . componentLocalName . targetCLBI) activeTargets )- pwd <- getCurrentDirectory (compilerProg, _) <- case flavorToProgram (compilerFlavor (compiler lbi)) of Nothing -> dieWithException verbosity $ UnknownCompilerFlavor (compilerFlavor (compiler lbi)) Just program -> requireProgram verbosity program (withPrograms lbi) - let (warns, json) = mkBuildInfo pwd pkg_descr lbi flags (compilerProg, compiler lbi) activeTargets+ wdir <- absoluteWorkingDirLBI lbi+ let (warns, json) = mkBuildInfo wdir 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- LBS.writeFile (buildInfoPref distPref) buildInfoText+ LBS.writeFile buildInfoFile buildInfoText - when (not shouldDumpBuildInfo) $ do+ unless shouldDumpBuildInfo $ -- Remove existing build-info.json as it might be outdated now.- exists <- doesFileExist (buildInfoPref distPref)- when exists $ removeFile (buildInfoPref distPref)+ removeFileForcibly buildInfoFile where+ buildInfoFile = interpretSymbolicPathLBI lbi $ buildInfoPref distPref shouldDumpBuildInfo = fromFlagOrDefault NoDumpBuildInfo dumpBuildInfoFlag == DumpBuildInfo -- \| Given the flavor of the compiler, try to find out@@ -261,7 +318,6 @@ flavorToProgram GHCJS = Just ghcjsProgram flavorToProgram UHC = Just uhcProgram flavorToProgram JHC = Just jhcProgram- flavorToProgram HaskellSuite{} = Just haskellSuiteProgram flavorToProgram _ = Nothing repl@@ -275,67 +331,111 @@ -- ^ preprocessors to run before compiling -> [String] -> IO ()-repl pkg_descr lbi flags suffixes args = do- let distPref = fromFlag (replDistPref flags)- verbosity = fromFlag (replVerbosity flags)+repl pkg lbi flags pps args =+ void $+ repl_setupHooks+ (const $ return [])+ defaultVerbosityHandles+ pkg+ lbi+ flags+ pps+ args - target <-- readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of- -- This seems DEEPLY questionable.- [] -> case allTargetsInBuildOrder' pkg_descr lbi of- (target : _) -> return target- [] -> dieWithException verbosity $ FailedToDetermineTarget- [target] -> return target- _ -> dieWithException verbosity $ NoMultipleTargets- let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target]- debug verbosity $- "Component build order: "- ++ intercalate- ", "- ( map- (showComponentName . componentLocalName . targetCLBI)- componentsToBuild- )+repl_setupHooks+ :: (SetupHooks.PreBuildComponentInputs -> IO [SetupHooks.MonitorFilePath])+ -- ^ pre-build hook+ -> VerbosityHandles+ -> 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 [SetupHooks.MonitorFilePath]+repl_setupHooks+ preBuildHook+ verbHandles+ pkg_descr+ lbi+ flags+ suffixHandlers+ args = do+ let distPref = fromFlag (replDistPref flags)+ verbosity = mkVerbosity verbHandles $ fromFlag (replVerbosity flags) - internalPackageDB <- createInternalPackageDB verbosity lbi distPref+ target <-+ readTargetInfos verbosity pkg_descr lbi args >>= \case+ -- This seems DEEPLY questionable.+ [] -> case allTargetsInBuildOrder' pkg_descr lbi of+ (target : _) -> return target+ [] -> dieWithException verbosity FailedToDetermineTarget+ [target] -> return target+ _ -> dieWithException verbosity NoMultipleTargets+ let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target]+ debug verbosity $+ "Component build order: "+ ++ intercalate+ ", "+ ( map+ (showComponentName . componentLocalName . targetCLBI)+ componentsToBuild+ ) - let lbiForComponent comp lbi' =- lbi'- { withPackageDB = withPackageDB lbi ++ [internalPackageDB]- , withPrograms =- addInternalBuildTools- pkg_descr- lbi'- (componentBuildInfo comp)- (withPrograms lbi')- }+ internalPackageDB <- createInternalPackageDB verbosity lbi distPref - -- build any dependent components- sequence_- [ do+ let lbiForComponent comp lbi' = do+ curDir <- absoluteWorkingDirLBI lbi'+ return $+ lbi'+ { withPackageDB = withPackageDB lbi' ++ [internalPackageDB]+ , withPrograms =+ -- Include any build-tool-depends on build tools internal to the current package.+ addInternalBuildTools+ curDir+ pkg_descr+ lbi'+ (componentBuildInfo comp)+ (withPrograms lbi')+ }+ pbci lbi' tgt = SetupHooks.PreBuildComponentInputs (BuildRepl flags) lbi' tgt++ -- build any dependent components and collect their monitored file paths+ depMonitors <- fmap concat $ for (safeInit componentsToBuild) $ \subtarget -> do let clbi = targetCLBI subtarget comp = targetComponent subtarget- lbi' = lbiForComponent comp lbi- preBuildComponent verbosity lbi subtarget- buildComponent- mempty{buildVerbosity = toFlag verbosity}- NoFlag- pkg_descr- lbi'- suffixes- comp- clbi- distPref- | subtarget <- safeInit componentsToBuild- ]+ lbi' <- lbiForComponent comp lbi+ monitors <- preBuildComponent (preBuildHook (pbci lbi' subtarget)) verbosity lbi' subtarget - -- REPL for target components- let clbi = targetCLBI target- comp = targetComponent target- lbi' = lbiForComponent comp lbi- preBuildComponent verbosity lbi target- replComponent flags verbosity pkg_descr lbi' suffixes comp clbi distPref+ _mb_ipi <-+ buildComponent+ verbHandles+ (mempty{buildCommonFlags = mempty{setupVerbosity = toFlag $ verbosityFlags verbosity}})+ NoFlag+ pkg_descr+ lbi'+ suffixHandlers+ comp+ clbi+ distPref + return monitors++ -- REPL for target components+ let clbi = targetCLBI target+ comp = targetComponent target+ lbi' <- lbiForComponent comp lbi++ targetMonitors <-+ preBuildComponent (preBuildHook (pbci lbi' target)) verbosity lbi' target++ replComponent flags verbosity pkg_descr lbi' suffixHandlers comp clbi distPref++ return (depMonitors <> targetMonitors)+ -- | Start an interpreter without loading any package files. startInterpreter :: Verbosity@@ -351,25 +451,29 @@ _ -> dieWithException verbosity REPLNotSupported buildComponent- :: BuildFlags+ :: VerbosityHandles+ -> BuildFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> Component -> ComponentLocalBuildInfo- -> FilePath+ -> SymbolicPath Pkg (Dir Dist) -> IO (Maybe InstalledPackageInfo)-buildComponent flags _ _ _ _ (CTest TestSuite{testInterface = TestSuiteUnsupported tt}) _ _ =- dieWithException (fromFlag $ buildVerbosity flags) $ NoSupportBuildingTestSuite tt-buildComponent flags _ _ _ _ (CBench Benchmark{benchmarkInterface = BenchmarkUnsupported tt}) _ _ =- dieWithException (fromFlag $ buildVerbosity flags) $ NoSupportBuildingBenchMark tt+buildComponent verbHandles flags _ _ _ _ (CTest TestSuite{testInterface = TestSuiteUnsupported tt}) _ _ =+ dieWithException (mkVerbosity verbHandles $ fromFlag $ buildVerbosity flags) $+ NoSupportBuildingTestSuite tt+buildComponent verbHandles flags _ _ _ _ (CBench Benchmark{benchmarkInterface = BenchmarkUnsupported tt}) _ _ =+ dieWithException (mkVerbosity verbHandles $ fromFlag $ buildVerbosity flags) $+ NoSupportBuildingBenchMark tt buildComponent+ verbHandles flags numJobs pkg_descr lbi0- suffixes+ suffixHandlers comp@( CTest test@TestSuite{testInterface = TestSuiteLibV09{}} )@@ -380,11 +484,11 @@ -- built. distPref = do- let verbosity = fromFlag $ buildVerbosity flags- pwd <- getCurrentDirectory+ inplaceDir <- absoluteWorkingDirLBI lbi0+ let verbosity = mkVerbosity verbHandles $ fromFlag $ buildVerbosity flags 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+ testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 inplaceDir distPref+ preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers 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'@@ -395,7 +499,7 @@ (maybeComponentInstantiatedWith clbi) let libbi = libBuildInfo lib lib' = lib{libBuildInfo = addSrcDir (addExtraOtherModules libbi generatedExtras) genDir}- buildLib flags numJobs pkg lbi lib' libClbi+ buildLib verbHandles flags 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.@@ -403,6 +507,7 @@ verbosity (compiler lbi) (withPrograms lbi)+ (mbWorkDirLBI lbi) (withPackageDB lbi) ipi HcPkg.defaultRegisterOptions@@ -416,17 +521,18 @@ buildExe verbosity numJobs pkg_descr lbi exe' exeClbi return Nothing -- Can't depend on test suite buildComponent+ verbHandles flags numJobs pkg_descr lbi- suffixes+ suffixHandlers comp clbi distPref = do- let verbosity = fromFlag $ buildVerbosity flags- preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes+ let verbosity = mkVerbosity verbHandles $ fromFlag $ buildVerbosity flags+ preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers extras <- preprocessExtras verbosity comp lbi setupMessage' verbosity@@ -444,27 +550,26 @@ flip addExtraCmmSources extras $ flip addExtraCxxSources extras $ flip addExtraCSources extras $- flip addExtraJsSources extras $- libbi+ addExtraJsSources libbi extras } - buildLib flags numJobs pkg_descr lbi lib' clbi+ buildLib verbHandles flags numJobs pkg_descr lbi lib' clbi let oneComponentRequested (OneComponentRequestedSpec _) = True oneComponentRequested _ = False -- Don't register inplace if we're only building a single component; -- it's not necessary because there won't be any subsequent builds -- that need to tag us- if (not (oneComponentRequested (componentEnabledSpec lbi)))+ if not (oneComponentRequested (componentEnabledSpec lbi)) then do -- Register the library in-place, so exes can depend -- on internally defined libraries.- pwd <- getCurrentDirectory+ inplaceDir <- absoluteWorkingDirLBI lbi let -- The in place registration uses the "-inplace" suffix, not an ABI hash installedPkgInfo = inplaceInstalledPackageInfo- pwd+ inplaceDir distPref pkg_descr -- NB: Use a fake ABI hash to avoid@@ -473,11 +578,12 @@ lib' lbi clbi- debug verbosity $ "Registering inplace:\n" ++ (IPI.showInstalledPackageInfo installedPkgInfo)+ debug verbosity $ "Registering inplace:\n" ++ IPI.showInstalledPackageInfo installedPkgInfo registerPackage verbosity (compiler lbi) (withPrograms lbi)+ (flagToMaybe $ buildWorkingDir flags) (withPackageDB lbi) installedPkgInfo HcPkg.defaultRegisterOptions@@ -519,60 +625,64 @@ -> LocalBuildInfo -> ComponentLocalBuildInfo -> Verbosity- -> IO (FilePath, [ModuleName.ModuleName])+ -> IO (SymbolicPath Pkg (Dir Source), [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+ unless (null codeGens) $ createDirectoryIfMissingVerbose verbosity True $ i tgtDir+ (tgtDir,) . 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"+ mbWorkDir = mbWorkDirLBI lbi+ i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path+ tgtDir = buildDir lbi </> makeRelativePathEx (nm' </> nm' ++ "-gen")+ verbLevel = verbosityLevel verbosity go :: String -> IO [ModuleName.ModuleName] go codeGenProg = fmap fromString . lines- <$> getDbProgramOutput+ <$> getDbProgramOutputCwd verbosity+ mbWorkDir (simpleProgram codeGenProg) (withPrograms lbi)- ( (tgtDir : map getSymbolicPath srcDirs)+ ( map interpretSymbolicPathCWD (tgtDir : srcDirs) ++ ( "--"- : GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) (GHC.componentGhcOptions verbosity lbi bi clbi tgtDir)+ : GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) (GHC.componentGhcOptions verbLevel lbi bi clbi tgtDir) ) ) -- | Add extra C sources generated by preprocessing to build -- information.-addExtraCSources :: BuildInfo -> [FilePath] -> BuildInfo+addExtraCSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo 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 :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo 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 :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo 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 :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo 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 :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo addExtraJsSources bi extras = bi{jsSources = new} where new = ordNub (extras ++ jsSources bi)@@ -585,10 +695,10 @@ new = ordNub (extras ++ otherModules bi) -- | Add extra source dir for generated modules.-addSrcDir :: BuildInfo -> FilePath -> BuildInfo+addSrcDir :: BuildInfo -> SymbolicPath Pkg (Dir Source) -> BuildInfo addSrcDir bi extra = bi{hsSourceDirs = new} where- new = ordNub (unsafeMakeSymbolicPath extra : hsSourceDirs bi)+ new = ordNub (extra : hsSourceDirs bi) replComponent :: ReplFlags@@ -598,7 +708,7 @@ -> [PPSuffixHandler] -> Component -> ComponentLocalBuildInfo- -> FilePath+ -> SymbolicPath Pkg (Dir Dist) -> IO () replComponent _ verbosity _ _ _ (CTest TestSuite{testInterface = TestSuiteUnsupported tt}) _ _ = dieWithException verbosity $ NoSupportBuildingTestSuite tt@@ -609,53 +719,54 @@ verbosity pkg_descr lbi0- suffixes+ suffixHandlers comp@( CTest test@TestSuite{testInterface = TestSuiteLibV09{}} ) clbi distPref = do- pwd <- getCurrentDirectory+ inplaceDir <- absoluteWorkingDirLBI lbi0 let (pkg, lib, libClbi, lbi, _, _, _) =- testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd- preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes+ testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 inplaceDir distPref+ preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers extras <- preprocessExtras verbosity comp lbi let libbi = libBuildInfo lib lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ extras}}- replLib replFlags pkg lbi lib' libClbi+ replLib (verbosityHandles verbosity) replFlags pkg lbi lib' libClbi replComponent replFlags verbosity pkg_descr lbi- suffixes+ suffixHandlers comp clbi _ = do- preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes+ let verbHandles = verbosityHandles verbosity+ preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers extras <- preprocessExtras verbosity comp lbi case comp of CLib lib -> do let libbi = libBuildInfo lib lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ extras}}- replLib replFlags pkg_descr lbi lib' clbi+ replLib verbHandles replFlags pkg_descr lbi lib' clbi CFLib flib ->- replFLib replFlags pkg_descr lbi flib clbi+ replFLib verbHandles replFlags pkg_descr lbi flib clbi CExe exe -> do let ebi = buildInfo exe exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}}- replExe replFlags pkg_descr lbi exe' clbi+ replExe verbHandles replFlags pkg_descr lbi exe' clbi CTest test@TestSuite{testInterface = TestSuiteExeV10{}} -> do let exe = testSuiteExeV10AsExe test let ebi = buildInfo exe exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}}- replExe replFlags pkg_descr lbi exe' clbi+ replExe verbHandles replFlags pkg_descr lbi exe' clbi CBench bm@Benchmark{benchmarkInterface = BenchmarkExeV10{}} -> do let exe = benchmarkExeV10asExe bm let ebi = buildInfo exe exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}}- replExe replFlags pkg_descr lbi exe' clbi+ replExe verbHandles replFlags pkg_descr lbi exe' clbi #if __GLASGOW_HASKELL__ < 811 -- silence pattern-match warnings prior to GHC 9.0 _ -> error "impossible"@@ -693,8 +804,9 @@ -> TestSuite -> ComponentLocalBuildInfo -> LocalBuildInfo- -> FilePath- -> FilePath+ -> AbsolutePath (Dir Pkg)+ -- ^ absolute inplace dir+ -> SymbolicPath Pkg (Dir Dist) -> ( PackageDescription , Library , ComponentLocalBuildInfo@@ -708,8 +820,8 @@ test@TestSuite{testInterface = TestSuiteLibV09 _ m} clbi lbi- distPref- pwd =+ inplaceDir+ distPref = (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) where bi = testBuildInfo test@@ -753,12 +865,7 @@ , testSuites = [] , subLibraries = [lib] }- ipi = inplaceInstalledPackageInfo pwd distPref pkg (mkAbiHash "") lib lbi libClbi- testDir =- buildDir lbi- </> stubName test- </> stubName test- ++ "-tmp"+ ipi = inplaceInstalledPackageInfo inplaceDir distPref pkg (mkAbiHash "") lib lbi libClbi testLibDep = Dependency pkgName'@@ -767,11 +874,11 @@ exe = Executable { exeName = mkUnqualComponentName $ stubName test- , modulePath = stubFilePath test+ , modulePath = makeRelativePathEx $ stubFilePath test , exeScope = ExecutablePublic , buildInfo = (testBuildInfo test)- { hsSourceDirs = [unsafeMakeSymbolicPath testDir]+ { hsSourceDirs = [coerceSymbolicPath $ testBuildDir lbi test] , targetBuildDepends = testLibDep : targetBuildDepends (testBuildInfo test)@@ -781,13 +888,12 @@ -- 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)+ : 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@@ -811,49 +917,77 @@ createInternalPackageDB :: Verbosity -> LocalBuildInfo- -> FilePath+ -> SymbolicPath Pkg (Dir Dist) -> 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)+ createPackageDB verbosity (compiler lbi) (withPrograms lbi) dbPath+ return (SpecificPackageDB dbRelPath) where- dbPath = internalPackageDBPath lbi distPref+ dbRelPath = internalPackageDBPath lbi distPref+ dbPath = interpretSymbolicPathLBI lbi dbRelPath +-- | Update the program database to include any build-tool-depends specified+-- in the given 'BuildInfo' on build tools internal to the current package.+--+-- This function:+--+-- - adds these internal build tools to the 'ProgramDb', including+-- paths to their respective data directories,+-- - adds their paths to the current 'progSearchPath', and adds the data+-- directory environment variable for the current package to the current+-- 'progOverrideEnv', so that any programs configured from now on will be+-- able to invoke these build tools. addInternalBuildTools- :: PackageDescription+ :: AbsolutePath (Dir Pkg)+ -> PackageDescription -> LocalBuildInfo -> BuildInfo -> ProgramDb -> ProgramDb-addInternalBuildTools pkg lbi bi progs =- foldr updateProgram progs internalBuildTools+addInternalBuildTools pwd pkg lbi bi progs =+ prependProgramSearchPathNoLogging+ internalToolPaths+ [pkgDataDirVar]+ $ foldr updateProgram progs internalBuildTools where+ internalToolPaths = map (takeDirectory . programPath) internalBuildTools+ pkgDataDirVar = (pkgPathEnvVar pkg "datadir", Just dataDirPath) internalBuildTools =- [ simpleConfiguredProgram toolName' (FoundOnSystem toolLocation)+ [ (simpleConfiguredProgram toolName' (FoundOnSystem toolLocation))+ { programOverrideEnv = [pkgDataDirVar]+ } | toolName <- getAllInternalToolDependencies pkg bi , let toolName' = unUnqualComponentName toolName- , let toolLocation = buildDir lbi </> toolName' </> toolName' <.> exeExtension (hostPlatform lbi)+ , let toolLocation =+ interpretSymbolicPathLBI lbi $+ buildDir lbi+ </> makeRelativePathEx (toolName' </> toolName' <.> exeExtension (hostPlatform lbi)) ] + -- This is an absolute path, so if a process changes directory, it can still+ -- find the datadir (#10717)+ dataDirPath :: FilePath+ dataDirPath = interpretSymbolicPathAbsolute pwd (dataDir pkg)+ -- TODO: build separate libs in separate dirs so that we can build -- multiple libs, e.g. for 'LibTest' library-style test suites buildLib- :: BuildFlags+ :: VerbosityHandles+ -> BuildFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO ()-buildLib flags numJobs pkg_descr lbi lib clbi =- let verbosity = fromFlag $ buildVerbosity flags+buildLib verbHandles flags numJobs pkg_descr lbi lib clbi =+ let verbosity = mkVerbosity verbHandles $ fromFlag $ buildVerbosity flags in case compilerFlavor (compiler lbi) of- GHC -> GHC.buildLib flags numJobs pkg_descr lbi lib clbi+ GHC -> GHC.buildLib verbHandles flags 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 _ -> dieWithException verbosity BuildingNotSupportedWithCompiler -- | Build a foreign library@@ -889,47 +1023,58 @@ _ -> dieWithException verbosity BuildingNotSupportedWithCompiler replLib- :: ReplFlags+ :: VerbosityHandles+ -> ReplFlags -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO ()-replLib replFlags pkg_descr lbi lib clbi =- let verbosity = fromFlag $ replVerbosity replFlags+replLib verbHandles replFlags pkg_descr lbi lib clbi =+ let verbosity = mkVerbosity verbHandles (fromFlag $ replVerbosity replFlags) opts = replReplOptions replFlags in 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 NoFlag pkg_descr lbi lib clbi+ GHC -> GHC.replLib verbHandles replFlags NoFlag pkg_descr lbi lib clbi GHCJS -> GHCJS.replLib (replOptionsFlags opts) verbosity NoFlag pkg_descr lbi lib clbi _ -> dieWithException verbosity REPLNotSupported replExe- :: ReplFlags+ :: VerbosityHandles+ -> ReplFlags -> PackageDescription -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO ()-replExe flags pkg_descr lbi exe clbi =- let verbosity = fromFlag $ replVerbosity flags+replExe verbHandles flags pkg_descr lbi exe clbi =+ let verbosity = mkVerbosity verbHandles $ fromFlag $ replVerbosity flags in case compilerFlavor (compiler lbi) of- GHC -> GHC.replExe flags NoFlag pkg_descr lbi exe clbi- GHCJS -> GHCJS.replExe (replOptionsFlags $ replReplOptions flags) verbosity NoFlag pkg_descr lbi exe clbi+ GHC -> GHC.replExe verbHandles flags NoFlag pkg_descr lbi exe clbi+ GHCJS ->+ GHCJS.replExe+ (replOptionsFlags $ replReplOptions flags)+ verbosity+ NoFlag+ pkg_descr+ lbi+ exe+ clbi _ -> dieWithException verbosity REPLNotSupported replFLib- :: ReplFlags+ :: VerbosityHandles+ -> ReplFlags -> PackageDescription -> LocalBuildInfo -> ForeignLib -> ComponentLocalBuildInfo -> IO ()-replFLib flags pkg_descr lbi exe clbi =- let verbosity = fromFlag $ replVerbosity flags+replFLib verbHandles flags pkg_descr lbi exe clbi =+ let verbosity = mkVerbosity verbHandles (fromFlag $ replVerbosity flags) in case compilerFlavor (compiler lbi) of- GHC -> GHC.replFLib flags NoFlag pkg_descr lbi exe clbi+ GHC -> GHC.replFLib verbHandles flags NoFlag pkg_descr lbi exe clbi _ -> dieWithException verbosity REPLNotSupported -- | Runs 'componentInitialBuildSteps' on every configured component.@@ -979,7 +1124,7 @@ -- ^ The verbosity to use -> IO () componentInitialBuildSteps _distPref pkg_descr lbi clbi verbosity = do- let compBuildDir = componentBuildDir lbi clbi+ let compBuildDir = interpretSymbolicPathLBI lbi $ componentBuildDir lbi clbi createDirectoryIfMissingVerbose verbosity True compBuildDir writeBuiltinAutogenFiles verbosity pkg_descr lbi clbi {-# DEPRECATED@@ -987,21 +1132,57 @@ "This function does not prepare all source files for a component. Suggestion: use 'Setup repl <compName> --repl-multi-file=<fn>'." #-} --- | Pre-build steps for a component: creates the autogenerated files--- for a particular configured component.+-- | Creates the autogenerated files for a particular configured component,+-- and runs the pre-build hook. preBuildComponent- :: Verbosity+ :: IO r+ -- ^ pre-build hook+ -> Verbosity -> LocalBuildInfo -- ^ Configuration information -> TargetInfo- -> IO ()-preBuildComponent verbosity lbi tgt = do+ -> IO r+preBuildComponent preBuildHook verbosity lbi tgt = do let pkg_descr = localPkgDescr lbi clbi = targetCLBI tgt- compBuildDir = componentBuildDir lbi clbi+ compBuildDir = interpretSymbolicPathLBI lbi $ componentBuildDir lbi clbi createDirectoryIfMissingVerbose verbosity True compBuildDir writeBuiltinAutogenFiles verbosity pkg_descr lbi clbi+ preBuildHook +-- | Compute and execute 'PreBuildComponentRules', returning the monitored+-- files declared by the rules.+runPreBuildHooks+ :: VerbosityHandles+ -> SetupHooks.PreBuildComponentInputs+ -> SetupHooks.PreBuildComponentRules+ -> IO [SetupHooks.MonitorFilePath]+runPreBuildHooks+ verbHandles+ pbci@( SetupHooks.PreBuildComponentInputs+ { SetupHooks.buildingWhat = what+ , SetupHooks.localBuildInfo = lbi+ , SetupHooks.targetInfo = tgt+ }+ )+ pbcRules = do+ let verbosity = mkVerbosity verbHandles $ buildingWhatVerbosity what+ (rules, mons) <- SetupHooks.computeRules verbosity pbci pbcRules+ SetupHooks.executeRules verbosity lbi tgt rules+ return mons++-- | Built-in pre-build 'SetupHooks' for a given 'BuildType'.+builtinPreBuildHooks+ :: BuildType+ -> SetupHooks.PreBuildComponentInputs+ -> IO [SetupHooks.MonitorFilePath]+builtinPreBuildHooks _ =+ -- NB: currently there are no built-in pre-build hooks.+ --+ -- In the future, we may want to migrate built-in preprocessors (such as+ -- @hsc2hs@, @alex@, @happy@) to pre-build hooks.+ const (return [])+ -- | Generate and write to disk all built-in autogenerated files -- for the specified component. These files will be put in the -- autogenerated module directory for this component@@ -1042,7 +1223,7 @@ pathsFile = AutogenModule (autogenPathsModuleName pkg) (Suffix "hs") pathsContents = toUTF8LBS $ generatePathsModule pkg lbi clbi packageInfoFile = AutogenModule (autogenPackageInfoModuleName pkg) (Suffix "hs")- packageInfoContents = toUTF8LBS $ generatePackageInfoModule pkg lbi+ packageInfoContents = toUTF8LBS $ generatePackageInfoModule pkg cppHeaderFile = AutogenFile $ toShortText cppHeaderName cppHeaderContents = toUTF8LBS $ generateCabalMacrosHeader pkg lbi clbi @@ -1106,4 +1287,4 @@ -- Write the contents of the file. rewriteFileLBS verbosity path contents where- autogenDir = autogenComponentModulesDir lbi clbi+ autogenDir = interpretSymbolicPathLBI lbi $ autogenComponentModulesDir lbi clbi
src/Distribution/Simple/Build/Inputs.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE PatternSynonyms #-}- module Distribution.Simple.Build.Inputs ( -- * Inputs of actions for building components PreBuildComponentInputs (..)@@ -18,13 +14,17 @@ , BuildingWhat (..) , LocalBuildInfo (..) , TargetInfo (..)+ , buildingWhatCommonFlags , buildingWhatVerbosity+ , buildingWhatWorkingDir , buildingWhatDistPref ) where import Distribution.Simple.Compiler-import Distribution.Simple.Setup (BuildingWhat (..), buildingWhatDistPref, buildingWhatVerbosity)+import Distribution.Simple.Setup hiding+ ( BuildFlags (buildVerbosity)+ ) import Distribution.Types.BuildInfo import Distribution.Types.Component import Distribution.Types.ComponentLocalBuildInfo@@ -44,7 +44,7 @@ } -- | Get the @'Verbosity'@ from the context the component being built is in.-buildVerbosity :: PreBuildComponentInputs -> Verbosity+buildVerbosity :: PreBuildComponentInputs -> VerbosityFlags buildVerbosity = buildingWhatVerbosity . buildingWhat -- | Get the @'Component'@ being built.
src/Distribution/Simple/Build/Macros.hs view
@@ -58,7 +58,7 @@ , let (major1, major2, minor) = majorMinor ver ] , Z.zPackageKey = case clbi of- LibComponentLocalBuildInfo{} -> componentCompatPackageKey clbi+ LibComponentLocalBuildInfo{componentCompatPackageKey = compatPackageKey} -> compatPackageKey _ -> "" , Z.zComponentId = prettyShow (componentComponentId clbi) , Z.zPackageVersion = pkgVersion (package pkg_descr)
src/Distribution/Simple/Build/PackageInfoModule.hs view
@@ -10,7 +10,7 @@ -- Generating the PackageInfo_pkgname module. -- -- This is a module that Cabal generates for the benefit of packages. It--- enables them to find their package informations.+-- enables them to find their package information. module Distribution.Simple.Build.PackageInfoModule ( generatePackageInfoModule ) where@@ -19,11 +19,14 @@ import Prelude () import Distribution.Package-import Distribution.PackageDescription-import Distribution.Simple.Compiler-import Distribution.Simple.LocalBuildInfo-import Distribution.Utils.ShortText-import Distribution.Version+ ( PackageName+ , packageName+ , packageVersion+ , unPackageName+ )+import Distribution.Types.PackageDescription (PackageDescription (..))+import Distribution.Types.Version (versionNumbers)+import Distribution.Utils.ShortText (fromShortText) import qualified Distribution.Simple.Build.PackageInfoModule.Z as Z @@ -33,8 +36,8 @@ -- ------------------------------------------------------------ -generatePackageInfoModule :: PackageDescription -> LocalBuildInfo -> String-generatePackageInfoModule pkg_descr lbi =+generatePackageInfoModule :: PackageDescription -> String+generatePackageInfoModule pkg_descr = Z.render Z.Z { Z.zPackageName = showPkgName $ packageName pkg_descr@@ -42,15 +45,7 @@ , 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])-- ghc_newer_than minVersion =- case compilerCompatVersion GHC (compiler lbi) of- Nothing -> False- Just version -> version `withinRange` orLaterVersion minVersion showPkgName :: PackageName -> String showPkgName = map fixchar . unPackageName
src/Distribution/Simple/Build/PackageInfoModule/Z.hs view
@@ -2,7 +2,7 @@ module Distribution.Simple.Build.PackageInfoModule.Z (render, Z (..)) where -import Distribution.ZinzaPrelude+import Distribution.ZinzaPrelude (Generic, execWriter, tell) data Z = Z { zPackageName :: String@@ -10,20 +10,30 @@ , 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 ()- tell "{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}\n"+ tell "{-# LANGUAGE NoRebindableSyntax #-}\n" tell "{-# OPTIONS_GHC -w #-}\n"+ tell "\n"+ tell "{-|\n"+ tell "Module : PackageInfo_"+ tell (zPackageName z_root)+ tell "\n"+ tell "Description : Contents of some of the package's Cabal file's fields.\n"+ tell "\n"+ tell "WARNING: This module was generated by Cabal. Any modifications will be\n"+ tell "overwritten if the module is regenerated.\n"+ tell "\n"+ tell "This module exports values that record information from some of the fields of\n"+ tell "the package's Cabal package description file (Cabal file).\n"+ tell "\n"+ tell "For further information about the fields in a Cabal file, see the Cabal User\n"+ tell "Guide.\n"+ tell "-}\n"+ tell "\n" tell "module PackageInfo_" tell (zPackageName z_root) tell " (\n"@@ -37,23 +47,29 @@ tell "import Data.Version (Version(..))\n" tell "import Prelude\n" tell "\n"+ tell "-- |The content of the @name@ field of the package's Cabal file, but with any\n"+ tell "-- hyphen characters replaced by underscore characters.\n" tell "name :: String\n" tell "name = " tell (show $ zPackageName z_root) tell "\n"+ tell "-- |The content of the @version@ field of the package's Cabal file.\n" tell "version :: Version\n" tell "version = Version " tell (zVersionDigits z_root) tell " []\n" tell "\n"+ tell "-- |The content of the @synopsis@ field of the package's Cabal file.\n" tell "synopsis :: String\n" tell "synopsis = " tell (show $ zSynopsis z_root) tell "\n"+ tell "-- |The content of the @copyright@ field of the package's Cabal file.\n" tell "copyright :: String\n" tell "copyright = " tell (show $ zCopyright z_root) tell "\n"+ tell "-- |The content of the @homepage@ field of the package's Cabal file.\n" tell "homepage :: String\n" tell "homepage = " tell (show $ zHomepage z_root)
src/Distribution/Simple/Build/PathsModule.hs view
@@ -44,13 +44,12 @@ 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.zIsAArch64 = buildArch == AArch64 , Z.zNot = not , Z.zManglePkgName = showPkgName , Z.zPrefix = show flat_prefix@@ -62,15 +61,6 @@ , 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])-- ghc_newer_than 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
src/Distribution/Simple/Build/PathsModule/Z.hs view
@@ -5,13 +5,12 @@ data Z = Z {zPackageName :: PackageName, zVersionDigits :: String,- zSupportsCpp :: Bool,- zSupportsNoRebindableSyntax :: Bool, zAbsolute :: Bool, zRelocatable :: Bool, zIsWindows :: Bool, zIsI386 :: Bool, zIsX8664 :: Bool,+ zIsAArch64 :: Bool, zPrefix :: FilePath, zBindir :: FilePath, zLibdir :: FilePath,@@ -24,34 +23,34 @@ deriving Generic render :: Z -> String render z_root = execWriter $ do- if (zSupportsCpp z_root)- then do- tell "{-# LANGUAGE CPP #-}\n"- return ()- else do- return ()- if (zSupportsNoRebindableSyntax z_root)- then do- tell "{-# LANGUAGE NoRebindableSyntax #-}\n"- return ()- else do- return ()+ tell "{-# LANGUAGE CPP #-}\n"+ tell "{-# LANGUAGE NoRebindableSyntax #-}\n" if (zNot z_root (zAbsolute z_root)) then do tell "{-# LANGUAGE ForeignFunctionInterface #-}\n" return () else do return ()- if (zSupportsCpp z_root)- then do- tell "#if __GLASGOW_HASKELL__ >= 810\n"- tell "{-# OPTIONS_GHC -Wno-prepositive-qualified-module #-}\n"- tell "#endif\n"- return ()- else do- return ()- tell "{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}\n" tell "{-# OPTIONS_GHC -w #-}\n"+ tell "\n"+ tell "{-|\n"+ tell "Module : Paths_"+ tell (zManglePkgName z_root (zPackageName z_root))+ tell "\n"+ tell "Description : Data file location, and package version and installation\n"+ tell " directories.\n"+ tell "\n"+ tell "WARNING: This module was generated by Cabal. Any modifications will be\n"+ tell "overwritten if the module is regenerated.\n"+ tell "\n"+ tell "This module exports a function to locate data files, and values that record\n"+ tell "the version of the package and some directories which the package has been\n"+ tell "configured to be installed into.\n"+ tell "\n"+ tell "For further information about Cabal's options for its configuration step, and\n"+ tell "their default values, see the Cabal User Guide.\n"+ tell "-}\n"+ tell "\n" tell "module Paths_" tell (zManglePkgName z_root (zPackageName z_root)) tell " (\n"@@ -69,7 +68,6 @@ return () tell "\n" tell "import qualified Control.Exception as Exception\n"- tell "import qualified Data.List as List\n" tell "import Data.Version (Version(..))\n" tell "import System.Environment (getEnv)\n" tell "import Prelude\n"@@ -81,38 +79,67 @@ else do return () tell "\n"- if (zSupportsCpp z_root)- then do- tell "#if defined(VERSION_base)\n"- tell "\n"- tell "#if MIN_VERSION_base(4,0,0)\n"- tell "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"- tell "#else\n"- tell "catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a\n"- tell "#endif\n"- tell "\n"- tell "#else\n"- tell "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"- tell "#endif\n"- tell "catchIO = Exception.catch\n"- return ()- else do- tell "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"- tell "catchIO = Exception.catch\n"- return ()+ tell "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"+ tell "catchIO = Exception.catch\n" tell "\n"+ tell "-- |The package version.\n" tell "version :: Version\n" tell "version = Version " tell (zVersionDigits z_root) tell " []\n" tell "\n"+ tell "-- |If the argument is a filename, the result is the name of a corresponding\n"+ tell "-- file on the system on which the program is running, if the file were listed\n"+ tell "-- in the @data-files@ field of the package's Cabal package description file.\n"+ tell "-- No check is performed that the given filename is listed in that field.\n" tell "getDataFileName :: FilePath -> IO FilePath\n" tell "getDataFileName name = do\n" tell " dir <- getDataDir\n" tell " return (dir `joinFileName` name)\n" tell "\n"- tell "getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"+ tell "-- |The location of the directory specified by Cabal's @--bindir@ option (where\n"+ tell "-- executables that the user might invoke are installed). This can be overridden\n"+ tell "-- at runtime using the environment variable "+ tell (zManglePkgName z_root (zPackageName z_root))+ tell "_bindir.\n"+ tell "getBinDir :: IO FilePath\n" tell "\n"+ tell "-- |The location of the directory specified by Cabal's @--libdir@ option (where\n"+ tell "-- object libraries are installed). This can be overridden at runtime using the\n"+ tell "-- environment variable "+ tell (zManglePkgName z_root (zPackageName z_root))+ tell "_libdir.\n"+ tell "getLibDir :: IO FilePath\n"+ tell "\n"+ tell "-- |The location of the directory specified by Cabal's @--dynlibdir@ option\n"+ tell "-- (where dynamic libraries are installed). This can be overridden at runtime\n"+ tell "-- using the environment variable "+ tell (zManglePkgName z_root (zPackageName z_root))+ tell "_dynlibdir.\n"+ tell "getDynLibDir :: IO FilePath\n"+ tell "\n"+ tell "-- |The location of the directory specified by Cabal's @--datadir@ option (where\n"+ tell "-- architecture-independent data files are installed). This can be overridden at\n"+ tell "-- runtime using the environment variable "+ tell (zManglePkgName z_root (zPackageName z_root))+ tell "_datadir.\n"+ tell "getDataDir :: IO FilePath\n"+ tell "\n"+ tell "-- |The location of the directory specified by Cabal's @--libexedir@ option\n"+ tell "-- (where executables that are not expected to be invoked directly by the user\n"+ tell "-- are installed). This can be overridden at runtime using the environment\n"+ tell "-- variable "+ tell (zManglePkgName z_root (zPackageName z_root))+ tell "_libexedir.\n"+ tell "getLibexecDir :: IO FilePath\n"+ tell "\n"+ tell "-- |The location of the directory specified by Cabal's @--sysconfdir@ option\n"+ tell "-- (where configuration files are installed). This can be overridden at runtime\n"+ tell "-- using the environment variable "+ tell (zManglePkgName z_root (zPackageName z_root))+ tell "_sysconfdir.\n"+ tell "getSysconfDir :: IO FilePath\n"+ tell "\n" let z_var0_function_defs = do tell "minusFileName :: FilePath -> String -> FilePath\n"@@ -285,9 +312,16 @@ tell " c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" return () else do- tell "-- win32 supported only with I386, X86_64\n"- tell "c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n"- tell "c_GetModuleFileName = _\n"+ if (zIsAArch64 z_root)+ then do+ tell "foreign import ccall unsafe \"windows.h GetModuleFileNameW\"\n"+ tell " c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n"+ return ()+ else do+ tell "-- win32 supported only with I386, X86_64, AArch64\n"+ tell "c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n"+ tell "c_GetModuleFileName = _\n"+ return () return () return () tell "\n"@@ -306,9 +340,14 @@ tell "joinFileName \"\" fname = fname\n" tell "joinFileName \".\" fname = fname\n" tell "joinFileName dir \"\" = dir\n"- tell "joinFileName dir fname\n"- tell " | isPathSeparator (List.last dir) = dir ++ fname\n"+ tell "joinFileName dir@(c:cs) fname\n"+ tell " | isPathSeparator (lastChar c cs) = dir ++ fname\n" tell " | otherwise = dir ++ pathSeparator : fname\n"+ tell " where\n"+ tell " -- We do not use Data.List.NonEmpty.last, as that would limit the module to\n"+ tell " -- base >= 4.9.0.0 (GHC >= 8.0.1).\n"+ tell " lastChar x [] = x\n"+ tell " lastChar _ (x:xs) = lastChar x xs\n" tell "\n" tell "pathSeparator :: Char\n" if (zIsWindows z_root)
src/Distribution/Simple/BuildPaths.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- @@ -18,20 +20,30 @@ , srcPref , buildInfoPref , haddockDirName+ , haddockLibraryDirPath+ , haddockTestDirPath+ , haddockBenchmarkDirPath , hscolourPref , haddockPref , autogenPackageModulesDir , autogenComponentModulesDir+ , preBuildRulesCacheFile , autogenPathsModuleName , autogenPackageInfoModuleName , cppHeaderName- , haddockName+ , haddockPath+ , haddockPackageLibraryName+ , haddockPackageLibraryName'+ , haddockLibraryName+ , haddockLibraryPath , mkGenericStaticLibName , mkLibName , mkProfLibName , mkGenericSharedLibName , mkSharedLibName+ , mkProfSharedLibName , mkStaticLibName+ , mkBytecodeLibName , mkGenericSharedBundledLibName , exeExtension , objExtension@@ -42,9 +54,14 @@ , getSourceFiles , getLibSourceFiles , getExeSourceFiles+ , getTestSourceFiles+ , getBenchmarkSourceFiles , getFLibSourceFiles , exeBuildDir , flibBuildDir+ , stubName+ , testBuildDir+ , benchmarkBuildDir ) where import Distribution.Compat.Prelude@@ -59,13 +76,12 @@ import Distribution.Simple.Errors import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PreProcess.Types (builtinHaskellSuffixes)-import Distribution.Simple.Setup.Common (defaultDistPref)+import Distribution.Simple.Setup.Common import Distribution.Simple.Setup.Haddock (HaddockTarget (..)) import Distribution.Simple.Utils import Distribution.System import Distribution.Utils.Path import Distribution.Verbosity-import System.FilePath (normalise, (<.>), (</>)) -- --------------------------------------------------------------------------- -- Build directories and files@@ -73,34 +89,87 @@ srcPref :: FilePath -> FilePath srcPref distPref = distPref </> "src" -hscolourPref :: HaddockTarget -> FilePath -> PackageDescription -> FilePath+hscolourPref+ :: HaddockTarget+ -> SymbolicPath root (Dir Dist)+ -> PackageDescription+ -> SymbolicPath root (Dir Artifacts) hscolourPref = haddockPref -- | Build info json file, generated in every build-buildInfoPref :: FilePath -> FilePath-buildInfoPref distPref = distPref </> "build-info.json"+buildInfoPref+ :: SymbolicPath root (Dir Dist)+ -> SymbolicPath root File+buildInfoPref distPref = distPref </> makeRelativePathEx "build-info.json" -- | This is the name of the directory in which the generated haddocks -- should be stored. It does not include the @<dist>/doc/html@ prefix.+--+-- It is also used by `haddock-project` when constructing its output directory. haddockDirName :: HaddockTarget -> PackageDescription -> FilePath haddockDirName ForDevelopment = prettyShow . packageName haddockDirName ForHackage = (++ "-docs") . prettyShow . packageId +-- | This is the name of the directory in which the generated haddocks for+-- a (sub)library should be stored. It does not include the @<dist>/doc/html@+-- prefix.+--+-- It is also used by `haddock-project` when constructing its output directory.+haddockLibraryDirPath+ :: HaddockTarget+ -> PackageDescription+ -> Library+ -> FilePath+haddockLibraryDirPath haddockTarget pkg_descr lib =+ case libName lib of+ LSubLibName sublib_name ->+ haddockDirName haddockTarget pkg_descr </> prettyShow sublib_name+ _ -> haddockDirName haddockTarget pkg_descr++haddockTestDirPath+ :: HaddockTarget+ -> PackageDescription+ -> TestSuite+ -> FilePath+haddockTestDirPath haddockTarget pkg_descr test =+ haddockDirName haddockTarget pkg_descr </> prettyShow (testName test)++haddockBenchmarkDirPath+ :: HaddockTarget+ -> PackageDescription+ -> Benchmark+ -> FilePath+haddockBenchmarkDirPath haddockTarget pkg_descr bench =+ haddockDirName haddockTarget pkg_descr </> prettyShow (benchmarkName bench)+ -- | The directory to which generated haddock documentation should be written.-haddockPref :: HaddockTarget -> FilePath -> PackageDescription -> FilePath+haddockPref+ :: HaddockTarget+ -> SymbolicPath root (Dir Dist)+ -> PackageDescription+ -> SymbolicPath root (Dir Artifacts) haddockPref haddockTarget distPref pkg_descr =- distPref </> "doc" </> "html" </> haddockDirName haddockTarget pkg_descr+ distPref </> makeRelativePathEx ("doc" </> "html" </> haddockDirName haddockTarget pkg_descr) -- | The directory in which we put auto-generated modules for EVERY -- component in the package.-autogenPackageModulesDir :: LocalBuildInfo -> String-autogenPackageModulesDir lbi = buildDir lbi </> "global-autogen"+autogenPackageModulesDir :: LocalBuildInfo -> SymbolicPath Pkg (Dir Source)+autogenPackageModulesDir lbi = buildDir lbi </> makeRelativePathEx "global-autogen" -- | The directory in which we put auto-generated modules for a -- particular component.-autogenComponentModulesDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> String-autogenComponentModulesDir lbi clbi = componentBuildDir lbi clbi </> "autogen"+autogenComponentModulesDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> SymbolicPath Pkg (Dir Source)+autogenComponentModulesDir lbi clbi = componentBuildDir lbi clbi </> makeRelativePathEx "autogen" +-- | The path to the pre-build rules cache file for a component, used to+-- compute rule staleness across runs.+preBuildRulesCacheFile+ :: LocalBuildInfo+ -> ComponentLocalBuildInfo+ -> SymbolicPath Pkg File+preBuildRulesCacheFile lbi clbi =+ componentBuildDir lbi clbi </> makeRelativePathEx "setup-hooks-rules.cache"+ -- NB: Look at 'checkForeignDeps' for where a simplified version of this -- has been copy-pasted. @@ -125,9 +194,36 @@ fixchar '-' = '_' fixchar c = c -haddockName :: PackageDescription -> FilePath-haddockName pkg_descr = prettyShow (packageName pkg_descr) <.> "haddock"+haddockPath :: PackageDescription -> FilePath+haddockPath pkg_descr = prettyShow (packageName pkg_descr) <.> "haddock" +-- | A name of a (sub)library used by haddock, in the form+-- `<package>:<library>` if it is a sublibrary, or `<package>` if it is the+-- main library.+--+-- Used by `haddock-project` and `Distribution.Simple.Haddock`.+haddockPackageLibraryName :: PackageDescription -> Library -> String+haddockPackageLibraryName pkg_descr lib =+ haddockPackageLibraryName' (packageName pkg_descr) (libName lib)++haddockPackageLibraryName' :: PackageName -> LibraryName -> String+haddockPackageLibraryName' pkg_name lib_name =+ case lib_name of+ LSubLibName sublib_name ->+ prettyShow pkg_name ++ ":" ++ prettyShow sublib_name+ LMainLibName -> prettyShow pkg_name++-- | A name of a (sub)library used by haddock.+haddockLibraryName :: PackageDescription -> Library -> String+haddockLibraryName pkg_descr lib =+ case libName lib of+ LSubLibName sublib_name -> prettyShow sublib_name+ LMainLibName -> prettyShow (packageName pkg_descr)++-- | File path of the ".haddock" file.+haddockLibraryPath :: PackageDescription -> Library -> FilePath+haddockLibraryPath pkg_descr lib = haddockLibraryName pkg_descr lib <.> "haddock"+ -- ----------------------------------------------------------------------------- -- Source File helper @@ -136,14 +232,16 @@ -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo- -> IO [(ModuleName.ModuleName, FilePath)]-getLibSourceFiles verbosity lbi lib clbi = getSourceFiles verbosity searchpaths modules+ -> IO [(ModuleName.ModuleName, SymbolicPath Pkg File)]+getLibSourceFiles verbosity lbi lib clbi =+ getSourceFiles verbosity mbWorkDir searchpaths modules where bi = libBuildInfo lib modules = allLibModules lib clbi+ mbWorkDir = mbWorkDirLBI lbi searchpaths =- componentBuildDir lbi clbi- : map getSymbolicPath (hsSourceDirs bi)+ coerceSymbolicPath (componentBuildDir lbi clbi)+ : hsSourceDirs bi ++ [ autogenComponentModulesDir lbi clbi , autogenPackageModulesDir lbi ]@@ -153,61 +251,133 @@ -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo- -> IO [(ModuleName.ModuleName, FilePath)]+ -> IO [(ModuleName.ModuleName, SymbolicPath Pkg 'File)] getExeSourceFiles verbosity lbi exe clbi = do- moduleFiles <- getSourceFiles verbosity searchpaths modules- srcMainPath <- findFileEx verbosity (map getSymbolicPath $ hsSourceDirs bi) (modulePath exe)+ moduleFiles <- getSourceFiles verbosity mbWorkDir searchpaths modules+ srcMainPath <- findFileCwd verbosity mbWorkDir (hsSourceDirs bi) (modulePath exe) return ((ModuleName.main, srcMainPath) : moduleFiles) where+ mbWorkDir = mbWorkDirLBI lbi bi = buildInfo exe modules = otherModules bi searchpaths = autogenComponentModulesDir lbi clbi : autogenPackageModulesDir lbi- : exeBuildDir lbi exe- : map getSymbolicPath (hsSourceDirs bi)+ : coerceSymbolicPath (exeBuildDir lbi exe)+ : hsSourceDirs bi +getTestSourceFiles+ :: Verbosity+ -> LocalBuildInfo+ -> TestSuite+ -> ComponentLocalBuildInfo+ -> IO [(ModuleName.ModuleName, SymbolicPath Pkg 'File)]+getTestSourceFiles verbosity lbi test@TestSuite{testInterface = TestSuiteExeV10 _ path} clbi = do+ moduleFiles <- getSourceFiles verbosity mbWorkDir searchpaths modules+ srcMainPath <- findFileCwd verbosity mbWorkDir (hsSourceDirs bi) path+ return ((ModuleName.main, srcMainPath) : moduleFiles)+ where+ mbWorkDir = mbWorkDirLBI lbi+ bi = testBuildInfo test+ modules = otherModules bi+ searchpaths =+ autogenComponentModulesDir lbi clbi+ : autogenPackageModulesDir lbi+ : coerceSymbolicPath (testBuildDir lbi test)+ : hsSourceDirs bi+getTestSourceFiles _ _ _ _ = return []++getBenchmarkSourceFiles+ :: Verbosity+ -> LocalBuildInfo+ -> Benchmark+ -> ComponentLocalBuildInfo+ -> IO [(ModuleName.ModuleName, SymbolicPath Pkg 'File)]+getBenchmarkSourceFiles verbosity lbi bench@Benchmark{benchmarkInterface = BenchmarkExeV10 _ path} clbi = do+ moduleFiles <- getSourceFiles verbosity mbWorkDir searchpaths modules+ srcMainPath <- findFileCwd verbosity mbWorkDir (hsSourceDirs bi) path+ return ((ModuleName.main, srcMainPath) : moduleFiles)+ where+ mbWorkDir = mbWorkDirLBI lbi+ bi = benchmarkBuildInfo bench+ modules = otherModules bi+ searchpaths =+ autogenComponentModulesDir lbi clbi+ : autogenPackageModulesDir lbi+ : coerceSymbolicPath (benchmarkBuildDir lbi bench)+ : hsSourceDirs bi+getBenchmarkSourceFiles _ _ _ _ = return []+ getFLibSourceFiles :: Verbosity -> LocalBuildInfo -> ForeignLib -> ComponentLocalBuildInfo- -> IO [(ModuleName.ModuleName, FilePath)]-getFLibSourceFiles verbosity lbi flib clbi = getSourceFiles verbosity searchpaths modules+ -> IO [(ModuleName.ModuleName, SymbolicPath Pkg File)]+getFLibSourceFiles verbosity lbi flib clbi =+ getSourceFiles verbosity mbWorkDir searchpaths modules where bi = foreignLibBuildInfo flib modules = otherModules bi+ mbWorkDir = mbWorkDirLBI lbi searchpaths = autogenComponentModulesDir lbi clbi : autogenPackageModulesDir lbi- : flibBuildDir lbi flib- : map getSymbolicPath (hsSourceDirs bi)+ : coerceSymbolicPath (flibBuildDir lbi flib)+ : hsSourceDirs bi getSourceFiles :: Verbosity- -> [FilePath]+ -> Maybe (SymbolicPath CWD ('Dir Pkg))+ -> [SymbolicPathX allowAbsolute Pkg (Dir Source)] -> [ModuleName.ModuleName]- -> IO [(ModuleName.ModuleName, FilePath)]-getSourceFiles verbosity dirs modules = flip traverse modules $ \m ->- fmap ((,) m) $- findFileWithExtension builtinHaskellSuffixes dirs (ModuleName.toFilePath m)- >>= maybe (notFound m) (return . normalise)+ -> IO [(ModuleName.ModuleName, SymbolicPathX allowAbsolute Pkg File)]+getSourceFiles verbosity mbWorkDir dirs modules = for modules $ \m ->+ fmap (m,) $+ findFileCwdWithExtension+ mbWorkDir+ builtinHaskellSuffixes+ dirs+ (moduleNameSymbolicPath m)+ >>= maybe (notFound m) (return . normaliseSymbolicPath) where notFound module_ = dieWithException verbosity $ CantFindSourceModule module_ -- | The directory where we put build results for an executable-exeBuildDir :: LocalBuildInfo -> Executable -> FilePath-exeBuildDir lbi exe = buildDir lbi </> nm </> nm ++ "-tmp"+exeBuildDir :: LocalBuildInfo -> Executable -> SymbolicPath Pkg (Dir Build)+exeBuildDir lbi exe = buildDir lbi </> makeRelativePathEx (nm </> nm ++ "-tmp") where nm = unUnqualComponentName $ exeName exe -- | The directory where we put build results for a foreign library-flibBuildDir :: LocalBuildInfo -> ForeignLib -> FilePath-flibBuildDir lbi flib = buildDir lbi </> nm </> nm ++ "-tmp"+flibBuildDir :: LocalBuildInfo -> ForeignLib -> SymbolicPath Pkg (Dir Build)+flibBuildDir lbi flib = buildDir lbi </> makeRelativePathEx (nm </> nm ++ "-tmp") where nm = unUnqualComponentName $ foreignLibName flib +-- | The name of the stub executable associated with a library 'TestSuite'.+stubName :: TestSuite -> FilePath+stubName t = unUnqualComponentName (testName t) ++ "Stub"++-- | The directory where we put build results for a test suite+testBuildDir :: LocalBuildInfo -> TestSuite -> SymbolicPath Pkg (Dir Build)+testBuildDir lbi tst =+ buildDir lbi </> makeRelativePathEx testDir+ where+ testDir = case testInterface tst of+ TestSuiteLibV09{} ->+ stubName tst </> stubName tst ++ "-tmp"+ _ -> nm </> nm ++ "-tmp"+ nm = unUnqualComponentName $ testName tst++-- | The directory where we put build results for a benchmark suite+benchmarkBuildDir :: LocalBuildInfo -> Benchmark -> SymbolicPath Pkg (Dir Build)+benchmarkBuildDir lbi bm =+ buildDir lbi </> makeRelativePathEx (nm </> nm ++ "-tmp")+ where+ nm = unUnqualComponentName $ benchmarkName bm+ -- --------------------------------------------------------------------------- -- Library file names @@ -238,6 +408,10 @@ mkSharedLibName platform comp lib = mkGenericSharedLibName platform comp (getHSLibraryName lib) +mkProfSharedLibName :: Platform -> CompilerId -> UnitId -> String+mkProfSharedLibName platform comp lib =+ mkGenericSharedLibName platform comp (getHSLibraryName lib ++ "_p")+ -- Static libs are named the same as shared libraries, only with -- a different extension. mkStaticLibName :: Platform -> CompilerId -> UnitId -> String@@ -245,6 +419,9 @@ "lib" ++ getHSLibraryName lib ++ "-" ++ comp <.> staticLibExtension platform where comp = prettyShow compilerFlavor ++ prettyShow compilerVersion++mkBytecodeLibName :: CompilerId -> UnitId -> String+mkBytecodeLibName _comp lib = getHSLibraryName lib <.> ".bytecodelib" -- | Create a library name for a bundled shared library from a given name. -- This matches the naming convention for shared libraries as implemented in
src/Distribution/Simple/BuildTarget.hs view
@@ -1,8 +1,10 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- @@ -40,6 +42,7 @@ , reportBuildTargetProblems ) where +import Data.Bifunctor (second) import Distribution.Compat.Prelude import Prelude () @@ -130,6 +133,9 @@ BuildTargetFile ComponentName FilePath deriving (Eq, Show, Generic) +-- | @since 3.18+deriving instance Ord BuildTarget+ instance Binary BuildTarget buildTargetComponentName :: BuildTarget -> ComponentName@@ -228,12 +234,12 @@ tokens :: CabalParsing m => m (String, Maybe (String, Maybe String)) tokens =- (\s -> (s, Nothing)) <$> parsecHaskellString+ (,Nothing) <$> parsecHaskellString <|> (,) <$> token <*> P.optional (P.char ':' *> tokens2) tokens2 :: CabalParsing m => m (String, Maybe String) tokens2 =- (\s -> (s, Nothing)) <$> parsecHaskellString+ (,Nothing) <$> parsecHaskellString <|> (,) <$> token <*> P.optional (P.char ':' *> (parsecHaskellString <|> token)) token :: CabalParsing m => m String@@ -326,7 +332,7 @@ (things, got :| _) = unzip' expected' in BuildTargetExpected userTarget (NE.toList things) got | not (null nosuch) = BuildTargetNoSuch userTarget nosuch- | otherwise = error $ "resolveBuildTarget: internal error in matching"+ | otherwise = error "resolveBuildTarget: internal error in matching" where expected = [(thing, got) | MatchErrorExpected thing got <- errs] nosuch = [(thing, got) | MatchErrorNoSuch thing got <- errs]@@ -353,9 +359,9 @@ where (amb, unamb) = step ql ts - userTargetQualLevel (UserBuildTargetSingle _) = QL1- userTargetQualLevel (UserBuildTargetDouble _ _) = QL2- userTargetQualLevel (UserBuildTargetTriple _ _ _) = QL3+ userTargetQualLevel UserBuildTargetSingle{} = QL1+ userTargetQualLevel UserBuildTargetDouble{} = QL2+ userTargetQualLevel UserBuildTargetTriple{} = QL3 step :: QualLevel@@ -407,7 +413,7 @@ targets -> dieWithException verbosity $ UnknownBuildTarget $- map (\(target, nosuch) -> (showUserBuildTarget target, nosuch)) targets+ map (first showUserBuildTarget) targets case [(t, ts) | BuildTargetAmbiguous t ts <- problems] of [] -> return ()@@ -417,7 +423,7 @@ map ( \(target, amb) -> ( showUserBuildTarget target- , (map (\(ut, bt) -> (showUserBuildTarget ut, showBuildTargetKind bt)) amb)+ , map (\(ut, bt) -> (showUserBuildTarget ut, showBuildTargetKind bt)) amb ) ) targets@@ -496,12 +502,12 @@ , 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+ , cinfoHsFiles = map getSymbolicPath $ componentHsFiles c+ , cinfoAsmFiles = map getSymbolicPath $ asmSources bi+ , cinfoCmmFiles = map getSymbolicPath $ cmmSources bi+ , cinfoCFiles = map getSymbolicPath $ cSources bi+ , cinfoCxxFiles = map getSymbolicPath $ cxxSources bi+ , cinfoJsFiles = map getSymbolicPath $ jsSources bi } | c <- pkgComponents pkg , let bi = componentBuildInfo c@@ -529,7 +535,7 @@ componentModules (CTest test) = testModules test componentModules (CBench bench) = benchmarkModules bench -componentHsFiles :: Component -> [FilePath]+componentHsFiles :: Component -> [RelativePath Source File] componentHsFiles (CExe exe) = [modulePath exe] componentHsFiles ( CTest@@ -652,7 +658,7 @@ orNoSuchThing (showComponentKind ckind ++ " component") str $ increaseConfidenceFor $ matchInexactly- (\(ck, cn) -> (ck, caseFold cn))+ (second caseFold) [((cinfoKind c, cinfoStrName c), c) | c <- cs] (ckind, str) @@ -853,6 +859,9 @@ | MatchErrorNoSuch String String deriving (Show, Eq) +-- | @since 3.18+deriving instance Ord MatchError+ instance Alternative Match where empty = mzero (<|>) = mplus@@ -905,10 +914,10 @@ NoMatch d ms >>= _ = NoMatch d ms ExactMatch d xs >>= f = addDepth d $- foldr matchPlus matchZero (map f xs)+ foldr (matchPlus . f) matchZero xs InexactMatch d xs >>= f = addDepth d . forceInexact $- foldr matchPlus matchZero (map f xs)+ foldr (matchPlus . f) matchZero xs addDepth :: Confidence -> Match a -> Match a addDepth d' (NoMatch d msgs) = NoMatch (d' + d) msgs@@ -941,13 +950,13 @@ increaseConfidenceFor :: Match a -> Match a increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r -nubMatches :: Eq a => Match a -> Match a+nubMatches :: Ord 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 (ExactMatch d xs) = ExactMatch d (ordNub xs)+nubMatches (InexactMatch d xs) = InexactMatch d (ordNub xs) nubMatchErrors :: Match a -> Match a-nubMatchErrors (NoMatch d msgs) = NoMatch d (nub msgs)+nubMatchErrors (NoMatch d msgs) = NoMatch d (ordNub msgs) nubMatchErrors (ExactMatch d xs) = ExactMatch d xs nubMatchErrors (InexactMatch d xs) = InexactMatch d xs @@ -968,14 +977,14 @@ -- | 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 :: Ord b => Match b -> MaybeAmbiguous b findMatch match = case match of- NoMatch _ msgs -> None (nub msgs)+ NoMatch _ msgs -> None (ordNub msgs) ExactMatch _ xs -> checkAmbiguous xs InexactMatch _ xs -> checkAmbiguous xs where- checkAmbiguous xs = case nub xs of+ checkAmbiguous xs = case ordNub xs of [x] -> Unambiguous x xs' -> Ambiguous xs' @@ -1016,9 +1025,7 @@ 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+ Nothing -> maybe matchZero inexactMatches (Map.lookup (cannonicalise x) m') where m = Map.fromListWith (++) [(k, [x]) | (k, x) <- xs]
src/Distribution/Simple/BuildToolDepends.hs view
@@ -13,7 +13,7 @@ import Distribution.Package import Distribution.PackageDescription --- | Same as 'desugarBuildTool', but requires atomic informations (package+-- | Same as 'desugarBuildTool', but requires atomic information (package -- name, executable names) instead of a whole 'PackageDescription'. desugarBuildToolSimple :: PackageName@@ -34,7 +34,6 @@ , "hsc2hs" , "c2hs" , "cpphs"- , "greencard" , "hspec-discover" ] allowMap = Map.fromList $ flip map allowlist $ \n ->
+ src/Distribution/Simple/BuildWay.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE LambdaCase #-}++module Distribution.Simple.BuildWay+ ( BuildWay (..)+ , buildWayObjectExtension+ , buildWayInterfaceExtension+ ) where++data BuildWay = StaticWay | DynWay | ProfWay | ProfDynWay+ deriving (Eq, Ord, Show, Read, Enum)++-- | Returns the object extension for the given build way (e.g. "dyn_o" for 'DynWay' on ELF)+buildWayObjectExtension :: String -> BuildWay -> String+buildWayObjectExtension ext = \case+ StaticWay -> ext+ ProfWay -> "p_" ++ ext+ DynWay -> "dyn_" ++ ext+ ProfDynWay -> "p_dyn_" ++ ext++buildWayInterfaceExtension :: BuildWay -> String+buildWayInterfaceExtension = buildWayObjectExtension "hi"
src/Distribution/Simple/Command.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- @@ -64,6 +66,7 @@ -- * Option Descriptions , OptDescr (..)+ , fmapOptDescr , Description , SFlags , LFlags@@ -88,6 +91,7 @@ import Prelude () import qualified Data.Array as Array+import Data.Either (rights) import qualified Data.List as List import Distribution.Compat.Lens (ALens', (#~), (^#)) import qualified Distribution.GetOpt as GetOpt@@ -151,6 +155,16 @@ (Bool -> a -> a) (a -> Maybe Bool) +fmapOptDescr :: forall a b. (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b+fmapOptDescr x u = \case+ ReqArg d o p upd get -> ReqArg d o p (fmap m upd) (get . x)+ OptArg d o p upd (str, g) get -> OptArg d o p (fmap m upd) (str, m g) (get . x)+ ChoiceOpt opts -> ChoiceOpt $ fmap (\(d, o, upd, get) -> (d, o, m upd, get . x)) opts+ BoolOpt d true false upd get -> BoolOpt d true false (\b -> m $ upd b) (get . x)+ where+ m :: (a -> a) -> (b -> b)+ m upd_a b = u (upd_a $ x b) b+ -- | Short command line option strings type SFlags = [Char] @@ -381,7 +395,7 @@ 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, liftSet get' set' set, get . get') | (d, ff, set, get) <- opts ] liftOptDescr get' set' (OptArg d ff ad set (dv, mkDef) get) =@@ -576,11 +590,11 @@ -- 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]+ accum flags = foldr (flip (.)) id (rights flags) unrecognised opts = [ "unrecognized " ++ "'"- ++ (commandName command)+ ++ commandName command ++ "'" ++ " option `" ++ opt@@ -611,8 +625,8 @@ -- | Mark command as hidden. Hidden commands don't show up in the 'progname -- help' or 'progname --help' output. hiddenCommand :: Command action -> Command action-hiddenCommand (Command name synopsys f _cmdType) =- Command name synopsys f HiddenCommand+hiddenCommand (Command name synopsis f _cmdType) =+ Command name synopsis f HiddenCommand commandAddAction :: CommandUI flags@@ -706,7 +720,7 @@ CommandList list -> pure $ CommandList (list ++ commandNames) CommandErrors _ -> pure $ CommandHelp globalHelp CommandReadyToGo (_, []) -> pure $ CommandHelp globalHelp- CommandReadyToGo (_, (name : cmdArgs')) ->+ CommandReadyToGo (_, name : cmdArgs') -> case lookupCommand name of [Command _ _ action _] -> case action ("--help" : cmdArgs') of
src/Distribution/Simple/Compiler.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-} ----------------------------------------------------------------------------- @@ -34,11 +35,22 @@ , compilerInfo -- * Support for package databases- , PackageDB (..)+ , PackageDB , PackageDBStack+ , PackageDBCWD+ , PackageDBStackCWD+ , PackageDBX (..)+ , PackageDBStackX+ , PackageDBS+ , PackageDBStackS , registrationPackageDB , absolutePackageDBPaths , absolutePackageDBPath+ , interpretPackageDB+ , interpretPackageDBStack+ , coercePackageDB+ , coercePackageDBStack+ , readPackageDb -- * Support for optimisation levels , OptimisationLevel (..)@@ -62,12 +74,20 @@ , unitIdSupported , coverageSupported , profilingSupported+ , profilingDynamicSupported+ , profilingDynamicSupportedOrUnknown+ , profilingVanillaSupported+ , profilingVanillaSupportedOrUnknown+ , dynamicSupported+ , bytecodeArtifactsSupported , backpackSupported , arResponseFilesSupported , arDashLSupported , libraryDynDirSupported , libraryVisibilitySupported , jsemSupported+ , jsemVersion+ , reexportedAsSupported -- * Support for profiling detail levels , ProfDetailLevel (..)@@ -76,15 +96,22 @@ , showProfDetailLevel ) where +import Distribution.Compat.CharParsing import Distribution.Compat.Prelude+import Distribution.Parsec import Distribution.Pretty import Prelude () import Distribution.Compiler+import Distribution.Package (PackageName) import Distribution.Simple.Utils+import Distribution.Types.UnitId (UnitId)+import Distribution.Utils.Path import Distribution.Version+ import Language.Haskell.Extension +import Data.Bool (bool) import qualified Data.Map as Map (lookup) import System.Directory (canonicalizePath) @@ -101,12 +128,19 @@ -- ^ Supported language standards. , compilerExtensions :: [(Extension, Maybe CompilerFlag)] -- ^ Supported extensions.+ , compilerWiredInUnitIds :: Maybe [(PackageName, UnitId)]+ -- ^ 'UnitId's that the compiler doesn't support reinstalling.+ -- For instance, when using GHC plugins, one wants to use the exact same+ -- version of the `ghc` package as the one the compiler was linked against.+ -- 'Nothing' indicates that the compiler hasn't supplied this+ -- information and that we should act pessimistically. , compilerProperties :: Map String String -- ^ A key-value map for properties not covered by the above fields. }- deriving (Eq, Generic, Typeable, Show, Read)+ deriving (Eq, Generic, Show, Read) instance Binary Compiler+instance NFData Compiler instance Structured Compiler showCompilerId :: Compiler -> String@@ -159,6 +193,7 @@ (Just . compilerCompat $ c) (Just . map fst . compilerLanguages $ c) (Just . map fst . compilerExtensions $ c)+ (compilerWiredInUnitIds c) -- ------------------------------------------------------------ @@ -172,15 +207,28 @@ -- 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+--+-- Abstracted over+data PackageDBX fp = GlobalPackageDB | UserPackageDB- | SpecificPackageDB FilePath- deriving (Eq, Generic, Ord, Show, Read, Typeable)+ | -- | NB: the path might be relative or it might be absolute+ SpecificPackageDB fp+ deriving (Eq, Generic, Ord, Show, Read, Functor, Foldable, Traversable) -instance Binary PackageDB-instance Structured PackageDB+instance Binary fp => Binary (PackageDBX fp)+instance NFData fp => NFData (PackageDBX fp)+instance Structured fp => Structured (PackageDBX fp) +-- | Parse a PackageDB stack entry+--+-- @since 3.7.0.0+readPackageDb :: String -> Maybe PackageDB+readPackageDb "clear" = Nothing+readPackageDb "global" = Just GlobalPackageDB+readPackageDb "user" = Just UserPackageDB+readPackageDb other = Just (SpecificPackageDB (makeSymbolicPath other))+ -- | We typically get packages from several databases, and stack them -- together. This type lets us be explicit about that stacking. For example -- typical stacks include:@@ -196,25 +244,64 @@ -- 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]+type PackageDBStackX from = [PackageDBX from] +type PackageDB = PackageDBX (SymbolicPath Pkg (Dir PkgDB))+type PackageDBStack = PackageDBStackX (SymbolicPath Pkg (Dir PkgDB))++type PackageDBS from = PackageDBX (SymbolicPath from (Dir PkgDB))+type PackageDBStackS from = PackageDBStackX (SymbolicPath from (Dir PkgDB))++type PackageDBCWD = PackageDBX FilePath+type PackageDBStackCWD = PackageDBStackX FilePath+ -- | Return the package that we should register into. This is the package db at -- the top of the stack.-registrationPackageDB :: PackageDBStack -> PackageDB+registrationPackageDB :: PackageDBStackX from -> PackageDBX from registrationPackageDB dbs = case safeLast dbs of Nothing -> error "internal error: empty package db set" Just p -> p -- | Make package paths absolute-absolutePackageDBPaths :: PackageDBStack -> IO PackageDBStack-absolutePackageDBPaths = traverse absolutePackageDBPath+absolutePackageDBPaths+ :: Maybe (SymbolicPath CWD (Dir Pkg))+ -> PackageDBStack+ -> IO PackageDBStack+absolutePackageDBPaths mbWorkDir = traverse $ absolutePackageDBPath mbWorkDir -absolutePackageDBPath :: PackageDB -> IO PackageDB-absolutePackageDBPath GlobalPackageDB = return GlobalPackageDB-absolutePackageDBPath UserPackageDB = return UserPackageDB-absolutePackageDBPath (SpecificPackageDB db) =- SpecificPackageDB `liftM` canonicalizePath db+absolutePackageDBPath+ :: Maybe (SymbolicPath CWD (Dir Pkg))+ -> PackageDB+ -> IO PackageDB+absolutePackageDBPath _ GlobalPackageDB = return GlobalPackageDB+absolutePackageDBPath _ UserPackageDB = return UserPackageDB+absolutePackageDBPath mbWorkDir (SpecificPackageDB db) = do+ let db' =+ case symbolicPathRelative_maybe db of+ Nothing -> getSymbolicPath db+ Just rel_path -> interpretSymbolicPath mbWorkDir rel_path+ SpecificPackageDB . makeSymbolicPath <$> canonicalizePath db' +interpretPackageDB :: Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageDBCWD+interpretPackageDB _ GlobalPackageDB = GlobalPackageDB+interpretPackageDB _ UserPackageDB = UserPackageDB+interpretPackageDB mbWorkDir (SpecificPackageDB db) =+ SpecificPackageDB (interpretSymbolicPath mbWorkDir db)++interpretPackageDBStack :: Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDBStack -> PackageDBStackCWD+interpretPackageDBStack mbWorkDir = map (interpretPackageDB mbWorkDir)++-- | Transform a package db using a FilePath into one using symbolic paths.+coercePackageDB :: PackageDBCWD -> PackageDBX (SymbolicPath CWD (Dir PkgDB))+coercePackageDB GlobalPackageDB = GlobalPackageDB+coercePackageDB UserPackageDB = UserPackageDB+coercePackageDB (SpecificPackageDB db) = SpecificPackageDB (makeSymbolicPath db)++coercePackageDBStack+ :: [PackageDBCWD]+ -> [PackageDBX (SymbolicPath CWD (Dir PkgDB))]+coercePackageDBStack = map coercePackageDB+ -- ------------------------------------------------------------ -- * Optimisation levels@@ -228,25 +315,42 @@ = NoOptimisation | NormalOptimisation | MaximumOptimisation- deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable)+ deriving (Bounded, Enum, Eq, Generic, Read, Show) instance Binary OptimisationLevel+instance NFData OptimisationLevel instance Structured OptimisationLevel +instance Parsec OptimisationLevel where+ parsec = parsecOptimisationLevel++parsecOptimisationLevel :: CabalParsing m => m OptimisationLevel+parsecOptimisationLevel = boolParser <|> intParser+ where+ boolParser = bool NoOptimisation NormalOptimisation <$> parsec+ intParser = intToOptimisationLevel <$> integral+ flagToOptimisationLevel :: Maybe String -> OptimisationLevel 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"+ [(i, "")] -> intToOptimisationLevel i _ -> error $ "Can't parse optimisation level " ++ s +intToOptimisationLevel :: Int -> OptimisationLevel+intToOptimisationLevel i+ | i >= minLevel && i <= maxLevel = toEnum i+ | otherwise =+ error $+ "Bad optimisation level: "+ ++ show i+ ++ ". Valid values are "+ ++ show minLevel+ ++ ".."+ ++ show maxLevel+ where+ minLevel = fromEnum (minBound :: OptimisationLevel)+ maxLevel = fromEnum (maxBound :: OptimisationLevel)+ -- ------------------------------------------------------------ -- * Debug info levels@@ -261,11 +365,18 @@ | MinimalDebugInfo | NormalDebugInfo | MaximalDebugInfo- deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable)+ deriving (Bounded, Enum, Eq, Generic, Read, Show) instance Binary DebugInfoLevel+instance NFData DebugInfoLevel instance Structured DebugInfoLevel +instance Parsec DebugInfoLevel where+ parsec = parsecDebugInfoLevel++parsecDebugInfoLevel :: CabalParsing m => m DebugInfoLevel+parsecDebugInfoLevel = flagToDebugInfoLevel . pure <$> parsecToken+ flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel flagToDebugInfoLevel Nothing = NormalDebugInfo flagToDebugInfoLevel (Just s) = case reads s of@@ -294,8 +405,7 @@ languageToFlags :: Compiler -> Maybe Language -> [CompilerFlag] languageToFlags comp = filter (not . null)- . catMaybes- . map (languageToFlag comp)+ . mapMaybe (languageToFlag comp) . maybe [Haskell98] (\x -> [x]) languageToFlag :: Compiler -> Language -> Maybe CompilerFlag@@ -314,8 +424,7 @@ extensionsToFlags comp = nub . filter (not . null)- . catMaybes- . map (extensionToFlag comp)+ . mapMaybe (extensionToFlag comp) -- | Looks up the flag for a given extension, for a given compiler. -- Ignores the subtlety of extensions which lack associated flags.@@ -372,19 +481,29 @@ where v = compilerVersion comp +-- | What semaphore protocol version does this compiler use?+--+-- Returns @Nothing@ for compilers that don't report a "Semaphore version"+-- field in @ghc --info@ (i.e. GHC 9.8–9.14, which use v1).+jsemVersion :: Compiler -> Maybe Int+jsemVersion comp = case compilerFlavor comp of+ GHC -> Map.lookup "Semaphore version" (compilerProperties comp) >>= readMaybe+ _ -> Nothing++-- | Does the compiler support the -reexported-modules "A as B" syntax+reexportedAsSupported :: Compiler -> Bool+reexportedAsSupported comp = case compilerFlavor comp of+ GHC -> v >= mkVersion [9, 12]+ _ -> False+ where+ v = compilerVersion comp+ -- | Does this compiler support a package database entry with: -- "dynamic-library-dirs"? 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]- )+ GHC -> True _ -> False- where- v = compilerVersion comp -- | Does this compiler's "ar" command supports response file -- arguments (i.e. @file-style arguments).@@ -413,6 +532,59 @@ GHCJS -> True _ -> False +-- | Returns Just if we can certainly determine whether a way is supported+-- if we don't know, return Nothing+waySupported :: String -> Compiler -> Maybe Bool+waySupported way comp =+ case compilerFlavor comp of+ GHC ->+ -- Information about compiler ways is only accurately reported after+ -- 9.10.1. Which is useful as this is before profiling dynamic support+ -- was introduced. (See GHC #24881)+ if compilerVersion comp >= mkVersion [9, 10, 1]+ then case Map.lookup "RTS ways" (compilerProperties comp) of+ Just ways -> Just (way `elem` words ways)+ Nothing -> Just False+ else Nothing+ _ -> Nothing++-- | Either profiling is definitely supported or we don't know (so assume+-- it is)+profilingVanillaSupportedOrUnknown :: Compiler -> Bool+profilingVanillaSupportedOrUnknown comp = profilingVanillaSupported comp `elem` [Just True, Nothing]++-- | Is the compiler distributed with profiling libraries+profilingVanillaSupported :: Compiler -> Maybe Bool+profilingVanillaSupported comp = waySupported "p" comp++-- | Is the compiler distributed with profiling dynamic libraries+profilingDynamicSupported :: Compiler -> Maybe Bool+profilingDynamicSupported comp+ | GHC <- compilerFlavor comp+ , -- Certainly not before 9.11, as prof+dyn was not implemented yet.+ compilerVersion comp <= mkVersion [9, 11, 0] =+ Just False+ | otherwise =+ waySupported "p_dyn" comp++-- | Either profiling dynamic is definitely supported or we don't know (so assume+-- it is)+profilingDynamicSupportedOrUnknown :: Compiler -> Bool+profilingDynamicSupportedOrUnknown comp =+ profilingDynamicSupported comp `elem` [Just True, Nothing]++-- | Is the compiler distributed with dynamic libraries+dynamicSupported :: Compiler -> Maybe Bool+dynamicSupported comp = waySupported "dyn" comp++-- | Does the compiler support producing bytecode objects and bytecode libraries?+bytecodeArtifactsSupported :: Compiler -> Bool+bytecodeArtifactsSupported comp+ | GHC <- compilerFlavor comp+ , compilerVersion comp >= mkVersion [9, 15, 0] =+ True+ | otherwise = False+ -- | Does this compiler support a package database entry with: -- "visibility"? libraryVisibilitySupported :: Compiler -> Bool@@ -455,10 +627,17 @@ | ProfDetailAllFunctions | ProfDetailTopLate | ProfDetailOther String- deriving (Eq, Generic, Read, Show, Typeable)+ deriving (Eq, Generic, Read, Show) instance Binary ProfDetailLevel+instance NFData ProfDetailLevel instance Structured ProfDetailLevel++instance Parsec ProfDetailLevel where+ parsec = parsecProfDetailLevel++parsecProfDetailLevel :: CabalParsing m => m ProfDetailLevel+parsecProfDetailLevel = flagToProfDetailLevel <$> parsecToken flagToProfDetailLevel :: String -> ProfDetailLevel flagToProfDetailLevel "" = ProfDetailDefault
src/Distribution/Simple/Configure.hs view
@@ -1,2636 +1,3097 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}----------------------------------------------------------------------------------- |--- Module : Distribution.Simple.Configure--- Copyright : Isaac Jones 2003-2005--- License : BSD3------ Maintainer : cabal-devel@haskell.org--- Portability : portable------ This deals with the /configure/ phase. It provides the 'configure' action--- which is given the package description and configure flags. It then tries--- to: configure the compiler; resolves any conditionals in the package--- description; resolve the package dependencies; check if all the extensions--- used by this package are supported by the compiler; check that all the build--- tools are available (including version checks if appropriate); checks for--- any required @pkg-config@ packages (updating the 'BuildInfo' with the--- results)------ Then based on all this it saves the info in the 'LocalBuildInfo' and writes--- 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- , getConfigStateFile- , getPersistBuildConfig- , checkPersistBuildConfigOutdated- , tryGetPersistBuildConfig- , maybeGetPersistBuildConfig- , findDistPref- , findDistPrefOrDefault- , getInternalLibraries- , computeComponentId- , computeCompatPackageKey- , localBuildInfoFile- , getInstalledPackages- , getInstalledPackagesMonitorFiles- , getInstalledPackagesById- , getPackageDBContents- , configCompilerEx- , configCompilerAuxEx- , computeEffectiveProfiling- , ccLdOptionsBuildInfo- , checkForeignDeps- , interpretPackageDbFlags- , ConfigStateFileError (..)- , tryGetConfigStateFile- , platformDefines- ) where--import Control.Monad-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.InstalledPackageInfo (InstalledPackageInfo)-import qualified Distribution.InstalledPackageInfo as IPI-import Distribution.Package-import Distribution.PackageDescription-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, lookupUnitId)-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.PreProcess-import Distribution.Simple.Program-import Distribution.Simple.Program.Db (lookupProgramByName, modifyProgramSearchPath, prependProgramSearchPath)-import Distribution.Simple.Setup.Common as Setup-import Distribution.Simple.Setup.Config as Setup-import Distribution.Simple.Utils-import Distribution.System-import Distribution.Types.ComponentRequestedSpec-import Distribution.Types.GivenComponent-import qualified Distribution.Types.LocalBuildConfig as LBC-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.GHCJS as GHCJS-import qualified Distribution.Simple.HaskellSuite as HaskellSuite-import qualified Distribution.Simple.UHC as UHC--import Control.Exception- ( try- )-import qualified Data.ByteString as BS-import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy.Char8 as BLC8-import Data.List- ( 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- )-import System.FilePath- ( isAbsolute- , takeDirectory- , (</>)- )-import System.IO- ( hClose- , hPutStrLn- )-import qualified System.Info- ( compilerName- , compilerVersion- )-import Text.PrettyPrint- ( Doc- , char- , hsep- , quotes- , renderStyle- , text- , ($+$)- )--import qualified Data.Maybe as M-import qualified Data.Set as Set-import qualified Distribution.Compat.NonEmptySet as NES-import Distribution.Simple.Errors-import Distribution.Types.AnnotatedId--type UseExternalInternalDeps = Bool---- | The errors that can be thrown when reading the @setup-config@ file.-data ConfigStateFileError- = -- | 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 "Re-run the 'configure' command."-dispConfigStateFileError ConfigStateFileBadHeader =- text "Saved package config file header is corrupt."- <+> text "Re-run the 'configure' command."-dispConfigStateFileError ConfigStateFileNoParse =- text "Saved package config file is corrupt."- <+> text "Re-run the 'configure' command."-dispConfigStateFileError ConfigStateFileMissing =- text "Run the 'configure' command first."-dispConfigStateFileError (ConfigStateFileBadVersion oldCabal oldCompiler _) =- 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--instance Show ConfigStateFileError where- 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 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- 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 = try . getConfigStateFile---- | Try to read the 'localBuildInfoFile'.-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 = getConfigStateFile . localBuildInfoFile---- | Try to read the 'localBuildInfoFile'.-maybeGetPersistBuildConfig- :: FilePath- -- ^ The @dist@ directory path.- -> IO (Maybe LocalBuildInfo)-maybeGetPersistBuildConfig =- 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 distPref lbi = do- createDirectoryIfMissing False distPref- writeFileAtomic (localBuildInfoFile distPref) $- BLC8.unlines [showHeader pkgId, structuredEncode lbi]- where- pkgId = localPackage lbi---- | Identifier of the current Cabal package.-currentCabalId :: PackageIdentifier-currentCabalId = PackageIdentifier (mkPackageName "Cabal") cabalVersion---- | Identifier of the current compiler package.-currentCompilerId :: PackageIdentifier-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 header = case BLC8.words header of- [ "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')- _ -> throwIO ConfigStateFileNoHeader---- | Generate the @setup-config@ file header.-showHeader- :: PackageIdentifier- -- ^ The processed package.- -> ByteString-showHeader pkgId =- BLC8.unwords- [ "Saved"- , "package"- , "config"- , "for"- , toUTF8LBS $ prettyShow pkgId- , "written"- , "by"- , BLC8.pack $ prettyShow currentCabalId- , "using"- , BLC8.pack $ prettyShow currentCompilerId- ]---- | Check that localBuildInfoFile is up-to-date with respect to the--- .cabal file.-checkPersistBuildConfigOutdated :: FilePath -> FilePath -> IO Bool-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 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 defDistPref overrideDistPref = do- envDistPref <- liftM parseEnvDistPref (lookupEnv "CABAL_BUILDDIR")- return $ fromFlagOrDefault defDistPref (mappend envDistPref overrideDistPref)- where- parseEnvDistPref env =- case env of- Just distPref | not (null distPref) -> toFlag distPref- _ -> NoFlag---- | 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 'defaultDistPref' is used. Call--- 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 = findDistPref defaultDistPref---- | Perform the \"@.\/setup configure@\" action.--- Returns the @.setup-config@ file.-configure- :: (GenericPackageDescription, HookedBuildInfo)- -> ConfigFlags- -> IO LocalBuildInfo-configure (g_pkg_descr, hookedBuildInfo) cfg = do- -- Cabal pre-configure- (lbc1, comp, platform, enabledComps) <- preConfigurePackage cfg g_pkg_descr-- -- Cabal package-wide configure- (lbc2, pbd2, pkg_info) <-- finalizeAndConfigurePackage cfg lbc1 g_pkg_descr comp platform enabledComps-- -- Cabal per-component configure- externalPkgDeps <- finalCheckPackage g_pkg_descr pbd2 hookedBuildInfo pkg_info- configureComponents lbc2 pbd2 pkg_info externalPkgDeps--preConfigurePackage- :: ConfigFlags- -> GenericPackageDescription- -> IO (LBC.LocalBuildConfig, Compiler, Platform, ComponentRequestedSpec)-preConfigurePackage cfg g_pkg_descr = do- let verbosity = fromFlag (configVerbosity cfg)-- -- 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 g_pkg_descr- 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)- [] -> dieWithException verbosity NoValidComponent- _ -> dieWithException verbosity ConfigureEitherSingleOrAll-- case mb_cname of- Nothing -> setupMessage verbosity "Configuring" (packageId g_pkg_descr)- Just cname ->- setupMessage'- verbosity- "Configuring"- (packageId g_pkg_descr)- cname- (Just (configInstantiateWith cfg))-- -- configCID is only valid for per-component configure- when (isJust (flagToMaybe (configCID cfg)) && isNothing mb_cname) $- dieWithException verbosity ConfigCIDValidForPreComponent-- -- 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))- )- $ dieWithException verbosity SanityCheckForEnableComponents-- checkDeprecatedFlags verbosity cfg- checkExactConfiguration verbosity g_pkg_descr cfg-- programDbPre <- mkProgramDb cfg (configPrograms 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- , programDb00 :: ProgramDb- ) <-- configCompilerEx- (flagToMaybe (configHcFlavor cfg))- (flagToMaybe (configHcPath cfg))- (flagToMaybe (configHcPkg cfg))- programDbPre- (lessVerbose verbosity)-- -- Where to build the package- let build_dir :: FilePath -- e.g. dist/build- build_dir = configFlagsBuildDir cfg- -- NB: create this directory now so that all configure hooks get- -- to see it. (In practice, the Configure build-type needs it before- -- the postConfPackageHook runs.)- createDirectoryIfMissingVerbose (lessVerbose verbosity) True build_dir-- lbc <- computeLocalBuildConfig cfg comp programDb00- return (lbc, comp, compPlatform, enabled)--computeLocalBuildConfig- :: ConfigFlags- -> Compiler- -> ProgramDb- -> IO LBC.LocalBuildConfig-computeLocalBuildConfig cfg comp programDb = do- let verbosity = fromFlag (configVerbosity cfg)- -- 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-- -- Basically yes/no/unknown.- let linkerSupportsRelocations :: Maybe Bool- linkerSupportsRelocations =- case lookupProgramByName "ld" programDb of- Nothing -> Nothing- Just ld ->- case Map.lookup "Supports relocatable output" $ programProperties ld of- Just "YES" -> Just True- Just "NO" -> Just False- _other -> Nothing- 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- -- NOTE: If linkerSupportsRelocations is Nothing this may still fail if the- -- linker does not support -r.- True | not (fromMaybe True linkerSupportsRelocations) -> do- warn verbosity $- "--enable-library-for-ghci is not supported with the current"- ++ " linker; 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."-- setProfiling <- configureProfiling verbosity cfg comp-- setCoverage <- 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 buildOptions =- setCoverage . setProfiling $- LBC.BuildOptions- { 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- , relocatable = fromFlagOrDefault False $ configRelocatable cfg- }-- return $- LBC.LocalBuildConfig- { extraConfigArgs = [] -- Currently configure does not- -- take extra args, but if it- -- did they would go here.- , withPrograms = programDb- , withBuildOptions = buildOptions- }--data PackageInfo = PackageInfo- { internalPackageSet :: Set LibraryName- , promisedDepsSet :: Map (PackageName, ComponentName) ComponentId- , installedPackageSet :: InstalledPackageIndex- , requiredDepsMap :: Map (PackageName, ComponentName) InstalledPackageInfo- }--configurePackage- :: ConfigFlags- -> LBC.LocalBuildConfig- -> PackageDescription- -> FlagAssignment- -> ComponentRequestedSpec- -> Compiler- -> Platform- -> ProgramDb- -> PackageDBStack- -> IO (LBC.LocalBuildConfig, LBC.PackageBuildDescr)-configurePackage cfg lbc0 pkg_descr00 flags enabled comp platform programDb0 packageDbs = do- let verbosity = fromFlag (configVerbosity cfg)-- -- add extra include/lib dirs as specified in cfg- pkg_descr0 = addExtraIncludeLibDirsFromConfigFlags pkg_descr00 cfg- -- TODO: it is not clear whether this adding these dirs is necessary- -- when we are directly stating from a PackageDescription (e.g. when- -- cabal-install has determined a PackageDescription, instead of rediscovering- -- when working with a GenericPackageDescription).- -- Could this function call be moved to the end of finalizeAndConfigurePackage- -- right before calling configurePackage?-- -- Configure certain external build tools, see below for which ones.- let requiredBuildTools = do- bi <- enabledBuildInfos pkg_descr0 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_descr0 bi- , not $ isInternal pkg_descr0 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_descr0 buildTool- ]- externBuildToolDeps ++ unknownBuildTools-- programDb1 <-- configureAllKnownPrograms (lessVerbose verbosity) programDb0- >>= configureRequiredPrograms verbosity requiredBuildTools-- (pkg_descr2, programDb2) <-- configurePkgconfigPackages verbosity pkg_descr0 programDb1 enabled-- let use_external_internal_deps =- case enabled of- OneComponentRequestedSpec{} -> True- ComponentRequestedSpec{} -> False-- -- 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_descr2)- let- installDirs =- combineInstallDirs- fromFlagOrDefault- defaultDirs- (configInstallDirs cfg)- lbc = lbc0{LBC.withPrograms = programDb2}- pbd =- LBC.PackageBuildDescr- { configFlags = cfg- , flagAssignment = flags- , componentEnabledSpec = enabled- , compiler = comp- , hostPlatform = platform- , localPkgDescr = pkg_descr2- , installDirTemplates = installDirs- , withPackageDB = packageDbs- , pkgDescrFile = Nothing- , extraCoverageFor = []- }-- debug verbosity $- "Finalized package description:\n"- ++ showPackageDescription pkg_descr2-- return (lbc, pbd)--finalizeAndConfigurePackage- :: ConfigFlags- -> LBC.LocalBuildConfig- -> GenericPackageDescription- -> Compiler- -> Platform- -> ComponentRequestedSpec- -> IO (LBC.LocalBuildConfig, LBC.PackageBuildDescr, PackageInfo)-finalizeAndConfigurePackage cfg lbc0 g_pkg_descr comp platform enabled = do- let verbosity = fromFlag (configVerbosity cfg)-- let programDb0 = LBC.withPrograms lbc0- -- What package database(s) to use- packageDbs :: PackageDBStack- packageDbs =- interpretPackageDbFlags- (fromFlag (configUserInstall cfg))- (configPackageDBs cfg)-- -- The InstalledPackageIndex of all installed packages- installedPackageSet :: InstalledPackageIndex <-- getInstalledPackages- (lessVerbose verbosity)- comp- packageDbs- programDb0-- -- The set of package names which are "shadowed" by internal- -- packages, and which component they map to- let internalPackageSet :: Set LibraryName- internalPackageSet = getInternalLibraries g_pkg_descr-- -- Some sanity checks related to dynamic/static linking.- when (fromFlag (configDynExe cfg) && fromFlag (configFullyStaticExe cfg)) $- dieWithException verbosity SanityCheckForDynamicStaticLinking-- -- 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 (dieWithException verbosity) return $- combinedConstraints- (configConstraints cfg)- (configDependencies cfg)- installedPackageSet-- let- promisedDepsSet = mkPromisedDepsSet (configPromisedDependencies cfg)- pkg_info =- PackageInfo- { internalPackageSet- , promisedDepsSet- , installedPackageSet- , requiredDepsMap- }-- -- 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.- let use_external_internal_deps = case enabled of- OneComponentRequestedSpec{} -> True- ComponentRequestedSpec{} -> False- ( pkg_descr0 :: PackageDescription- , flags :: FlagAssignment- ) <-- configureFinalizedPackage- verbosity- cfg- enabled- allConstraints- ( dependencySatisfiable- use_external_internal_deps- (fromFlagOrDefault False (configExactConfiguration cfg))- (fromFlagOrDefault False (configAllowDependingOnPrivateLibs cfg))- (packageName g_pkg_descr)- installedPackageSet- internalPackageSet- promisedDepsSet- requiredDepsMap- )- comp- platform- g_pkg_descr-- (lbc, pbd) <-- configurePackage- cfg- lbc0- pkg_descr0- flags- enabled- comp- platform- programDb0- packageDbs- return (lbc, pbd, pkg_info)--addExtraIncludeLibDirsFromConfigFlags- :: PackageDescription -> ConfigFlags -> PackageDescription-addExtraIncludeLibDirsFromConfigFlags pkg_descr cfg =- 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- }--finalCheckPackage- :: GenericPackageDescription- -> LBC.PackageBuildDescr- -> HookedBuildInfo- -> PackageInfo- -> IO ([PreExistingComponent], [PromisedComponent])-finalCheckPackage- g_pkg_descr- ( LBC.PackageBuildDescr- { configFlags = cfg- , localPkgDescr = pkg_descr- , compiler = comp- , hostPlatform = compPlatform- , componentEnabledSpec = enabled- }- )- hookedBuildInfo- (PackageInfo{internalPackageSet, promisedDepsSet, installedPackageSet, requiredDepsMap}) =- do- let verbosity = fromFlag (configVerbosity cfg)- use_external_internal_deps =- case enabled of- OneComponentRequestedSpec{} -> True- ComponentRequestedSpec{} -> False-- let cabalFileDir =- maybe "." takeDirectory $- flagToMaybe (configCabalFilePath cfg)- checkCompilerProblems verbosity comp pkg_descr enabled- checkPackageProblems- verbosity- cabalFileDir- g_pkg_descr- (updatePackageDescription hookedBuildInfo pkg_descr)- -- NB: we apply the HookedBuildInfo to check it is valid,- -- but we don't propagate it.- -- Other UserHooks must separately return it again, and we- -- will re-apply it each time.-- -- 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)) $- dieWithException verbosity $- UnsupportedLanguages (packageId g_pkg_descr) (compilerId comp) (map prettyShow langs)- let extlist =- nub $- concatMap- allExtensions- (enabledBuildInfos pkg_descr enabled)- let exts = unsupportedExtensions comp extlist- when (not (null exts)) $- dieWithException verbosity $- UnsupportedLanguageExtension (packageId g_pkg_descr) (compilerId comp) (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)) $- dieWithException verbosity $- CantFindForeignLibraries unsupportedFLibs-- -- 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.)- configureDependencies- verbosity- use_external_internal_deps- internalPackageSet- promisedDepsSet- installedPackageSet- requiredDepsMap- pkg_descr- enabled--configureComponents- :: LBC.LocalBuildConfig- -> LBC.PackageBuildDescr- -> PackageInfo- -> ([PreExistingComponent], [PromisedComponent])- -> IO LocalBuildInfo-configureComponents- lbc@(LBC.LocalBuildConfig{withPrograms = programDb})- pbd0@( LBC.PackageBuildDescr- { configFlags = cfg- , localPkgDescr = pkg_descr- , compiler = comp- , componentEnabledSpec = enabled- }- )- (PackageInfo{promisedDepsSet, installedPackageSet})- externalPkgDeps =- do- let verbosity = fromFlag (configVerbosity cfg)- use_external_internal_deps =- case enabled of- OneComponentRequestedSpec{} -> True- ComponentRequestedSpec{} -> 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.- ( 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-- let buildComponentsMap =- foldl'- ( \m clbi ->- Map.insertWith- (++)- (componentLocalName clbi)- [clbi]- m- )- Map.empty- buildComponents-- let cbd =- LBC.ComponentBuildDescr- { componentGraph = Graph.fromDistinctList buildComponents- , componentNameMap = buildComponentsMap- , promisedPkgs = promisedDepsSet- , installedPkgs = packageDependsIndex- }-- -- For whole-package configure, we determine the- -- extraCoverageFor of the main lib and sub libs here.- extraCoverageUnitIds = case enabled of- -- Whole package configure, add package libs- ComponentRequestedSpec{} -> mapMaybe mbCompUnitId buildComponents- -- Component configure, no need to do anything- OneComponentRequestedSpec{} -> []- mbCompUnitId LibComponentLocalBuildInfo{componentUnitId} = Just componentUnitId- mbCompUnitId _ = Nothing-- pbd =- pbd0- { LBC.extraCoverageFor = extraCoverageUnitIds- }-- lbd =- LBC.LocalBuildDescr- { packageBuildDescr = pbd- , componentBuildDescr = cbd- }-- lbi =- NewLocalBuildInfo- { localBuildDescr = lbd- , localBuildConfig = lbc- }-- when (LBC.relocatable $ LBC.withBuildOptions lbc) $- 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- )- $ dieWithException verbosity- $ ExpectedAbsoluteDirectory (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--mkPromisedDepsSet :: [GivenComponent] -> Map (PackageName, ComponentName) ComponentId-mkPromisedDepsSet comps = Map.fromList [((pn, CLibName ln), cid) | GivenComponent pn ln cid <- comps]---- | Adds the extra program paths from the flags provided to @configure@ as--- well as specified locations for certain known programs and their default--- arguments.-mkProgramDb :: ConfigFlags -> ProgramDb -> IO ProgramDb-mkProgramDb cfg initialProgramDb = do- programDb <-- modifyProgramSearchPath (getProgramSearchPath initialProgramDb ++) -- We need to have the paths to programs installed by build-tool-depends before all other paths- <$> prependProgramSearchPath (fromFlagOrDefault normal (configVerbosity cfg)) searchpath initialProgramDb- pure- . userSpecifyArgss (configProgramArgs cfg)- . userSpecifyPaths (configProgramPaths cfg)- $ programDb- where- searchpath = fromNubList (configProgramPathExtra cfg)---- Note. We try as much as possible to _prepend_ rather than postpend the extra-prog-path--- so that we can override the system path. However, in a v2-build, at this point, the "system" path--- has already been extended by both the built-tools-depends paths, as well as the program-path-extra--- so for v2 builds adding it again is entirely unnecessary. However, it needs to get added again _anyway_--- so as to take effect for v1 builds or standalone calls to Setup.hs--- In this instance, the lesser evil is to not allow it to override the system path.---- -------------------------------------------------------------------------------- Helper functions for configure---- | 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."- )---- | 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) $- dieWithException verbosity $- FlagsNotSpecified diffFlags---- | Create a PackageIndex that makes *any libraries that might be*--- defined internally to this package look like installed packages, in--- case an executable should refer to any of them as dependencies.------ It must be *any libraries that might be* defined rather than the--- actual definitions, because these depend on conditionals in the .cabal--- 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 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))---- | 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) ComponentId- -> Map (PackageName, ComponentName) InstalledPackageInfo- -- ^ required dependencies- -> (Dependency -> Bool)-dependencySatisfiable- use_external_internal_deps- exact_config- allow_private_deps- pn- installedPackageSet- packageLibraries- promisedDeps- 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- 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 =- not . null $ PackageIndex.lookupDependency installedPackageSet depName vr-- internalDepSatisfiable =- Set.isSubsetOf (NES.toSet sublibs) packageLibraries- 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---- | Finalize a generic package description.------ The workhorse is 'finalizePD'.-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- (pkg_descr, flags) <-- case finalizePD- (configConfigurationsFlags cfg)- enabled- satisfies- compPlatform- (compilerInfo comp)- allConstraints- pkg_descr0 of- Right r -> return r- Left missing ->- dieWithException verbosity $ EncounteredMissingDependency missing-- unless (nullFlagAssignment flags) $- info verbosity $- "Flags chosen: "- ++ intercalate- ", "- [ unFlagName fn ++ "=" ++ prettyShow value- | (fn, value) <- unFlagAssignment flags- ]-- return (pkg_descr, flags)---- | 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)- )- $ dieWithException verbosity CompilerDoesn'tSupportThinning- when- ( any (not . null . reexportedModules) (allLibraries pkg_descr)- && not (reexportedModulesSupported comp)- )- $ dieWithException verbosity CompilerDoesn'tSupportReexports- when- ( any (not . null . signatures) (allLibraries pkg_descr)- && not (backpackSupported comp)- )- $ dieWithException verbosity CompilerDoesn'tSupportBackpack---- | 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- 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- ]-- 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- ]-- promisedPkgDeps =- [ fpec- | (_, PromisedDependency fpec) <- allPkgDeps- ]-- when- ( not (null internalPkgDeps)- && not (newPackageDepsBehaviour pkg_descr)- )- $ dieWithException verbosity- $ LibraryWithinSamePackage internalPkgDeps- reportFailedDependencies verbosity failedDeps- reportSelectedDependencies verbosity allPkgDeps-- return (externalPkgDeps, promisedPkgDeps)---- | Select and apply coverage settings for the build based on the--- 'ConfigFlags' and 'Compiler'.-configureCoverage- :: Verbosity- -> ConfigFlags- -> Compiler- -> IO (LBC.BuildOptions -> LBC.BuildOptions)-configureCoverage verbosity cfg comp = do- let tryExeCoverage = fromFlagOrDefault False (configCoverage cfg)- tryLibCoverage =- fromFlagOrDefault- tryExeCoverage- (mappend (configCoverage cfg) (configLibCoverage cfg))- -- TODO: Should we also enforce something here on that --coverage-for cannot- -- include indefinite components or instantiations?- if coverageSupported comp- then do- let apply buildOptions =- buildOptions- { LBC.libCoverage = tryLibCoverage- , LBC.exeCoverage = tryExeCoverage- }- return apply- else do- let apply buildOptions =- buildOptions- { LBC.libCoverage = False- , LBC.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@--- from the specified 'ConfigFlags'. This may be useful for--- external Cabal tools which need to interact with Setup in--- a backwards-compatible way: the most predictable mechanism--- for enabling profiling across many legacy versions is to--- NOT use @--enable-profiling@ and use those two flags instead.------ Note that @--enable-executable-profiling@ also affects profiling--- of benchmarks and (non-detailed) test suites.-computeEffectiveProfiling :: ConfigFlags -> (Bool {- lib -}, Bool {- exe -})-computeEffectiveProfiling cfg =- -- The --profiling flag sets the default for both libs and exes,- -- but can be overridden by --library-profiling, or the old deprecated- -- --executable-profiling flag.- --- -- 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)---- | Select and apply profiling settings for the build based on the--- 'ConfigFlags' and 'Compiler'.-configureProfiling- :: Verbosity- -> ConfigFlags- -> Compiler- -> IO (LBC.BuildOptions -> LBC.BuildOptions)-configureProfiling verbosity cfg comp = do- let (tryLibProfiling, tryExeProfiling) = computeEffectiveProfiling 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]- )- return ProfDetailDefault- checkProfileLevel other = return other-- (exeProfWithoutLibProf, applyProfiling) <-- if profilingSupported comp- then do- exeLevel <- checkProfileLevel tryExeProfileLevel- libLevel <- checkProfileLevel tryLibProfileLevel- let apply buildOptions =- buildOptions- { LBC.withProfLib = tryLibProfiling- , LBC.withProfLibDetail = libLevel- , LBC.withProfExe = tryExeProfiling- , LBC.withProfExeDetail = exeLevel- }- return (tryExeProfiling && not tryLibProfiling, apply)- else do- let apply buildOptions =- buildOptions- { LBC.withProfLib = False- , LBC.withProfLibDetail = ProfDetailNone- , LBC.withProfExe = False- , LBC.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---- -------------------------------------------------------------------------------- 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--hackageUrl :: String-hackageUrl = "http://hackage.haskell.org/package/"--type ResolvedDependency = (Dependency, DependencyResolution)--data DependencyResolution- = -- | An external dependency from the package database, OR an- -- internal dependency which we are getting from the package- -- database.- 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- -- building its dependencies, if these dependencies need to be built later- -- again. For example, when launching a multi-repl,- -- 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)- -- 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---- | 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- 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-- 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'- PromisedDependency promisedComp -> packageId promisedComp- ]--reportFailedDependencies :: Verbosity -> [FailedDependency] -> IO ()-reportFailedDependencies _ [] = return ()-reportFailedDependencies verbosity failed =- dieWithException verbosity $ ReportFailedDependencies failed hackageUrl---- | 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 comp packageDBs progdb = do- when (null packageDBs) $- dieWithException verbosity NoPackageDatabaseSpecified-- 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- GHCJS -> GHCJS.getInstalledPackages verbosity packageDBs' progdb- UHC -> UHC.getInstalledPackages verbosity comp packageDBs' progdb- HaskellSuite{} ->- HaskellSuite.getInstalledPackages verbosity packageDBs' progdb- flv ->- dieWithException verbosity $ HowToFindInstalledPackages flv- where- packageDBExists (SpecificPackageDB path) = do- exists <- doesPathExist path- unless exists $- 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---- | Like 'getInstalledPackages', but for a single package DB.------ NB: Why isn't this always a fall through to 'getInstalledPackages'?--- 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 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---- | 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 comp packageDBs progdb platform =- case compilerFlavor comp of- 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- return []---- | Looks up the 'InstalledPackageInfo' of the given 'UnitId's from the--- 'PackageDBStack' in the 'LocalBuildInfo'.-getInstalledPackagesById- :: (Exception (VerboseException exception), Show exception, Typeable exception)- => Verbosity- -> LocalBuildInfo- -> (UnitId -> exception)- -- ^ Construct an exception that is thrown if a- -- unit-id is not found in the installed packages,- -- from the unit-id that is missing.- -> [UnitId]- -- ^ The unit ids to lookup in the installed packages- -> IO [InstalledPackageInfo]-getInstalledPackagesById verbosity LocalBuildInfo{compiler = comp, withPackageDB = pkgDb, withPrograms = progDb} mkException unitids = do- ipindex <- getInstalledPackages verbosity comp pkgDb progDb- mapM- ( \uid -> case lookupUnitId ipindex uid of- Nothing -> dieWithException verbosity (mkException uid)- Just ipkg -> return ipkg- )- unitids---- | 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- where- initialStack- | userInstall = [GlobalPackageDB, UserPackageDB]- | otherwise = [GlobalPackageDB]-- 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".------ When finalising the package we have to take into account the specific--- installed deps we've been given, and the finalise function expects--- constraints, so we have to translate these deps into version constraints.------ But after finalising we then have to make sure we pick the right specific--- deps in the end. So we still need to remember which installed packages to--- pick.-combinedConstraints- :: [PackageVersionConstraint]- -> [GivenComponent]- -- ^ installed dependencies- -> InstalledPackageIndex- -> Either- CabalException- ( [PackageVersionConstraint]- , Map (PackageName, ComponentName) InstalledPackageInfo- )-combinedConstraints constraints dependencies installedPackages = do- when (not (null badComponentIds)) $- Left $- CombinedConstraints (dispDependencies badComponentIds)-- -- TODO: we don't check that all dependencies are used!-- return (allConstraints, idConstraintMap)- where- allConstraints :: [PackageVersionConstraint]- 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- ]-- -- The dependencies along with the installed package info, if it exists- dependenciesPkgInfo :: [(PackageName, ComponentName, ComponentId, Maybe InstalledPackageInfo)]- dependenciesPkgInfo =- [ (pkgname, CLibName lname, cid, mpkg)- | GivenComponent pkgname lname cid <- dependencies- , let mpkg =- PackageIndex.lookupComponentId- installedPackages- cid- ]-- -- If we looked up a package specified by an installed package id- -- (i.e. someone has written a hash) and didn't find it then it's- -- an error.- badComponentIds =- [ (pkgname, cname, cid)- | (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- ]---- -------------------------------------------------------------------------------- Configuring program dependencies--configureRequiredPrograms- :: Verbosity- -> [LegacyExeDependency]- -> ProgramDb- -> IO ProgramDb-configureRequiredPrograms verbosity deps progdb =- foldM (configureRequiredProgram verbosity) progdb deps---- | Configure a required program, ensuring that it exists in the PATH--- (or where the user has specified the program must live) and making it--- available for use via the 'ProgramDb' interface. If the program is--- 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- (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'---- -------------------------------------------------------------------------------- Configuring pkg-config package dependencies--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')- where- allpkgs = concatMap pkgconfigDepends (enabledBuildInfos pkg_descr enabled)- pkgconfig =- getDbProgramOutput- (lessVerbose verbosity)- pkgConfigProgram- progdb-- requirePkg dep@(PkgconfigDependency pkgn range) = do- version <-- pkgconfig ["--modversion", pkg]- `catchIO` (\_ -> dieWithException verbosity $ PkgConfigNotFound pkg versionRequirement)- `catchExit` (\_ -> dieWithException verbosity $ PkgConfigNotFound pkg versionRequirement)- let trim = dropWhile isSpace . dropWhileEnd isSpace- let v = PkgconfigVersion (toUTF8BS $ trim version)- if not (withinPkgconfigVersionRange v range)- then dieWithException verbosity $ BadVersion pkg versionRequirement v- else info verbosity (depSatisfied v)- where- depSatisfied v =- "Dependency "- ++ prettyShow dep- ++ ": using version "- ++ prettyShow v-- versionRequirement- | isAnyPkgconfigVersion range = ""- | otherwise = " version " ++ prettyShow range-- pkg = unPkgconfigName pkgn-- -- Adds pkgconfig dependencies to the build info for a component- addPkgConfigBI compBI setCompBI comp = do- bi <- pkgconfigBuildInfo (pkgconfigDepends (compBI comp))- return $ setCompBI comp (compBI comp `mappend` bi)-- -- Adds pkgconfig dependencies to the build info for a library- addPkgConfigBILib = addPkgConfigBI libBuildInfo $- \lib bi -> lib{libBuildInfo = bi}-- -- Adds pkgconfig dependencies to the build info for an executable- addPkgConfigBIExe = addPkgConfigBI buildInfo $- \exe bi -> exe{buildInfo = bi}-- -- Adds pkgconfig dependencies to the build info for a test suite- addPkgConfigBITest = addPkgConfigBI testBuildInfo $- \test bi -> test{testBuildInfo = bi}-- -- Adds pkgconfig dependencies to the build info for a benchmark- addPkgConfigBIBench = addPkgConfigBI benchmarkBuildInfo $- \bench bi -> bench{benchmarkBuildInfo = bi}-- pkgconfigBuildInfo :: [PkgconfigDependency] -> IO BuildInfo- pkgconfigBuildInfo [] = return mempty- pkgconfigBuildInfo pkgdeps = do- let pkgs = nub [prettyShow pkg | PkgconfigDependency pkg _ <- pkgdeps]- ccflags <- pkgconfig ("--cflags" : 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.------ This can be used with the output from configuration programs like pkg-config--- and similar package-specific programs like mysql-config, freealut-config etc.--- For example:------ > ccflags <- getDbProgramOutput verbosity prog progdb ["--cflags"]--- > 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- (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''- }---- -------------------------------------------------------------------------------- Determining the compiler details--configCompilerAuxEx- :: ConfigFlags- -> IO (Compiler, Platform, ProgramDb)-configCompilerAuxEx cfg = do- programDb <- mkProgramDb cfg defaultProgramDb- configCompilerEx- (flagToMaybe $ configHcFlavor cfg)- (flagToMaybe $ configHcPath cfg)- (flagToMaybe $ configHcPkg cfg)- programDb- (fromFlag (configVerbosity cfg))--configCompilerEx- :: Maybe CompilerFlavor- -> Maybe FilePath- -> Maybe FilePath- -> ProgramDb- -> Verbosity- -> IO (Compiler, Platform, ProgramDb)-configCompilerEx Nothing _ _ _ verbosity = dieWithException verbosity UnknownCompilerException-configCompilerEx (Just hcFlavor) hcPath hcPkg progdb verbosity = do- (comp, maybePlatform, programDb) <- case hcFlavor of- 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- _ -> dieWithException verbosity UnknownCompilerException- return (comp, fromMaybe buildPlatform maybePlatform, programDb)---- -------------------------------------------------------------------------------- Testing C lib and header dependencies---- Try to build a test C program which includes every header and links every--- lib. If that fails, try to narrow it down by preprocessing (only) and linking--- with individual headers and libs. If none is the obvious culprit then give a--- generic error message.--- 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- then extraLibsStatic- else extraLibs-- 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 =- dieWithException verbosity NoWorkingGcc- explainErrors hdr libs =- dieWithException verbosity $ ExplainErrors hdr libs---- | 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 dir gpkg pkg = do- ioChecks <- checkPackageFiles verbosity pkg dir- let pureChecks = checkPackage gpkg- (errors, warnings) =- partitionEithers (M.mapMaybe classEW $ pureChecks ++ ioChecks)- if null errors- then traverse_ (warn verbosity) (map ppPackageCheck warnings)- else dieWithException verbosity $ CheckPackageProblems (map ppPackageCheck errors)- where- -- Classify error/warnings. Left: error, Right: warning.- classEW :: PackageCheck -> Maybe (Either PackageCheck PackageCheck)- classEW e@(PackageBuildImpossible _) = Just (Left e)- classEW w@(PackageBuildWarning _) = Just (Right w)- classEW (PackageDistSuspicious _) = Nothing- classEW (PackageDistSuspiciousWarn _) = Nothing- 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- ]- 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]) $- dieWithException verbosity $- NoOSSupport os- where- (Platform _ os) = hostPlatform lbi-- -- Check if the Compiler support relocatable builds- checkCompiler =- unless (compilerFlavor comp `elem` [GHC]) $- dieWithException verbosity $- NoCompilerSupport (show comp)- where- comp = compiler lbi-- -- Check if all the install dirs are relative to same prefix- packagePrefixRelative =- unless (relativeInstallDirs installDirs) $- dieWithException verbosity $- InstallDirsNotPrefixRelative (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- ]- )-- -- 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- 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- -- The @prefix@ itself must also be canonicalized because- -- canonicalizing @libdir@ may expand symlinks which would make- -- @prefix@ no longer being a prefix of @canonical libdir@,- -- while @canonical p@ could be a prefix of @canonical libdir@- p' <- canonicalizePath p- unless (p' `isPrefixOf` canonicalized) $- dieWithException verbosity $- LibDirDepsPrefixNotRelative libdir p- | 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)---- -------------------------------------------------------------------------------- Testing foreign library requirements--unsupportedForeignLibs :: Compiler -> Platform -> [ForeignLib] -> [String]-unsupportedForeignLibs 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"- ]- | otherwise = goGhcPlatform platform- 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)+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++-----------------------------------------------------------------------------++-- |+-- Module : Distribution.Simple.Configure+-- Copyright : Isaac Jones 2003-2005+-- License : BSD3+--+-- Maintainer : cabal-devel@haskell.org+-- Portability : portable+--+-- This deals with the /configure/ phase. It provides the 'configure' action+-- which is given the package description and configure flags. It then tries+-- to: configure the compiler; resolves any conditionals in the package+-- description; resolve the package dependencies; check if all the extensions+-- used by this package are supported by the compiler; check that all the build+-- tools are available (including version checks if appropriate); checks for+-- any required @pkg-config@ packages (updating the 'BuildInfo' with the+-- results)+--+-- Then based on all this it saves the info in the 'LocalBuildInfo' and writes+-- 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+ , configure_setupHooks+ , computePackageInfo+ , computePackageInfoFromIndex+ , configureFinal+ , runPreConfPackageHook+ , runPostConfPackageHook+ , runPreConfComponentHook+ , configurePackage+ , PackageInfo (..)+ , mkProgramDb+ , finalCheckPackage+ , configureComponents+ , mkPromisedDepsSet+ , combinedConstraints+ , writePersistBuildConfig+ , getConfigStateFile+ , getPersistBuildConfig+ , checkPersistBuildConfigOutdated+ , tryGetPersistBuildConfig+ , maybeGetPersistBuildConfig+ , findDistPref+ , findDistPrefOrDefault+ , getInternalLibraries+ , computeComponentId+ , computeCompatPackageKey+ , localBuildInfoFile+ , getInstalledPackages+ , getInstalledPackagesMonitorFiles+ , getInstalledPackagesById+ , getPackageDBContents+ , configCompiler+ , configCompilerEx+ , configCompilerAuxEx+ , configCompilerProgDb+ , computeEffectiveProfiling+ , adjustBuildOptions+ , buildOptionsAdjustmentWarnings+ , adjustBuildOptionsAndWarn+ , ccLdOptionsBuildInfo+ , checkForeignDeps+ , interpretPackageDbFlags+ , ConfigStateFileError (..)+ , tryGetConfigStateFile+ , platformDefines+ ) where++import Control.Monad+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.InstalledPackageInfo (InstalledPackageInfo)+import qualified Distribution.InstalledPackageInfo as IPI+import Distribution.Package+import Distribution.PackageDescription+import Distribution.PackageDescription.Check hiding (doesFileExist, listDirectory)+import Distribution.PackageDescription.Configuration+import Distribution.PackageDescription.PrettyPrint+import Distribution.Simple.BuildTarget+import Distribution.Simple.BuildToolDepends+import Distribution.Simple.BuildWay+import Distribution.Simple.Compiler+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.PackageIndex (InstalledPackageIndex, lookupUnitId)+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PreProcess+import Distribution.Simple.Program+import Distribution.Simple.Program.Db+ ( ProgramDb (..)+ , lookupProgramByName+ , modifyProgramSearchPath+ , prependProgramSearchPath+ , updateConfiguredProgs+ )+import Distribution.Simple.Setup.Common as Setup+import Distribution.Simple.Setup.Config as Setup+import Distribution.Simple.SetupHooks.Internal+ ( ConfigureHooks (..)+ , applyComponentDiffs+ , noConfigureHooks+ )+import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks+import Distribution.Simple.Utils+import Distribution.System+import Distribution.Types.ComponentRequestedSpec+import Distribution.Types.DependencySatisfaction (DependencySatisfaction (..))+import Distribution.Types.GivenComponent+import qualified Distribution.Types.LocalBuildConfig as LBC+import Distribution.Types.LocalBuildInfo+import Distribution.Types.MissingDependencyReason (MissingDependencyReason (..))+import Distribution.Types.PackageVersionConstraint+import Distribution.Utils.LogProgress+import Distribution.Utils.NubList+import Distribution.Utils.String (trim)+import Distribution.Verbosity+import Distribution.Version++import qualified Distribution.Simple.GHC as GHC+import qualified Distribution.Simple.GHCJS as GHCJS+import qualified Distribution.Simple.UHC as UHC++import Control.Exception+ ( try+ )+import qualified Data.ByteString as BS+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy.Char8 as BLC8+import Data.List+ ( intersect+ , stripPrefix+ , (\\)+ )+import qualified Data.List.NonEmpty as NEL+import qualified Data.Map as Map+import Distribution.Compat.Environment (lookupEnv)+import Distribution.Parsec+ ( simpleParsec+ )+import Distribution.Pretty+ ( defaultStyle+ , pretty+ , prettyShow+ )+import Distribution.Simple.Errors+import Distribution.Types.AnnotatedId+import Distribution.Utils.Path+import Distribution.Utils.Structured (structuredDecodeOrFailIO, structuredEncode)+import System.Directory+ ( canonicalizePath+ , createDirectoryIfMissing+ , doesFileExist+ , doesPathExist+ , listDirectory+ )+import System.FilePath+ ( isAbsolute+ )+import System.IO+ ( hClose+ , hPutStrLn+ )+import qualified System.Info+ ( compilerName+ , compilerVersion+ )+import Text.PrettyPrint+ ( Doc+ , char+ , hsep+ , quotes+ , renderStyle+ , 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+ = -- | No header found.+ ConfigStateFileNoHeader+ | -- | Incorrect header.+ ConfigStateFileBadHeader+ | -- | Cannot parse file contents.+ ConfigStateFileNoParse+ | -- | No file!+ ConfigStateFileMissing+ { cfgStateFileErrorCwd :: Maybe (SymbolicPath CWD (Dir Pkg))+ , cfgStateFileErrorFile :: SymbolicPath Pkg File+ }+ | -- | Mismatched version.+ ConfigStateFileBadVersion+ PackageIdentifier+ PackageIdentifier+ (Either ConfigStateFileError LocalBuildInfo)++-- | Format a 'ConfigStateFileError' as a user-facing error message.+dispConfigStateFileError :: ConfigStateFileError -> Doc+dispConfigStateFileError ConfigStateFileNoHeader =+ text "Saved package config file header is missing."+ <+> text "Re-run the 'Setup configure' command."+dispConfigStateFileError ConfigStateFileBadHeader =+ text "Saved package config file header is corrupt."+ <+> text "Re-run the 'Setup configure' command."+dispConfigStateFileError ConfigStateFileNoParse =+ text "Saved package config file is corrupt."+ <+> text "Re-run the 'Setup configure' command."+dispConfigStateFileError ConfigStateFileMissing{} =+ text "Run the 'Setup configure' command first."+dispConfigStateFileError (ConfigStateFileBadVersion oldCabal oldCompiler _) =+ text "Saved package config file is outdated:"+ $+$ badCabal+ $+$ badCompiler+ $+$ text "Re-run the 'Setup 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++instance Show ConfigStateFileError where+ 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+ :: Maybe (SymbolicPath CWD (Dir Pkg))+ -> SymbolicPath Pkg File+ -- ^ The file path of the @setup-config@ file.+ -> IO LocalBuildInfo+getConfigStateFile mbWorkDir setupConfigFile = do+ let filename = interpretSymbolicPath mbWorkDir setupConfigFile+ exists <- doesFileExist filename+ unless exists $ throwIO $ ConfigStateFileMissing mbWorkDir setupConfigFile+ -- 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+ :: Maybe (SymbolicPath CWD (Dir Pkg))+ -- ^ Working directory.+ -> SymbolicPath Pkg File+ -- ^ The file path of the @setup-config@ file.+ -> IO (Either ConfigStateFileError LocalBuildInfo)+tryGetConfigStateFile mbWorkDir = try . getConfigStateFile mbWorkDir++-- | Try to read the 'localBuildInfoFile'.+tryGetPersistBuildConfig+ :: Maybe (SymbolicPath CWD (Dir Pkg))+ -- ^ Working directory.+ -> SymbolicPath Pkg (Dir Dist)+ -- ^ The @dist@ directory path.+ -> IO (Either ConfigStateFileError LocalBuildInfo)+tryGetPersistBuildConfig mbWorkDir = try . getPersistBuildConfig mbWorkDir++-- | 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+ :: Maybe (SymbolicPath CWD (Dir Pkg))+ -- ^ Working directory.+ -> SymbolicPath Pkg (Dir Dist)+ -- ^ The @dist@ directory path.+ -> IO LocalBuildInfo+getPersistBuildConfig mbWorkDir distPref =+ getConfigStateFile mbWorkDir $ localBuildInfoFile distPref++-- | Try to read the 'localBuildInfoFile'.+maybeGetPersistBuildConfig+ :: Maybe (SymbolicPath CWD (Dir Pkg))+ -- ^ Working directory.+ -> SymbolicPath Pkg (Dir Dist)+ -- ^ The @dist@ directory path.+ -> IO (Maybe LocalBuildInfo)+maybeGetPersistBuildConfig mbWorkDir =+ fmap (either (const Nothing) Just) . tryGetPersistBuildConfig mbWorkDir++-- | After running configure, output the 'LocalBuildInfo' to the+-- 'localBuildInfoFile'.+writePersistBuildConfig+ :: Maybe (SymbolicPath CWD (Dir Pkg))+ -- ^ Working directory+ -> SymbolicPath Pkg (Dir Dist)+ -- ^ The @dist@ directory path.+ -> LocalBuildInfo+ -- ^ The 'LocalBuildInfo' to write.+ -> IO ()+writePersistBuildConfig mbWorkDir distPref lbi = do+ createDirectoryIfMissing False (i distPref)+ writeFileAtomic (i $ localBuildInfoFile distPref) $+ BLC8.unlines [showHeader pkgId, structuredEncode lbi]+ where+ i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path+ pkgId = localPackage lbi++-- | Identifier of the current Cabal package.+currentCabalId :: PackageIdentifier+currentCabalId = PackageIdentifier (mkPackageName "Cabal") cabalVersion++-- | Identifier of the current compiler package.+currentCompilerId :: PackageIdentifier+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 header = case BLC8.words header of+ [ "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')+ _ -> throwIO ConfigStateFileNoHeader++-- | Generate the @setup-config@ file header.+showHeader+ :: PackageIdentifier+ -- ^ The processed package.+ -> ByteString+showHeader pkgId =+ BLC8.unwords+ [ "Saved"+ , "package"+ , "config"+ , "for"+ , toUTF8LBS $ prettyShow pkgId+ , "written"+ , "by"+ , BLC8.pack $ prettyShow currentCabalId+ , "using"+ , BLC8.pack $ prettyShow currentCompilerId+ ]++-- | Check that localBuildInfoFile is up-to-date with respect to the+-- .cabal file.+checkPersistBuildConfigOutdated+ :: Maybe (SymbolicPath CWD (Dir Pkg))+ -> SymbolicPath Pkg (Dir Dist)+ -> SymbolicPath Pkg File+ -> IO Bool+checkPersistBuildConfigOutdated mbWorkDir distPref pkg_descr_file =+ i pkg_descr_file `moreRecentFile` i (localBuildInfoFile distPref)+ where+ i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path++-- | Get the path of @dist\/setup-config@.+localBuildInfoFile+ :: SymbolicPath Pkg (Dir Dist)+ -- ^ The @dist@ directory path.+ -> SymbolicPath Pkg File+localBuildInfoFile distPref = distPref </> makeRelativePathEx "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+ :: SymbolicPath Pkg (Dir Dist)+ -- ^ default \"dist\" prefix+ -> Setup.Flag (SymbolicPath Pkg (Dir Dist))+ -- ^ override \"dist\" prefix+ -> IO (SymbolicPath Pkg (Dir Dist))+findDistPref defDistPref overrideDistPref = do+ envDistPref <- parseEnvDistPref <$> lookupEnv "CABAL_BUILDDIR"+ return $ fromFlagOrDefault defDistPref (mappend envDistPref overrideDistPref)+ where+ parseEnvDistPref env =+ case env of+ Just distPref | not (null distPref) -> toFlag $ makeSymbolicPath distPref+ _ -> NoFlag++-- | 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 'defaultDistPref' is used. Call+-- 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 (SymbolicPath Pkg (Dir Dist))+ -- ^ override \"dist\" prefix+ -> IO (SymbolicPath Pkg (Dir Dist))+findDistPrefOrDefault = findDistPref defaultDistPref++-- | Perform the \"@.\/setup configure@\" action.+--+-- Returns the @LocalBuildInfo@, also writing it to the @setup-config@ file.+configure+ :: (GenericPackageDescription, HookedBuildInfo)+ -> ConfigFlags+ -> IO LocalBuildInfo+configure p cfg = do+ lbi <- configure_setupHooks noConfigureHooks p defaultVerbosityHandles cfg+ -- Write the 'LocalBuildInfo' to the @setup-config@ file.+ --+ -- NB: the shared 'configure_setupHooks'/'configureFinal' functions deliberately+ -- don't include this logic, as it is the responsibility of each top-level+ -- configure entry point.+ let distPref = fromFlag $ configDistPref cfg+ mbWorkDir = flagToMaybe $ configWorkingDir cfg+ writePersistBuildConfig mbWorkDir distPref lbi+ return lbi++-- | Run the @Cabal@ library configure phase.+--+-- NB: this function does /not/ persist the resulting 'LocalBuildInfo' to the+-- @setup-config@ file; that is the responsibility of callers.+configure_setupHooks+ :: ConfigureHooks+ -> (GenericPackageDescription, HookedBuildInfo)+ -> VerbosityHandles+ -> ConfigFlags+ -> IO LocalBuildInfo+configure_setupHooks+ confHooks@(ConfigureHooks{preConfPackageHook})+ (g_pkg_descr, hookedBuildInfo)+ verbHandles+ cfg = do+ (lbc0, comp, platform, enabledComps) <- preConfigurePackage verbHandles cfg g_pkg_descr++ -- Package-wide pre-configure hook+ lbc1 <-+ maybe+ (return lbc0)+ (runPreConfPackageHook cfg comp platform lbc0)+ preConfPackageHook++ -- Cabal package-wide configure+ (allConstraints, pkgInfo) <-+ computePackageInfo verbHandles cfg lbc1 g_pkg_descr comp+ (packageDbs, pkg_descr0, flags) <-+ finalizePackageDescription+ verbHandles+ cfg+ g_pkg_descr+ comp+ platform+ enabledComps+ allConstraints+ pkgInfo++ configureFinal+ verbHandles+ confHooks+ hookedBuildInfo+ cfg+ lbc1+ (g_pkg_descr, pkg_descr0)+ flags+ enabledComps+ comp+ platform+ packageDbs+ pkgInfo++configureFinal+ :: VerbosityHandles+ -> ConfigureHooks+ -> HookedBuildInfo+ -> ConfigFlags+ -> LBC.LocalBuildConfig+ -> (GenericPackageDescription, PackageDescription)+ -> FlagAssignment+ -> ComponentRequestedSpec+ -> Compiler+ -> Platform+ -> PackageDBStack+ -> PackageInfo+ -> IO LocalBuildInfo+configureFinal+ verbHandles+ (ConfigureHooks{postConfPackageHook, preConfComponentHook})+ hookedBuildInfo+ cfg+ lbc0+ (gpkgDescr, pkgDescr0)+ flags+ enabledComps+ comp+ platform+ packageDbs+ pkgInfo@PackageInfo+ { installedPackageSet = installedPkgSet+ , promisedDepsSet = promisedDeps+ } =+ do+ let verbosity = mkVerbosity verbHandles (fromFlag (configVerbosity cfg))++ -- Apply compiler capability checks to the incoming build options+ -- (idempotent).+ lbc1 <- do+ let opts = LBC.withBuildOptions lbc0+ opts' <- adjustBuildOptionsAndWarn verbosity comp (LBC.withPrograms lbc0) opts+ return lbc0{LBC.withBuildOptions = opts'}++ -- Cabal package-wide configure+ (lbc2, pbd2) <-+ configurePackage verbHandles cfg lbc1 pkgDescr0 flags enabledComps comp platform packageDbs++ -- Package-wide post-configure hook+ for_ postConfPackageHook $ runPostConfPackageHook lbc2 pbd2++ -- Per-component pre-configure hooks+ pkgDescr <- do+ let pkgDescr2 = LBC.localPkgDescr pbd2+ applyComponentDiffs+ verbosity+ (for preConfComponentHook . runPreConfComponentHook lbc2 pbd2)+ pkgDescr2+ let pbd3 = pbd2{LBC.localPkgDescr = pkgDescr}++ -- Cabal per-component configure+ finalCheckPackage verbHandles gpkgDescr pbd3 hookedBuildInfo++ let+ use_external_internal_deps =+ case enabledComps of+ OneComponentRequestedSpec{} -> True+ ComponentRequestedSpec{} -> False+ -- 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 <-+ selectDependencies+ verbosity+ use_external_internal_deps+ pkgInfo+ pkgDescr+ enabledComps+ configureComponents verbHandles lbc2 pbd3 installedPkgSet promisedDeps externalPkgDeps++runPreConfPackageHook+ :: ConfigFlags+ -> Compiler+ -> Platform+ -> LBC.LocalBuildConfig+ -> (SetupHooks.PreConfPackageInputs -> IO SetupHooks.PreConfPackageOutputs)+ -> IO LBC.LocalBuildConfig+runPreConfPackageHook cfg comp platform lbc0 pre_conf = do+ let programDb0 = LBC.withPrograms lbc0+ programDb0' = programDb0{unconfiguredProgs = Map.empty}+ input =+ SetupHooks.PreConfPackageInputs+ { SetupHooks.configFlags = cfg+ , SetupHooks.localBuildConfig = lbc0{LBC.withPrograms = programDb0'}+ , -- Unconfigured programs are not supplied to the hook,+ -- as these cannot be passed over a serialisation boundary+ -- (see the "Binary ProgramDb" instance).+ SetupHooks.compiler = comp+ , SetupHooks.platform = platform+ }+ SetupHooks.PreConfPackageOutputs+ { SetupHooks.buildOptions = opts1+ , SetupHooks.extraConfiguredProgs = progs1+ } <-+ pre_conf input+ -- The package-wide pre-configure hook returns a 'BuildOptions' that+ -- overrides the one it was passed in, as well as an update to+ -- the 'ProgramDb' in the form of new configured programs to add+ -- to the program database.+ return $+ lbc0+ { LBC.withBuildOptions = opts1+ , LBC.withPrograms =+ updateConfiguredProgs+ (`Map.union` progs1)+ programDb0+ }++runPostConfPackageHook+ :: LBC.LocalBuildConfig+ -> LBC.PackageBuildDescr+ -> (SetupHooks.PostConfPackageInputs -> IO ())+ -> IO ()+runPostConfPackageHook lbc2 pbd2 postConfPkg =+ let input =+ SetupHooks.PostConfPackageInputs+ { SetupHooks.localBuildConfig = lbc2+ , SetupHooks.packageBuildDescr = pbd2+ }+ in postConfPkg input++runPreConfComponentHook+ :: LBC.LocalBuildConfig+ -> LBC.PackageBuildDescr+ -> Component+ -> (SetupHooks.PreConfComponentInputs -> IO SetupHooks.PreConfComponentOutputs)+ -> IO SetupHooks.ComponentDiff+runPreConfComponentHook lbc pbd c hook = do+ let input =+ SetupHooks.PreConfComponentInputs+ { SetupHooks.localBuildConfig = lbc+ , SetupHooks.packageBuildDescr = pbd+ , SetupHooks.component = c+ }+ SetupHooks.PreConfComponentOutputs+ { SetupHooks.componentDiff = diff+ } <-+ hook input+ return diff++preConfigurePackage+ :: VerbosityHandles+ -> ConfigFlags+ -> GenericPackageDescription+ -> IO (LBC.LocalBuildConfig, Compiler, Platform, ComponentRequestedSpec)+preConfigurePackage verbHandles cfg g_pkg_descr = do+ let verbosity = mkVerbosity verbHandles (fromFlag $ configVerbosity cfg)++ -- 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 g_pkg_descr+ targets0 = configTargets cfg+ targets <- readBuildTargets verbosity flat_pkg_descr targets0+ -- TODO: bleat if you use the module/file syntax+ let targets' = [cname | BuildTargetComponent cname <- targets]+ case targets' of+ _ | null targets0 -> return Nothing+ [cname] -> return (Just cname)+ [] -> dieWithException verbosity NoValidComponent+ _ -> dieWithException verbosity ConfigureEitherSingleOrAll++ case mb_cname of+ Nothing -> setupMessage verbosity "Configuring" (packageId g_pkg_descr)+ Just cname ->+ setupMessage'+ verbosity+ "Configuring"+ (packageId g_pkg_descr)+ cname+ (Just (configInstantiateWith cfg))++ -- configCID is only valid for per-component configure+ when (isJust (flagToMaybe (configCID cfg)) && isNothing mb_cname) $+ dieWithException verbosity ConfigCIDValidForPreComponent++ -- Make a data structure describing what components are enabled.+ let enabled :: ComponentRequestedSpec+ enabled =+ maybe+ 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)+ }+ OneComponentRequestedSpec+ mb_cname+ -- Some sanity checks related to enabling components.+ when+ ( isJust mb_cname+ && (fromFlag (configTests cfg) || fromFlag (configBenchmarks cfg))+ )+ $ dieWithException verbosity SanityCheckForEnableComponents++ checkDeprecatedFlags verbosity cfg+ checkExactConfiguration verbosity g_pkg_descr cfg++ programDbPre <- mkProgramDb verbHandles cfg (configPrograms 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+ , programDb00 :: ProgramDb+ ) <-+ configCompilerEx+ (flagToMaybe (configHcFlavor cfg))+ (flagToMaybe (configHcPath cfg))+ (flagToMaybe (configHcPkg cfg))+ programDbPre+ (modifyVerbosityFlags lessVerbose verbosity)++ -- Where to build the package+ let builddir :: SymbolicPath Pkg (Dir Build) -- e.g. dist/build+ builddir = setupFlagsBuildDir $ configCommonFlags cfg+ mbWorkDir = flagToMaybe $ configWorkingDir cfg+ -- NB: create this directory now so that all configure hooks get+ -- to see it. (In practice, the Configure build-type needs it before+ -- the postConfPackageHook runs.)+ createDirectoryIfMissingVerbose (modifyVerbosityFlags lessVerbose verbosity) True $+ interpretSymbolicPath mbWorkDir builddir++ lbc <- computeLocalBuildConfig verbHandles cfg comp programDb00+ return (lbc, comp, compPlatform, enabled)++computeLocalBuildConfig+ :: VerbosityHandles+ -> ConfigFlags+ -> Compiler+ -> ProgramDb+ -> IO LBC.LocalBuildConfig+computeLocalBuildConfig verbHandles cfg comp programDb = do+ let common = configCommonFlags cfg+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ rawBuildOptions <- buildOptionsFromConfigFlags verbosity cfg comp+ buildOptions <- adjustBuildOptionsAndWarn verbosity comp programDb rawBuildOptions+ return $+ LBC.LocalBuildConfig+ { extraConfigArgs = []+ , -- Currently configure does not+ -- take extra args, but if it+ -- did they would go here.+ withPrograms = programDb+ , withBuildOptions = buildOptions+ }++-- | Compute a default 'LBC.BuildOptions' from 'ConfigFlags', applying+-- compiler-specific defaults but without compiler capability checks+-- (see 'adjustBuildOptionsAndWarn' for that).+buildOptionsFromConfigFlags+ :: Verbosity+ -> ConfigFlags+ -> Compiler+ -> IO LBC.BuildOptions+buildOptionsFromConfigFlags verbosity cfg comp = do+ 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).+ GHC.compilerBuildWay comp `notElem` [DynWay, ProfDynWay]+ CompilerId GHCJS _ ->+ not (GHCJS.isDynamic comp)+ _ -> False++ 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.compilerBuildWay comp == DynWay+ 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++ -- See doc/internal/bytecode-libraries.md for the end-to-end story.+ withBytecodeLib_ =+ fromFlagOrDefault False $ configBytecodeLib cfg++ withDynExe_ = fromFlag $ configDynExe cfg++ withFullyStaticExe_ = fromFlag $ configFullyStaticExe cfg++ setProfiling <- configureProfiling verbosity cfg comp++ setCoverage <- 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++ return $+ setCoverage . setProfiling $+ LBC.BuildOptions+ { withVanillaLib = fromFlag $ configVanillaLib cfg+ , withSharedLib = withSharedLib_+ , withStaticLib = withStaticLib_+ , withBytecodeLib = withBytecodeLib_+ , withDynExe = withDynExe_+ , withFullyStaticExe = withFullyStaticExe_+ , withProfLib = False+ , withProfLibShared = False+ , withProfLibDetail = ProfDetailNone+ , withProfExe = False+ , withProfExeDetail = ProfDetailNone+ , withOptimization = fromFlag $ configOptimization cfg+ , withDebugInfo = fromFlag $ configDebugInfo cfg+ , withGHCiLib = fromFlagOrDefault ghciLibByDefault (configGHCiLib cfg)+ , splitSections = fromFlagOrDefault False $ configSplitSections cfg+ , splitObjs = fromFlagOrDefault False $ configSplitObjs cfg+ , stripExes = strip_exe+ , stripLibs = strip_lib+ , exeCoverage = False+ , libCoverage = False+ , relocatable = fromFlagOrDefault False $ configRelocatable cfg+ }++-- | Adjust 'LBC.BuildOptions' to be compatible with the given 'Compiler' and+-- 'ProgramDb'.+--+-- See also 'adjustBuildOptionsAndWarn', which additionally informs the user+-- of unavailable requested features via warning messages.+adjustBuildOptions :: Compiler -> ProgramDb -> LBC.BuildOptions -> LBC.BuildOptions+adjustBuildOptions comp programDb opts =+ opts+ { LBC.splitSections = splitSec+ , LBC.splitObjs = splitObj+ , LBC.withGHCiLib = ghciLib+ , LBC.withBytecodeLib = bytecodeLib+ , LBC.exeCoverage = exeCov+ , LBC.libCoverage = libCov+ }+ where+ splitSec+ | not (LBC.splitSections opts) = False+ | GHC <- compilerFlavor comp+ , compilerVersion comp >= mkVersion [8, 0] =+ True+ | GHCJS <- compilerFlavor comp = True+ | otherwise = False -- not supported by this compiler+ splitObj+ | not (LBC.splitObjs opts) = False+ | splitSec = False -- mutually exclusive with split-sections+ | GHC <- compilerFlavor comp = True+ | GHCJS <- compilerFlavor comp = True+ | otherwise = False -- not supported by this compiler+ linkerSupportsRelocations :: Maybe Bool+ linkerSupportsRelocations =+ case lookupProgramByName "ld" programDb of+ Nothing -> Nothing+ Just ld ->+ case Map.lookup "Supports relocatable output" $ programProperties ld of+ Just "YES" -> Just True+ Just "NO" -> Just False+ _other -> Nothing++ ghciLib+ | LBC.withGHCiLib opts+ , not (fromMaybe True linkerSupportsRelocations) =+ False+ | otherwise = LBC.withGHCiLib opts++ bytecodeLib+ | LBC.withBytecodeLib opts+ , not (bytecodeArtifactsSupported comp) =+ False+ | otherwise = LBC.withBytecodeLib opts++ exeCov+ | LBC.exeCoverage opts, not (coverageSupported comp) = False+ | otherwise = LBC.exeCoverage opts++ libCov+ | LBC.libCoverage opts, not (coverageSupported comp) = False+ | otherwise = LBC.libCoverage opts++-- | Warnings to emit after downgrading 'LBC.BuildOptions' when the+-- compiler (or another toolchain program) doesn't support a requested feature.+buildOptionsAdjustmentWarnings+ :: Compiler+ -> LBC.BuildOptions+ -- ^ original options+ -> LBC.BuildOptions+ -- ^ adjusted options (result of 'adjustBuildOptions')+ -> [String]+buildOptionsAdjustmentWarnings comp opts0 opts1 =+ [ "This compiler does not support bytecode libraries; ignoring --enable-library-bytecode"+ | LBC.withBytecodeLib opts0+ , not (LBC.withBytecodeLib opts1)+ ]+ ++ [ "this compiler does not support --enable-split-sections; ignoring"+ | LBC.splitSections opts0+ , not (LBC.splitSections opts1)+ ]+ ++ [ if LBC.splitSections opts1+ then+ "--enable-split-sections and --enable-split-objs are mutually "+ ++ "exclusive; ignoring the latter"+ else "this compiler does not support --enable-split-objs; ignoring"+ | LBC.splitObjs opts0+ , not (LBC.splitObjs opts1)+ ]+ ++ [ "--enable-library-for-ghci is not supported with the current"+ ++ " linker; ignoring..."+ | LBC.withGHCiLib opts0+ , not (LBC.withGHCiLib opts1)+ ]+ ++ [ "The compiler "+ ++ showCompilerId comp+ ++ " does not support "+ ++ "program coverage. Program coverage has been disabled."+ | LBC.exeCoverage opts0+ , not (LBC.exeCoverage opts1)+ ]++-- | Like 'adjustBuildOptions', but includes warnings for downgraded+-- build options.+adjustBuildOptionsAndWarn+ :: Verbosity+ -> Compiler+ -> ProgramDb+ -> LBC.BuildOptions+ -> IO LBC.BuildOptions+adjustBuildOptionsAndWarn verbosity comp programDb opts0 = do+ let opts1 = adjustBuildOptions comp programDb opts0+ mapM_ (warn verbosity) (buildOptionsAdjustmentWarnings comp opts0 opts1)++ -- Also warn for any inconsistencies found in BuildOptions.+ when+ ( LBC.withDynExe opts1+ && not (LBC.withProfExe opts1)+ && not (LBC.withSharedLib opts1)+ )+ $ 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."+ when+ ( LBC.withDynExe opts1+ && LBC.withProfExe opts1+ && not (LBC.withProfLibShared opts1)+ )+ $ warn verbosity+ $ "Executables will use profiled dynamic linking, but a profiled shared library "+ ++ "is not being built. Linking will fail if any executables "+ ++ "depend on the library."+ return opts1++data PackageInfo = PackageInfo+ { internalPackageSet :: Set LibraryName+ -- ^ Libraries internal to the package+ , promisedDepsSet :: Map (PackageName, ComponentName) PromisedComponent+ -- ^ Collection of components that are promised, i.e. are not installed already.+ --+ -- See 'PromisedDependency' for more details.+ , installedPackageSet :: InstalledPackageIndex+ -- ^ Installed packages+ , requiredDepsMap :: Map (PackageName, ComponentName) InstalledPackageInfo+ -- ^ Packages for which we have been given specific deps to use+ }++configurePackage+ :: VerbosityHandles+ -> ConfigFlags+ -> LBC.LocalBuildConfig+ -> PackageDescription+ -> FlagAssignment+ -> ComponentRequestedSpec+ -> Compiler+ -> Platform+ -> PackageDBStack+ -> IO (LBC.LocalBuildConfig, LBC.PackageBuildDescr)+configurePackage verbHandles cfg lbc0 pkg_descr00 flags enabled comp platform packageDbs = do+ let common = configCommonFlags cfg+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ programDb0 = LBC.withPrograms lbc0++ -- add extra include/lib dirs as specified in cfg+ pkg_descr0 = addExtraIncludeLibDirsFromConfigFlags pkg_descr00 cfg+ -- TODO: it is not clear whether this adding these dirs is necessary+ -- when we are directly stating from a PackageDescription (e.g. when+ -- cabal-install has determined a PackageDescription, instead of rediscovering+ -- when working with a GenericPackageDescription).+ -- Could this function call be moved to the end of finalizeAndConfigurePackage+ -- right before calling configurePackage?++ -- Configure certain external build tools, see below for which ones.+ let requiredBuildTools+ -- If --ignore-build-tools is set, no build tool is required:+ | fromFlagOrDefault False $ configIgnoreBuildTools cfg =+ []+ | otherwise = do+ bi <- enabledBuildInfos pkg_descr0 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_descr0 bi+ , not $ isInternal pkg_descr0 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+ , isNothing (desugarBuildTool pkg_descr0 buildTool)+ ]+ externBuildToolDeps ++ unknownBuildTools++ programDb1 <-+ configureAllKnownPrograms (modifyVerbosityFlags lessVerbose verbosity) programDb0+ >>= configureRequiredPrograms verbosity requiredBuildTools++ (pkg_descr2, programDb2) <-+ configurePkgconfigPackages verbosity pkg_descr0 programDb1 enabled++ let use_external_internal_deps =+ case enabled of+ OneComponentRequestedSpec{} -> True+ ComponentRequestedSpec{} -> False++ -- Compute installation directory templates, based on user+ -- configuration.+ --+ -- TODO: Move this into a helper function.+ defaultDirs :: InstallDirTemplates <-+ defaultInstallDirs'+ use_external_internal_deps+ (compilerFlavor comp)+ (fromFlagOrDefault True (configUserInstall cfg))+ (hasLibs pkg_descr2)+ let+ installDirs =+ combineInstallDirs+ fromFlagOrDefault+ defaultDirs+ (configInstallDirs cfg)+ lbc = lbc0{LBC.withPrograms = programDb2}+ pbd =+ LBC.PackageBuildDescr+ { configFlags = cfg+ , flagAssignment = flags+ , componentEnabledSpec = enabled+ , compiler = comp+ , hostPlatform = platform+ , localPkgDescr = pkg_descr2+ , installDirTemplates = installDirs+ , withPackageDB = packageDbs+ , pkgDescrFile = Nothing+ , extraCoverageFor = []+ }++ debug verbosity $+ "Finalized package description:\n"+ ++ showPackageDescription pkg_descr2++ return (lbc, pbd)++computePackageInfo+ :: VerbosityHandles+ -> ConfigFlags+ -> LBC.LocalBuildConfig+ -> GenericPackageDescription+ -> Compiler+ -> IO ([PackageVersionConstraint], PackageInfo)+computePackageInfo verbHandles cfg lbc0 g_pkg_descr comp = do+ let common = configCommonFlags cfg+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ mbWorkDir = flagToMaybe $ setupWorkingDir common++ let programDb0 = LBC.withPrograms lbc0+ -- What package database(s) to use+ packageDbs :: PackageDBStack+ packageDbs =+ interpretPackageDbFlags+ (fromFlagOrDefault True (configUserInstall cfg))+ (configPackageDBs cfg)++ -- The InstalledPackageIndex of all installed packages+ installedPackageSet :: InstalledPackageIndex <-+ getInstalledPackages+ (modifyVerbosityFlags lessVerbose verbosity)+ comp+ mbWorkDir+ packageDbs+ programDb0+ computePackageInfoFromIndex verbHandles cfg g_pkg_descr installedPackageSet++-- | Like 'computePackageInfo' but takes a given 'InstalledPackageIndex'+-- instead of needing to query the @hc-pkg@ program to obtain it.+computePackageInfoFromIndex+ :: VerbosityHandles+ -> ConfigFlags+ -> GenericPackageDescription+ -> InstalledPackageIndex+ -> IO ([PackageVersionConstraint], PackageInfo)+computePackageInfoFromIndex verbHandles cfg g_pkg_descr installedPackageSet = do+ let common = configCommonFlags cfg+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ -- The set of package names which are "shadowed" by internal+ -- packages, and which component they map to+ internalPackageSet :: Set LibraryName+ internalPackageSet = getInternalLibraries g_pkg_descr++ -- Some sanity checks related to dynamic/static linking.+ when (fromFlag (configDynExe cfg) && fromFlag (configFullyStaticExe cfg)) $+ dieWithException verbosity SanityCheckForDynamicStaticLinking++ -- 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 (dieWithException verbosity) return $+ combinedConstraints+ (configConstraints cfg)+ (configDependencies cfg)+ installedPackageSet++ let+ promisedDepsSet = mkPromisedDepsSet (configPromisedDependencies cfg)+ return+ ( allConstraints+ , PackageInfo+ { internalPackageSet+ , promisedDepsSet+ , installedPackageSet+ , requiredDepsMap+ }+ )++finalizePackageDescription+ :: VerbosityHandles+ -> ConfigFlags+ -> GenericPackageDescription+ -> Compiler+ -> Platform+ -> ComponentRequestedSpec+ -> [PackageVersionConstraint]+ -> PackageInfo+ -> IO (PackageDBStack, PackageDescription, FlagAssignment)+finalizePackageDescription verbHandles cfg g_pkg_descr comp platform enabled allConstraints pkgInfo = do+ let common = configCommonFlags cfg+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)++ -- What package database(s) to use+ let packageDbs :: PackageDBStack+ packageDbs =+ interpretPackageDbFlags+ (fromFlagOrDefault True (configUserInstall cfg))+ (configPackageDBs 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.+ let use_external_internal_deps = case enabled of+ OneComponentRequestedSpec{} -> True+ ComponentRequestedSpec{} -> False+ ( pkg_descr0 :: PackageDescription+ , flags :: FlagAssignment+ ) <-+ finalizePackageDescription2+ verbosity+ cfg+ enabled+ allConstraints+ ( dependencySatisfiable+ use_external_internal_deps+ (fromFlagOrDefault False (configExactConfiguration cfg))+ (fromFlagOrDefault False (configAllowDependingOnPrivateLibs cfg))+ (packageName g_pkg_descr)+ pkgInfo+ )+ comp+ platform+ g_pkg_descr+ return (packageDbs, pkg_descr0, flags)++addExtraIncludeLibDirsFromConfigFlags+ :: PackageDescription -> ConfigFlags -> PackageDescription+addExtraIncludeLibDirsFromConfigFlags pkg_descr cfg =+ 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+ }++finalCheckPackage+ :: VerbosityHandles+ -> GenericPackageDescription+ -> LBC.PackageBuildDescr+ -> HookedBuildInfo+ -> IO ()+finalCheckPackage+ verbHandles+ g_pkg_descr+ ( LBC.PackageBuildDescr+ { configFlags = cfg+ , localPkgDescr = pkg_descr+ , compiler = comp+ , hostPlatform = compPlatform+ , componentEnabledSpec = enabled+ }+ )+ hookedBuildInfo =+ do+ let common = configCommonFlags cfg+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ cabalFileDir = packageRoot common++ checkCompilerProblems verbosity comp pkg_descr enabled+ checkPackageProblems+ verbosity+ cabalFileDir+ g_pkg_descr+ (updatePackageDescription hookedBuildInfo pkg_descr)+ -- NB: we apply the HookedBuildInfo to check it is valid,+ -- but we don't propagate it.+ -- Other UserHooks must separately return it again, and we+ -- will re-apply it each time.++ -- Check languages and extensions+ -- TODO: Move this into a helper function.+ let langlist =+ ordNub $+ mapMaybe defaultLanguage (enabledBuildInfos pkg_descr enabled)+ let langs = unsupportedLanguages comp langlist+ unless (null langs) $+ dieWithException verbosity $+ UnsupportedLanguages (packageId pkg_descr) (compilerId comp) (map prettyShow langs)+ let extlist =+ ordNub $+ concatMap+ allExtensions+ (enabledBuildInfos pkg_descr enabled)+ let exts = unsupportedExtensions comp extlist+ unless (null exts) $+ dieWithException verbosity $+ UnsupportedLanguageExtension (packageId pkg_descr) (compilerId comp) (map prettyShow exts)++ -- Check foreign library build requirements+ let flibs = [flib | CFLib flib <- enabledComponents pkg_descr enabled]+ let unsupportedFLibs = unsupportedForeignLibs comp compPlatform flibs+ unless (null unsupportedFLibs) $+ dieWithException verbosity $+ CantFindForeignLibraries unsupportedFLibs++configureComponents+ :: VerbosityHandles+ -> LBC.LocalBuildConfig+ -> LBC.PackageBuildDescr+ -> InstalledPackageIndex+ -> Map (PackageName, ComponentName) PromisedComponent+ -> ([PreExistingComponent], [ConfiguredPromisedComponent])+ -> IO LocalBuildInfo+configureComponents+ verbHandles+ lbc@(LBC.LocalBuildConfig{withPrograms = programDb})+ pbd0@( LBC.PackageBuildDescr+ { configFlags = cfg+ , localPkgDescr = pkg_descr+ , compiler = comp+ , componentEnabledSpec = enabled+ }+ )+ installedPackageSet+ promisedDepsSet+ externalPkgDeps =+ do+ let common = configCommonFlags cfg+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ use_external_internal_deps =+ case enabled of+ OneComponentRequestedSpec{} -> True+ ComponentRequestedSpec{} -> 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.+ ( 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++ let buildComponentsMap =+ foldl'+ ( \m clbi ->+ Map.insertWith+ (++)+ (componentLocalName clbi)+ [clbi]+ m+ )+ Map.empty+ buildComponents++ let cbd =+ LBC.ComponentBuildDescr+ { componentGraph = Graph.fromDistinctList buildComponents+ , componentNameMap = buildComponentsMap+ , promisedPkgs = promisedDepsSet+ , installedPkgs = packageDependsIndex+ }++ -- For whole-package configure, we determine the+ -- extraCoverageFor of the main lib and sub libs here.+ extraCoverageUnitIds = case enabled of+ -- Whole package configure, add package libs+ ComponentRequestedSpec{} -> mapMaybe mbCompUnitId buildComponents+ -- Component configure, no need to do anything since+ -- extra-coverage-for will be passed for all other components that+ -- should be covered.+ OneComponentRequestedSpec{} -> []+ mbCompUnitId LibComponentLocalBuildInfo{componentUnitId} = Just componentUnitId+ mbCompUnitId _ = Nothing++ pbd =+ pbd0+ { LBC.extraCoverageFor = extraCoverageUnitIds+ }++ lbd =+ LBC.LocalBuildDescr+ { packageBuildDescr = pbd+ , componentBuildDescr = cbd+ }++ lbi =+ NewLocalBuildInfo+ { localBuildDescr = lbd+ , localBuildConfig = lbc+ }++ when (LBC.relocatable $ LBC.withBuildOptions lbc) $+ checkRelocatable verbosity pkg_descr lbi++ when (LBC.withDynExe $ LBC.withBuildOptions lbc) $+ checkSharedExes verbosity 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+ )+ $ dieWithException verbosity+ $ ExpectedAbsoluteDirectory (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 "Bytecode Libraries" (bytecodelibdir dirs) (bytecodelibdir 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++mkPromisedDepsSet :: [PromisedComponent] -> Map (PackageName, ComponentName) PromisedComponent+mkPromisedDepsSet comps = Map.fromList [((packageName pn, CLibName ln), p) | p@(PromisedComponent pn ln _) <- comps]++-- | Adds the extra program paths from the flags provided to @configure@ as+-- well as specified locations for certain known programs and their default+-- arguments.+mkProgramDb :: VerbosityHandles -> ConfigFlags -> ProgramDb -> IO ProgramDb+mkProgramDb verbHandles cfg initialProgramDb = do+ programDb <-+ modifyProgramSearchPath (getProgramSearchPath initialProgramDb ++) -- We need to have the paths to programs installed by build-tool-depends before all other paths+ <$> prependProgramSearchPath verbosity searchpath [] initialProgramDb+ pure+ . userSpecifyArgss (configProgramArgs cfg)+ . userSpecifyPaths (configProgramPaths cfg)+ $ programDb+ where+ verbosity = mkVerbosity verbHandles $ fromFlagOrDefault normal (configVerbosity cfg)+ searchpath = fromNubList (configProgramPathExtra cfg)++-- Note. We try as much as possible to _prepend_ rather than postpend the extra-prog-path+-- so that we can override the system path. However, in a v2-build, at this point, the "system" path+-- has already been extended by both the built-tools-depends paths, as well as the program-path-extra+-- so for v2 builds adding it again is entirely unnecessary. However, it needs to get added again _anyway_+-- so as to take effect for v1 builds or standalone calls to Setup.hs+-- In this instance, the lesser evil is to not allow it to override the system path.++-- -----------------------------------------------------------------------------+-- Helper functions for configure++-- | 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."+ )++-- | 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+ unless (null diffFlags) $+ dieWithException verbosity $+ FlagsNotSpecified diffFlags++-- | Create a PackageIndex that makes *any libraries that might be*+-- defined internally to this package look like installed packages, in+-- case an executable should refer to any of them as dependencies.+--+-- It must be *any libraries that might be* defined rather than the+-- actual definitions, because these depend on conditionals in the .cabal+-- 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 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))++-- | 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+ -> PackageInfo+ -> (Dependency -> DependencySatisfaction)+dependencySatisfiable+ use_external_internal_deps+ exact_config+ allow_private_deps+ pn+ PackageInfo+ { internalPackageSet = packageLibraries+ , promisedDepsSet = promisedDeps+ , installedPackageSet+ , 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+ 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++ let depComponentName =+ CLibName $ LSubLibName $ packageNameToUnqualComponentName depName+ invisibleLibraries = NES.filter (not . visible) sublibs+ in if sublibs == mainLibSet && Map.member (pn, depComponentName) requiredDepsMap+ then Satisfied+ else case nonEmpty $ Set.toList invisibleLibraries of+ Nothing -> Satisfied+ Just invisibleLibraries' -> Unsatisfied $ MissingLibrary invisibleLibraries'+ | 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 =+ let allVersions = PackageIndex.lookupPackageName installedPackageSet depName+ eligibleVersions =+ [ version+ | (version, _infos) <- PackageIndex.eligibleDependencies allVersions+ ]+ in if null $ PackageIndex.matchingDependencies vr allVersions+ then+ if null eligibleVersions+ then Unsatisfied MissingPackage+ else Unsatisfied $ WrongVersion eligibleVersions+ else Satisfied++ internalDepSatisfiable =+ let missingLibraries = NES.toSet sublibs `Set.difference` packageLibraries+ in case nonEmpty $ Set.toList missingLibraries of+ Nothing -> Satisfied+ Just missingLibraries' -> Unsatisfied $ MissingLibrary missingLibraries'++ internalDepSatisfiableExternally =+ -- TODO: Might need to propagate information on which versions _are_ available, if any...+ let missingLibraries =+ NES.filter (null . PackageIndex.lookupInternalDependency installedPackageSet pn vr) sublibs+ in case nonEmpty $ Set.toList missingLibraries of+ Nothing -> Satisfied+ Just missingLibraries' -> Unsatisfied $ MissingLibrary missingLibraries'++ -- 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'.+finalizePackageDescription2+ :: Verbosity+ -> ConfigFlags+ -> ComponentRequestedSpec+ -> [PackageVersionConstraint]+ -> (Dependency -> DependencySatisfaction)+ -- ^ tests if a dependency is satisfiable.+ -- Might say it's satisfiable even when not.+ -> Compiler+ -> Platform+ -> GenericPackageDescription+ -> IO (PackageDescription, FlagAssignment)+finalizePackageDescription2+ verbosity+ cfg+ enabled+ allConstraints+ satisfies+ comp+ compPlatform+ pkg_descr0 = do+ (pkg_descr, flags) <-+ case finalizePD+ (configConfigurationsFlags cfg)+ enabled+ satisfies+ compPlatform+ (compilerInfo comp)+ allConstraints+ pkg_descr0 of+ Right r -> return r+ Left missing ->+ dieWithException verbosity $ EncounteredMissingDependency missing++ unless (nullFlagAssignment flags) $+ info verbosity $+ "Flags chosen: "+ ++ intercalate+ ", "+ [ unFlagName fn ++ "=" ++ prettyShow value+ | (fn, value) <- unFlagAssignment flags+ ]++ return (pkg_descr, flags)++-- | 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)+ )+ $ dieWithException verbosity CompilerDoesn'tSupportThinning+ when+ ( any (not . null . reexportedModules) (allLibraries pkg_descr)+ && not (reexportedModulesSupported comp)+ )+ $ dieWithException verbosity CompilerDoesn'tSupportReexports+ when+ ( any (not . null . signatures) (allLibraries pkg_descr)+ && not (backpackSupported comp)+ )+ $ dieWithException verbosity CompilerDoesn'tSupportBackpack++-- | Select dependencies for the package.+selectDependencies+ :: Verbosity+ -> UseExternalInternalDeps+ -> PackageInfo+ -> PackageDescription+ -> ComponentRequestedSpec+ -> IO ([PreExistingComponent], [ConfiguredPromisedComponent])+selectDependencies+ verbosity+ use_external_internal_deps+ pkgInfo+ pkg_descr+ enableSpec = do+ let failedDeps :: [FailedDependency]+ allPkgDeps :: [ResolvedDependency]+ (failedDeps, allPkgDeps) =+ partitionEithers $+ concat+ [ fmap (dep,) <$> status+ | dep <- enabledBuildDepends pkg_descr enableSpec+ , let status =+ selectDependency+ (package pkg_descr)+ pkgInfo+ 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+ ]++ promisedPkgDeps =+ [ fpec+ | (_, PromisedDependency fpec) <- allPkgDeps+ ]++ when+ ( not (null internalPkgDeps)+ && not (newPackageDepsBehaviour pkg_descr)+ )+ $ dieWithException verbosity+ $ LibraryWithinSamePackage internalPkgDeps+ reportFailedDependencies verbosity failedDeps+ reportSelectedDependencies verbosity allPkgDeps++ return (externalPkgDeps, promisedPkgDeps)++-- | Select and apply coverage settings for the build based on the+-- 'ConfigFlags' and 'Compiler'.+configureCoverage+ :: Verbosity+ -> ConfigFlags+ -> Compiler+ -> IO (LBC.BuildOptions -> LBC.BuildOptions)+configureCoverage verbosity cfg comp = do+ let tryExeCoverage = fromFlagOrDefault False (configCoverage cfg)+ tryLibCoverage =+ fromFlagOrDefault+ tryExeCoverage+ (mappend (configCoverage cfg) (configLibCoverage cfg))+ -- TODO: Should we also enforce something here on that --coverage-for cannot+ -- include indefinite components or instantiations?+ if coverageSupported comp+ then do+ let apply buildOptions =+ buildOptions+ { LBC.libCoverage = tryLibCoverage+ , LBC.exeCoverage = tryExeCoverage+ }+ return apply+ else do+ let apply buildOptions =+ buildOptions+ { LBC.libCoverage = False+ , LBC.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@+-- from the specified 'ConfigFlags'. This may be useful for+-- external Cabal tools which need to interact with Setup in+-- a backwards-compatible way: the most predictable mechanism+-- for enabling profiling across many legacy versions is to+-- NOT use @--enable-profiling@ and use those two flags instead.+--+-- Note that @--enable-executable-profiling@ also affects profiling+-- of benchmarks and (non-detailed) test suites.+computeEffectiveProfiling :: ConfigFlags -> (Bool {- lib vanilla-}, Bool {- lib shared -}, Bool {- exe -})+computeEffectiveProfiling cfg =+ -- The --profiling flag sets the default for both libs and exes,+ -- but can be overridden by --library-profiling, or the old deprecated+ -- --executable-profiling flag.+ --+ -- The --profiling-detail and --library-profiling-detail flags behave+ -- similarly+ let dynamicExe = fromFlagOrDefault False (configDynExe cfg)+ tryExeProfiling =+ fromFlagOrDefault+ False+ (mappend (configProf cfg) (configProfExe cfg))+ tryLibProfiling =+ fromFlagOrDefault+ (tryExeProfiling && not dynamicExe)+ (configProfLib cfg)+ tryLibProfilingShared =+ fromFlagOrDefault+ (tryExeProfiling && dynamicExe)+ (configProfShared cfg)+ in (tryLibProfiling, tryLibProfilingShared, tryExeProfiling)++-- | Select and apply profiling settings for the build based on the+-- 'ConfigFlags' and 'Compiler'.+configureProfiling+ :: Verbosity+ -> ConfigFlags+ -> Compiler+ -> IO (LBC.BuildOptions -> LBC.BuildOptions)+configureProfiling verbosity cfg comp = do+ let (tryLibProfiling, tryLibProfilingShared, tryExeProfiling) = computeEffectiveProfiling 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]+ )+ return ProfDetailDefault+ checkProfileLevel other = return other++ applyProfiling <-+ if profilingSupported comp && (profilingVanillaSupportedOrUnknown comp || profilingDynamicSupportedOrUnknown comp)+ then do+ exeLevel <- checkProfileLevel tryExeProfileLevel+ libLevel <- checkProfileLevel tryLibProfileLevel+ let apply buildOptions =+ buildOptions+ { LBC.withProfLib = tryLibProfiling+ , LBC.withProfLibDetail = libLevel+ , LBC.withProfExe = tryExeProfiling+ , LBC.withProfExeDetail = exeLevel+ }+ let compilerSupportsProfilingDynamic = profilingDynamicSupportedOrUnknown comp+ apply2 <-+ if compilerSupportsProfilingDynamic+ then -- Case 1: We support profiled shared libraries so turn on shared profiling+ -- libraries if the user asked for it.+ return $ \buildOptions -> apply buildOptions{LBC.withProfLibShared = tryLibProfilingShared}+ else -- Case 2: Compiler doesn't support profiling shared so turn them off+ do+ -- If we wanted to enable profiling shared libraries.. tell the+ -- user we couldn't.+ when (profilingVanillaSupportedOrUnknown comp && tryLibProfilingShared) $+ warn+ verbosity+ ( "The compiler "+ ++ showCompilerId comp+ ++ " does not support "+ ++ "profiling shared objects. Static profiled objects "+ ++ "will be built."+ )+ return $ \buildOptions ->+ let original_options = apply buildOptions+ in original_options+ { LBC.withProfLibShared = False+ , LBC.withProfLib = profilingVanillaSupportedOrUnknown comp && (tryLibProfilingShared || LBC.withProfLib original_options)+ , LBC.withDynExe = if LBC.withProfExe original_options then False else LBC.withDynExe original_options+ }++ when (tryExeProfiling && not (tryLibProfiling || tryLibProfilingShared)) $ do+ warn+ verbosity+ ( "Executables will be built with profiling, but library "+ ++ "profiling is disabled. Linking will fail if any executables "+ ++ "depend on the library."+ )+ return apply2+ else do+ let apply buildOptions =+ buildOptions+ { LBC.withProfLib = False+ , LBC.withProfLibShared = False+ , LBC.withProfLibDetail = ProfDetailNone+ , LBC.withProfExe = False+ , LBC.withProfExeDetail = ProfDetailNone+ }+ when (tryExeProfiling || tryLibProfiling) $+ warn+ verbosity+ ( "The compiler "+ ++ showCompilerId comp+ ++ " does not support "+ ++ "profiling. Profiling has been disabled."+ )+ return apply++ return applyProfiling++-- -----------------------------------------------------------------------------+-- 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++hackageUrl :: String+hackageUrl = "http://hackage.haskell.org/package/"++type ResolvedDependency = (Dependency, DependencyResolution)++data DependencyResolution+ = -- | An external dependency from the package database, OR an+ -- internal dependency which we are getting from the package+ -- database.+ 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+ -- building its dependencies, if these dependencies need to be built later+ -- again. For example, when launching a multi-repl,+ -- 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 ConfiguredPromisedComponent+ | -- | 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 Pkg' typeclass.)+ InternalDependency PackageId++-- | Test for a package dependency and record the version we have installed.+selectDependency+ :: PackageId+ -- ^ Package id of current package+ -> PackageInfo+ -> UseExternalInternalDeps+ -- ^ Are we configuring a+ -- single component?+ -> Dependency+ -> [Either FailedDependency DependencyResolution]+selectDependency+ pkgid+ ( PackageInfo+ { internalPackageSet = internalIndex+ , promisedDepsSet = promisedIndex+ , installedPackageSet = 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 pc <- Map.lookup (dep_pkgname, CLibName lib) promisedIndex =+ return $ PromisedDependency (ConfiguredPromisedComponent dep_pkgname (AnnotatedId (promisedComponentPackage pc) (CLibName lib) (promisedComponentId pc)))+ 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 pc <- Map.lookup (dep_pkgname, CLibName lib) promisedIndex =+ return $ PromisedDependency (ConfiguredPromisedComponent dep_pkgname (AnnotatedId (promisedComponentPackage pc) (CLibName lib) (promisedComponentId pc)))+ 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'+ PromisedDependency promisedComp -> packageId promisedComp+ ]++reportFailedDependencies :: Verbosity -> [FailedDependency] -> IO ()+reportFailedDependencies _ [] = return ()+reportFailedDependencies verbosity failed =+ dieWithException verbosity $ ReportFailedDependencies failed hackageUrl++-- | 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+ -> Maybe (SymbolicPath CWD (Dir from))+ -> PackageDBStackX (SymbolicPath from (Dir PkgDB))+ -- ^ The stack of package databases.+ -> ProgramDb+ -> IO InstalledPackageIndex+getInstalledPackages verbosity comp mbWorkDir packageDBs progdb = do+ when (null packageDBs) $+ dieWithException verbosity NoPackageDatabaseSpecified++ 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 mbWorkDir packageDBs' progdb+ GHCJS -> GHCJS.getInstalledPackages verbosity mbWorkDir packageDBs' progdb+ UHC -> UHC.getInstalledPackages verbosity comp mbWorkDir packageDBs' progdb+ flv ->+ dieWithException verbosity $ HowToFindInstalledPackages flv+ where+ packageDBExists (SpecificPackageDB path0) = do+ let path = interpretSymbolicPath mbWorkDir path0+ exists <- doesPathExist path+ unless exists $+ 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++-- | Like 'getInstalledPackages', but for a single package DB.+--+-- NB: Why isn't this always a fall through to 'getInstalledPackages'?+-- 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+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -> PackageDB+ -> ProgramDb+ -> IO InstalledPackageIndex+getPackageDBContents verbosity comp mbWorkDir packageDB progdb = do+ info verbosity "Reading installed packages..."+ case compilerFlavor comp of+ GHC -> GHC.getPackageDBContents verbosity mbWorkDir packageDB progdb+ GHCJS -> GHCJS.getPackageDBContents verbosity mbWorkDir packageDB progdb+ -- For other compilers, try to fall back on 'getInstalledPackages'.+ _ -> getInstalledPackages verbosity comp mbWorkDir [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+ -> Maybe (SymbolicPath CWD ('Dir from))+ -> PackageDBStackS from+ -> ProgramDb+ -> Platform+ -> IO [FilePath]+getInstalledPackagesMonitorFiles verbosity comp mbWorkDir packageDBs progdb platform =+ case compilerFlavor comp of+ GHC ->+ GHC.getInstalledPackagesMonitorFiles+ verbosity+ mbWorkDir+ platform+ progdb+ packageDBs+ other -> do+ warn verbosity $+ "don't know how to find change monitoring files for "+ ++ "the installed package databases for "+ ++ prettyShow other+ return []++-- | Looks up the 'InstalledPackageInfo' of the given 'UnitId's from the+-- 'PackageDBStack' in the 'LocalBuildInfo'.+getInstalledPackagesById+ :: Exception (VerboseException exception)+ => Verbosity+ -> LocalBuildInfo+ -> (UnitId -> exception)+ -- ^ Construct an exception that is thrown if a+ -- unit-id is not found in the installed packages,+ -- from the unit-id that is missing.+ -> [UnitId]+ -- ^ The unit ids to lookup in the installed packages+ -> IO [InstalledPackageInfo]+getInstalledPackagesById verbosity lbi@LocalBuildInfo{compiler = comp, withPackageDB = pkgDb, withPrograms = progDb} mkException unitids = do+ let mbWorkDir = mbWorkDirLBI lbi+ ipindex <- getInstalledPackages verbosity comp mbWorkDir pkgDb progDb+ mapM+ ( \uid -> case lookupUnitId ipindex uid of+ Nothing -> dieWithException verbosity (mkException uid)+ Just ipkg -> return ipkg+ )+ unitids++-- | 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 (PackageDBX fp)] -> PackageDBStackX fp+interpretPackageDbFlags userInstall specificDBs =+ extra initialStack specificDBs+ where+ initialStack+ | userInstall = [GlobalPackageDB, UserPackageDB]+ | otherwise = [GlobalPackageDB]++ 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".+--+-- When finalising the package we have to take into account the specific+-- installed deps we've been given, and the finalise function expects+-- constraints, so we have to translate these deps into version constraints.+--+-- But after finalising we then have to make sure we pick the right specific+-- deps in the end. So we still need to remember which installed packages to+-- pick.+combinedConstraints+ :: [PackageVersionConstraint]+ -> [GivenComponent]+ -- ^ installed dependencies+ -> InstalledPackageIndex+ -> Either+ CabalException+ ( [PackageVersionConstraint]+ , Map (PackageName, ComponentName) InstalledPackageInfo+ )+combinedConstraints constraints dependencies installedPackages = do+ unless (null badComponentIds) $+ Left $+ CombinedConstraints (dispDependencies badComponentIds)++ -- TODO: we don't check that all dependencies are used!++ return (allConstraints, idConstraintMap)+ where+ allConstraints :: [PackageVersionConstraint]+ 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+ ]++ -- The dependencies along with the installed package info, if it exists+ dependenciesPkgInfo :: [(PackageName, ComponentName, ComponentId, Maybe InstalledPackageInfo)]+ dependenciesPkgInfo =+ [ (pkgname, CLibName lname, cid, mpkg)+ | GivenComponent pkgname lname cid <- dependencies+ , let mpkg =+ PackageIndex.lookupComponentId+ installedPackages+ cid+ ]++ -- If we looked up a package specified by an installed package id+ -- (i.e. someone has written a hash) and didn't find it then it's+ -- an error.+ badComponentIds =+ [ (pkgname, cname, cid)+ | (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+ ]++-- -----------------------------------------------------------------------------+-- Configuring program dependencies++configureRequiredPrograms+ :: Verbosity+ -> [LegacyExeDependency]+ -> ProgramDb+ -> IO ProgramDb+configureRequiredPrograms verbosity deps progdb =+ foldM (configureRequiredProgram verbosity) progdb deps++-- | Configure a required program, ensuring that it exists in the PATH+-- (or where the user has specified the program must live) and making it+-- available for use via the 'ProgramDb' interface. If the program is+-- 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+ (LegacyExeDependency progName verRange) =+ case lookupProgramByName progName progdb of+ Just prog ->+ -- If the program has already been configured, use it+ -- (as long as the version is compatible).+ --+ -- Not doing so means falling back to the "simpleProgram" path below,+ -- which might fail if the program has custom logic to find a version+ -- (such as hsc2hs).+ let loc = locationPath $ programLocation prog+ in case programVersion prog of+ Nothing+ | verRange == anyVersion ->+ return progdb+ | otherwise ->+ dieWithException verbosity $!+ UnknownVersionDb (programId prog) verRange loc+ Just version+ | withinRange version verRange ->+ return progdb+ | otherwise ->+ dieWithException verbosity $!+ BadVersionDb (programId prog) version verRange loc+ Nothing ->+ -- Otherwise, try to configure it as a 'simpleProgram' automatically+ case lookupKnownProgram progName progdb of+ Nothing ->+ -- 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 pkg_descr progdb enabled+ | null allpkgs = return (pkg_descr, progdb)+ | otherwise = do+ (_, _, progdb') <-+ requireProgramVersion+ (modifyVerbosityFlags 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+ (modifyVerbosityFlags lessVerbose verbosity)+ pkgConfigProgram+ progdb++ requirePkg dep@(PkgconfigDependency pkgn range) = do+ version <-+ pkgconfig ["--modversion", pkg]+ `catchIO` (\_ -> dieWithException verbosity $ PkgConfigNotFound pkg versionRequirement)+ `catchExit` (\_ -> dieWithException verbosity $ PkgConfigNotFound pkg versionRequirement)+ let v = PkgconfigVersion (toUTF8BS $ trim version)+ if not (withinPkgconfigVersionRange v range)+ then dieWithException verbosity $ BadVersion pkg versionRequirement v+ else info verbosity (depSatisfied v)+ where+ depSatisfied v =+ "Dependency "+ ++ prettyShow dep+ ++ ": using version "+ ++ prettyShow v++ versionRequirement+ | isAnyPkgconfigVersion range = ""+ | otherwise = " version " ++ prettyShow range++ pkg = unPkgconfigName pkgn++ -- Adds pkgconfig dependencies to the build info for a component+ addPkgConfigBI compBI setCompBI comp = do+ bi <- pkgconfigBuildInfo (pkgconfigDepends (compBI comp))+ return $ setCompBI comp (compBI comp `mappend` bi)++ -- Adds pkgconfig dependencies to the build info for a library+ addPkgConfigBILib = addPkgConfigBI libBuildInfo $+ \lib bi -> lib{libBuildInfo = bi}++ -- Adds pkgconfig dependencies to the build info for an executable+ addPkgConfigBIExe = addPkgConfigBI buildInfo $+ \exe bi -> exe{buildInfo = bi}++ -- Adds pkgconfig dependencies to the build info for a test suite+ addPkgConfigBITest = addPkgConfigBI testBuildInfo $+ \test bi -> test{testBuildInfo = bi}++ -- Adds pkgconfig dependencies to the build info for a benchmark+ addPkgConfigBIBench = addPkgConfigBI benchmarkBuildInfo $+ \bench bi -> bench{benchmarkBuildInfo = bi}++ pkgconfigBuildInfo :: [PkgconfigDependency] -> IO BuildInfo+ pkgconfigBuildInfo [] = return mempty+ pkgconfigBuildInfo pkgdeps = do+ let pkgs = ordNub [prettyShow pkg | PkgconfigDependency pkg _ <- pkgdeps]+ ccflags <- pkgconfig ("--cflags" : 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.+--+-- This can be used with the output from configuration programs like pkg-config+-- and similar package-specific programs like mysql-config, freealut-config etc.+-- For example:+--+-- > ccflags <- getDbProgramOutput verbosity prog progdb ["--cflags"]+-- > 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+ (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags'+ extraLibsStatic' = filter ("-l" `isPrefixOf`) ldflags_static+ extraLibDirsStatic' = filter ("-L" `isPrefixOf`) ldflags_static+ in mempty+ { includeDirs = map (makeSymbolicPath . drop 2) includeDirs'+ , extraLibs = map (drop 2) extraLibs'+ , extraLibDirs = map (makeSymbolicPath . drop 2) extraLibDirs'+ , extraLibsStatic = map (drop 2) extraLibsStatic'+ , extraLibDirsStatic = map (makeSymbolicPath . drop 2) extraLibDirsStatic'+ , ccOptions = cflags'+ , ldOptions = ldflags''+ }++-- -----------------------------------------------------------------------------+-- Determining the compiler details++configCompilerAuxEx+ :: VerbosityHandles+ -> ConfigFlags+ -> IO (Compiler, Platform, ProgramDb)+configCompilerAuxEx verbHandles cfg = do+ programDb <- mkProgramDb verbHandles cfg defaultProgramDb+ let common = configCommonFlags cfg+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ configCompilerEx+ (flagToMaybe $ configHcFlavor cfg)+ (flagToMaybe $ configHcPath cfg)+ (flagToMaybe $ configHcPkg cfg)+ programDb+ verbosity++-- | Configure the compiler and associated programs such as @hc-pkg@, @haddock@+-- and toolchain program such as @ar@, @ld@.+configCompilerEx+ :: Maybe CompilerFlavor+ -> Maybe FilePath+ -- ^ user-specified @hc@ path (optional)+ -> Maybe FilePath+ -- ^ user-specified @hc-pkg@ path (optional)+ -> ProgramDb+ -> Verbosity+ -> IO (Compiler, Platform, ProgramDb)+configCompilerEx Nothing _ _ _ verbosity = dieWithException verbosity UnknownCompilerException+configCompilerEx (Just hcFlavor) hcPath hcPkg progdb verbosity = do+ (comp, maybePlatform, programDb) <- case hcFlavor of+ GHC -> GHC.configure verbosity hcPath hcPkg progdb+ GHCJS -> GHCJS.configure verbosity hcPath hcPkg progdb+ UHC -> UHC.configure verbosity hcPath progdb+ _ -> dieWithException verbosity UnknownCompilerException+ return (comp, fromMaybe buildPlatform maybePlatform, programDb)++-- | Configure the compiler ONLY.+configCompiler+ :: Maybe CompilerFlavor+ -> Maybe FilePath+ -- ^ user-specified @hc@ path (optional)+ -> ProgramDb+ -> Verbosity+ -> IO (Compiler, Platform, ProgramDb)+configCompiler mbFlavor hcPath progdb verbosity = do+ (comp, maybePlatform, programDb) <-+ case mbFlavor of+ Nothing -> dieWithException verbosity UnknownCompilerException+ Just hcFlavor ->+ case hcFlavor of+ GHC -> GHC.configureCompiler verbosity hcPath progdb+ GHCJS -> GHCJS.configureCompiler verbosity hcPath progdb+ UHC -> UHC.configure verbosity hcPath progdb+ _ -> dieWithException verbosity UnknownCompilerException+ return (comp, fromMaybe buildPlatform maybePlatform, programDb)++-- | Configure programs associated to the compiler, such as @hc-pkg@, @haddock@+-- and toolchain program such as @ar@, @ld@.+configCompilerProgDb+ :: Verbosity+ -> Compiler+ -> ProgramDb+ -- ^ program database containing the compiler+ -> Maybe FilePath+ -- ^ user-specified @hc-pkg@ path (optional)+ -> IO ProgramDb+configCompilerProgDb verbosity comp hcProgDb hcPkgPath = do+ case compilerFlavor comp of+ GHC -> GHC.compilerProgramDb verbosity comp hcProgDb hcPkgPath+ GHCJS -> GHCJS.compilerProgramDb verbosity comp hcProgDb hcPkgPath+ _ -> return hcProgDb++-- -----------------------------------------------------------------------------+-- Testing C lib and header dependencies++-- Try to build a test C program which includes every header and links every+-- lib. If that fails, try to narrow it down by preprocessing (only) and linking+-- with individual headers and libs. If none is the obvious culprit then give a+-- generic error message.+-- 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 (fmap getSymbolicPath . 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++ -- 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, issue a warning, because C compilers are+ -- not guaranteed to pick the correct one and there appears to be+ -- no way to control which is picked.+ --+ checkDuplicateHeaders = do+ let relIncDirs = filter (not . isAbsolute) (collectField (fmap getSymbolicPath . includeDirs))+ isHeader = isSuffixOf ".h"+ genHeaders <- for relIncDirs $ \dir ->+ fmap (dir </>) . filter isHeader+ <$> listDirectory (i (buildDir lbi) </> dir) `catchIO` (\_ -> return [])+ srcHeaders <- for relIncDirs $ \dir ->+ fmap (dir </>) . filter isHeader+ <$> listDirectory (baseDir </> dir) `catchIO` (\_ -> return [])+ let commonHeaders = concat genHeaders `intersect` concat srcHeaders+ for_ commonHeaders $ \hdr -> do+ warn verbosity $+ "Duplicate header found in "+ ++ (getSymbolicPath (buildDir lbi) </> hdr)+ ++ " and "+ ++ (baseDir </> hdr)+ ++ ". Which one the C compiler will use is unspecified."++ 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])++ common = configCommonFlags $ configFlags lbi+ baseDir = packageRoot common++ -- See Note [Symbolic paths] in Distribution.Utils.Path+ i = interpretSymbolicPathLBI lbi+ mbWorkDir = mbWorkDirLBI 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" ++ i (buildDir lbi </> makeRelativePathEx "autogen")]+ -- `configure' may generate headers in the build directory+ ++ [ "-I" ++ i (buildDir lbi </> unsafeCoerceSymbolicPath dir)+ | dir <- mapMaybe symbolicPathRelative_maybe $ ordNub (collectField includeDirs)+ ]+ -- we might also reference headers from the+ -- packages directory.+ ++ [ "-I" ++ baseDir </> getSymbolicPath dir+ | dir <- mapMaybe symbolicPathRelative_maybe $ ordNub (collectField includeDirs)+ ]+ ++ [ "-I" ++ dir+ | dir <- ordNub (collectField (fmap getSymbolicPath . includeDirs))+ , isAbsolute dir+ ]+ ++ ["-I" ++ baseDir]+ ++ 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" ++ getSymbolicPath 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 :: String -> [ProgArg] -> IO Bool+ builds program args =+ withTempFileCwd ".c" $ \cName cHnd ->+ withTempFileCwd "" $ \oNname oHnd ->+ do+ hPutStrLn cHnd program+ hClose cHnd+ hClose oHnd+ _ <-+ getDbProgramOutputCwd+ verbosity+ mbWorkDir+ gccProgram+ (withPrograms lbi)+ (getSymbolicPath cName : "-o" : getSymbolicPath oNname : args)+ return True+ `catchIO` (\_ -> return False)+ `catchExit` (\_ -> return False)++ explainErrors Nothing [] = return () -- should be impossible!+ explainErrors _ _+ | isNothing . lookupProgram gccProgram . withPrograms $ lbi =+ dieWithException verbosity NoWorkingGcc+ explainErrors hdr libs =+ dieWithException verbosity $ ExplainErrors hdr libs++-- | 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 dir gpkg pkg = do+ ioChecks <- checkPackageFiles verbosity pkg dir+ let pureChecks = checkPackage gpkg+ (errors, warnings) =+ partitionEithers (M.mapMaybe classEW $ pureChecks ++ ioChecks)+ if null errors+ then traverse_ (warn verbosity . ppPackageCheck) warnings+ else dieWithException verbosity $ CheckPackageProblems (map ppPackageCheck errors)+ where+ -- Classify error/warnings. Left: error, Right: warning.+ classEW :: PackageCheck -> Maybe (Either PackageCheck PackageCheck)+ classEW e@(PackageBuildImpossible _) = Just (Left e)+ classEW w@(PackageBuildWarning _) = Just (Right w)+ classEW (PackageDistSuspicious _) = Nothing+ classEW (PackageDistSuspiciousWarn _) = Nothing+ classEW (PackageDistInexcusable _) = Nothing++-- | Perform checks if a shared executable can be built+checkSharedExes+ :: Verbosity+ -> LocalBuildInfo+ -> IO ()+checkSharedExes verbosity lbi =+ when (os == Windows) $+ dieWithException verbosity $+ NoOSSupport os "shared executables"+ where+ (Platform _ os) = hostPlatform lbi++-- | Preform checks if a relocatable build is allowed+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, FreeBSD]) $+ dieWithException verbosity $+ NoOSSupport os "relocatable builds"+ where+ (Platform _ os) = hostPlatform lbi++ -- Check if the Compiler support relocatable builds+ checkCompiler =+ unless (compilerFlavor comp == GHC) $+ dieWithException verbosity $+ NoCompilerSupport (show comp)+ where+ comp = compiler lbi++ -- Check if all the install dirs are relative to same prefix+ packagePrefixRelative =+ unless (relativeInstallDirs installDirs) $+ dieWithException verbosity $+ InstallDirsNotPrefixRelative 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 . stripPrefix p)+ [ bindir+ , libdir+ , dynlibdir+ , bytecodelibdir+ , 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 $ getSymbolicPath pkgr) ipkgs+ where+ doCheck pkgr ipkg+ | Just 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+ -- The @prefix@ itself must also be canonicalized because+ -- canonicalizing @libdir@ may expand symlinks which would make+ -- @prefix@ no longer being a prefix of @canonical libdir@,+ -- while @canonical p@ could be a prefix of @canonical libdir@+ p' <- canonicalizePath p+ unless (p' `isPrefixOf` canonicalized) $+ dieWithException verbosity $+ LibDirDepsPrefixNotRelative libdir p+ | 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)++-- -----------------------------------------------------------------------------+-- Testing foreign library requirements++unsupportedForeignLibs :: Compiler -> Platform -> [ForeignLib] -> [String]+unsupportedForeignLibs 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 = goGhcPlatform platform+ 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 _ FreeBSD) = goGhcLinux (foreignLibType flib) goGhcPlatform (Platform I386 Windows) = goGhcWindows (foreignLibType flib) goGhcPlatform (Platform X86_64 Windows) = goGhcWindows (foreignLibType flib) goGhcPlatform _ =
src/Distribution/Simple/ConfigureScript.hs view
@@ -1,10 +1,11 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------{-# OPTIONS_GHC -fno-warn-deprecations #-}+{-# OPTIONS_GHC -Wno-deprecations #-} -- | -- Module : Distribution.Simple.ConfigureScript@@ -23,6 +24,7 @@ -- local import Distribution.PackageDescription import Distribution.Pretty+import Distribution.Simple.Configure (findDistPrefOrDefault) import Distribution.Simple.Errors import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program@@ -30,22 +32,17 @@ import Distribution.Simple.Setup.Common import Distribution.Simple.Setup.Config import Distribution.Simple.Utils-import Distribution.System (buildPlatform)+import Distribution.System (Platform, buildPlatform) import Distribution.Utils.NubList+import Distribution.Utils.Path import Distribution.Verbosity -- Base-import System.FilePath- ( dropDrive- , searchPathSeparator- , splitDirectories- , takeDirectory- , (</>)- )+import System.Directory (createDirectoryIfMissing, doesFileExist, makeAbsolute)+import qualified System.FilePath as FilePath #ifdef mingw32_HOST_OS import System.FilePath (normalise, splitDrive) #endif-import Distribution.Compat.Directory (makeAbsolute) import Distribution.Compat.Environment (getEnvironment) import Distribution.Compat.GetShortPathName (getShortPathName) @@ -53,13 +50,25 @@ import qualified Data.Map as Map runConfigureScript- :: Verbosity+ :: VerbosityHandles -> ConfigFlags- -> LocalBuildInfo+ -> FlagAssignment+ -> ProgramDb+ -> Platform+ -- ^ host platform -> IO ()-runConfigureScript verbosity flags lbi = do+runConfigureScript verbHandles cfg flags programDb hp = do+ let commonCfg = configCommonFlags cfg+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity commonCfg)+ dist_dir <- findDistPrefOrDefault $ setupDistPref commonCfg+ let build_dir = dist_dir </> makeRelativePathEx "build"+ mbWorkDir = flagToMaybe $ setupWorkingDir commonCfg+ configureScriptPath = packageRoot commonCfg </> "configure"+ confExists <- doesFileExist configureScriptPath+ unless confExists $+ dieWithException verbosity (ConfigureScriptNotFound configureScriptPath)+ configureFile <- makeAbsolute configureScriptPath env <- getEnvironment- let programDb = withPrograms lbi (ccProg, ccFlags) <- configureCCompiler verbosity programDb ccProgShort <- getShortPathName ccProg -- The C compiler's compilation and linker flags (e.g.@@ -68,9 +77,20 @@ -- 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"++ -- Do not presume the CXX compiler is available, but it always will be after 9.4.+ (mcxxProgShort, mcxxFlags) <- do+ mprog <- needProgram verbosity gppProgram programDb+ case mprog of+ Just (p, _) -> do+ let pInv = programInvocation p []+ let cxxProg = progInvokePath pInv+ let cxxFlags = progInvokeArgs pInv+ cxxProgShort <- getShortPathName cxxProg+ return (Just cxxProgShort, Just cxxFlags)+ Nothing -> return (Nothing, Nothing)++ let configureFile' = toUnix configureFile -- 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@@ -84,9 +104,8 @@ -- TODO: We don't check for colons, tildes or leading dashes. We -- also should check the builddir's path, destdir, and all other -- paths as well.- let configureFile' = toUnix configureFile for_ badAutoconfCharacters $ \(c, cname) ->- when (c `elem` dropDrive configureFile') $+ when (c `elem` FilePath.dropDrive configureFile') $ warn verbosity $ concat [ "The path to the './configure' script, '"@@ -116,7 +135,7 @@ Map.fromListWith (<>) [ (flagEnvVar flag, (flag, bool) :| [])- | (flag, bool) <- unFlagAssignment $ flagAssignment lbi+ | (flag, bool) <- unFlagAssignment flags ] -- A map from env vars to flag names to the single flag we will go with cabalFlagMapDeconflicted :: Map String (FlagName, Bool) <-@@ -148,40 +167,45 @@ ] ++ [ ( "CABAL_FLAGS"- , Just $ unwords [showFlagValue fv | fv <- unFlagAssignment $ flagAssignment lbi]+ , Just $ unwords [showFlagValue fv | fv <- unFlagAssignment flags] ) ]- let extraPath = fromNubList $ configProgramPathExtra flags- let cflagsEnv =- maybe (unwords ccFlags) (++ (" " ++ unwords ccFlags)) $- lookup "CFLAGS" env- spSep = [searchPathSeparator]+ let extraPath = fromNubList $ configProgramPathExtra cfg+ let mkFlagsEnv fs var = maybe (unwords fs) (++ (" " ++ unwords fs)) (lookup var env)+ spSep = [FilePath.searchPathSeparator] pathEnv = maybe (intercalate spSep extraPath) ((intercalate spSep extraPath ++ spSep) ++) $ lookup "PATH" env overEnv =- ("CFLAGS", Just cflagsEnv)- : [("PATH", Just pathEnv) | not (null extraPath)]+ ("CFLAGS", Just (mkFlagsEnv ccFlags "CFLAGS"))+ : [("CXXFLAGS", Just (mkFlagsEnv cxxFlags "CXXFLAGS")) | Just cxxFlags <- [mcxxFlags]]+ ++ [("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+ maybeHostFlag = ["--host=" ++ show (pretty hp) | hp /= buildPlatform]+ args' =+ configureFile'+ : args+ ++ ["CC=" ++ ccProgShort]+ ++ ["CXX=" ++ cxxProgShort | Just cxxProgShort <- [mcxxProgShort]]+ ++ maybeHostFlag shProg = simpleProgram "sh"- progDb <- prependProgramSearchPath verbosity extraPath emptyProgramDb+ progDb <- prependProgramSearchPath verbosity extraPath [] emptyProgramDb shConfiguredProg <- lookupProgram shProg `fmap` configureProgram verbosity shProg progDb case shConfiguredProg of- Just sh ->+ Just sh -> do+ let build_in = interpretSymbolicPath mbWorkDir build_dir+ createDirectoryIfMissing True build_in runProgramInvocation verbosity $ (programInvocation (sh{programOverrideEnv = overEnv}) args')- { progInvokeCwd = Just (buildDir lbi)+ { progInvokeCwd = Just build_in } Nothing -> dieWithException verbosity NotFoundMsg where- args = configureArgs backwardsCompatHack flags+ args = configureArgs backwardsCompatHack cfg backwardsCompatHack = False -- | Convert Windows path to Unix ones@@ -191,10 +215,10 @@ (l, rest) = case splitDrive tmp of ([], x) -> ("/" , x) (h:_, x) -> ('/':h:"/", x)- parts = splitDirectories rest+ parts = FilePath.splitDirectories rest in l ++ intercalate "/" parts #else-toUnix s = intercalate "/" $ splitDirectories s+toUnix s = intercalate "/" $ FilePath.splitDirectories s #endif badAutoconfCharacters :: [(Char, String)]
src/Distribution/Simple/Errors.hs view
@@ -20,18 +20,16 @@ import Distribution.InstalledPackageInfo import Distribution.ModuleName import Distribution.Package-import Distribution.PackageDescription (FlagName, UnqualComponentName)+import Distribution.PackageDescription import Distribution.Pretty ( Pretty (pretty) , prettyShow ) import Distribution.Simple.InstallDirs import Distribution.Simple.PreProcess.Types (Suffix)+import Distribution.Simple.SetupHooks.Errors import Distribution.System (OS)-import Distribution.Types.BenchmarkType-import Distribution.Types.LibraryName-import Distribution.Types.PkgconfigVersion-import Distribution.Types.TestType+import Distribution.Types.MissingDependency (MissingDependency) import Distribution.Types.VersionRange.Internal () import Distribution.Version import Text.PrettyPrint@@ -51,10 +49,10 @@ | -- | @NoLibraryFound@ has been downgraded to a warning, and is therefore no longer emitted. NoLibraryFound | CompilerNotInstalled CompilerFlavor- | CantFindIncludeFile String+ | CantFindIncludeFile String [String] | UnsupportedTestSuite String | UnsupportedBenchMark String- | NoIncludeFileFound String+ | NoIncludeFileFound String [String] | NoModuleFound ModuleName [Suffix] | RegMultipleInstancePkg | SuppressingChecksOnFile@@ -80,8 +78,6 @@ | NoSupportBuildingTestSuite TestType | NoSupportBuildingBenchMark BenchmarkType | BuildingNotSupportedWithCompiler- | ProvideHaskellSuiteTool String- | CannotDetermineCompilerVersion | PkgDumpFailed | FailedToParseOutput | CantFindSourceModule ModuleName@@ -100,8 +96,7 @@ | AmbiguousBuildTarget [(String, [(String, String)])] | CheckBuildTargets String | VersionMismatchGHC FilePath Version FilePath Version- | CheckPackageDbStackPost76- | CheckPackageDbStackPre76+ | CheckPackageDbStack | GlobalPackageDbSpecifiedFirst | CantInstallForeignLib | NoSupportForPreProcessingTest TestType@@ -116,7 +111,7 @@ | CheckSemaphoreSupport | NoLibraryForPackage | SanityCheckHookedBuildInfo UnqualComponentName- | ConfigureScriptNotFound+ | ConfigureScriptNotFound FilePath | NoValidComponent | ConfigureEitherSingleOrAll | ConfigCIDValidForPreComponent@@ -127,7 +122,7 @@ | CantFindForeignLibraries [String] | ExpectedAbsoluteDirectory FilePath | FlagsNotSpecified [FlagName]- | EncounteredMissingDependency [Dependency]+ | EncounteredMissingDependency [MissingDependency] | CompilerDoesn'tSupportThinning | CompilerDoesn'tSupportReexports | CompilerDoesn'tSupportBackpack@@ -139,7 +134,7 @@ | BadVersion String String PkgconfigVersion | UnknownCompilerException | NoWorkingGcc- | NoOSSupport OS+ | NoOSSupport OS String | NoCompilerSupport String | InstallDirsNotPrefixRelative (InstallDirs FilePath) | ExplainErrors (Maybe (Either [Char] [Char])) [String]@@ -153,8 +148,7 @@ | Couldn'tFindTestProgLibV09 FilePath | TestCoverageSupportLibV09 | RawSystemStdout String- | FindFileCwd FilePath- | FindFileEx FilePath+ | FindFile FilePath | FindModuleFileEx ModuleName [Suffix] [FilePath] | MultipleFilesWithExtension String | NoDesc@@ -173,7 +167,10 @@ | BadVersionDb String Version VersionRange FilePath | UnknownVersionDb String VersionRange FilePath | MissingCoveredInstalledLibrary UnitId- deriving (Show, Typeable)+ | SetupHooksException SetupHooksException+ | MultiReplDoesNotSupportComplexReexportedModules PackageName ComponentName+ | StandaloneBytecodeNotSupportedYet+ deriving (Show) exceptionCode :: CabalException -> Int exceptionCode e = case e of@@ -212,8 +209,8 @@ NoSupportBuildingTestSuite{} -> 4106 NoSupportBuildingBenchMark{} -> 5320 BuildingNotSupportedWithCompiler{} -> 7077- ProvideHaskellSuiteTool{} -> 7509- CannotDetermineCompilerVersion{} -> 4519+ -- Retired: ProvideHaskellSuiteTool{} -> 7509+ -- Retired: CannotDetermineCompilerVersion{} -> 4519 PkgDumpFailed{} -> 2291 FailedToParseOutput{} -> 5500 CantFindSourceModule{} -> 8870@@ -232,8 +229,8 @@ AmbiguousBuildTarget{} -> 7865 CheckBuildTargets{} -> 4733 VersionMismatchGHC{} -> 4000- CheckPackageDbStackPost76{} -> 3000- CheckPackageDbStackPre76{} -> 5640+ CheckPackageDbStack{} -> 3000+ -- Retired: CheckPackageDbStackPre76{} -> 5640 GlobalPackageDbSpecifiedFirst{} -> 2345 CantInstallForeignLib{} -> 8221 NoSupportForPreProcessingTest{} -> 3008@@ -285,8 +282,7 @@ Couldn'tFindTestProgLibV09{} -> 9012 TestCoverageSupportLibV09{} -> 1076 RawSystemStdout{} -> 3098- FindFileCwd{} -> 4765- FindFileEx{} -> 2115+ FindFile{} -> 2115 FindModuleFileEx{} -> 6663 MultipleFilesWithExtension{} -> 3333 NoDesc{} -> 7654@@ -305,6 +301,10 @@ BadVersionDb{} -> 8038 UnknownVersionDb{} -> 1008 MissingCoveredInstalledLibrary{} -> 9341+ SetupHooksException err ->+ setupHooksExceptionCode err+ MultiReplDoesNotSupportComplexReexportedModules{} -> 9355+ StandaloneBytecodeNotSupportedYet -> 9356 versionRequirement :: VersionRange -> String versionRequirement range@@ -314,15 +314,15 @@ exceptionMessage :: CabalException -> String exceptionMessage e = case e of NoBenchMarkProgram cmd -> "Could not find benchmark program \"" ++ cmd ++ "\". Did you build the package first?"- EnableBenchMark -> "No benchmarks enabled. Did you remember to configure with " ++ "\'--enable-benchmarks\'?"+ EnableBenchMark -> "No benchmarks enabled. Did you remember to \'Setup configure\' with " ++ "\'--enable-benchmarks\'?" BenchMarkNameDisabled bmName -> "Package configured with benchmark " ++ bmName ++ " disabled." NoBenchMark bmName -> "no such benchmark: " ++ bmName NoLibraryFound -> "No executables and no library found. Nothing to do." CompilerNotInstalled compilerFlavor -> "installing with " ++ prettyShow compilerFlavor ++ "is not implemented"- CantFindIncludeFile file -> "can't find include file " ++ file- UnsupportedTestSuite testType -> "Unsupported test suite type: " ++ testType+ CantFindIncludeFile file sd -> "can't find include file " ++ file ++ " in any of the search dirs " ++ intercalate ", " sd+ UnsupportedTestSuite test_type -> "Unsupported test suite type: " ++ test_type UnsupportedBenchMark benchMarkType -> "Unsupported benchmark type: " ++ benchMarkType- NoIncludeFileFound f -> "can't find include file " ++ f+ NoIncludeFileFound f sd -> "can't find include file " ++ f ++ " in any of the search dirs " ++ intercalate ", " sd NoModuleFound m suffixes -> "Could not find module: " ++ prettyShow m@@ -331,8 +331,8 @@ ++ ".\n" ++ "If the module " ++ "is autogenerated it should be added to 'autogen-modules'."- RegMultipleInstancePkg -> "HcPkg.register: the compiler does not support,registering multiple instances of packages."- SuppressingChecksOnFile -> "HcPkg.register: the compiler does not support ,suppressing checks on files."+ RegMultipleInstancePkg -> "HcPkg.register: the compiler does not support registering multiple instances of packages."+ SuppressingChecksOnFile -> "HcPkg.register: the compiler does not support suppressing checks on files." NoSupportDirStylePackageDb -> "HcPkg.writeRegistrationFileDirectly: compiler does not support dir style package dbs" OnlySupportSpecificPackageDb -> "HcPkg.writeRegistrationFileDirectly: only supports SpecificPackageDB for now" FailedToParseOutputDescribe programId pkgId -> "failed to parse output of '" ++ programId ++ " describe " ++ prettyShow pkgId ++ "'"@@ -353,7 +353,7 @@ ++ " but " ++ "haddock is using GHC version " ++ prettyShow haddockGhcVersion- MustHaveSharedLibraries -> "Must have vanilla or shared libraries " ++ "enabled in order to run haddock"+ MustHaveSharedLibraries -> "Must have vanilla or shared libraries enabled in order to run haddock" HaddockPackageFlags inf -> "internal error when calculating transitive " ++ "package dependencies.\nDebug info: "@@ -362,11 +362,9 @@ FailedToDetermineTarget -> "Failed to determine target." NoMultipleTargets -> "The 'repl' command does not support multiple targets at once." REPLNotSupported -> "A REPL is not supported with this compiler."- NoSupportBuildingTestSuite testType -> "No support for building test suite type " ++ show testType+ NoSupportBuildingTestSuite test_type -> "No support for building test suite type " ++ show test_type NoSupportBuildingBenchMark benchMarkType -> "No support for building benchmark type " ++ show benchMarkType BuildingNotSupportedWithCompiler -> "Building is not supported with this compiler."- ProvideHaskellSuiteTool msg -> show msg- CannotDetermineCompilerVersion -> "haskell-suite: couldn't determine compiler version" PkgDumpFailed -> "pkg dump failed" FailedToParseOutput -> "failed to parse output of 'pkg dump'" CantFindSourceModule moduleName -> "can't find source for module " ++ prettyShow moduleName@@ -391,7 +389,7 @@ GlobalPackageDBLimitation -> "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"+ ++ "the future, see https://gitlab.haskell.org/ghc/ghc/-/issues/5977" GlobalPackageDBSpecifiedFirst -> "If the global package db is specified, it must be " ++ "specified first and cannot be specified multiple times"@@ -471,13 +469,9 @@ ++ ghcPkgProgPath ++ " is version " ++ prettyShow ghcPkgVersion- CheckPackageDbStackPost76 ->+ CheckPackageDbStack -> "If the global package db is specified, it must be " ++ "specified first and cannot be specified multiple times"- CheckPackageDbStackPre76 ->- "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" GlobalPackageDbSpecifiedFirst -> "If the global package db is specified, it must be " ++ "specified first and cannot be specified multiple times"@@ -487,8 +481,7 @@ ++ "suite type " ++ prettyShow tt NoSupportForPreProcessingBenchmark tt ->- "No support for preprocessing benchmark "- ++ "type "+ "No support for preprocessing benchmark type " ++ prettyShow tt CantFindSourceForPreProcessFile errorStr -> errorStr NoSupportPreProcessingTestExtras tt ->@@ -511,11 +504,11 @@ SanityCheckHookedBuildInfo exe1 -> "The buildinfo contains info for an executable called '" ++ prettyShow exe1- ++ "' but the package does not have a "+ ++ "' but the package does not have an " ++ "executable with that name."- ConfigureScriptNotFound -> "configure script not found."+ ConfigureScriptNotFound fp -> "configure script not found at " ++ fp ++ "." NoValidComponent -> "No valid component targets found"- ConfigureEitherSingleOrAll -> "Can only configure either single component or all of them"+ ConfigureEitherSingleOrAll -> "Can only configure either a single component or all of them" ConfigCIDValidForPreComponent -> "--cid is only supported for per-component configure" SanityCheckForEnableComponents -> "--enable-tests/--enable-benchmarks are incompatible with"@@ -525,23 +518,23 @@ ++ " are incompatible with each other." UnsupportedLanguages pkgId compilerId langs -> "The package "- ++ prettyShow (pkgId)+ ++ prettyShow pkgId ++ " requires the following languages which are not " ++ "supported by "- ++ prettyShow (compilerId)+ ++ prettyShow compilerId ++ ": " ++ intercalate ", " langs UnsupportedLanguageExtension pkgId compilerId exts -> "The package "- ++ prettyShow (pkgId)+ ++ prettyShow pkgId ++ " requires the following language extensions which are not " ++ "supported by "- ++ prettyShow (compilerId)+ ++ prettyShow compilerId ++ ": " ++ intercalate ", " exts CantFindForeignLibraries unsupportedFLibs -> "Cannot build some foreign libraries: "- ++ intercalate "," unsupportedFLibs+ ++ intercalate ", " unsupportedFLibs ExpectedAbsoluteDirectory fPath -> "expected an absolute directory name for --prefix: " ++ fPath FlagsNotSpecified diffFlags -> "'--exact-configuration' was given, "@@ -553,7 +546,7 @@ . nest 4 . sep . punctuate comma- . map (pretty . simplifyDependency)+ . map pretty $ missing ) CompilerDoesn'tSupportThinning ->@@ -572,7 +565,7 @@ ++ "' 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 failed hackageUrl -> (intercalate "\n\n" (map reportFailedDependency failed))+ ReportFailedDependencies failed hackageUrl -> intercalate "\n\n" (map reportFailedDependency failed) where reportFailedDependency (DependencyNotExists pkgname) = "there is no version of "@@ -617,15 +610,16 @@ NoWorkingGcc -> unlines [ "No working gcc"- , "This package depends on foreign library but we cannot "+ , "This package depends on a 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." ]- NoOSSupport os ->+ NoOSSupport os what -> "Operating system: " ++ prettyShow os- ++ ", does not support relocatable builds"+ ++ ", does not support "+ ++ what NoCompilerSupport comp -> "Compiler: " ++ comp@@ -673,8 +667,8 @@ ++ "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."+ ++ "In this case you can re-run 'Setup 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 "@@ -684,18 +678,18 @@ ++ "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."+ ++ "In this case you can re-run 'Setup 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."+ ++ "In this case you can re-run 'Setup 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 "+ ++ "You can re-run 'Setup configure' with the verbosity flag " ++ "-v3 to see the error messages from the C compiler."- CheckPackageProblems errors -> (intercalate "\n\n" $ errors)+ CheckPackageProblems errors -> intercalate "\n\n" errors LibDirDepsPrefixNotRelative l p -> "Library directory of a dependency: " ++ show l@@ -726,8 +720,7 @@ ++ "\". Did you build the package first?" TestCoverageSupportLibV09 -> "Test coverage is only supported for packages with a library component." RawSystemStdout errors -> errors- FindFileCwd fileName -> fileName ++ " doesn't exist"- FindFileEx fileName -> fileName ++ " doesn't exist"+ FindFile fileName -> fileName ++ " doesn't exist" FindModuleFileEx mod_name extensions searchPath -> "Could not find module: " ++ prettyShow mod_name@@ -757,7 +750,7 @@ RegisMultiplePkgNotSupported -> "Registering multiple package instances is not yet supported for this compiler" RegisteringNotImplemented -> "Registering is not implemented for this compiler" NoTestSuitesEnabled ->- "No test suites enabled. Did you remember to configure with "+ "No test suites enabled. Did you remember to 'Setup configure' with " ++ "\'--enable-tests\'?" TestNameDisabled tName -> "Package configured with test suite "@@ -799,3 +792,17 @@ "Failed to find the installed unit '" ++ prettyShow unitId ++ "' in package database stack."+ SetupHooksException err ->+ setupHooksExceptionMessage err+ MultiReplDoesNotSupportComplexReexportedModules pname cname ->+ "When attempting start the repl for "+ ++ showComponentName cname+ ++ " from package "+ ++ prettyShow pname+ ++ " a module renaming was found.\n"+ ++ "Multi-repl does not work with complicated reexported-modules until GHC-9.12."+ StandaloneBytecodeNotSupportedYet ->+ unlines+ [ "The ecosystem doesn't support building packages with just bytecode libraries yet."+ , "If you have run into this error, please comment on issue #<TODO>"+ ]
+ src/Distribution/Simple/FileMonitor/Types.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE DeriveGeneric #-}++-- |+-- Module: Distribution.Simple.FileMonitor.Types+--+-- Types for monitoring files and directories.+module Distribution.Simple.FileMonitor.Types+ ( -- * Globs with respect to a root+ RootedGlob (..)+ , FilePathRoot (..)+ , Glob++ -- * File monitoring+ , MonitorFilePath (..)+ , MonitorKindFile (..)+ , MonitorKindDir (..)++ -- ** Utility constructors of t'MonitorFilePath'+ , monitorFile+ , monitorFileHashed+ , monitorNonExistentFile+ , monitorFileExistence+ , monitorDirectory+ , monitorNonExistentDirectory+ , monitorDirectoryExistence+ , monitorFileOrDirectory+ , monitorFileGlob+ , monitorFileGlobExistence+ , monitorFileSearchPath+ , monitorFileHashedSearchPath+ )+where++import Distribution.Compat.Prelude+import Distribution.Simple.Glob.Internal+ ( Glob (..)+ )++import qualified Distribution.Compat.CharParsing as P+import Distribution.Parsec+import Distribution.Pretty+import Distribution.Utils.Generic (isAsciiAlpha)+import qualified Text.PrettyPrint as Disp++--------------------------------------------------------------------------------+-- Rooted globs.+--++-- | A file path specified by globbing, relative+-- to some root directory.+data RootedGlob+ = RootedGlob+ FilePathRoot+ -- ^ what the glob is relative to+ Glob+ -- ^ the glob+ deriving (Eq, Show, Generic)++instance Binary RootedGlob+instance Structured RootedGlob++data FilePathRoot+ = FilePathRelative+ | -- | e.g. @"/"@, @"c:\"@ or result of 'takeDrive'+ FilePathRoot FilePath+ | FilePathHomeDir+ deriving (Eq, Show, Generic)++instance Binary FilePathRoot+instance Structured FilePathRoot++------------------------------------------------------------------------------+-- Types for specifying files to monitor+--++-- | A description of a file (or set of files) to monitor for changes.+--+-- Where file paths are relative they are relative to a common directory+-- (e.g. project root), not necessarily the process current directory.+data MonitorFilePath+ = MonitorFile+ { monitorKindFile :: !MonitorKindFile+ , monitorKindDir :: !MonitorKindDir+ , monitorPath :: !FilePath+ }+ | MonitorFileGlob+ { monitorKindFile :: !MonitorKindFile+ , monitorKindDir :: !MonitorKindDir+ , monitorPathGlob :: !RootedGlob+ }+ deriving (Eq, Show, Generic)++data MonitorKindFile+ = FileExists+ | FileModTime+ | FileHashed+ | FileNotExists+ deriving (Eq, Show, Generic)++data MonitorKindDir+ = DirExists+ | DirModTime+ | DirNotExists+ deriving (Eq, Show, Generic)++instance Binary MonitorFilePath+instance Binary MonitorKindFile+instance Binary MonitorKindDir++instance Structured MonitorFilePath+instance Structured MonitorKindFile+instance Structured MonitorKindDir++-- | Monitor a single file for changes, based on its modification time.+-- The monitored file is considered to have changed if it no longer+-- exists or if its modification time has changed.+monitorFile :: FilePath -> MonitorFilePath+monitorFile = MonitorFile FileModTime DirNotExists++-- | Monitor a single file for changes, based on its modification time+-- and content hash. The monitored file is considered to have changed if+-- it no longer exists or if its modification time and content hash have+-- changed.+monitorFileHashed :: FilePath -> MonitorFilePath+monitorFileHashed = MonitorFile FileHashed DirNotExists++-- | Monitor a single non-existent file for changes. The monitored file+-- is considered to have changed if it exists.+monitorNonExistentFile :: FilePath -> MonitorFilePath+monitorNonExistentFile = MonitorFile FileNotExists DirNotExists++-- | Monitor a single file for existence only. The monitored file is+-- considered to have changed if it no longer exists.+monitorFileExistence :: FilePath -> MonitorFilePath+monitorFileExistence = MonitorFile FileExists DirNotExists++-- | Monitor a single directory for changes, based on its modification+-- time. The monitored directory is considered to have changed if it no+-- longer exists or if its modification time has changed.+monitorDirectory :: FilePath -> MonitorFilePath+monitorDirectory = MonitorFile FileNotExists DirModTime++-- | Monitor a single non-existent directory for changes. The monitored+-- directory is considered to have changed if it exists.+monitorNonExistentDirectory :: FilePath -> MonitorFilePath+-- Just an alias for monitorNonExistentFile, since you can't+-- tell the difference between a non-existent directory and+-- a non-existent file :)+monitorNonExistentDirectory = monitorNonExistentFile++-- | Monitor a single directory for existence. The monitored directory is+-- considered to have changed only if it no longer exists.+monitorDirectoryExistence :: FilePath -> MonitorFilePath+monitorDirectoryExistence = MonitorFile FileNotExists DirExists++-- | Monitor a single file or directory for changes, based on its modification+-- time. The monitored file is considered to have changed if it no longer+-- exists or if its modification time has changed.+monitorFileOrDirectory :: FilePath -> MonitorFilePath+monitorFileOrDirectory = MonitorFile FileModTime DirModTime++-- | Monitor a set of files (or directories) identified by a file glob.+-- The monitored glob is considered to have changed if the set of files+-- matching the glob changes (i.e. creations or deletions), or for files if the+-- modification time and content hash of any matching file has changed.+monitorFileGlob :: RootedGlob -> MonitorFilePath+monitorFileGlob = MonitorFileGlob FileHashed DirExists++-- | Monitor a set of files (or directories) identified by a file glob for+-- existence only. The monitored glob is considered to have changed if the set+-- of files matching the glob changes (i.e. creations or deletions).+monitorFileGlobExistence :: RootedGlob -> MonitorFilePath+monitorFileGlobExistence = MonitorFileGlob FileExists DirExists++-- | Creates a list of files to monitor when you search for a file which+-- unsuccessfully looked in @notFoundAtPaths@ before finding it at+-- @foundAtPath@.+monitorFileSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath]+monitorFileSearchPath notFoundAtPaths foundAtPath =+ monitorFile foundAtPath+ : map monitorNonExistentFile notFoundAtPaths++-- | Similar to 'monitorFileSearchPath', but also instructs us to+-- monitor the hash of the found file.+monitorFileHashedSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath]+monitorFileHashedSearchPath notFoundAtPaths foundAtPath =+ monitorFileHashed foundAtPath+ : map monitorNonExistentFile notFoundAtPaths++------------------------------------------------------------------------------+-- Parsing & pretty-printing+--++instance Pretty RootedGlob where+ pretty (RootedGlob root pathglob) = pretty root Disp.<> pretty pathglob++instance Parsec RootedGlob where+ parsec = do+ root <- parsec+ case root of+ FilePathRelative -> RootedGlob root <$> parsec+ _ -> RootedGlob root <$> parsec <|> pure (RootedGlob root GlobDirTrailing)++instance Pretty FilePathRoot where+ pretty FilePathRelative = Disp.empty+ pretty (FilePathRoot root) = Disp.text root+ pretty FilePathHomeDir = Disp.char '~' Disp.<> Disp.char '/'++instance Parsec FilePathRoot where+ parsec = root <|> P.try home <|> P.try drive <|> pure FilePathRelative+ where+ root = FilePathRoot "/" <$ P.char '/'+ home = FilePathHomeDir <$ P.string "~/"+ drive = do+ dr <- P.satisfy isAsciiAlpha+ _ <- P.char ':'+ _ <- P.char '/' <|> P.char '\\'+ return (FilePathRoot (toUpper dr : ":\\"))
src/Distribution/Simple/Flag.hs view
@@ -1,7 +1,5 @@-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-} ----------------------------------------------------------------------------- @@ -20,7 +18,9 @@ -- -- Split off from "Distribution.Simple.Setup" to break import cycles. module Distribution.Simple.Flag- ( Flag (..)+ ( Flag+ , pattern Flag+ , pattern NoFlag , allFlags , toFlag , fromFlag@@ -33,6 +33,7 @@ , BooleanFlag (..) ) where +import Data.Monoid (Last (..)) import Distribution.Compat.Prelude hiding (get) import Distribution.Compat.Stack import Prelude ()@@ -62,43 +63,15 @@ -- 'NoFlag' and later flags override earlier ones. -- -- Isomorphic to 'Maybe' a.-data Flag a = Flag a | NoFlag deriving (Eq, Generic, Show, Read, Typeable, Foldable, Traversable)--instance Binary a => Binary (Flag a)-instance Structured a => Structured (Flag a)--instance Functor Flag where- fmap f (Flag x) = Flag (f x)- fmap _ NoFlag = NoFlag--instance Applicative Flag where- (Flag x) <*> y = x <$> y- NoFlag <*> _ = NoFlag- pure = Flag--instance Monoid (Flag a) where- mempty = NoFlag- mappend = (<>)+type Flag = Last -instance Semigroup (Flag a) where- _ <> f@(Flag _) = f- f <> NoFlag = f+pattern Flag :: a -> Last a+pattern Flag a = Last (Just a) -instance Bounded a => Bounded (Flag a) where- minBound = toFlag minBound- maxBound = toFlag maxBound+pattern NoFlag :: Last a+pattern NoFlag = Last Nothing -instance Enum a => Enum (Flag a) where- fromEnum = fromEnum . fromFlag- toEnum = toFlag . toEnum- enumFrom (Flag a) = map toFlag . enumFrom $ a- enumFrom _ = []- enumFromThen (Flag a) (Flag b) = toFlag `map` enumFromThen a b- 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 _ _ _ = []+{-# COMPLETE Flag, NoFlag #-} -- | Wraps a value in 'Flag'. toFlag :: a -> Flag a@@ -111,26 +84,22 @@ -- | Extracts a value from a 'Flag', and returns the default value on 'NoFlag'. fromFlagOrDefault :: a -> Flag a -> a-fromFlagOrDefault _ (Flag x) = x-fromFlagOrDefault def NoFlag = def+fromFlagOrDefault def = fromMaybe def . getLast -- | Converts a 'Flag' value to a 'Maybe' value. flagToMaybe :: Flag a -> Maybe a-flagToMaybe (Flag x) = Just x-flagToMaybe NoFlag = Nothing+flagToMaybe = getLast -- | Pushes a function through a 'Flag' value, and returns a default -- if the 'Flag' value is 'NoFlag'. -- -- @since 3.4.0.0 flagElim :: b -> (a -> b) -> Flag a -> b-flagElim n _ NoFlag = n-flagElim _ f (Flag x) = f x+flagElim n f = maybe n f . getLast -- | Converts a 'Flag' value to a list. flagToList :: Flag a -> [a]-flagToList (Flag x) = [x]-flagToList NoFlag = []+flagToList = maybeToList . getLast -- | Returns 'True' only if every 'Flag' 'Bool' value is Flag True, else 'False'. allFlags :: [Flag Bool] -> Flag Bool@@ -141,8 +110,7 @@ -- | Converts a 'Maybe' value to a 'Flag' value. maybeToFlag :: Maybe a -> Flag a-maybeToFlag Nothing = NoFlag-maybeToFlag (Just x) = Flag x+maybeToFlag = Last -- | Merge the elements of a list 'Flag' with another list 'Flag'. mergeListFlag :: Flag [a] -> Flag [a] -> Flag [a]
src/Distribution/Simple/GHC.hs view
@@ -1,9 +1,11 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- @@ -40,6 +42,8 @@ module Distribution.Simple.GHC ( getGhcInfo , configure+ , configureCompiler+ , compilerProgramDb , getInstalledPackages , getInstalledPackagesMonitorFiles , getPackageDBContents@@ -57,10 +61,9 @@ , hcPkgInfo , registerPackage , Internal.componentGhcOptions- , Internal.componentCcGhcOptions , getGhcAppDir , getLibDir- , isDynamic+ , compilerBuildWay , getGlobalPackageDB , pkgRoot @@ -82,12 +85,12 @@ import Distribution.Compat.Prelude import Prelude () +import Control.Arrow ((***)) import Control.Monad (forM_)-import Data.List (stripPrefix) import qualified Data.Map as Map+import Data.Maybe (fromJust) import Distribution.CabalSpecVersion import Distribution.InstalledPackageInfo (InstalledPackageInfo)-import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo import Distribution.Package import Distribution.PackageDescription as PD import Distribution.Pretty@@ -95,8 +98,9 @@ import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler import Distribution.Simple.Errors-import Distribution.Simple.Flag (Flag (..), toFlag)+import Distribution.Simple.Flag import qualified Distribution.Simple.GHC.Build as GHC+import Distribution.Simple.GHC.Build.Modules (BuildWay (..)) import Distribution.Simple.GHC.Build.Utils import Distribution.Simple.GHC.EnvironmentParser import Distribution.Simple.GHC.ImplInfo@@ -110,7 +114,7 @@ import Distribution.Simple.Program.GHC import qualified Distribution.Simple.Program.HcPkg as HcPkg import qualified Distribution.Simple.Program.Strip as Strip-import Distribution.Simple.Setup.Common (extraCompilationArtifacts)+import Distribution.Simple.Setup.Common import Distribution.Simple.Setup.Repl import Distribution.Simple.Utils import Distribution.System@@ -118,27 +122,32 @@ import Distribution.Types.ParStrat import Distribution.Types.TargetInfo import Distribution.Utils.NubList+import Distribution.Utils.Path import Distribution.Verbosity import Distribution.Version import Language.Haskell.Extension+import System.FilePath+ ( isRelative+ , takeDirectory+ )+import qualified System.Info+#ifndef mingw32_HOST_OS+import System.Posix (createSymbolicLink)+#endif /* mingw32_HOST_OS */++{- FOURMOLU_DISABLE -} import System.Directory ( canonicalizePath , createDirectoryIfMissing , doesDirectoryExist , doesFileExist , getAppUserDataDirectory- , getDirectoryContents- )-import System.FilePath- ( takeDirectory- , (<.>)- , (</>)- )-import qualified System.Info+ , listDirectory #ifndef mingw32_HOST_OS-import System.Directory (renameFile)-import System.Posix (createSymbolicLink)-#endif /* mingw32_HOST_OS */+ , renameFile+#endif+ )+{- FOURMOLU_ENABLE -} import Distribution.Simple.Setup (BuildingWhat (..)) import Distribution.Simple.Setup.Build@@ -146,83 +155,62 @@ -- ----------------------------------------------------------------------------- -- Configuring +-- | Configure GHC, and then auxiliary programs such as @ghc-pkg@, @haddock@+-- as well as toolchain programs such as @ar@, @ld. configure :: Verbosity -> Maybe FilePath+ -- ^ user-specified @ghc@ path (optional) -> Maybe FilePath+ -- ^ user-specified @ghc-pkg@ path (optional) -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb) configure verbosity hcPath hcPkgPath conf0 = do+ (comp, compPlatform, progdb1) <- configureCompiler verbosity hcPath conf0+ compProgDb <- compilerProgramDb verbosity comp progdb1 hcPkgPath+ return (comp, compPlatform, compProgDb)++-- | Configure GHC.+configureCompiler+ :: Verbosity+ -> Maybe FilePath+ -- ^ user-specified @ghc@ path (optional)+ -> ProgramDb+ -> IO (Compiler, Maybe Platform, ProgramDb)+configureCompiler verbosity hcPath conf0 = do (ghcProg, ghcVersion, progdb1) <- requireProgramVersion verbosity ghcProgram (orLaterVersion (mkVersion [7, 0, 1])) (userMaybeSpecifyPath "ghc" hcPath conf0)- let implInfo = ghcVersionImplInfo ghcVersion - -- Cabal currently supports ghc >= 7.0.1 && < 9.12- -- ... and the following odd development version- unless (ghcVersion < mkVersion [9, 12]) $- warn verbosity $+ -- Cabal currently supports GHC less than `maxGhcVersion`+ let maxGhcVersion = mkVersion [10, 2]+ unless (ghcVersion < maxGhcVersion) $+ info verbosity $ "Unknown/unsupported 'ghc' version detected " ++ "(Cabal " ++ prettyShow cabalVersion- ++ " supports 'ghc' version < 9.12): "+ ++ " supports 'ghc' version < "+ ++ prettyShow maxGhcVersion+ ++ "): " ++ 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) $- dieWithException verbosity $- VersionMismatchGHC (programPath ghcProg) ghcVersion (programPath ghcPkgProg) 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' $- addKnownProgram runghcProgram' progdb2-- languages <- Internal.getLanguages verbosity implInfo ghcProg- extensions0 <- Internal.getExtensions verbosity implInfo ghcProg+ let implInfo = ghcVersionImplInfo ghcVersion+ languages <- Internal.getLanguages implInfo+ extensions0 <- Internal.getExtensions verbosity ghcProg ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcProg+ let ghcInfoMap = Map.fromList ghcInfo filterJS = if ghcVersion < mkVersion [9, 8] then filterExt JavaScriptFFI else id extensions = -- workaround https://gitlab.haskell.org/ghc/ghc/-/issues/11214- filterJS $- -- see 'filterExtTH' comment below- filterExtTH $- extensions0+ -- see 'filterExtTH' comment below+ filterJS $ filterExtTH extensions0 -- starting with GHC 8.0, `TemplateHaskell` will be omitted from -- `--supported-extensions` when it's not available.@@ -239,9 +227,36 @@ compilerId :: CompilerId compilerId = CompilerId GHC ghcVersion + projectUnitId :: Maybe String+ projectUnitId = Map.lookup "Project Unit Id" ghcInfoMap++ -- The @AbiTag@ is the @Project Unit Id@ but with redundant information from the compiler version removed.+ -- For development versions of the compiler these look like:+ -- @Project Unit Id@: "ghc-9.13-inplace"+ -- @compilerId@: "ghc-9.13.20250413"+ -- So, we need to be careful to only strip the /common/ prefix.+ -- In this example, @AbiTag@ is "inplace".+ -- If the @Project Unit Id@ exactly matches @compilerId@, stripping the+ -- common prefix yields the empty string, which should be treated as+ -- @NoAbiTag@ rather than @AbiTag ""@. compilerAbiTag :: AbiTag- compilerAbiTag = maybe NoAbiTag AbiTag (Map.lookup "Project Unit Id" ghcInfoMap >>= stripPrefix (prettyShow compilerId <> "-"))+ compilerAbiTag =+ let abiTagSuffix =+ dropWhile (== '-') . stripCommonPrefix (prettyShow compilerId)+ <$> projectUnitId+ in case abiTagSuffix of+ Nothing -> NoAbiTag+ Just "" -> NoAbiTag+ Just tag -> AbiTag tag + wiredInUnitIds = do+ ghcInternalUnitId <- Map.lookup "ghc-internal Unit Id" ghcInfoMap+ ghcUnitId <- projectUnitId+ pure+ [ (mkPackageName "ghc", mkUnitId ghcUnitId)+ , (mkPackageName "ghc-internal", mkUnitId ghcInternalUnitId)+ ]+ let comp = Compiler { compilerId@@ -250,12 +265,87 @@ , compilerLanguages = languages , compilerExtensions = extensions , compilerProperties = ghcInfoMap+ , compilerWiredInUnitIds = wiredInUnitIds } compPlatform = Internal.targetPlatform ghcInfo- -- configure gcc and ld- progdb4 = Internal.configureToolchain implInfo ghcProg ghcInfoMap progdb3- return (comp, compPlatform, progdb4)+ return (comp, compPlatform, progdb1) +-- | Given a configured @ghc@ program, configure auxiliary programs such+-- as @ghc-pkg@ or @haddock@, as well as toolchain programs such as @ar@, @ld@,+-- based on:+--+-- - the location of the @ghc@ executable,+-- - toolchain information in the GHC settings file.+compilerProgramDb+ :: Verbosity+ -> Compiler+ -> ProgramDb+ -> Maybe FilePath+ -- ^ user-specified @ghc-pkg@ path (optional)+ -> IO ProgramDb+compilerProgramDb verbosity comp progdb1 hcPkgPath = do+ -- 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+ }+ ghcPkgProgram' =+ ghcPkgProgram+ { programFindLocation = guessGhcPkgFromGhcPath ghcProg+ }+ progdb2 =+ -- The knownPrograms are populated before userMaybeSpecifyPath+ -- in the case that ProgramDb has been restored from a cache and is empty+ -- See #11373 for where this went wrong before+ userMaybeSpecifyPath "ghc-pkg" hcPkgPath $+ addKnownProgram haddockProgram' $+ addKnownProgram hsc2hsProgram' $+ addKnownProgram hpcProgram' $+ addKnownProgram runghcProgram' $+ addKnownProgram+ ghcPkgProgram'+ progdb1++ ghcProg = fromJust $ lookupProgram ghcProgram progdb1+ ghcVersion = compilerVersion comp++ -- configure gcc, ld, ar etc... based on the paths stored+ -- in the GHC settings file+ progdb3 =+ Internal.configureToolchain+ (ghcVersionImplInfo ghcVersion)+ ghcProg+ (compilerProperties comp)+ progdb2++ -- 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, progdb4) <-+ requireProgramVersion+ verbosity+ ghcPkgProgram'+ anyVersion+ progdb3++ when (ghcVersion /= ghcPkgVersion) $+ dieWithException verbosity $+ VersionMismatchGHC (programPath ghcProg) ghcVersion (programPath ghcPkgProg) ghcPkgVersion++ return progdb4+ -- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find -- the corresponding tool; e.g. if the tool is ghc-pkg, we try looking -- for a versioned or unversioned ghc-pkg in the same dir, that is:@@ -392,31 +482,32 @@ -- | Given a single package DB, return all installed packages. getPackageDBContents :: Verbosity- -> PackageDB+ -> Maybe (SymbolicPath CWD (Dir from))+ -> PackageDBX (SymbolicPath from (Dir PkgDB)) -> ProgramDb -> IO InstalledPackageIndex-getPackageDBContents verbosity packagedb progdb = do- pkgss <- getInstalledPackages' verbosity [packagedb] progdb+getPackageDBContents verbosity mbWorkDir packagedb progdb = do+ pkgss <- getInstalledPackages' verbosity mbWorkDir [packagedb] progdb toPackageIndex verbosity pkgss progdb -- | Given a package DB stack, return all installed packages. getInstalledPackages :: Verbosity- -> Compiler- -> PackageDBStack+ -> Maybe (SymbolicPath CWD (Dir from))+ -> PackageDBStackX (SymbolicPath from (Dir PkgDB)) -> ProgramDb -> IO InstalledPackageIndex-getInstalledPackages verbosity comp packagedbs progdb = do+getInstalledPackages verbosity mbWorkDir packagedbs progdb = do checkPackageDbEnvVar verbosity- checkPackageDbStack verbosity comp packagedbs- pkgss <- getInstalledPackages' verbosity packagedbs progdb+ checkPackageDbStack verbosity packagedbs+ pkgss <- getInstalledPackages' verbosity mbWorkDir 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+ PackageIndex.insert rts index _ -> index -- No (or multiple) ghc rts package is registered!! -- Feh, whatever, the ghc test suite does some crazy stuff. @@ -425,7 +516,7 @@ -- 'getInstalledPackages'. toPackageIndex :: Verbosity- -> [(PackageDB, [InstalledPackageInfo])]+ -> [(PackageDBX a, [InstalledPackageInfo])] -> ProgramDb -> IO InstalledPackageIndex toPackageIndex verbosity pkgss progdb = do@@ -488,75 +579,56 @@ checkPackageDbEnvVar verbosity = 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)--checkPackageDbStackPost76 :: Verbosity -> PackageDBStack -> IO ()-checkPackageDbStackPost76 _ (GlobalPackageDB : rest)+checkPackageDbStack :: Eq fp => Verbosity -> PackageDBStackX fp -> IO ()+checkPackageDbStack _ (GlobalPackageDB : rest) | GlobalPackageDB `notElem` rest = return ()-checkPackageDbStackPost76 verbosity rest+checkPackageDbStack verbosity rest | GlobalPackageDB `elem` rest =- dieWithException verbosity CheckPackageDbStackPost76-checkPackageDbStackPost76 _ _ = return ()--checkPackageDbStackPre76 :: Verbosity -> PackageDBStack -> IO ()-checkPackageDbStackPre76 _ (GlobalPackageDB : rest)- | GlobalPackageDB `notElem` rest = return ()-checkPackageDbStackPre76 verbosity rest- | GlobalPackageDB `notElem` rest =- dieWithException verbosity CheckPackageDbStackPre76-checkPackageDbStackPre76 verbosity _ =- dieWithException verbosity GlobalPackageDbSpecifiedFirst---- 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'}+ dieWithException verbosity CheckPackageDbStack+checkPackageDbStack _ _ = return () -- | Get the packages from specific PackageDBs, not cumulative. getInstalledPackages' :: Verbosity- -> [PackageDB]+ -> Maybe (SymbolicPath CWD (Dir from))+ -> [PackageDBX (SymbolicPath from (Dir PkgDB))] -> ProgramDb- -> IO [(PackageDB, [InstalledPackageInfo])]-getInstalledPackages' verbosity packagedbs progdb =+ -> IO [(PackageDBX (SymbolicPath from (Dir PkgDB)), [InstalledPackageInfo])]+getInstalledPackages' verbosity mbWorkDir packagedbs progdb = sequenceA [ do- pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb+ pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity mbWorkDir packagedb return (packagedb, pkgs) | packagedb <- packagedbs ] getInstalledPackagesMonitorFiles- :: Verbosity+ :: forall from+ . Verbosity+ -> Maybe (SymbolicPath CWD (Dir from)) -> Platform -> ProgramDb- -> [PackageDB]+ -> [PackageDBS from] -> IO [FilePath]-getInstalledPackagesMonitorFiles verbosity platform progdb =+getInstalledPackagesMonitorFiles verbosity mbWorkDir platform progdb = traverse getPackageDBPath where- getPackageDBPath :: PackageDB -> IO FilePath+ getPackageDBPath :: PackageDBS from -> IO FilePath getPackageDBPath GlobalPackageDB = selectMonitorFile =<< getGlobalPackageDB verbosity ghcProg getPackageDBPath UserPackageDB = selectMonitorFile =<< getUserPackageDB verbosity ghcProg platform- getPackageDBPath (SpecificPackageDB path) = selectMonitorFile path+ getPackageDBPath (SpecificPackageDB path) = selectMonitorFile (interpretSymbolicPath mbWorkDir path) -- GHC has old style file dbs, and new style directory dbs. -- Note that for dir style dbs, we only need to monitor the cache file, not -- the whole directory. The ghc program itself only reads the cache file -- so it's safe to only monitor this one file.- selectMonitorFile path = do+ selectMonitorFile path0 = do+ let path =+ if isRelative path0+ then interpretSymbolicPath mbWorkDir (makeRelativePathEx path0)+ else path0 isFileStyle <- doesFileExist path if isFileStyle then return path@@ -568,28 +640,38 @@ -- Building a library buildLib- :: BuildFlags+ :: VerbosityHandles+ -> BuildFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO ()-buildLib flags numJobs pkg lbi lib clbi =- GHC.build numJobs pkg $- PreBuildComponentInputs (BuildNormal flags) lbi (TargetInfo clbi (CLib lib))+buildLib verbHandles flags numJobs pkg lbi lib clbi =+ GHC.build numJobs verbHandles pkg $+ PreBuildComponentInputs+ { buildingWhat = BuildNormal flags+ , localBuildInfo = lbi+ , targetInfo = TargetInfo clbi (CLib lib)+ } replLib- :: ReplFlags+ :: VerbosityHandles+ -> ReplFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO ()-replLib flags numJobs pkg lbi lib clbi =- GHC.build numJobs pkg $- PreBuildComponentInputs (BuildRepl flags) lbi (TargetInfo clbi (CLib lib))+replLib verbHandles flags numJobs pkg lbi lib clbi =+ GHC.build numJobs verbHandles pkg $+ PreBuildComponentInputs+ { buildingWhat = BuildRepl flags+ , localBuildInfo = lbi+ , targetInfo = TargetInfo clbi (CLib lib)+ } -- | Start a REPL without loading any source files. startInterpreter@@ -605,9 +687,11 @@ { ghcOptMode = toFlag GhcModeInteractive , ghcOptPackageDBs = packageDBs }- checkPackageDbStack verbosity comp packageDBs+ checkPackageDbStack verbosity packageDBs (ghcProg, _) <- requireProgram verbosity ghcProgram progdb- runGHC verbosity ghcProg comp platform replOpts+ -- This doesn't pass source file arguments to GHC, so we don't have to worry+ -- about using a response file here.+ runGHC verbosity ghcProg comp platform Nothing replOpts -- ----------------------------------------------------------------------------- -- Building an executable or foreign library@@ -622,20 +706,34 @@ -> ComponentLocalBuildInfo -> IO () buildFLib v numJobs pkg lbi flib clbi =- GHC.build numJobs pkg $- PreBuildComponentInputs (BuildNormal mempty{buildVerbosity = toFlag v}) lbi (TargetInfo clbi (CFLib flib))+ GHC.build numJobs (verbosityHandles v) pkg $+ PreBuildComponentInputs+ { buildingWhat =+ BuildNormal $+ mempty+ { buildCommonFlags =+ mempty{setupVerbosity = toFlag $ verbosityFlags v}+ }+ , localBuildInfo = lbi+ , targetInfo = TargetInfo clbi (CFLib flib)+ } replFLib- :: ReplFlags+ :: VerbosityHandles+ -> ReplFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo -> ForeignLib -> ComponentLocalBuildInfo -> IO ()-replFLib replFlags njobs pkg lbi flib clbi =- GHC.build njobs pkg $- PreBuildComponentInputs (BuildRepl replFlags) lbi (TargetInfo clbi (CFLib flib))+replFLib verbHandles replFlags njobs pkg lbi flib clbi =+ GHC.build njobs verbHandles pkg $+ PreBuildComponentInputs+ { buildingWhat = BuildRepl replFlags+ , localBuildInfo = lbi+ , targetInfo = TargetInfo clbi (CFLib flib)+ } -- | Build an executable with GHC. buildExe@@ -647,20 +745,34 @@ -> ComponentLocalBuildInfo -> IO () buildExe v njobs pkg lbi exe clbi =- GHC.build njobs pkg $- PreBuildComponentInputs (BuildNormal mempty{buildVerbosity = toFlag v}) lbi (TargetInfo clbi (CExe exe))+ GHC.build njobs (verbosityHandles v) pkg $+ PreBuildComponentInputs+ { buildingWhat =+ BuildNormal $+ mempty+ { buildCommonFlags =+ mempty{setupVerbosity = toFlag $ verbosityFlags v}+ }+ , localBuildInfo = lbi+ , targetInfo = TargetInfo clbi (CExe exe)+ } replExe- :: ReplFlags+ :: VerbosityHandles+ -> ReplFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO ()-replExe replFlags njobs pkg lbi exe clbi =- GHC.build njobs pkg $- PreBuildComponentInputs (BuildRepl replFlags) lbi (TargetInfo clbi (CExe exe))+replExe verbHandles replFlags njobs pkg lbi exe clbi =+ GHC.build njobs verbHandles pkg $+ PreBuildComponentInputs+ { buildingWhat = BuildRepl replFlags+ , localBuildInfo = lbi+ , targetInfo = TargetInfo clbi (CExe exe)+ } -- | Extracts a String representing a hash of the ABI of a built -- library. It can fail if the library has not yet been built.@@ -676,8 +788,9 @@ libBi = libBuildInfo lib comp = compiler lbi platform = hostPlatform lbi+ mbWorkDir = mbWorkDirLBI lbi vanillaArgs =- (Internal.componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi))+ Internal.componentGhcOptions (verbosityLevel verbosity) lbi libBi clbi (componentBuildDir lbi clbi) `mappend` mempty { ghcOptMode = toFlag GhcModeAbiHash , ghcOptInputModules = toNubListR $ exposedModules lib@@ -703,18 +816,35 @@ , 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"+ profDynArgs =+ vanillaArgs+ `mappend` mempty+ { ghcOptProfilingMode = toFlag True+ , ghcOptProfilingAuto =+ Internal.profDetailLevelFlag+ True+ (withProfLibDetail lbi)+ , ghcOptDynLinkMode = toFlag GhcDynamicOnly+ , ghcOptFPic = toFlag True+ , ghcOptHiSuffix = toFlag "p_dyn_hi"+ , ghcOptObjSuffix = toFlag "p_dyn_o"+ , ghcOptExtra = hcProfSharedOptions GHC libBi+ }+ ghcArgs =+ let (libWays, _, _) = buildWays lbi+ in case libWays (componentIsIndefinite clbi) of+ (ProfDynWay : _) -> profDynArgs+ (ProfWay : _) -> profArgs+ (StaticWay : _) -> vanillaArgs+ (DynWay : _) -> sharedArgs+ _ -> error "libAbiHash: Can't find an enabled library way" (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) hash <- getProgramInvocationOutput verbosity- =<< ghcInvocation verbosity ghcProg comp platform ghcArgs+ =<< ghcInvocation verbosity ghcProg comp platform mbWorkDir ghcArgs return (takeWhile (not . isSpace) hash) @@ -787,10 +917,8 @@ 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) $- dieWithException verbosity $- CantInstallForeignLib+ unless (null (foreignLibVersion flib os)) $ do+ when (os /= Linux) $ dieWithException verbosity CantInstallForeignLib #ifndef mingw32_HOST_OS -- 'createSymbolicLink file1 file2' creates a symbolic link -- named 'file2' which points to the file 'file1'.@@ -799,7 +927,7 @@ -- 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+ withTempDirectory dstDir nm $ \tmpDir -> do let link1 = flibBuildName lbi flib link2 = "lib" ++ nm <.> "so" createSymbolicLink name (tmpDir </> link1)@@ -811,7 +939,7 @@ nm = unUnqualComponentName $ foreignLibName flib #endif /* mingw32_HOST_OS */ --- | Install for ghc, .hi, .a and, if --with-ghci given, .o+-- | Install for ghc, .hi, .a, .so, .bytecodelib and, if --with-ghci given, .o installLib :: Verbosity -> LocalBuildInfo@@ -820,86 +948,112 @@ -> FilePath -- ^ install location for dynamic libraries -> FilePath+ -- ^ install location for bytecode libraries+ -> FilePath -- ^ Build location -> PackageDescription -> Library -> ComponentLocalBuildInfo -> IO ()-installLib verbosity lbi targetDir dynlibTargetDir _builtDir pkg lib clbi = do+installLib verbosity lbi targetDir dynlibTargetDir bytecodeTargetDir _builtDir pkg lib clbi = do+ let+ (wantedLibWays, _, _) = buildWays lbi+ isIndef = componentIsIndefinite clbi+ libWays = wantedLibWays isIndef++ info verbosity ("Wanted install ways: " ++ show libWays)+ -- copy .hi files over:- whenVanilla $ copyModuleFiles $ Suffix "hi"- whenProf $ copyModuleFiles $ Suffix "p_hi"- whenShared $ copyModuleFiles $ Suffix "dyn_hi"+ forM_ (wantedLibWays isIndef) $ \case+ StaticWay -> copyModuleFiles (Suffix "hi")+ DynWay -> copyModuleFiles (Suffix "dyn_hi")+ ProfWay -> copyModuleFiles (Suffix "p_hi")+ ProfDynWay -> copyModuleFiles (Suffix "p_dyn_hi") -- copy extra compilation artifacts that ghc plugins may produce copyDirectoryIfExists extraCompilationArtifacts -- copy the built library files over:- whenHasCode $ do- whenVanilla $ do- sequence_- [ installOrdinary+ when (has_code && hasLib) $ do+ -- Bytecode libraries are installed in bytecodelibdir and are copied+ -- without stripping; see doc/internal/bytecode-libraries.md.+ whenBytecodeLib $ installOrdinaryNoStrip builtDir bytecodeTargetDir bytecodeLibName++ forM_ libWays $ \case+ StaticWay -> do+ sequence_+ [ installOrdinary+ builtDir+ targetDir+ (mkGenericStaticLibName (l ++ f))+ | l <-+ getHSLibraryName+ (componentUnitId clbi)+ : extraBundledLibs (libBuildInfo lib)+ , f <- "" : extraLibFlavours (libBuildInfo lib)+ ]+ whenGHCi $ installOrdinary builtDir targetDir ghciLibName+ ProfWay -> do+ installOrdinary builtDir targetDir profileLibName+ whenGHCi $ installOrdinary builtDir targetDir ghciProfLibName+ ProfDynWay -> do+ installShared 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- 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)- ]+ dynlibTargetDir+ (mkProfSharedLibName platform compiler_id uid)+ DynWay -> do+ 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 <- listDirectory (i builtDir)+ let l' =+ mkGenericSharedBundledLibName+ platform+ compiler_id+ (l ++ f)+ forM_ files $ \file ->+ when (l' `isPrefixOf` file) $ do+ isFile <- doesFileExist (i $ builtDir </> makeRelativePathEx file)+ when isFile $ do+ installShared+ builtDir+ dynlibTargetDir+ file+ | l <- extraBundledLibs (libBuildInfo lib)+ , f <- "" : extraDynLibFlavours (libBuildInfo lib)+ ] where+ -- See Note [Symbolic paths] in Distribution.Utils.Path+ i = interpretSymbolicPathLBI lbi+ builtDir = componentBuildDir lbi clbi+ mbWorkDir = mbWorkDirLBI lbi - install isShared srcDir dstDir name = do- let src = srcDir </> name+ install isShared shouldStrip srcDir dstDir name = do+ let src = i $ srcDir </> makeRelativePathEx name dst = dstDir </> name createDirectoryIfMissingVerbose verbosity True dstDir@@ -908,23 +1062,26 @@ then installExecutableFile verbosity src dst else installOrdinaryFile verbosity src dst - when (stripLibs lbi) $+ when (shouldStrip && stripLibs lbi) $ Strip.stripLib verbosity platform (withPrograms lbi) dst - installOrdinary = install False- installShared = install True+ installOrdinary = install False True+ installOrdinaryNoStrip = install False False+ installShared = install True True - copyModuleFiles ext =- findModuleFilesEx verbosity [builtDir] [ext] (allLibModules lib clbi)- >>= installOrdinaryFiles verbosity targetDir+ copyModuleFiles ext = do+ files <- findModuleFilesCwd verbosity mbWorkDir [builtDir] [ext] (allLibModules lib clbi)+ let files' = map (i *** getSymbolicPath) files+ installOrdinaryFiles verbosity targetDir files' + copyDirectoryIfExists :: RelativePath Build (Dir Artifacts) -> IO () copyDirectoryIfExists dirName = do- let src = builtDir </> dirName- dst = targetDir </> dirName+ let src = i $ builtDir </> dirName+ dst = targetDir </> getSymbolicPath dirName dirExists <- doesDirectoryExist src when dirExists $ copyDirectoryRecursive verbosity src dst @@ -932,6 +1089,7 @@ platform = hostPlatform lbi uid = componentUnitId clbi profileLibName = mkProfLibName uid+ bytecodeLibName = mkBytecodeLibName compiler_id uid ghciLibName = Internal.mkGHCiLibName uid ghciProfLibName = Internal.mkGHCiProfLibName uid @@ -947,50 +1105,35 @@ Platform JavaScript _ -> True _ -> 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)+ whenBytecodeLib = when (hasLib && withBytecodeLib lbi && has_code) -- ----------------------------------------------------------------------------- -- Registering -hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo+hcPkgInfo :: ProgramDb -> HcPkg.ConfiguredProgram 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- ghcPkgProg = fromMaybe (error "GHC.hcPkgInfo: no ghc program") $ lookupProgram ghcPkgProgram progdb- ver = fromMaybe (error "GHC.hcPkgInfo: no ghc version") $ programVersion ghcPkgProg+ fromMaybe (error "GHC.hcPkgInfo: no ghc program") $ lookupProgram ghcPkgProgram progdb registerPackage :: Verbosity -> ProgramDb- -> PackageDBStack+ -> Maybe (SymbolicPath CWD (Dir from))+ -> PackageDBStackS from -> InstalledPackageInfo -> HcPkg.RegisterOptions -> IO ()-registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions =+registerPackage verbosity progdb mbWorkDir packageDbs installedPkgInfo registerOptions = HcPkg.register (hcPkgInfo progdb) verbosity+ mbWorkDir packageDbs installedPkgInfo registerOptions -pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath-pkgRoot verbosity lbi = pkgRoot'+pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO (SymbolicPath CWD (Dir Pkg))+pkgRoot verbosity lbi = fmap makeSymbolicPath . pkgRoot' where pkgRoot' GlobalPackageDB = let ghcProg = fromMaybe (error "GHC.pkgRoot: no ghc program") $ lookupProgram ghcProgram (withPrograms lbi)@@ -1006,9 +1149,12 @@ : 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+ -- does not yet exist. Otherwise '${pkgroot}' will resolve to a -- directory at the time of 'ghc-pkg register', and registration will -- fail. createDirectoryIfMissing True rootDir return rootDir- pkgRoot' (SpecificPackageDB fp) = return (takeDirectory fp)+ pkgRoot' (SpecificPackageDB fp) =+ return $+ takeDirectory $+ interpretSymbolicPathLBI lbi fp
src/Distribution/Simple/GHC/Build.hs view
@@ -1,30 +1,37 @@+{-# LANGUAGE DataKinds #-}+ module Distribution.Simple.GHC.Build where import Distribution.Compat.Prelude import Prelude () -import Control.Monad.IO.Class-import qualified Data.Set as Set+import qualified Distribution.Compat.Graph as Graph+ import Distribution.PackageDescription as PD hiding (buildInfo) import Distribution.Simple.Build.Inputs import Distribution.Simple.Flag (Flag) import Distribution.Simple.GHC.Build.ExtraSources import Distribution.Simple.GHC.Build.Link import Distribution.Simple.GHC.Build.Modules-import Distribution.Simple.GHC.Build.Utils (withDynFLib)+import Distribution.Simple.GHC.Build.Utils (compilerBuildWay, isHaskell, withDynFLib) import Distribution.Simple.LocalBuildInfo-import Distribution.Simple.Program+import Distribution.Simple.Program.Builtin (ghcProgram)+import Distribution.Simple.Program.Db (requireProgram) import Distribution.Simple.Utils-import Distribution.Types.ComponentLocalBuildInfo (componentIsIndefinite)++import Distribution.Types.ComponentLocalBuildInfo+import Distribution.Types.PackageName.Magic (fakePackageId) import Distribution.Types.ParStrat import Distribution.Utils.NubList (fromNubListR)-import System.Directory hiding (exeExtension)-import System.FilePath+import Distribution.Utils.Path -{--Note [Build Target Dir vs Target Dir]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+import Distribution.Verbosity (VerbosityHandles, mkVerbosity, verbosityHandles) +import Control.Monad.IO.Class+import System.FilePath (splitDirectories)++{- Note [Build Target Dir vs Target Dir]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Where to place the build result (targetDir) and the build artifacts (buildTargetDir). \* For libraries, targetDir == buildTargetDir, where both the library and@@ -47,7 +54,7 @@ invocations that different OSes constrain us to. Cabal invocations can rapidly reach this limit, in part, due to the long length of cabal v2 prefixes. To minimize the likelihood, we use-`makeRelativeToCurrentDirectory` to shorten the paths used in invocations+`tryMakeRelativeToWorkingDir` to shorten the paths used in invocations (see da6321bb). However, in executables, we don't do this. It seems that we don't need to do it@@ -61,80 +68,120 @@ -- Includes building Haskell modules, extra build sources, and linking. build :: Flag ParStrat+ -> VerbosityHandles -> PackageDescription -> PreBuildComponentInputs -- ^ The context and component being built in it. -> IO ()-build numJobs pkg_descr pbci = do+build numJobs verbHandles pkg_descr pbci = do let- verbosity = buildVerbosity pbci- component = buildComponent pbci+ verbosity = mkVerbosity verbHandles $ buildVerbosity pbci isLib = buildIsLib pbci lbi = localBuildInfo pbci+ comp = buildComponent pbci clbi = buildCLBI pbci+ isIndef = componentIsIndefinite clbi+ mbWorkDir = mbWorkDirLBI lbi+ i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path -- Create a few directories for building the component -- See Note [Build Target Dir vs Target Dir]- let targetDir_absolute = componentBuildDir lbi clbi- buildTargetDir_absolute+ let targetDir0 :: SymbolicPath Pkg ('Dir Build)+ targetDir0 = componentBuildDir lbi clbi+ buildTargetDir0 :: SymbolicPath Pkg ('Dir Artifacts)+ buildTargetDir0 -- Libraries use the target dir for building (see above)- | isLib = targetDir_absolute+ | isLib = coerceSymbolicPath targetDir0 -- In other cases, use targetDir/<name-of-target-dir>-tmp- | targetDirName : _ <- reverse $ splitDirectories targetDir_absolute =- targetDir_absolute </> (targetDirName ++ "-tmp")+ | targetDirName : _ <- reverse $ splitDirectories $ getSymbolicPath targetDir0 =+ coerceSymbolicPath targetDir0 </> makeRelativePathEx (targetDirName ++ "-tmp") | otherwise = error "GHC.build: targetDir is empty" liftIO $ do- createDirectoryIfMissingVerbose verbosity True targetDir_absolute- createDirectoryIfMissingVerbose verbosity True buildTargetDir_absolute+ createDirectoryIfMissingVerbose verbosity True $ i targetDir0+ createDirectoryIfMissingVerbose verbosity True $ i buildTargetDir0 -- See Note [Build Target Dir vs Target Dir] as well- _targetDir <- liftIO $ makeRelativeToCurrentDirectory targetDir_absolute+ let targetDir = targetDir0 -- NB: no 'makeRelative' buildTargetDir <-- -- To preserve the previous behaviour, we don't use relative dirs for- -- executables. Historically, this isn't needed to reduce the CLI limit- -- (unlike for libraries) because we link executables with the module names- -- instead of passing the path to object file -- that's something else we- -- can now fix after the refactor lands. if isLib- then liftIO $ makeRelativeToCurrentDirectory buildTargetDir_absolute- else return buildTargetDir_absolute+ then -- NB: this might fail to make the buildTargetDir relative,+ -- as noted in #9776. Oh well.+ tryMakeRelative mbWorkDir buildTargetDir0+ else return buildTargetDir0+ -- To preserve the previous behaviour, we don't use relative dirs for+ -- executables. Historically, this isn't needed to reduce the CLI limit+ -- (unlike for libraries) because we link executables with the module names+ -- instead of passing the path to object file -- that's something else we+ -- can now fix after the refactor lands. (ghcProg, _) <- liftIO $ requireProgram verbosity ghcProgram (withPrograms lbi) - -- Determine in which ways we want to build the component- let- wantVanilla = if isLib then withVanillaLib lbi else False- -- Arguably, wantStatic should be "withFullyStaticExe lbi" for executables,- -- but it was not before the refactor.- wantStatic = if isLib then withStaticLib lbi else not (wantDynamic || wantProf)- wantDynamic = case component of- CLib{} -> withSharedLib lbi- CFLib flib -> withDynFLib flib- CExe{} -> withDynExe lbi- CTest{} -> withDynExe lbi- CBench{} -> withDynExe lbi- wantProf = if isLib then withProfLib lbi else withProfExe lbi+ -- Ways which are wanted from configuration flags+ let wantedWays@(wantedLibWays, wantedFLibWay, wantedExeWay) = buildWays lbi - -- See also Note [Building Haskell Modules accounting for TH] in Distribution.Simple.GHC.Build.Modules- -- We build static by default if no other way is wanted.- -- For executables and foreign libraries, there should only be one wanted way.- wantedWays =- Set.fromList $- -- If building a library, we accumulate all the ways,- -- otherwise, we take just one.- (if isLib then id else take 1) $- [ProfWay | wantProf]- -- I don't see why we shouldn't build with dynamic- -- indefinite components.- <> [DynWay | wantDynamic && not (componentIsIndefinite clbi)]- <> [StaticWay | wantStatic || wantVanilla || not (wantDynamic || wantProf)]+ -- Ways which are needed due to the compiler configuration+ let doingTH =+ -- Does this component, or another component that (transitively) depends+ -- on this component, use TemplateHaskell or QuasiQuotes?+ --+ -- Ticket #7684 showed that we need to take into account intra-package+ -- dependencies.+ any usesTemplateHaskellOrQQ thisCompAndReverseDepsBuildInfos - liftIO $ info verbosity ("Wanted build ways: " ++ show (Set.toList wantedWays))+ -- The BuildInfos for this component and all of the components that+ -- transitively depend on it (its reverse dependencies).+ thisCompAndReverseDepsBuildInfos =+ [ componentBuildInfo revDepComp+ | let compUnitId = componentUnitId clbi+ , -- 'revClosure' retrieves components that depend on this component.+ revDepCLBI <- fromMaybe [clbi] $ Graph.revClosure (componentGraph lbi) [compUnitId]+ , -- Use 'lookupComponent' here; don't use any function that goes via+ -- 'getComponent' (e.g. mkTargetInfo or unitIdTarget'), as that will+ -- tiresomely cause an error for 'detailed-0.9' test-suites because+ -- 'testSuiteLibV09AsLibAndExe' creates a stub PackageDescription with+ -- most components zeroed out.+ --+ -- The implementation below means we will get 'Nothing' when the+ -- current component is a 'detailed-0.9' test-suite, which is fine+ -- as nothing can depend on a test-suite.+ Just revDepComp <- [lookupComponent pkg_descr $ componentLocalName revDepCLBI]+ ] + defaultGhcWay = compilerBuildWay (buildCompiler pbci)+ wantedModBuildWays = case comp of+ CLib _ -> wantedLibWays isIndef+ CFLib fl -> [wantedFLibWay (withDynFLib fl)]+ CExe _ -> [wantedExeWay]+ CTest _ -> [wantedExeWay]+ CBench _ -> [wantedExeWay]+ finalModBuildWays =+ wantedModBuildWays+ ++ [defaultGhcWay | doingTH && defaultGhcWay `notElem` wantedModBuildWays]+ compNameStr = showComponentName $ componentName comp++ liftIO $ info verbosity ("Wanted module build ways(" ++ compNameStr ++ "): " ++ show wantedModBuildWays)+ liftIO $ info verbosity ("Final module build ways(" ++ compNameStr ++ "): " ++ show finalModBuildWays) -- We need a separate build and link phase, and C sources must be compiled -- after Haskell modules, because C sources may depend on stub headers -- generated from compiling Haskell modules (#842, #3294).- buildOpts <- buildHaskellModules numJobs ghcProg pkg_descr buildTargetDir_absolute wantedWays pbci- extraSources <- buildAllExtraSources ghcProg buildTargetDir pbci- linkOrLoadComponent ghcProg pkg_descr (fromNubListR extraSources) (buildTargetDir, targetDir_absolute) (wantedWays, buildOpts) pbci+ (mbMainFile, inputModules) <- componentInputs buildTargetDir verbHandles pkg_descr pbci+ let (hsMainFile, nonHsMainFile) =+ case mbMainFile of+ Just mainFile+ | PD.package pkg_descr == fakePackageId+ || isHaskell (getSymbolicPath mainFile) ->+ (Just mainFile, Nothing)+ | otherwise ->+ (Nothing, Just mainFile)+ Nothing -> (Nothing, Nothing)+ buildOpts <- buildHaskellModules numJobs ghcProg hsMainFile inputModules buildTargetDir finalModBuildWays verbHandles pbci+ extraSources <- buildAllExtraSources nonHsMainFile ghcProg buildTargetDir wantedWays verbHandles pbci+ linkOrLoadComponent+ ghcProg+ (verbosityHandles verbosity)+ pkg_descr+ (fromNubListR extraSources)+ (buildTargetDir, targetDir)+ (wantedWays, buildOpts)+ pbci
src/Distribution/Simple/GHC/Build/ExtraSources.hs view
@@ -1,6 +1,8 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-} module Distribution.Simple.GHC.Build.ExtraSources where @@ -8,6 +10,7 @@ import Data.Foldable import Distribution.Simple.Flag import qualified Distribution.Simple.GHC.Internal as Internal+import Distribution.Simple.Program import Distribution.Simple.Program.GHC import Distribution.Simple.Utils import Distribution.Utils.NubList@@ -16,26 +19,32 @@ import Distribution.Types.Component import Distribution.Types.TargetInfo +import Distribution.Simple.Build.Inputs+import Distribution.Simple.BuildWay import Distribution.Simple.GHC.Build.Utils import Distribution.Simple.LocalBuildInfo-import Distribution.Simple.Program.Types+import Distribution.Simple.Setup.Common (commonSetupTempFileOptions) import Distribution.System (Arch (JavaScript), Platform (..)) import Distribution.Types.ComponentLocalBuildInfo-import Distribution.Types.Executable-import Distribution.Verbosity (Verbosity)--import Distribution.Simple.Build.Inputs+import Distribution.Utils.Path+import Distribution.Verbosity (VerbosityHandles, VerbosityLevel, mkVerbosity, verbosityLevel) -- | An action that builds all the extra build sources of a component, i.e. C, -- C++, Js, Asm, C-- sources. buildAllExtraSources- :: ConfiguredProgram+ :: Maybe (SymbolicPath Pkg File)+ -- ^ An optional non-Haskell Main file+ -> ConfiguredProgram -- ^ The GHC configured program- -> FilePath+ -> SymbolicPath Pkg (Dir Artifacts) -- ^ The build directory for this target+ -> (Bool -> [BuildWay], Bool -> BuildWay, BuildWay)+ -- ^ Needed build ways+ -> VerbosityHandles+ -- ^ Logging handles -> PreBuildComponentInputs -- ^ The context and component being built in it.- -> IO (NubListR FilePath)+ -> IO (NubListR (SymbolicPath Pkg File)) -- ^ Returns the (nubbed) list of extra sources that were built buildAllExtraSources = mconcat@@ -51,43 +60,52 @@ , buildJsSources , buildAsmSources , buildCmmSources- :: ConfiguredProgram+ :: Maybe (SymbolicPath Pkg File)+ -- ^ An optional non-Haskell Main file+ -> ConfiguredProgram -- ^ The GHC configured program- -> FilePath+ -> SymbolicPath Pkg (Dir Artifacts) -- ^ The build directory for this target+ -> (Bool -> [BuildWay], Bool -> BuildWay, BuildWay)+ -- ^ Needed build ways+ -> VerbosityHandles+ -- ^ Logging handles -> PreBuildComponentInputs -- ^ The context and component being built in it.- -> IO (NubListR FilePath)+ -> IO (NubListR (SymbolicPath Pkg File)) -- ^ Returns the list of extra sources that were built-buildCSources =+buildCSources mbMainFile = buildExtraSources "C Sources"- Internal.componentCcGhcOptions- True- ( \c ->- cSources (componentBuildInfo c)- ++ case c of- CExe exe | isC (modulePath exe) -> [modulePath exe]- _otherwise -> []+ (Internal.splitCandCxxOptions Internal.CcProgram)+ ( \c -> do+ let cFiles = cSources (componentBuildInfo c)+ case c of+ CExe{}+ | Just main <- mbMainFile+ , isC $ getSymbolicPath main ->+ cFiles ++ [main]+ _otherwise -> cFiles )-buildCxxSources =+buildCxxSources mbMainFile = buildExtraSources "C++ Sources"- Internal.componentCxxGhcOptions- True- ( \c ->- cxxSources (componentBuildInfo c)- ++ case c of- CExe exe | isCxx (modulePath exe) -> [modulePath exe]- _otherwise -> []+ (Internal.splitCandCxxOptions Internal.CxxProgram)+ ( \c -> do+ let cxxFiles = cxxSources (componentBuildInfo c)+ case c of+ CExe{}+ | Just main <- mbMainFile+ , isCxx $ getSymbolicPath main ->+ cxxFiles ++ [main]+ _otherwise -> cxxFiles )-buildJsSources ghcProg buildTargetDir = do+buildJsSources _mbMainFile ghcProg buildTargetDir neededWays verbHandles = do Platform hostArch _ <- hostPlatform <$> localBuildInfo let hasJsSupport = hostArch == JavaScript buildExtraSources "JS Sources"- Internal.componentJsGhcOptions- False+ Internal.sourcesGhcOptions ( \c -> if hasJsSupport then -- JS files are C-like with GHC's JS backend: they are@@ -99,17 +117,17 @@ ) ghcProg buildTargetDir-buildAsmSources =+ neededWays+ verbHandles+buildAsmSources _mbMainFile = buildExtraSources "Assembler Sources"- Internal.componentAsmGhcOptions- True+ Internal.sourcesGhcOptions (asmSources . componentBuildInfo)-buildCmmSources =+buildCmmSources _mbMainFile = buildExtraSources "C-- Sources"- Internal.componentCmmGhcOptions- True+ Internal.sourcesGhcOptions (cmmSources . componentBuildInfo) -- | Create 'PreBuildComponentRules' for a given type of extra build sources@@ -118,16 +136,17 @@ buildExtraSources :: String -- ^ String describing the extra sources being built, for printing.- -> (Verbosity -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> FilePath -> GhcOptions)+ -> ( VerbosityLevel+ -> LocalBuildInfo+ -> BuildInfo+ -> ComponentLocalBuildInfo+ -> SymbolicPath Pkg (Dir Artifacts)+ -> SymbolicPath Pkg File+ -> GhcOptions+ ) -- ^ Function to determine the @'GhcOptions'@ for the- -- invocation of GHC when compiling these extra sources (e.g.- -- @'Internal.componentCxxGhcOptions'@,- -- @'Internal.componentCmmGhcOptions'@)- -> Bool- -- ^ Some types of build sources should not be built in the dynamic way, namely, JS sources.- -- I'm not entirely sure this remains true after we migrate to supporting GHC's JS backend rather than GHCJS.- -- Boolean for "do we allow building these sources the dynamic way?"- -> (Component -> [FilePath])+ -- invocation of GHC when compiling these extra sources+ -> (Component -> [SymbolicPath Pkg File]) -- ^ View the extra sources of a component, typically from -- the build info (e.g. @'asmSources'@, @'cSources'@). -- @'Executable'@ components might additionally add the@@ -135,106 +154,123 @@ -- if it should be compiled as the rest of them. -> ConfiguredProgram -- ^ The GHC configured program- -> FilePath+ -> SymbolicPath Pkg (Dir Artifacts) -- ^ The build directory for this target+ -> (Bool -> [BuildWay], Bool -> BuildWay, BuildWay)+ -- ^ Needed build ways+ -> VerbosityHandles+ -- ^ Handles for logging -> PreBuildComponentInputs -- ^ The context and component being built in it.- -> IO (NubListR FilePath)+ -> IO (NubListR (SymbolicPath Pkg File)) -- ^ Returns the list of extra sources that were built-buildExtraSources description componentSourceGhcOptions wantDyn viewSources ghcProg buildTargetDir =- \PreBuildComponentInputs{buildingWhat, localBuildInfo = lbi, targetInfo} ->- let- bi = componentBuildInfo (targetComponent targetInfo)- verbosity = buildingWhatVerbosity buildingWhat- clbi = targetCLBI targetInfo-- sources = viewSources (targetComponent targetInfo)+buildExtraSources+ description+ componentSourceGhcOptions+ viewSources+ ghcProg+ buildTargetDir+ (neededLibWays, neededFLibWay, neededExeWay)+ verbHandles =+ \PreBuildComponentInputs{buildingWhat, localBuildInfo = lbi, targetInfo} -> do+ let+ bi = componentBuildInfo (targetComponent targetInfo)+ verbosity = mkVerbosity verbHandles $ buildingWhatVerbosity buildingWhat+ clbi = targetCLBI targetInfo+ isIndef = componentIsIndefinite clbi+ mbWorkDir = mbWorkDirLBI lbi+ i = interpretSymbolicPath mbWorkDir+ sources = viewSources (targetComponent targetInfo)+ comp = compiler lbi+ platform = hostPlatform lbi+ tempFileOptions = commonSetupTempFileOptions $ buildingWhatCommonFlags buildingWhat+ runGhcProg =+ runGHCWithResponseFile+ "ghc.rsp"+ Nothing+ tempFileOptions+ verbosity+ ghcProg+ comp+ platform+ mbWorkDir - comp = compiler lbi- platform = hostPlatform lbi- -- Instead of keeping this logic here, we really just want to- -- receive as an input the `neededWays` from GHC/Build.build and build- -- accordingly, since we've already determined the extra needed ways- -- needed for e.g. template haskell. Although we'd have to account for 'wantDyn'.- isGhcDynamic = isDynamic comp- doingTH = usesTemplateHaskellOrQQ bi- forceSharedLib = doingTH && isGhcDynamic- runGhcProg = runGHC verbosity ghcProg comp platform+ buildAction :: SymbolicPath Pkg File -> IO ()+ buildAction sourceFile = do+ let baseSrcOpts =+ componentSourceGhcOptions+ (verbosityLevel verbosity)+ lbi+ bi+ clbi+ buildTargetDir+ sourceFile+ vanillaSrcOpts =+ -- -fPIC is used in case you are using the repl+ -- of a dynamically linked GHC+ baseSrcOpts{ghcOptFPic = toFlag True}+ profSrcOpts =+ vanillaSrcOpts+ `mappend` mempty+ { ghcOptProfilingMode = toFlag True+ }+ sharedSrcOpts =+ vanillaSrcOpts+ `mappend` mempty+ { ghcOptFPic = toFlag True+ , ghcOptDynLinkMode = toFlag GhcDynamicOnly+ }+ profSharedSrcOpts =+ vanillaSrcOpts+ `mappend` mempty+ { ghcOptProfilingMode = toFlag True+ , ghcOptFPic = toFlag True+ , ghcOptDynLinkMode = toFlag GhcDynamicOnly+ }+ -- 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 vanillaSrcOpts) - buildAction sourceFile = do- let baseSrcOpts =- componentSourceGhcOptions- verbosity- lbi- bi- clbi- buildTargetDir- sourceFile- vanillaSrcOpts- -- Dynamic GHC requires C sources to be built- -- with -fPIC for REPL to work. See #2207.- | isGhcDynamic && wantDyn = baseSrcOpts{ghcOptFPic = toFlag True}- | otherwise = baseSrcOpts- profSrcOpts =- vanillaSrcOpts- `mappend` mempty- { ghcOptProfilingMode = toFlag True- }- sharedSrcOpts =- vanillaSrcOpts- `mappend` mempty- { ghcOptFPic = toFlag True- , ghcOptDynLinkMode = toFlag GhcDynamicOnly- }- -- 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 vanillaSrcOpts)- compileIfNeeded opts = do- needsRecomp <- checkNeedsRecompilation sourceFile opts- when needsRecomp $ runGhcProg opts+ compileIfNeeded :: GhcOptions -> IO ()+ compileIfNeeded opts = do+ needsRecomp <- checkNeedsRecompilation mbWorkDir sourceFile opts+ when needsRecomp $ runGhcProg opts - -- TODO: This whole section can be streamlined to the- -- wantedWays+neededWays logic used in Build/Modules.hs- createDirectoryIfMissingVerbose verbosity True odir- case targetComponent targetInfo of- -- For libraries, we compile extra objects in the three ways: vanilla, shared, and profiled.- -- We suffix shared objects with .dyn_o and profiled ones with .p_o.- CLib _lib- -- Unless for repl, in which case we only need the vanilla way- | BuildRepl _ <- buildingWhat ->- compileIfNeeded vanillaSrcOpts- | otherwise ->- do+ createDirectoryIfMissingVerbose verbosity True (i odir)+ case targetComponent targetInfo of+ -- For libraries, we compile extra objects in the four ways: vanilla, shared, profiled and profiled shared.+ -- We suffix shared objects with `.dyn_o`, profiled ones with `.p_o` and profiled shared ones with `.p_dyn_o`.+ CLib _lib+ -- Unless for repl, in which case we only need the vanilla way+ | BuildRepl _ <- buildingWhat -> compileIfNeeded vanillaSrcOpts- when (wantDyn && (forceSharedLib || withSharedLib lbi)) $- compileIfNeeded sharedSrcOpts{ghcOptObjSuffix = toFlag "dyn_o"}- when (withProfLib lbi) $- compileIfNeeded profSrcOpts{ghcOptObjSuffix = toFlag "p_o"}+ | otherwise ->+ do+ forM_ (neededLibWays isIndef) $ \case+ StaticWay -> compileIfNeeded vanillaSrcOpts+ DynWay -> compileIfNeeded sharedSrcOpts{ghcOptObjSuffix = toFlag "dyn_o"}+ ProfWay -> compileIfNeeded profSrcOpts{ghcOptObjSuffix = toFlag "p_o"}+ ProfDynWay -> compileIfNeeded profSharedSrcOpts{ghcOptObjSuffix = toFlag "p_dyn_o"}+ CFLib flib ->+ case neededFLibWay (withDynFLib flib) of+ StaticWay -> compileIfNeeded vanillaSrcOpts+ DynWay -> compileIfNeeded sharedSrcOpts+ ProfWay -> compileIfNeeded profSrcOpts+ ProfDynWay -> compileIfNeeded profSharedSrcOpts+ -- For the remaining component types (Exec, Test, Bench), we also+ -- determine with which options to build the objects (vanilla vs shared vs+ -- profiled), but predicate is the same for the three kinds.+ _exeLike ->+ case neededExeWay of+ StaticWay -> compileIfNeeded vanillaSrcOpts+ DynWay -> compileIfNeeded sharedSrcOpts+ ProfWay -> compileIfNeeded profSrcOpts+ ProfDynWay -> compileIfNeeded profSharedSrcOpts - -- For foreign libraries, we determine with which options to build the- -- objects (vanilla vs shared vs profiled)- CFLib flib- | withProfExe lbi -> -- It doesn't sound right to query "ProfExe" for a foreign library...- compileIfNeeded profSrcOpts- | withDynFLib flib && wantDyn ->- compileIfNeeded sharedSrcOpts- | otherwise ->- compileIfNeeded vanillaSrcOpts- -- For the remaining component types (Exec, Test, Bench), we also- -- determine with which options to build the objects (vanilla vs shared vs- -- profiled), but predicate is the same for the three kinds.- _exeLike- | withProfExe lbi ->- compileIfNeeded profSrcOpts- | withDynExe lbi && wantDyn ->- compileIfNeeded sharedSrcOpts- | otherwise ->- compileIfNeeded vanillaSrcOpts- in -- build any sources- if (null sources || componentIsIndefinite clbi)+ if null sources || componentIsIndefinite clbi then return mempty else do info verbosity ("Building " ++ description ++ "...")
src/Distribution/Simple/GHC/Build/Link.hs view
@@ -1,21 +1,22 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-} module Distribution.Simple.GHC.Build.Link where import Distribution.Compat.Prelude import Prelude () -import Control.Exception (assert)-import Control.Monad (forM_)+import Control.Monad import Control.Monad.IO.Class import qualified Data.ByteString.Lazy.Char8 as BS import qualified Data.Set as Set+import Distribution.Backpack import Distribution.Compat.Binary (encode) import Distribution.Compat.ResponseFile import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as IPI import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo-import qualified Distribution.ModuleName as ModuleName import Distribution.Package import Distribution.PackageDescription as PD import Distribution.PackageDescription.Utils (cabalBug)@@ -23,27 +24,42 @@ import Distribution.Simple.Build.Inputs import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler+import Distribution.Simple.Errors import Distribution.Simple.GHC.Build.Modules-import Distribution.Simple.GHC.Build.Utils (exeTargetName, flibBuildName, flibTargetName, withDynFLib)+import Distribution.Simple.GHC.Build.Utils+ ( exeTargetName+ , flibBuildName+ , flibTargetName+ , objectFilePath+ , withDynFLib+ ) import Distribution.Simple.GHC.ImplInfo import qualified Distribution.Simple.GHC.Internal as Internal import Distribution.Simple.LocalBuildInfo import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.PreProcess.Types import Distribution.Simple.Program import qualified Distribution.Simple.Program.Ar as Ar import Distribution.Simple.Program.GHC import qualified Distribution.Simple.Program.Ld as Ld import Distribution.Simple.Setup.Common+import Distribution.Simple.Setup.Config import Distribution.Simple.Setup.Repl import Distribution.Simple.Utils import Distribution.System import Distribution.Types.ComponentLocalBuildInfo import Distribution.Utils.NubList+import Distribution.Utils.Path import Distribution.Verbosity import Distribution.Version+ import System.Directory+ ( createDirectoryIfMissing+ , doesDirectoryExist+ , renameFile+ ) import System.FilePath+ ( isRelative+ ) -- | Links together the object files of the Haskell modules and extra sources -- using the context in which the component is being built.@@ -52,178 +68,224 @@ linkOrLoadComponent :: ConfiguredProgram -- ^ The configured GHC program that will be used for linking+ -> VerbosityHandles+ -- ^ Handles used for logging -> PackageDescription -- ^ The package description containing the component being built- -> [FilePath]+ -> [SymbolicPath Pkg File] -- ^ The full list of extra build sources (all C, C++, Js, -- Asm, and Cmm sources), which were compiled to object -- files.- -> (FilePath, FilePath)+ -> (SymbolicPath Pkg (Dir Artifacts), SymbolicPath Pkg (Dir Build)) -- ^ The build target dir, and the target dir. -- See Note [Build Target Dir vs Target Dir] in Distribution.Simple.GHC.Build- -> (Set.Set BuildWay, BuildWay -> GhcOptions)+ -> ((Bool -> [BuildWay], Bool -> BuildWay, BuildWay), BuildWay -> GhcOptions) -- ^ The set of build ways wanted based on the user opts, and a function to -- convert a build way into the set of ghc options that were used to build -- that way. -> PreBuildComponentInputs -- ^ The context and component being built in it. -> IO ()-linkOrLoadComponent ghcProg pkg_descr extraSources (buildTargetDir, targetDir) (wantedWays, buildOpts) pbci = do- let- verbosity = buildVerbosity pbci- target = targetInfo pbci- component = buildComponent pbci- what = buildingWhat pbci- lbi = localBuildInfo pbci- bi = buildBI pbci- clbi = buildCLBI pbci+linkOrLoadComponent+ ghcProg+ verbHandles+ pkg_descr+ extraSources+ (buildTargetDir, targetDir)+ ((wantedLibWays, wantedFLibWay, wantedExeWay), buildOpts)+ pbci = do+ let+ verbosity = mkVerbosity verbHandles $ buildVerbosity pbci+ target = targetInfo pbci+ component = buildComponent pbci+ what = buildingWhat pbci+ lbi = localBuildInfo pbci+ bi = buildBI pbci+ clbi = buildCLBI pbci+ isIndef = componentIsIndefinite clbi+ mbWorkDir = mbWorkDirLBI lbi+ tempFileOptions = commonSetupTempFileOptions $ buildingWhatCommonFlags what - -- ensure extra lib dirs exist before passing to ghc- cleanedExtraLibDirs <- liftIO $ filterM doesDirectoryExist (extraLibDirs bi)- cleanedExtraLibDirsStatic <- liftIO $ filterM doesDirectoryExist (extraLibDirsStatic bi)+ -- See Note [Symbolic paths] in Distribution.Utils.Path+ i = interpretSymbolicPathLBI lbi - let- extraSourcesObjs = map (`replaceExtension` objExtension) extraSources+ -- ensure extra lib dirs exist before passing to ghc+ cleanedExtraLibDirs <- liftIO $ filterM (doesDirectoryExist . i) (extraLibDirs bi)+ cleanedExtraLibDirsStatic <- liftIO $ filterM (doesDirectoryExist . i) (extraLibDirsStatic bi) - -- TODO: Shouldn't we use withStaticLib for libraries and something else- -- for foreign libs in the three cases where we use `withFullyStaticExe` below?- linkerOpts rpaths =- mempty- { ghcOptLinkOptions =- PD.ldOptions bi- ++ [ "-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 bi- else extraLibs bi- , ghcOptLinkLibPath =- toNubListR $+ let+ extraSourcesObjs :: [SymbolicPath Pkg File]+ extraSourcesObjs =+ [ objectFilePath buildTargetDir objExtension src+ | src <- extraSources+ ]++ -- TODO: Shouldn't we use withStaticLib for libraries and something else+ -- for foreign libs in the three cases where we use `withFullyStaticExe` below?+ linkerOpts rpaths =+ mempty+ { ghcOptLinkOptions =+ [ "-static"+ | withFullyStaticExe lbi+ ]+ -- Pass extra `ld-options` given+ -- through to GHC's linker.+ ++ maybe+ []+ programOverrideArgs+ (lookupProgram ldProgram (withPrograms lbi))+ , ghcOptLinkLibs = if withFullyStaticExe lbi- then cleanedExtraLibDirsStatic- else cleanedExtraLibDirs- , ghcOptLinkFrameworks = toNubListR $ PD.frameworks bi- , ghcOptLinkFrameworkDirs = toNubListR $ PD.extraFrameworkDirs bi- , ghcOptInputFiles = toNubListR [buildTargetDir </> x | x <- extraSourcesObjs]- , ghcOptNoLink = Flag False- , ghcOptRPaths = rpaths- }- case what of- BuildRepl replFlags -> liftIO $ do- let- -- For repl we use the vanilla (static) ghc options- staticOpts = buildOpts StaticWay- replOpts =- staticOpts- { -- Repl options use Static as the base, but doesn't need to pass -static.- -- However, it maybe should, for uniformity.- ghcOptDynLinkMode = NoFlag- , ghcOptExtra =- Internal.filterGhciFlags- (ghcOptExtra staticOpts)- <> replOptionsFlags (replReplOptions replFlags)- , ghcOptInputModules = replNoLoad (replReplOptions replFlags) (ghcOptInputModules staticOpts)- , ghcOptInputFiles = replNoLoad (replReplOptions replFlags) (ghcOptInputFiles staticOpts)- }- -- 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.- --- -- TODO: The repl doesn't use the runtime paths from linkerOpts- -- (ghcOptRPaths), which looks like a bug. After the refactor we- -- can fix this.- `mappend` linkerOpts mempty- `mappend` mempty- { ghcOptMode = toFlag GhcModeInteractive- , ghcOptOptimisation = toFlag GhcNoOptimisation+ then extraLibsStatic bi+ else extraLibs bi+ , ghcOptLinkLibPath =+ toNubListR $+ if withFullyStaticExe lbi+ then cleanedExtraLibDirsStatic+ else cleanedExtraLibDirs+ , ghcOptLinkFrameworks = toNubListR $ map getSymbolicPath $ PD.frameworks bi+ , ghcOptLinkFrameworkDirs = toNubListR $ PD.extraFrameworkDirs bi+ , ghcOptInputFiles = toNubListR extraSourcesObjs+ , ghcOptNoLink = Flag False+ , ghcOptRPaths = rpaths+ }++ case what of+ BuildRepl replFlags -> liftIO $ do+ let+ -- For repl we use the vanilla (static) ghc options+ staticOpts = buildOpts StaticWay+ replOpts =+ staticOpts+ { -- Repl options use Static as the base, but doesn't need to pass -static.+ -- However, it maybe should, for uniformity.+ ghcOptDynLinkMode = NoFlag+ , ghcOptExtra =+ Internal.filterGhciFlags+ (ghcOptExtra staticOpts)+ <> replOptionsFlags (replReplOptions 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.+ --+ -- TODO: The repl doesn't use the runtime paths from linkerOpts+ -- (ghcOptRPaths), which looks like a bug. After the refactor we+ -- can fix this.+ `mappend` linkerOpts mempty+ `mappend` mempty+ { ghcOptMode = toFlag GhcModeInteractive+ , ghcOptOptimisation = toFlag GhcNoOptimisation+ }+ replOpts_final =+ replOpts+ { ghcOptInputModules = replNoLoad (replReplOptions replFlags) (ghcOptInputModules replOpts)+ , ghcOptInputFiles = replNoLoad (replReplOptions replFlags) (ghcOptInputFiles replOpts)+ } - -- 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.- when (case component of CLib lib -> null (allLibModules lib clbi); _ -> False) $- warn verbosity "No exposed modules"- runReplOrWriteFlags ghcProg lbi replFlags replOpts (pkgName (PD.package pkg_descr)) target- _otherwise ->- let- runGhcProg = runGHC verbosity ghcProg comp platform- platform = hostPlatform lbi- comp = compiler lbi- in- when (not $ componentIsIndefinite clbi) $ do- -- If not building dynamically, we don't pass any runtime paths.- rpaths <- if DynWay `Set.member` wantedWays then getRPaths pbci else return (toNubListR [])- liftIO $ do- info verbosity "Linking..."- let linkExeLike name = linkExecutable (linkerOpts rpaths) (wantedWays, buildOpts) targetDir name runGhcProg lbi- case component of- CLib lib -> linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg lib lbi clbi extraSources rpaths wantedWays- CFLib flib -> linkFLib flib bi lbi (linkerOpts rpaths) (wantedWays, buildOpts) targetDir runGhcProg- CExe exe -> linkExeLike (exeName exe)- CTest test -> linkExeLike (testName test)- CBench bench -> linkExeLike (benchmarkName bench)+ -- 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.+ when (case component of CLib lib -> null (allLibModules lib clbi); _ -> False) $+ warn verbosity "No exposed modules"+ runReplOrWriteFlags+ ghcProg+ verbHandles+ lbi+ replFlags+ replOpts_final+ (pkgName (PD.package pkg_descr))+ target+ _otherwise ->+ let+ runGhcProg =+ runGHCWithResponseFile+ "ghc.rsp"+ Nothing+ tempFileOptions+ verbosity+ ghcProg+ comp+ platform+ mbWorkDir+ platform = hostPlatform lbi+ comp = compiler lbi+ get_rpaths ways =+ if DynWay `Set.member` ways then getRPaths pbci else return (toNubListR [])+ in+ unless (componentIsIndefinite clbi) $ do+ -- If not building dynamically, we don't pass any runtime paths.+ liftIO $ do+ info verbosity "Linking..."+ let linkExeLike name = do+ rpaths <- get_rpaths (Set.singleton wantedExeWay)+ linkExecutable (linkerOpts rpaths) (wantedExeWay, buildOpts) targetDir name runGhcProg lbi+ case component of+ CLib lib -> do+ let libWays = wantedLibWays isIndef+ rpaths <- get_rpaths (Set.fromList libWays)+ linkLibrary buildTargetDir cleanedExtraLibDirs verbosity runGhcProg lib lbi clbi extraSources rpaths libWays+ CFLib flib -> do+ let flib_way = wantedFLibWay (withDynFLib flib)+ rpaths <- get_rpaths (Set.singleton flib_way)+ linkFLib flib bi lbi (linkerOpts rpaths) (flib_way, buildOpts) targetDir runGhcProg+ CExe exe -> linkExeLike (exeName exe)+ CTest test -> linkExeLike (testName test)+ CBench bench -> linkExeLike (benchmarkName bench) -- | Link a library component linkLibrary- :: FilePath+ :: SymbolicPath Pkg (Dir Artifacts) -- ^ The library target build directory- -> [FilePath]+ -> [SymbolicPath Pkg (Dir Lib)] -- ^ The list of extra lib dirs that exist (aka "cleaned")- -> PackageDescription- -- ^ The package description containing this library -> Verbosity -> (GhcOptions -> IO ()) -- ^ Run the configured Ghc program -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo- -> [FilePath]+ -> [SymbolicPath Pkg File] -- ^ Extra build sources (that were compiled to objects) -> NubListR FilePath -- ^ A list with the runtime-paths (rpaths), or empty if not linking dynamically- -> Set.Set BuildWay+ -> [BuildWay] -- ^ Wanted build ways and corresponding build options -> IO ()-linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg lib lbi clbi extraSources rpaths wantedWays = do+linkLibrary buildTargetDir cleanedExtraLibDirs verbosity runGhcProg lib lbi clbi extraSources rpaths wantedWays = do let compiler_id = compilerId comp comp = compiler lbi- ghcVersion = compilerVersion comp implInfo = getImplInfo comp uid = componentUnitId clbi libBi = libBuildInfo lib- Platform _hostArch hostOS = hostPlatform lbi- vanillaLibFilePath = buildTargetDir </> mkLibName uid- profileLibFilePath = buildTargetDir </> mkProfLibName uid+ vanillaLibFilePath = buildTargetDir </> makeRelativePathEx (mkLibName uid)+ profileLibFilePath = buildTargetDir </> makeRelativePathEx (mkProfLibName uid) sharedLibFilePath = buildTargetDir- </> mkSharedLibName (hostPlatform lbi) compiler_id uid+ </> makeRelativePathEx (mkSharedLibName (hostPlatform lbi) compiler_id uid)+ profSharedLibFilePath =+ buildTargetDir+ </> makeRelativePathEx (mkProfSharedLibName (hostPlatform lbi) compiler_id uid) staticLibFilePath = buildTargetDir- </> mkStaticLibName (hostPlatform lbi) compiler_id uid- ghciLibFilePath = buildTargetDir </> Internal.mkGHCiLibName uid- ghciProfLibFilePath = buildTargetDir </> Internal.mkGHCiProfLibName uid- libInstallPath =- libdir $- absoluteComponentInstallDirs- pkg_descr- lbi- uid- NoCopyDest- sharedLibInstallPath =- libInstallPath- </> mkSharedLibName (hostPlatform lbi) compiler_id uid+ </> makeRelativePathEx (mkStaticLibName (hostPlatform lbi) compiler_id uid)+ bytecodeLibFilePath =+ buildTargetDir+ </> makeRelativePathEx (mkBytecodeLibName compiler_id uid)+ ghciLibFilePath = buildTargetDir </> makeRelativePathEx (Internal.mkGHCiLibName uid)+ ghciProfLibFilePath = buildTargetDir </> makeRelativePathEx (Internal.mkGHCiProfLibName uid) - getObjFiles way =+ getObjWayFiles :: BuildWay -> IO [SymbolicPath Pkg File]+ getObjWayFiles w = getObjFiles (buildWayObjectExtension objExtension w) (buildWayObjectExtension objExtension w)++ getObjBytecodeWayFiles :: BuildWay -> IO [SymbolicPath Pkg File]+ getObjBytecodeWayFiles companion_way = getObjFiles "gbc" (buildWayObjectExtension objExtension companion_way)++ getObjFiles :: String -> String -> IO [SymbolicPath Pkg File]+ getObjFiles hs_ext obj_ext = mconcat [ Internal.getHaskellObjects implInfo@@ -231,20 +293,9 @@ lbi clbi buildTargetDir- (buildWayPrefix way ++ objExtension)+ hs_ext True- , pure $- map (buildTargetDir </>) $- map ((`replaceExtension` (buildWayPrefix way ++ objExtension))) extraSources- , catMaybes- <$> sequenceA- [ findFileWithExtension- [Suffix $ buildWayPrefix way ++ objExtension]- [buildTargetDir]- (ModuleName.toFilePath x ++ "_stub")- | ghcVersion < mkVersion [7, 2] -- ghc-7.2+ does not make _stub.o files- , x <- allLibModules lib clbi- ]+ , pure $ map (objectFilePath buildTargetDir obj_ext) extraSources ] -- I'm fairly certain that, just like the executable, we can keep just the@@ -256,76 +307,74 @@ -- we could more easily merge the two. -- -- Right now, instead, we pass the path to each object file.+ ghcBaseLinkArgs :: GhcOptions ghcBaseLinkArgs =- mempty- { -- TODO: This basically duplicates componentGhcOptions.- -- I think we want to do the same as we do for executables: re-use the- -- base options, and link by module names, not object paths.- 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- }+ Internal.linkGhcOptions (verbosityLevel verbosity) lbi libBi clbi+ <> mempty+ { ghcOptExtra = hcStaticOptions GHC libBi+ , ghcOptNoAutoLinkPackages = toFlag True+ } -- 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 :: [SymbolicPath Pkg File] -> GhcOptions ghcSharedLinkArgs dynObjectFiles = ghcBaseLinkArgs { ghcOptShared = toFlag True , ghcOptDynLinkMode = toFlag GhcDynamicOnly- , ghcOptInputFiles = toNubListR dynObjectFiles+ , ghcOptInputFiles = toNubListR $ map coerceSymbolicPath dynObjectFiles , ghcOptOutputFile = toFlag sharedLibFilePath- , -- 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+ , ghcOptDylibName = mempty , ghcOptLinkLibs = extraLibs libBi- , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs- , ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi+ , ghcOptLinkLibPath = toNubListR cleanedExtraLibDirs+ , ghcOptLinkFrameworks = toNubListR $ map getSymbolicPath $ PD.frameworks libBi , ghcOptLinkFrameworkDirs = toNubListR $ PD.extraFrameworkDirs libBi , ghcOptRPaths = rpaths }+ ghcProfSharedLinkArgs pdynObjectFiles =+ ghcBaseLinkArgs+ { ghcOptShared = toFlag True+ , ghcOptProfilingMode = toFlag True+ , ghcOptProfilingAuto =+ Internal.profDetailLevelFlag+ True+ (withProfLibDetail lbi)+ , ghcOptDynLinkMode = toFlag GhcDynamicOnly+ , ghcOptInputFiles = toNubListR pdynObjectFiles+ , ghcOptOutputFile = toFlag profSharedLibFilePath+ , ghcOptDylibName = mempty+ , ghcOptLinkLibs = extraLibs libBi+ , ghcOptLinkLibPath = toNubListR cleanedExtraLibDirs+ , ghcOptLinkFrameworks = toNubListR $ map getSymbolicPath $ PD.frameworks libBi+ , ghcOptLinkFrameworkDirs =+ toNubListR $ PD.extraFrameworkDirs libBi+ , ghcOptRPaths = rpaths+ } ghcStaticLinkArgs staticObjectFiles = ghcBaseLinkArgs { ghcOptStaticLib = toFlag True- , ghcOptInputFiles = toNubListR staticObjectFiles+ , ghcOptInputFiles = toNubListR $ map coerceSymbolicPath staticObjectFiles , ghcOptOutputFile = toFlag staticLibFilePath , ghcOptLinkLibs = extraLibs libBi , -- TODO: Shouldn't this use cleanedExtraLibDirsStatic instead?- ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs+ ghcOptLinkLibPath = toNubListR cleanedExtraLibDirs }+ ghcBytecodeLinkArgs objectFiles =+ (ghcSharedLinkArgs objectFiles)+ { ghcOptBytecodeLib = toFlag True+ , ghcOptInputFiles = toNubListR $ map coerceSymbolicPath objectFiles+ , ghcOptOutputFile = toFlag bytecodeLibFilePath+ } - staticObjectFiles <- getObjFiles StaticWay- profObjectFiles <- getObjFiles ProfWay- dynamicObjectFiles <- getObjFiles DynWay+ staticObjectFiles <- getObjWayFiles StaticWay+ profObjectFiles <- getObjWayFiles ProfWay+ dynamicObjectFiles <- getObjWayFiles DynWay+ profDynamicObjectFiles <- getObjWayFiles ProfDynWay + -- See doc/internal/bytecode-libraries.md for how the chosen companion+ -- way determines which .gbc files get packed into the .bytecodelib. let linkWay = \case ProfWay -> do@@ -338,8 +387,14 @@ ldProg ghciProfLibFilePath profObjectFiles+ ProfDynWay -> do+ runGhcProg $ ghcProfSharedLinkArgs profDynamicObjectFiles DynWay -> do runGhcProg $ ghcSharedLinkArgs dynamicObjectFiles+ -- The .gbc files were built with DynWay if both are enabled.+ when (withBytecodeLib lbi) $ do+ bytecodeObjectFiles <- getObjBytecodeWayFiles DynWay+ runGhcProg $ ghcBytecodeLinkArgs bytecodeObjectFiles StaticWay -> do when (withVanillaLib lbi) $ do Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles@@ -353,24 +408,37 @@ staticObjectFiles when (withStaticLib lbi) $ do runGhcProg $ ghcStaticLinkArgs staticObjectFiles+ -- The .gbc files were built with `DynWay` if `DynWay` is enabled. Otherwise (this case),+ -- the files are produced alongside `StaticWay`.+ when (withBytecodeLib lbi && (DynWay `notElem` wantedWays)) $ do+ bytecodeObjectFiles <- getObjBytecodeWayFiles StaticWay+ runGhcProg $ ghcBytecodeLinkArgs bytecodeObjectFiles -- ROMES: Why exactly branch on staticObjectFiles, rather than any other build -- kind that we might have wanted instead? -- This would be simpler by not adding every object to the invocation, and -- rather using module names. unless (null staticObjectFiles) $ do- info verbosity (show (ghcOptPackages (Internal.componentGhcOptions verbosity lbi libBi clbi buildTargetDir)))+ info verbosity $+ show $+ ghcOptPackages $+ Internal.componentGhcOptions+ (verbosityLevel verbosity)+ lbi+ libBi+ clbi+ buildTargetDir traverse_ linkWay wantedWays -- | Link the executable resulting from building this component, be it an -- executable, test, or benchmark component. linkExecutable- :: (GhcOptions)+ :: GhcOptions -- ^ The linker-specific GHC options- -> (Set.Set BuildWay, BuildWay -> GhcOptions)+ -> (BuildWay, BuildWay -> GhcOptions) -- ^ The wanted build ways and corresponding GhcOptions that were -- used to compile the modules in that way.- -> FilePath+ -> SymbolicPath Pkg (Dir Build) -- ^ The target dir (2024-01:note: not the same as build target -- dir, see Note [Build Target Dir vs Target Dir] in Distribution.Simple.GHC.Build) -> UnqualComponentName@@ -379,46 +447,40 @@ -- ^ Run the configured GHC program -> LocalBuildInfo -> IO ()-linkExecutable linkerOpts (wantedWays, buildOpts) targetDir targetName runGhcProg lbi = do- -- When building an executable, we should only "want" one build way.- assert (Set.size wantedWays == 1) $- forM_ wantedWays $ \way -> do- let baseOpts = buildOpts way- linkOpts =- baseOpts- `mappend` linkerOpts- `mappend` mempty- { -- If there are no input Haskell files we pass -no-hs-main, and- -- assume there is a main function in another non-haskell object- ghcOptLinkNoHsMain = toFlag (ghcOptInputFiles baseOpts == mempty && ghcOptInputScripts baseOpts == mempty)- }- comp = compiler lbi+linkExecutable linkerOpts (way, buildOpts) targetDir targetName runGhcProg lbi = do+ let baseOpts = buildOpts way+ linkOpts =+ baseOpts+ `mappend` linkerOpts+ `mappend` mempty+ { -- If there are no input Haskell files we pass -no-hs-main, and+ -- assume there is a main function in another non-haskell object+ ghcOptLinkNoHsMain = toFlag (ghcOptInputFiles baseOpts == mempty && ghcOptInputScripts baseOpts == mempty)+ } - -- Work around old GHCs not relinking in this- -- situation, see #3294- let target = targetDir </> exeTargetName (hostPlatform lbi) targetName- when (compilerVersion comp < mkVersion [7, 7]) $ do- e <- doesFileExist target- when e (removeFile target)- runGhcProg linkOpts{ghcOptOutputFile = toFlag target}+ -- Work around old GHCs not relinking in this+ -- situation, see #3294+ let target =+ targetDir </> makeRelativePathEx (exeTargetName (hostPlatform lbi) targetName)+ runGhcProg linkOpts{ghcOptOutputFile = toFlag target} -- | Link a foreign library component linkFLib :: ForeignLib -> BuildInfo -> LocalBuildInfo- -> (GhcOptions)+ -> GhcOptions -- ^ The linker-specific GHC options- -> (Set.Set BuildWay, BuildWay -> GhcOptions)+ -> (BuildWay, BuildWay -> GhcOptions) -- ^ The wanted build ways and corresponding GhcOptions that were -- used to compile the modules in that way.- -> FilePath+ -> SymbolicPath Pkg (Dir Build) -- ^ The target dir (2024-01:note: not the same as build target -- dir, see Note [Build Target Dir vs Target Dir] in Distribution.Simple.GHC.Build) -> (GhcOptions -> IO ()) -- ^ Run the configured GHC program -> IO ()-linkFLib flib bi lbi linkerOpts (wantedWays, buildOpts) targetDir runGhcProg = do+linkFLib flib bi lbi linkerOpts (way, buildOpts) targetDir runGhcProg = do let comp = compiler lbi @@ -432,7 +494,7 @@ | otherwise = mempty { ghcOptLinkLibs = rtsOptLinkLibs- , ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo+ , ghcOptLinkLibPath = toNubListR $ map makeSymbolicPath $ rtsLibPaths rtsInfo } where threaded = hasThreaded bi@@ -450,17 +512,17 @@ else statRtsVanillaLib (rtsStaticInfo rtsInfo) ] - linkOpts :: BuildWay -> GhcOptions- linkOpts way = case foreignLibType flib of+ linkOpts :: GhcOptions+ linkOpts = case foreignLibType flib of ForeignLibNativeShared ->- (buildOpts way)+ buildOpts way `mappend` linkerOpts `mappend` rtsLinkOpts `mappend` mempty { ghcOptLinkNoHsMain = toFlag True , ghcOptShared = toFlag True , ghcOptFPic = toFlag True- , ghcOptLinkModDefFiles = toNubListR $ foreignLibModDefFile flib+ , ghcOptLinkModDefFiles = toNubListR $ fmap getSymbolicPath $ foreignLibModDefFile flib } ForeignLibNativeStatic -> -- this should be caught by buildFLib@@ -473,11 +535,10 @@ -- soname on supported platforms. See also the note for -- @flibBuildName@. let buildName = flibBuildName lbi flib- -- There should not be more than one wanted way when building an flib- assert (Set.size wantedWays == 1) $- forM_ wantedWays $ \way -> do- runGhcProg (linkOpts way){ghcOptOutputFile = toFlag (targetDir </> buildName)}- renameFile (targetDir </> buildName) (targetDir </> flibTargetName lbi flib)+ let outFile = targetDir </> makeRelativePathEx buildName+ runGhcProg linkOpts{ghcOptOutputFile = toFlag outFile}+ let i = interpretSymbolicPathLBI lbi+ renameFile (i outFile) (i targetDir </> flibTargetName lbi flib) -- | Calculate the RPATHs for the component we are building. --@@ -507,7 +568,7 @@ supportRPaths OSX = True supportRPaths FreeBSD = case compid of- CompilerId GHC ver | ver >= mkVersion [7, 10, 2] -> True+ CompilerId GHC _ -> True _ -> False supportRPaths OpenBSD = False supportRPaths NetBSD = False@@ -534,7 +595,9 @@ OSX -> "@loader_path" _ -> "$ORIGIN" relPath p = if isRelative p then hostPref </> p else p- rpaths = toNubListR (map relPath libraryPaths) <> toNubListR (extraLibDirs bi)+ rpaths =+ toNubListR (map relPath libraryPaths)+ <> toNubListR (map getSymbolicPath $ extraLibDirs bi) return rpaths else return mempty @@ -609,7 +672,7 @@ -- threaded RTS. This is used to determine which RTS to link against when -- building a foreign library with a GHC without support for @-flink-rts@. hasThreaded :: BuildInfo -> Bool-hasThreaded bi = elem "-threaded" ghc+hasThreaded bi = "-threaded" `elem` ghc where PerCompilerFlavor ghc _ = options bi @@ -617,34 +680,64 @@ -- GHCi with the GHC options Cabal elaborated to load the component interactively. runReplOrWriteFlags :: ConfiguredProgram+ -> VerbosityHandles -> LocalBuildInfo -> ReplFlags -> GhcOptions -> PackageName -> TargetInfo -> IO ()-runReplOrWriteFlags ghcProg lbi rflags ghcOpts pkg_name target =+runReplOrWriteFlags ghcProg verbHandles lbi rflags ghcOpts pkg_name target = let bi = componentBuildInfo $ targetComponent target clbi = targetCLBI target+ cname = componentName (targetComponent target) comp = compiler lbi platform = hostPlatform lbi+ common = configCommonFlags $ configFlags lbi+ mbWorkDir = mbWorkDirLBI lbi+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ tempFileOptions = commonSetupTempFileOptions common in case replOptionsFlagOutput (replReplOptions rflags) of- NoFlag -> runGHC (fromFlag $ replVerbosity rflags) ghcProg comp platform ghcOpts+ NoFlag -> do+ -- If a specific GHC implementation is specified, use it+ runReplProgram+ (flagToMaybe $ replWithRepl (replReplOptions rflags))+ tempFileOptions+ verbosity+ ghcProg+ comp+ platform+ mbWorkDir+ ghcOpts Flag out_dir -> do- src_dir <- getCurrentDirectory let uid = componentUnitId clbi this_unit = prettyShow uid- reexported_modules = [mn | LibComponentLocalBuildInfo{} <- [clbi], IPI.ExposedModule mn (Just{}) <- componentExposedModules clbi]+ getOpenModName (OpenModule _ mn) = Just mn+ getOpenModName (OpenModuleVar{}) = Nothing+ reexported_modules =+ [ (from_mn, to_mn) | LibComponentLocalBuildInfo{componentExposedModules = exposed_mods} <- [clbi], IPI.ExposedModule to_mn (Just m) <- exposed_mods, Just from_mn <- [getOpenModName m]+ ]+ renderReexportedModule (from_mn, to_mn)+ | reexportedAsSupported comp =+ pure $ prettyShow from_mn ++ " as " ++ prettyShow to_mn+ | otherwise =+ if from_mn == to_mn+ then pure $ prettyShow to_mn+ else dieWithException verbosity (MultiReplDoesNotSupportComplexReexportedModules pkg_name cname) 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- ]+ render_extra_opts = do+ rexp_mods <- mapM renderReexportedModule reexported_modules+ pure $+ concat $+ [ ["-this-package-name", prettyShow pkg_name]+ , case mbWorkDir of+ Nothing -> []+ Just wd -> ["-working-dir", getSymbolicPath wd]+ ]+ ++ [ ["-reexported-module", m] | m <- rexp_mods+ ]+ ++ [ ["-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")@@ -652,6 +745,7 @@ writeFileAtomic (out_dir </> "paths" </> this_unit) (encode ghcProg) -- Write out options for this component into a file ready for loading into -- the multi-repl+ extra_opts <- render_extra_opts writeFileAtomic (out_dir </> this_unit) $ BS.pack $ escapeArgs $
src/Distribution/Simple/GHC/Build/Modules.hs view
@@ -1,9 +1,14 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RankNTypes #-} -module Distribution.Simple.GHC.Build.Modules (buildHaskellModules, BuildWay (..), buildWayPrefix) where+module Distribution.Simple.GHC.Build.Modules+ ( buildHaskellModules+ , BuildWay (..)+ , buildWayObjectExtension+ , componentInputs+ ) where import Control.Monad.IO.Class import Distribution.Compat.Prelude@@ -15,7 +20,9 @@ import qualified Distribution.PackageDescription as PD import Distribution.Pretty import Distribution.Simple.Build.Inputs+import Distribution.Simple.BuildWay import Distribution.Simple.Compiler+import Distribution.Simple.Errors (CabalException (StandaloneBytecodeNotSupportedYet)) import Distribution.Simple.GHC.Build.Utils import qualified Distribution.Simple.GHC.Internal as Internal import qualified Distribution.Simple.Hpc as Hpc@@ -34,7 +41,9 @@ import Distribution.Types.TestSuite import Distribution.Types.TestSuiteInterface import Distribution.Utils.NubList-import System.FilePath+import Distribution.Utils.Path+import Distribution.Verbosity (VerbosityHandles, mkVerbosity, verbosityLevel)+import System.FilePath () {- Note [Building Haskell Modules accounting for TH]@@ -45,7 +54,7 @@ * The dynamic/shared way (-dynamic) * The profiled way (-prof) -For libraries, we may /want/ to build modules in all three ways, or in any combination, depending on user options.+For libraries, we may /want/ to build modules in all ways, or in any combination, depending on user options. For executables, we just /want/ to build the executable in the requested way. In practice, however, we may /need/ to build modules in additional ways beyonds the ones that were requested.@@ -94,13 +103,17 @@ -- ^ The parallelism strategy (e.g. num of jobs) -> ConfiguredProgram -- ^ The GHC configured program- -> PD.PackageDescription- -- ^ The package description- -> FilePath+ -> Maybe (SymbolicPath Pkg File)+ -- ^ Optional path to a Haskell Main file to build+ -> [ModuleName]+ -- ^ The Haskell modules to build+ -> SymbolicPath Pkg ('Dir Artifacts) -- ^ The path to the build directory for this target, which -- has already been created.- -> Set.Set BuildWay- -- ^ The set of wanted build ways according to user options+ -> [BuildWay]+ -- ^ The set of needed build ways according to user options+ -> VerbosityHandles+ -- ^ Logging handles -> PreBuildComponentInputs -- ^ The context and component being built in it. -> IO (BuildWay -> GhcOptions)@@ -108,47 +121,59 @@ -- invocation used to compile the component in that 'BuildWay'. -- This can be useful in, eg, a linker invocation, in which we want to use the -- same options and list the same inputs as those used for building.-buildHaskellModules numJobs ghcProg pkg_descr buildTargetDir wantedWays pbci = do+buildHaskellModules numJobs ghcProg mbMainFile inputModules buildTargetDir neededLibWays verbHandles pbci = do -- See Note [Building Haskell Modules accounting for TH] let- verbosity = buildVerbosity pbci+ verbosity = mkVerbosity verbHandles $ buildVerbosity pbci isLib = buildIsLib pbci clbi = buildCLBI pbci lbi = localBuildInfo pbci bi = buildBI pbci what = buildingWhat pbci comp = buildCompiler pbci+ i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path+ neededLibWaysSet = Set.fromList neededLibWays + withBytecode = withBytecodeLib lbi+ -- If this component will be loaded into a repl, we don't compile the modules at all. forRepl | BuildRepl{} <- what = True | otherwise = False - -- TODO: do we need to put hs-boot files into place for mutually recursive- -- modules? FIX: what about exeName.hi-boot?-- -- Determine if program coverage should be enabled and if so, what- -- '-hpcdir' should be.- let isCoverageEnabled = if isLib then libCoverage lbi else exeCoverage lbi- hpcdir way- | forRepl = mempty -- HPC is not supported in ghci- | isCoverageEnabled = Flag $ Hpc.mixDir (buildTargetDir </> extraCompilationArtifacts) way- | otherwise = mempty+ -- TODO: do we need to put hs-boot files into place for mutually recursive+ -- modules? FIX: what about exeName.hi-boot? - (inputFiles, inputModules) <- componentInputs buildTargetDir pkg_descr pbci+ -- Determine if program coverage should be enabled and if so, what+ -- '-hpcdir' should be.+ isCoverageEnabled = if isLib then libCoverage lbi else exeCoverage lbi+ hpcdir way+ | forRepl = mempty -- HPC is not supported in ghci+ | isCoverageEnabled = Flag $ Hpc.mixDir (coerceSymbolicPath $ coerceSymbolicPath buildTargetDir </> extraCompilationArtifacts) way+ | otherwise = mempty - let- runGhcProg = runGHC verbosity ghcProg comp platform+ mbWorkDir = mbWorkDirLBI lbi+ tempFileOptions = commonSetupTempFileOptions $ buildingWhatCommonFlags what+ runGhcProg =+ runGHCWithResponseFile+ "ghc.rsp"+ Nothing+ tempFileOptions+ verbosity+ ghcProg+ comp+ platform+ mbWorkDir platform = hostPlatform lbi - -- See Note [Building Haskell Modules accounting for TH]- doingTH = usesTemplateHaskellOrQQ bi+ (hsMains, scriptMains) =+ partition (isHaskell . getSymbolicPath) (maybeToList mbMainFile) -- We define the base opts which are shared across different build ways in -- 'buildHaskellModules' baseOpts way =- (Internal.componentGhcOptions verbosity lbi bi clbi buildTargetDir)+ Internal.componentGhcOptions (verbosityLevel verbosity) lbi bi clbi buildTargetDir `mappend` mempty { ghcOptMode = toFlag GhcModeMake , -- Previously we didn't pass -no-link when building libs,@@ -158,34 +183,36 @@ ghcOptNoLink = if isLib then NoFlag else toFlag True , ghcOptNumJobs = numJobs , ghcOptInputModules = toNubListR inputModules- , ghcOptInputFiles =- toNubListR $- if PD.package pkg_descr == fakePackageId- then filter isHaskell inputFiles- else inputFiles- , ghcOptInputScripts =- toNubListR $- if PD.package pkg_descr == fakePackageId- then filter (not . isHaskell) inputFiles- else []+ , ghcOptInputFiles = toNubListR hsMains+ , ghcOptInputScripts = toNubListR scriptMains , ghcOptExtra = buildWayExtraHcOptions way GHC bi- , ghcOptHiSuffix = optSuffixFlag (buildWayPrefix way) "hi"- , ghcOptObjSuffix = optSuffixFlag (buildWayPrefix way) "o"+ , ghcOptHiSuffix = needsWaySuffixFlag (buildWayInterfaceExtension way) "hi"+ , ghcOptObjSuffix = needsWaySuffixFlag (buildWayObjectExtension "o" way) "o" , ghcOptHPCDir = hpcdir (buildWayHpcWay way) -- maybe this should not be passed for vanilla? } where- optSuffixFlag "" _ = NoFlag- optSuffixFlag pre x = toFlag (pre ++ x)+ needsWaySuffixFlag x y = if x == y then NoFlag else toFlag x + -- Bytecode objects are attached to an existing native way; see+ -- doc/internal/bytecode-libraries.md for the companion-way rules.+ bytecodeToo p = if p then toFlag GhcByteCodeAndObjectCode else NoFlag++ hasWay way = way `Set.member` neededLibWaysSet+ -- For libs we don't pass -static when building static, leaving it -- implicit. We should just always pass -static, but we don't want to -- change behaviour when doing the refactor.- staticOpts = (baseOpts StaticWay){ghcOptDynLinkMode = if isLib then NoFlag else toFlag GhcStaticOnly}+ staticOpts =+ (baseOpts StaticWay)+ { ghcOptDynLinkMode = if isLib then NoFlag else toFlag GhcStaticOnly+ , ghcOptObjectMode = bytecodeToo (withBytecode && not (hasWay DynWay))+ } dynOpts = (baseOpts DynWay) { ghcOptDynLinkMode = toFlag GhcDynamicOnly -- use -dynamic , -- TODO: Does it hurt to set -fPIC for executables? ghcOptFPic = toFlag True -- use -fPIC+ , ghcOptObjectMode = bytecodeToo withBytecode } profOpts = (baseOpts ProfWay)@@ -195,57 +222,113 @@ (if isLib then True else False) ((if isLib then withProfLibDetail else withProfExeDetail) lbi) }+ profDynOpts =+ (baseOpts ProfDynWay)+ { ghcOptDynLinkMode = toFlag GhcDynamicOnly -- use -dynamic+ , -- TODO: Does it hurt to set -fPIC for executables?+ ghcOptFPic = toFlag True -- use -fPIC+ , ghcOptProfilingMode = toFlag True+ , ghcOptProfilingAuto =+ Internal.profDetailLevelFlag+ (if isLib then True else False)+ ((if isLib then withProfLibDetail else withProfExeDetail) lbi)+ }+ -- Options for building both static and dynamic way at the same time, using -- the GHC flag -static and -dynamic-too dynTooOpts = (baseOpts StaticWay) { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic -- use -dynamic-too- , ghcOptDynHiSuffix = toFlag (buildWayPrefix DynWay ++ "hi")- , ghcOptDynObjSuffix = toFlag (buildWayPrefix DynWay ++ "o")+ , ghcOptDynHiSuffix = toFlag (buildWayInterfaceExtension DynWay)+ , ghcOptDynObjSuffix = toFlag (buildWayObjectExtension "o" DynWay) , ghcOptHPCDir = hpcdir Hpc.Dyn+ , ghcOptObjectMode = bytecodeToo withBytecode -- Should we pass hcSharedOpts in the -dynamic-too ghc invocation? -- (Note that `baseOtps StaticWay = hcStaticOptions`, not hcSharedOpts) } + profDynTooOpts =+ (baseOpts ProfWay)+ { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic -- use -dynamic-too+ , -- TODO: Does it hurt to set -fPIC for executables?+ ghcOptFPic = toFlag True -- use -fPIC+ , ghcOptProfilingMode = toFlag True+ , ghcOptProfilingAuto =+ Internal.profDetailLevelFlag+ (if isLib then True else False)+ ((if isLib then withProfLibDetail else withProfExeDetail) lbi)+ , ghcOptDynHiSuffix = toFlag (buildWayInterfaceExtension ProfDynWay)+ , ghcOptDynObjSuffix = toFlag (buildWayObjectExtension "o" ProfDynWay)+ , ghcOptHPCDir = hpcdir Hpc.ProfDyn+ -- Should we pass hcSharedOpts in the -dynamic-too ghc invocation?+ -- (Note that `baseOtps StaticWay = hcStaticOptions`, not hcSharedOpts)+ }+ -- Determines how to build for each way, also serves as the base options -- for loading modules in 'linkOrLoadComponent' buildOpts way = case way of StaticWay -> staticOpts DynWay -> dynOpts ProfWay -> profOpts+ ProfDynWay -> profDynOpts - defaultGhcWay = if isDynamic comp then DynWay else StaticWay+ when+ ( withBytecode+ && not (hasWay StaticWay || hasWay DynWay)+ )+ $ dieWithException verbosity StandaloneBytecodeNotSupportedYet -- If there aren't modules, or if we're loading the modules in repl, don't build.- unless (forRepl || (null inputFiles && null inputModules)) $ liftIO $ do+ unless (forRepl || (isNothing mbMainFile && null inputModules)) $ liftIO $ do -- See Note [Building Haskell Modules accounting for TH] let- neededWays =- wantedWays- <> Set.fromList- -- TODO: You also don't need to build the GHC way when doing TH if- -- you are using an external interpreter!!- [defaultGhcWay | doingTH && defaultGhcWay `Set.notMember` wantedWays]- -- If we need both static and dynamic, use dynamic-too instead of -- compiling twice (if we support it) useDynamicToo =- StaticWay `Set.member` neededWays- && DynWay `Set.member` neededWays+ StaticWay `Set.member` neededLibWaysSet+ && DynWay `Set.member` neededLibWaysSet && supportsDynamicToo comp && null (hcSharedOptions GHC bi) + useProfDynamicToo =+ ProfWay `Set.member` neededLibWaysSet+ && ProfDynWay `Set.member` neededLibWaysSet+ && supportsDynamicToo comp+ && null (hcSharedOptions GHC bi)++ defaultGhcWay = compilerBuildWay comp++ order w+ | w == defaultGhcWay = 0+ | otherwise = fromEnum w + 1+ -- The ways we'll build, in order orderedBuilds- -- If we can use dynamic-too, do it first. The default GHC way can only- -- be static or dynamic, so, if we build both right away, any modules- -- possibly needed by TH later (e.g. if building profiled) are already built.+ -- We need to make sure that the way which is the way the compiler is built+ -- is built first so that Template Haskell works.+ | useProfDynamicToo && useDynamicToo =+ if defaultGhcWay `elem` [ProfDynWay, ProfWay]+ then [buildProfAndProfDynamicToo, buildStaticAndDynamicToo]+ else [buildStaticAndDynamicToo, buildProfAndProfDynamicToo]+ | useProfDynamicToo && not useDynamicToo =+ if defaultGhcWay `elem` [ProfDynWay, ProfWay]+ then+ [buildProfAndProfDynamicToo]+ ++ (runGhcProg . buildOpts <$> neededLibWays \\ [ProfDynWay, ProfWay])+ else+ (runGhcProg . buildOpts <$> neededLibWays \\ [ProfDynWay, ProfWay])+ ++ [buildProfAndProfDynamicToo] | useDynamicToo =- [buildStaticAndDynamicToo]- ++ (runGhcProg . buildOpts <$> Set.toList neededWays \\ [StaticWay, DynWay])+ if defaultGhcWay `elem` [StaticWay, DynWay]+ then+ [buildStaticAndDynamicToo]+ ++ (runGhcProg . buildOpts <$> neededLibWays \\ [StaticWay, DynWay])+ else+ (runGhcProg . buildOpts <$> neededLibWays \\ [StaticWay, DynWay])+ ++ [buildStaticAndDynamicToo] -- Otherwise, we need to ensure the defaultGhcWay is built first | otherwise =- runGhcProg . buildOpts <$> sortOn (\w -> if w == defaultGhcWay then 0 else fromEnum w + 1) (Set.toList neededWays)+ runGhcProg . buildOpts <$> sortOn order neededLibWays buildStaticAndDynamicToo = do runGhcProg dynTooOpts@@ -257,29 +340,33 @@ -- static and dynamically linked executables. We copy -- the modules interfaces so they are available under -- both ways.- copyDirectoryRecursive verbosity dynDir vanillaDir+ copyDirectoryRecursive verbosity (i dynDir) (i vanillaDir) _ -> return ()++ buildProfAndProfDynamicToo = do+ runGhcProg profDynTooOpts+ case (hpcdir Hpc.ProfDyn, hpcdir Hpc.Prof) of+ (Flag profDynDir, Flag profDir) ->+ -- 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 (i profDynDir) (i profDir)+ _ -> return () in -- REVIEW:ADD? info verbosity "Building Haskell Sources..." sequence_ orderedBuilds return buildOpts -data BuildWay = StaticWay | DynWay | ProfWay- deriving (Eq, Ord, Show, Enum)---- | Returns the object/interface extension prefix for the given build way (e.g. "dyn_" for 'DynWay')-buildWayPrefix :: BuildWay -> String-buildWayPrefix = \case- StaticWay -> ""- ProfWay -> "p_"- DynWay -> "dyn_"- -- | Returns the corresponding 'Hpc.Way' for a 'BuildWay' buildWayHpcWay :: BuildWay -> Hpc.Way buildWayHpcWay = \case StaticWay -> Hpc.Vanilla ProfWay -> Hpc.Prof DynWay -> Hpc.Dyn+ ProfDynWay -> Hpc.ProfDyn -- | Returns a function to extract the extra haskell compiler options from a -- 'BuildInfo' and 'CompilerFlavor'@@ -288,47 +375,50 @@ StaticWay -> hcStaticOptions ProfWay -> hcProfOptions DynWay -> hcSharedOptions+ ProfDynWay -> hcProfSharedOptions --- | Returns a pair of the Haskell input files and Haskell modules of the--- component being built.+-- | Returns a pair of the main file and Haskell modules of the component being+-- built. The main file is not necessarily a Haskell file. It could also be+-- e.g. a C source, or, a Haskell repl script (that does not necessarily have+-- an extension). ----- The "input files" are either the path to the main Haskell module, or a repl--- script (that does not necessarily have an extension).+-- The main file is Nothing if the component is not executable. componentInputs- :: FilePath+ :: SymbolicPath Pkg (Dir Artifacts) -- ^ Target build dir+ -> VerbosityHandles+ -- ^ Logging handles -> PD.PackageDescription -> PreBuildComponentInputs -- ^ The context and component being built in it.- -> IO ([FilePath], [ModuleName])- -- ^ The Haskell input files, and the Haskell modules-componentInputs buildTargetDir pkg_descr pbci = do- let- verbosity = buildVerbosity pbci- component = buildComponent pbci- clbi = buildCLBI pbci-+ -> IO (Maybe (SymbolicPath Pkg File), [ModuleName])+ -- ^ The main input file, and the Haskell modules+componentInputs buildTargetDir verbHandles pkg_descr pbci = case component of CLib lib ->- pure ([], allLibModules lib clbi)+ pure (Nothing, allLibModules lib clbi) CFLib flib ->- pure ([], foreignLibModules flib)+ pure (Nothing, foreignLibModules flib) CExe Executable{buildInfo = bi', modulePath} ->- exeLikeInputs verbosity bi' modulePath+ exeLikeInputs bi' modulePath CTest TestSuite{testBuildInfo = bi', testInterface = TestSuiteExeV10 _ mainFile} ->- exeLikeInputs verbosity bi' mainFile+ exeLikeInputs bi' mainFile CBench Benchmark{benchmarkBuildInfo = bi', benchmarkInterface = BenchmarkExeV10 _ mainFile} ->- exeLikeInputs verbosity bi' mainFile+ exeLikeInputs bi' mainFile CTest TestSuite{} -> error "testSuiteExeV10AsExe: wrong kind" CBench Benchmark{} -> error "benchmarkExeV10asExe: wrong kind" where- exeLikeInputs verbosity bnfo modulePath = liftIO $ do- main <- findExecutableMain verbosity buildTargetDir (bnfo, modulePath)+ verbosity = mkVerbosity verbHandles $ buildVerbosity pbci+ component = buildComponent pbci+ clbi = buildCLBI pbci+ mbWorkDir = mbWorkDirLBI $ localBuildInfo pbci+ exeLikeInputs bnfo modulePath = liftIO $ do+ main <- findExecutableMain verbosity mbWorkDir buildTargetDir (bnfo, modulePath) let mainModName = exeMainModuleName bnfo otherModNames = otherModules bnfo -- Scripts have fakePackageId and are always Haskell but can have any extension.- if isHaskell main || PD.package pkg_descr == fakePackageId+ if isHaskell (getSymbolicPath main) || PD.package pkg_descr == fakePackageId then if PD.specVersion pkg_descr < CabalSpecV2_0 && (mainModName `elem` otherModNames) then do@@ -347,6 +437,6 @@ "Enabling workaround for Main module '" ++ prettyShow mainModName ++ "' listed in 'other-modules' illegally!"- return ([main], filter (/= mainModName) otherModNames)- else return ([main], otherModNames)- else return ([], otherModNames)+ return (Just main, filter (/= mainModName) otherModNames)+ else return (Just main, otherModNames)+ else return (Just main, otherModNames)
src/Distribution/Simple/GHC/Build/Utils.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}+ module Distribution.Simple.GHC.Build.Utils where import Distribution.Compat.Prelude@@ -10,6 +13,7 @@ import Distribution.PackageDescription as PD import Distribution.PackageDescription.Utils (cabalBug) import Distribution.Simple.BuildPaths+import Distribution.Simple.BuildWay import Distribution.Simple.Compiler import qualified Distribution.Simple.GHC.Internal as Internal import Distribution.Simple.Program.GHC@@ -17,36 +21,47 @@ import Distribution.Simple.Utils import Distribution.System import Distribution.Types.LocalBuildInfo-import Distribution.Utils.Path (getSymbolicPath)+ ( LocalBuildInfo (hostPlatform)+ )+import Distribution.Utils.Path import Distribution.Verbosity import System.FilePath- ( replaceExtension- , takeExtension- , (<.>)- , (</>)+ ( takeExtension ) -- | Find the path to the entry point of an executable (typically specified in--- @main-is@, and found in @hs-source-dirs@).+-- @main-is@, and found in @hs-source-dirs@ -- yes, even when @main-is@ is not a Haskell file). findExecutableMain :: Verbosity- -> FilePath+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -> SymbolicPath Pkg (Dir build) -- ^ Build directory- -> (BuildInfo, FilePath)+ -> (BuildInfo, RelativePath Source File) -- ^ The build info and module path of an executable-like component (Exe, Test, Bench)- -> IO FilePath+ -> IO (SymbolicPath Pkg File) -- ^ The path to the main source file.-findExecutableMain verbosity bdir (bnfo, modPath) =- findFileEx verbosity (bdir : map getSymbolicPath (hsSourceDirs bnfo)) modPath+findExecutableMain verbosity mbWorkDir buildDir (bnfo, modPath) =+ findFileCwd verbosity mbWorkDir (coerceSymbolicPath buildDir : hsSourceDirs bnfo) modPath -- | Does this compiler support the @-dynamic-too@ option supportsDynamicToo :: Compiler -> Bool supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" +compilerBuildWay :: Compiler -> BuildWay+compilerBuildWay c =+ case (isDynamic c, isProfiled c) of+ (True, True) -> ProfDynWay+ (True, False) -> DynWay+ (False, True) -> ProfWay+ (False, False) -> StaticWay+ -- | Is this compiler's RTS dynamically linked? isDynamic :: Compiler -> Bool isDynamic = Internal.ghcLookupProperty "GHC Dynamic" +isProfiled :: Compiler -> Bool+isProfiled = Internal.ghcLookupProperty "GHC Profiled"+ -- | Should we dynamically link the foreign library, based on its 'foreignLibType'? withDynFLib :: ForeignLib -> Bool withDynFLib flib =@@ -58,32 +73,76 @@ ForeignLibTypeUnknown -> cabalBug "unknown foreign lib type" +-- | Is the extension of the file in the list of extensions?+extensionIn :: [String] -> FilePath -> Bool+extensionIn exts fp = takeExtension fp `elem` exts+ -- | Is this file a C++ source file, i.e. ends with .cpp, .cxx, or .c++? isCxx :: FilePath -> Bool-isCxx fp = elem (takeExtension fp) [".cpp", ".cxx", ".c++"]+isCxx = extensionIn [".cpp", ".cxx", ".c++"] -- | Is this a C source file, i.e. ends with .c? isC :: FilePath -> Bool-isC fp = elem (takeExtension fp) [".c"]+isC = extensionIn [".c"] -- | FilePath has a Haskell extension: .hs or .lhs isHaskell :: FilePath -> Bool-isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"]+isHaskell = extensionIn [".hs", ".lhs"] -- | 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+checkNeedsRecompilation+ :: Maybe (SymbolicPath CWD (Dir Pkg))+ -> SymbolicPath Pkg File+ -> GhcOptions+ -> IO Bool+checkNeedsRecompilation mbWorkDir filename opts =+ i filename `moreRecentFile` oname where- oname = getObjectFileName filename opts+ oname = getObjectFileName mbWorkDir filename opts+ i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path -- | Finds the object file name of the given source file-getObjectFileName :: FilePath -> GhcOptions -> FilePath-getObjectFileName filename opts = oname+getObjectFileName+ :: Maybe (SymbolicPath CWD (Dir Pkg))+ -- ^ Package directory+ -> SymbolicPath Pkg File+ -- ^ Symbolic path to the source file+ -> GhcOptions+ -- ^ GHC compilation options+ -> FilePath+ -- ^ Path to the object file+getObjectFileName mbWorkDir filename opts = oname where+ i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path odir = fromFlag (ghcOptObjDir opts) oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts)- oname = odir </> replaceExtension filename oext+ -- NB: the filepath might be absolute, e.g. if it is the path to+ -- an autogenerated .hs file.+ oname = i $ objectFilePath odir oext filename++-- | Given the path to a source file (Haskell, C, JS...), return the corresponding+-- object file path (input to the linker).+objectFilePath+ :: SymbolicPath Pkg (Dir Artifacts)+ -- ^ Objects build directory (@-odir@)+ -> String+ -- ^ Object file extension+ -> SymbolicPath Pkg File+ -- ^ Source file path (relative or absolute)+ -> SymbolicPath Pkg File+ -- ^ Resulting object file path+objectFilePath buildTargetDir objExt src =+ case symbolicPathRelative_maybe objPath of+ Just relObjPath ->+ -- For a relative input file, the output object file is placed under the -odir.+ coerceSymbolicPath buildTargetDir </> relObjPath+ Nothing ->+ -- For an absolute input file, the object file is placed next to the input file+ -- and not within -odir.+ objPath+ where+ objPath = src `replaceExtensionSymbolicPath` objExt -- | Target name for a foreign library (the actual file name) --
src/Distribution/Simple/GHC/EnvironmentParser.hs view
@@ -1,18 +1,13 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-} module Distribution.Simple.GHC.EnvironmentParser (parseGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc (..)) where +import Data.Functor (($>)) import Distribution.Compat.Prelude import Prelude () import Distribution.Simple.Compiler- ( PackageDB (..)- ) import Distribution.Simple.GHC.Internal ( GhcEnvironmentFileEntry (..) )@@ -26,12 +21,12 @@ , parseFromFile ) -parseEnvironmentFileLine :: Parser GhcEnvironmentFileEntry+parseEnvironmentFileLine :: Parser (GhcEnvironmentFileEntry FilePath) parseEnvironmentFileLine = GhcEnvFileComment <$> comment <|> GhcEnvFilePackageId <$> unitId <|> GhcEnvFilePackageDb <$> packageDb- <|> pure GhcEnvFileClearPackageDbStack <* clearDb+ <|> GhcEnvFileClearPackageDbStack <$ clearDb where comment = P.string "--" *> P.many (P.noneOf "\r\n") unitId =@@ -40,20 +35,20 @@ *> 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 "global-package-db" $> GlobalPackageDB)+ <|> (P.string "user-package-db" $> 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) instance Exception ParseErrorExc -parseGhcEnvironmentFile :: Parser [GhcEnvironmentFileEntry]+parseGhcEnvironmentFile :: Parser [GhcEnvironmentFileEntry FilePath] parseGhcEnvironmentFile = parseEnvironmentFileLine `P.sepEndBy` P.endOfLine <* P.eof -readGhcEnvironmentFile :: FilePath -> IO [GhcEnvironmentFileEntry]+readGhcEnvironmentFile :: FilePath -> IO [GhcEnvironmentFileEntry FilePath] readGhcEnvironmentFile path = either (throwIO . ParseErrorExc) return =<< parseFromFile parseGhcEnvironmentFile path
src/Distribution/Simple/GHC/ImplInfo.hs view
@@ -20,7 +20,13 @@ import Prelude () import Distribution.Simple.Compiler-import Distribution.Version+ ( Compiler+ , CompilerFlavor (..)+ , compilerCompatVersion+ , compilerFlavor+ , compilerVersion+ )+import Distribution.Types.Version (Version, versionNumbers) -- | -- Information about features and quirks of a GHC-based implementation.@@ -34,30 +40,14 @@ -- 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+ { supportsGHC2021 :: Bool -- ^ -XGHC2021 flag , supportsGHC2024 :: Bool -- ^ -XGHC2024 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 , flagHie :: Bool -- ^ -hiedir flag supported- , supportsDebugLevels :: Bool- -- ^ supports numeric @-g@ levels , supportsPkgEnvFiles :: Bool -- ^ picks up @.ghc.environment@ files , flagWarnMissingHomeModules :: Bool@@ -88,18 +78,10 @@ ghcVersionImplInfo :: Version -> GhcImplInfo ghcVersionImplInfo ver = GhcImplInfo- { supportsHaskell2010 = v >= [7]- , supportsGHC2021 = v >= [9, 1]+ { supportsGHC2021 = v >= [9, 1] , supportsGHC2024 = v >= [9, 9]- , 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] , flagHie = v >= [8, 8]- , 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]@@ -115,18 +97,10 @@ -> GhcImplInfo ghcjsVersionImplInfo _ghcjsver ghcver = GhcImplInfo- { supportsHaskell2010 = True- , supportsGHC2021 = True+ { supportsGHC2021 = ghcv >= [9, 1] , supportsGHC2024 = ghcv >= [9, 9]- , reportsNoExt = True- , alwaysNondecIndent = False- , flagGhciScript = True- , flagProfAuto = True- , flagProfLate = True- , flagPackageConf = False- , flagDebugInfo = False+ , flagProfLate = ghcv >= [9, 4] , flagHie = ghcv >= [8, 8]- , supportsDebugLevels = ghcv >= [8, 0] , supportsPkgEnvFiles = ghcv >= [8, 0, 2] -- TODO: check this works in ghcjs , flagWarnMissingHomeModules = ghcv >= [8, 2] , unitIdForExes = ghcv >= [9, 2]
src/Distribution/Simple/GHC/Internal.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -18,12 +19,8 @@ , getExtensions , targetPlatform , getGhcInfo- , componentCcGhcOptions- , componentCmmGhcOptions- , componentCxxGhcOptions- , componentAsmGhcOptions- , componentJsGhcOptions , componentGhcOptions+ , sourcesGhcOptions , mkGHCiLibName , mkGHCiProfLibName , filterGhciFlags@@ -33,6 +30,11 @@ , substTopDir , checkPackageDbEnvVar , profDetailLevelFlag+ , ghcOptionsSince+ , linkGhcOptions+ , optimizationCFlags+ , splitCandCxxOptions+ , SplitSource (..) -- * GHC platform and version strings , ghcArchString@@ -57,16 +59,14 @@ import qualified Data.Set as Set import Distribution.Backpack import Distribution.Compat.Stack-import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Lex import qualified Distribution.ModuleName as ModuleName-import Distribution.PackageDescription import Distribution.Parsec (simpleParsec) import Distribution.Pretty (prettyShow) import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler import Distribution.Simple.Errors-import Distribution.Simple.Flag (Flag (NoFlag), maybeToFlag, toFlag)+import Distribution.Simple.Flag import Distribution.Simple.GHC.ImplInfo import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program@@ -74,24 +74,27 @@ import Distribution.Simple.Setup.Common (extraCompilationArtifacts) import Distribution.Simple.Utils import Distribution.System-import Distribution.Types.ComponentId (ComponentId)+import Distribution.Types.BuildInfo import Distribution.Types.ComponentLocalBuildInfo+import Distribution.Types.GivenComponent+import qualified Distribution.Types.InstalledPackageInfo as IPI+import Distribution.Types.Library import Distribution.Types.LocalBuildInfo+import Distribution.Types.ModuleRenaming+import Distribution.Types.PackageName import Distribution.Types.TargetInfo import Distribution.Types.UnitId-import Distribution.Utils.NubList (toNubListR)+import Distribution.Types.Version+import Distribution.Utils.NubList (NubListR, toNubListR) import Distribution.Utils.Path import Distribution.Verbosity-import Distribution.Version (Version) import Language.Haskell.Extension-import System.Directory (getDirectoryContents, getTemporaryDirectory)+import System.Directory (listDirectory) import System.Environment (getEnv) import System.FilePath ( takeDirectory , takeExtension , takeFileName- , (<.>)- , (</>) ) import System.IO (hClose, hPutStrLn) @@ -112,6 +115,11 @@ , programPostConf = configureGcc } . addKnownProgram+ gppProgram+ { programFindLocation = findProg gppProgramName extraGppPath+ , programPostConf = configureGpp+ }+ . addKnownProgram ldProgram { programFindLocation = findProg ldProgramName extraLdPath , programPostConf = \v cp ->@@ -127,6 +135,7 @@ { programFindLocation = findProg stripProgramName extraStripPath } where+ compilerDir, base_dir, mingwBinDir :: FilePath compilerDir = takeDirectory (programPath ghcProg) base_dir = takeDirectory compilerDir mingwBinDir = base_dir </> "mingw" </> "bin"@@ -137,6 +146,7 @@ maybeName prog = maybe (programName prog) (dropExeExtension . takeFileName) gccProgramName = maybeName gccProgram mbGccLocation+ gppProgramName = maybeName gppProgram mbGppLocation ldProgramName = maybeName ldProgram mbLdLocation arProgramName = maybeName arProgram mbArLocation stripProgramName = maybeName stripProgram mbStripLocation@@ -149,18 +159,20 @@ mbDir = maybeToList . fmap takeDirectory $ mbPath extraGccPath = mkExtraPath mbGccLocation windowsExtraGccDir+ extraGppPath = mkExtraPath mbGppLocation windowsExtraGppDir 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+ , windowsExtraGppDir , windowsExtraLdDir , windowsExtraArDir , windowsExtraStripDir ) = let b = mingwBinDir </> binPrefix- in (b, b, b, b)+ in (b, b, b, b, b) findProg :: String@@ -171,20 +183,20 @@ findProg progName extraPath v searchpath = findProgramOnSearchPath v searchpath' progName where- searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath+ searchpath' = map ProgramSearchPathDir extraPath ++ searchpath -- Read tool locations from the 'ghc --info' output. Useful when -- cross-compiling. mbGccLocation = Map.lookup "C compiler command" ghcInfo+ mbGppLocation = 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"- -- 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"+ cxxFlags = getFlags "C++ compiler flags"+ gccLinkerFlags = getFlags "C compiler link flags"+ ldLinkerFlags = 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@@ -210,6 +222,15 @@ ++ gccLinkerFlags } + configureGpp :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram+ configureGpp _v gppProg = do+ return+ gppProg+ { programDefaultArgs =+ programDefaultArgs gppProg+ ++ cxxFlags+ }+ configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram configureLd v ldProg = do ldProg' <- configureLd' v ldProg@@ -221,9 +242,8 @@ -- 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+ ldx <- withTempFile ".c" $ \testcfile testchnd ->+ withTempFile ".o" $ \testofile testohnd -> do hPutStrLn testchnd "int foo() { return 0; }" hClose testchnd hClose testohnd@@ -236,7 +256,7 @@ , "-o" , testofile ]- withTempFile tempDir ".o" $ \testofile' testohnd' ->+ withTempFile ".o" $ \testofile' testohnd' -> do hClose testohnd' _ <-@@ -252,11 +272,9 @@ else return ldProg getLanguages- :: Verbosity- -> GhcImplInfo- -> ConfiguredProgram+ :: GhcImplInfo -> IO [(Language, String)]-getLanguages _ implInfo _+getLanguages implInfo -- TODO: should be using --supported-languages rather than hard coding | supportsGHC2024 implInfo = return@@ -271,12 +289,11 @@ , (Haskell2010, "-XHaskell2010") , (Haskell98, "-XHaskell98") ]- | supportsHaskell2010 implInfo =+ | otherwise = return [ (Haskell98, "-XHaskell98") , (Haskell2010, "-XHaskell2010") ]- | otherwise = return [(Haskell98, "")] getGhcInfo :: Verbosity@@ -298,233 +315,232 @@ getExtensions :: Verbosity- -> GhcImplInfo -> ConfiguredProgram -> IO [(Extension, Maybe String)]-getExtensions verbosity implInfo ghcProg = do+getExtensions verbosity 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+ return+ [ (ext, Just $ "-X" ++ prettyShow ext)+ | Just ext <- map simpleParsec $ lines str+ ] -componentCcGhcOptions- :: Verbosity- -> LocalBuildInfo+includePaths+ :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo- -> FilePath- -> FilePath- -> GhcOptions-componentCcGhcOptions verbosity 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- }+ -> SymbolicPath Pkg p+ -> NubListR (SymbolicPath Pkg (Dir Include))+includePaths lbi bi clbi odir =+ toNubListR $+ [ coerceSymbolicPath $ autogenComponentModulesDir lbi clbi+ , coerceSymbolicPath $ autogenPackageModulesDir lbi+ , coerceSymbolicPath odir+ ]+ -- includes relative to the package+ ++ includeDirs bi+ -- potential includes generated by `configure'+ -- in the build directory+ ++ [ buildDir lbi </> dir+ | dir <- mapMaybe (symbolicPathRelative_maybe . unsafeCoerceSymbolicPath) $ includeDirs bi+ ] -componentCxxGhcOptions- :: Verbosity+data SplitSource = CcProgram | CxxProgram++splitCandCxxOptions+ :: SplitSource+ -> VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo- -> FilePath- -> FilePath+ -> SymbolicPath Pkg (Dir Artifacts)+ -> SymbolicPath Pkg File -> GhcOptions-componentCxxGhcOptions verbosity 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- }+splitCandCxxOptions source verbosity lbi bi clbi odir filename = case source of+ CxxProgram ->+ -- For C++ sources: reset ccOptions for GHC < 8.10, because on those+ -- old GHCs there's no -optcxx flag — all options go through -optc.+ -- Without this reset, C-specific flags (ccOptions) would leak into+ -- C++ compilation via -optc, which is wrong.+ setGppProgram $ setCcOptions $ sourcesGhcOptions verbosity lbi bi clbi odir filename+ CcProgram ->+ -- For C sources: reset cxxOptions for GHC < 8.10, because on those+ -- old GHCs there's no -optcxx flag — all options go through -optc.+ -- Without this reset, C++-specific flags (cxxOptions) would leak into+ -- C compilation via -optc, which is wrong.+ setCcProgram $ setCxxOptions $ sourcesGhcOptions verbosity lbi bi clbi odir filename+ where+ setCcOptions xxx =+ xxx+ { -- C compiler options: GHC >= 8.10 requires -optcxx, older requires -optc+ -- we want to be able to support cxx-options and cc-options separately+ -- https://gitlab.haskell.org/ghc/ghc/-/issues/16477+ -- see example in cabal-testsuite/PackageTests/FFI/ForeignOptsCxx+ ghcOptCcOptions =+ ghcOptionsSince+ (mkVersion [8, 10])+ (compiler lbi)+ (optimizationCFlags lbi ++ ccOptions bi)+ }+ setCxxOptions xxx =+ xxx+ { -- C++ compiler options: GHC >= 8.10 requires -optcxx, older requires -optc+ -- we want to be able to support cxx-options and cc-options separately+ -- https://gitlab.haskell.org/ghc/ghc/-/issues/16477+ -- see example in cabal-testsuite/PackageTests/FFI/ForeignOptsC+ ghcOptCxxOptions =+ ghcOptionsSince+ (mkVersion [8, 10])+ (compiler lbi)+ (optimizationCFlags lbi ++ cxxOptions bi)+ }+ setCcProgram xxx =+ xxx+ { -- We pass -pgmc to ensure that GHC respects cc-options and ld-options (#4435, #9801).+ -- However, we deliberately restrict this flag ONLY to C and C++ source files.+ -- We do not pass it globally (e.g., during linking or ordinary Haskell compilation)+ -- for two reasons:+ -- 1. Status quo: This preserves Cabal's historical behavior.+ -- 2. GHC < 9.4 bug (https://gitlab.haskell.org/ghc/ghc/-/issues/15319): Before GHC 9.4,+ -- passing a custom C compiler via -pgmc caused GHC to automatically disable the+ -- -no-pie flag (which is critical during linking on auto-hardened toolchains).+ -- Passing -pgmc globally would therefore break linking on older GHCs.+ -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6949 fixed this by moving+ -- the -no-pie check to -pgml, but scoping -pgmc exclusively to C/C++ compilation+ -- protects older GHC versions from this link-time breakage.+ -- see example in cabal-testsuite/PackageTests/FFI/ForeignOptsPgmc+ ghcOptCcProgram = maybeToFlag $ programPath <$> lookupProgram gccProgram (withPrograms lbi)+ }+ setGppProgram xxx =+ xxx+ { -- We explicitly pass the C++ compiler via -pgmcxx because GHC >= 9.4+ -- does not automatically detect it from the toolchain. Without this GHC+ -- falls back to a gcc as a C++ compiler.+ -- Related: #11805+ ghcOptGppProgram =+ ghcOptionsSince+ (mkVersion [9, 4])+ (compiler lbi)+ (maybeToFlag $ programPath <$> lookupProgram gppProgram (withPrograms lbi))+ , -- For GHC < 9.4, which does not support -pgmcxx, we fall back to+ -- passing the C++ compiler via -pgmc. This ensures C++ sources are+ -- compiled with the correct compiler even on older GHCs.+ -- Note: we use gppProgram (C++ compiler), NOT gccProgram (C compiler),+ -- because this path is specifically for C++ source files.+ -- Related: #11805+ ghcOptCcProgram =+ ghcOptionsBefore+ (mkVersion [9, 4])+ (compiler lbi)+ (maybeToFlag $ programPath <$> lookupProgram gppProgram (withPrograms lbi))+ } -componentAsmGhcOptions- :: Verbosity+sourcesGhcOptions+ :: VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo- -> FilePath- -> FilePath+ -> SymbolicPath Pkg (Dir Artifacts)+ -> SymbolicPath Pkg File -> GhcOptions-componentAsmGhcOptions verbosity 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)+sourcesGhcOptions verbosity lbi bi clbi odir filename =+ (componentGhcOptions verbosity lbi bi clbi 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+ , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi+ , -- cpp-options apply only to .hs files; GHC ignores -optP for non-Haskell+ -- files (and since 9.10 this behavior is explicit/enforced)+ ghcOptCppOptions = [] } -componentJsGhcOptions- :: Verbosity+optimizationCFlags :: LocalBuildInfo -> [String]+optimizationCFlags lbi =+ ( case withOptimization lbi of+ -- see --disable-optimization+ NoOptimisation -> []+ -- '*-options: -O[n]' is generally not needed. When building with+ -- optimisations Cabal automatically adds '-O2' for * code. Setting it+ -- yourself interferes with the --disable-optimization flag.+ -- see https://github.com/haskell/cabal/pull/8250+ NormalOptimisation -> ["-O2"]+ -- see --enable-optimization+ MaximumOptimisation -> ["-O2"]+ )+ ++ ( case withDebugInfo lbi of+ NoDebugInfo -> []+ MinimalDebugInfo -> ["-g1"]+ NormalDebugInfo -> ["-g"]+ MaximalDebugInfo -> ["-g3"]+ )++-- Applies options only if the GHC version is greater than or+-- equal to the given one.+ghcOptionsSince :: Monoid a => Version -> Compiler -> a -> a+ghcOptionsSince ver comp defOptions =+ case compilerCompatVersion GHC comp of+ Just v+ | v >= ver -> defOptions+ | otherwise -> mempty+ Nothing -> mempty++-- Applies options only if the GHC version is less than the given one.+ghcOptionsBefore :: Monoid a => Version -> Compiler -> a -> a+ghcOptionsBefore ver comp defOptions =+ case compilerCompatVersion GHC comp of+ Just v+ | v < ver -> defOptions+ | otherwise -> mempty+ Nothing -> mempty++componentGhcOptions+ :: VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo- -> FilePath- -> FilePath+ -> SymbolicPath Pkg (Dir build) -> GhcOptions-componentJsGhcOptions verbosity 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- }+componentGhcOptions verbosity lbi bi clbi odir =+ let implInfo = getImplInfo $ compiler lbi+ in (linkGhcOptions verbosity lbi bi clbi)+ { ghcOptSourcePath =+ toNubListR $+ hsSourceDirs bi+ ++ [coerceSymbolicPath odir]+ ++ [autogenComponentModulesDir lbi clbi]+ ++ [autogenPackageModulesDir lbi]+ , ghcOptCppIncludePath = includePaths lbi bi clbi odir+ , ghcOptObjDir = toFlag $ coerceSymbolicPath odir+ , ghcOptHiDir = toFlag $ coerceSymbolicPath odir+ , ghcOptHieDir = bool NoFlag (toFlag $ coerceSymbolicPath odir </> (extraCompilationArtifacts </> makeRelativePathEx "hie")) $ flagHie implInfo+ , ghcOptStubDir = toFlag $ coerceSymbolicPath odir+ , ghcOptOutputDir = toFlag $ coerceSymbolicPath odir+ , ghcOptBytecodeDir = toFlag $ coerceSymbolicPath odir+ } -componentGhcOptions- :: Verbosity+linkGhcOptions+ :: VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo- -> FilePath -> GhcOptions-componentGhcOptions verbosity lbi bi clbi odir =+linkGhcOptions verbosity lbi bi clbi = let implInfo = getImplInfo $ compiler lbi in 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)+ ghcOptVerbosity = toFlag (min verbosity Normal)+ , ghcOptCcOptions = ccOptions bi+ , ghcOptCxxOptions = cxxOptions bi+ , ghcOptAsmOptions = asmOptions bi+ , ghcOptLinkOptions = ldOptions bi+ , ghcOptCppOptions = cppOptions bi+ , ghcOptJSppOptions = jsppOptions bi+ , ghcOptExtra = hcOptions GHC bi <> cmmOptions bi , ghcOptCabal = toFlag True , ghcOptThisUnitId = case clbi of LibComponentLocalBuildInfo{componentCompatPackageKey = pk} ->@@ -559,41 +575,32 @@ , 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- , ghcOptHieDir = bool NoFlag (toFlag $ odir </> extraCompilationArtifacts </> "hie") $ flagHie implInfo- , ghcOptStubDir = toFlag odir- , ghcOptOutputDir = toFlag odir+ toNubListR [coerceSymbolicPath (autogenComponentModulesDir lbi clbi </> makeRelativePathEx cppHeaderName)]+ , ghcOptFfiIncludes = toNubListR $ map getSymbolicPath $ includes bi , ghcOptOptimisation = toGhcOptimisation (withOptimization lbi) , ghcOptDebugInfo = toFlag (withDebugInfo lbi)- , ghcOptExtra = hcOptions GHC bi- , ghcOptExtraPath = toNubListR $ exe_paths+ , 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)+ , ghcOptExtensionMap = Map.fromList . compilerExtensions $ compiler lbi+ , -- Use -pgmc to ensure that Cabal always passes cc-options, ld-options to GHC (#4435, #9801)+ -- We can only do this on GHC >= 9.4, as we need https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6949+ -- Without that GHC MR, this change would cause GHC to never pass -no-pie when linking,+ -- which can cause breakage depending on the C toolchain use. We would have to appropriately+ -- pass -pgmc-supports-no-pie as appropriate to avoid this regression.+ ghcOptCcProgram =+ ghcOptionsSince+ (mkVersion [9, 4])+ (compiler lbi)+ (maybeToFlag $ programPath <$> lookupProgram gccProgram (withPrograms lbi))+ , -- The assumption that the C++ compiler is part of the toolchain is only since ghc-9.4.+ ghcOptGppProgram =+ ghcOptionsSince+ (mkVersion [9, 4])+ (compiler lbi)+ (maybeToFlag $ programPath <$> lookupProgram gppProgram (withPrograms lbi)) } where exe_paths =@@ -608,45 +615,6 @@ toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation -componentCmmGhcOptions- :: Verbosity- -> LocalBuildInfo- -> BuildInfo- -> ComponentLocalBuildInfo- -> FilePath- -> FilePath- -> GhcOptions-componentCmmGhcOptions verbosity 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- }- -- | Strip out flags that are not supported in ghci filterGhciFlags :: [String] -> [String] filterGhciFlags = filter supported@@ -679,20 +647,20 @@ -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo- -> FilePath+ -> SymbolicPath Pkg (Dir Artifacts) -> String -> Bool- -> IO [FilePath]+ -> IO [SymbolicPath Pkg File] 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)+ [ pref </> makeRelativePathEx (ModuleName.toFilePath x ++ splitSuffix) | x <- allLibModules lib clbi ]- objss <- traverse getDirectoryContents dirs+ objss <- traverse (listDirectory . i) dirs let objs =- [ dir </> obj+ [ dir </> makeRelativePathEx obj | (objs', dir) <- zip objss dirs , obj <- objs' , let obj_ext = takeExtension obj@@ -701,16 +669,18 @@ return objs | otherwise = return- [ pref </> ModuleName.toFilePath x <.> wanted_obj_ext+ [ pref </> makeRelativePathEx (ModuleName.toFilePath x <.> wanted_obj_ext) | x <- allLibModules lib clbi ]+ where+ i = interpretSymbolicPathLBI lbi -- | Create the required packaged arguments, but filtering out package arguments which -- 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+ :: Map (PackageName, ComponentName) PromisedComponent -> ComponentLocalBuildInfo -> [(OpenUnitId, ModuleRenaming)] mkGhcOptPackages promisedPkgsMap clbi =@@ -718,7 +688,7 @@ ] where -- Promised deps are going to be simple UnitIds- promised_cids = Set.fromList (map newSimpleUnitId (Map.elems promisedPkgsMap))+ promised_cids = Set.fromList (map (newSimpleUnitId . promisedComponentId) (Map.elems promisedPkgsMap)) substTopDir :: FilePath -> IPI.InstalledPackageInfo -> IPI.InstalledPackageInfo substTopDir topDir ipo =@@ -804,7 +774,7 @@ -- Constructing GHC environment files -- | The kinds of entries we can stick in a @.ghc.environment@ file.-data GhcEnvironmentFileEntry+data GhcEnvironmentFileEntry fp = -- | @-- a comment@ GhcEnvFileComment String | -- | @package-id foo-1.0-4fe301a...@@@ -812,7 +782,7 @@ | -- | @global-package-db@, -- @user-package-db@ or -- @package-db blah/package.conf.d/@- GhcEnvFilePackageDb PackageDB+ GhcEnvFilePackageDb (PackageDBX fp) | -- | @clear-package-db@ GhcEnvFileClearPackageDbStack deriving (Eq, Ord, Show)@@ -823,9 +793,9 @@ -- 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+ :: PackageDBStackX fp -> [UnitId]- -> [GhcEnvironmentFileEntry]+ -> [GhcEnvironmentFileEntry fp] simpleGhcEnvironmentFile packageDBs pkgids = GhcEnvFileClearPackageDbStack : map GhcEnvFilePackageDb packageDBs@@ -843,7 +813,7 @@ -- ^ the GHC target platform -> Version -- ^ the GHC version- -> [GhcEnvironmentFileEntry]+ -> [GhcEnvironmentFileEntry FilePath] -- ^ the content -> IO FilePath writeGhcEnvironmentFile directory platform ghcversion entries = do@@ -858,12 +828,12 @@ ".ghc.environment." ++ ghcPlatformAndVersionString platform ghcversion -- | Render a bunch of GHC environment file entries-renderGhcEnvironmentFile :: [GhcEnvironmentFileEntry] -> String+renderGhcEnvironmentFile :: [GhcEnvironmentFileEntry FilePath] -> String renderGhcEnvironmentFile = unlines . map renderGhcEnvironmentFileEntry -- | Render an individual GHC environment file entry-renderGhcEnvironmentFileEntry :: GhcEnvironmentFileEntry -> String+renderGhcEnvironmentFileEntry :: GhcEnvironmentFileEntry FilePath -> String renderGhcEnvironmentFileEntry entry = case entry of GhcEnvFileComment comment -> format comment where
src/Distribution/Simple/GHCJS.hs view
@@ -1,11 +1,12 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TupleSections #-} module Distribution.Simple.GHCJS ( getGhcInfo , configure+ , configureCompiler+ , compilerProgramDb , getInstalledPackages , getInstalledPackagesMonitorFiles , getPackageDBContents@@ -23,7 +24,6 @@ , hcPkgInfo , registerPackage , componentGhcOptions- , Internal.componentCcGhcOptions , getLibDir , isDynamic , getGlobalPackageDB@@ -61,6 +61,8 @@ import Distribution.Simple.Compiler import Distribution.Simple.Errors import Distribution.Simple.Flag+import Distribution.Simple.GHC.Build.Link (hasThreaded)+import Distribution.Simple.GHC.Build.Utils (isCxx, isHaskell) import Distribution.Simple.GHC.EnvironmentParser import Distribution.Simple.GHC.ImplInfo import qualified Distribution.Simple.GHC.Internal as Internal@@ -81,18 +83,19 @@ import Distribution.Types.ParStrat import Distribution.Utils.NubList import Distribution.Utils.Path-import Distribution.Verbosity (Verbosity)+import Distribution.Verbosity (Verbosity (..), VerbosityLevel, verbosityLevel) import Distribution.Version +import Control.Arrow ((***)) import Control.Monad (msum) import Data.Char (isLower) import qualified Data.Map as Map+import Data.Maybe (fromJust) import System.Directory ( canonicalizePath , createDirectoryIfMissing , doesFileExist , getAppUserDataDirectory- , removeFile , renameFile ) import System.FilePath@@ -100,21 +103,35 @@ , replaceExtension , takeDirectory , takeExtension- , (<.>)- , (</>) ) import qualified System.Info -- ----------------------------------------------------------------------------- -- Configuring +-- | Configure GHCJS, and then auxiliary programs such as @ghc-pkg@, @haddock@+-- as well as toolchain programs such as @ar@, @ld. configure :: Verbosity -> Maybe FilePath+ -- ^ user-specified @ghcjs@ path (optional) -> Maybe FilePath+ -- ^ user-specified @ghcjs-pkg@ path (optional) -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb) configure verbosity hcPath hcPkgPath conf0 = do+ (comp, compPlatform, progdb1) <- configureCompiler verbosity hcPath conf0+ compProgDb <- compilerProgramDb verbosity comp progdb1 hcPkgPath+ return (comp, compPlatform, compProgDb)++-- | Configure GHCJS.+configureCompiler+ :: Verbosity+ -> Maybe FilePath+ -- ^ user-specified @ghc@ path (optional)+ -> ProgramDb+ -> IO (Compiler, Maybe Platform, ProgramDb)+configureCompiler verbosity hcPath conf0 = do (ghcjsProg, ghcjsVersion, progdb1) <- requireProgramVersion verbosity@@ -135,6 +152,44 @@ let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion + languages <- Internal.getLanguages implInfo+ extensions <- Internal.getExtensions verbosity 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+ , compilerWiredInUnitIds = Nothing+ }+ compPlatform = Internal.targetPlatform ghcjsInfo+ return (comp, compPlatform, progdb1)++-- | Given a configured @ghcjs@ program, configure auxiliary programs such+-- as @ghcjs-pkg@ or @haddock@, based on the location of the @ghcjs@ executable.+compilerProgramDb+ :: Verbosity+ -> Compiler+ -> ProgramDb+ -> Maybe FilePath+ -- ^ user-specified @ghc-pkg@ path (optional)+ -> IO ProgramDb+compilerProgramDb verbosity comp progdb1 hcPkgPath = do+ let+ ghcjsProg = fromJust $ lookupProgram ghcjsProgram progdb1+ ghcjsVersion = compilerVersion comp+ ghcjsGhcVersion = case compilerCompat comp of+ [CompilerId GHC ghcjsGhcVer] -> ghcjsGhcVer+ compat -> error $ "could not parse ghcjsGhcVersion:" ++ show compat+ -- 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:@@ -186,28 +241,9 @@ progdb3 = addKnownProgram haddockProgram' $ addKnownProgram hsc2hsProgram' $- addKnownProgram hpcProgram' $- {- addKnownProgram runghcProgram' -} progdb2-- languages <- Internal.getLanguages verbosity implInfo ghcjsProg- extensions <- Internal.getExtensions verbosity implInfo ghcjsProg-- ghcjsInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg- let ghcInfoMap = Map.fromList ghcjsInfo+ addKnownProgram hpcProgram' {- addKnownProgram runghcProgram' -} progdb2 - 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)+ return progdb3 guessGhcjsPkgFromGhcjsPath :: ConfiguredProgram@@ -313,29 +349,31 @@ -- | Given a single package DB, return all installed packages. getPackageDBContents :: Verbosity- -> PackageDB+ -> Maybe (SymbolicPath CWD (Dir from))+ -> PackageDBX (SymbolicPath from (Dir PkgDB)) -> ProgramDb -> IO InstalledPackageIndex-getPackageDBContents verbosity packagedb progdb = do- pkgss <- getInstalledPackages' verbosity [packagedb] progdb+getPackageDBContents verbosity mbWorkDir packagedb progdb = do+ pkgss <- getInstalledPackages' verbosity mbWorkDir [packagedb] progdb toPackageIndex verbosity pkgss progdb -- | Given a package DB stack, return all installed packages. getInstalledPackages :: Verbosity- -> PackageDBStack+ -> Maybe (SymbolicPath CWD (Dir from))+ -> PackageDBStackX (SymbolicPath from (Dir PkgDB)) -> ProgramDb -> IO InstalledPackageIndex-getInstalledPackages verbosity packagedbs progdb = do+getInstalledPackages verbosity mbWorkDir packagedbs progdb = do checkPackageDbEnvVar verbosity checkPackageDbStack verbosity packagedbs- pkgss <- getInstalledPackages' verbosity packagedbs progdb+ pkgss <- getInstalledPackages' verbosity mbWorkDir packagedbs progdb index <- toPackageIndex verbosity pkgss progdb return $! index toPackageIndex :: Verbosity- -> [(PackageDB, [InstalledPackageInfo])]+ -> [(PackageDBX a, [InstalledPackageInfo])] -> ProgramDb -> IO InstalledPackageIndex toPackageIndex verbosity pkgss progdb = do@@ -347,7 +385,7 @@ [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) | (_, pkgs) <- pkgss ]- return $! (mconcat indices)+ return $! mconcat indices where ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb @@ -391,7 +429,7 @@ checkPackageDbEnvVar verbosity = Internal.checkPackageDbEnvVar verbosity "GHCJS" "GHCJS_PACKAGE_PATH" -checkPackageDbStack :: Verbosity -> PackageDBStack -> IO ()+checkPackageDbStack :: Eq fp => Verbosity -> PackageDBStackX fp -> IO () checkPackageDbStack _ (GlobalPackageDB : rest) | GlobalPackageDB `notElem` rest = return () checkPackageDbStack verbosity rest@@ -402,13 +440,14 @@ getInstalledPackages' :: Verbosity- -> [PackageDB]+ -> Maybe (SymbolicPath CWD (Dir from))+ -> [PackageDBX (SymbolicPath from (Dir PkgDB))] -> ProgramDb- -> IO [(PackageDB, [InstalledPackageInfo])]-getInstalledPackages' verbosity packagedbs progdb =+ -> IO [(PackageDBX (SymbolicPath from (Dir PkgDB)), [InstalledPackageInfo])]+getInstalledPackages' verbosity mbWorkDir packagedbs progdb = sequenceA [ do- pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb+ pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity mbWorkDir packagedb return (packagedb, pkgs) | packagedb <- packagedbs ]@@ -417,10 +456,11 @@ getInstalledPackagesMonitorFiles :: Verbosity -> Platform+ -> Maybe (SymbolicPath CWD (Dir Pkg)) -> ProgramDb -> [PackageDB] -> IO [FilePath]-getInstalledPackagesMonitorFiles verbosity platform progdb =+getInstalledPackagesMonitorFiles verbosity platform mbWorkDir progdb = traverse getPackageDBPath where getPackageDBPath :: PackageDB -> IO FilePath@@ -428,13 +468,17 @@ selectMonitorFile =<< getGlobalPackageDB verbosity ghcjsProg getPackageDBPath UserPackageDB = selectMonitorFile =<< getUserPackageDB verbosity ghcjsProg platform- getPackageDBPath (SpecificPackageDB path) = selectMonitorFile path+ getPackageDBPath (SpecificPackageDB path) = selectMonitorFile (interpretSymbolicPath mbWorkDir path) -- GHC has old style file dbs, and new style directory dbs. -- Note that for dir style dbs, we only need to monitor the cache file, not -- the whole directory. The ghc program itself only reads the cache file -- so it's safe to only monitor this one file.- selectMonitorFile path = do+ selectMonitorFile path0 = do+ let path =+ if isRelative path0+ then interpretSymbolicPath mbWorkDir (makeRelativePathEx path0)+ else path0 isFileStyle <- doesFileExist path if isFileStyle then return path@@ -493,15 +537,21 @@ whenStaticLib forceStatic = when (forceStatic || withStaticLib lbi) -- whenGHCiLib = when (withGHCiLib lbi)- forRepl = maybe False (const True) mReplFlags+ forRepl = isJust mReplFlags -- ifReplLib = when forRepl comp = compiler lbi implInfo = getImplInfo comp platform@(Platform _hostArch _hostOS) = hostPlatform lbi has_code = not (componentIsIndefinite clbi)+ mbWorkDir = mbWorkDirLBI lbi + -- See Note [Symbolic paths] in Distribution.Utils.Path+ i = interpretSymbolicPathLBI lbi+ u :: SymbolicPathX allowAbs Pkg to -> FilePath+ u = getSymbolicPath+ (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)- let runGhcjsProg = runGHC verbosity ghcjsProg comp platform+ let runGhcjsProg = runGHC verbosity ghcjsProg comp platform mbWorkDir let libBi = libBuildInfo lib @@ -518,25 +568,25 @@ let isCoverageEnabled = libCoverage lbi hpcdir way | forRepl = mempty -- HPC is not supported in ghci- | isCoverageEnabled = toFlag $ Hpc.mixDir (libTargetDir </> extraCompilationArtifacts) way+ | isCoverageEnabled = toFlag $ Hpc.mixDir (coerceSymbolicPath libTargetDir </> coerceSymbolicPath extraCompilationArtifacts) way | otherwise = mempty - createDirectoryIfMissingVerbose verbosity True libTargetDir+ createDirectoryIfMissingVerbose verbosity True $ i 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+ cObjs = map (`replaceExtensionSymbolicPath` objExtension) cLikeFiles+ baseOpts = componentGhcOptions (verbosityLevel verbosity) lbi libBi clbi libTargetDir linkJsLibOpts = mempty { ghcOptExtra = [ "-link-js-lib" , getHSLibraryName uid , "-js-lib-outputdir"- , libTargetDir+ , u libTargetDir ]- ++ jsSrcs+ ++ map u jsSrcs } vanillaOptsNoJsLib = baseOpts@@ -569,7 +619,7 @@ , ghcOptFPic = toFlag True , -- ghcOptHiSuffix = toFlag "dyn_hi", -- ghcOptObjSuffix = toFlag "dyn_o",- ghcOptExtra = hcSharedOptions GHC libBi+ ghcOptExtra = hcOptions GHC libBi ++ hcSharedOptions GHC libBi , ghcOptHPCDir = hpcdir Hpc.Dyn } @@ -605,7 +655,7 @@ -- static and dynamically linked executables. We copy -- the modules interfaces so they are available under -- both ways.- copyDirectoryRecursive verbosity dynDir vanillaDir+ copyDirectoryRecursive verbosity (i dynDir) (i vanillaDir) _ -> return () else if isGhcjsDynamic@@ -690,39 +740,22 @@ info verbosity "Linking..." let cSharedObjs = map- (`replaceExtension` ("dyn_" ++ objExtension))+ (`replaceExtensionSymbolicPath` ("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+ sharedLibFilePath = libTargetDir </> makeRelativePathEx (mkSharedLibName (hostPlatform lbi) compiler_id uid)+ staticLibFilePath = libTargetDir </> makeRelativePathEx (mkStaticLibName (hostPlatform lbi) compiler_id uid) 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+ (coerceSymbolicPath libTargetDir) objExtension True hSharedObjs <-@@ -733,7 +766,7 @@ lib lbi clbi- libTargetDir+ (coerceSymbolicPath libTargetDir) ("dyn_" ++ objExtension) False else return []@@ -743,11 +776,11 @@ let staticObjectFiles = hObjs- ++ map (libTargetDir </>) cObjs+ ++ map (makeSymbolicPath . (getSymbolicPath libTargetDir </>) . getSymbolicPath) cObjs ++ stubObjs dynamicObjectFiles = hSharedObjs- ++ map (libTargetDir </>) cSharedObjs+ ++ map (makeSymbolicPath . (getSymbolicPath libTargetDir </>) . getSymbolicPath) cSharedObjs ++ stubSharedObjs -- After the relocation lib is created we invoke ghc -shared -- with the dependencies spelled out as -package arguments@@ -758,16 +791,8 @@ , 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+ , ghcOptExtra = hcOptions GHC libBi ++ hcSharedOptions GHC libBi+ , ghcOptHideAllPackages = toFlag True , ghcOptNoAutoLinkPackages = toFlag True , ghcOptPackageDBs = withPackageDB lbi , ghcOptThisUnitId = case clbi of@@ -789,7 +814,7 @@ Internal.mkGhcOptPackages mempty clbi , ghcOptLinkLibs = extraLibs libBi , ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi- , ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi+ , ghcOptLinkFrameworks = toNubListR $ map getSymbolicPath $ PD.frameworks libBi , ghcOptLinkFrameworkDirs = toNubListR $ PD.extraFrameworkDirs libBi , ghcOptRPaths = rpaths@@ -863,7 +888,7 @@ } checkPackageDbStack verbosity packageDBs (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram progdb- runGHC verbosity ghcjsProg comp platform replOpts+ runGHC verbosity ghcjsProg comp platform Nothing replOpts -- ----------------------------------------------------------------------------- -- Building an executable or foreign library@@ -1037,7 +1062,7 @@ ForeignLibTypeUnknown -> cabalBug "unknown foreign lib type" -gbuildModDefFiles :: GBuildMode -> [FilePath]+gbuildModDefFiles :: GBuildMode -> [RelativePath Source File] gbuildModDefFiles (GBuildExe _) = [] gbuildModDefFiles (GReplExe _ _) = [] gbuildModDefFiles (GBuildFLib flib) = foreignLibModDefFile flib@@ -1103,21 +1128,22 @@ -- -- Used to correctly build and link sources. data BuildSources = BuildSources- { cSourcesFiles :: [FilePath]- , cxxSourceFiles :: [FilePath]- , inputSourceFiles :: [FilePath]+ { cSourcesFiles :: [SymbolicPath Pkg File]+ , cxxSourceFiles :: [SymbolicPath Pkg File]+ , inputSourceFiles :: [SymbolicPath Pkg File] , inputSourceModules :: [ModuleName] } -- | Locate and return the 'BuildSources' required to build and link. gbuildSources :: Verbosity+ -> Maybe (SymbolicPath CWD ('Dir Pkg)) -> PackageId -> CabalSpecVersion- -> FilePath+ -> SymbolicPath Pkg (Dir Source) -> GBuildMode -> IO BuildSources-gbuildSources verbosity pkgId specVer tmpDir bm =+gbuildSources verbosity mbWorkDir pkgId specVer tmpDir bm = case bm of GBuildExe exe -> exeSources exe GReplExe _ exe -> exeSources exe@@ -1126,12 +1152,13 @@ where exeSources :: Executable -> IO BuildSources exeSources exe@Executable{buildInfo = bnfo, modulePath = modPath} = do- main <- findFileEx verbosity (tmpDir : map getSymbolicPath (hsSourceDirs bnfo)) modPath+ main <- findFileCwd verbosity mbWorkDir (tmpDir : hsSourceDirs bnfo) modPath let mainModName = fromMaybe ModuleName.main $ exeMainModuleName exe otherModNames = exeModules exe+ haskellMain = isHaskell (getSymbolicPath main) -- Scripts have fakePackageId and are always Haskell but can have any extension.- if isHaskell main || pkgId == fakePackageId+ if haskellMain || pkgId == fakePackageId then if specVer < CabalSpecV2_0 && (mainModName `elem` otherModNames) then do@@ -1168,7 +1195,7 @@ } else let (csf, cxxsf)- | isCxx main = (cSources bnfo, main : cxxSources bnfo)+ | isCxx (getSymbolicPath 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@@ -1190,13 +1217,6 @@ , inputSourceModules = foreignLibModules flib } - isCxx :: FilePath -> Bool- isCxx fp = elem (takeExtension fp) [".cpp", ".cxx", ".c++"]---- | FilePath has a Haskell extension: .hs or .lhs-isHaskell :: FilePath -> Bool-isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"]- -- | Generic build function. See comment for 'GBuildMode'. gbuild :: Verbosity@@ -1215,7 +1235,8 @@ GBuildFLib{} -> mempty comp = compiler lbi platform = hostPlatform lbi- runGhcProg = runGHC verbosity ghcjsProg comp platform+ mbWorkDir = mbWorkDirLBI lbi+ runGhcProg = runGHC verbosity ghcjsProg comp platform mbWorkDir let (bnfo, threaded) = case bm of GBuildFLib _ -> popThreadedFlag (gbuildInfo bm)@@ -1223,11 +1244,15 @@ -- 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")- createDirectoryIfMissingVerbose verbosity True targetDir- createDirectoryIfMissingVerbose verbosity True tmpDir+ targetDir = buildDir lbi </> makeRelativePathEx (gbuildName bm)+ tmpDir = targetDir </> makeRelativePathEx (gbuildName bm ++ "-tmp") + -- See Note [Symbolic paths] in Distribution.Utils.Path+ i = interpretSymbolicPath mbWorkDir++ createDirectoryIfMissingVerbose verbosity True $ i targetDir+ createDirectoryIfMissingVerbose verbosity True $ i tmpDir+ -- TODO: do we need to put hs-boot files into place for mutually recursive -- modules? FIX: what about exeName.hi-boot? @@ -1236,11 +1261,11 @@ let isCoverageEnabled = exeCoverage lbi hpcdir way | gbuildIsRepl bm = mempty -- HPC is not supported in ghci- | isCoverageEnabled = toFlag $ Hpc.mixDir (tmpDir </> extraCompilationArtifacts) way+ | isCoverageEnabled = toFlag $ Hpc.mixDir (tmpDir </> coerceSymbolicPath extraCompilationArtifacts) way | otherwise = mempty rpaths <- getRPaths lbi clbi- buildSources <- gbuildSources verbosity (package pkg_descr) (specVersion pkg_descr) tmpDir bm+ buildSources <- gbuildSources verbosity mbWorkDir (package pkg_descr) (specVersion pkg_descr) tmpDir bm let cSrcs = cSourcesFiles buildSources cxxSrcs = cxxSourceFiles buildSources@@ -1248,8 +1273,8 @@ inputModules = inputSourceModules buildSources isGhcDynamic = isDynamic comp dynamicTooSupported = supportsDynamicToo comp- cObjs = map (`replaceExtension` objExtension) cSrcs- cxxObjs = map (`replaceExtension` objExtension) cxxSrcs+ cObjs = map (`replaceExtensionSymbolicPath` objExtension) cSrcs+ cxxObjs = map (`replaceExtensionSymbolicPath` objExtension) cxxSrcs needDynamic = gbuildNeedDynamic lbi bm needProfiling = withProfExe lbi @@ -1261,18 +1286,18 @@ TestComponentLocalBuildInfo{} -> True BenchComponentLocalBuildInfo{} -> True baseOpts =- (componentGhcOptions verbosity lbi bnfo clbi tmpDir)+ componentGhcOptions (verbosityLevel verbosity) lbi bnfo clbi tmpDir `mappend` mempty { ghcOptMode = toFlag GhcModeMake , ghcOptInputFiles = toNubListR $ if package pkg_descr == fakePackageId- then filter isHaskell inputFiles+ then filter (isHaskell . getSymbolicPath) inputFiles else inputFiles , ghcOptInputScripts = toNubListR $ if package pkg_descr == fakePackageId- then filter (not . isHaskell) inputFiles+ then filter (not . isHaskell . getSymbolicPath) inputFiles else [] , ghcOptInputModules = toNubListR inputModules , -- for all executable components (exe/test/bench),@@ -1309,7 +1334,7 @@ ghcOptFPic = toFlag True , ghcOptHiSuffix = toFlag "dyn_hi" , ghcOptObjSuffix = toFlag "dyn_o"- , ghcOptExtra = hcSharedOptions GHC bnfo+ , ghcOptExtra = hcOptions GHC bnfo ++ hcSharedOptions GHC bnfo , ghcOptHPCDir = hpcdir Hpc.Dyn } dynTooOpts =@@ -1327,13 +1352,14 @@ , ghcOptLinkLibPath = toNubListR $ extraLibDirs bnfo , ghcOptLinkFrameworks = toNubListR $- PD.frameworks bnfo+ map getSymbolicPath $+ PD.frameworks bnfo , ghcOptLinkFrameworkDirs = toNubListR $ PD.extraFrameworkDirs bnfo , ghcOptInputFiles = toNubListR- [tmpDir </> x | x <- cObjs ++ cxxObjs]+ [makeSymbolicPath $ getSymbolicPath tmpDir </> getSymbolicPath x | x <- cObjs ++ cxxObjs] } dynLinkerOpts = mempty@@ -1416,13 +1442,7 @@ sequence_ [ do let baseCxxOpts =- Internal.componentCxxGhcOptions- verbosity- lbi- bnfo- clbi- tmpDir- filename+ Internal.splitCandCxxOptions Internal.CxxProgram (verbosityLevel verbosity) lbi bnfo clbi odir filename vanillaCxxOpts = if isGhcDynamic then -- Dynamic GHC requires C++ sources to be built@@ -1449,8 +1469,8 @@ -- 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+ createDirectoryIfMissingVerbose verbosity True (i odir)+ needsRecomp <- checkNeedsRecompilation mbWorkDir filename opts when needsRecomp $ runGhcProg opts | filename <- cxxSrcs@@ -1462,13 +1482,7 @@ sequence_ [ do let baseCcOpts =- Internal.componentCcGhcOptions- verbosity- lbi- bnfo- clbi- tmpDir- filename+ Internal.splitCandCxxOptions Internal.CcProgram (verbosityLevel verbosity) lbi bnfo clbi tmpDir filename vanillaCcOpts = if isGhcDynamic then -- Dynamic GHC requires C sources to be built@@ -1491,8 +1505,8 @@ | needDynamic = sharedCcOpts | otherwise = vanillaCcOpts odir = fromFlag (ghcOptObjDir opts)- createDirectoryIfMissingVerbose verbosity True odir- needsRecomp <- checkNeedsRecompilation filename opts+ createDirectoryIfMissingVerbose verbosity True (i odir)+ needsRecomp <- checkNeedsRecompilation mbWorkDir filename opts when needsRecomp $ runGhcProg opts | filename <- cSrcs@@ -1516,10 +1530,7 @@ 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- e <- doesFileExist target- when e (removeFile target)+ let target = targetDir </> makeRelativePathEx targetName runGhcProg linkOpts{ghcOptOutputFile = toFlag target} GBuildFLib flib -> do let rtsInfo = extractRtsInfo lbi@@ -1543,9 +1554,9 @@ { ghcOptLinkNoHsMain = toFlag True , ghcOptShared = toFlag True , ghcOptLinkLibs = rtsOptLinkLibs- , ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo+ , ghcOptLinkLibPath = toNubListR $ map makeSymbolicPath $ rtsLibPaths rtsInfo , ghcOptFPic = toFlag True- , ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm+ , ghcOptLinkModDefFiles = toNubListR $ fmap getSymbolicPath $ gbuildModDefFiles bm } ForeignLibNativeStatic -> -- this should be caught by buildFLib@@ -1559,8 +1570,9 @@ -- @flibBuildName@. info verbosity "Linking..." let buildName = flibBuildName lbi flib- runGhcProg linkOpts{ghcOptOutputFile = toFlag (targetDir </> buildName)}- renameFile (targetDir </> buildName) (targetDir </> targetName)+ buildFile = targetDir </> makeRelativePathEx buildName+ runGhcProg linkOpts{ghcOptOutputFile = toFlag buildFile}+ renameFile (i buildFile) (i targetDir </> targetName) data DynamicRtsInfo = DynamicRtsInfo { dynRtsVanillaLib :: FilePath@@ -1629,18 +1641,31 @@ -- | 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+checkNeedsRecompilation+ :: Maybe (SymbolicPath CWD (Dir Pkg))+ -> SymbolicPath Pkg File+ -> GhcOptions+ -> IO Bool+checkNeedsRecompilation mbWorkDir filename opts =+ i filename `moreRecentFile` oname where- oname = getObjectFileName filename opts+ oname = getObjectFileName mbWorkDir filename opts+ i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path -- | Finds the object file name of the given source file-getObjectFileName :: FilePath -> GhcOptions -> FilePath-getObjectFileName filename opts = oname+getObjectFileName+ :: Maybe (SymbolicPath CWD (Dir Pkg))+ -> SymbolicPath Pkg File+ -> GhcOptions+ -> FilePath+getObjectFileName mbWorkDir filename opts = oname where- odir = fromFlag (ghcOptObjDir opts)+ i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path+ odir = i $ fromFlag (ghcOptObjDir opts) oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts)- oname = odir </> replaceExtension filename oext+ -- NB: the filepath might be absolute, e.g. if it is the path to+ -- an autogenerated .hs file.+ oname = odir </> replaceExtension (getSymbolicPath filename) oext -- | Calculate the RPATHs for the component we are building. --@@ -1674,7 +1699,7 @@ supportRPaths OSX = True supportRPaths FreeBSD = case compid of- CompilerId GHC ver | ver >= mkVersion [7, 10, 2] -> True+ CompilerId GHC _ -> True _ -> False supportRPaths OpenBSD = False supportRPaths NetBSD = False@@ -1703,7 +1728,7 @@ popThreadedFlag :: BuildInfo -> (BuildInfo, Bool) popThreadedFlag bi = ( bi{options = filterHcOptions (/= "-threaded") (options bi)}- , hasThreaded (options bi)+ , hasThreaded bi ) where filterHcOptions@@ -1713,9 +1738,6 @@ filterHcOptions p (PerCompilerFlavor 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@@ -1730,8 +1752,9 @@ libBi = libBuildInfo lib comp = compiler lbi platform = hostPlatform lbi+ mbWorkDir = mbWorkDirLBI lbi vanillaArgs =- (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi))+ componentGhcOptions (verbosityLevel verbosity) lbi libBi clbi (componentBuildDir lbi clbi) `mappend` mempty { ghcOptMode = toFlag GhcModeAbiHash , ghcOptInputModules = toNubListR $ exposedModules lib@@ -1743,7 +1766,7 @@ , ghcOptFPic = toFlag True , ghcOptHiSuffix = toFlag "js_dyn_hi" , ghcOptObjSuffix = toFlag "js_dyn_o"- , ghcOptExtra = hcSharedOptions GHC libBi+ , ghcOptExtra = hcOptions GHC libBi ++ hcSharedOptions GHC libBi } profArgs = vanillaArgs@@ -1767,15 +1790,15 @@ hash <- getProgramInvocationOutput verbosity- =<< ghcInvocation verbosity ghcjsProg comp platform ghcArgs+ =<< ghcInvocation verbosity ghcjsProg comp platform mbWorkDir ghcArgs return (takeWhile (not . isSpace) hash) componentGhcOptions- :: Verbosity+ :: VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo- -> FilePath+ -> SymbolicPath Pkg (Dir build) -> GhcOptions componentGhcOptions verbosity lbi bi clbi odir = let opts = Internal.componentGhcOptions verbosity lbi bi clbi odir@@ -1812,7 +1835,7 @@ exeFileName = exeName' fixedExeBaseName = progprefix ++ exeName' ++ progsuffix installBinary dest = do- runDbProgram verbosity ghcjsProgram (withPrograms lbi) $+ runDbProgramCwd verbosity (mbWorkDirLBI lbi) ghcjsProgram (withPrograms lbi) $ [ "--install-executable" , buildPref </> exeName' </> exeFileName , "-o"@@ -1856,12 +1879,14 @@ -> FilePath -- ^ install location for dynamic libraries -> FilePath+ -- ^ install location for bytecode libraries+ -> FilePath -- ^ Build location -> PackageDescription -> Library -> ComponentLocalBuildInfo -> IO ()-installLib verbosity lbi targetDir dynlibTargetDir _builtDir _pkg lib clbi = do+installLib verbosity lbi targetDir dynlibTargetDir _bytecodeTargetDir _builtDir _pkg lib clbi = do whenVanilla $ copyModuleFiles $ Suffix "js_hi" whenProf $ copyModuleFiles $ Suffix "js_p_hi" whenShared $ copyModuleFiles $ Suffix "js_dyn_hi"@@ -1874,7 +1899,7 @@ whenVanilla $ do sequence_ [ installOrdinary builtDir' targetDir (toJSLibName $ mkGenericStaticLibName (l ++ f))- | l <- getHSLibraryName (componentUnitId clbi) : (extraBundledLibs (libBuildInfo lib))+ | l <- getHSLibraryName (componentUnitId clbi) : extraBundledLibs (libBuildInfo lib) , f <- "" : extraLibFlavours (libBuildInfo lib) ] -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciLibName)@@ -1891,10 +1916,12 @@ , f <- "" : extraDynLibFlavours (libBuildInfo lib) ] where+ i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path builtDir' = componentBuildDir lbi clbi+ mbWorkDir = mbWorkDirLBI lbi install isShared isJS srcDir dstDir name = do- let src = srcDir </> name+ let src = i $ srcDir </> makeRelativePathEx name dst = dstDir </> name createDirectoryIfMissingVerbose verbosity True dstDir @@ -1912,9 +1939,10 @@ installOrdinary = install False True installShared = install True True - copyModuleFiles ext =- findModuleFilesEx verbosity [builtDir'] [ext] (allLibModules lib clbi)- >>= installOrdinaryFiles verbosity targetDir+ copyModuleFiles ext = do+ files <- findModuleFilesCwd verbosity mbWorkDir [builtDir'] [ext] (allLibModules lib clbi)+ let files' = map (i *** getSymbolicPath) files+ installOrdinaryFiles verbosity targetDir files' compiler_id = compilerId (compiler lbi) platform = hostPlatform lbi@@ -1964,35 +1992,23 @@ -- ----------------------------------------------------------------------------- -- Registering -hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo+hcPkgInfo :: ProgramDb -> HcPkg.ConfiguredProgram 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]- ghcjsPkgProg = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs program") $ lookupProgram ghcjsPkgProgram progdb- ver = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs version") $ programVersion ghcjsPkgProg+ fromMaybe (error "GHCJS.hcPkgInfo no ghcjs program") $ lookupProgram ghcjsPkgProgram progdb registerPackage :: Verbosity -> ProgramDb- -> PackageDBStack+ -> Maybe (SymbolicPath CWD (Dir from))+ -> PackageDBStackS from -> InstalledPackageInfo -> HcPkg.RegisterOptions -> IO ()-registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions =+registerPackage verbosity progdb mbWorkDir packageDbs installedPkgInfo registerOptions = HcPkg.register (hcPkgInfo progdb) verbosity+ mbWorkDir packageDbs installedPkgInfo registerOptions@@ -2020,7 +2036,10 @@ -- fail. createDirectoryIfMissing True rootDir return rootDir- pkgRoot' (SpecificPackageDB fp) = return (takeDirectory fp)+ pkgRoot' (SpecificPackageDB fp) =+ return $+ takeDirectory $+ interpretSymbolicPathLBI lbi fp -- | Get the JavaScript file name and command and arguments to run a -- program compiled by GHCJS
src/Distribution/Simple/Glob.hs view
@@ -1,6 +1,7 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- @@ -22,6 +23,8 @@ , GlobResult (..) , globMatches , fileGlobMatches+ , matchGlob+ , matchGlobPieces , matchDirFileGlob , matchDirFileGlobWithDie , runDirFileGlob@@ -39,20 +42,84 @@ import Distribution.Compat.Prelude import Prelude () -import Distribution.CabalSpecVersion (CabalSpecVersion)+import Distribution.CabalSpecVersion+ ( CabalSpecVersion (..)+ )+import Distribution.Pretty import Distribution.Simple.Errors ( CabalException (MatchDirFileGlob, MatchDirFileGlobErrors) ) import Distribution.Simple.Glob.Internal-import Distribution.Simple.Utils (dieWithException, warn)-import Distribution.Verbosity (Verbosity)+import Distribution.Simple.Utils+ ( debug+ , dieWithException+ , getDirectoryContentsRecursive+ , warn+ )+import Distribution.Utils.Path+import Distribution.Verbosity+ ( Verbosity+ , defaultVerbosityHandles+ , mkVerbosity+ , silent+ ) +import Control.Monad (mapM)+import Data.List (stripPrefix)+import System.Directory+import System.FilePath hiding ((<.>), (</>))+ ------------------------------------------------------------------------------- -- * Matching -------------------------------------------------------------------------------- +-- | Match a 'Glob' against the file system, starting from a+-- given root directory. The results are all relative to the given root.+--+-- @since 3.12.0.0+matchGlob :: FilePath -> Glob -> IO [FilePath]+matchGlob root glob =+ -- For this function, which is the general globbing one (doesn't care about+ -- cabal spec, used e.g. for monitoring), we consider all matches.+ mapMaybe+ ( \case+ GlobMatch a -> Just a+ GlobWarnMultiDot a -> Just a+ GlobMatchesDirectory a -> Just a+ GlobMissingDirectory{} -> Nothing+ )+ <$> runDirFileGlob (mkVerbosity defaultVerbosityHandles silent) Nothing root glob++-- | Match a globbing pattern against a file path component+matchGlobPieces :: GlobPieces -> String -> Bool+matchGlobPieces = goStart+ where+ -- From the man page, glob(7):+ -- "If a filename starts with a '.', this character must be+ -- matched explicitly."++ 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+ -- | Extract the matches from a list of 'GlobResult's. -- -- Note: throws away the 'GlobMissingDirectory' results; chances are@@ -75,7 +142,12 @@ -- prefix. -- -- The second 'FilePath' is the glob itself.-matchDirFileGlob :: Verbosity -> CabalSpecVersion -> FilePath -> FilePath -> IO [FilePath]+matchDirFileGlob+ :: Verbosity+ -> CabalSpecVersion+ -> Maybe (SymbolicPath CWD (Dir dir))+ -> SymbolicPathX allowAbs dir file+ -> IO [SymbolicPathX allowAbs dir file] matchDirFileGlob v = matchDirFileGlobWithDie v dieWithException -- | Like 'matchDirFileGlob' but with customizable 'die'@@ -83,45 +155,367 @@ -- @since 3.6.0.0 matchDirFileGlobWithDie :: Verbosity- -> (Verbosity -> CabalException -> IO [FilePath])+ -> (forall res. Verbosity -> CabalException -> IO [res]) -> CabalSpecVersion- -> FilePath+ -> Maybe (SymbolicPath CWD (Dir dir))+ -> SymbolicPathX allowAbs dir file+ -> IO [SymbolicPathX allowAbs dir file]+matchDirFileGlobWithDie verbosity rip version mbWorkDir symPath =+ let rawFilePath = getSymbolicPath symPath+ dir = maybe "." getSymbolicPath mbWorkDir+ in case parseFileGlob version rawFilePath of+ Left err -> rip verbosity $ MatchDirFileGlob (explainGlobSyntaxError rawFilePath err)+ Right glob -> do+ results <- runDirFileGlob verbosity (Just version) dir glob+ let missingDirectories =+ [missingDir | GlobMissingDirectory missingDir <- results]+ matches = globMatches results+ directoryMatches = [a | GlobMatchesDirectory a <- results]++ let errors :: [String]+ errors =+ [ "filepath wildcard '"+ ++ rawFilePath+ ++ "' refers to the directory"+ ++ " '"+ ++ missingDir+ ++ "', which does not exist or is not a directory."+ | missingDir <- missingDirectories+ ]+ ++ [ "filepath wildcard '" ++ rawFilePath ++ "' does not match any files."+ | null matches && null directoryMatches+ -- we don't error out on directory matches, simply warn about them and ignore.+ ]++ warns :: [String]+ warns =+ [ "Ignoring directory '" ++ path ++ "'" ++ " listed in a Cabal package field which should only include files (not directories)."+ | path <- directoryMatches+ ]++ if null errors+ then do+ unless (null warns) $+ warn verbosity $+ unlines warns+ return $ map unsafeMakeSymbolicPath matches+ else rip verbosity $ MatchDirFileGlobErrors errors++-------------------------------------------------------------------------------++-- * Parsing & printing++--------------------------------------------------------------------------------+-- Filepaths with globs may be parsed in the special context is globbing in+-- cabal package fields, such as `data-files`. In that case, we restrict the+-- globbing syntax to that supported by the cabal spec version in use.+-- Otherwise, we parse the globs to the extent of our globbing features+-- (wildcards `*`, unions `{a,b,c}`, and directory-recursive wildcards `**`).++-- ** Parsing globs in a cabal package++parseFileGlob :: CabalSpecVersion -> FilePath -> Either GlobSyntaxError Glob+parseFileGlob version filepath = case reverse (splitDirectories filepath) of+ [] ->+ Left EmptyGlob+ (filename : "**" : segments)+ | allowGlobStar -> do+ finalSegment <- case splitExtensions filename of+ ("*", ext)+ | '*' `elem` ext -> Left StarInExtension+ | null ext -> Left NoExtensionOnStar+ | otherwise -> Right (GlobDirRecursive [WildCard, Literal ext])+ _+ | allowLiteralFilenameGlobStar ->+ Right (GlobDirRecursive [Literal filename])+ | otherwise ->+ Left LiteralFileNameGlobStar++ foldM addStem 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 (GlobFile [WildCard, Literal ext])+ (_, ext)+ | '*' `elem` ext -> Left StarInExtension+ | '*' `elem` filename -> Left StarInFileName+ | otherwise -> Right (GlobFile [Literal filename])++ foldM addStem pat segments+ where+ addStem pat seg+ | '*' `elem` seg = Left StarInDirectory+ | otherwise = Right (GlobDir [Literal seg] pat)+ allowGlob = version >= CabalSpecV1_6+ allowGlobStar = version >= CabalSpecV2_4+ allowLiteralFilenameGlobStar = version >= CabalSpecV3_8++enableMultidot :: CabalSpecVersion -> Bool+enableMultidot version+ | version >= CabalSpecV2_4 = True+ | otherwise = False++--------------------------------------------------------------------------------+-- Parse and printing utils+--------------------------------------------------------------------------------++-- ** Cabal package globbing errors++data GlobSyntaxError+ = StarInDirectory+ | StarInFileName+ | StarInExtension+ | NoExtensionOnStar+ | EmptyGlob+ | LiteralFileNameGlobStar+ | VersionDoesNotSupportGlobStar+ | VersionDoesNotSupportGlob+ deriving (Eq, Show)++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."+explainGlobSyntaxError filepath StarInExtension =+ "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."+explainGlobSyntaxError filepath NoExtensionOnStar =+ "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 '*'."+explainGlobSyntaxError _ EmptyGlob =+ "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."+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."++-- Note throughout that we use splitDirectories, not splitPath. On+-- Posix, this makes no difference, but, because Windows accepts both+-- slash and backslash as its path separators, if we left in the+-- separators from the glob we might not end up properly normalised.++data GlobResult a+ = -- | 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.+ 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 a+ | -- | The glob matched a directory when we were looking for files only.+ -- It didn't match a file!+ --+ -- @since 3.12.0.0+ GlobMatchesDirectory a+ deriving (Show, Eq, Ord, Functor)++-- | Match files against a pre-parsed glob, starting in a directory.+--+-- The 'Version' argument must be the spec version of the package+-- description being processed, as globs behave slightly differently+-- in different spec versions.+--+-- The 'FilePath' argument is the directory that the glob is relative+-- to. It must be a valid directory (and hence it can't be the empty+-- string). The returned values will not include this prefix.+runDirFileGlob+ :: Verbosity+ -> Maybe CabalSpecVersion+ -- ^ If the glob we are running should care about the cabal spec, and warnings such as 'GlobWarnMultiDot', then this should be the version.+ -- If you want to run a glob but don't care about any of the cabal-spec restrictions on globs, use 'Nothing'! -> FilePath- -> IO [FilePath]-matchDirFileGlobWithDie verbosity rip version dir filepath = case parseFileGlob version filepath of- Left err -> rip verbosity $ MatchDirFileGlob (explainGlobSyntaxError filepath err)- Right glob -> do- results <- runDirFileGlob verbosity (Just version) dir glob- let missingDirectories =- [missingDir | GlobMissingDirectory missingDir <- results]- matches = globMatches results- directoryMatches = [a | GlobMatchesDirectory a <- results]+ -> Glob+ -> IO [GlobResult FilePath]+runDirFileGlob verbosity mspec rawRoot pat = do+ -- The default data-dir is null. Our callers -should- be+ -- converting that to '.' themselves, but it's a certainty that+ -- some future call-site will forget and trigger a really+ -- hard-to-debug failure if we don't check for that here.+ when (null rawRoot) $+ warn verbosity $+ "Null dir passed to runDirFileGlob; interpreting it "+ ++ "as '.'. This is probably an internal error."+ let root = if null rawRoot then "." else rawRoot+ -- This function might be called from the project root with dir as+ -- ".". Walking the tree starting there involves going into .git/+ -- and dist-newstyle/, which is a lot of work for no reward, so+ -- extract the constant prefix from the pattern and start walking+ -- there, and only walk as much as we need to: recursively if **,+ -- the whole directory if *, and just the specific file if it's a+ -- literal.+ let+ (prefixSegments, pathOrVariablePattern) = splitConstantPrefix pat+ joinedPrefix = joinPath prefixSegments - 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 && null directoryMatches- -- we don't error out on directory matches, simply warn about them and ignore.- ]+ -- The glob matching function depends on whether we care about the cabal version or not+ doesGlobMatch :: GlobPieces -> String -> Maybe (GlobResult ())+ doesGlobMatch glob str = case mspec of+ Just spec -> checkNameMatches spec glob str+ Nothing -> if matchGlobPieces glob str then Just (GlobMatch ()) else Nothing - warns :: [String]- warns =- [ "Ignoring directory '" ++ path ++ "'" ++ " listed in a Cabal package field which should only include files (not directories)."- | path <- directoryMatches- ]+ go (GlobFile glob) dir = do+ entries <- listDirectory (root </> dir)+ catMaybes+ <$> mapM+ ( \s -> do+ -- When running a glob from a Cabal package description (i.e.+ -- when a cabal spec version is passed as an argument), we+ -- disallow matching a @GlobFile@ against a directory, preferring+ -- @GlobDir dir GlobDirTrailing@ to specify a directory match.+ isFile <- maybe (return True) (const $ doesFileExist (root </> dir </> s)) mspec+ let match = (dir </> s <$) <$> doesGlobMatch glob s+ return $+ if isFile+ then match+ else case match of+ Just (GlobMatch x) -> Just $ GlobMatchesDirectory x+ Just (GlobWarnMultiDot x) -> Just $ GlobMatchesDirectory x+ Just (GlobMatchesDirectory x) -> Just $ GlobMatchesDirectory x+ Just (GlobMissingDirectory x) -> Just $ GlobMissingDirectory x -- this should never match, unless you are in a file-delete-heavy concurrent setting i guess+ Nothing -> Nothing+ )+ entries+ go (GlobDirRecursive glob) dir = do+ entries <- getDirectoryContentsRecursive (root </> dir)+ return $+ mapMaybe+ ( \s -> do+ globMatch <- doesGlobMatch glob (takeFileName s)+ pure ((dir </> s) <$ globMatch)+ )+ entries+ go (GlobDir glob globPath) dir = do+ entries <- listDirectory (root </> dir)+ subdirs <-+ filterM+ ( \subdir ->+ doesDirectoryExist+ (root </> dir </> subdir)+ )+ $ filter (matchGlobPieces glob) entries+ concat <$> traverse (\subdir -> go globPath (dir </> subdir)) subdirs+ go GlobDirTrailing dir = return [GlobMatch dir] - if null errors- then do- unless (null warns) $- warn verbosity $- unlines warns- return matches- else rip verbosity $ MatchDirFileGlobErrors errors+ case pathOrVariablePattern of+ Left filename -> do+ let filepath = joinedPrefix </> filename+ debug verbosity $ "Treating glob as filepath literal '" ++ filepath ++ "' in directory '" ++ root ++ "'."+ directoryExists <- doesDirectoryExist (root </> filepath)+ if directoryExists+ then pure [GlobMatchesDirectory filepath]+ else do+ exist <- doesFileExist (root </> filepath)+ pure [GlobMatch filepath | exist]+ Right variablePattern -> do+ debug verbosity $ "Expanding glob '" ++ show (pretty pat) ++ "' in directory '" ++ root ++ "'."+ directoryExists <- doesDirectoryExist (root </> joinedPrefix)+ if directoryExists+ then go variablePattern joinedPrefix+ else return [GlobMissingDirectory joinedPrefix]+ where+ -- \| Extract the (possibly null) constant prefix from the pattern.+ -- This has the property that, if @(pref, final) = splitConstantPrefix pat@,+ -- then @pat === foldr GlobDir final pref@.+ splitConstantPrefix :: Glob -> ([FilePath], Either FilePath Glob)+ splitConstantPrefix = fmap literalize . unfoldr' step+ where+ literalize (GlobFile [Literal filename]) =+ Left filename+ literalize glob =+ Right glob++ step (GlobDir [Literal seg] pat') = Right (seg, pat')+ step pat' = Left pat'++ unfoldr' :: (a -> Either r (b, a)) -> a -> ([b], r)+ unfoldr' f a = case f a of+ Left r -> ([], r)+ Right (b, a') -> case unfoldr' f a' of+ (bs, r) -> (b : bs, r)++-- | Is the root of this relative glob path a directory-recursive wildcard, e.g. @**/*.txt@ ?+isRecursiveInRoot :: Glob -> Bool+isRecursiveInRoot (GlobDirRecursive _) = True+isRecursiveInRoot _ = False++-- | Check how the string matches the glob under this cabal version+checkNameMatches :: CabalSpecVersion -> GlobPieces -> String -> Maybe (GlobResult ())+checkNameMatches spec glob candidate+ -- Check if glob matches in its general form+ | matchGlobPieces glob candidate =+ -- if multidot is supported, then this is a clean match+ if enableMultidot spec+ then pure (GlobMatch ())+ else -- if not, issue a warning saying multidot is needed for the match++ let (_, candidateExts) = splitExtensions $ takeFileName candidate+ extractExts :: GlobPieces -> Maybe String+ extractExts [] = Nothing+ extractExts [Literal lit]+ -- Any literal terminating a glob, and which does have an extension,+ -- returns that extension. Otherwise, recurse until Nothing is returned.+ | let ext = takeExtensions lit+ , ext /= "" =+ Just ext+ extractExts (_ : x) = extractExts x+ in case extractExts glob of+ Just exts+ | exts == candidateExts ->+ return (GlobMatch ())+ | exts `isSuffixOf` candidateExts ->+ return (GlobWarnMultiDot ())+ _ -> return (GlobMatch ())+ | otherwise = empty++-- | How/does the glob match the given filepath, according to the cabal version?+-- Since this is pure, we don't make a distinction between matching on+-- directories or files (i.e. this function won't return 'GlobMatchesDirectory')+fileGlobMatches :: CabalSpecVersion -> Glob -> FilePath -> Maybe (GlobResult ())+fileGlobMatches version g path = go g (splitDirectories path)+ where+ go GlobDirTrailing [] = Just (GlobMatch ())+ go (GlobFile glob) [file] = checkNameMatches version glob file+ go (GlobDirRecursive glob) dirs+ | [] <- reverse dirs =+ Nothing -- @dir/**/x.txt@ should not match @dir/hello@+ | file : _ <- reverse dirs =+ checkNameMatches version glob file+ go (GlobDir glob globPath) (dir : dirs) = do+ _ <- checkNameMatches version glob dir -- we only care if dir segment matches+ go globPath dirs+ go _ _ = Nothing
src/Distribution/Simple/Glob/Internal.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- @@ -20,20 +18,9 @@ import Distribution.Compat.Prelude import Prelude () -import Control.Monad (mapM)-+import qualified Distribution.Compat.CharParsing as P import Distribution.Parsec import Distribution.Pretty--import Distribution.CabalSpecVersion-import Distribution.Simple.Utils-import Distribution.Verbosity hiding (normal)--import Data.List (stripPrefix)-import System.Directory-import System.FilePath--import qualified Distribution.Compat.CharParsing as P import qualified Text.PrettyPrint as Disp --------------------------------------------------------------------------------@@ -44,6 +31,9 @@ GlobDir !GlobPieces !Glob | -- | @**/<glob>@, where @**@ denotes recursively traversing -- all directories and matching filenames on <glob>.+ --+ -- Note that the @<glob>@ portion can only match on filenames, not paths,+ -- so for example @**/foo/*.txt@ is not supported. GlobDirRecursive !GlobPieces | -- | A file glob. GlobFile !GlobPieces@@ -70,116 +60,8 @@ instance Binary GlobPiece instance Structured GlobPiece ------------------------------------------------------------------------------------ * Matching- ------------------------------------------------------------------------------------ | Match a 'Glob' against the file system, starting from a--- given root directory. The results are all relative to the given root.------ @since 3.12.0.0-matchGlob :: FilePath -> Glob -> IO [FilePath]-matchGlob root glob =- -- For this function, which is the general globbing one (doesn't care about- -- cabal spec, used e.g. for monitoring), we consider all matches.- mapMaybe- ( \case- GlobMatch a -> Just a- GlobWarnMultiDot a -> Just a- GlobMatchesDirectory a -> Just a- GlobMissingDirectory{} -> Nothing- )- <$> runDirFileGlob silent Nothing root glob---- | Match a globbing pattern against a file path component-matchGlobPieces :: GlobPieces -> String -> Bool-matchGlobPieces = goStart- where- -- From the man page, glob(7):- -- "If a filename starts with a '.', this character must be- -- matched explicitly."-- 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------------------------------------------------------------------------------------- * Parsing & printing------------------------------------------------------------------------------------- Filepaths with globs may be parsed in the special context is globbing in--- cabal package fields, such as `data-files`. In that case, we restrict the--- globbing syntax to that supported by the cabal spec version in use.--- Otherwise, we parse the globs to the extent of our globbing features--- (wildcards `*`, unions `{a,b,c}`, and directory-recursive wildcards `**`).---- ** Parsing globs in a cabal package--parseFileGlob :: CabalSpecVersion -> FilePath -> Either GlobSyntaxError Glob-parseFileGlob version filepath = case reverse (splitDirectories filepath) of- [] ->- Left EmptyGlob- (filename : "**" : segments)- | allowGlobStar -> do- finalSegment <- case splitExtensions filename of- ("*", ext)- | '*' `elem` ext -> Left StarInExtension- | null ext -> Left NoExtensionOnStar- | otherwise -> Right (GlobDirRecursive [WildCard, Literal ext])- _- | allowLiteralFilenameGlobStar ->- Right (GlobDirRecursive [Literal filename])- | otherwise ->- Left LiteralFileNameGlobStar-- foldM addStem 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 (GlobFile [WildCard, Literal ext])- (_, ext)- | '*' `elem` ext -> Left StarInExtension- | '*' `elem` filename -> Left StarInFileName- | otherwise -> Right (GlobFile [Literal filename])-- foldM addStem pat segments- where- addStem pat seg- | '*' `elem` seg = Left StarInDirectory- | otherwise = Right (GlobDir [Literal seg] pat)- allowGlob = version >= CabalSpecV1_6- allowGlobStar = version >= CabalSpecV2_4- allowLiteralFilenameGlobStar = version >= CabalSpecV3_8--enableMultidot :: CabalSpecVersion -> Bool-enableMultidot version- | version >= CabalSpecV2_4 = True- | otherwise = False---- ** Parsing globs otherwise+-- Parsing & pretty-printing instance Pretty Glob where pretty (GlobDir glob pathglob) =@@ -195,16 +77,9 @@ instance Parsec Glob where parsec = parsecPath where- parsecPath :: CabalParsing m => m Glob- parsecPath = do- glob <- parsecGlob- dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob)- -- We could support parsing recursive directory search syntax- -- @**@ here too, rather than just in 'parseFileGlob'- dirSep :: CabalParsing m => m () dirSep =- () <$ P.char '/'+ void (P.char '/') <|> P.try ( do _ <- P.char '\\'@@ -212,6 +87,17 @@ P.notFollowedBy (P.satisfy isGlobEscapedChar) ) + parsecPath :: CabalParsing m => m Glob+ parsecPath =+ P.choice+ [ do+ P.try (P.string "**" *> dirSep)+ GlobDirRecursive <$> parsecGlob+ , do+ glob <- parsecGlob+ dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob)+ ]+ parsecGlob :: CabalParsing m => m GlobPieces parsecGlob = some parsecPiece where@@ -226,10 +112,6 @@ normal = P.satisfy (\c -> not (isGlobEscapedChar c) && c /= '/' && c /= '\\') escape = P.try $ P.char '\\' >> P.satisfy isGlobEscapedChar ------------------------------------------------------------------------------------ Parse and printing utils---------------------------------------------------------------------------------- dispGlobPieces :: GlobPieces -> Disp.Doc dispGlobPieces = Disp.hcat . map dispPiece where@@ -254,244 +136,3 @@ isGlobEscapedChar '}' = True isGlobEscapedChar ',' = True isGlobEscapedChar _ = False---- ** Cabal package globbing errors--data GlobSyntaxError- = StarInDirectory- | StarInFileName- | StarInExtension- | NoExtensionOnStar- | EmptyGlob- | LiteralFileNameGlobStar- | VersionDoesNotSupportGlobStar- | VersionDoesNotSupportGlob- deriving (Eq, Show)--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."-explainGlobSyntaxError filepath StarInExtension =- "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."-explainGlobSyntaxError filepath NoExtensionOnStar =- "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 '*'."-explainGlobSyntaxError _ EmptyGlob =- "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."-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."---- Note throughout that we use splitDirectories, not splitPath. On--- Posix, this makes no difference, but, because Windows accepts both--- slash and backslash as its path separators, if we left in the--- separators from the glob we might not end up properly normalised.--data GlobResult a- = -- | 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.- 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 a- | -- | The glob matched a directory when we were looking for files only.- -- It didn't match a file!- --- -- @since 3.12.0.0- GlobMatchesDirectory a- deriving (Show, Eq, Ord, Functor)---- | Match files against a pre-parsed glob, starting in a directory.------ The 'Version' argument must be the spec version of the package--- description being processed, as globs behave slightly differently--- in different spec versions.------ The 'FilePath' argument is the directory that the glob is relative--- to. It must be a valid directory (and hence it can't be the empty--- string). The returned values will not include this prefix.-runDirFileGlob- :: Verbosity- -> Maybe CabalSpecVersion- -- ^ If the glob we are running should care about the cabal spec, and warnings such as 'GlobWarnMultiDot', then this should be the version.- -- If you want to run a glob but don't care about any of the cabal-spec restrictions on globs, use 'Nothing'!- -> FilePath- -> Glob- -> IO [GlobResult FilePath]-runDirFileGlob verbosity mspec rawRoot pat = do- -- The default data-dir is null. Our callers -should- be- -- converting that to '.' themselves, but it's a certainty that- -- some future call-site will forget and trigger a really- -- hard-to-debug failure if we don't check for that here.- when (null rawRoot) $- warn verbosity $- "Null dir passed to runDirFileGlob; interpreting it "- ++ "as '.'. This is probably an internal error."- let root = if null rawRoot then "." else rawRoot- debug verbosity $ "Expanding glob '" ++ show (pretty pat) ++ "' in directory '" ++ root ++ "'."- -- This function might be called from the project root with dir as- -- ".". Walking the tree starting there involves going into .git/- -- and dist-newstyle/, which is a lot of work for no reward, so- -- extract the constant prefix from the pattern and start walking- -- there, and only walk as much as we need to: recursively if **,- -- the whole directory if *, and just the specific file if it's a- -- literal.- let- (prefixSegments, variablePattern) = splitConstantPrefix pat- joinedPrefix = joinPath prefixSegments-- -- The glob matching function depends on whether we care about the cabal version or not- doesGlobMatch :: GlobPieces -> String -> Maybe (GlobResult ())- doesGlobMatch glob str = case mspec of- Just spec -> checkNameMatches spec glob str- Nothing -> if matchGlobPieces glob str then Just (GlobMatch ()) else Nothing-- go (GlobFile glob) dir = do- entries <- getDirectoryContents (root </> dir)- catMaybes- <$> mapM- ( \s -> do- -- When running a glob from a Cabal package description (i.e.- -- when a cabal spec version is passed as an argument), we- -- disallow matching a @GlobFile@ against a directory, preferring- -- @GlobDir dir GlobDirTrailing@ to specify a directory match.- isFile <- maybe (return True) (const $ doesFileExist (root </> dir </> s)) mspec- let match = (dir </> s <$) <$> doesGlobMatch glob s- return $- if isFile- then match- else case match of- Just (GlobMatch x) -> Just $ GlobMatchesDirectory x- Just (GlobWarnMultiDot x) -> Just $ GlobMatchesDirectory x- Just (GlobMatchesDirectory x) -> Just $ GlobMatchesDirectory x- Just (GlobMissingDirectory x) -> Just $ GlobMissingDirectory x -- this should never match, unless you are in a file-delete-heavy concurrent setting i guess- Nothing -> Nothing- )- entries- go (GlobDirRecursive glob) dir = do- entries <- getDirectoryContentsRecursive (root </> dir)- return $- mapMaybe- ( \s -> do- globMatch <- doesGlobMatch glob (takeFileName s)- pure ((dir </> s) <$ globMatch)- )- entries- go (GlobDir glob globPath) dir = do- entries <- getDirectoryContents (root </> dir)- subdirs <-- filterM- ( \subdir ->- doesDirectoryExist- (root </> dir </> subdir)- )- $ filter (matchGlobPieces glob) entries- concat <$> traverse (\subdir -> go globPath (dir </> subdir)) subdirs- go GlobDirTrailing dir = return [GlobMatch dir]-- directoryExists <- doesDirectoryExist (root </> joinedPrefix)- if directoryExists- then go variablePattern joinedPrefix- else return [GlobMissingDirectory joinedPrefix]- where- -- \| Extract the (possibly null) constant prefix from the pattern.- -- This has the property that, if @(pref, final) = splitConstantPrefix pat@,- -- then @pat === foldr GlobDir final pref@.- splitConstantPrefix :: Glob -> ([FilePath], Glob)- splitConstantPrefix = unfoldr' step- where- step (GlobDir [Literal seg] pat') = Right (seg, pat')- step pat' = Left pat'-- unfoldr' :: (a -> Either r (b, a)) -> a -> ([b], r)- unfoldr' f a = case f a of- Left r -> ([], r)- Right (b, a') -> case unfoldr' f a' of- (bs, r) -> (b : bs, r)---- | Is the root of this relative glob path a directory-recursive wildcard, e.g. @**/*.txt@ ?-isRecursiveInRoot :: Glob -> Bool-isRecursiveInRoot (GlobDirRecursive _) = True-isRecursiveInRoot _ = False---- | Check how the string matches the glob under this cabal version-checkNameMatches :: CabalSpecVersion -> GlobPieces -> String -> Maybe (GlobResult ())-checkNameMatches spec glob candidate- -- Check if glob matches in its general form- | matchGlobPieces glob candidate =- -- if multidot is supported, then this is a clean match- if enableMultidot spec- then pure (GlobMatch ())- else -- if not, issue a warning saying multidot is needed for the match-- let (_, candidateExts) = splitExtensions $ takeFileName candidate- extractExts :: GlobPieces -> Maybe String- extractExts [] = Nothing- extractExts [Literal lit]- -- Any literal terminating a glob, and which does have an extension,- -- returns that extension. Otherwise, recurse until Nothing is returned.- | let ext = takeExtensions lit- , ext /= "" =- Just ext- extractExts (_ : x) = extractExts x- in case extractExts glob of- Just exts- | exts == candidateExts ->- return (GlobMatch ())- | exts `isSuffixOf` candidateExts ->- return (GlobWarnMultiDot ())- _ -> return (GlobMatch ())- | otherwise = empty---- | How/does the glob match the given filepath, according to the cabal version?--- Since this is pure, we don't make a distinction between matching on--- directories or files (i.e. this function won't return 'GlobMatchesDirectory')-fileGlobMatches :: CabalSpecVersion -> Glob -> FilePath -> Maybe (GlobResult ())-fileGlobMatches version g path = go g (splitDirectories path)- where- go GlobDirTrailing [] = Just (GlobMatch ())- go (GlobFile glob) [file] = checkNameMatches version glob file- go (GlobDirRecursive glob) dirs- | [] <- reverse dirs =- Nothing -- @dir/**/x.txt@ should not match @dir/hello@- | file : _ <- reverse dirs =- checkNameMatches version glob file- go (GlobDir glob globPath) (dir : dirs) = do- _ <- checkNameMatches version glob dir -- we only care if dir segment matches- go globPath dirs- go _ _ = Nothing
src/Distribution/Simple/Haddock.hs view
@@ -1,1227 +1,1639 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RankNTypes #-}----------------------------------------------------------------------------------- |--- Module : Distribution.Simple.Haddock--- Copyright : Isaac Jones 2003-2005--- License : BSD3------ Maintainer : cabal-devel@haskell.org--- Portability : portable------ This module deals with the @haddock@ and @hscolour@ commands.--- It uses information about installed packages (from @ghc-pkg@) to find the--- locations of documentation for dependent packages, so it can create links.------ The @hscolour@ support allows generating HTML versions of the original--- source, with coloured syntax highlighting.-module Distribution.Simple.Haddock- ( haddock- , createHaddockIndex- , hscolour- , haddockPackagePaths- , Visibility (..)- ) where--import Distribution.Compat.Prelude-import Prelude ()--import qualified Distribution.Simple.GHC as GHC-import qualified Distribution.Simple.GHCJS as GHCJS---- local--import Distribution.Backpack (OpenModule)-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 (matchDirFileGlob)-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.Register-import Distribution.Simple.Setup.Haddock-import Distribution.Simple.Setup.Hscolour-import Distribution.Simple.Utils-import Distribution.System-import Distribution.Types.ComponentLocalBuildInfo-import Distribution.Types.ExposedModule-import Distribution.Types.LocalBuildInfo-import Distribution.Types.TargetInfo-import Distribution.Utils.NubList-import qualified Distribution.Utils.ShortText as ShortText-import Distribution.Version--import Distribution.Verbosity-import Language.Haskell.Extension--import Distribution.Compat.Semigroup (All (..), Any (..))--import Control.Monad-import Data.Either (rights)--import Distribution.Simple.Errors-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)---- | The FilePath of a directory, it's a monoid under '(</>)'.-newtype Directory = Dir {unDir' :: FilePath} deriving (Read, Show, Eq, Ord)--unDir :: Directory -> FilePath-unDir = normalise . unDir'--type Template = String--data Output = Html | Hoogle- 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 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]) $- dieWithException verbosity NoSupportForHoogle-- 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 dieWithException verbosity NoSupportForQuickJumpFlag- else warn verbosity (msg ++ "\n" ++ alt)-- haddockGhcVersionStr <-- getProgramOutput- verbosity- haddockProg- ["--ghc-version"]- case (simpleParsec haddockGhcVersionStr, compilerCompatVersion GHC comp) of- (Nothing, _) -> dieWithException verbosity NoGHCVersionFromHaddock- (_, Nothing) -> dieWithException verbosity NoGHCVersionFromCompiler- (Just haddockGhcVersion, Just ghcVersion)- | haddockGhcVersion == ghcVersion -> return ()- | otherwise -> dieWithException verbosity $ HaddockAndGHCVersionDoesntMatch ghcVersion 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) =- 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."-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- , haddockHtmlLocation = Flag (pkg_url ++ "/docs")- , haddockContents = Flag (toPathTemplate pkg_url)- , haddockLinkedSource = 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- [ 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'.- let using_hscolour = flag haddockLinkedSource && version < mkVersion [2, 17]- when using_hscolour $- 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-- internalPackageDB <-- createInternalPackageDB verbosity lbi (flag haddockDistPref)-- (\f -> foldM_ f (installedPkgs lbi) targets') $ \index target -> do- let component = targetComponent target- clbi = targetCLBI target-- preBuildComponent verbosity lbi target-- 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" $- \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- }-- 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-- 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 comp platform flags = do- let args = fromHaddockProjectFlags flags- (haddockProg, _version) <-- getHaddockProg verbosity programDb comp args (Flag True)- 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}- }- where- ghcArgs = fromMaybe [] . lookup "ghc" . haddockProgramArgs $ flags--fromHaddockProjectFlags :: HaddockProjectFlags -> HaddockArgs-fromHaddockProjectFlags flags =- mempty- { argOutputDir = Dir (fromFlag $ haddockProjectDir flags)- , argQuickJump = Flag True- , argGenContents = Flag True- , argGenIndex = Flag True- , argPrologueFile = haddockProjectPrologue flags- , argInterfaces = fromFlagOrDefault [] (haddockProjectInterfaces flags)- , argLinkedSource = Flag True- , argLib = haddockProjectLib flags- }--fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs-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- , 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-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-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 dieWithException verbosity MustHaveSharedLibraries-- 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 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))- }--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- }--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- }--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- }- CExe exe -> Just exe- _ -> Nothing--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- }--getReexports :: ComponentLocalBuildInfo -> [OpenModule]-getReexports LibComponentLocalBuildInfo{componentExposedModules = mods} =- mapMaybe exposedReexport mods-getReexports _ = []--getGhcCppOpts- :: Version- -> BuildInfo- -> GhcOptions-getGhcCppOpts haddockVersion bi =- 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)- 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-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}---- ---------------------------------------------------------------------------------- | Call haddock with the specified arguments.-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."- | 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-renderArgs verbosity tmpFileOpts version comp platform args k = do- 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- let renderedArgs =- ( case argPrologueFile args of- Flag pfile -> ["--prologue=" ++ pfile]- _ -> []- )- <> 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)- where- outputDir = (unDir $ argOutputDir args)- isNotArgContents = isNothing (flagToMaybe $ argContents args)- isNotArgIndex = isNothing (flagToMaybe $ argIndex args)- isArgGenIndex = fromFlagOrDefault False (argGenIndex args)- -- Haddock, when generating HTML, does not generate an index if the options- -- --use-contents or --use-index are passed to it. See- -- https://haskell-haddock.readthedocs.io/en/latest/invoking.html#cmdoption-use-contents- isIndexGenerated = isArgGenIndex && isNotArgContents && isNotArgIndex- result =- intercalate ", "- . map- ( \o ->- outputDir- </> case o of- Html- | isIndexGenerated ->- "index.html"- Html- | otherwise ->- mempty- 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- , if haddockSupportsPackageName- 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, True <- flagToList . argQuickJump $ args- ]- , ["--hyperlinked-source" | isHyperlinkedSource]- , (\(All b, xs) -> bool (map (("--hide=" ++) . prettyShow) xs) [] b)- . argHideModules- $ args- , bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args- , -- Haddock's --source-* options are ignored once --hyperlinked-source is- -- set.- -- See https://haskell-haddock.readthedocs.io/en/latest/invoking.html#cmdoption-hyperlinked-source- -- To avoid Haddock's warning, we only set --source-* options if- -- --hyperlinked-source is not set.- if isHyperlinkedSource- then []- else- 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- , bool [] [verbosityFlag] . getAny . argVerbose $ args- , map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html")- . fromFlagOrDefault []- . argOutput- $ args- , renderInterfaces . argInterfaces $ 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- | r <- argReexports args- , isVersion 2 19- ]- , argTargets $ 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]- haddockSupportsHyperlinkedSource = isVersion 2 17- isHyperlinkedSource =- haddockSupportsHyperlinkedSource- && fromFlagOrDefault False (argLinkedSource args)--------------------------------------------------------------------------------------- | 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 ipkgs mkHtmlPath = do- 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- )- 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- ]-- 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"]-- -- Actually extract interface and HTML paths from an 'InstalledPackageInfo'.- interfaceAndHtmlPath- :: InstalledPackageInfo- -> Maybe (FilePath, Maybe FilePath)- interfaceAndHtmlPath pkg = do- interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)- html <- case mkHtmlPath of- 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-- -- '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 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 ->- dieWithException verbosity $ HaddockPackageFlags 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)--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- pkg_id- (mkLegacyUnitId pkg_id)- (compilerInfo (compiler lbi))- (hostPlatform lbi)---- --------------------------------------------------------------------------------- hscolour support.--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' onNoHsColour haddockTarget pkg_descr lbi suffixes flags =- either (\excep -> onNoHsColour $ exceptionMessage excep) (\(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."-- setupMessage verbosity "Running hscolour for" (packageId pkg_descr)- createDirectoryIfMissingVerbose verbosity True $- hscolourPref haddockTarget distPref pkg_descr-- withAllComponentsInBuildOrder pkg_descr lbi $ \comp clbi -> do- let tgt = TargetInfo clbi comp- preBuildComponent verbosity lbi tgt- preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes- let- doExe com = case (compToExe com) of- Just exe -> do- 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)- "Unsupported component, skipping..."- return ()- case comp of- CLib lib -> do- 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"- 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-- stylesheet = flagToMaybe (hscolourCSS 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"--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+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------++-- |+-- Module : Distribution.Simple.Haddock+-- Copyright : Isaac Jones 2003-2005+-- License : BSD3+--+-- Maintainer : cabal-devel@haskell.org+-- Portability : portable+--+-- This module deals with the @haddock@ and @hscolour@ commands.+-- It uses information about installed packages (from @ghc-pkg@) to find the+-- locations of documentation for dependent packages, so it can create links.+--+-- The @hscolour@ support allows generating HTML versions of the original+-- source, with coloured syntax highlighting.+module Distribution.Simple.Haddock+ ( haddock+ , haddock_setupHooks+ , createHaddockIndex+ , hscolour+ , hscolour_setupHooks+ , haddockPackagePaths+ , Visibility (..)+ ) where++import Distribution.Compat.Prelude+import Prelude ()++import qualified Distribution.Simple.GHC as GHC+import qualified Distribution.Simple.GHCJS as GHCJS++-- local++import Data.Semigroup (All (..), Any (..))+import Distribution.Backpack (OpenModule)+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.Errors+import Distribution.Simple.FileMonitor.Types+ ( MonitorFilePath+ )+import Distribution.Simple.Flag+import Distribution.Simple.Glob (matchDirFileGlob)+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.Register+import Distribution.Simple.Setup+import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks+ ( PreBuildComponentInputs (..)+ )+import Distribution.Simple.Utils+import Distribution.System+import Distribution.Types.ComponentLocalBuildInfo+import Distribution.Types.ExposedModule+import Distribution.Types.LocalBuildInfo+import Distribution.Types.TargetInfo+import Distribution.Utils.Path hiding+ ( Dir+ )+import qualified Distribution.Utils.Path as Path+import qualified Distribution.Utils.ShortText as ShortText+import Distribution.Verbosity+import Distribution.Version++import Data.Bool (bool)+import Data.Either (lefts, rights)+import System.Directory (doesDirectoryExist, doesFileExist)+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.+ , argComponentName :: Flag String+ -- ^ Optional name used to construct haddock's `--package-name` option for+ -- various components (tests suites, sublibriaries, etc).+ , 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.+ , argResourcesDir :: Flag String+ -- ^ haddock's static \/ auxiliary files.+ , argUseUnicode :: Flag Bool+ -- ^ haddock's `--use-unicode` flag+ }+ deriving (Generic)++-- | The FilePath of a directory, it's a monoid under '(</>)'.+newtype Directory = Dir {unDir' :: FilePath} deriving (Read, Show, Eq, Ord)++-- NB: only correct at the top-level, after we have combined monoidally+-- the top-level output directory with the component subdir.+unDir :: Directory -> SymbolicPath Pkg (Path.Dir Artifacts)+unDir = makeSymbolicPath . normalise . unDir'++type Template = String++data Output = Html | Hoogle+ 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 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]) $+ dieWithException verbosity NoSupportForHoogle++ 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 dieWithException verbosity NoSupportForQuickJumpFlag+ else warn verbosity (msg ++ "\n" ++ alt)++ haddockGhcVersionStr <-+ getProgramOutput+ verbosity+ haddockProg+ ["--ghc-version"]+ case (simpleParsec haddockGhcVersionStr, compilerCompatVersion GHC comp) of+ (Nothing, _) -> dieWithException verbosity NoGHCVersionFromHaddock+ (_, Nothing) -> dieWithException verbosity NoGHCVersionFromCompiler+ (Just haddockGhcVersion, Just ghcVersion)+ | haddockGhcVersion == ghcVersion -> return ()+ | otherwise -> dieWithException verbosity $ HaddockAndGHCVersionDoesntMatch ghcVersion haddockGhcVersion++ return (haddockProg, version)++haddock+ :: PackageDescription+ -> LocalBuildInfo+ -> [PPSuffixHandler]+ -> HaddockFlags+ -> IO ()+haddock pkg lbi suffixHandlers flags =+ void $+ haddock_setupHooks+ (const $ return [])+ defaultVerbosityHandles+ pkg+ lbi+ suffixHandlers+ flags++haddock_setupHooks+ :: (SetupHooks.PreBuildComponentInputs -> IO [MonitorFilePath])+ -- ^ pre-build hook+ -> VerbosityHandles+ -> PackageDescription+ -> LocalBuildInfo+ -> [PPSuffixHandler]+ -> HaddockFlags+ -> IO [MonitorFilePath]+haddock_setupHooks+ _+ verbHandles+ pkg_descr+ _+ _+ haddockFlags+ | not (hasLibs pkg_descr)+ && not (fromFlag $ haddockExecutables haddockFlags)+ && not (fromFlag $ haddockTestSuites haddockFlags)+ && not (fromFlag $ haddockBenchmarks haddockFlags)+ && not (fromFlag $ haddockForeignLibs haddockFlags) = do+ warn verb $+ "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."+ return []+ where+ verb = mkVerbosity verbHandles $ fromFlag $ haddockVerbosity haddockFlags+haddock_setupHooks+ preBuildHook+ verbHandles+ pkg_descr+ lbi+ suffixes+ flags' = do+ let verbosity = mkVerbosity verbHandles (fromFlag $ haddockVerbosity flags)+ mbWorkDir = flagToMaybe $ haddockWorkingDir flags+ comp = compiler lbi+ platform = hostPlatform lbi+ config = configFlags 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)+ , haddockLinkedSource = Flag True+ , haddockQuickJump = Flag True+ }+ pkg_url = "/package/$pkg-$version"+ flag f = fromFlag $ f flags++ tmpFileOpts =+ commonSetupTempFileOptions $ configCommonFlags config+ 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'.+ let using_hscolour = flag haddockLinkedSource && version < mkVersion [2, 17]+ when using_hscolour $+ void $+ hscolour'+ (const $ return [])+ -- NB: we are not passing the user BuildHooks here,+ -- because we are already running the pre/post build hooks+ -- for Haddock.+ verbHandles+ (warn verbosity)+ haddockTarget+ pkg_descr+ lbi+ suffixes+ (defaultHscolourFlags `mappend` haddockToHscolour flags)++ targets <- readTargetInfos verbosity pkg_descr lbi (haddockTargets flags)++ let+ targets' =+ case targets of+ [] -> allTargetsInBuildOrder' pkg_descr lbi+ _ -> targets++ internalPackageDB <-+ createInternalPackageDB verbosity lbi (flag $ setupDistPref . haddockCommonFlags)++ (mons, _mbIPI) <- (\f -> foldM f ([], installedPkgs lbi) targets') $ \(monsAcc, index) target -> do+ curDir <- absoluteWorkingDirLBI lbi+ let+ component = targetComponent target+ clbi = targetCLBI target+ bi = componentBuildInfo component+ -- Include any build-tool-depends on build tools internal to the current package.+ progs' = addInternalBuildTools curDir pkg_descr lbi bi (withPrograms lbi)+ lbi' =+ lbi+ { withPrograms = progs'+ , withPackageDB = withPackageDB lbi ++ [internalPackageDB]+ , installedPkgs = index+ }++ pbci = SetupHooks.PreBuildComponentInputs (BuildHaddock flags) lbi' target++ -- See Note [Hi Haddock Recompilation Avoidance]+ reusingGHCCompilationArtifacts verbosity tmpFileOpts mbWorkDir lbi bi clbi version $ \haddockArtifactsDirs -> do+ mons <- preBuildComponent (preBuildHook pbci) verbosity lbi' target+ preprocessComponent pkg_descr component lbi' clbi False verbosity suffixes+ let+ doExe com = case compToExe com of+ Just exe -> do+ exeArgs <-+ fromExecutable+ verbosity+ haddockArtifactsDirs+ lbi'+ clbi+ htmlTemplate+ haddockTarget+ pkg_descr+ exe+ commonArgs+ runHaddock+ verbosity+ mbWorkDir+ tmpFileOpts+ comp+ platform+ haddockProg+ True+ exeArgs+ Nothing -> do+ warn+ verbosity+ "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)+ ipi <- case component of+ CLib lib -> do+ smsg+ libArgs <-+ fromLibrary+ verbosity+ haddockArtifactsDirs+ lbi'+ clbi+ htmlTemplate+ haddockTarget+ pkg_descr+ lib+ commonArgs+ runHaddock+ verbosity+ mbWorkDir+ tmpFileOpts+ comp+ platform+ haddockProg+ True+ libArgs+ inplaceDir <- absoluteWorkingDirLBI lbi++ let+ ipi =+ inplaceInstalledPackageInfo+ inplaceDir+ (flag $ setupDistPref . haddockCommonFlags)+ pkg_descr+ (mkAbiHash "inplace")+ lib+ lbi'+ clbi++ debug verbosity $+ "Registering inplace:\n"+ ++ InstalledPackageInfo.showInstalledPackageInfo ipi++ registerPackage+ verbosity+ (compiler lbi')+ (withPrograms lbi')+ mbWorkDir+ (withPackageDB lbi')+ ipi+ HcPkg.defaultRegisterOptions+ { HcPkg.registerMultiInstance = True+ }++ return $ PackageIndex.insert ipi index+ CFLib flib ->+ when+ (flag haddockForeignLibs)+ ( do+ smsg+ flibArgs <-+ fromForeignLib+ verbosity+ haddockArtifactsDirs+ lbi'+ clbi+ htmlTemplate+ haddockTarget+ pkg_descr+ flib+ commonArgs+ runHaddock+ verbosity+ mbWorkDir+ tmpFileOpts+ comp+ platform+ haddockProg+ True+ flibArgs+ )+ >> return index+ CExe _ -> when (flag haddockExecutables) (smsg >> doExe component) >> return index+ CTest test -> do+ when (flag haddockTestSuites) $ do+ smsg+ testArgs <-+ fromTest+ verbosity+ haddockArtifactsDirs+ lbi'+ clbi+ htmlTemplate+ haddockTarget+ pkg_descr+ test+ commonArgs+ runHaddock+ verbosity+ mbWorkDir+ tmpFileOpts+ comp+ platform+ haddockProg+ True+ testArgs+ return index+ CBench bench -> do+ when (flag haddockBenchmarks) $ do+ smsg+ benchArgs <-+ fromBenchmark+ verbosity+ haddockArtifactsDirs+ lbi'+ clbi+ htmlTemplate+ haddockTarget+ pkg_descr+ bench+ commonArgs+ runHaddock+ verbosity+ mbWorkDir+ tmpFileOpts+ comp+ platform+ haddockProg+ True+ benchArgs+ return index++ return (monsAcc ++ mons, ipi)++ for_ (extraDocFiles pkg_descr) $ \fpath -> do+ files <- matchDirFileGlob verbosity (specVersion pkg_descr) mbWorkDir fpath+ let targetDir = Dir $ unDir' (argOutputDir commonArgs) </> haddockDirName haddockTarget pkg_descr+ for_ files $+ copyFileToCwd verbosity mbWorkDir (unDir targetDir)++ return mons++-- | Execute 'Haddock' configured with 'HaddocksFlags'. It is used to build+-- index and contents for documentation of multiple packages.+createHaddockIndex+ :: Verbosity+ -> ProgramDb+ -> Compiler+ -> Platform+ -> Maybe (SymbolicPath CWD (Path.Dir Pkg))+ -> HaddockProjectFlags+ -> IO ()+createHaddockIndex verbosity programDb comp platform mbWorkDir flags = do+ let args = fromHaddockProjectFlags flags+ tmpFileOpts =+ commonSetupTempFileOptions $ haddockProjectCommonFlags flags+ (haddockProg, _version) <-+ getHaddockProg verbosity programDb comp args (Flag True)+ runHaddock verbosity mbWorkDir tmpFileOpts 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+ , argResourcesDir = haddockResourcesDir flags+ , argVerbose =+ maybe mempty (Any . (>= Deafening) . vLevel)+ . flagToMaybe+ $ setupVerbosity commonFlags+ , argOutput =+ Flag $ case [Html | Flag True <- [haddockHtml flags]]+ ++ [Hoogle | Flag True <- [haddockHoogle flags]] of+ [] -> [Html]+ os -> os+ , argOutputDir = maybe mempty (Dir . getSymbolicPath) . flagToMaybe $ setupDistPref commonFlags+ , argGhcOptions = mempty{ghcOptExtra = ghcArgs}+ , argUseUnicode = haddockUseUnicode flags+ }+ where+ ghcArgs = fromMaybe [] . lookup "ghc" . haddockProgramArgs $ flags+ commonFlags = haddockCommonFlags flags++fromHaddockProjectFlags :: HaddockProjectFlags -> HaddockArgs+fromHaddockProjectFlags flags =+ mempty+ { argOutputDir = Dir (fromFlag $ haddockProjectDir flags)+ , argQuickJump = Flag True+ , argGenContents = Flag True+ , argGenIndex = Flag True+ , argPrologueFile = haddockProjectPrologue flags+ , argInterfaces = fromFlagOrDefault [] (haddockProjectInterfaces flags)+ , argLinkedSource = Flag True+ , argResourcesDir = haddockProjectResourcesDir flags+ , argCssFile = haddockProjectCss flags+ }++fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs+fromPackageDescription _haddockTarget pkg_descr =+ mempty+ { argInterfaceFile = Flag $ haddockPath pkg_descr+ , argPackageName = Flag $ packageId pkg_descr+ , argOutputDir = Dir $ "doc" </> "html"+ , 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+ :: VerbosityLevel+ -> LocalBuildInfo+ -> BuildInfo+ -> ComponentLocalBuildInfo+ -> SymbolicPath Pkg (Path.Dir build)+ -> 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++{-+Note [Hi Haddock Recompilation Avoidance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Starting with Haddock 2.28, we no longer want to run Haddock's GHC session in+an arbitrary temporary directory. Doing so always causes recompilation during+documentation generation, which can now be avoided thanks to Hi Haddock.++Instead, we want to re-use the interface and object files produced by GHC.+We copy these intermediate files produced by GHC to temporary directories and+point haddock to them.++The reason why we can't use the GHC files /inplace/ is that haddock may have to+recompile (e.g. because of `haddock-options`). In that case, we want to be sure+the files produced by GHC do not get overwritten.++See https://github.com/haskell/cabal/pull/9177 for discussion.++(W.1) As it turns out, -stubdir is included in GHC's recompilation fingerprint.+This means that if we use a temporary directory for stubfiles produced by GHC+for the haddock invocation, haddock will trigger full recompilation since the+stubdir would be different.++So we don't use a temporary stubdir, despite the tmp o-dir and hi-dir:++We want to avoid at all costs haddock accidentally overwriting o-files and+hi-files (e.g. if a user specified haddock-option triggers recompilation), and+thus copy them to a temporary directory to pass them on to haddock. However,+stub files are much less problematic since ABI-incompatibility isn't at play+here, that is, there doesn't seem to be a GHC flag that could accidentally make+a stub file incompatible with the one produced by GHC from the same module.+-}++mkHaddockArgs+ :: Verbosity+ -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts))+ -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock.+ -- See Note [Hi Haddock Recompilation Avoidance]+ -> LocalBuildInfo+ -> ComponentLocalBuildInfo+ -> Maybe PathTemplate+ -- ^ template for HTML location+ -> [SymbolicPath Pkg File]+ -> BuildInfo+ -> IO HaddockArgs+mkHaddockArgs verbosity (tmpObjDir, tmpHiDir, tmpStubDir) lbi clbi htmlTemplate inFiles bi = do+ let+ vanillaOpts' =+ componentGhcOptions Normal lbi bi clbi (buildDir lbi)+ vanillaOpts =+ vanillaOpts'+ { -- See Note [Hi Haddock Recompilation Avoidance]+ ghcOptObjDir = toFlag tmpObjDir+ , ghcOptHiDir = toFlag tmpHiDir+ , ghcOptStubDir = toFlag tmpStubDir+ }+ sharedOpts =+ vanillaOpts+ { ghcOptDynLinkMode = toFlag GhcDynamicOnly+ , ghcOptFPic = toFlag True+ , ghcOptHiSuffix = toFlag "dyn_hi"+ , ghcOptObjSuffix = toFlag "dyn_o"+ , ghcOptExtra = hcSharedOptions GHC bi+ }+ ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate+ opts <-+ if withVanillaLib lbi+ then return vanillaOpts+ else+ if withSharedLib lbi+ then return sharedOpts+ else dieWithException verbosity MustHaveSharedLibraries++ return+ ifaceArgs+ { argGhcOptions = opts+ , argTargets = map getSymbolicPath inFiles+ , argReexports = getReexports clbi+ }++fromLibrary+ :: Verbosity+ -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts))+ -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock.+ -- See Note [Hi Haddock Recompilation Avoidance]+ -> LocalBuildInfo+ -> ComponentLocalBuildInfo+ -> Maybe PathTemplate+ -- ^ template for HTML location+ -> HaddockTarget+ -> PackageDescription+ -> Library+ -> HaddockArgs+ -- ^ common args+ -> IO HaddockArgs+fromLibrary verbosity haddockArtifactsDirs lbi clbi htmlTemplate haddockTarget pkg_descr lib commonArgs = do+ inFiles <- map snd `fmap` getLibSourceFiles verbosity lbi lib clbi+ args <-+ mkHaddockArgs+ verbosity+ haddockArtifactsDirs+ lbi+ clbi+ htmlTemplate+ inFiles+ (libBuildInfo lib)+ let args' =+ commonArgs+ <> args+ { argOutputDir =+ Dir $ haddockLibraryDirPath haddockTarget pkg_descr lib+ , argInterfaceFile = Flag $ haddockLibraryPath pkg_descr lib+ }+ args'' =+ args'+ { argHideModules = (mempty, otherModules (libBuildInfo lib))+ , argTitle = Flag $ haddockPackageLibraryName pkg_descr lib+ , argComponentName = toFlag (haddockPackageLibraryName' (pkgName (package pkg_descr)) (libName lib))+ , -- we need to accommodate for `argOutputDir`, see `haddockLibraryPath`+ argBaseUrl = case (libName lib, argBaseUrl args') of+ (LSubLibName _, Flag url) -> Flag $ ".." </> url+ (_, a) -> a+ , argContents = case (libName lib, argContents args') of+ (LSubLibName _, Flag url) -> Flag $ ".." </> url+ (_, a) -> a+ , argIndex = case (libName lib, argIndex args') of+ (LSubLibName _, Flag url) -> Flag $ ".." </> url+ (_, a) -> a+ }+ return args''++fromExecutable+ :: Verbosity+ -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts))+ -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock.+ -- See Note [Hi Haddock Recompilation Avoidance]+ -> LocalBuildInfo+ -> ComponentLocalBuildInfo+ -> Maybe PathTemplate+ -- ^ template for HTML location+ -> HaddockTarget+ -> PackageDescription+ -> Executable+ -> HaddockArgs+ -- ^ common args+ -> IO HaddockArgs+fromExecutable verbosity haddockArtifactsDirs lbi clbi htmlTemplate haddockTarget pkg_descr exe commonArgs = do+ inFiles <- map snd `fmap` getExeSourceFiles verbosity lbi exe clbi+ args <-+ mkHaddockArgs+ verbosity+ haddockArtifactsDirs+ lbi+ clbi+ htmlTemplate+ inFiles+ (buildInfo exe)+ let args' =+ commonArgs+ <> args+ { argOutputDir =+ Dir $+ haddockDirName haddockTarget pkg_descr+ </> unUnqualComponentName (exeName exe)+ }+ return+ args'+ { argTitle = Flag $ unUnqualComponentName $ exeName exe+ , -- we need to accommodate `argOutputDir`+ argBaseUrl = case argBaseUrl args' of+ Flag url -> Flag $ ".." </> url+ NoFlag -> NoFlag+ , argContents = case argContents args' of+ Flag url -> Flag $ ".." </> url+ NoFlag -> NoFlag+ , argIndex = case argIndex args' of+ Flag url -> Flag $ ".." </> url+ NoFlag -> NoFlag+ }++fromTest+ :: Verbosity+ -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts))+ -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock.+ -- See Note [Hi Haddock Recompilation Avoidance]+ -> LocalBuildInfo+ -> ComponentLocalBuildInfo+ -> Maybe PathTemplate+ -- ^ template for HTML location+ -> HaddockTarget+ -> PackageDescription+ -> TestSuite+ -> HaddockArgs+ -- ^ common args+ -> IO HaddockArgs+fromTest verbosity haddockArtifactsDirs lbi clbi htmlTemplate haddockTarget pkg_descr test commonArgs = do+ inFiles <- map snd `fmap` getTestSourceFiles verbosity lbi test clbi+ args <-+ mkHaddockArgs+ verbosity+ haddockArtifactsDirs+ lbi+ clbi+ htmlTemplate+ inFiles+ (testBuildInfo test)+ let args' =+ commonArgs+ <> args+ { argOutputDir =+ Dir $+ haddockDirName haddockTarget pkg_descr+ </> unUnqualComponentName (testName test)+ }+ return+ args'+ { argTitle = Flag $ prettyShow (packageName pkg_descr)+ , argComponentName = Flag $ prettyShow (packageName pkg_descr) ++ ":" ++ unUnqualComponentName (testName test)+ , -- we need to accommodate `argOutputDir`+ argBaseUrl = case argBaseUrl args' of+ Flag url -> Flag $ ".." </> url+ NoFlag -> NoFlag+ , argContents = case argContents args' of+ Flag url -> Flag $ ".." </> url+ NoFlag -> NoFlag+ , argIndex = case argIndex args' of+ Flag url -> Flag $ ".." </> url+ NoFlag -> NoFlag+ }++fromBenchmark+ :: Verbosity+ -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts))+ -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock.+ -- See Note [Hi Haddock Recompilation Avoidance]+ -> LocalBuildInfo+ -> ComponentLocalBuildInfo+ -> Maybe PathTemplate+ -- ^ template for HTML location+ -> HaddockTarget+ -> PackageDescription+ -> Benchmark+ -> HaddockArgs+ -- ^ common args+ -> IO HaddockArgs+fromBenchmark verbosity haddockArtifactsDirs lbi clbi htmlTemplate haddockTarget pkg_descr bench commonArgs = do+ inFiles <- map snd `fmap` getBenchmarkSourceFiles verbosity lbi bench clbi+ args <-+ mkHaddockArgs+ verbosity+ haddockArtifactsDirs+ lbi+ clbi+ htmlTemplate+ inFiles+ (benchmarkBuildInfo bench)+ let args' =+ commonArgs+ <> args+ { argOutputDir =+ Dir $+ haddockDirName haddockTarget pkg_descr+ </> unUnqualComponentName (benchmarkName bench)+ }+ return+ args'+ { argTitle = Flag $ prettyShow (packageName pkg_descr)+ , argComponentName = Flag $ prettyShow (packageName pkg_descr) ++ ":" ++ unUnqualComponentName (benchmarkName bench)+ , -- we need to accommodate `argOutputDir`+ argBaseUrl = case argBaseUrl args' of+ Flag url -> Flag $ ".." </> url+ NoFlag -> NoFlag+ , argContents = case argContents args' of+ Flag url -> Flag $ ".." </> url+ NoFlag -> NoFlag+ , argIndex = case argIndex args' of+ Flag url -> Flag $ ".." </> url+ NoFlag -> NoFlag+ }++fromForeignLib+ :: Verbosity+ -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts))+ -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock.+ -- See Note [Hi Haddock Recompilation Avoidance]+ -> LocalBuildInfo+ -> ComponentLocalBuildInfo+ -> Maybe PathTemplate+ -- ^ template for HTML location+ -> HaddockTarget+ -> PackageDescription+ -> ForeignLib+ -> HaddockArgs+ -- ^ common args+ -> IO HaddockArgs+fromForeignLib verbosity haddockArtifactsDirs lbi clbi htmlTemplate haddockTarget pkg_descr flib commonArgs = do+ inFiles <- map snd `fmap` getFLibSourceFiles verbosity lbi flib clbi+ args <-+ mkHaddockArgs+ verbosity+ haddockArtifactsDirs+ lbi+ clbi+ htmlTemplate+ inFiles+ (foreignLibBuildInfo flib)+ let args' =+ commonArgs+ <> args+ { argOutputDir =+ Dir $+ haddockDirName haddockTarget pkg_descr+ </> unUnqualComponentName (foreignLibName flib)+ }+ return+ args'+ { argTitle = Flag $ unUnqualComponentName $ foreignLibName flib+ , -- we need to accommodate `argOutputDir`+ argBaseUrl = case argBaseUrl args' of+ Flag url -> Flag $ ".." </> url+ NoFlag -> NoFlag+ , argContents = case argContents args' of+ Flag url -> Flag $ ".." </> url+ NoFlag -> NoFlag+ , argIndex = case argIndex args' of+ Flag url -> Flag $ ".." </> url+ NoFlag -> NoFlag+ }++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+ }+ CExe exe -> Just exe+ _ -> Nothing++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 (modifyVerbosityFlags verboseUnmarkOutput verbosity)) warnings+ return $+ mempty+ { argInterfaces = packageFlags+ }++getReexports :: ComponentLocalBuildInfo -> [OpenModule]+getReexports LibComponentLocalBuildInfo{componentExposedModules = mods} =+ mapMaybe exposedReexport mods+getReexports _ = []++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}++-- | If Hi Haddock is supported, this function creates temporary directories+-- and copies existing interface and object files produced by GHC into them,+-- then passes them off to the given continuation.+--+-- If Hi Haddock is _not_ supported, we can't re-use GHC's compilation files.+-- Instead, we use a clean temporary directory to the continuation,+-- with no hope for recompilation avoidance.+--+-- See Note [Hi Haddock Recompilation Avoidance]+reusingGHCCompilationArtifacts+ :: Verbosity+ -> TempFileOptions+ -> Maybe (SymbolicPath CWD (Path.Dir Pkg))+ -- ^ Working directory+ -> LocalBuildInfo+ -> BuildInfo+ -> ComponentLocalBuildInfo+ -> Version+ -- ^ Haddock's version+ -> ((SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts)) -> IO r)+ -- ^ Continuation+ -> IO r+reusingGHCCompilationArtifacts verbosity tmpFileOpts mbWorkDir lbi bi clbi version act+ | version >= mkVersion [2, 28, 0] = do+ withTempDirectoryCwdEx tmpFileOpts mbWorkDir (distPrefLBI lbi) "haddock-objs" $ \tmpObjDir ->+ withTempDirectoryCwdEx tmpFileOpts mbWorkDir (distPrefLBI lbi) "haddock-his" $ \tmpHiDir -> do+ -- Re-use ghc's interface and obj files, but first copy them to+ -- somewhere where it is safe if haddock overwrites them+ let+ vanillaOpts = componentGhcOptions Normal lbi bi clbi (buildDir lbi)+ i = interpretSymbolicPath mbWorkDir+ copyDir getGhcDir tmpDir = do+ let ghcDir = i $ fromFlag $ getGhcDir vanillaOpts+ ghcDirExists <- doesDirectoryExist ghcDir+ -- Don't try to copy artifacts if they don't exist, e.g. if+ -- we have not yet run the 'build' command.+ when ghcDirExists $+ copyDirectoryRecursive verbosity ghcDir (i tmpDir)+ copyDir ghcOptObjDir tmpObjDir+ copyDir ghcOptHiDir tmpHiDir+ -- copyDir ghcOptStubDir tmpStubDir -- (see W.1 in Note [Hi Haddock Recompilation Avoidance])++ act (tmpObjDir, tmpHiDir, fromFlag $ ghcOptHiDir vanillaOpts)+ | otherwise = do+ withTempDirectoryCwdEx tmpFileOpts mbWorkDir (distPrefLBI lbi) "tmp" $+ \tmpFallback -> act (tmpFallback, tmpFallback, tmpFallback)++-- ------------------------------------------------------------------------------++-- | Call haddock with the specified arguments.+runHaddock+ :: Verbosity+ -> Maybe (SymbolicPath CWD (Path.Dir Pkg))+ -> TempFileOptions+ -> Compiler+ -> Platform+ -> ConfiguredProgram+ -> Bool+ -- ^ require targets+ -> HaddockArgs+ -> IO ()+runHaddock verbosity mbWorkDir 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."+ | otherwise = do+ let haddockVersion =+ fromMaybe+ (error "unable to determine haddock version")+ (programVersion haddockProg)+ renderArgs verbosity mbWorkDir tmpFileOpts haddockVersion comp platform args $+ \flags result -> do+ runProgramCwd verbosity mbWorkDir haddockProg flags+ notice verbosity $ "Documentation created: " ++ result++renderArgs+ :: forall a+ . Verbosity+ -> Maybe (SymbolicPath CWD (Path.Dir Pkg))+ -> TempFileOptions+ -> Version+ -> Compiler+ -> Platform+ -> HaddockArgs+ -> ([String] -> FilePath -> IO a)+ -> IO a+renderArgs verbosity mbWorkDir tmpFileOpts version comp platform args k = do+ let haddockSupportsUTF8 = version >= mkVersion [2, 14, 4]+ haddockSupportsResponseFiles = version > mkVersion [2, 16, 2]+ createDirectoryIfMissingVerbose verbosity True (i outputDir)+ let withPrologueArgs prologueArgs =+ let renderedArgs = prologueArgs <> renderPureArgs version comp platform args+ in if haddockSupportsResponseFiles+ then+ withResponseFile+ verbosity+ tmpFileOpts+ "haddock-response.txt"+ (if haddockSupportsUTF8 then Just utf8 else Nothing)+ renderedArgs+ (\responseFileName -> k ["@" ++ responseFileName] result)+ else k renderedArgs result+ case (argPrologueFile args, argPrologue args) of+ (Flag pfile, _) ->+ withPrologueArgs ["--prologue=" ++ pfile]+ (_, Flag prologueText) ->+ withTempFileEx tmpFileOpts "haddock-prologue.txt" $+ \prologueFileName h -> do+ when haddockSupportsUTF8 (hSetEncoding h utf8)+ hPutStrLn h prologueText+ hClose h+ withPrologueArgs ["--prologue=" ++ u prologueFileName]+ (NoFlag, NoFlag) ->+ withPrologueArgs []+ where+ -- See Note [Symbolic paths] in Distribution.Utils.Path+ i = interpretSymbolicPath mbWorkDir+ u :: SymbolicPath Pkg to -> FilePath+ u = interpretSymbolicPathCWD++ outputDir = coerceSymbolicPath $ unDir $ argOutputDir args+ isNotArgContents = isNothing (flagToMaybe $ argContents args)+ isNotArgIndex = isNothing (flagToMaybe $ argIndex args)+ isArgGenIndex = fromFlagOrDefault False (argGenIndex args)+ -- Haddock, when generating HTML, does not generate an index if the options+ -- --use-contents or --use-index are passed to it. See+ -- https://haskell-haddock.readthedocs.io/en/latest/invoking.html#cmdoption-use-contents+ isIndexGenerated = isArgGenIndex && isNotArgContents && isNotArgIndex+ result =+ intercalate ", "+ . map+ ( \o ->+ i outputDir+ </> case o of+ Html+ | isIndexGenerated ->+ "index.html"+ Html+ | otherwise ->+ mempty+ 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=" ++ u (unDir (argOutputDir args)) </> f)+ . flagToList+ . argInterfaceFile+ $ args+ , if haddockSupportsPackageName+ then+ maybe+ []+ ( \pkg ->+ [ "--package-name="+ ++ case argComponentName args of+ Flag name -> name+ _ -> prettyShow (pkgName pkg)+ , "--package-version=" ++ prettyShow (pkgVersion pkg)+ ]+ )+ . flagToMaybe+ . argPackageName+ $ args+ else []+ , ["--since-qual=external" | isVersion 2 20]+ , [ "--quickjump" | isVersion 2 19, True <- flagToList . argQuickJump $ args+ ]+ , ["--hyperlinked-source" | isHyperlinkedSource]+ , (\(All b, xs) -> bool [] (map (("--hide=" ++) . prettyShow) xs) b)+ . argHideModules+ $ args+ , bool [] ["--ignore-all-exports"] . getAny . argIgnoreExports $ args+ , -- Haddock's --source-* options are ignored once --hyperlinked-source is+ -- set.+ -- See https://haskell-haddock.readthedocs.io/en/latest/invoking.html#cmdoption-hyperlinked-source+ -- To avoid Haddock's warning, we only set --source-* options if+ -- --hyperlinked-source is not set.+ if isHyperlinkedSource+ then []+ else+ maybe+ []+ ( \(m, e, l) ->+ [ "--source-module=" ++ m+ , "--source-entity=" ++ e+ ]+ ++ ["--source-entity-line=" ++ l | isVersion 2 14]+ )+ . 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+ , bool [verbosityFlag] [] . getAny . argVerbose $ args+ , map (\case Hoogle -> "--hoogle"; Html -> "--html")+ . fromFlagOrDefault []+ . argOutput+ $ args+ , renderInterfaces . argInterfaces $ args+ , (: []) . ("--odir=" ++) . u . unDir . argOutputDir $ args+ , maybe+ []+ ( (: [])+ . ("--title=" ++)+ . bool+ id+ (++ " (internal documentation)")+ (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+ | isVersion 2 19+ , r <- argReexports args+ ]+ , argTargets args+ , maybe [] ((: []) . (resourcesDirFlag ++)) . flagToMaybe . argResourcesDir $ args+ , -- Do not re-direct compilation output to a temporary directory (--no-tmp-comp-dir)+ -- We pass this option by default to haddock to avoid recompilation+ -- See Note [Hi Haddock Recompilation Avoidance]+ ["--no-tmp-comp-dir" | version >= mkVersion [2, 28, 0]]+ , bool [] ["--use-unicode"] . fromFlagOrDefault False . argUseUnicode $ args+ ]+ where+ -- See Note [Symbolic paths] in Distribution.Utils.Path+ u = interpretSymbolicPathCWD+ 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 ->+ ""+ ]+ , [case visibility of Visible -> "visible"; Hidden -> "hidden" | haddockSupportsVisibility]+ , [i]+ ]+ )++ isVersion major minor = version >= mkVersion [major, minor]+ verbosityFlag+ | isVersion 2 5 = "--verbosity=1"+ | otherwise = "--verbose"+ resourcesDirFlag+ | isVersion 2 29 = "--resources-dir="+ | otherwise = "--lib="+ haddockSupportsVisibility = version >= mkVersion [2, 26, 1]+ haddockSupportsPackageName = version > mkVersion [2, 16]+ haddockSupportsHyperlinkedSource = isVersion 2 17+ isHyperlinkedSource =+ haddockSupportsHyperlinkedSource+ && fromFlagOrDefault False (argLinkedSource args)++---------------------------------------------------------------------------------++-- | 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 ipkgs mkHtmlPath = do+ interfaces <-+ sequenceA+ [ case interfaceAndHtmlPath ipkg of+ Nothing -> do+ 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+ )+ 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+ ]++ let missing = lefts interfaces+ warning =+ "The following packages have no Haddock documentation "+ ++ "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 = [mkPackageName "rts"]++ -- Actually extract interface and HTML paths from an 'InstalledPackageInfo'.+ interfaceAndHtmlPath+ :: InstalledPackageInfo+ -> Maybe (FilePath, Maybe FilePath)+ interfaceAndHtmlPath pkg = do+ interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)+ html <- case mkHtmlPath of+ 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++ -- '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 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 ->+ dieWithException verbosity $ HaddockPackageFlags 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)++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+ pkg_id+ (mkLegacyUnitId pkg_id)+ (compilerInfo (compiler lbi))+ (hostPlatform lbi)++-- ------------------------------------------------------------------------------+-- hscolour support.++hscolour+ :: PackageDescription+ -> LocalBuildInfo+ -> [PPSuffixHandler]+ -> HscolourFlags+ -> IO ()+hscolour pkg lbi pps flags =+ void $+ hscolour_setupHooks+ (const $ return [])+ defaultVerbosityHandles+ pkg+ lbi+ pps+ flags++hscolour_setupHooks+ :: (SetupHooks.PreBuildComponentInputs -> IO [MonitorFilePath])+ -- ^ pre-build hook+ -> VerbosityHandles+ -> PackageDescription+ -> LocalBuildInfo+ -> [PPSuffixHandler]+ -> HscolourFlags+ -> IO [MonitorFilePath]+hscolour_setupHooks preBuildHook verbHandles =+ hscolour' preBuildHook verbHandles dieNoVerbosity ForDevelopment++hscolour'+ :: (SetupHooks.PreBuildComponentInputs -> IO [MonitorFilePath])+ -- ^ pre-build hook+ -> VerbosityHandles+ -> (String -> IO ())+ -- ^ Called when the 'hscolour' exe is not found.+ -> HaddockTarget+ -> PackageDescription+ -> LocalBuildInfo+ -> [PPSuffixHandler]+ -> HscolourFlags+ -> IO [MonitorFilePath]+hscolour'+ preBuildHook+ verbHandles+ onNoHsColour+ haddockTarget+ pkg_descr+ lbi+ suffixes+ flags =+ either noHsColourPath (\(hscolourProg, _, _) -> go hscolourProg)+ =<< lookupProgramVersion+ verbosity+ hscolourProgram+ (orLaterVersion (mkVersion [1, 8]))+ (withPrograms lbi)+ where+ noHsColourPath excep = do+ onNoHsColour $ exceptionMessage excep+ return []+ common = hscolourCommonFlags flags+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ distPref = fromFlag $ setupDistPref common+ mbWorkDir = mbWorkDirLBI lbi+ i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path+ u :: SymbolicPath Pkg to -> FilePath+ u = interpretSymbolicPathCWD++ go :: ConfiguredProgram -> IO [MonitorFilePath]+ 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."++ setupMessage verbosity "Running hscolour for" (packageId pkg_descr)+ createDirectoryIfMissingVerbose verbosity True $+ i $+ hscolourPref haddockTarget distPref pkg_descr++ let targets = allTargetsInBuildOrder' pkg_descr lbi++ -- 'foldM' with arguments flipped for readability+ forFoldM acc xs f = foldM f acc xs++ forFoldM [] targets $ \monsAcc target -> do+ let+ comp = targetComponent target+ clbi = targetCLBI target+ pbci = SetupHooks.PreBuildComponentInputs (BuildHscolour flags) lbi target++ mons <- preBuildComponent (preBuildHook pbci) verbosity lbi target+ preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes++ let+ doExe com = case compToExe com of+ Just exe -> do+ let outputDir =+ hscolourPref haddockTarget distPref pkg_descr+ </> makeRelativePathEx (unUnqualComponentName (exeName exe) </> "src")+ runHsColour hscolourProg outputDir =<< getExeSourceFiles verbosity lbi exe clbi+ Nothing -> do+ warn verbosity "Unsupported component, skipping..."+ return ()++ -- Execute the component-specific hscolour actions+ case comp of+ CLib lib -> do+ let outputDir = hscolourPref haddockTarget distPref pkg_descr </> makeRelativePathEx "src"+ runHsColour hscolourProg outputDir =<< getLibSourceFiles verbosity lbi lib clbi+ CFLib flib -> do+ let outputDir =+ hscolourPref haddockTarget distPref pkg_descr+ </> makeRelativePathEx+ ( 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++ return (monsAcc <> mons)++ stylesheet = flagToMaybe (hscolourCSS flags)++ runHsColour+ :: ConfiguredProgram+ -> SymbolicPath Pkg to+ -> [(ModuleName.ModuleName, SymbolicPath Pkg to1)]+ -> IO ()+ runHsColour prog outputDir moduleFiles = do+ createDirectoryIfMissingVerbose verbosity True (i outputDir)++ case stylesheet of -- copy the CSS file+ Nothing+ | programVersion prog >= Just (mkVersion [1, 9]) ->+ runProgramCwd+ verbosity+ mbWorkDir+ prog+ ["-print-css", "-o" ++ u outputDir </> "hscolour.css"]+ | otherwise -> return ()+ Just s -> copyFileVerbose verbosity s (i outputDir </> "hscolour.css")++ for_ moduleFiles $ \(m, inFile) ->+ runProgramCwd+ verbosity+ mbWorkDir+ prog+ ["-css", "-anchor", "-o" ++ outFile m, u inFile]+ where+ outFile m =+ i outputDir+ </> intercalate "-" (ModuleName.components m)+ <.> "html"++haddockToHscolour :: HaddockFlags -> HscolourFlags+haddockToHscolour flags =+ HscolourFlags+ { hscolourCommonFlags = haddockCommonFlags flags+ , hscolourCSS = haddockHscolourCss flags+ , hscolourExecutables = haddockExecutables flags+ , hscolourTestSuites = haddockTestSuites flags+ , hscolourBenchmarks = haddockBenchmarks flags+ , hscolourForeignLibs = haddockForeignLibs flags } -- ------------------------------------------------------------------------------
− src/Distribution/Simple/HaskellSuite.hs
@@ -1,267 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}--module Distribution.Simple.HaskellSuite where--import Distribution.Compat.Prelude-import Prelude ()--import qualified Data.List.NonEmpty as NE--import Distribution.InstalledPackageInfo hiding (includeDirs)-import Distribution.Package-import Distribution.PackageDescription-import Distribution.Parsec (simpleParsec)-import Distribution.Pretty-import Distribution.Simple.BuildPaths-import Distribution.Simple.Compiler-import Distribution.Simple.Errors-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--configure- :: 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 (dieWithException verbosity $ ProvideHaskellSuiteTool msg) return mbHcPath-- when (isJust hcPkgPath) $- warn verbosity "--with-hc-pkg option is ignored for haskell-suite"-- (comp, confdCompiler, progdb1) <- configureCompiler hcPath progdb0-- -- Update our pkg tool. It uses the same executable as the compiler, but- -- all command start with "pkg"- (confdPkg, _) <- requireProgram verbosity haskellSuitePkgProgram progdb1- let progdb2 =- updateProgram- confdPkg- { programLocation = programLocation confdCompiler- , programDefaultArgs = ["pkg"]- }- progdb1-- return (comp, Nothing, progdb2)- where- configureCompiler hcPath progdb0' = do- let- haskellSuiteProgram' =- haskellSuiteProgram- { 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.- -- Instead, call configureProgram directly first.- progdb1 <- configureProgram verbosity haskellSuiteProgram' progdb0'- (confdCompiler, progdb2) <- requireProgram verbosity haskellSuiteProgram' progdb1-- extensions <- getExtensions 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- }-- return (comp, confdCompiler, progdb2)--hstoolVersion :: Verbosity -> FilePath -> IO (Maybe Version)-hstoolVersion = findProgramVersion "--hspkg-version" id--numericVersion :: Verbosity -> FilePath -> IO (Maybe Version)-numericVersion = findProgramVersion "--compiler-version" (fromMaybe "" . safeLast . words)--getCompilerVersion :: Verbosity -> ConfiguredProgram -> IO (String, Version)-getCompilerVersion verbosity prog = do- output <- rawSystemStdout verbosity (programPath prog) ["--compiler-version"]- let- parts = words output- name = concat $ safeInit parts -- there shouldn't be any spaces in the name anyway- versionStr = fromMaybe "" $ safeLast parts- version <-- maybe- (dieWithException verbosity CannotDetermineCompilerVersion)- return- $ simpleParsec versionStr- return (name, version)--getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Maybe CompilerFlag)]-getExtensions verbosity prog = do- extStrs <-- lines- `fmap` rawSystemStdout verbosity (programPath prog) ["--supported-extensions"]- return- [(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"]- return- [(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 packagedbs progdb =- liftM (PackageIndex.fromList . concat) $ for packagedbs $ \packagedb ->- do- str <-- getDbProgramOutput- verbosity- haskellSuitePkgProgram- progdb- ["dump", packageDbOpt packagedb]- `catchExit` \_ -> dieWithException verbosity PkgDumpFailed-- case parsePackages str of- Right ok -> return ok- _ -> dieWithException verbosity FailedToParseOutput- where- parsePackages str =- 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--buildLib- :: 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,- -- pieces of PackageDescription.- --- -- For now, we only pass those that we know are used.-- let odir = buildDir lbi- bi = libBuildInfo lib- srcDirs = map getSymbolicPath (hsSourceDirs bi) ++ [odir]- dbStack = withPackageDB lbi- language = fromMaybe Haskell98 (defaultLanguage bi)- progdb = withPrograms lbi- 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]--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- 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)--registerPackage- :: Verbosity- -> ProgramDb- -> PackageDBStack- -> InstalledPackageInfo- -> IO ()-registerPackage verbosity progdb packageDbs installedPkgInfo = do- (hspkg, _) <- requireProgram verbosity haskellSuitePkgProgram progdb-- runProgramInvocation verbosity $- ( programInvocation- hspkg- ["update", packageDbOpt $ registrationPackageDB packageDbs]- )- { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo installedPkgInfo- }--initPackageDB :: Verbosity -> ProgramDb -> FilePath -> IO ()-initPackageDB verbosity progdb dbPath =- runDbProgram- verbosity- haskellSuitePkgProgram- progdb- ["init", dbPath]--packageDbOpt :: PackageDB -> String-packageDbOpt GlobalPackageDB = "--global"-packageDbOpt UserPackageDB = "--user"-packageDbOpt (SpecificPackageDB db) = "--package-db=" ++ db
src/Distribution/Simple/Hpc.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-}@@ -36,7 +37,11 @@ ) import qualified Distribution.PackageDescription as PD import Distribution.Pretty-import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..))+import Distribution.Simple.LocalBuildInfo+ ( LocalBuildInfo (..)+ , interpretSymbolicPathLBI+ , mbWorkDirLBI+ ) import Distribution.Simple.Program ( hpcProgram , requireProgramVersion@@ -44,64 +49,66 @@ import Distribution.Simple.Program.Hpc (markup, union) import Distribution.Simple.Utils (notice) import Distribution.Types.UnqualComponentName+import Distribution.Utils.Path import Distribution.Verbosity (Verbosity ()) import Distribution.Version (anyVersion)+ import System.Directory (createDirectoryIfMissing, doesFileExist)-import System.FilePath -- ------------------------------------------------------------------------- -- Haskell Program Coverage -data Way = Vanilla | Prof | Dyn+data Way = Vanilla | Prof | Dyn | ProfDyn deriving (Bounded, Enum, Eq, Read, Show) hpcDir- :: FilePath+ :: SymbolicPath Pkg (Dir Dist) -- ^ \"dist/\" prefix -> Way- -> FilePath+ -> SymbolicPath Pkg (Dir Artifacts) -- ^ Directory containing component's HPC .mix files-hpcDir distPref way = distPref </> "hpc" </> wayDir+hpcDir distPref way = distPref </> makeRelativePathEx ("hpc" </> wayDir) where wayDir = case way of Vanilla -> "vanilla" Prof -> "prof" Dyn -> "dyn"+ ProfDyn -> "prof_dyn" mixDir- :: FilePath+ :: SymbolicPath Pkg (Dir Dist) -- ^ \"dist/\" prefix -> Way- -> FilePath+ -> SymbolicPath Pkg (Dir Mix) -- ^ Directory containing test suite's .mix files-mixDir distPref way = hpcDir distPref way </> "mix"+mixDir distPref way = hpcDir distPref way </> makeRelativePathEx "mix" tixDir- :: FilePath+ :: SymbolicPath Pkg (Dir Dist) -- ^ \"dist/\" prefix -> Way- -> FilePath+ -> SymbolicPath Pkg (Dir Tix) -- ^ Directory containing test suite's .tix files-tixDir distPref way = hpcDir distPref way </> "tix"+tixDir distPref way = hpcDir distPref way </> makeRelativePathEx "tix" -- | Path to the .tix file containing a test suite's sum statistics. tixFilePath- :: FilePath+ :: SymbolicPath Pkg (Dir Dist) -- ^ \"dist/\" prefix -> Way -> FilePath -- ^ Component name- -> FilePath+ -> SymbolicPath Pkg File -- ^ Path to test suite's .tix file-tixFilePath distPref way name = tixDir distPref way </> name <.> "tix"+tixFilePath distPref way name = tixDir distPref way </> makeRelativePathEx (name <.> "tix") htmlDir- :: FilePath+ :: SymbolicPath Pkg (Dir Dist) -- ^ \"dist/\" prefix -> Way- -> FilePath+ -> SymbolicPath Pkg (Dir Artifacts) -- ^ Path to test suite's HTML markup directory-htmlDir distPref way = hpcDir distPref way </> "html"+htmlDir distPref way = hpcDir distPref way </> makeRelativePathEx "html" -- | Attempt to guess the way the test suites in this package were compiled -- and linked with the library so the correct module interfaces are found.@@ -114,7 +121,7 @@ -- | Haskell Program Coverage information required to produce a valid HPC -- report through the `hpc markup` call for the package libraries. data HPCMarkupInfo = HPCMarkupInfo- { pathsToLibsArtifacts :: [FilePath]+ { pathsToLibsArtifacts :: [SymbolicPath Pkg (Dir Artifacts)] -- ^ The paths to the library components whose modules are included in the -- coverage report , libsModulesToInclude :: [ModuleName]@@ -126,14 +133,16 @@ :: Verbosity -> HPCMarkupInfo -> LocalBuildInfo- -> FilePath+ -> SymbolicPath Pkg (Dir Dist) -- ^ Testsuite \"dist/\" prefix -> PD.PackageDescription -> [TestSuite] -> IO () markupPackage verbosity HPCMarkupInfo{pathsToLibsArtifacts, libsModulesToInclude} lbi testDistPref pkg_descr suites = do let tixFiles = map (tixFilePath testDistPref way) testNames- tixFilesExist <- traverse doesFileExist tixFiles+ mbWorkDir = mbWorkDirLBI lbi+ i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path+ tixFilesExist <- traverse (doesFileExist . i) tixFiles when (and tixFilesExist) $ do -- behaviour of 'markup' depends on version, so we need *a* version -- but no particular one@@ -165,16 +174,16 @@ let excluded = concatMap testModules suites ++ [main] pkgName = prettyShow $ PD.package pkg_descr summedTixFile = tixFilePath testDistPref way pkgName- createDirectoryIfMissing True $ takeDirectory summedTixFile- union hpc verbosity tixFiles summedTixFile excluded+ createDirectoryIfMissing True $ i $ takeDirectorySymbolicPath summedTixFile+ union mbWorkDir hpc verbosity tixFiles summedTixFile excluded return summedTixFile - markup hpc hpcVer verbosity tixFile mixDirs htmlDir' libsModulesToInclude+ markup mbWorkDir hpc hpcVer verbosity tixFile mixDirs htmlDir' libsModulesToInclude notice verbosity $ "Package coverage report written to "- ++ htmlDir'+ ++ i htmlDir' </> "hpc_index.html" where way = guessWay lbi testNames = fmap (unUnqualComponentName . testName) suites- mixDirs = map (`mixDir` way) pathsToLibsArtifacts+ mixDirs = map ((`mixDir` way) . coerceSymbolicPath) pathsToLibsArtifacts
src/Distribution/Simple/Install.hs view
@@ -1,4 +1,7 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} -----------------------------------------------------------------------------@@ -17,11 +20,15 @@ -- compiler-specific functions to do the rest. module Distribution.Simple.Install ( install+ , install_setupHooks+ , installFileGlob ) where import Distribution.Compat.Prelude import Prelude () +import Distribution.CabalSpecVersion (CabalSpecVersion)+ import Distribution.Types.ExecutableScope import Distribution.Types.ForeignLib import Distribution.Types.LocalBuildInfo@@ -31,40 +38,43 @@ import Distribution.Package import Distribution.PackageDescription-import Distribution.Simple.BuildPaths (haddockName, haddockPref)+import Distribution.Simple.BuildPaths (haddockPath, haddockPref) import Distribution.Simple.BuildTarget import Distribution.Simple.Compiler ( CompilerFlavor (..) , compilerFlavor )-import Distribution.Simple.Flag- ( fromFlag- ) import Distribution.Simple.Glob (matchDirFileGlob) import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Setup.Config import Distribution.Simple.Setup.Copy ( CopyFlags (..) ) import Distribution.Simple.Setup.Haddock ( HaddockTarget (ForDevelopment) )+import Distribution.Simple.SetupHooks.Internal+ ( InstallHooks (..)+ )+import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose , dieWithException , info , installDirectoryContents , installOrdinaryFile+ , isAbsoluteOnAnyPlatform , isInSearchPath , noticeNoWrap , warn )-import Distribution.Utils.Path (getSymbolicPath)+import Distribution.Utils.Path import Distribution.Compat.Graph (IsNode (..)) import Distribution.Simple.Errors import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS-import qualified Distribution.Simple.HaskellSuite as HaskellSuite+import Distribution.Simple.Setup.Common import qualified Distribution.Simple.UHC as UHC import System.Directory@@ -72,10 +82,8 @@ , doesFileExist ) import System.FilePath- ( isRelative- , takeDirectory+ ( takeDirectory , takeFileName- , (</>) ) import Distribution.Pretty@@ -96,32 +104,58 @@ -> CopyFlags -- ^ flags sent to copy or install -> IO ()-install pkg_descr lbi flags = do- checkHasLibsOrExes- targets <- readTargetInfos verbosity pkg_descr lbi (copyArgs flags)+install = install_setupHooks SetupHooks.noInstallHooks defaultVerbosityHandles - copyPackage verbosity pkg_descr lbi distPref copydest+install_setupHooks+ :: InstallHooks+ -> VerbosityHandles+ -> PackageDescription+ -- ^ information from the .cabal file+ -> LocalBuildInfo+ -- ^ information from the configure step+ -> CopyFlags+ -- ^ flags sent to copy or install+ -> IO ()+install_setupHooks+ (InstallHooks{installComponentHook})+ verbHandles+ pkg_descr+ lbi+ flags = do+ checkHasLibsOrExes+ targets <- readTargetInfos verbosity pkg_descr lbi (copyTargets flags) - -- It's not necessary to do these in build-order, but it's harmless- 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)+ copyPackage verbosity pkg_descr lbi distPref copydest - checkHasLibsOrExes =- unless (hasLibs pkg_descr || hasForeignLibs pkg_descr || hasExes pkg_descr) $- warn verbosity "No executables and no library found. Nothing to do."+ -- It's not necessary to do these in build-order, but it's harmless+ withNeededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) $ \target -> do+ let comp = targetComponent target+ clbi = targetCLBI target+ copyComponent verbosity pkg_descr lbi comp clbi copydest+ for_ installComponentHook $ \instAction ->+ let inputs =+ SetupHooks.InstallComponentInputs+ { copyFlags = flags+ , localBuildInfo = lbi+ , targetInfo = target+ }+ in instAction inputs+ where+ common = copyCommonFlags flags+ distPref = fromFlag $ setupDistPref common+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ copydest = fromFlag (copyDest flags) + checkHasLibsOrExes =+ unless (hasLibs pkg_descr || hasForeignLibs pkg_descr || hasExes pkg_descr) $+ warn verbosity "No executables and no library found. Nothing to do."+ -- | Copy package global files. copyPackage :: Verbosity -> PackageDescription -> LocalBuildInfo- -> FilePath+ -> SymbolicPath Pkg (Dir Dist) -> CopyDest -> IO () copyPackage verbosity pkg_descr lbi distPref copydest = do@@ -134,17 +168,19 @@ , htmldir = htmlPref , haddockdir = interfacePref } = absoluteInstallCommandDirs pkg_descr lbi (localUnitId lbi) copydest+ mbWorkDir = mbWorkDirLBI lbi+ i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path -- Install (package-global) data files- installDataFiles verbosity pkg_descr dataPref+ installDataFiles verbosity mbWorkDir pkg_descr $ makeSymbolicPath dataPref -- Install (package-global) Haddock files -- TODO: these should be done per-library- docExists <- doesDirectoryExist $ haddockPref ForDevelopment distPref pkg_descr+ docExists <- doesDirectoryExist $ i $ haddockPref ForDevelopment distPref pkg_descr info verbosity ( "directory "- ++ haddockPref ForDevelopment distPref pkg_descr+ ++ getSymbolicPath (haddockPref ForDevelopment distPref pkg_descr) ++ " does exist: " ++ show docExists )@@ -155,7 +191,7 @@ createDirectoryIfMissingVerbose verbosity True htmlPref installDirectoryContents verbosity- (haddockPref ForDevelopment distPref pkg_descr)+ (i $ haddockPref ForDevelopment distPref pkg_descr) htmlPref -- setPermissionsRecursive [Read] htmlPref -- The haddock interface file actually already got installed@@ -164,25 +200,26 @@ -- copy in htmlPref first. let haddockInterfaceFileSrc = haddockPref ForDevelopment distPref pkg_descr- </> haddockName pkg_descr- haddockInterfaceFileDest = interfacePref </> haddockName pkg_descr+ </> makeRelativePathEx (haddockPath pkg_descr)+ haddockInterfaceFileDest = interfacePref </> haddockPath 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+ exists <- doesFileExist $ i haddockInterfaceFileSrc when exists $ do createDirectoryIfMissingVerbose verbosity True interfacePref installOrdinaryFile verbosity- haddockInterfaceFileSrc+ (i haddockInterfaceFileSrc) haddockInterfaceFileDest let lfiles = licenseFiles pkg_descr unless (null lfiles) $ do createDirectoryIfMissingVerbose verbosity True docPref- for_ lfiles $ \lfile' -> do- let lfile :: FilePath- lfile = getSymbolicPath lfile'- installOrdinaryFile verbosity lfile (docPref </> takeFileName lfile)+ for_ lfiles $ \lfile -> do+ installOrdinaryFile+ verbosity+ (i lfile)+ (docPref </> takeFileName (getSymbolicPath lfile)) -- | Copy files associated with a component. copyComponent@@ -197,9 +234,10 @@ let InstallDirs { libdir = libPref , dynlibdir = dynlibPref+ , bytecodelibdir = bytecodeLibPref , includedir = incPref } = absoluteInstallCommandDirs pkg_descr lbi (componentUnitId clbi) copydest- buildPref = componentBuildDir lbi clbi+ buildPref = interpretSymbolicPathLBI lbi $ componentBuildDir lbi clbi case libName lib of LMainLibName -> noticeNoWrap verbosity ("Installing library in " ++ libPref)@@ -210,19 +248,9 @@ 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+ GHC -> GHC.installLib verbosity lbi libPref dynlibPref bytecodeLibPref buildPref pkg_descr lib clbi+ GHCJS -> GHCJS.installLib verbosity lbi libPref dynlibPref bytecodeLibPref buildPref pkg_descr lib clbi+ UHC -> UHC.installLib verbosity lbi libPref dynlibPref bytecodeLibPref buildPref pkg_descr lib clbi _ -> dieWithException verbosity $ CompilerNotInstalled (compilerFlavor (compiler lbi)) copyComponent verbosity pkg_descr lbi (CFLib flib) clbi copydest = do@@ -230,7 +258,7 @@ { flibdir = flibPref , includedir = incPref } = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest- buildPref = componentBuildDir lbi clbi+ buildPref = interpretSymbolicPathLBI lbi $ componentBuildDir lbi clbi noticeNoWrap verbosity ("Installing foreign library " ++ unUnqualComponentName (foreignLibName flib) ++ " in " ++ flibPref) installIncludeFiles verbosity (foreignLibBuildInfo flib) lbi buildPref incPref@@ -243,7 +271,7 @@ let installDirs = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest -- the installers know how to find the actual location of the -- binaries- buildPref = buildDir lbi+ buildPref = interpretSymbolicPathLBI lbi $ buildDir lbi uid = componentUnitId clbi pkgid = packageId pkg_descr binPref@@ -260,7 +288,7 @@ ++ binPref ) inPath <- isInSearchPath binPref- when (not inPath) $+ unless inPath $ warn verbosity ( "The directory "@@ -271,7 +299,6 @@ 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 () _ -> dieWithException verbosity $ CompilerNotInstalled (compilerFlavor (compiler lbi)) @@ -280,29 +307,57 @@ copyComponent _ _ _ (CTest _) _ _ = return () -- | Install the files listed in data-files-installDataFiles :: Verbosity -> PackageDescription -> FilePath -> IO ()-installDataFiles verbosity pkg_descr destDataDir =- for_ (dataFiles pkg_descr) $ \glob -> do- let srcDataDirRaw = dataDir pkg_descr- srcDataDir =- if null srcDataDirRaw- then "."- else srcDataDirRaw- files <- matchDirFileGlob verbosity (specVersion pkg_descr) srcDataDir glob- for_ files $ \file' -> do- let src = srcDataDir </> file'- dst = destDataDir </> file'- createDirectoryIfMissingVerbose verbosity True (takeDirectory dst)- installOrdinaryFile verbosity src dst+installDataFiles+ :: Verbosity+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -> PackageDescription+ -> SymbolicPath Pkg (Dir DataDir)+ -> IO ()+installDataFiles verbosity mbWorkDir pkg_descr destDataDir =+ traverse_+ (installFileGlob verbosity (specVersion pkg_descr) mbWorkDir (srcDataDir, destDataDir))+ (dataFiles pkg_descr)+ where+ srcDataDirRaw = getSymbolicPath $ dataDir pkg_descr+ srcDataDir :: Maybe (SymbolicPath CWD (Dir DataDir))+ srcDataDir+ | null srcDataDirRaw =+ Nothing+ | isAbsoluteOnAnyPlatform srcDataDirRaw =+ Just $ makeSymbolicPath srcDataDirRaw+ | otherwise =+ Just $ fromMaybe sameDirectory mbWorkDir </> makeRelativePathEx srcDataDirRaw +-- | Install the files specified by the given glob pattern.+installFileGlob+ :: Verbosity+ -> CabalSpecVersion+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -> (Maybe (SymbolicPath CWD (Dir DataDir)), SymbolicPath Pkg (Dir DataDir))+ -- ^ @(src_dir, dest_dir)@+ -> RelativePath DataDir File+ -- ^ file glob pattern+ -> IO ()+installFileGlob verbosity spec_version mbWorkDir (srcDir, destDir) glob = do+ files <- matchDirFileGlob verbosity spec_version srcDir glob+ for_ files $ \file' -> do+ let src = getSymbolicPath (fromMaybe sameDirectory srcDir </> file')+ dst = interpretSymbolicPath mbWorkDir (destDir </> 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)+ let relincdirs = sameDirectory : mapMaybe symbolicPathRelative_maybe (includeDirs libBi) incdirs =- [baseDir lbi </> dir | dir <- relincdirs]- ++ [buildPref </> dir | dir <- relincdirs]- incs <- traverse (findInc incdirs) (installIncludes libBi)+ [ root </> getSymbolicPath dir+ | -- NB: both baseDir and buildPref are already interpreted,+ -- so we don't need to interpret these paths in the call to findInc.+ dir <- relincdirs+ , root <- [baseDir lbi, buildPref]+ ]+ incs <- traverse (findInc incdirs . getSymbolicPath) (installIncludes libBi) sequence_ [ do createDirectoryIfMissingVerbose verbosity True destDir@@ -312,9 +367,11 @@ destDir = takeDirectory destFile ] where- baseDir lbi' = fromMaybe "" (takeDirectory <$> cabalFilePath lbi')- findInc [] file = dieWithException verbosity $ CantFindIncludeFile 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' = packageRoot $ configCommonFlags $ configFlags lbi'+ findInc fs f = go fs+ where+ go [] = dieWithException verbosity $ CantFindIncludeFile f fs+ go (d : ds) = do+ let path = d </> f+ b <- doesFileExist path+ if b then return (f, path) else go ds
src/Distribution/Simple/InstallDirs.hs view
@@ -1,8 +1,9 @@+{-# LANGUAGE CApiFFI #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -----------------------------------------------------------------------------@@ -45,6 +46,7 @@ , compilerTemplateEnv , packageTemplateEnv , abiTemplateEnv+ , installDirsGrammar , installDirsTemplateEnv ) where @@ -52,9 +54,13 @@ import Prelude () import Distribution.Compat.Environment (lookupEnv)+import Distribution.Compat.Lens (Lens') import Distribution.Compiler+import Distribution.FieldGrammar import Distribution.Package+import Distribution.Parsec import Distribution.Pretty+import Distribution.Simple.Flag import Distribution.Simple.InstallDirs.Internal import Distribution.System @@ -88,6 +94,7 @@ , libdir :: dir , libsubdir :: dir , dynlibdir :: dir+ , bytecodelibdir :: dir , flibdir :: dir -- ^ foreign libraries , libexecdir :: dir@@ -101,12 +108,13 @@ , haddockdir :: dir , sysconfdir :: dir }- deriving (Eq, Read, Show, Functor, Generic, Typeable)+ deriving (Eq, Read, Show, Functor, Generic) instance Binary dir => Binary (InstallDirs dir)+instance NFData dir => NFData (InstallDirs dir) instance Structured dir => Structured (InstallDirs dir) -instance (Semigroup dir, Monoid dir) => Monoid (InstallDirs dir) where+instance Monoid dir => Monoid (InstallDirs dir) where mempty = gmempty mappend = (<>) @@ -125,6 +133,7 @@ , libdir = libdir a `combine` libdir b , libsubdir = libsubdir a `combine` libsubdir b , dynlibdir = dynlibdir a `combine` dynlibdir b+ , bytecodelibdir = bytecodelibdir a `combine` bytecodelibdir b , flibdir = flibdir a `combine` flibdir b , libexecdir = libexecdir a `combine` libexecdir b , libexecsubdir = libexecsubdir a `combine` libexecsubdir b@@ -223,6 +232,7 @@ "$libdir" </> case comp of UHC -> "$pkgid" _other -> "$abi"+ , bytecodelibdir = "$libdir" </> "$libsubdir" , libexecsubdir = "$abi" </> "$pkgid" , flibdir = "$libdir" , libexecdir = case buildOS of@@ -278,6 +288,8 @@ , libdir = subst libdir [prefixVar, bindirVar] , libsubdir = subst libsubdir [] , dynlibdir = subst dynlibdir [prefixVar, bindirVar, libdirVar]+ , bytecodelibdir =+ subst bytecodelibdir [prefixVar, bindirVar, libdirVar, libsubdirVar] , flibdir = subst flibdir [prefixVar, bindirVar, libdirVar] , libexecdir = subst libexecdir prefixBinLibVars , libexecsubdir = subst libexecsubdir []@@ -344,6 +356,8 @@ CopyToDb FilePath deriving (Eq, Show, Generic) +-- TODO: are these paths absolute or relative? Relative to what?+ instance Binary CopyDest instance Structured CopyDest @@ -387,9 +401,10 @@ -- | 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)+ deriving (Eq, Ord, Generic) instance Binary PathTemplate+instance NFData PathTemplate instance Structured PathTemplate type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)]@@ -480,6 +495,7 @@ , (LibdirVar, libdir dirs) , (LibsubdirVar, libsubdir dirs) , (DynlibdirVar, dynlibdir dirs)+ , (BytecodelibdirVar, bytecodelibdir dirs) , (DatadirVar, datadir dirs) , (DatasubdirVar, datasubdir dirs) , (DocdirVar, docdir dirs)@@ -505,6 +521,12 @@ , (template, "") <- reads path ] +instance Parsec PathTemplate where+ parsec = parsecPathTemplate++parsecPathTemplate :: CabalParsing m => m PathTemplate+parsecPathTemplate = toPathTemplate <$> parsecFilePath+ -- --------------------------------------------------------------------------- -- Internal utilities @@ -535,14 +557,7 @@ -- csidl_PROGRAM_FILES_COMMON :: CInt -- csidl_PROGRAM_FILES_COMMON = 0x002b -{- FOURMOLU_DISABLE -}-#ifdef x86_64_HOST_ARCH-#define CALLCONV ccall-#else-#define CALLCONV stdcall-#endif--foreign import CALLCONV unsafe "shlobj.h SHGetFolderPathW"+foreign import capi unsafe "shlobj.h SHGetFolderPathW" c_SHGetFolderPath :: Ptr () -> CInt -> Ptr ()@@ -550,4 +565,86 @@ -> CWString -> Prelude.IO CInt #endif-{- FOURMOLU_ENABLE -}++-- ---------------------------------------------------------------------------+-- FieldGrammar++installDirsGrammar :: ParsecFieldGrammar' (InstallDirs (Flag PathTemplate))+installDirsGrammar =+ InstallDirs+ <$> optionalFieldDef "prefix" installDirsPrefixLens mempty+ <*> optionalFieldDef "bindir" installDirsBindirLens mempty+ <*> optionalFieldDef "libdir" installDirsLibdirLens mempty+ <*> optionalFieldDef "libsubdir" installDirsLibsubdirLens mempty+ <*> optionalFieldDef "dynlibdir" installDirsDynlibdirLens mempty+ <*> optionalFieldDef "bytecodelibdir" installDirsBytecodelibdirLens mempty+ <*> pure NoFlag -- flibdir+ <*> optionalFieldDef "libexecdir" installDirsLibexecdirLens mempty+ <*> optionalFieldDef "libexecsubdir" installDirsLibexecsubdirLens mempty+ <*> pure NoFlag -- includedir+ <*> optionalFieldDef "datadir" installDirsDatadirLens mempty+ <*> optionalFieldDef "datasubdir" installDirsDatasubdirLens mempty+ <*> optionalFieldDef "docdir" installDirsDocdirLens mempty+ <*> pure NoFlag -- mandir+ <*> optionalFieldDef "htmldir" installDirsHtmldirLens mempty+ <*> optionalFieldDef "haddockdir" installDirsHaddockdirLens mempty+ <*> optionalFieldDef "sysconfdir" installDirsSysconfdirLens mempty++-- ---------------------------------------------------------------------------+-- Lenses++installDirsPrefixLens :: Lens' (InstallDirs a) a+installDirsPrefixLens f c = fmap (\x -> c{prefix = x}) (f (prefix c))+{-# INLINEABLE installDirsPrefixLens #-}++installDirsBindirLens :: Lens' (InstallDirs a) a+installDirsBindirLens f c = fmap (\x -> c{bindir = x}) (f (bindir c))+{-# INLINEABLE installDirsBindirLens #-}++installDirsLibdirLens :: Lens' (InstallDirs a) a+installDirsLibdirLens f c = fmap (\x -> c{libdir = x}) (f (libdir c))+{-# INLINEABLE installDirsLibdirLens #-}++installDirsLibsubdirLens :: Lens' (InstallDirs a) a+installDirsLibsubdirLens f c = fmap (\x -> c{libsubdir = x}) (f (libsubdir c))+{-# INLINEABLE installDirsLibsubdirLens #-}++installDirsDynlibdirLens :: Lens' (InstallDirs a) a+installDirsDynlibdirLens f c = fmap (\x -> c{dynlibdir = x}) (f (dynlibdir c))+{-# INLINEABLE installDirsDynlibdirLens #-}++installDirsBytecodelibdirLens :: Lens' (InstallDirs a) a+installDirsBytecodelibdirLens f c = fmap (\x -> c{bytecodelibdir = x}) (f (bytecodelibdir c))+{-# INLINEABLE installDirsBytecodelibdirLens #-}++installDirsLibexecdirLens :: Lens' (InstallDirs a) a+installDirsLibexecdirLens f c = fmap (\x -> c{libexecdir = x}) (f (libexecdir c))+{-# INLINEABLE installDirsLibexecdirLens #-}++installDirsLibexecsubdirLens :: Lens' (InstallDirs a) a+installDirsLibexecsubdirLens f c = fmap (\x -> c{libexecsubdir = x}) (f (libexecsubdir c))+{-# INLINEABLE installDirsLibexecsubdirLens #-}++installDirsDatadirLens :: Lens' (InstallDirs a) a+installDirsDatadirLens f c = fmap (\x -> c{datadir = x}) (f (datadir c))+{-# INLINEABLE installDirsDatadirLens #-}++installDirsDatasubdirLens :: Lens' (InstallDirs a) a+installDirsDatasubdirLens f c = fmap (\x -> c{datasubdir = x}) (f (datasubdir c))+{-# INLINEABLE installDirsDatasubdirLens #-}++installDirsDocdirLens :: Lens' (InstallDirs a) a+installDirsDocdirLens f c = fmap (\x -> c{docdir = x}) (f (docdir c))+{-# INLINEABLE installDirsDocdirLens #-}++installDirsHtmldirLens :: Lens' (InstallDirs a) a+installDirsHtmldirLens f c = fmap (\x -> c{htmldir = x}) (f (htmldir c))+{-# INLINEABLE installDirsHtmldirLens #-}++installDirsHaddockdirLens :: Lens' (InstallDirs a) a+installDirsHaddockdirLens f c = fmap (\x -> c{haddockdir = x}) (f (haddockdir c))+{-# INLINEABLE installDirsHaddockdirLens #-}++installDirsSysconfdirLens :: Lens' (InstallDirs a) a+installDirsSysconfdirLens f c = fmap (\x -> c{sysconfdir = x}) (f (sysconfdir c))+{-# INLINEABLE installDirsSysconfdirLens #-}
src/Distribution/Simple/InstallDirs/Internal.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module Distribution.Simple.InstallDirs.Internal@@ -12,9 +11,10 @@ data PathComponent = Ordinary FilePath | Variable PathTemplateVariable- deriving (Eq, Ord, Generic, Typeable)+ deriving (Eq, Ord, Generic) instance Binary PathComponent+instance NFData PathComponent instance Structured PathComponent data PathTemplateVariable@@ -28,6 +28,8 @@ LibsubdirVar | -- | The @$dynlibdir@ path variable DynlibdirVar+ | -- | The @$bytecodelibdir@ path variable+ BytecodelibdirVar | -- | The @$datadir@ path variable DatadirVar | -- | The @$datasubdir@ path variable@@ -65,9 +67,10 @@ TestSuiteResultVar | -- | The name of the benchmark being run BenchmarkNameVar- deriving (Eq, Ord, Generic, Typeable)+ deriving (Eq, Ord, Generic) instance Binary PathTemplateVariable+instance NFData PathTemplateVariable instance Structured PathTemplateVariable instance Show PathTemplateVariable where@@ -77,6 +80,7 @@ show LibdirVar = "libdir" show LibsubdirVar = "libsubdir" show DynlibdirVar = "dynlibdir"+ show BytecodelibdirVar = "bytecodelibdir" show DatadirVar = "datadir" show DatasubdirVar = "datasubdir" show DocdirVar = "docdir"@@ -110,6 +114,7 @@ , ("libdir", LibdirVar) , ("libsubdir", LibsubdirVar) , ("dynlibdir", DynlibdirVar)+ , ("bytecodelibdir", BytecodelibdirVar) , ("datadir", DatadirVar) , ("datasubdir", DatasubdirVar) , ("docdir", DocdirVar)
src/Distribution/Simple/LocalBuildInfo.hs view
@@ -1,7 +1,6 @@-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} -----------------------------------------------------------------------------@@ -29,9 +28,13 @@ -- * Convenience accessors , buildDir- , cabalFilePath+ , packageRoot , progPrefix , progSuffix+ , interpretSymbolicPathLBI+ , mbWorkDirLBI+ , absoluteWorkingDirLBI+ , buildWays -- * Buildable package components , Component (..)@@ -91,6 +94,7 @@ import Distribution.PackageDescription import Distribution.Pretty import Distribution.Simple.Compiler+import Distribution.Simple.Flag import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs , prefixRelativeInstallDirs@@ -98,36 +102,67 @@ ) import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.PackageIndex+import Distribution.Simple.Setup.Common+import Distribution.Simple.Setup.Config import Distribution.Simple.Utils+import Distribution.Utils.Path import Data.List (stripPrefix)-import System.FilePath--import System.Directory (canonicalizePath, doesDirectoryExist)+import qualified System.Directory as Directory+ ( canonicalizePath+ , doesDirectoryExist+ ) -- ----------------------------------------------------------------------------- -- Configuration information of buildable components -componentBuildDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> FilePath+componentBuildDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> SymbolicPath Pkg (Dir Build) -- 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+ (buildDir lbi </>) $+ makeRelativePathEx $+ 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 +-- | Interpret a symbolic path with respect to the working directory+-- stored in 'LocalBuildInfo'.+--+-- Use this before directly interacting with the file system.+--+-- NB: when invoking external programs (such as @GHC@), it is preferable to set+-- the working directory of the process rather than calling this function, as+-- this function will turn relative paths into absolute paths if the working+-- directory is an absolute path. This can degrade error messages, or worse,+-- break the behaviour entirely (because the program might expect certain paths+-- to be relative).+--+-- See Note [Symbolic paths] in Distribution.Utils.Path+interpretSymbolicPathLBI :: LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> FilePath+interpretSymbolicPathLBI lbi =+ interpretSymbolicPath (mbWorkDirLBI lbi)++-- | Retrieve an optional working directory from 'LocalBuildInfo'.+mbWorkDirLBI :: LocalBuildInfo -> Maybe (SymbolicPath CWD (Dir Pkg))+mbWorkDirLBI =+ flagToMaybe . setupWorkingDir . configCommonFlags . configFlags++-- | Absolute path to the current working directory.+absoluteWorkingDirLBI :: LocalBuildInfo -> IO (AbsolutePath (Dir Pkg))+absoluteWorkingDirLBI lbi = absoluteWorkingDir (mbWorkDirLBI lbi)+ -- | Perform the action on each enabled 'library' in the package -- description with the 'ComponentLocalBuildInfo'. withLibLBI@@ -251,7 +286,7 @@ | (uid, _) <- componentPackageDeps clbi , -- Test that it's internal sub_target <- allTargetsInBuildOrder' pkgDescr lbi- , componentUnitId (targetCLBI (sub_target)) == uid+ , componentUnitId (targetCLBI sub_target) == uid ] internalLibs = [ getLibDir (targetCLBI sub_target)@@ -272,7 +307,7 @@ internalLibs = map getLibDir internalCLBIs -} getLibDir sub_clbi- | inplace = componentBuildDir lbi sub_clbi+ | inplace = interpretSymbolicPathLBI lbi $ 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@@ -285,7 +320,7 @@ -- because you never have any internal libraries in this case; -- they're all external. let external_ipkgs = filter is_external (allPackages installed)- is_external ipkg = not (installedUnitId ipkg `elem` internalDeps)+ is_external ipkg = installedUnitId ipkg `notElem` 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@@ -318,9 +353,9 @@ -- '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+ exists <- Directory.doesDirectoryExist p if exists- then canonicalizePath p+ then Directory.canonicalizePath p else return p -- | Get all module names that needed to be built by GHC; i.e., all@@ -438,7 +473,7 @@ (LocalBuildInfo{compiler = comp, hostPlatform = plat}) uid = fromPathTemplate- . (InstallDirs.substPathTemplate env)+ . InstallDirs.substPathTemplate env where env = initialPathTemplateEnv
src/Distribution/Simple/PackageDescription.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE DataKinds #-}+ ----------------------------------------------------------------------------- -- |@@ -16,6 +18,8 @@ -- * Utility Parsing function , parseString+ , readAndParseFile+ , flattenDups ) where import Distribution.Compat.Prelude@@ -29,23 +33,37 @@ ( parseGenericPackageDescription , parseHookedBuildInfo )-import Distribution.Parsec.Error (showPError)+import Distribution.Parsec.Error (showPErrorWithSource)+import Distribution.Parsec.Source import Distribution.Parsec.Warning ( PWarnType (PWTExperimental) , PWarning (..)- , showPWarning+ , PWarningWithSource (..)+ , showPWarningWithSource ) import Distribution.Simple.Errors import Distribution.Simple.Utils (dieWithException, equating, warn)-import Distribution.Verbosity (Verbosity, normal)+import Distribution.Utils.Path+import Distribution.Verbosity (Verbosity, VerbosityLevel (..), verbosityLevel) import System.Directory (doesFileExist) import Text.Printf (printf) -readGenericPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription-readGenericPackageDescription = readAndParseFile parseGenericPackageDescription+readGenericPackageDescription+ :: Verbosity+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -> SymbolicPath Pkg File+ -> IO GenericPackageDescription+readGenericPackageDescription =+ readAndParseFile parseGenericPackageDescription -readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo-readHookedBuildInfo = readAndParseFile parseHookedBuildInfo+readHookedBuildInfo+ :: Verbosity+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -- ^ working directory+ -> SymbolicPath Pkg File+ -> IO HookedBuildInfo+readHookedBuildInfo =+ readAndParseFile parseHookedBuildInfo -- | Helper combinator to do parsing plumbing for files. --@@ -54,23 +72,27 @@ -- -- Argument order is chosen to encourage partial application. readAndParseFile- :: (BS.ByteString -> ParseResult a)+ :: (BS.ByteString -> ParseResult CabalFileSource a) -- ^ File contents to final value parser -> Verbosity -- ^ Verbosity level- -> FilePath+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -- ^ Working directory+ -> SymbolicPath Pkg File -- ^ File to read -> IO a-readAndParseFile parser verbosity fpath = do- exists <- doesFileExist fpath+readAndParseFile parser verbosity mbWorkDir fpath = do+ let ipath = interpretSymbolicPath mbWorkDir fpath+ upath = getSymbolicPath fpath+ exists <- doesFileExist ipath unless exists $ dieWithException verbosity $- ErrorParsingFileDoesntExist fpath- bs <- BS.readFile fpath- parseString parser verbosity fpath bs+ ErrorParsingFileDoesntExist upath+ bs <- BS.readFile ipath+ parseString parser verbosity upath bs parseString- :: (BS.ByteString -> ParseResult a)+ :: (BS.ByteString -> ParseResult CabalFileSource a) -- ^ File contents to final value parser -> Verbosity -- ^ Verbosity level@@ -79,38 +101,41 @@ -> BS.ByteString -> IO a parseString parser verbosity name bs = do- let (warnings, result) = runParseResult (parser bs)- traverse_ (warn verbosity . showPWarning name) (flattenDups verbosity warnings)+ let (warnings, result) = runParseResult $ withSource (PCabalFile (name, bs)) (parser bs)+ traverse_ (warn verbosity . showPWarningWithSource . fmap renderCabalFileSource) (flattenDups verbosity warnings) case result of Right x -> return x Left (_, errors) -> do- traverse_ (warn verbosity . showPError name) errors+ traverse_ (warn verbosity . showPErrorWithSource . fmap renderCabalFileSource) errors dieWithException verbosity $ FailedParsing name -- | Collapse duplicate experimental feature warnings into single warning, with -- a count of further sites-flattenDups :: Verbosity -> [PWarning] -> [PWarning]+flattenDups :: Verbosity -> [PWarningWithSource src] -> [PWarningWithSource src] flattenDups verbosity ws- | verbosity <= normal = rest ++ experimentals+ | verbosityLevel verbosity <= Normal = rest ++ experimentals | otherwise = ws -- show all instances where- (exps, rest) = partition (\(PWarning w _ _) -> w == PWTExperimental) ws+ (exps, rest) = partition (\(PWarningWithSource _ (PWarning w _ _)) -> w == PWTExperimental) ws experimentals = concatMap flatCount- . groupBy (equating warningStr)- . sortBy (comparing warningStr)+ . groupBy (equating (warningStr . pwarning))+ . sortBy (comparing (warningStr . pwarning)) $ exps warningStr (PWarning _ _ w) = w -- flatten if we have 3 or more examples- flatCount :: [PWarning] -> [PWarning]+ flatCount :: [PWarningWithSource src] -> [PWarningWithSource src] 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))+ flatCount (PWarningWithSource source (PWarning t pos w) : xs) =+ [ PWarningWithSource+ source+ ( PWarning+ t+ pos+ (w <> printf " (and %d more occurrences)" (length xs))+ ) ]
src/Distribution/Simple/PackageIndex.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -68,6 +67,7 @@ , lookupSourcePackageId , lookupPackageId , lookupPackageName+ , lookupInternalPackageName , lookupDependency , lookupInternalDependency @@ -93,6 +93,10 @@ , dependencyCycles , dependencyGraph , moduleNameIndex++ -- ** Filters on lookup results+ , eligibleDependencies+ , matchingDependencies ) where import qualified Data.Map.Strict as Map@@ -142,7 +146,7 @@ -- preserved. See #1463 for discussion. packageIdIndex :: !(Map (PackageName, LibraryName) (Map Version [a])) }- deriving (Eq, Generic, Show, Read, Typeable)+ deriving (Eq, Generic, Show, Read) instance Binary a => Binary (PackageIndex a) instance Structured a => Structured (PackageIndex a)@@ -180,7 +184,7 @@ all (\g -> length g == 1) (groupBy (equating installedUnitId) pinsts')- , pinst <- assert pinstsOk $ pinsts'+ , pinst <- assert pinstsOk pinsts' , let pinstOk = packageName pinst == pname && packageVersion pinst == pver@@ -365,8 +369,8 @@ -- | Removes all packages satisfying this dependency from the index. -- deleteDependency :: Dependency -> PackageIndex -> PackageIndex-deleteDependency (Dependency name verstionRange) =- delete' name (\pkg -> packageVersion pkg `withinRange` verstionRange)+deleteDependency (Dependency name versionRange) =+ delete' name (\pkg -> packageVersion pkg `withinRange` versionRange) -} --@@ -455,9 +459,7 @@ -- 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 -> []- Just pkgs -> pkgs -- in preference order+ Just pvers -> fromMaybe [] (Map.lookup (packageVersion pkgid) pvers) -- in preference order -- | Convenient alias of 'lookupSourcePackageId', but assuming only -- one package per package ID.@@ -474,10 +476,19 @@ -> [(Version, [a])] lookupPackageName index name = -- Do not match internal libraries- case Map.lookup (name, LMainLibName) (packageIdIndex index) of- Nothing -> []- Just pvers -> Map.toList pvers+ lookupInternalPackageName index name LMainLibName +-- | Does a lookup by source package name and library name.+--+-- Also looks up internal packages.+lookupInternalPackageName+ :: PackageIndex a+ -> PackageName+ -> LibraryName+ -> [(Version, [a])]+lookupInternalPackageName index name library =+ maybe [] Map.toList (Map.lookup (name, library) (packageIdIndex index))+ -- | Does a lookup by source package name and a range of versions. -- -- We get back any number of versions of the specified package name, all@@ -509,25 +520,48 @@ -> 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')- ]+ matchingDependencies versionRange $+ lookupInternalPackageName index name libn++-- | Filter a set of installed packages to ones eligible as dependencies.+--+-- 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.+--+-- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty.+eligibleDependencies+ :: [(Version, [IPI.InstalledPackageInfo])]+ -> [(Version, [IPI.InstalledPackageInfo])]+eligibleDependencies versions =+ [ (ver, pkgs')+ | (ver, pkgs) <- versions+ , 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) +-- | Get eligible dependencies from a list of versions. --+-- This can be used to filter the output of 'lookupPackageName' or+-- 'lookupInternalPackageName'.+--+-- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty.+matchingDependencies+ :: VersionRange+ -> [(Version, [IPI.InstalledPackageInfo])]+ -> [(Version, [IPI.InstalledPackageInfo])]+matchingDependencies versionRange versions =+ let eligibleVersions = eligibleDependencies versions+ in [ (ver, pkgs)+ | (ver, pkgs) <- eligibleVersions+ , ver `withinRange` versionRange+ ] +--+ -- * Case insensitive name lookups --@@ -629,7 +663,7 @@ :: InstalledPackageIndex -> [UnitId] -> Either- (InstalledPackageIndex)+ InstalledPackageIndex [(IPI.InstalledPackageInfo, [UnitId])] dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of (completed, []) -> Left completed@@ -696,7 +730,7 @@ graph = Array.listArray bounds- [ [v | Just v <- map id_to_vertex (installedDepends pkg)]+ [ mapMaybe id_to_vertex (installedDepends pkg) | pkg <- pkgs ]
src/Distribution/Simple/PreProcess.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -22,6 +23,7 @@ module Distribution.Simple.PreProcess ( preprocessComponent , preprocessExtras+ , preprocessFile , knownSuffixHandlers , ppSuffixes , PPSuffixHandler@@ -33,7 +35,6 @@ , runSimplePreProcessor , ppCpp , ppCpp'- , ppGreenCard , ppC2hs , ppHsc2hs , ppHappy@@ -51,7 +52,6 @@ import Distribution.Backpack.DescribeUnitId 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 Distribution.Simple.BuildPaths@@ -71,16 +71,14 @@ import Distribution.Utils.Path import Distribution.Verbosity import Distribution.Version+ import System.Directory (doesDirectoryExist, doesFileExist) import System.FilePath- ( dropExtensions- , normalise+ ( normalise , replaceExtension , splitExtension , takeDirectory , takeExtensions- , (<.>)- , (</>) ) import System.Info (arch, os) @@ -89,7 +87,7 @@ -- between modules. unsorted :: Verbosity- -> [FilePath]+ -> [path] -> [ModuleName] -> IO [ModuleName] unsorted _ _ ms = pure ms@@ -98,7 +96,10 @@ -- preprocessor: just takes the path to the build directory and uses -- this to search for C sources with names that match the -- preprocessor's output name format.-type PreProcessorExtras = FilePath -> IO [FilePath]+type PreProcessorExtras =+ Maybe (SymbolicPath CWD (Dir Pkg))+ -> SymbolicPath Pkg (Dir Source)+ -> IO [RelativePath Source File] mkSimplePreProcessor :: (FilePath -> FilePath -> Verbosity -> IO ())@@ -157,58 +158,51 @@ case comp of (CLib lib@Library{libBuildInfo = bi}) -> do let dirs =- map getSymbolicPath (hsSourceDirs bi)+ hsSourceDirs bi ++ [autogenComponentModulesDir lbi clbi, autogenPackageModulesDir lbi] let hndlrs = localHandlers bi mods <- orderingFromHandlers verbosity dirs hndlrs (allLibModules lib clbi)- for_ (map ModuleName.toFilePath mods) $+ for_ (map moduleNameSymbolicPath 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"+ (CFLib flib@ForeignLib{foreignLibBuildInfo = bi}) -> do+ let flibDir = flibBuildDir lbi flib dirs =- map getSymbolicPath (hsSourceDirs bi)+ hsSourceDirs bi ++ [ autogenComponentModulesDir lbi clbi , autogenPackageModulesDir lbi ] let hndlrs = localHandlers bi mods <- orderingFromHandlers verbosity dirs hndlrs (foreignLibModules flib)- for_ (map ModuleName.toFilePath mods) $+ for_ (map moduleNameSymbolicPath mods) $ pre dirs flibDir hndlrs- (CExe exe@Executable{buildInfo = bi, exeName = nm}) -> do- let nm' = unUnqualComponentName nm- let exeDir = buildDir lbi </> nm' </> nm' ++ "-tmp"+ (CExe exe@Executable{buildInfo = bi}) -> do+ let exeDir = exeBuildDir lbi exe dirs =- map getSymbolicPath (hsSourceDirs bi)+ hsSourceDirs bi ++ [ autogenComponentModulesDir lbi clbi , autogenPackageModulesDir lbi ] let hndlrs = localHandlers bi mods <- orderingFromHandlers verbosity dirs hndlrs (otherModules bi)- for_ (map ModuleName.toFilePath mods) $+ for_ (map moduleNameSymbolicPath 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+ pre (hsSourceDirs bi) exeDir (localHandlers bi) $+ dropExtensionsSymbolicPath (modulePath exe)+ CTest test@TestSuite{} -> do+ let testDir = testBuildDir lbi test case testInterface test of TestSuiteExeV10 _ f ->- preProcessTest test f $ buildDir lbi </> nm' </> nm' ++ "-tmp"+ preProcessTest test f testDir TestSuiteLibV09 _ _ -> do- let testDir =- buildDir lbi- </> stubName test- </> stubName test- ++ "-tmp"- writeSimpleTestStub test testDir- preProcessTest test (stubFilePath test) testDir+ writeSimpleTestStub test (i testDir)+ preProcessTest test (makeRelativePathEx $ stubFilePath test) testDir TestSuiteUnsupported tt -> dieWithException verbosity $ NoSupportForPreProcessingTest tt- CBench bm@Benchmark{benchmarkName = nm} -> do- let nm' = unUnqualComponentName nm+ CBench bm@Benchmark{} -> do+ let benchDir = benchmarkBuildDir lbi bm case benchmarkInterface bm of BenchmarkExeV10 _ f ->- preProcessBench bm f $ buildDir lbi </> nm' </> nm' ++ "-tmp"+ preProcessBench bm f benchDir BenchmarkUnsupported tt -> dieWithException verbosity $ NoSupportForPreProcessingBenchmark tt where@@ -217,8 +211,10 @@ builtinCSuffixes = map Suffix cSourceExtensions builtinSuffixes = builtinHaskellSuffixes ++ builtinCSuffixes localHandlers bi = [(ext, h bi lbi clbi) | (ext, h) <- handlers]+ mbWorkDir = mbWorkDirLBI lbi+ i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path pre dirs dir lhndlrs fp =- preprocessFile (map unsafeMakeSymbolicPath dirs) dir isSrcDist fp verbosity builtinSuffixes lhndlrs True+ preprocessFile mbWorkDir dirs dir isSrcDist fp verbosity builtinSuffixes lhndlrs True preProcessTest test = preProcessComponent (testBuildInfo test)@@ -231,36 +227,37 @@ preProcessComponent :: BuildInfo -> [ModuleName]- -> FilePath- -> FilePath+ -> RelativePath Source File+ -> SymbolicPath Pkg (Dir Build) -> IO ()- preProcessComponent bi modules exePath dir = do+ preProcessComponent bi modules exePath outputDir = do let biHandlers = localHandlers bi sourceDirs =- map getSymbolicPath (hsSourceDirs bi)+ hsSourceDirs bi ++ [ autogenComponentModulesDir lbi clbi , autogenPackageModulesDir lbi ] sequence_ [ preprocessFile- (map unsafeMakeSymbolicPath sourceDirs)- dir+ mbWorkDir+ sourceDirs+ outputDir isSrcDist- (ModuleName.toFilePath modu)+ (moduleNameSymbolicPath 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)+ -- 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+ mbWorkDir+ (coerceSymbolicPath outputDir : hsSourceDirs bi)+ outputDir isSrcDist- (dropExtensions $ exePath)+ (dropExtensionsSymbolicPath exePath) verbosity builtinSuffixes biHandlers@@ -273,13 +270,15 @@ -- | Find the first extension of the file that exists, and preprocess it -- if required. preprocessFile- :: [SymbolicPath PackageDir SourceDir]+ :: Maybe (SymbolicPath CWD (Dir Pkg))+ -- ^ package directory location+ -> [SymbolicPath Pkg (Dir Source)] -- ^ source directories- -> FilePath+ -> SymbolicPath Pkg (Dir Build) -- ^ build directory -> Bool -- ^ preprocess for sdist- -> FilePath+ -> RelativePath Source File -- ^ module file name -> Verbosity -- ^ verbosity@@ -290,32 +289,35 @@ -> Bool -- ^ fail on missing file -> IO ()-preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers failOnMissing = do+preprocessFile mbWorkDir 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+ psrcFiles <- findFileCwdWithExtension' mbWorkDir (map fst handlers) 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++ -- Note [Dodgy build dirs for preprocessors]+ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ -- 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+ bsrcFiles <- findFileCwdWithExtension mbWorkDir builtinSuffixes (buildAsSrcLoc : searchLoc) baseFile case (bsrcFiles, failOnMissing) of (Nothing, True) -> dieWithException verbosity $ CantFindSourceForPreProcessFile $ "can't find source for "- ++ baseFile+ ++ getSymbolicPath 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+ let (srcStem, ext) = splitExtension $ getSymbolicPath psrcRelFile psrcFile = psrcLoc </> psrcRelFile pp = fromMaybe@@ -333,20 +335,22 @@ 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+ ppsrcFiles <- findFileCwdWithExtension mbWorkDir builtinSuffixes [buildAsSrcLoc] baseFile recomp <- case ppsrcFiles of Nothing -> return True Just ppsrcFile ->- psrcFile `moreRecentFile` ppsrcFile+ i psrcFile `moreRecentFile` i ppsrcFile when recomp $ do- let destDir = buildLoc </> dirName srcStem+ let destDir = i buildLoc </> takeDirectory srcStem createDirectoryIfMissingVerbose verbosity True destDir runPreProcessorWithHsBootHack pp- (psrcLoc, psrcRelFile)+ (psrcLoc, getSymbolicPath psrcRelFile) (buildLoc, srcStem <.> "hs") where- dirName = takeDirectory+ i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path+ buildAsSrcLoc :: SymbolicPath Pkg (Dir Source)+ buildAsSrcLoc = coerceSymbolicPath buildLoc -- FIXME: This is a somewhat nasty hack. GHC requires that hs-boot files -- be in the same place as the hs files, so if we put the hs file in dist/@@ -357,20 +361,25 @@ pp (inBaseDir, inRelativeFile) (outBaseDir, outRelativeFile) = do+ -- Preprocessors are expected to take into account the working+ -- directory, e.g. using runProgramCwd with a working directory+ -- computed with mbWorkDirLBI.+ -- Hence the use of 'getSymbolicPath' here. runPreProcessor pp- (inBaseDir, inRelativeFile)- (outBaseDir, outRelativeFile)+ (getSymbolicPath inBaseDir, inRelativeFile)+ (getSymbolicPath outBaseDir, outRelativeFile) verbosity - exists <- doesFileExist inBoot- when exists $ copyFileVerbose verbosity inBoot outBoot- where+ -- Here we interact directly with the file system, so we must+ -- interpret symbolic paths with respect to the working directory.+ let+ inFile = normalise (i inBaseDir </> inRelativeFile)+ outFile = normalise (i outBaseDir </> outRelativeFile) inBoot = replaceExtension inFile "hs-boot" outBoot = replaceExtension outFile "hs-boot"-- inFile = normalise (inBaseDir </> inRelativeFile)- outFile = normalise (outBaseDir </> outRelativeFile)+ exists <- doesFileExist inBoot+ when exists $ copyFileVerbose verbosity inBoot outBoot -- ------------------------------------------------------------ @@ -378,19 +387,6 @@ -- ------------------------------------------------------------ -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])- }- -- This one is useful for preprocessors that can't handle literate source. -- We also need a way to chain preprocessors. ppUnlit :: PreProcessor@@ -435,7 +431,7 @@ program anyVersion (withPrograms lbi)- runProgram verbosity prog $+ runProgramCwd verbosity (mbWorkDirLBI lbi) prog $ ["-E", "-cpp"] -- This is a bit of an ugly hack. We're going to -- unlit the file ourselves later on if appropriate,@@ -443,10 +439,14 @@ -- 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)]+ ++ ["-optP-include", "-optP" ++ u (autogenComponentModulesDir lbi clbi </> makeRelativePathEx cppHeaderName)] ++ ["-o", outFile, inFile] ++ extraArgs }+ where+ -- See Note [Symbolic paths] in Distribution.Utils.Path+ u :: SymbolicPath Pkg to -> FilePath+ u = interpretSymbolicPathCWD ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor ppCpphs extraArgs _bi lbi clbi =@@ -460,17 +460,18 @@ cpphsProgram anyVersion (withPrograms lbi)- runProgram verbosity cpphsProg $+ runProgramCwd verbosity (mbWorkDirLBI lbi) cpphsProg $ ("-O" ++ outFile) : inFile : "--noline" : "--strip"- : ( if cpphsVersion >= mkVersion [1, 6]- then ["--include=" ++ (autogenComponentModulesDir lbi clbi </> cppHeaderName)]- else []- )+ : ["--include=" ++ u (autogenComponentModulesDir lbi clbi </> makeRelativePathEx cppHeaderName) | cpphsVersion >= mkVersion [1, 6]] ++ extraArgs }+ where+ -- See Note [Symbolic paths] in Distribution.Utils.Path+ u :: SymbolicPath Pkg to -> FilePath+ u = interpretSymbolicPathCWD ppHsc2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor ppHsc2hs bi lbi clbi =@@ -485,6 +486,7 @@ hsc2hsProgram anyVersion (withPrograms lbi)+ let runHsc2hs = runProgramCwd verbosity mbWorkDir hsc2hsProg -- See Trac #13896 and https://github.com/haskell/cabal/issues/3122. let isCross = hostPlatform lbi /= buildPlatform prependCrossFlags = if isCross then ("-x" :) else id@@ -495,113 +497,122 @@ withResponseFile verbosity defaultTempFileOptions- (takeDirectory outFile) "hsc2hs-response.txt" Nothing pureArgs ( \responseFileName ->- runProgram verbosity hsc2hsProg (prependCrossFlags ["@" ++ responseFileName])+ runHsc2hs (prependCrossFlags ["@" ++ responseFileName]) )- else runProgram verbosity hsc2hsProg (prependCrossFlags pureArgs)+ else runHsc2hs (prependCrossFlags pureArgs) } where+ -- See Note [Symbolic paths] in Distribution.Utils.Path+ u :: SymbolicPathX allowAbs Pkg to -> FilePath+ u = interpretSymbolicPathCWD+ mbWorkDir = mbWorkDirLBI lbi+ -- 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 <-- if withFullyStaticExe lbi- then PD.extraLibDirsStatic bi- else PD.extraLibDirs bi- ]- ++ [ "--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]- ++ 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- ]- ++ Installed.ldOptions pkg- ]+ cflags+ ++ ldflags ++ preccldFlags ++ hsc2hsOptions bi ++ postccldFlags ++ ["-o", outFile, inFile] where+ ldflags =+ map ("--lflag=" ++) $+ ordNub $+ concat+ [ programDefaultArgs gccProg ++ programOverrideArgs gccProg+ , osxFrameworkDirs+ , [ arg+ | isOSX+ , opt <- map getSymbolicPath (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.++ -- Options from the current package:+ [ "-L" ++ u opt+ | opt <-+ if withFullyStaticExe lbi+ then PD.extraLibDirsStatic bi+ else PD.extraLibDirs bi+ ]+ , [ "-Wl,-R," ++ u opt+ | isELF+ , opt <-+ if withFullyStaticExe lbi+ then PD.extraLibDirsStatic bi+ else PD.extraLibDirs bi+ ]+ , ["-l" ++ opt | opt <- PD.extraLibs bi]+ , PD.ldOptions bi+ , -- Options from dependent packages+ [ 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+ ]+ ++ Installed.ldOptions pkg+ ]+ ]++ cflags =+ map ("--cflag=" ++) $+ ordNub $+ concat+ [ programDefaultArgs gccProg ++ programOverrideArgs gccProg+ , osxFrameworkDirs+ , platformDefines lbi+ , -- Options from the current package:+ ["-I" ++ u dir | dir <- PD.includeDirs bi]+ , [ "-I" ++ u (buildDir lbi </> unsafeCoerceSymbolicPath relDir)+ | relDir <- mapMaybe symbolicPathRelative_maybe $ PD.includeDirs 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!+ PD.ccOptions bi ++ PD.cppOptions bi+ ,+ [ "-I" ++ u (autogenComponentModulesDir lbi clbi)+ , "-I" ++ u (autogenPackageModulesDir lbi)+ , "-include"+ , u $ autogenComponentModulesDir lbi clbi </> makeRelativePathEx cppHeaderName+ ]+ , -- Options from dependent packages+ [ opt+ | pkg <- pkgs+ , opt <-+ ["-I" ++ opt | opt <- Installed.includeDirs pkg]+ ++ Installed.ccOptions pkg+ ]+ ]++ osxFrameworkDirs =+ [ "-F" ++ opt+ | isOSX+ , opt <- ordNub (concatMap Installed.frameworkDirs pkgs)+ ]+ -- hsc2hs flag parsing was wrong -- (see -- https://github.com/haskell/hsc2hs/issues/35) -- so we need to put -- --cc/--ld *after* hsc2hsOptions,@@ -643,9 +654,10 @@ _ -> error "No (or multiple) ghc rts package is registered!!" ppHsc2hsExtras :: PreProcessorExtras-ppHsc2hsExtras buildBaseDir =- filter ("_hsc.c" `isSuffixOf`)- `fmap` getDirectoryContentsRecursive buildBaseDir+ppHsc2hsExtras mbWorkDir buildBaseDir = do+ fs <- getDirectoryContentsRecursive $ interpretSymbolicPath mbWorkDir buildBaseDir+ let hscCFiles = filter ("_hsc.c" `isSuffixOf`) fs+ return $ map makeRelativePathEx hscCFiles ppC2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor ppC2hs bi lbi clbi =@@ -663,11 +675,11 @@ (orLaterVersion (mkVersion [0, 15])) (withPrograms lbi) (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi)- runProgram verbosity c2hsProg $+ runProgramCwd verbosity mbWorkDir c2hsProg $ -- Options from the current package: ["--cpp=" ++ programPath gccProg, "--cppopts=-E"] ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi]- ++ ["--cppopts=-include" ++ (autogenComponentModulesDir lbi clbi </> cppHeaderName)]+ ++ ["--cppopts=-include" ++ u (autogenComponentModulesDir lbi clbi </> makeRelativePathEx cppHeaderName)] ++ ["--include=" ++ outBaseDir] -- Options from dependent packages ++ [ "--cppopts=" ++ opt@@ -698,11 +710,17 @@ } where pkgs = PackageIndex.topologicalOrder (installedPkgs lbi)+ mbWorkDir = mbWorkDirLBI lbi+ -- See Note [Symbolic paths] in Distribution.Utils.Path+ u :: SymbolicPath Pkg to -> FilePath+ u = interpretSymbolicPathCWD ppC2hsExtras :: PreProcessorExtras-ppC2hsExtras d =- filter (\p -> takeExtensions p == ".chs.c")- `fmap` getDirectoryContentsRecursive d+ppC2hsExtras mbWorkDir buildBaseDir = do+ fs <- getDirectoryContentsRecursive $ interpretSymbolicPath mbWorkDir buildBaseDir+ return $+ map makeRelativePathEx $+ filter (\p -> takeExtensions p == ".chs.c") fs -- TODO: perhaps use this with hsc2hs too -- TODO: remove cc-options from cpphs for cabal-version: >= 1.10@@ -713,7 +731,7 @@ getCppOptions bi lbi = platformDefines lbi ++ cppOptions bi- ++ ["-I" ++ dir | dir <- PD.includeDirs bi]+ ++ ["-I" ++ getSymbolicPath dir | dir <- PD.includeDirs bi] ++ [opt | opt@('-' : c : _) <- PD.ccOptions bi ++ PD.cxxOptions bi, c `elem` "DIU"] platformDefines :: LocalBuildInfo -> [String]@@ -732,10 +750,6 @@ ++ ["-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@@ -780,7 +794,7 @@ Android -> ["android"] Ghcjs -> ["ghcjs"] Wasi -> ["wasi"]- Hurd -> ["hurd"]+ Hurd -> ["gnu"] Haiku -> ["haiku"] OtherOS _ -> [] archStr = case hostArch of@@ -833,8 +847,9 @@ { platformIndependent = False , ppOrdering = unsorted , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->- runDbProgram+ runDbProgramCwd verbosity+ (mbWorkDirLBI lbi) prog (withPrograms lbi) (args ++ ["-o", outFile, inFile])@@ -844,11 +859,10 @@ ppSuffixes :: [PPSuffixHandler] -> [Suffix] ppSuffixes = map fst --- | Standard preprocessors: GreenCard, c2hs, hsc2hs, happy, alex and cpphs.+-- | Standard preprocessors: c2hs, hsc2hs, happy, alex and cpphs. knownSuffixHandlers :: [PPSuffixHandler] knownSuffixHandlers =- [ (Suffix "gc", ppGreenCard)- , (Suffix "chs", ppC2hs)+ [ (Suffix "chs", ppC2hs) , (Suffix "hsc", ppHsc2hs) , (Suffix "x", ppAlex) , (Suffix "y", ppHappy)@@ -866,41 +880,37 @@ :: Verbosity -> Component -> LocalBuildInfo- -> IO [FilePath]+ -> IO [SymbolicPath Pkg File] preprocessExtras verbosity comp lbi = case comp of CLib _ -> pp $ buildDir lbi- (CExe Executable{exeName = nm}) -> do- let nm' = unUnqualComponentName nm- pp $ buildDir lbi </> nm' </> nm' ++ "-tmp"- (CFLib ForeignLib{foreignLibName = nm}) -> do- let nm' = unUnqualComponentName nm- pp $ buildDir lbi </> nm' </> nm' ++ "-tmp"- CTest test -> do- let nm' = unUnqualComponentName $ testName test+ (CExe exe@Executable{}) -> pp $ exeBuildDir lbi exe+ (CFLib flib@ForeignLib{}) -> pp $ flibBuildDir lbi flib+ CTest test -> case testInterface test of- TestSuiteExeV10 _ _ ->- pp $ buildDir lbi </> nm' </> nm' ++ "-tmp"- TestSuiteLibV09 _ _ ->- pp $ buildDir lbi </> stubName test </> stubName test ++ "-tmp" TestSuiteUnsupported tt -> dieWithException verbosity $ NoSupportPreProcessingTestExtras tt- CBench bm -> do- let nm' = unUnqualComponentName $ benchmarkName bm+ _ -> pp $ testBuildDir lbi test+ CBench bm -> case benchmarkInterface bm of- BenchmarkExeV10 _ _ ->- pp $ buildDir lbi </> nm' </> nm' ++ "-tmp" BenchmarkUnsupported tt -> dieWithException verbosity $ NoSupportPreProcessingBenchmarkExtras tt+ _ -> pp $ benchmarkBuildDir lbi bm where- pp :: FilePath -> IO [FilePath]- pp dir = do- b <- doesDirectoryExist dir+ pp :: SymbolicPath Pkg (Dir Build) -> IO [SymbolicPath Pkg File]+ pp builddir = do+ -- Use the build dir as a source dir.+ let dir :: SymbolicPath Pkg (Dir Source)+ dir = coerceSymbolicPath builddir+ mbWorkDir = mbWorkDirLBI lbi+ b <- doesDirectoryExist (interpretSymbolicPathLBI lbi dir) if b- then- (map (dir </>) . filter not_sub . concat)- <$> for- knownExtrasHandlers- (withLexicalCallStack (\f -> f dir))+ then do+ xs <- for knownExtrasHandlers $ withLexicalCallStack $ \f -> f mbWorkDir dir+ let not_subs =+ map (dir </>) $+ filter (not_sub . getSymbolicPath) $+ concat xs+ return not_subs else pure [] -- TODO: This is a terrible hack to work around #3545 while we don't -- reorganize the directory layout. Basically, for the main
src/Distribution/Simple/PreProcess/Types.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -18,6 +19,7 @@ module Distribution.Simple.PreProcess.Types ( Suffix (..) , PreProcessor (..)+ , PreProcessCommand , builtinHaskellSuffixes , builtinHaskellBootSuffixes )@@ -28,6 +30,7 @@ import Distribution.ModuleName (ModuleName) import Distribution.Pretty+import Distribution.Utils.Path import Distribution.Verbosity import qualified Text.PrettyPrint as Disp @@ -41,11 +44,12 @@ -- > ppTestHandler = -- > PreProcessor { -- > platformIndependent = True,+-- > ppOrdering = \_ _ -> return, -- > 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+-- > return () -- -- 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@@ -78,7 +82,7 @@ ppOrdering :: Verbosity- -> [FilePath] -- Source directories+ -> [SymbolicPath Pkg (Dir Source)] -- Source directories -> [ModuleName] -- Module names -> IO [ModuleName] -- Sorted modules @@ -88,11 +92,21 @@ -- -- @since 3.8.1.0 , 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+ :: PreProcessCommand }++-- | A command to run a given preprocessor on a single source file.+--+-- The input and output file paths are passed in as arguments, as it is+-- the build system and not the package author which chooses the location of+-- source files.+type PreProcessCommand =+ (FilePath, FilePath)+ -- ^ Location of the source file relative to a base dir+ -> (FilePath, FilePath)+ -- ^ Output file name, relative to an output base dir+ -> Verbosity+ -> IO () -- Should exit if the preprocessor fails -- | A suffix (or file extension). --
src/Distribution/Simple/Program.hs view
@@ -1,3 +1,11 @@+{- FUTUREWORK:+ -+ - Currently the logic in this module is not tested.+ -+ - Ideally, a set of unit tests that check whether certain+ - flags trigger recompilation should be added.+ - -}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -51,6 +59,7 @@ , ProgArg , ProgramLocation (..) , runProgram+ , runProgramCwd , getProgramOutput , suppressOverrideArgs @@ -93,17 +102,19 @@ , requireProgramVersion , needProgram , runDbProgram+ , runDbProgramCwd , getDbProgramOutput+ , getDbProgramOutputCwd -- * Programs that Cabal knows about , ghcProgram , ghcPkgProgram , ghcjsProgram , ghcjsPkgProgram- , hmakeProgram , jhcProgram , uhcProgram , gccProgram+ , gppProgram , arProgram , stripProgram , happyProgram@@ -114,7 +125,6 @@ , hscolourProgram , doctestProgram , haddockProgram- , greencardProgram , ldProgram , tarProgram , cppProgram@@ -132,6 +142,7 @@ import Distribution.Simple.Program.Run import Distribution.Simple.Program.Types import Distribution.Simple.Utils+import Distribution.Utils.Path import Distribution.Verbosity -- | Runs the given configured program.@@ -146,6 +157,20 @@ runProgram verbosity prog args = runProgramInvocation verbosity (programInvocation prog args) +-- | Runs the given configured program.+runProgramCwd+ :: Verbosity+ -- ^ Verbosity+ -> Maybe (SymbolicPath CWD (Dir to))+ -- ^ Working directory+ -> ConfiguredProgram+ -- ^ The program to run+ -> [ProgArg]+ -- ^ Any /extra/ arguments to add+ -> IO ()+runProgramCwd verbosity mbWorkDir prog args =+ runProgramInvocation verbosity (programInvocationCwd mbWorkDir prog args)+ -- | Runs the given configured program and gets the output. getProgramOutput :: Verbosity@@ -169,11 +194,27 @@ -> [ProgArg] -- ^ Any /extra/ arguments to add -> IO ()-runDbProgram verbosity prog programDb args =+runDbProgram verbosity prog progDb args =+ runDbProgramCwd verbosity Nothing prog progDb args++-- | Looks up the given program in the program database and runs it.+runDbProgramCwd+ :: Verbosity+ -- ^ verbosity+ -> Maybe (SymbolicPath CWD (Dir to))+ -- ^ working directory+ -> Program+ -- ^ The program to run+ -> ProgramDb+ -- ^ look up the program here+ -> [ProgArg]+ -- ^ Any /extra/ arguments to add+ -> IO ()+runDbProgramCwd verbosity mbWorkDir prog programDb args = case lookupProgram prog programDb of Nothing -> dieWithException verbosity $ ProgramNotFound (programName prog)- Just configuredProg -> runProgram verbosity configuredProg args+ Just configuredProg -> runProgramCwd verbosity mbWorkDir configuredProg args -- | Looks up the given program in the program database and runs it. getDbProgramOutput@@ -186,7 +227,25 @@ -> [ProgArg] -- ^ Any /extra/ arguments to add -> IO String-getDbProgramOutput verbosity prog programDb args =+getDbProgramOutput verb prog progDb args =+ getDbProgramOutputCwd verb Nothing prog progDb args++-- | Looks up the given program in the program database and runs it.+getDbProgramOutputCwd+ :: Verbosity+ -- ^ verbosity+ -> Maybe (SymbolicPath CWD (Dir to))+ -- ^ working directory+ -> Program+ -- ^ The program to run+ -> ProgramDb+ -- ^ look up the program here+ -> [ProgArg]+ -- ^ Any /extra/ arguments to add+ -> IO String+getDbProgramOutputCwd verbosity mbWorkDir prog programDb args = case lookupProgram prog programDb of Nothing -> dieWithException verbosity $ ProgramNotFound (programName prog)- Just configuredProg -> getProgramOutput verbosity configuredProg args+ Just configuredProg ->+ getProgramInvocationOutput verbosity $+ programInvocationCwd mbWorkDir configuredProg args
src/Distribution/Simple/Program/Ar.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-}@@ -25,10 +26,7 @@ import qualified Data.ByteString.Char8 as BS8 import Distribution.Compat.CopyFile (filesEqual) import Distribution.Simple.Compiler (arDashLSupported, arResponseFilesSupported)-import Distribution.Simple.Flag- ( fromFlagOrDefault- )-import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..))+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..), mbWorkDirLBI) import Distribution.Simple.Program ( ProgramInvocation , arProgram@@ -39,29 +37,32 @@ ) import Distribution.Simple.Program.Run ( multiStageProgramInvocation- , programInvocation+ , programInvocationCwd , runProgramInvocation )+import Distribution.Simple.Setup.Common import Distribution.Simple.Setup.Config ( configUseResponseFiles ) import Distribution.Simple.Utils ( defaultTempFileOptions , dieWithLocation'- , withTempDirectory+ , withTempDirectoryCwd ) import Distribution.System ( Arch (..) , OS (..) , Platform (..) )+import Distribution.Utils.Path import Distribution.Verbosity ( Verbosity- , deafening- , verbose+ , VerbosityLevel (..)+ , verbosityLevel )+ import System.Directory (doesFileExist, renameFile)-import System.FilePath (splitFileName, (</>))+import System.FilePath (splitFileName) import System.IO ( Handle , IOMode (ReadWriteMode)@@ -75,14 +76,21 @@ createArLibArchive :: Verbosity -> LocalBuildInfo- -> FilePath- -> [FilePath]+ -> SymbolicPath Pkg File+ -> [SymbolicPath Pkg File] -> IO () createArLibArchive verbosity lbi targetPath files = do- (ar, _) <- requireProgram verbosity arProgram progDb+ (arProg, _) <- requireProgram verbosity arProgram progDb - let (targetDir, targetName) = splitFileName targetPath- withTempDirectory verbosity targetDir "objs" $ \tmpDir -> do+ let (targetDir0, targetName0) = splitFileName $ getSymbolicPath targetPath+ targetDir = makeSymbolicPath targetDir0+ targetName = makeRelativePathEx targetName0+ mbWorkDir = mbWorkDirLBI lbi+ -- See Note [Symbolic paths] in Distribution.Utils.Path+ i = interpretSymbolicPath mbWorkDir+ u :: SymbolicPath Pkg to -> FilePath+ u = interpretSymbolicPathCWD+ withTempDirectoryCwd mbWorkDir targetDir "objs" $ \tmpDir -> do let tmpPath = tmpDir </> targetName -- The args to use with "ar" are actually rather subtle and system-dependent.@@ -105,7 +113,8 @@ -- 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+ let simpleArgs, initialArgs, finalArgs :: [String]+ simpleArgs = case hostOS of OSX -> ["-r", "-s"] _ | dashLSupported -> ["-qL"] _ -> ["-r"]@@ -116,12 +125,13 @@ _ | dashLSupported -> ["-qL"] _ -> ["-q"] - extraArgs = verbosityOpts verbosity ++ [tmpPath]+ extraArgs = verbosityOpts verbosity ++ [u tmpPath] - simple = programInvocation ar (simpleArgs ++ extraArgs)- initial = programInvocation ar (initialArgs ++ extraArgs)+ ar = programInvocationCwd mbWorkDir arProg+ simple = ar (simpleArgs ++ extraArgs)+ initial = ar (initialArgs ++ extraArgs) middle = initial- final = programInvocation ar (finalArgs ++ extraArgs)+ final = ar (finalArgs ++ extraArgs) oldVersionManualOverride = fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi@@ -130,10 +140,9 @@ dashLSupported = arDashLSupported (compiler lbi) - invokeWithResponesFile :: FilePath -> ProgramInvocation- invokeWithResponesFile atFile =- programInvocation ar $- simpleArgs ++ extraArgs ++ ['@' : atFile]+ invokeWithResponseFile :: FilePath -> ProgramInvocation+ invokeWithResponseFile atFile =+ ar $ simpleArgs ++ extraArgs ++ ['@' : atFile] if oldVersionManualOverride || responseArgumentsNotSupported then@@ -143,24 +152,24 @@ multiStageProgramInvocation simple (initial, middle, final)- files+ (map getSymbolicPath files) ]- else withResponseFile verbosity defaultTempFileOptions tmpDir "ar.rsp" Nothing files $- \path -> runProgramInvocation verbosity $ invokeWithResponesFile path+ else withResponseFile verbosity defaultTempFileOptions "ar.rsp" Nothing (map getSymbolicPath files) $+ \path -> runProgramInvocation verbosity $ invokeWithResponseFile path 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+ $ wipeMetadata verbosity (i tmpPath) -- AIX uses its own "ar" format variant+ equal <- filesEqual (i tmpPath) (i targetPath)+ unless equal $ renameFile (i tmpPath) (i targetPath) where progDb = withPrograms lbi Platform hostArch hostOS = hostPlatform lbi verbosityOpts v- | v >= deafening = ["-v"]- | v >= verbose = []+ | verbosityLevel v >= Deafening = ["-v"]+ | verbosityLevel 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
src/Distribution/Simple/Program/Builtin.hs view
@@ -20,12 +20,10 @@ , runghcProgram , ghcjsProgram , ghcjsPkgProgram- , hmakeProgram , jhcProgram- , haskellSuiteProgram- , haskellSuitePkgProgram , uhcProgram , gccProgram+ , gppProgram , arProgram , stripProgram , happyProgram@@ -36,7 +34,6 @@ , hscolourProgram , doctestProgram , haddockProgram- , greencardProgram , ldProgram , tarProgram , cppProgram@@ -64,6 +61,9 @@ -- ------------------------------------------------------------ +-- NOTE: if you modify the list of builtin programs below, also update documentation in+-- the Cabal manual: option `--with-PROG` described in doc/setup-commands.rst+ -- | The default list of programs. -- These programs are typically used internally to Cabal. builtinPrograms :: [Program]@@ -74,9 +74,6 @@ , ghcPkgProgram , ghcjsProgram , ghcjsPkgProgram- , haskellSuiteProgram- , haskellSuitePkgProgram- , hmakeProgram , jhcProgram , uhcProgram , hpcProgram@@ -89,7 +86,6 @@ , hsc2hsProgram , c2hsProgram , cpphsProgram- , greencardProgram , -- platform toolchain gccProgram , arProgram@@ -104,33 +100,27 @@ 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)+ , programPostConf = ghcPostConf , programNormaliseArgs = normaliseGhcArgs }+ where+ ghcPostConf _verbosity ghcProg = do+ let ignorePackageEnv prog = prog{programDefaultArgs = "-package-env=-" : programDefaultArgs prog} + canIgnorePackageEnv = orLaterVersion $ mkVersion [8, 4, 4]++ applyWhen cond f prog = if cond then f prog else prog++ return $+ maybe+ ghcProg+ ( \v ->+ -- By default, ignore GHC_ENVIRONMENT variable of any package environment+ -- files. See #10759+ applyWhen (withinRange v canIgnorePackageEnv) ignorePackageEnv ghcProg+ )+ (programVersion ghcProg)+ runghcProgram :: Program runghcProgram = (simpleProgram "runghc")@@ -170,17 +160,6 @@ _ -> "" } -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- _ -> ""- }- jhcProgram :: Program jhcProgram = (simpleProgram "jhc")@@ -208,40 +187,6 @@ _ -> "" } --- This represents a haskell-suite compiler. Of course, the compiler--- itself probably is not called "haskell-suite", so this is not a real--- program. (But we don't know statically the name of the actual compiler,--- so this is the best we can do.)------ Having this Program value serves two purposes:------ 1. We can accept options for the compiler in the form of------ --haskell-suite-option(s)=...------ 2. We can find a program later using this static id (with--- requireProgram).------ 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", [])- }---- 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", [])- }- happyProgram :: Program happyProgram = (simpleProgram "happy")@@ -270,6 +215,13 @@ { programFindVersion = findProgramVersion "-dumpversion" id } +gppProgram :: Program+gppProgram =+ (simpleProgram "gpp")+ { programFindVersion = findProgramVersion "-dumpversion" id+ , programFindLocation = \v p -> findProgramOnSearchPath v p "g++"+ }+ arProgram :: Program arProgram = simpleProgram "ar" @@ -277,7 +229,10 @@ stripProgram = (simpleProgram "strip") { programFindVersion = \verbosity ->- findProgramVersion "--version" stripExtractVersion (lessVerbose verbosity)+ findProgramVersion+ "--version"+ stripExtractVersion+ (modifyVerbosityFlags lessVerbose verbosity) } hsc2hsProgram :: Program@@ -343,9 +298,6 @@ , programNormaliseArgs = \_ _ args -> args } -greencardProgram :: Program-greencardProgram = simpleProgram "greencard"- ldProgram :: Program ldProgram = (simpleProgram "ld")@@ -400,7 +352,7 @@ -- Some versions of tar don't support '--help'. `catchIO` (\_ -> return "") let k = "Supports --format"- v = if ("--format" `isInfixOf` tarHelpOutput) then "YES" else "NO"+ v = if "--format" `isInfixOf` tarHelpOutput then "YES" else "NO" m = Map.insert k v (programProperties tarProg) return $ tarProg{programProperties = m} }
src/Distribution/Simple/Program/Db.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -26,7 +25,7 @@ -- 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+ ProgramDb (..) , emptyProgramDb , defaultProgramDb , restoreProgramDb@@ -34,7 +33,9 @@ -- ** Query and manipulate the program db , addKnownProgram , addKnownPrograms+ , clearUnconfiguredPrograms , prependProgramSearchPath+ , prependProgramSearchPathNoLogging , lookupKnownProgram , knownPrograms , getProgramSearchPath@@ -53,6 +54,7 @@ -- ** Query and manipulate the program db , configureProgram+ , configureUnconfiguredProgram , configureAllKnownPrograms , unconfigureProgram , lookupProgramVersion@@ -60,8 +62,17 @@ , requireProgram , requireProgramVersion , needProgram++ -- * Internal functions+ , UnconfiguredProgs+ , ConfiguredProgs+ , updateUnconfiguredProgs+ , updateConfiguredProgs+ , updatePathProgDb ) where +import Control.Monad ((<=<))+import Data.Functor ((<&>)) import Distribution.Compat.Prelude import Prelude () @@ -95,16 +106,16 @@ data ProgramDb = ProgramDb { unconfiguredProgs :: UnconfiguredProgs , progSearchPath :: ProgramSearchPath+ , progOverrideEnv :: [(String, Maybe String)] , configuredProgs :: ConfiguredProgs }- deriving (Typeable) type UnconfiguredProgram = (Program, Maybe FilePath, [ProgArg]) type UnconfiguredProgs = Map.Map String UnconfiguredProgram type ConfiguredProgs = Map.Map String ConfiguredProgram emptyProgramDb :: ProgramDb-emptyProgramDb = ProgramDb Map.empty defaultProgramSearchPath Map.empty+emptyProgramDb = ProgramDb Map.empty defaultProgramSearchPath [] Map.empty defaultProgramDb :: ProgramDb defaultProgramDb = restoreProgramDb builtinPrograms emptyProgramDb@@ -144,14 +155,17 @@ instance Binary ProgramDb where put db = do put (progSearchPath db)+ put (progOverrideEnv db) put (configuredProgs db) get = do searchpath <- get+ overrides <- get progs <- get return $! emptyProgramDb { progSearchPath = searchpath+ , progOverrideEnv = overrides , configuredProgs = progs } @@ -162,6 +176,7 @@ 0 "ProgramDb" [ structure (Proxy :: Proxy ProgramSearchPath)+ , structure (Proxy :: Proxy [(String, Maybe String)]) , structure (Proxy :: Proxy ConfiguredProgs) ] @@ -189,6 +204,14 @@ addKnownPrograms :: [Program] -> ProgramDb -> ProgramDb addKnownPrograms progs progdb = foldl' (flip addKnownProgram) progdb progs +-- | Drop all unconfigured programs from a 'ProgramDb', retaining only+-- configured programs, the search path, and environment overrides.+--+-- This mirrors round-tripping via the @'Binary' 'ProgramDb'@ instance, which+-- drops unconfigured programs.+clearUnconfiguredPrograms :: ProgramDb -> ProgramDb+clearUnconfiguredPrograms progdb = progdb{unconfiguredProgs = Map.empty}+ lookupKnownProgram :: String -> ProgramDb -> Maybe Program lookupKnownProgram name = fmap (\(p, _, _) -> p) . Map.lookup name . unconfiguredProgs@@ -223,20 +246,39 @@ setProgramSearchPath (f $ getProgramSearchPath db) db -- | Modify the current 'ProgramSearchPath' used by the 'ProgramDb'--- by prepending the provided extra paths. Also logs the added paths--- in info verbosity.+-- by prepending the provided extra paths.+--+-- - Logs the added paths in info verbosity.+-- - Prepends environment variable overrides. prependProgramSearchPath :: Verbosity -> [FilePath]+ -> [(String, Maybe FilePath)] -> ProgramDb -> IO ProgramDb-prependProgramSearchPath verbosity extraPaths db =- if not $ null extraPaths- then do- logExtraProgramSearchPath verbosity extraPaths- pure $ modifyProgramSearchPath (map ProgramSearchPathDir extraPaths ++) db- else pure db+prependProgramSearchPath verbosity extraPaths extraEnv db = do+ unless (null extraPaths) $+ logExtraProgramSearchPath verbosity extraPaths+ unless (null extraEnv) $+ logExtraProgramOverrideEnv verbosity extraEnv+ return $ prependProgramSearchPathNoLogging extraPaths extraEnv db +prependProgramSearchPathNoLogging+ :: [FilePath]+ -> [(String, Maybe String)]+ -> ProgramDb+ -> ProgramDb+prependProgramSearchPathNoLogging extraPaths extraEnv db =+ let db' =+ if null extraPaths+ then db -- skip work if nothing to do+ else modifyProgramSearchPath (nub . (map ProgramSearchPathDir extraPaths ++)) db+ db'' =+ if null extraEnv+ then db' -- skip work if nothing to do+ else db'{progOverrideEnv = extraEnv ++ progOverrideEnv db'}+ in 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.@@ -304,7 +346,7 @@ -- | 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+ (\(_, p, _) -> p) <=< (Map.lookup (programName prog) . unconfiguredProgs) -- | Get any extra args that have been previously specified for a program. userSpecifiedArgs :: Program -> ProgramDb -> [ProgArg]@@ -338,11 +380,13 @@ -- --------------------------- -- Configuring known programs --- | Try to configure a specific program. If the program is already included in--- the collection of unconfigured programs then we use any user-supplied--- location and arguments. If the program gets configured successfully it gets--- added to the configured collection.+-- | Try to configure a specific program and add it to the program database. --+-- If the program is already included in the collection of unconfigured programs,+-- then we use any user-supplied location and arguments.+-- If the program gets configured successfully, it gets added to the configured+-- collection.+-- -- Note that it is not a failure if the program cannot be configured. It's only -- a failure if the user supplied a location and the program could not be found -- at that location.@@ -357,11 +401,30 @@ -> ProgramDb -> IO ProgramDb configureProgram verbosity prog progdb = do+ mbConfiguredProg <- configureUnconfiguredProgram verbosity prog progdb+ case mbConfiguredProg of+ Nothing -> return progdb+ Just configuredProg -> do+ let progdb' =+ updateConfiguredProgs+ (Map.insert (programName prog) configuredProg)+ progdb+ return progdb'++-- | Try to configure a specific program. If the program is already included in+-- the collection of unconfigured programs then we use any user-supplied+-- location and arguments.+configureUnconfiguredProgram+ :: Verbosity+ -> Program+ -> ProgramDb+ -> IO (Maybe ConfiguredProgram)+configureUnconfiguredProgram verbosity prog progdb = do let name = programName prog maybeLocation <- case userSpecifiedPath prog progdb of Nothing -> programFindLocation prog verbosity (progSearchPath progdb)- >>= return . fmap (swap . fmap FoundOnSystem . swap)+ <&> fmap (swap . fmap FoundOnSystem . swap) Just path -> do absolute <- doesExecutableExist path if absolute@@ -372,7 +435,7 @@ (dieWithException verbosity $ ConfigureProgram name path) (return . Just . swap . fmap UserSpecified . swap) case maybeLocation of- Nothing -> return progdb+ Nothing -> return Nothing Just (location, triedLocations) -> do version <- programFindVersion prog verbosity (locationPath location) newPath <- programSearchPathAsPATHVar (progSearchPath progdb)@@ -382,13 +445,13 @@ , programVersion = version , programDefaultArgs = [] , programOverrideArgs = userSpecifiedArgs prog progdb- , programOverrideEnv = [("PATH", Just newPath)]+ , programOverrideEnv = [("PATH", Just newPath)] ++ progOverrideEnv progdb , programProperties = Map.empty , programLocation = location , programMonitorFiles = triedLocations } configuredProg' <- programPostConf prog verbosity configuredProg- return (updateConfiguredProgs (Map.insert name configuredProg') progdb)+ return $ Just configuredProg' -- | Configure a bunch of programs using 'configureProgram'. Just a 'foldM'. configurePrograms@@ -438,6 +501,45 @@ where progs = catMaybes [lookupKnownProgram name progdb | (name, _) <- paths] +-- | Update the PATH and environment variables of already-configured programs+-- in the program database.+--+-- This is a somewhat sketchy operation, but it handles the following situation:+--+-- - we add a build-tool-depends executable to the program database, with its+-- associated data directory environment variables;+-- - we want invocations of GHC (an already configured program) to be able to+-- find this program (e.g. if the build-tool-depends executable is used+-- in a Template Haskell splice).+--+-- In this case, we want to add the build tool to the PATH of GHC, even though+-- GHC is already configured which in theory means we shouldn't touch it any+-- more.+updatePathProgDb :: Verbosity -> ProgramDb -> IO ProgramDb+updatePathProgDb verbosity progdb =+ updatePathProgs verbosity progs progdb+ where+ progs = Map.elems $ configuredProgs progdb++-- | See 'updatePathProgDb'+updatePathProgs :: Verbosity -> [ConfiguredProgram] -> ProgramDb -> IO ProgramDb+updatePathProgs verbosity progs progdb =+ foldM (flip (updatePathProg verbosity)) progdb progs++-- | See 'updatePathProgDb'.+updatePathProg :: Verbosity -> ConfiguredProgram -> ProgramDb -> IO ProgramDb+updatePathProg _verbosity prog progdb = do+ newPath <- programSearchPathAsPATHVar (progSearchPath progdb)+ let envOverrides = progOverrideEnv progdb+ progOverrides = programOverrideEnv prog+ prog' =+ prog+ { programOverrideEnv =+ [("PATH", Just newPath)]+ ++ filter ((/= "PATH") . fst) (envOverrides ++ progOverrides)+ }+ return $ updateProgram prog' progdb+ -- | Check that a program is configured and available to be run. -- -- It raises an exception if the program could not be configured, otherwise@@ -516,6 +618,5 @@ -> ProgramDb -> IO (ConfiguredProgram, Version, ProgramDb) requireProgramVersion verbosity prog range programDb =- join $- either (dieWithException verbosity) return- `fmap` lookupProgramVersion verbosity prog range programDb+ either (dieWithException verbosity) return+ =<< lookupProgramVersion verbosity prog range programDb
src/Distribution/Simple/Program/Find.hs view
@@ -1,6 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -33,6 +31,7 @@ , findProgramOnSearchPath , programSearchPathAsPATHVar , logExtraProgramSearchPath+ , logExtraProgramOverrideEnv , getSystemSearchPath , getExtraPathEnv , simpleProgram@@ -47,7 +46,7 @@ import Distribution.System import Distribution.Verbosity -import qualified System.Directory as Directory+import System.Directory ( findExecutable ) import System.FilePath as FilePath@@ -74,6 +73,19 @@ "Including the following directories in PATH:" : map ("- " ++) extraPaths +logExtraProgramOverrideEnv+ :: Verbosity+ -> [(String, Maybe String)]+ -> IO ()+logExtraProgramOverrideEnv verbosity extraEnv =+ info verbosity . unlines $+ "Including the following environment variable overrides:"+ : [ "- " ++ case mbVal of+ Nothing -> "unset " ++ var+ Just val -> var ++ "=" ++ val+ | (var, mbVal) <- extraEnv+ ]+ findProgramOnSearchPath :: Verbosity -> ProgramSearchPath@@ -192,29 +204,6 @@ return path #else FilePath.getSearchPath-#endif--#ifdef MIN_VERSION_directory-#if MIN_VERSION_directory(1,2,1)-#define HAVE_directory_121-#endif-#endif--findExecutable :: FilePath -> IO (Maybe FilePath)-#ifdef HAVE_directory_121-findExecutable = Directory.findExecutable-#else-findExecutable prog = do- -- With directory < 1.2.1 'findExecutable' doesn't check that the path- -- really refers to an executable.- mExe <- Directory.findExecutable prog- case mExe of- Just exe -> do- exeExists <- doesExecutableExist exe- if exeExists- then return mExe- else return Nothing- _ -> return mExe #endif -- | Make a simple named program.
src/Distribution/Simple/Program/GHC.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}@@ -10,10 +12,13 @@ , GhcMode (..) , GhcOptimisation (..) , GhcDynLinkMode (..)+ , GhcObjectMode (..) , GhcProfAuto (..) , ghcInvocation , renderGhcOptions , runGHC+ , runGHCWithResponseFile+ , runReplProgram , packageDbArgsDb , normaliseGhcArgs ) where@@ -21,8 +26,8 @@ import Distribution.Compat.Prelude import Prelude () +import Data.Semigroup (First (..), Last (..)) import Distribution.Backpack-import Distribution.Compat.Semigroup (First' (..), Last' (..), Option' (..)) import Distribution.ModuleName import Distribution.PackageDescription import Distribution.Pretty@@ -30,25 +35,31 @@ import Distribution.Simple.Flag import Distribution.Simple.GHC.ImplInfo import Distribution.Simple.Program.Find (getExtraPathEnv)+import Distribution.Simple.Program.ResponseFile import Distribution.Simple.Program.Run import Distribution.Simple.Program.Types+import Distribution.Simple.Utils (TempFileOptions, infoNoWrap) import Distribution.System import Distribution.Types.ComponentId+import Distribution.Types.ParStrat import Distribution.Utils.NubList+import Distribution.Utils.Path import Distribution.Verbosity import Distribution.Version++import GHC.IO.Encoding (TextEncoding) import Language.Haskell.Extension import Data.List (stripPrefix) import qualified Data.Map as Map import Data.Monoid (All (..), Any (..), Endo (..)) import qualified Data.Set as Set-import Distribution.Types.ParStrat+import qualified System.Process as Process normaliseGhcArgs :: Maybe Version -> PackageDescription -> [String] -> [String] normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs | ghcVersion `withinRange` supportedGHCVersions =- argumentFilters . filter simpleFilters . filterRtsOpts $ ghcArgs+ argumentFilters . filter simpleFilters . filterRtsArgs $ ghcArgs where supportedGHCVersions :: VersionRange supportedGHCVersions = orLaterVersion (mkVersion [8, 0])@@ -137,15 +148,18 @@ flagArgumentFilter :: [String] -> [String] -> [String] flagArgumentFilter flags = go where- makeFilter :: String -> String -> Option' (First' ([String] -> [String]))- makeFilter flag arg = Option' $ First' . filterRest <$> stripPrefix flag arg+ makeFilter :: String -> String -> Maybe (First ([String] -> [String]))+ makeFilter flag arg = First . filterRest <$> stripPrefix flag arg where+ -- Drop the next argument, whether it comes after a `=` or+ -- is stand-alone.+ filterRest :: String -> [String] -> [String] filterRest leftOver = case dropEq leftOver of [] -> drop 1 _ -> id checkFilter :: String -> Maybe ([String] -> [String])- checkFilter = fmap getFirst' . getOption' . foldMap makeFilter flags+ checkFilter = fmap getFirst . foldMap makeFilter flags go :: [String] -> [String] go [] = []@@ -153,24 +167,24 @@ Just f -> go (f args) Nothing -> arg : go args + -- Options that take parameters and do not modify the generated artifacts+ -- are filtered out. argumentFilters :: [String] -> [String] argumentFilters = flagArgumentFilter- ["-ghci-script", "-H", "-interactive-print"]+ [ "-ghci-script"+ , "-H"+ , "-interactive-print"+ , "-fghci-browser-assets-dir"+ ] - filterRtsOpts :: [String] -> [String]- filterRtsOpts = go False- 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- where- addOpt- | isRTSopts = id- | otherwise = (opt :)+ -- \| Remove RTS arguments from a list.+ filterRtsArgs :: [String] -> [String]+ filterRtsArgs = snd . splitRTSArgs + -- Simple options (i.e. that do not take parameters, or just+ -- take int parameters) which do *not* change generated artifacts+ -- are filtered out. simpleFilters :: String -> Bool simpleFilters = not@@ -181,7 +195,8 @@ , Any . isPrefixOf "-dsuppress-" , Any . isPrefixOf "-dno-suppress-" , flagIn $ invertibleFlagSet "-" ["ignore-dot-ghci"]- , flagIn . invertibleFlagSet "-f" . mconcat $+ , -- -f-something -f-no-something options.+ flagIn . invertibleFlagSet "-f" . mconcat $ [ [ "reverse-errors" , "warn-unused-binds"@@ -320,9 +335,12 @@ , "-ddpr-cols" , "-dtrace-level" , "-fghci-hist-size"+ , "-dinitial-unique"+ , "-dunique-increment" ] , from [8, 2] ["-fmax-uncovered-patterns", "-fmax-errors"] , from [8, 4] $ to [8, 6] ["-fmax-valid-substitutions"]+ , from [9, 12] ["-fmax-forced-spec-args", "-fwrite-if-compression"] ] dropIntFlag :: Bool -> String -> String -> Any@@ -361,12 +379,12 @@ safeToFilterHoles :: Bool safeToFilterHoles = getAll . checkGhcFlags $- All . fromMaybe True . fmap getLast' . getOption' . foldMap notDeferred+ All . maybe True getLast . foldMap notDeferred where- notDeferred :: String -> Option' (Last' Bool)- notDeferred "-fdefer-typed-holes" = Option' . Just . Last' $ False- notDeferred "-fno-defer-typed-holes" = Option' . Just . Last' $ True- notDeferred _ = Option' Nothing+ notDeferred :: String -> Maybe (Last Bool)+ notDeferred "-fdefer-typed-holes" = Just . Last $ False+ notDeferred "-fno-defer-typed-holes" = Just . Last $ True+ notDeferred _ = Nothing isTypedHoleFlag :: String -> Any isTypedHoleFlag =@@ -419,13 +437,13 @@ , ----------------------- -- Inputs and outputs - ghcOptInputFiles :: NubListR FilePath+ ghcOptInputFiles :: NubListR (SymbolicPath Pkg File) -- ^ The main input files; could be .hs, .hi, .c, .o, depending on mode.- , ghcOptInputScripts :: NubListR FilePath+ , ghcOptInputScripts :: NubListR (SymbolicPath Pkg File) -- ^ 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+ , ghcOptOutputFile :: Flag (SymbolicPath Pkg File) -- ^ Location for output file; the @ghc -o@ flag. , ghcOptOutputDynFile :: Flag FilePath -- ^ Location for dynamic output file in 'GhcStaticAndDynamic' mode;@@ -433,8 +451,10 @@ , 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).- , ghcOptSourcePath :: NubListR FilePath+ , ghcOptSourcePath :: NubListR (SymbolicPath Pkg (Dir Source)) -- ^ Search path for Haskell source files; the @ghc -i@ flag.+ , ghcOptUnitFiles :: [FilePath]+ -- ^ Unit files to load; the @ghc -unit@ flag. , ------------- -- Packages @@ -474,13 +494,13 @@ ghcOptLinkLibs :: [FilePath] -- ^ Names of libraries to link in; the @ghc -l@ flag.- , ghcOptLinkLibPath :: NubListR FilePath+ , ghcOptLinkLibPath :: NubListR (SymbolicPath Pkg (Dir Lib)) -- ^ 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+ , ghcOptLinkFrameworkDirs :: NubListR (SymbolicPath Pkg (Dir Framework)) -- ^ OSX only: Search path for frameworks to link in; the -- @ghc -framework-path@ flag. , ghcOptLinkRts :: Flag Bool@@ -503,14 +523,18 @@ -- ^ Options to pass through to the Assembler. , ghcOptCppOptions :: [String] -- ^ Options to pass through to CPP; the @ghc -optP@ flag.- , ghcOptCppIncludePath :: NubListR FilePath+ , ghcOptJSppOptions :: [String]+ -- ^ Options to pass through to CPP; the @ghc -optJSP@ flag. @since 3.16.0.0+ , ghcOptCppIncludePath :: NubListR (SymbolicPath Pkg (Dir Include)) -- ^ Search path for CPP includes like header files; the @ghc -I@ flag.- , ghcOptCppIncludes :: NubListR FilePath+ , ghcOptCppIncludes :: NubListR (SymbolicPath Pkg File) -- ^ 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.+ -- ^ Program to use for the C compiler; the @ghc -pgmc@ flag.+ , ghcOptGppProgram :: Flag FilePath+ -- ^ Program to use for the C++ compiler; the @ghc -pgmcxx@ flag. , ---------------------------- -- Language and extensions @@ -538,7 +562,7 @@ -- ^ Use the \"split object files\" feature; the @ghc -split-objs@ flag. , ghcOptNumJobs :: Flag ParStrat -- ^ Run N jobs simultaneously (if possible).- , ghcOptHPCDir :: Flag FilePath+ , ghcOptHPCDir :: Flag (SymbolicPath Pkg (Dir Mix)) -- ^ Enable coverage analysis; the @ghc -fhpc -hpcdir@ flags. , ---------------- -- GHCi@@ -554,26 +578,29 @@ -- ^ only in 'GhcStaticAndDynamic' mode , ghcOptDynObjSuffix :: Flag String -- ^ only in 'GhcStaticAndDynamic' mode- , ghcOptHiDir :: Flag FilePath- , ghcOptHieDir :: Flag FilePath- , ghcOptObjDir :: Flag FilePath- , ghcOptOutputDir :: Flag FilePath- , ghcOptStubDir :: Flag FilePath+ , ghcOptHiDir :: Flag (SymbolicPath Pkg (Dir Artifacts))+ , ghcOptHieDir :: Flag (SymbolicPath Pkg (Dir Artifacts))+ , ghcOptObjDir :: Flag (SymbolicPath Pkg (Dir Artifacts))+ , ghcOptOutputDir :: Flag (SymbolicPath Pkg (Dir Artifacts))+ , ghcOptStubDir :: Flag (SymbolicPath Pkg (Dir Artifacts))+ , ghcOptBytecodeDir :: Flag (SymbolicPath Pkg (Dir Artifacts)) , -------------------- -- Creating libraries ghcOptDynLinkMode :: Flag GhcDynLinkMode+ , ghcOptObjectMode :: Flag GhcObjectMode , ghcOptStaticLib :: Flag Bool , ghcOptShared :: Flag Bool+ , ghcOptBytecodeLib :: Flag Bool , ghcOptFPic :: Flag Bool , ghcOptDylibName :: Flag String , ghcOptRPaths :: NubListR FilePath , --------------- -- Misc flags - ghcOptVerbosity :: Flag Verbosity+ ghcOptVerbosity :: Flag VerbosityLevel -- ^ Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag.- , ghcOptExtraPath :: NubListR FilePath+ , ghcOptExtraPath :: NubListR (SymbolicPath Pkg (Dir Build)) -- ^ Put the extra folders in the PATH environment variable we invoke -- GHC with , ghcOptCabal :: Flag Bool@@ -617,6 +644,15 @@ GhcStaticAndDynamic deriving (Show, Eq) +data GhcObjectMode+ = -- | -fobject-code+ GhcObjectCode+ | -- | -fbyte-code+ GhcByteCode+ | -- | -fbyte-code-and-object-code+ GhcByteCodeAndObjectCode+ deriving (Show, Eq)+ data GhcProfAuto = -- | @-fprof-auto@ GhcProfAutoAll@@ -633,27 +669,101 @@ -> ConfiguredProgram -> Compiler -> Platform+ -> Maybe (SymbolicPath CWD (Dir Pkg)) -> GhcOptions -> IO ()-runGHC verbosity ghcProg comp platform opts = do- runProgramInvocation verbosity =<< ghcInvocation verbosity ghcProg comp platform opts+runGHC verbosity ghcProg comp platform mbWorkDir opts = do+ runProgramInvocation verbosity+ =<< ghcInvocation verbosity ghcProg comp platform mbWorkDir opts +runGHCWithResponseFile+ :: FilePath+ -> Maybe TextEncoding+ -> TempFileOptions+ -> Verbosity+ -> ConfiguredProgram+ -> Compiler+ -> Platform+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -> GhcOptions+ -> IO ()+runGHCWithResponseFile fileNameTemplate encoding tempFileOptions verbosity ghcProg comp platform maybeWorkDir opts = do+ invocation <- ghcInvocation verbosity ghcProg comp platform maybeWorkDir opts++ let compilerSupportsResponseFiles =+ case compilerCompatVersion GHC comp of+ -- GHC 9.4 is the first version which supports response files.+ Just version -> version >= mkVersion [9, 4]+ Nothing -> False++ args = progInvokeArgs invocation++ if not compilerSupportsResponseFiles+ then runProgramInvocation verbosity invocation+ else do+ let (rtsArgs, otherArgs) = splitRTSArgs args++ withResponseFile+ verbosity+ tempFileOptions+ fileNameTemplate+ encoding+ otherArgs+ $ \responseFile -> do+ let newInvocation =+ invocation{progInvokeArgs = ('@' : responseFile) : rtsArgs}++ infoNoWrap verbosity $+ "GHC response file arguments: "+ <> case otherArgs of+ [] -> ""+ arg : args' -> Process.showCommandForUser arg args'++ runProgramInvocation verbosity newInvocation++-- Start the repl. Either use `ghc`, or the program specified by the --with-repl flag.+runReplProgram+ :: Maybe FilePath+ -- ^ --with-repl argument+ -> TempFileOptions+ -> Verbosity+ -> ConfiguredProgram+ -> Compiler+ -> Platform+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -> GhcOptions+ -> IO ()+runReplProgram withReplProg tempFileOptions verbosity ghcProg comp platform mbWorkDir ghcOpts =+ let replProg = case withReplProg of+ Just path -> ghcProg{programLocation = FoundOnSystem path}+ Nothing -> ghcProg+ in runGHCWithResponseFile "ghci.rsp" Nothing tempFileOptions verbosity replProg comp platform mbWorkDir ghcOpts+ ghcInvocation :: Verbosity -> ConfiguredProgram -> Compiler -> Platform+ -> Maybe (SymbolicPath CWD (Dir Pkg)) -> GhcOptions -> IO ProgramInvocation-ghcInvocation verbosity ghcProg comp platform opts = do+ghcInvocation verbosity ghcProg comp platform mbWorkDir opts = do -- NOTE: GHC is the only program whose path we modify with more values than -- the standard @extra-prog-path@, namely the folders of the executables in -- the components, see @componentGhcOptions@. let envOverrides = programOverrideEnv ghcProg- extraPath <- getExtraPathEnv verbosity envOverrides (fromNubListR (ghcOptExtraPath opts))+ extraPath <-+ getExtraPathEnv verbosity envOverrides $+ map getSymbolicPath $+ fromNubListR $+ ghcOptExtraPath opts let ghcProg' = ghcProg{programOverrideEnv = envOverrides ++ extraPath}+ return $+ programInvocationCwd mbWorkDir ghcProg' $+ renderGhcOptions comp platform opts - pure $ programInvocation ghcProg' (renderGhcOptions comp platform opts)+-- TODO: use the -working-dir GHC flag instead of setting the process+-- working directory, as this improves error messages. renderGhcOptions :: Compiler -> Platform -> GhcOptions -> [String] renderGhcOptions comp _platform@(Platform _arch os) opts@@ -702,18 +812,12 @@ | not (flagBool ghcOptProfilingMode) -> [] Nothing -> []- Just GhcProfAutoAll- | flagProfAuto implInfo -> ["-fprof-auto"]- | otherwise -> ["-auto-all"] -- not the same, but close+ Just GhcProfAutoAll -> ["-fprof-auto"] 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"]+ Just GhcProfAutoToplevel -> ["-fprof-auto-top"]+ Just GhcProfAutoExported -> ["-fprof-auto-exported"] , ["-split-sections" | flagBool ghcOptSplitSections] , case compilerCompatVersion GHC comp of -- the -split-objs flag was removed in GHC 9.8@@ -721,15 +825,12 @@ _ -> ["-split-objs" | flagBool ghcOptSplitObjs] , case flagToMaybe (ghcOptHPCDir opts) of Nothing -> []- Just hpcdir -> ["-fhpc", "-hpcdir", hpcdir]+ Just hpcdir -> ["-fhpc", "-hpcdir", u hpcdir] , if parmakeSupported comp then case ghcOptNumJobs opts of NoFlag -> [] Flag Serial -> []- Flag (UseSem name) ->- if jsemSupported comp- then ["-jsem " ++ name]- else []+ Flag (UseSem name) -> ["-jsem " ++ name | jsemSupported comp] Flag (NumJobs n) -> ["-j" ++ maybe "" show n] else [] , --------------------@@ -737,11 +838,17 @@ ["-staticlib" | flagBool ghcOptStaticLib] , ["-shared" | flagBool ghcOptShared]+ , ["-bytecodelib" | flagBool ghcOptBytecodeLib] , case flagToMaybe (ghcOptDynLinkMode opts) of Nothing -> [] Just GhcStaticOnly -> ["-static"] Just GhcDynamicOnly -> ["-dynamic"] Just GhcStaticAndDynamic -> ["-static", "-dynamic-too"]+ , case flagToMaybe (ghcOptObjectMode opts) of+ Nothing -> []+ Just GhcObjectCode -> ["-fobject-code"]+ Just GhcByteCode -> ["-fbyte-code", "-fwrite-interface", "-fwrite-byte-code"]+ Just GhcByteCodeAndObjectCode -> ["-fbyte-code-and-object-code"] , ["-fPIC" | flagBool ghcOptFPic] , concat [["-dylib-install-name", libname] | libname <- flag ghcOptDylibName] , ------------------------@@ -751,41 +858,45 @@ , 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 [["-hiedir", dir] | dir <- flag ghcOptHieDir]- , concat [["-stubdir", dir] | dir <- flag ghcOptStubDir]+ , concat [["-outputdir", u dir] | dir <- flag ghcOptOutputDir]+ , concat [["-odir", u dir] | dir <- flag ghcOptObjDir]+ , concat [["-hidir", u dir] | dir <- flag ghcOptHiDir]+ , concat [["-hiedir", u dir] | dir <- flag ghcOptHieDir]+ , concat [["-gbcdir", u dir] | bytecodeArtifactsSupported comp, dir <- flag ghcOptBytecodeDir]+ , concat [["-stubdir", u dir] | dir <- flag ghcOptStubDir] , ----------------------- -- Source search path ["-i" | flagBool ghcOptSourcePathClear]- , ["-i" ++ dir | dir <- flags ghcOptSourcePath]+ , ["-i" ++ u dir | dir <- flags ghcOptSourcePath] , -------------------- -------------------- -- CPP, C, and C++ stuff - ["-I" ++ dir | dir <- flags ghcOptCppIncludePath]+ ["-I" ++ u dir | dir <- flags ghcOptCppIncludePath] , ["-optP" ++ opt | opt <- ghcOptCppOptions opts]+ , ["-optJSP" ++ opt | opt <- ghcOptJSppOptions opts] , concat- [ ["-optP-include", "-optP" ++ inc]+ [ ["-optP-include", "-optP" ++ u inc] | inc <- flags ghcOptCppIncludes ] , ["-optc" ++ opt | opt <- ghcOptCcOptions opts] , -- C++ compiler options: GHC >= 8.10 requires -optcxx, older requires -optc+ -- https://gitlab.haskell.org/ghc/ghc/-/issues/16477 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]+ , concat [["-pgmcxx", cxx] | cxx <- flag ghcOptGppProgram] , ----------------- -- Linker stuff ["-optl" ++ opt | opt <- ghcOptLinkOptions opts] , ["-l" ++ lib | lib <- ghcOptLinkLibs opts]- , ["-L" ++ dir | dir <- flags ghcOptLinkLibPath]+ , ["-L" ++ u dir | dir <- flags ghcOptLinkLibPath] , if isOSX then concat@@ -796,7 +907,7 @@ , if isOSX then concat- [ ["-framework-path", path]+ [ ["-framework-path", u path] | path <- flags ghcOptLinkFrameworkDirs ] else []@@ -823,8 +934,8 @@ , if null (ghcOptInstantiatedWith opts) then [] else- "-instantiated-with"- : intercalate+ [ "-instantiated-with"+ , intercalate "," ( map ( \(n, m) ->@@ -834,12 +945,12 @@ ) (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)+ , packageDbArgsDb (interpretPackageDBStack Nothing (ghcOptPackageDBs opts)) , concat $ let space "" = "" space xs = ' ' : xs@@ -849,9 +960,7 @@ , ---------------------------- -- Language and extensions - if supportsHaskell2010 implInfo- then ["-X" ++ prettyShow lang | lang <- flag ghcOptLanguage]- else []+ ["-X" ++ prettyShow lang | lang <- flag ghcOptLanguage] , [ ext' | ext <- flags ghcOptExtensions , ext' <- case Map.lookup ext (ghcOptExtensionMap opts) of@@ -867,57 +976,44 @@ -- GHCi concat- [ ["-ghci-script", script] | script <- ghcOptGHCiScripts opts, flagGhciScript implInfo+ [ ["-ghci-script", script] | script <- ghcOptGHCiScripts opts ] , --------------- -- 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]+ map u $ flags ghcOptInputFiles+ , concat [["-x", "hs", u script] | script <- flags ghcOptInputScripts] , [prettyShow modu | modu <- flags ghcOptInputModules]- , concat [["-o", out] | out <- flag ghcOptOutputFile]+ , concat [["-o", u out] | out <- flag ghcOptOutputFile] , concat [["-dyno", out] | out <- flag ghcOptOutputDynFile]+ , -- unit files+ concat [["-unit", "@" ++ unit] | unit <- ghcOptUnitFiles opts] , --------------- -- Extra ghcOptExtra opts ] where+ -- See Note [Symbolic paths] in Distribution.Utils.Path+ u :: SymbolicPath Pkg to -> FilePath+ u = interpretSymbolicPathCWD 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 :: VerbosityLevel -> [String] verbosityOpts verbosity- | verbosity >= deafening = ["-v"]- | verbosity >= normal = []+ | verbosity >= Deafening = ["-v"]+ | 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- _ -> ierror- where- 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]+packageDbArgsDb :: PackageDBStackCWD -> [String] -- special cases to make arguments prettier in common scenarios-packageDbArgsDb dbstack = case dbstack of+packageDbArgsDb = \case (GlobalPackageDB : UserPackageDB : dbs) | all isSpecific dbs -> concatMap single dbs (GlobalPackageDB : dbs)@@ -934,10 +1030,25 @@ isSpecific (SpecificPackageDB _) = True isSpecific _ = False -packageDbArgs :: GhcImplInfo -> PackageDBStack -> [String]-packageDbArgs implInfo- | flagPackageConf implInfo = packageDbArgsConf- | otherwise = packageDbArgsDb+-- | Split a list of command-line arguments into RTS arguments and non-RTS+-- arguments.+splitRTSArgs :: [String] -> ([String], [String])+splitRTSArgs args =+ let addRTSArg arg ~(rtsArgs, nonRTSArgs) = (arg : rtsArgs, nonRTSArgs)+ addNonRTSArg arg ~(rtsArgs, nonRTSArgs) = (rtsArgs, arg : nonRTSArgs)++ go _ [] = ([], [])+ go isRTSArg (arg : rest) =+ case arg of+ "+RTS" -> addRTSArg arg $ go True rest+ "-RTS" -> addRTSArg arg $ go False rest+ "--RTS" -> ([arg], rest)+ "--" -> ([], arg : rest)+ _ ->+ if isRTSArg+ then addRTSArg arg $ go isRTSArg rest+ else addNonRTSArg arg $ go isRTSArg rest+ in go False args -- ----------------------------------------------------------------------------- -- Boilerplate Monoid instance for GhcOptions
src/Distribution/Simple/Program/HcPkg.hs view
@@ -1,10 +1,8 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} ------------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Program.HcPkg -- Copyright : Duncan Coutts 2009, 2013@@ -16,7 +14,7 @@ -- Currently only GHC and GHCJS have hc-pkg programs. module Distribution.Simple.Program.HcPkg ( -- * Types- HcPkgInfo (..)+ ConfiguredProgram (..) , RegisterOptions (..) , defaultRegisterOptions @@ -47,68 +45,79 @@ import Distribution.Compat.Prelude hiding (init) import Prelude () -import Distribution.InstalledPackageInfo-import Distribution.Parsec-import Distribution.Pretty+import Distribution.InstalledPackageInfo (InstalledPackageInfo (..), parseInstalledPackageInfo, showInstalledPackageInfo)+import Distribution.Parsec (simpleParsec)+import Distribution.Pretty (prettyShow) import Distribution.Simple.Compiler-import Distribution.Simple.Errors+ ( PackageDB+ , PackageDBS+ , PackageDBStack+ , PackageDBStackS+ , PackageDBX (..)+ , registrationPackageDB+ )+import Distribution.Simple.Errors (CabalException (..)) import Distribution.Simple.Program.Run-import Distribution.Simple.Program.Types-import Distribution.Simple.Utils-import Distribution.Types.ComponentId-import Distribution.Types.PackageId-import Distribution.Types.UnitId-import Distribution.Verbosity+ ( IOEncoding (..)+ , ProgramInvocation (..)+ , getProgramInvocationLBS+ , getProgramInvocationOutput+ , programInvocation+ , programInvocationCwd+ , runProgramInvocation+ )+import Distribution.Simple.Program.Types (ConfiguredProgram (..))+import Distribution.Simple.Utils (IOData (..), dieWithException, writeUTF8File)+import Distribution.Types.ComponentId (mkComponentId)+import Distribution.Types.PackageId (PackageId)+import Distribution.Types.UnitId (mkLegacyUnitId, unUnitId)+import Distribution.Utils.Path+ ( CWD+ , FileLike ((<.>))+ , FileOrDir (Dir)+ , PathLike ((</>))+ , Pkg+ , PkgDB+ , SymbolicPath+ , interpretSymbolicPath+ , interpretSymbolicPathCWD+ )+import Distribution.Verbosity (Verbosity, VerbosityLevel (..), verbosityLevel) import Data.List (stripPrefix)-import System.FilePath as FilePath (isPathSeparator, joinPath, splitDirectories, splitPath, (<.>), (</>))+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 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- }- -- | 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)+init :: ConfiguredProgram -> Verbosity -> FilePath -> IO ()+init hpi verbosity path =+ runProgramInvocation verbosity (initInvocation hpi verbosity path) -- | Run @hc-pkg@ using a given package DB stack, directly forwarding the -- provided command-line arguments to it.-invoke :: HcPkgInfo -> Verbosity -> PackageDBStack -> [String] -> IO ()-invoke hpi verbosity dbStack extraArgs =+invoke+ :: ConfiguredProgram+ -> Verbosity+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -> PackageDBStack+ -> [String]+ -> IO ()+invoke ghcProg verbosity mbWorkDir dbStack extraArgs = runProgramInvocation verbosity invocation where- args = packageDbStackOpts hpi dbStack ++ extraArgs- invocation = programInvocation (hcPkgProgram hpi) args+ args = packageDbStackOpts dbStack ++ extraArgs+ invocation = programInvocationCwd mbWorkDir ghcProg args -- | Additional variations in the behaviour for 'register'. data RegisterOptions = RegisterOptions@@ -116,9 +125,7 @@ -- ^ 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'.+ -- single version of a single package. , registerSuppressFilesCheck :: Bool -- ^ Require that no checks are performed on the existence of package -- files mentioned in the registration info. This must be used if@@ -139,122 +146,128 @@ -- -- > hc-pkg register {filename | -} [--user | --global | --package-db] register- :: HcPkgInfo+ :: ConfiguredProgram -> Verbosity- -> PackageDBStack+ -> Maybe (SymbolicPath CWD (Dir from))+ -> PackageDBStackS from -> InstalledPackageInfo -> RegisterOptions -> IO ()-register hpi verbosity packagedbs pkgInfo registerOptions- | registerMultiInstance registerOptions- , not (nativeMultiInstance hpi || recacheMultiInstance hpi) =- dieWithException verbosity RegMultipleInstancePkg- | registerSuppressFilesCheck registerOptions- , not (suppressFilesCheck hpi) =- dieWithException verbosity SuppressingChecksOnFile- -- 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 =+register hpi verbosity mbWorkDir packagedbs pkgInfo registerOptions+ | registerMultiInstance registerOptions = do let pkgdb = registrationPackageDB packagedbs- writeRegistrationFileDirectly verbosity hpi pkgdb pkgInfo- recache hpi verbosity pkgdb+ writeRegistrationFileDirectly verbosity mbWorkDir pkgdb pkgInfo+ recache hpi verbosity mbWorkDir pkgdb | otherwise = runProgramInvocation verbosity- (registerInvocation hpi verbosity packagedbs pkgInfo registerOptions)+ (registerInvocation hpi (verbosityLevel verbosity) mbWorkDir packagedbs pkgInfo registerOptions) writeRegistrationFileDirectly :: Verbosity- -> HcPkgInfo- -> PackageDB+ -> Maybe (SymbolicPath CWD (Dir from))+ -> PackageDBS from -> InstalledPackageInfo -> IO ()-writeRegistrationFileDirectly verbosity hpi (SpecificPackageDB dir) pkgInfo- | supportsDirDbs hpi =- do- let pkgfile = dir </> prettyShow (installedUnitId pkgInfo) <.> "conf"- writeUTF8File pkgfile (showInstalledPackageInfo pkgInfo)- | otherwise =- dieWithException verbosity NoSupportDirStylePackageDb-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.- dieWithException verbosity OnlySupportSpecificPackageDb+writeRegistrationFileDirectly verbosity mbWorkDir package pkgInfo =+ case package of+ (SpecificPackageDB dir) -> do+ let pkgfile = interpretSymbolicPath mbWorkDir dir </> prettyShow (installedUnitId pkgInfo) <.> "conf"+ writeUTF8File pkgfile (showInstalledPackageInfo pkgInfo)+ _ -> do+ -- 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.+ dieWithException verbosity OnlySupportSpecificPackageDb -- | 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 =+unregister :: ConfiguredProgram -> Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageId -> IO ()+unregister hpi verbosity mbWorkDir packagedb pkgid = runProgramInvocation verbosity- (unregisterInvocation hpi verbosity packagedb pkgid)+ (unregisterInvocation hpi (verbosityLevel verbosity) mbWorkDir 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 =+recache :: ConfiguredProgram -> Verbosity -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBS from -> IO ()+recache hpi verbosity mbWorkDir packagedb = runProgramInvocation verbosity- (recacheInvocation hpi verbosity packagedb)+ (recacheInvocation hpi (verbosityLevel verbosity) mbWorkDir 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 =+expose+ :: ConfiguredProgram+ -> Verbosity+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -> PackageDB+ -> PackageId+ -> IO ()+expose hpi verbosity mbWorkDir packagedb pkgid = runProgramInvocation verbosity- (exposeInvocation hpi verbosity packagedb pkgid)+ (exposeInvocation hpi (verbosityLevel verbosity) mbWorkDir 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+describe+ :: ConfiguredProgram+ -> Verbosity+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -> PackageDBStack+ -> PackageId+ -> IO [InstalledPackageInfo]+describe ghcProg verbosity mbWorkDir packagedb pid = do output <- getProgramInvocationLBS verbosity- (describeInvocation hpi verbosity packagedb pid)+ (describeInvocation ghcProg (verbosityLevel verbosity) mbWorkDir packagedb pid) `catchIO` \_ -> return mempty case parsePackages output of Left ok -> return ok- _ -> dieWithException verbosity $ FailedToParseOutputDescribe (programId (hcPkgProgram hpi)) pid+ _ -> dieWithException verbosity $ FailedToParseOutputDescribe (programId ghcProg) 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 =+hide+ :: ConfiguredProgram+ -> Verbosity+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -> PackageDB+ -> PackageId+ -> IO ()+hide hpi verbosity mbWorkDir packagedb pkgid = runProgramInvocation verbosity- (hideInvocation hpi verbosity packagedb pkgid)+ (hideInvocation hpi (verbosityLevel verbosity) mbWorkDir 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+dump+ :: ConfiguredProgram+ -> Verbosity+ -> Maybe (SymbolicPath CWD (Dir from))+ -> PackageDBX (SymbolicPath from (Dir PkgDB))+ -> IO [InstalledPackageInfo]+dump ghcProg verbosity mbWorkDir packagedb = do output <- getProgramInvocationLBS verbosity- (dumpInvocation hpi verbosity packagedb)+ (dumpInvocation ghcProg (verbosityLevel verbosity) mbWorkDir packagedb) `catchIO` \e ->- dieWithException verbosity $ DumpFailed (programId (hcPkgProgram hpi)) (displayException e)+ dieWithException verbosity $ DumpFailed (programId ghcProg) (displayException e) case parsePackages output of Left ok -> return ok- _ -> dieWithException verbosity $ FailedToParseOutputDump (programId (hcPkgProgram hpi))+ _ -> dieWithException verbosity $ FailedToParseOutputDump (programId ghcProg) parsePackages :: LBS.ByteString -> Either [InstalledPackageInfo] [String] parsePackages lbs0 =@@ -283,22 +296,13 @@ go [] = [LBS.toStrict lbs] go (idx : idxs) = let (pfx, sfx) = LBS.splitAt idx lbs- in case foldr (<|>) Nothing $ map (`lbsStripPrefix` sfx) separators of+ in case foldr ((<|>) . (`LBS.stripPrefix` sfx)) Nothing separators of Just sfx' -> LBS.toStrict pfx : doSplit sfx' Nothing -> go idxs separators :: [LBS.ByteString] separators = ["\n---\n", "\r\n---\r\n", "\r---\r"] -lbsStripPrefix :: LBS.ByteString -> LBS.ByteString -> Maybe LBS.ByteString-#if MIN_VERSION_bytestring(0,10,8)-lbsStripPrefix pfx lbs = LBS.stripPrefix pfx lbs-#else-lbsStripPrefix pfx lbs- | LBS.isPrefixOf pfx lbs = Just (LBS.drop (LBS.length 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)@@ -313,7 +317,7 @@ , libraryDynDirs = mungePaths (libraryDynDirs pkginfo) , frameworkDirs = mungePaths (frameworkDirs pkginfo) , haddockInterfaces = mungePaths (haddockInterfaces pkginfo)- , haddockHTMLs = mungeUrls (haddockHTMLs pkginfo)+ , haddockHTMLs = mungePaths (mungeUrls (haddockHTMLs pkginfo)) } where mungePaths = map mungePath@@ -362,20 +366,21 @@ -- 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+ :: ConfiguredProgram -> Verbosity+ -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> IO [PackageId]-list hpi verbosity packagedb = do+list ghcProg verbosity mbWorkDir packagedb = do output <- getProgramInvocationOutput verbosity- (listInvocation hpi verbosity packagedb)- `catchIO` \_ -> dieWithException verbosity $ ListFailed (programId (hcPkgProgram hpi))+ (listInvocation ghcProg (verbosityLevel verbosity) mbWorkDir packagedb)+ `catchIO` \_ -> dieWithException verbosity $ ListFailed (programId ghcProg) case parsePackageIds output of Just ok -> return ok- _ -> dieWithException verbosity $ FailedToParseOutputList (programId (hcPkgProgram hpi))+ _ -> dieWithException verbosity $ FailedToParseOutputList (programId ghcProg) where parsePackageIds = traverse simpleParsec . words @@ -383,23 +388,24 @@ -- The program invocations -- -initInvocation :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation-initInvocation hpi verbosity path =- programInvocation (hcPkgProgram hpi) args+initInvocation :: ConfiguredProgram -> Verbosity -> FilePath -> ProgramInvocation+initInvocation ghcProg verbosity path =+ programInvocation ghcProg args where args = ["init", path]- ++ verbosityOpts hpi verbosity+ ++ verbosityOpts (verbosityLevel verbosity) registerInvocation- :: HcPkgInfo- -> Verbosity- -> PackageDBStack+ :: ConfiguredProgram+ -> VerbosityLevel+ -> Maybe (SymbolicPath CWD (Dir from))+ -> PackageDBStackS from -> InstalledPackageInfo -> RegisterOptions -> ProgramInvocation-registerInvocation hpi verbosity packagedbs pkgInfo registerOptions =- (programInvocation (hcPkgProgram hpi) (args "-"))+registerInvocation ghcProg verbosity mbWorkDir packagedbs pkgInfo registerOptions =+ (programInvocationCwd mbWorkDir ghcProg (args "-")) { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo pkgInfo , progInvokeInputEncoding = IOEncodingUTF8 }@@ -411,131 +417,135 @@ args file = [cmdname, file]- ++ packageDbStackOpts hpi packagedbs+ ++ packageDbStackOpts packagedbs ++ [ "--enable-multi-instance" | registerMultiInstance registerOptions ] ++ [ "--force-files" | registerSuppressFilesCheck registerOptions ]- ++ verbosityOpts hpi verbosity+ ++ verbosityOpts verbosity unregisterInvocation- :: HcPkgInfo- -> Verbosity+ :: ConfiguredProgram+ -> VerbosityLevel+ -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageId -> ProgramInvocation-unregisterInvocation hpi verbosity packagedb pkgid =- programInvocation (hcPkgProgram hpi) $- ["unregister", packageDbOpts hpi packagedb, prettyShow pkgid]- ++ verbosityOpts hpi verbosity+unregisterInvocation ghcProg verbosity mbWorkDir packagedb pkgid =+ programInvocationCwd mbWorkDir ghcProg $+ ["unregister", packageDbOpts packagedb, prettyShow pkgid]+ ++ verbosityOpts verbosity recacheInvocation- :: HcPkgInfo- -> Verbosity- -> PackageDB+ :: ConfiguredProgram+ -> VerbosityLevel+ -> Maybe (SymbolicPath CWD (Dir from))+ -> PackageDBS from -> ProgramInvocation-recacheInvocation hpi verbosity packagedb =- programInvocation (hcPkgProgram hpi) $- ["recache", packageDbOpts hpi packagedb]- ++ verbosityOpts hpi verbosity+recacheInvocation ghcProg verbosity mbWorkDir packagedb =+ programInvocationCwd mbWorkDir ghcProg $+ ["recache", packageDbOpts packagedb]+ ++ verbosityOpts verbosity exposeInvocation- :: HcPkgInfo- -> Verbosity+ :: ConfiguredProgram+ -> VerbosityLevel+ -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageId -> ProgramInvocation-exposeInvocation hpi verbosity packagedb pkgid =- programInvocation (hcPkgProgram hpi) $- ["expose", packageDbOpts hpi packagedb, prettyShow pkgid]- ++ verbosityOpts hpi verbosity+exposeInvocation ghcProg verbosity mbWorkDir packagedb pkgid =+ programInvocationCwd mbWorkDir ghcProg $+ ["expose", packageDbOpts packagedb, prettyShow pkgid]+ ++ verbosityOpts verbosity describeInvocation- :: HcPkgInfo- -> Verbosity+ :: ConfiguredProgram+ -> VerbosityLevel+ -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDBStack -> PackageId -> ProgramInvocation-describeInvocation hpi verbosity packagedbs pkgid =- programInvocation (hcPkgProgram hpi) $+describeInvocation ghcProg verbosity mbWorkDir packagedbs pkgid =+ programInvocationCwd mbWorkDir ghcProg $ ["describe", prettyShow pkgid]- ++ packageDbStackOpts hpi packagedbs- ++ verbosityOpts hpi verbosity+ ++ packageDbStackOpts packagedbs+ ++ verbosityOpts verbosity hideInvocation- :: HcPkgInfo- -> Verbosity+ :: ConfiguredProgram+ -> VerbosityLevel+ -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageId -> ProgramInvocation-hideInvocation hpi verbosity packagedb pkgid =- programInvocation (hcPkgProgram hpi) $- ["hide", packageDbOpts hpi packagedb, prettyShow pkgid]- ++ verbosityOpts hpi verbosity+hideInvocation ghcProg verbosity mbWorkDir packagedb pkgid =+ programInvocationCwd mbWorkDir ghcProg $+ ["hide", packageDbOpts packagedb, prettyShow pkgid]+ ++ verbosityOpts verbosity -dumpInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation-dumpInvocation hpi _verbosity packagedb =- (programInvocation (hcPkgProgram hpi) args)+dumpInvocation+ :: ConfiguredProgram+ -> VerbosityLevel+ -> Maybe (SymbolicPath CWD (Dir from))+ -> PackageDBX (SymbolicPath from (Dir PkgDB))+ -> ProgramInvocation+dumpInvocation ghcProg _verbosity mbWorkDir packagedb =+ (programInvocationCwd mbWorkDir ghcProg args) { progInvokeOutputEncoding = IOEncodingUTF8 } where args =- ["dump", packageDbOpts hpi packagedb]- ++ verbosityOpts hpi silent+ ["dump", packageDbOpts packagedb]+ ++ verbosityOpts Silent --- We use verbosity level 'silent' because it is important that we+-- 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)+listInvocation+ :: ConfiguredProgram+ -> VerbosityLevel+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -> PackageDB+ -> ProgramInvocation+listInvocation ghcProg _verbosity mbWorkDir packagedb =+ (programInvocationCwd mbWorkDir ghcProg args) { progInvokeOutputEncoding = IOEncodingUTF8 } where args =- ["list", "--simple-output", packageDbOpts hpi packagedb]- ++ verbosityOpts hpi silent+ ["list", "--simple-output", packageDbOpts packagedb]+ ++ verbosityOpts Silent --- We use verbosity level 'silent' because it is important that we+-- 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+packageDbStackOpts :: PackageDBStackS from -> [String]+packageDbStackOpts dbstack = case dbstack of+ (GlobalPackageDB : UserPackageDB : dbs) ->+ "--global"+ : "--user"+ : map specific dbs+ (GlobalPackageDB : dbs) ->+ "--global"+ : "--no-user-package-db"+ : map specific dbs+ _ -> ierror where- specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db+ specific (SpecificPackageDB db) = "--package-db=" ++ interpretSymbolicPathCWD 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"--packageDbOpts :: HcPkgInfo -> PackageDB -> String-packageDbOpts _ GlobalPackageDB = "--global"-packageDbOpts _ UserPackageDB = "--user"-packageDbOpts hpi (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db+packageDbOpts :: PackageDBX (SymbolicPath from (Dir PkgDB)) -> String+packageDbOpts GlobalPackageDB = "--global"+packageDbOpts UserPackageDB = "--user"+packageDbOpts (SpecificPackageDB db) = "--package-db=" ++ interpretSymbolicPathCWD db -verbosityOpts :: HcPkgInfo -> Verbosity -> [String]-verbosityOpts hpi v- | noVerboseFlag hpi =- []- | v >= deafening = ["-v2"]- | v == silent = ["-v0"]+verbosityOpts :: VerbosityLevel -> [String]+verbosityOpts v+ | v >= Deafening = ["-v2"]+ | v == Silent = ["-v0"] | otherwise = []
src/Distribution/Simple/Program/Hpc.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -19,13 +20,12 @@ 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.Simple.Utils+import Distribution.Utils.Path import Distribution.Verbosity import Distribution.Version @@ -37,19 +37,20 @@ -- library as a dependency can still work, but those that include the library -- modules directly (in other-modules) don't. markup- :: ConfiguredProgram+ :: Maybe (SymbolicPath CWD (Dir Pkg))+ -> ConfiguredProgram -> Version -> Verbosity- -> FilePath+ -> SymbolicPath Pkg File -- ^ Path to .tix file- -> [FilePath]+ -> [SymbolicPath Pkg (Dir Mix)] -- ^ Paths to .mix file directories- -> FilePath+ -> SymbolicPath Pkg (Dir Artifacts) -- ^ 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+markup mbWorkDir hpc hpcVer verbosity tixFile hpcDirs destDir included = do hpcDirs' <- if withinRange hpcVer (orLaterVersion version07) then return hpcDirs@@ -69,69 +70,72 @@ return passedDirs -- Prior to GHC 8.0, hpc assumes all .mix paths are relative.- hpcDirs'' <- traverse makeRelativeToCurrentDirectory hpcDirs'+ hpcDirs'' <- traverse (tryMakeRelative mbWorkDir) hpcDirs' runProgramInvocation verbosity- (markupInvocation hpc tixFile hpcDirs'' destDir included)+ (markupInvocation mbWorkDir hpc tixFile hpcDirs'' destDir included) where version07 = mkVersion [0, 7] (passedDirs, droppedDirs) = splitAt 1 hpcDirs markupInvocation- :: ConfiguredProgram- -> FilePath+ :: Maybe (SymbolicPath CWD (Dir Pkg))+ -> ConfiguredProgram+ -> SymbolicPath Pkg File -- ^ Path to .tix file- -> [FilePath]+ -> [SymbolicPath Pkg (Dir Mix)] -- ^ Paths to .mix file directories- -> FilePath+ -> SymbolicPath Pkg (Dir Artifacts) -- ^ Path where html output should be -- located -> [ModuleName] -- ^ List of modules to include -> ProgramInvocation-markupInvocation hpc tixFile hpcDirs destDir included =+markupInvocation mbWorkDir hpc tixFile hpcDirs destDir included = let args = [ "markup"- , tixFile- , "--destdir=" ++ destDir+ , getSymbolicPath tixFile+ , "--destdir=" ++ getSymbolicPath destDir ]- ++ map ("--hpcdir=" ++) hpcDirs+ ++ map (("--hpcdir=" ++) . getSymbolicPath) hpcDirs ++ [ "--include=" ++ prettyShow moduleName | moduleName <- included ]- in programInvocation hpc args+ in programInvocationCwd mbWorkDir hpc args union- :: ConfiguredProgram+ :: Maybe (SymbolicPath CWD (Dir Pkg))+ -> ConfiguredProgram -> Verbosity- -> [FilePath]+ -> [SymbolicPath Pkg File] -- ^ Paths to .tix files- -> FilePath+ -> SymbolicPath Pkg File -- ^ Path to resultant .tix file -> [ModuleName] -- ^ List of modules to exclude from union -> IO ()-union hpc verbosity tixFiles outFile excluded =+union mbWorkDir hpc verbosity tixFiles outFile excluded = runProgramInvocation verbosity- (unionInvocation hpc tixFiles outFile excluded)+ (unionInvocation mbWorkDir hpc tixFiles outFile excluded) unionInvocation- :: ConfiguredProgram- -> [FilePath]+ :: Maybe (SymbolicPath CWD (Dir Pkg))+ -> ConfiguredProgram+ -> [SymbolicPath Pkg File] -- ^ Paths to .tix files- -> FilePath+ -> SymbolicPath Pkg File -- ^ Path to resultant .tix file -> [ModuleName] -- ^ List of modules to exclude from union -> ProgramInvocation-unionInvocation hpc tixFiles outFile excluded =- programInvocation hpc $+unionInvocation mbWorkDir hpc tixFiles outFile excluded =+ programInvocationCwd mbWorkDir hpc $ concat [ ["sum", "--union"]- , tixFiles- , ["--output=" ++ outFile]+ , map getSymbolicPath tixFiles+ , ["--output=" ++ getSymbolicPath outFile] , [ "--exclude=" ++ prettyShow moduleName | moduleName <- excluded ]
src/Distribution/Simple/Program/Internal.hs view
@@ -17,21 +17,28 @@ -- | Extract the version number from the output of 'strip --version'. ----- Invoking "strip --version" gives very inconsistent results. We ignore--- everything in parentheses (see #2497), look for the first word that starts--- with a number, and try parsing out the first two components of it. Non-GNU--- 'strip' doesn't appear to have a version flag.+-- Invoking "strip --version" gives very inconsistent results. We+-- ignore everything in parentheses (see #2497), look for the first+-- word that starts with a number, and try parsing out the first two+-- components of it. Non-GNU, non-LLVM 'strip' doesn't appear to have+-- a version flag. stripExtractVersion :: String -> String stripExtractVersion str = let numeric "" = False numeric (x : _) = isDigit x + closingParentheses =+ [ ")"+ , -- LLVM strip outputs "llvm-strip, compatible with GNU strip\nLLVM (http://llvm.org/):\n..."+ "):"+ ]+ -- 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 && "(" `isPrefixOf` x = filterPar' (n + 1) (safeTail x : xs)+ | n > 0 && any (`isSuffixOf` x) closingParentheses = filterPar' (n - 1) xs | n > 0 = filterPar' n xs | otherwise = x : filterPar' n xs
src/Distribution/Simple/Program/Ld.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -22,14 +23,14 @@ import Distribution.Simple.Flag ( fromFlagOrDefault )-import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..))+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..), mbWorkDirLBI) import Distribution.Simple.Program.ResponseFile ( withResponseFile ) import Distribution.Simple.Program.Run ( ProgramInvocation , multiStageProgramInvocation- , programInvocation+ , programInvocationCwd , runProgramInvocation ) import Distribution.Simple.Program.Types@@ -41,6 +42,7 @@ import Distribution.Simple.Utils ( defaultTempFileOptions )+import Distribution.Utils.Path import Distribution.Verbosity ( Verbosity )@@ -48,59 +50,61 @@ import System.Directory ( renameFile )-import System.FilePath- ( takeDirectory- , (<.>)- ) -- | Call @ld -r@ to link a bunch of object files together. combineObjectFiles :: Verbosity -> LocalBuildInfo -> ConfiguredProgram- -> FilePath- -> [FilePath]+ -> SymbolicPath Pkg File+ -> [SymbolicPath Pkg File] -> IO ()-combineObjectFiles verbosity lbi ld target files = do+combineObjectFiles verbosity lbi ldProg 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]-- initialArgs = ["-r", "-o", target]- middleArgs = ["-r", "-o", target, tmpfile]- finalArgs = middleArgs+ let+ -- See Note [Symbolic paths] in Distribution.Utils.Path+ u :: SymbolicPath Pkg to -> FilePath+ u = interpretSymbolicPathCWD+ i = interpretSymbolicPath mbWorkDir+ mbWorkDir = mbWorkDirLBI lbi - simple = programInvocation ld simpleArgs- initial = programInvocation ld initialArgs- middle = programInvocation ld middleArgs- final = programInvocation ld finalArgs+ simpleArgs = ["-r", "-o", u target]+ initialArgs = ["-r", "-o", u target]+ middleArgs = ["-r", "-o", u target, u tmpfile]+ finalArgs = middleArgs - targetDir = takeDirectory target+ ld = programInvocationCwd (mbWorkDirLBI lbi) ldProg+ simple = ld simpleArgs+ initial = ld initialArgs+ middle = ld middleArgs+ final = ld finalArgs - invokeWithResponesFile :: FilePath -> ProgramInvocation- invokeWithResponesFile atFile =- programInvocation ld $ simpleArgs ++ ['@' : atFile]+ invokeWithResponseFile :: FilePath -> ProgramInvocation+ invokeWithResponseFile atFile =+ ld $ simpleArgs ++ ['@' : atFile] - oldVersionManualOverride =- 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 =- not (arResponseFilesSupported (compiler lbi))+ oldVersionManualOverride =+ 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 =+ 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- where- 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+ renameFile (i target) (i tmpfile) run invs++ if oldVersionManualOverride || responseArgumentsNotSupported+ then run $ multiStageProgramInvocation simple (initial, middle, final) (map getSymbolicPath files)+ else withResponseFile verbosity defaultTempFileOptions "ld.rsp" Nothing (map getSymbolicPath files) $+ \path -> runProgramInvocation verbosity $ invokeWithResponseFile path+ where+ tmpfile = target <.> "tmp" -- perhaps should use a proper temp file
src/Distribution/Simple/Program/ResponseFile.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -19,14 +20,13 @@ import Distribution.Compat.Prelude import Distribution.Simple.Utils (TempFileOptions, debug, withTempFileEx)+import Distribution.Utils.Path import Distribution.Verbosity withResponseFile :: Verbosity -> TempFileOptions- -> FilePath- -- ^ Working directory to create response file in.- -> FilePath+ -> String -- ^ Template for response file name. -> Maybe TextEncoding -- ^ Encoding to use for response file contents.@@ -34,10 +34,13 @@ -- ^ Arguments to put into response file. -> (FilePath -> IO a) -> IO a-withResponseFile verbosity tmpFileOpts workDir fileNameTemplate encoding arguments f =- withTempFileEx tmpFileOpts workDir fileNameTemplate $ \responseFileName hf -> do+withResponseFile verbosity tmpFileOpts fileNameTemplate encoding arguments f =+ withTempFileEx tmpFileOpts fileNameTemplate $ \responsePath hf -> do+ let responseFileName = getSymbolicPath responsePath traverse_ (hSetEncoding hf) encoding- let responseContents = unlines $ map escapeResponseFileArg arguments+ let responseContents =+ unlines $+ map escapeResponseFileArg arguments hPutStr hf responseContents hClose hf debug verbosity $ responseFileName ++ " contents: <<<"
src/Distribution/Simple/Program/Run.hs view
@@ -1,6 +1,8 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- @@ -19,6 +21,7 @@ , emptyProgramInvocation , simpleProgramInvocation , programInvocation+ , programInvocationCwd , multiStageProgramInvocation , runProgramInvocation , getProgramInvocationOutput@@ -26,6 +29,7 @@ , getProgramInvocationOutputAndErrors , getProgramInvocationLBSAndErrors , getEffectiveEnvironment+ , getFullEnvironment ) where import Distribution.Compat.Prelude@@ -36,6 +40,7 @@ import Distribution.Simple.Program.Types import Distribution.Simple.Utils import Distribution.Utils.Generic+import Distribution.Utils.Path import Distribution.Verbosity import qualified Data.ByteString.Lazy as LBS@@ -56,6 +61,7 @@ , progInvokeInputEncoding :: IOEncoding -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'. , progInvokeOutputEncoding :: IOEncoding+ , progInvokeWhen :: IO Bool } data IOEncoding@@ -77,16 +83,23 @@ , progInvokeInput = Nothing , progInvokeInputEncoding = IOEncodingText , progInvokeOutputEncoding = IOEncodingText+ , progInvokeWhen = pure True } -simpleProgramInvocation :: FilePath -> [String] -> ProgramInvocation+simpleProgramInvocation+ :: FilePath+ -> [String]+ -> ProgramInvocation simpleProgramInvocation path args = emptyProgramInvocation { progInvokePath = path , progInvokeArgs = args } -programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation+programInvocation+ :: ConfiguredProgram+ -> [String]+ -> ProgramInvocation programInvocation prog args = emptyProgramInvocation { progInvokePath = programPath prog@@ -97,6 +110,17 @@ , progInvokeEnv = programOverrideEnv prog } +programInvocationCwd+ :: forall to+ . Maybe (SymbolicPath CWD (Dir to))+ -> ConfiguredProgram+ -> [String]+ -> ProgramInvocation+programInvocationCwd mbWorkDir prog args =+ (programInvocation prog args)+ { progInvokeCwd = fmap getSymbolicPath mbWorkDir+ }+ runProgramInvocation :: Verbosity -> ProgramInvocation -> IO () runProgramInvocation verbosity@@ -106,8 +130,7 @@ , progInvokeEnv = [] , progInvokeCwd = Nothing , progInvokeInput = Nothing- } =- rawSystemExit verbosity path args+ } = rawSystemExit verbosity Nothing path args runProgramInvocation verbosity ProgramInvocation@@ -214,6 +237,12 @@ -- | Return the current environment extended with the given overrides. -- If an entry is specified twice in @overrides@, the second entry takes -- precedence.+--+-- getEffectiveEnvironment returns 'Nothing' when there are no overrides.+-- It returns an argument that is suitable to pass directly to 'CreateProcess' to+-- override the environment.+-- If you need the full environment to manipulate further, even when there are no overrides,+-- then call 'getFullEnvironment'. getEffectiveEnvironment :: [(String, Maybe String)] -> IO (Maybe [(String, String)])@@ -224,6 +253,15 @@ apply os env = foldl' (flip update) env os update (var, Nothing) = Map.delete var update (var, Just val) = Map.insert var val++-- | Like 'getEffectiveEnvironment', but when no overrides are specified,+-- returns the full environment instead of 'Nothing'.+getFullEnvironment+ :: [(String, Maybe String)]+ -> IO [(String, String)]+getFullEnvironment overrides = do+ menv <- getEffectiveEnvironment overrides+ maybe getEnvironment return menv -- | 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
src/Distribution/Simple/Program/Script.hs view
@@ -82,7 +82,7 @@ ++ ["cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd] ++ case minput of Nothing ->- [path ++ concatMap (' ' :) args]+ [unwords (path : args)] Just input -> ["("] ++ ["echo " ++ escape line | line <- lines $ iodataToText input]
src/Distribution/Simple/Program/Strip.hs view
@@ -34,7 +34,7 @@ -- have the strip program anyway. warn verbosity $ "Unable to strip executable or library '"- ++ (takeBaseName path)+ ++ takeBaseName path ++ "' (missing the 'strip' program)" stripExe :: Verbosity -> Platform -> ProgramDb -> FilePath -> IO ()@@ -58,6 +58,10 @@ IOS -> return () AIX -> return () Solaris -> return ()+ OpenBSD ->+ -- '--strip-unneeded' sometimes strips too much on OpenBSD.+ -- -- See https://cvsweb.openbsd.org/cgi-bin/cvsweb/~checkout~/ports/lang/ghc/patches/patch-libraries_Cabal_Cabal_Distribution_Simple_Program_Strip_hs+ return () Windows -> -- Stripping triggers a bug in 'strip.exe' for -- libraries with lots identically named modules. See@@ -75,7 +79,7 @@ _ -> warn verbosity $ "Unable to strip library '"- ++ (takeBaseName path)+ ++ takeBaseName path ++ "' (version of 'strip' too old; " ++ "requires >= 2.18 on 32-bit Linux)" _ -> runStrip verbosity progdb path args
src/Distribution/Simple/Program/Types.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}@@ -107,7 +106,7 @@ ProgramSearchPathDir FilePath | -- | The system default ProgramSearchPathDefault- deriving (Eq, Generic, Typeable)+ deriving (Show, Eq, Generic) instance Binary ProgramSearchPathEntry instance Structured ProgramSearchPathEntry@@ -143,11 +142,11 @@ , 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+ -- of this 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)+ deriving (Eq, Generic, Read, Show) instance Binary ConfiguredProgram instance Structured ConfiguredProgram@@ -160,7 +159,7 @@ UserSpecified {locationPath :: FilePath} | -- | The program was found automatically. FoundOnSystem {locationPath :: FilePath}- deriving (Eq, Generic, Read, Show, Typeable)+ deriving (Eq, Generic, Read, Show) instance Binary ProgramLocation instance Structured ProgramLocation
src/Distribution/Simple/Register.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -28,7 +29,9 @@ -- generation and the unregister feature are not well used or tested. module Distribution.Simple.Register ( register+ , registerWithHandles , unregister+ , unregisterWithHandles , internalPackageDBPath , initPackageDB , doesPackageDBExist@@ -58,7 +61,6 @@ import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS-import qualified Distribution.Simple.HaskellSuite as HaskellSuite import qualified Distribution.Simple.PackageIndex as Index import qualified Distribution.Simple.UHC as UHC @@ -76,14 +78,17 @@ import Distribution.Simple.Program import qualified Distribution.Simple.Program.HcPkg as HcPkg import Distribution.Simple.Program.Script+import Distribution.Simple.Setup.Common+import Distribution.Simple.Setup.Haddock (HaddockTarget (ForDevelopment)) import Distribution.Simple.Setup.Register import Distribution.Simple.Utils import Distribution.System import Distribution.Utils.MapAccum+import Distribution.Utils.Path import Distribution.Verbosity as Verbosity import Distribution.Version import System.Directory-import System.FilePath (isAbsolute, (<.>), (</>))+import System.FilePath (isAbsolute) import qualified Data.ByteString.Lazy.Char8 as BS.Char8 @@ -96,45 +101,51 @@ -> RegisterFlags -- ^ Install in the user's database?; verbose -> IO ()-register pkg_descr lbi0 flags =+register = registerWithHandles defaultVerbosityHandles++registerWithHandles+ :: VerbosityHandles+ -> PackageDescription+ -> LocalBuildInfo+ -> RegisterFlags+ -- ^ Install in the user's database?; verbose+ -> IO ()+registerWithHandles verbHandles pkg_descr lbi0 flags = do -- 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)+ let verbosity = mkVerbosity verbHandles (fromFlag $ registerVerbosity flags)+ targets <- readTargetInfos verbosity pkg_descr lbi0 $ registerTargets 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)+ -- 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)+ (_, 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 verbHandles 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)+ registerAll verbHandles pkg_descr lbi0 flags (catMaybes ipi_mbs) generateOne- :: PackageDescription+ :: VerbosityHandles+ -> PackageDescription -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo -> RegisterFlags -> IO InstalledPackageInfo-generateOne pkg lib lbi clbi regFlags =+generateOne verbHandles pkg lib lbi clbi regFlags = do- absPackageDBs <- absolutePackageDBPaths packageDbs+ absPackageDBs <- absolutePackageDBPaths mbWorkDir packageDbs installedPkgInfo <- generateRegistrationInfo verbosity@@ -149,34 +160,38 @@ info verbosity (IPI.showInstalledPackageInfo installedPkgInfo) return installedPkgInfo where+ common = registerCommonFlags regFlags 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 $+ ordNub $ withPackageDB lbi ++ maybeToList (flagToMaybe (regPackageDB regFlags))- distPref = fromFlag (regDistPref regFlags)- verbosity = fromFlag (regVerbosity regFlags)+ distPref = fromFlag $ setupDistPref common+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ mbWorkDir = flagToMaybe $ setupWorkingDir common registerAll- :: PackageDescription+ :: VerbosityHandles+ -> PackageDescription -> LocalBuildInfo -> RegisterFlags -> [InstalledPackageInfo] -> IO ()-registerAll pkg lbi regFlags ipis =+registerAll verbHandles pkg lbi regFlags ipis = do- when (fromFlag (regPrintId regFlags)) $ do+ when (Just True == flagToMaybe (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))+ $ notice verbosity+ $ prettyShow (IPI.installedUnitId installedPkgInfo) -- Three different modes: case () of@@ -195,15 +210,17 @@ verbosity (compiler lbi) (withPrograms lbi)+ (mbWorkDirLBI lbi) packageDbs ipi HcPkg.defaultRegisterOptions where modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) regFile =- fromMaybe- (prettyShow (packageId pkg) <.> "conf")- (fromFlag (regGenPkgConf regFlags))+ interpretSymbolicPathLBI lbi $+ fromMaybe+ (makeSymbolicPath (prettyShow (packageId pkg) <.> "conf"))+ (fromFlag (regGenPkgConf regFlags)) modeGenerateRegScript = fromFlag (regGenScript regFlags) @@ -211,10 +228,12 @@ -- registering into a totally different db stack can -- fail if dependencies cannot be satisfied. packageDbs =- nub $+ ordNub $ withPackageDB lbi ++ maybeToList (flagToMaybe (regPackageDB regFlags))- verbosity = fromFlag (regVerbosity regFlags)+ common = registerCommonFlags regFlags+ verbosity = mkVerbosity verbHandles (fromFlag (setupVerbosity common))+ mbWorkDir = mbWorkDirLBI lbi writeRegistrationFileOrDirectory = do -- Handles overwriting both directory and file@@ -245,7 +264,7 @@ "Registration scripts are not implemented for this compiler" (compiler lbi) (withPrograms lbi)- (writeHcPkgRegisterScript verbosity ipis packageDbs)+ (writeHcPkgRegisterScript verbosity mbWorkDir ipis packageDbs) generateRegistrationInfo :: Verbosity@@ -255,13 +274,11 @@ -> ComponentLocalBuildInfo -> Bool -> Bool- -> FilePath+ -> SymbolicPath Pkg (Dir Dist) -> PackageDB -> IO InstalledPackageInfo generateRegistrationInfo verbosity pkg lib lbi clbi inplace reloc distPref packageDb = do- -- TODO: eliminate pwd!- pwd <- getCurrentDirectory-+ inplaceDir <- absoluteWorkingDirLBI lbi installedPkgInfo <- if inplace then -- NB: With an inplace installation, the user may run './Setup@@ -270,7 +287,7 @@ return ( inplaceInstalledPackageInfo- pwd+ inplaceDir distPref pkg (mkAbiHash "inplace")@@ -306,7 +323,7 @@ abiHash :: Verbosity -> PackageDescription- -> FilePath+ -> SymbolicPath Pkg (Dir Dist) -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo@@ -337,7 +354,7 @@ -> PackageDB -> IO InstalledPackageInfo relocRegistrationInfo verbosity pkg lib lbi clbi abi_hash packageDb =- case (compilerFlavor (compiler lbi)) of+ case compilerFlavor (compiler lbi) of GHC -> do fs <- GHC.pkgRoot verbosity lbi packageDb return@@ -353,22 +370,20 @@ initPackageDB :: Verbosity -> Compiler -> ProgramDb -> FilePath -> IO () initPackageDB verbosity comp progdb dbPath =- createPackageDB verbosity comp progdb False dbPath+ createPackageDB verbosity comp progdb dbPath -- | Create an empty package DB at the specified location. createPackageDB :: Verbosity -> Compiler -> ProgramDb- -> Bool -> FilePath -> IO ()-createPackageDB verbosity comp progdb preferCompat dbPath =+createPackageDB verbosity comp progdb dbPath = case compilerFlavor comp of- GHC -> HcPkg.init (GHC.hcPkgInfo progdb) verbosity preferCompat dbPath- GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity False dbPath+ GHC -> HcPkg.init (GHC.hcPkgInfo progdb) verbosity dbPath+ GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity dbPath UHC -> return ()- HaskellSuite _ -> HaskellSuite.initPackageDB verbosity progdb dbPath _ -> dieWithException verbosity CreatePackageDB doesPackageDBExist :: FilePath -> IO Bool@@ -380,14 +395,9 @@ else doesFileExist dbPath deletePackageDB :: FilePath -> IO ()-deletePackageDB dbPath = do+deletePackageDB = -- 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+ removePathForcibly -- | Run @hc-pkg@ using a given package DB stack, directly forwarding the -- provided command-line arguments to it.@@ -395,23 +405,24 @@ :: Verbosity -> Compiler -> ProgramDb+ -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDBStack -> [String] -> IO ()-invokeHcPkg verbosity comp progdb dbStack extraArgs =+invokeHcPkg verbosity comp progdb mbWorkDir dbStack extraArgs = withHcPkg verbosity "invokeHcPkg" comp progdb- (\hpi -> HcPkg.invoke hpi verbosity dbStack extraArgs)+ (\hpi -> HcPkg.invoke hpi verbosity mbWorkDir dbStack extraArgs) withHcPkg :: Verbosity -> String -> Compiler -> ProgramDb- -> (HcPkg.HcPkgInfo -> IO a)+ -> (HcPkg.ConfiguredProgram -> IO a) -> IO a withHcPkg verbosity name comp progdb f = case compilerFlavor comp of@@ -423,34 +434,35 @@ :: Verbosity -> Compiler -> ProgramDb- -> PackageDBStack+ -> Maybe (SymbolicPath CWD (Dir from))+ -> PackageDBStackS from -> InstalledPackageInfo -> HcPkg.RegisterOptions -> IO ()-registerPackage verbosity comp progdb packageDbs installedPkgInfo registerOptions =+registerPackage verbosity comp progdb mbWorkDir packageDbs installedPkgInfo registerOptions = case compilerFlavor comp of- GHC -> GHC.registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions- GHCJS -> GHCJS.registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions- HaskellSuite{} ->- HaskellSuite.registerPackage verbosity progdb packageDbs installedPkgInfo+ GHC -> GHC.registerPackage verbosity progdb mbWorkDir packageDbs installedPkgInfo registerOptions+ GHCJS -> GHCJS.registerPackage verbosity progdb mbWorkDir packageDbs installedPkgInfo registerOptions _ | HcPkg.registerMultiInstance registerOptions -> dieWithException verbosity RegisMultiplePkgNotSupported- UHC -> UHC.registerPackage verbosity comp progdb packageDbs installedPkgInfo+ UHC -> UHC.registerPackage verbosity mbWorkDir comp progdb packageDbs installedPkgInfo _ -> dieWithException verbosity RegisteringNotImplemented writeHcPkgRegisterScript :: Verbosity+ -> Maybe (SymbolicPath CWD (Dir Pkg)) -> [InstalledPackageInfo] -> PackageDBStack- -> HcPkg.HcPkgInfo+ -> HcPkg.ConfiguredProgram -> IO ()-writeHcPkgRegisterScript verbosity ipis packageDbs hpi = do+writeHcPkgRegisterScript verbosity mbWorkDir ipis packageDbs hpi = do let genScript installedPkgInfo = let invocation = HcPkg.registerInvocation hpi- Verbosity.normal+ Verbosity.Normal+ mbWorkDir packageDbs installedPkgInfo HcPkg.defaultRegisterOptions@@ -459,14 +471,15 @@ -- TODO: Do something more robust here regScript = unlines scripts - info verbosity ("Creating package registration script: " ++ regScriptFileName)- writeUTF8File regScriptFileName regScript- setFileExecutable regScriptFileName+ let out_file = interpretSymbolicPath mbWorkDir regScriptFileName+ info verbosity ("Creating package registration script: " ++ out_file)+ writeUTF8File out_file regScript+ setFileExecutable out_file -regScriptFileName :: FilePath+regScriptFileName :: SymbolicPath Pkg File regScriptFileName = case buildOS of- Windows -> "register.bat"- _ -> "register.sh"+ Windows -> makeSymbolicPath "register.bat"+ _ -> makeSymbolicPath "register.sh" -- ----------------------------------------------------------------------------- -- Making the InstalledPackageInfo@@ -489,9 +502,9 @@ { IPI.sourcePackageId = packageId pkg , IPI.installedUnitId = componentUnitId clbi , IPI.installedComponentId_ = componentComponentId clbi- , IPI.instantiatedWith = componentInstantiatedWith clbi+ , IPI.instantiatedWith = expectLibraryComponent (maybeComponentInstantiatedWith clbi) , IPI.sourceLibName = libName lib- , IPI.compatPackageKey = componentCompatPackageKey clbi+ , IPI.compatPackageKey = expectLibraryComponent (maybeComponentCompatPackageKey clbi) , -- If GHC >= 8.4 we register with SDPX, otherwise with legacy license IPI.license = if ghc84@@ -510,28 +523,27 @@ , IPI.indefinite = componentIsIndefinite clbi , IPI.exposed = libExposed lib , IPI.exposedModules =- componentExposedModules clbi+ expectLibraryComponent (maybeComponentExposedModules clbi) -- add virtual modules into the list of exposed modules for the -- package database as well.- ++ map (\name -> IPI.ExposedModule name Nothing) (virtualModules bi)+ ++ map (`IPI.ExposedModule` 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.libraryBytecodeDirs =+ [bytecodelibdir installDirs | hasLibrary && withBytecodeLib lbi] , IPI.dataDir = datadir installDirs , IPI.hsLibraries =- ( if hasLibrary- then [getHSLibraryName (componentUnitId clbi)]- else []- )+ [getHSLibraryName (componentUnitId clbi) | hasLibrary] ++ extraBundledLibs bi , IPI.extraLibraries = extraLibs bi , IPI.extraLibrariesStatic = extraLibsStatic bi , IPI.extraGHCiLibraries = extraGHCiLibs bi , IPI.includeDirs = absinc ++ adjustRelIncDirs relinc- , IPI.includes = includes bi+ , IPI.includes = map getSymbolicPath $ includes bi , IPI.depends = depends , IPI.abiDepends = [] -- due to #5465 , IPI.ccOptions = [] -- Note. NOT ccOptions bi!@@ -539,10 +551,11 @@ -- 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.frameworks = map getSymbolicPath $ frameworks bi+ , IPI.frameworkDirs = map getSymbolicPath $ extraFrameworkDirs bi+ , IPI.haddockInterfaces =+ [haddockdir installDirs </> haddockLibraryPath pkg lib | hasModules]+ , IPI.haddockHTMLs = [htmldir installDirs | hasModules] , IPI.pkgRoot = Nothing , IPI.libVisibility = libVisibility lib }@@ -555,7 +568,7 @@ -- 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)+ (absinc, relinc) = partition isAbsolute (map getSymbolicPath $ includeDirs bi) hasModules = not $ null (allLibModules lib clbi) comp = compiler lbi hasLibrary =@@ -570,6 +583,7 @@ hasJsSupport = case hostPlatform lbi of Platform JavaScript _ -> True _ -> False+ extraLibDirs' = map getSymbolicPath $ extraLibDirs bi libdirsStatic | hasLibrary = libdir installDirs : extraLibDirsStaticOrFallback | otherwise = extraLibDirsStaticOrFallback@@ -578,20 +592,22 @@ -- distinction between fully static linking and otherwise. -- Fall back to the normal library dirs in that case. extraLibDirsStaticOrFallback = case extraLibDirsStatic bi of- [] -> extraLibDirs bi- dirs -> dirs+ [] -> extraLibDirs'+ dirs -> map getSymbolicPath dirs (libdirs, dynlibdirs) | not hasLibrary =- (extraLibDirs bi, [])+ (extraLibDirs', []) -- 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+ ( libdir installDirs : extraLibDirs'+ , dynlibdir installDirs : extraLibDirs' ) | otherwise =- (libdir installDirs : dynlibdir installDirs : extraLibDirs bi, [])+ (libdir installDirs : dynlibdir installDirs : extraLibDirs', [])+ expectLibraryComponent (Just attribute) = attribute+ expectLibraryComponent Nothing = error "generalInstalledPackageInfo: Expected a library component, got something else." -- 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@@ -601,9 +617,8 @@ -- -- This function knows about the layout of in place packages. inplaceInstalledPackageInfo- :: FilePath- -- ^ top of the build tree- -> FilePath+ :: AbsolutePath (Dir Pkg)+ -> SymbolicPath Pkg (Dir Dist) -- ^ location of the dist tree -> PackageDescription -> AbiHash@@ -621,22 +636,31 @@ clbi installDirs where+ i = interpretSymbolicPathAbsolute inplaceDir -- See Note [Symbolic paths] in Distribution.Utils.Path adjustRelativeIncludeDirs = concatMap $ \d ->- [ inplaceDir </> d -- local include-dir- , inplaceDir </> libTargetDir </> d -- autogen include-dir+ [ i $ makeRelativePathEx d -- local include-dir+ , i $ libTargetDir </> makeRelativePathEx 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+ { libdir = i libTargetDir+ , dynlibdir = i libTargetDir+ , bytecodelibdir = i libTargetDir+ , datadir =+ let rawDataDir = dataDir pkg+ in if null $ getSymbolicPath rawDataDir+ then i sameDirectory+ else i rawDataDir+ , docdir = i inplaceDocdir , htmldir = inplaceHtmldir , haddockdir = inplaceHtmldir }- inplaceDocdir = inplaceDir </> distPref </> "doc"- inplaceHtmldir = inplaceDocdir </> "html" </> prettyShow (packageName pkg)+ inplaceDocdir = distPref </> makeRelativePathEx "doc"+ inplaceHtmldir =+ i $+ (inplaceDocdir </> makeRelativePathEx "html")+ </> makeRelativePathEx (haddockLibraryDirPath ForDevelopment pkg lib) -- | Construct 'InstalledPackageInfo' for the final install location of a -- library package.@@ -673,7 +697,7 @@ -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo- -> FilePath+ -> SymbolicPath CWD ('Dir Pkg) -> InstalledPackageInfo relocatableInstalledPackageInfo pkg abi_hash lib lbi clbi pkgroot = generalInstalledPackageInfo@@ -693,26 +717,32 @@ bi = libBuildInfo lib installDirs =- fmap (("${pkgroot}" </>) . shortRelativePath pkgroot) $+ fmap (("${pkgroot}" </>) . shortRelativePath (getSymbolicPath pkgroot)) $ absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest -- ----------------------------------------------------------------------------- -- Unregistration unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO ()-unregister pkg lbi regFlags = do+unregister = unregisterWithHandles defaultVerbosityHandles++unregisterWithHandles :: VerbosityHandles -> PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO ()+unregisterWithHandles verbHandles pkg lbi regFlags = do let pkgid = packageId pkg+ common = registerCommonFlags regFlags genScript = fromFlag (regGenScript regFlags)- verbosity = fromFlag (regVerbosity regFlags)+ verbosity = mkVerbosity verbHandles (fromFlag (setupVerbosity common)) packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi)) (regPackageDB regFlags)+ mbWorkDir = mbWorkDirLBI lbi unreg hpi = let invocation = HcPkg.unregisterInvocation hpi- Verbosity.normal+ Verbosity.Normal+ mbWorkDir packageDb pkgid in if genScript@@ -734,8 +764,8 @@ Windows -> "unregister.bat" _ -> "unregister.sh" -internalPackageDBPath :: LocalBuildInfo -> FilePath -> FilePath+internalPackageDBPath :: LocalBuildInfo -> SymbolicPath Pkg (Dir Dist) -> SymbolicPath Pkg (Dir PkgDB) internalPackageDBPath lbi distPref = case compilerFlavor (compiler lbi) of UHC -> UHC.inplacePackageDbPath lbi- _ -> distPref </> "package.conf.inplace"+ _ -> distPref </> makeRelativePathEx "package.conf.inplace"
src/Distribution/Simple/Setup.hs view
@@ -1,12 +1,10 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} ------------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Setup -- Copyright : Isaac Jones 2003-2004@@ -38,12 +36,14 @@ , emptyGlobalFlags , defaultGlobalFlags , globalCommand+ , CommonSetupFlags (..)+ , defaultCommonSetupFlags+ , commonSetupTempFileOptions , ConfigFlags (..) , emptyConfigFlags , defaultConfigFlags , configureCommand , configPrograms- , configAbsolutePaths , readPackageDb , readPackageDbList , showPackageDb@@ -119,7 +119,9 @@ , splitArgs , defaultDistPref , optionDistPref- , Flag (..)+ , Flag+ , pattern Flag+ , pattern NoFlag , toFlag , fromFlag , fromFlagOrDefault@@ -133,12 +135,14 @@ , falseArg , optionVerbosity , BuildingWhat (..)+ , buildingWhatCommonFlags , buildingWhatVerbosity+ , buildingWhatWorkingDir , buildingWhatDistPref ) where -import GHC.Generics (Generic)-import Prelude (FilePath, Show, ($))+import Distribution.Compat.Prelude+import Prelude () import Distribution.Simple.Flag import Distribution.Simple.InstallDirs@@ -155,13 +159,20 @@ import Distribution.Simple.Setup.Hscolour import Distribution.Simple.Setup.Install import Distribution.Simple.Setup.Register+ ( RegisterFlags (..)+ , defaultRegisterFlags+ , emptyRegisterFlags+ , registerCommand+ , unregisterCommand+ ) import Distribution.Simple.Setup.Repl import Distribution.Simple.Setup.SDist import Distribution.Simple.Setup.Test+import Distribution.Utils.Path -import Distribution.Verbosity (Verbosity)+import Distribution.Verbosity (VerbosityFlags) --- | What kind of build are we doing?+-- | What kind of build phase are we doing/hooking into? -- -- Is this a normal build, or is it perhaps for running an interactive -- session or Haddock?@@ -176,20 +187,22 @@ BuildHscolour HscolourFlags deriving (Generic, Show) -buildingWhatVerbosity :: BuildingWhat -> Verbosity-buildingWhatVerbosity = \case- BuildNormal flags -> fromFlag $ buildVerbosity flags- BuildRepl flags -> fromFlag $ replVerbosity flags- BuildHaddock flags -> fromFlag $ haddockVerbosity flags- BuildHscolour flags -> fromFlag $ hscolourVerbosity flags+buildingWhatCommonFlags :: BuildingWhat -> CommonSetupFlags+buildingWhatCommonFlags = \case+ BuildNormal flags -> buildCommonFlags flags+ BuildRepl flags -> replCommonFlags flags+ BuildHaddock flags -> haddockCommonFlags flags+ BuildHscolour flags -> hscolourCommonFlags flags -buildingWhatDistPref :: BuildingWhat -> FilePath-buildingWhatDistPref = \case- BuildNormal flags -> fromFlag $ buildDistPref flags- BuildRepl flags -> fromFlag $ replDistPref flags- BuildHaddock flags -> fromFlag $ haddockDistPref flags- BuildHscolour flags -> fromFlag $ hscolourDistPref flags+buildingWhatVerbosity :: BuildingWhat -> VerbosityFlags+buildingWhatVerbosity = fromFlag . setupVerbosity . buildingWhatCommonFlags +buildingWhatWorkingDir :: BuildingWhat -> Maybe (SymbolicPath CWD (Dir Pkg))+buildingWhatWorkingDir = flagToMaybe . setupWorkingDir . buildingWhatCommonFlags++buildingWhatDistPref :: BuildingWhat -> SymbolicPath Pkg (Dir Dist)+buildingWhatDistPref = fromFlag . setupDistPref . buildingWhatCommonFlags+ -- The test cases kinda have to be rewritten from the ground up... :/ -- hunitTests :: [Test] -- hunitTests =@@ -233,3 +246,6 @@ * quickCheck to test permutations of arguments * what other options can we over-ride with a command-line flag? -}++instance Binary BuildingWhat+instance Structured BuildingWhat
src/Distribution/Simple/Setup/Benchmark.hs view
@@ -1,10 +1,9 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-}-------------------------------------------------------------------------------+{-# LANGUAGE ViewPatterns #-} -- | -- Module : Distribution.Simple.Benchmark@@ -18,7 +17,15 @@ -- Definition of the benchmarking command-line options. -- See: @Distribution.Simple.Setup@ module Distribution.Simple.Setup.Benchmark- ( BenchmarkFlags (..)+ ( BenchmarkFlags+ ( BenchmarkCommonFlags+ , benchmarkVerbosity+ , benchmarkDistPref+ , benchmarkCabalFilePath+ , benchmarkWorkingDir+ , benchmarkTargets+ , ..+ ) , emptyBenchmarkFlags , defaultBenchmarkFlags , benchmarkCommand@@ -29,13 +36,12 @@ import Prelude () import Distribution.Simple.Command hiding (boolOpt, boolOpt')-import Distribution.Simple.Flag import Distribution.Simple.InstallDirs+import Distribution.Simple.Setup.Common import Distribution.Simple.Utils+import Distribution.Utils.Path import Distribution.Verbosity -import Distribution.Simple.Setup.Common- -- ------------------------------------------------------------ -- * Benchmark flags@@ -43,20 +49,42 @@ -- ------------------------------------------------------------ data BenchmarkFlags = BenchmarkFlags- { benchmarkDistPref :: Flag FilePath- , benchmarkVerbosity :: Flag Verbosity+ { benchmarkCommonFlags :: !CommonSetupFlags , benchmarkOptions :: [PathTemplate] }- deriving (Show, Generic, Typeable)+ deriving (Show, Generic) +pattern BenchmarkCommonFlags+ :: Flag VerbosityFlags+ -> Flag (SymbolicPath Pkg (Dir Dist))+ -> Flag (SymbolicPath CWD (Dir Pkg))+ -> Flag (SymbolicPath Pkg File)+ -> [String]+ -> BenchmarkFlags+pattern BenchmarkCommonFlags+ { benchmarkVerbosity+ , benchmarkDistPref+ , benchmarkWorkingDir+ , benchmarkCabalFilePath+ , benchmarkTargets+ } <-+ ( benchmarkCommonFlags ->+ CommonSetupFlags+ { setupVerbosity = benchmarkVerbosity+ , setupDistPref = benchmarkDistPref+ , setupWorkingDir = benchmarkWorkingDir+ , setupCabalFilePath = benchmarkCabalFilePath+ , setupTargets = benchmarkTargets+ }+ )+ instance Binary BenchmarkFlags instance Structured BenchmarkFlags defaultBenchmarkFlags :: BenchmarkFlags defaultBenchmarkFlags = BenchmarkFlags- { benchmarkDistPref = NoFlag- , benchmarkVerbosity = Flag normal+ { benchmarkCommonFlags = defaultCommonSetupFlags , benchmarkOptions = [] } @@ -82,43 +110,41 @@ benchmarkOptions' :: ShowOrParseArgs -> [OptionField BenchmarkFlags] benchmarkOptions' showOrParseArgs =- [ 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)- )- ]+ withCommonSetupOptions+ benchmarkCommonFlags+ (\c f -> f{benchmarkCommonFlags = c})+ showOrParseArgs+ [ option+ []+ ["benchmark-options"]+ ( "give extra options to benchmark executables "+ ++ "(split on spaces, use \"\" to prevent splitting; "+ ++ "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 "+ ++ "(passed directly as a single argument; "+ ++ "name template can use $pkgid, $compiler, "+ ++ "$os, $arch, $benchmark)"+ )+ benchmarkOptions+ (\v flags -> flags{benchmarkOptions = v})+ ( reqArg'+ "TEMPLATE"+ (\x -> [toPathTemplate x])+ (map fromPathTemplate)+ )+ ] emptyBenchmarkFlags :: BenchmarkFlags emptyBenchmarkFlags = mempty
src/Distribution/Simple/Setup/Build.hs view
@@ -1,10 +1,9 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-}-------------------------------------------------------------------------------+{-# LANGUAGE ViewPatterns #-} -- | -- Module : Distribution.Simple.Setup.Build@@ -18,7 +17,15 @@ -- Definition of the build command-line options. -- See: @Distribution.Simple.Setup@ module Distribution.Simple.Setup.Build- ( BuildFlags (..)+ ( BuildFlags+ ( BuildCommonFlags+ , buildVerbosity+ , buildDistPref+ , buildCabalFilePath+ , buildWorkingDir+ , buildTargets+ , ..+ ) , emptyBuildFlags , defaultBuildFlags , buildCommand@@ -32,12 +39,12 @@ import Distribution.Simple.Command hiding (boolOpt, boolOpt') import Distribution.Simple.Flag import Distribution.Simple.Program+import Distribution.Simple.Setup.Common import Distribution.Simple.Utils import Distribution.Types.DumpBuildInfo+import Distribution.Utils.Path import Distribution.Verbosity -import Distribution.Simple.Setup.Common- -- ------------------------------------------------------------ -- * Build flags@@ -45,33 +52,49 @@ -- ------------------------------------------------------------ data BuildFlags = BuildFlags- { buildProgramPaths :: [(String, FilePath)]+ { buildCommonFlags :: !CommonSetupFlags+ , buildProgramPaths :: [(String, FilePath)] , buildProgramArgs :: [(String, [String])]- , buildDistPref :: Flag FilePath- , buildVerbosity :: Flag Verbosity , buildNumJobs :: Flag (Maybe Int) , buildUseSemaphore :: Flag String- , -- 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 }- deriving (Read, Show, Generic, Typeable)+ deriving (Read, Show, Generic) +pattern BuildCommonFlags+ :: Flag VerbosityFlags+ -> Flag (SymbolicPath Pkg (Dir Dist))+ -> Flag (SymbolicPath CWD (Dir Pkg))+ -> Flag (SymbolicPath Pkg File)+ -> [String]+ -> BuildFlags+pattern BuildCommonFlags+ { buildVerbosity+ , buildDistPref+ , buildWorkingDir+ , buildCabalFilePath+ , buildTargets+ } <-+ ( buildCommonFlags ->+ CommonSetupFlags+ { setupVerbosity = buildVerbosity+ , setupDistPref = buildDistPref+ , setupWorkingDir = buildWorkingDir+ , setupCabalFilePath = buildCabalFilePath+ , setupTargets = buildTargets+ }+ )+ instance Binary BuildFlags instance Structured BuildFlags defaultBuildFlags :: BuildFlags defaultBuildFlags = BuildFlags- { buildProgramPaths = mempty+ { buildCommonFlags = defaultCommonSetupFlags+ , buildProgramPaths = mempty , buildProgramArgs = []- , buildDistPref = mempty- , buildVerbosity = Flag normal , buildNumJobs = mempty , buildUseSemaphore = NoFlag- , buildArgs = []- , buildCabalFilePath = mempty } buildCommand :: ProgramDb -> CommandUI BuildFlags@@ -105,21 +128,13 @@ -- ++ " " ++ pname ++ " build foo:Foo.Bar\n" -- ++ " " ++ pname ++ " build testsuite1:Foo/Bar.hs\n" commandUsage =- usageAlternatives "build" $+ 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+ , commandOptions = buildOptions progDb } buildOptions@@ -127,17 +142,21 @@ -> ShowOrParseArgs -> [OptionField BuildFlags] buildOptions progDb showOrParseArgs =- [ optionNumJobs- buildNumJobs- (\v flags -> flags{buildNumJobs = v})- , option- []- ["semaphore"]- "semaphore"- buildUseSemaphore- (\v flags -> flags{buildUseSemaphore = v})- (reqArg' "SEMAPHORE" Flag flagToList)- ]+ withCommonSetupOptions+ buildCommonFlags+ (\c f -> f{buildCommonFlags = c})+ showOrParseArgs+ [ optionNumJobs+ buildNumJobs+ (\v flags -> flags{buildNumJobs = v})+ , option+ []+ ["semaphore"]+ "Use the specified semaphore identifier so GHC can compile components in parallel"+ buildUseSemaphore+ (\v flags -> flags{buildUseSemaphore = v})+ (reqArg' "SEMAPHORE" Flag flagToList)+ ] ++ programDbPaths progDb showOrParseArgs
src/Distribution/Simple/Setup/Clean.hs view
@@ -1,10 +1,9 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-}-------------------------------------------------------------------------------+{-# LANGUAGE ViewPatterns #-} -- | -- Module : Distribution.Simple.Setup.Clean@@ -18,7 +17,15 @@ -- Definition of the clean command-line options. -- See: @Distribution.Simple.Setup@ module Distribution.Simple.Setup.Clean- ( CleanFlags (..)+ ( CleanFlags+ ( CleanCommonFlags+ , cleanVerbosity+ , cleanDistPref+ , cleanCabalFilePath+ , cleanWorkingDir+ , cleanTargets+ , ..+ ) , emptyCleanFlags , defaultCleanFlags , cleanCommand@@ -29,9 +36,9 @@ import Distribution.Simple.Command hiding (boolOpt, boolOpt') import Distribution.Simple.Flag-import Distribution.Verbosity- import Distribution.Simple.Setup.Common+import Distribution.Utils.Path+import Distribution.Verbosity -- ------------------------------------------------------------ @@ -40,23 +47,43 @@ -- ------------------------------------------------------------ data CleanFlags = CleanFlags- { cleanSaveConf :: Flag Bool- , cleanDistPref :: Flag FilePath- , cleanVerbosity :: Flag Verbosity- , cleanCabalFilePath :: Flag FilePath+ { cleanCommonFlags :: !CommonSetupFlags+ , cleanSaveConf :: Flag Bool }- deriving (Show, Generic, Typeable)+ deriving (Show, Generic) +pattern CleanCommonFlags+ :: Flag VerbosityFlags+ -> Flag (SymbolicPath Pkg (Dir Dist))+ -> Flag (SymbolicPath CWD (Dir Pkg))+ -> Flag (SymbolicPath Pkg File)+ -> [String]+ -> CleanFlags+pattern CleanCommonFlags+ { cleanVerbosity+ , cleanDistPref+ , cleanWorkingDir+ , cleanCabalFilePath+ , cleanTargets+ } <-+ ( cleanCommonFlags ->+ CommonSetupFlags+ { setupVerbosity = cleanVerbosity+ , setupDistPref = cleanDistPref+ , setupWorkingDir = cleanWorkingDir+ , setupCabalFilePath = cleanCabalFilePath+ , setupTargets = cleanTargets+ }+ )+ instance Binary CleanFlags instance Structured CleanFlags defaultCleanFlags :: CleanFlags defaultCleanFlags = CleanFlags- { cleanSaveConf = Flag False- , cleanDistPref = NoFlag- , cleanVerbosity = Flag normal- , cleanCabalFilePath = mempty+ { cleanCommonFlags = defaultCommonSetupFlags+ , cleanSaveConf = Flag False } cleanCommand :: CommandUI CleanFlags@@ -71,19 +98,18 @@ "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- ]+ withCommonSetupOptions+ cleanCommonFlags+ (\c f -> f{cleanCommonFlags = c})+ 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
src/Distribution/Simple/Setup/Common.hs view
@@ -1,11 +1,9 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} ------------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Setup.Common -- Copyright : Isaac Jones 2003-2004@@ -18,7 +16,11 @@ -- Common utilities for defining command-line options. -- See: @Distribution.Simple.Setup@ module Distribution.Simple.Setup.Common- ( CopyDest (..)+ ( CommonSetupFlags (..)+ , defaultCommonSetupFlags+ , withCommonSetupOptions+ , commonSetupTempFileOptions+ , CopyDest (..) , configureCCompiler , configureLinker , programDbOption@@ -31,7 +33,9 @@ , defaultDistPref , extraCompilationArtifacts , optionDistPref- , Flag (..)+ , Flag+ , pattern Flag+ , pattern NoFlag , toFlag , fromFlag , fromFlagOrDefault@@ -44,6 +48,7 @@ , trueArg , falseArg , reqArgFlag+ , reqSymbolicPathArgFlag , optionVerbosity , optionNumJobs ) where@@ -58,16 +63,115 @@ import Distribution.Simple.InstallDirs import Distribution.Simple.Program import Distribution.Simple.Utils+import Distribution.Utils.Path import Distribution.Verbosity +--------------------------------------------------------------------------------++-- | A datatype that stores common flags for different invocations+-- of a @Setup@ executable, e.g. configure, build, install.+data CommonSetupFlags = CommonSetupFlags+ { setupVerbosity :: !(Flag VerbosityFlags)+ -- ^ Verbosity+ , setupWorkingDir :: !(Flag (SymbolicPath CWD (Dir Pkg)))+ -- ^ Working directory (optional)+ , setupDistPref :: !(Flag (SymbolicPath Pkg (Dir Dist)))+ -- ^ Build directory+ , setupCabalFilePath :: !(Flag (SymbolicPath Pkg File))+ -- ^ Which Cabal file to use (optional)+ , setupTargets :: [String]+ -- ^ Which targets is this Setup invocation relative to?+ --+ -- TODO: this one should not be here, it's just that the silly+ -- UserHooks stop us from passing extra info in other ways+ , setupKeepTempFiles :: Flag Bool+ -- ^ When this flag is set, temporary files will be kept after building.+ --+ -- Note: Keeping temporary files is important functionality for HLS, which+ -- runs @cabal repl@ with a fake GHC to get CLI arguments. It will need the+ -- temporary files (including multi unit repl response files) to stay, even+ -- after the @cabal repl@ command exits.+ }+ deriving (Eq, Show, Read, Generic)++instance Binary CommonSetupFlags+instance Structured CommonSetupFlags++instance Semigroup CommonSetupFlags where+ (<>) = gmappend++instance Monoid CommonSetupFlags where+ mempty = gmempty+ mappend = (<>)++defaultCommonSetupFlags :: CommonSetupFlags+defaultCommonSetupFlags =+ CommonSetupFlags+ { setupVerbosity = Flag normal+ , setupWorkingDir = NoFlag+ , setupDistPref = NoFlag+ , setupCabalFilePath = NoFlag+ , setupTargets = []+ , setupKeepTempFiles = NoFlag+ }++-- | Get `TempFileOptions` that respect the `setupKeepTempFiles` flag.+commonSetupTempFileOptions :: CommonSetupFlags -> TempFileOptions+commonSetupTempFileOptions options =+ TempFileOptions+ { optKeepTempFiles =+ fromFlagOrDefault False (setupKeepTempFiles options)+ }++commonSetupOptions :: ShowOrParseArgs -> [OptionField CommonSetupFlags]+commonSetupOptions showOrParseArgs =+ [ optionVerbosity+ setupVerbosity+ (\v flags -> flags{setupVerbosity = v})+ , optionDistPref+ setupDistPref+ (\d flags -> flags{setupDistPref = d})+ showOrParseArgs+ , option+ ""+ ["cabal-file"]+ "use this Cabal file"+ setupCabalFilePath+ (\v flags -> flags{setupCabalFilePath = v})+ (reqSymbolicPathArgFlag "PATH")+ , option+ ""+ ["keep-temp-files"]+ "Keep temporary files."+ setupKeepTempFiles+ (\keepTempFiles flags -> flags{setupKeepTempFiles = keepTempFiles})+ trueArg+ -- NB: no --working-dir flag, as that value is populated using the+ -- global flag (see Distribution.Simple.Setup.Global.globalCommand).+ ]++withCommonSetupOptions+ :: (flags -> CommonSetupFlags)+ -> (CommonSetupFlags -> flags -> flags)+ -> ShowOrParseArgs+ -> [OptionField flags]+ -> [OptionField flags]+withCommonSetupOptions getCommon setCommon showOrParseArgs opts =+ map fmapOptionField (commonSetupOptions showOrParseArgs) ++ opts+ where+ fmapOptionField (OptionField nm descr) =+ OptionField nm (map (fmapOptDescr getCommon setCommon) descr)++--------------------------------------------------------------------------------+ -- FIXME Not sure where this should live-defaultDistPref :: FilePath-defaultDistPref = "dist"+defaultDistPref :: SymbolicPath Pkg (Dir Dist)+defaultDistPref = makeSymbolicPath "dist" -- | The name of the directory where optional compilation artifacts -- go, such as ghc plugins and .hie files.-extraCompilationArtifacts :: FilePath-extraCompilationArtifacts = "extra-compilation-artifacts"+extraCompilationArtifacts :: RelativePath Build (Dir Artifacts)+extraCompilationArtifacts = makeRelativePathEx "extra-compilation-artifacts" -- | Help text for @test@ and @bench@ commands. testOrBenchmarkHelpText@@ -173,7 +277,9 @@ [prog ++ "-option"] ( "give an extra option to " ++ prog- ++ " (no need to quote options containing spaces)"+ ++ " (passed directly to "+ ++ prog+ ++ " as a single argument)" ) get set@@ -210,7 +316,10 @@ option "" [prog ++ "-options"]- ("give extra options to " ++ prog)+ ( "give extra options to "+ ++ prog+ ++ " (split on spaces, use \"\" to prevent splitting)"+ ) get set (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const []))@@ -248,8 +357,8 @@ reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList optionDistPref- :: (flags -> Flag FilePath)- -> (Flag FilePath -> flags -> flags)+ :: (flags -> Flag (SymbolicPath Pkg (Dir Dist)))+ -> (Flag (SymbolicPath Pkg (Dir Dist)) -> flags -> flags) -> ShowOrParseArgs -> OptionField flags optionDistPref get set = \showOrParseArgs ->@@ -258,19 +367,36 @@ (distPrefFlagName showOrParseArgs) ( "The directory where Cabal puts generated build files " ++ "(default "- ++ defaultDistPref+ ++ getSymbolicPath defaultDistPref ++ ")" ) get set- (reqArgFlag "DIR")+ (reqSymbolicPathArgFlag "DIR") where distPrefFlagName ShowArgs = ["builddir"] distPrefFlagName ParseArgs = ["builddir", "distdir", "distpref"] +reqSymbolicPathArgFlag+ :: ArgPlaceHolder+ -> SFlags+ -> LFlags+ -> Description+ -> (b -> Flag (SymbolicPath from to))+ -> (Flag (SymbolicPath from to) -> b -> b)+ -> OptDescr b+reqSymbolicPathArgFlag title sf lf d get set =+ reqArgFlag+ title+ sf+ lf+ d+ (fmap getSymbolicPath . get)+ (set . fmap makeSymbolicPath)+ optionVerbosity- :: (flags -> Flag Verbosity)- -> (Flag Verbosity -> flags -> flags)+ :: (flags -> Flag VerbosityFlags)+ -> (Flag VerbosityFlags -> flags -> flags) -> OptionField flags optionVerbosity get set = option
src/Distribution/Simple/Setup/Config.hs view
@@ -1,8 +1,11 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- @@ -18,12 +21,19 @@ -- Definition of the configure command-line options. -- See: @Distribution.Simple.Setup@ module Distribution.Simple.Setup.Config- ( ConfigFlags (..)+ ( ConfigFlags+ ( ConfigCommonFlags+ , configVerbosity+ , configDistPref+ , configCabalFilePath+ , configWorkingDir+ , configTargets+ , ..+ ) , emptyConfigFlags , defaultConfigFlags , configureCommand , configPrograms- , configAbsolutePaths , readPackageDb , readPackageDbList , showPackageDb@@ -36,7 +46,9 @@ import Distribution.Compat.Prelude hiding (get) import Prelude () +import Data.Semigroup (Last (..)) import qualified Distribution.Compat.CharParsing as P+import Distribution.Compat.Stack import Distribution.Compiler import Distribution.ModuleName import Distribution.PackageDescription@@ -48,6 +60,7 @@ import Distribution.Simple.Flag import Distribution.Simple.InstallDirs import Distribution.Simple.Program+import Distribution.Simple.Setup.Common import Distribution.Simple.Utils import Distribution.Types.ComponentId import Distribution.Types.DumpBuildInfo@@ -56,13 +69,10 @@ import Distribution.Types.PackageVersionConstraint import Distribution.Types.UnitId import Distribution.Utils.NubList+import Distribution.Utils.Path import Distribution.Verbosity-import qualified Text.PrettyPrint as Disp -import Distribution.Compat.Semigroup (Last' (..), Option' (..))-import Distribution.Compat.Stack--import Distribution.Simple.Setup.Common+import qualified Text.PrettyPrint as Disp -- ------------------------------------------------------------ @@ -76,14 +86,12 @@ -- 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'.- -- TODO: Stop using this eventually when 'UserHooks' gets changed- configArgs :: [String]+ { configCommonFlags :: !CommonSetupFlags , -- 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)+ configPrograms_ :: Maybe (Last ProgramDb) -- ^ All programs that -- @cabal@ may run , configProgramPaths :: [(String, FilePath)]@@ -107,6 +115,8 @@ -- ^ Build shared library , configStaticLib :: Flag Bool -- ^ Build static library+ , configBytecodeLib :: Flag Bool+ -- ^ Build bytecode library , configDynExe :: Flag Bool -- ^ Enable dynamic linking of the -- executables.@@ -119,6 +129,8 @@ , configProf :: Flag Bool -- ^ Enable profiling in the library -- and executables.+ , configProfShared :: Flag Bool+ -- ^ Enable shared profiling objects , configProfDetail :: Flag ProfDetailLevel -- ^ Profiling detail level -- in the library and executables.@@ -137,16 +149,16 @@ -- ^ Installation -- paths , configScratchDir :: Flag FilePath- , configExtraLibDirs :: [FilePath]+ , configExtraLibDirs :: [SymbolicPath Pkg (Dir Lib)] -- ^ path to search for extra libraries- , configExtraLibDirsStatic :: [FilePath]+ , configExtraLibDirsStatic :: [SymbolicPath Pkg (Dir Lib)] -- ^ path to search for extra -- libraries when linking -- fully static executables- , configExtraFrameworkDirs :: [FilePath]+ , configExtraFrameworkDirs :: [SymbolicPath Pkg (Dir Framework)] -- ^ path to search for extra -- frameworks (OS X only)- , configExtraIncludeDirs :: [FilePath]+ , configExtraIncludeDirs :: [SymbolicPath Pkg (Dir Include)] -- ^ path to search for header files , configIPID :: Flag String -- ^ explicit IPID to be used@@ -156,12 +168,6 @@ -- ^ 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]@@ -181,7 +187,7 @@ -- dependencies. , configDependencies :: [GivenComponent] -- ^ The packages depended on which already exist- , configPromisedDependencies :: [GivenComponent]+ , configPromisedDependencies :: [PromisedComponent] -- ^ 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.@@ -226,9 +232,37 @@ -- testsuites run with @--enable-coverage@. Notably, this list must exclude -- indefinite libraries and instantiations because HPC does not support -- backpack (Nov. 2023).+ , configIgnoreBuildTools :: Flag Bool+ -- ^ When this flag is set, all tools declared in `build-tool`s and+ -- `build-tool-depends` will be ignored. This allows a Cabal package with+ -- build-tool-dependencies to be built even if the tool is not found. }- deriving (Generic, Read, Show, Typeable)+ deriving (Generic, Read, Show) +pattern ConfigCommonFlags+ :: Flag VerbosityFlags+ -> Flag (SymbolicPath Pkg (Dir Dist))+ -> Flag (SymbolicPath CWD (Dir Pkg))+ -> Flag (SymbolicPath Pkg File)+ -> [String]+ -> ConfigFlags+pattern ConfigCommonFlags+ { configVerbosity+ , configDistPref+ , configWorkingDir+ , configCabalFilePath+ , configTargets+ } <-+ ( configCommonFlags ->+ CommonSetupFlags+ { setupVerbosity = configVerbosity+ , setupDistPref = configDistPref+ , setupWorkingDir = configWorkingDir+ , setupCabalFilePath = configCabalFilePath+ , setupTargets = configTargets+ }+ )+ instance Binary ConfigFlags instance Structured ConfigFlags @@ -236,15 +270,13 @@ -- 'error' if internal invariant is violated. configPrograms :: WithCallStack (ConfigFlags -> ProgramDb) configPrograms =- fromMaybe (error "FIXME: remove configPrograms")- . fmap getLast'- . getOption'- . configPrograms_+ maybe (error "FIXME: remove configPrograms") getLast . configPrograms_ instance Eq ConfigFlags where (==) a b = -- configPrograms skipped: not user specified, has no Eq instance- equal configProgramPaths+ equal configCommonFlags+ && equal configProgramPaths && equal configProgramArgs && equal configProgramPathExtra && equal configHcFlavor@@ -254,11 +286,13 @@ && equal configProfLib && equal configSharedLib && equal configStaticLib+ && equal configBytecodeLib && equal configDynExe && equal configFullyStaticExe && equal configProfExe && equal configProf && equal configProfDetail+ && equal configProfShared && equal configProfLibDetail && equal configConfigureArgs && equal configOptimization@@ -271,8 +305,6 @@ && equal configExtraIncludeDirs && equal configIPID && equal configDeterministic- && equal configDistPref- && equal configVerbosity && equal configUserInstall && equal configPackageDBs && equal configGHCiLib@@ -294,28 +326,24 @@ && equal configDebugInfo && equal configDumpBuildInfo && equal configUseResponseFiles+ && equal configAllowDependingOnPrivateLibs && equal configCoverageFor+ && equal configIgnoreBuildTools 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)- {- FOURMOLU_DISABLE -} defaultConfigFlags :: ProgramDb -> ConfigFlags defaultConfigFlags progDb = emptyConfigFlags- { configArgs = []- , configPrograms_ = Option' (Just (Last' progDb))+ { configCommonFlags = defaultCommonSetupFlags+ , configPrograms_ = Just (Last progDb) , configHcFlavor = maybe NoFlag Flag defaultCompilerFlavor , configVanillaLib = Flag True , configProfLib = NoFlag , configSharedLib = NoFlag , configStaticLib = NoFlag+ , configBytecodeLib = NoFlag , configDynExe = Flag False , configFullyStaticExe = Flag False , configProfExe = NoFlag@@ -325,9 +353,6 @@ , 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.@@ -401,54 +426,37 @@ 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")- ]+ withCommonSetupOptions+ configCommonFlags+ (\c f -> f{configCommonFlags = c})+ 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")+ ]+ )+ , 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 ""@@ -494,6 +502,13 @@ (boolOpt [] []) , option ""+ ["library-bytecode"]+ "Bytecode library"+ configBytecodeLib+ (\v flags -> flags{configBytecodeLib = v})+ (boolOpt [] [])+ , option+ "" ["executable-dynamic"] "Executable dynamic linking" configDynExe@@ -515,6 +530,13 @@ (boolOpt [] []) , option ""+ ["profiling-shared"]+ "Build profiling shared libraries"+ configProfShared+ (\v flags -> flags{configProfShared = v})+ (boolOpt [] [])+ , option+ "" ["executable-profiling"] "Executable profiling (DEPRECATED)" configProfExe@@ -551,7 +573,7 @@ [ optArgDef' "n" (show NoOptimisation, Flag . flagToOptimisationLevel)- ( \f -> case f of+ ( \case Flag NoOptimisation -> [] Flag NormalOptimisation -> [Nothing] Flag MaximumOptimisation -> [Just "2"]@@ -573,7 +595,7 @@ [ optArg' "n" (Flag . flagToDebugInfoLevel)- ( \f -> case f of+ ( \case Flag NoDebugInfo -> [] Flag MinimalDebugInfo -> [Just "1"] Flag NormalDebugInfo -> [Nothing]@@ -683,7 +705,7 @@ "A list of directories to search for header files" configExtraIncludeDirs (\v flags -> flags{configExtraIncludeDirs = v})- (reqArg' "PATH" (\x -> [x]) id)+ (reqArg' "PATH" (\x -> [makeSymbolicPath x]) (fmap getSymbolicPath)) , option "" ["deterministic"]@@ -711,21 +733,21 @@ "A list of directories to search for external libraries" configExtraLibDirs (\v flags -> flags{configExtraLibDirs = v})- (reqArg' "PATH" (\x -> [x]) id)+ (reqArg' "PATH" (\x -> [makeSymbolicPath x]) (fmap getSymbolicPath)) , 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)+ (reqArg' "PATH" (\x -> [makeSymbolicPath x]) (fmap getSymbolicPath)) , 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)+ (reqArg' "PATH" (\x -> [makeSymbolicPath x]) (fmap getSymbolicPath)) , option "" ["extra-prog-path"]@@ -758,13 +780,13 @@ , option "" ["promised-dependency"]- "A list of promised dependencies. E.g., --promised-dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\""+ "A list of promised dependencies. E.g., --promised-dependency=\"void-0.5.8=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)+ "NAME-VER[:COMPONENT_NAME]=CID"+ (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsecPromisedComponent))+ (map prettyPromisedComponent) ) , option ""@@ -851,6 +873,15 @@ (Flag . (: []) . fromString) (fmap prettyShow . fromFlagOrDefault []) )+ , option+ ""+ ["ignore-build-tools"]+ ( "Ignore build tool dependencies. "+ ++ "If set, declared build tools needn't be found for compilation to proceed."+ )+ configIgnoreBuildTools+ (\v flags -> flags{configIgnoreBuildTools = v})+ trueArg ] where liftInstallDirs =@@ -868,15 +899,6 @@ readPackageDbList :: String -> [Maybe PackageDB] readPackageDbList str = [readPackageDb str] --- | Parse a PackageDB stack entry------ @since 3.7.0.0-readPackageDb :: String -> Maybe PackageDB-readPackageDb "clear" = Nothing-readPackageDb "global" = Just GlobalPackageDB-readPackageDb "user" = Just UserPackageDB-readPackageDb other = Just (SpecificPackageDB other)- showPackageDbList :: [Maybe PackageDB] -> [String] showPackageDbList = map showPackageDb @@ -887,12 +909,35 @@ showPackageDb Nothing = "clear" showPackageDb (Just GlobalPackageDB) = "global" showPackageDb (Just UserPackageDB) = "user"-showPackageDb (Just (SpecificPackageDB db)) = db+showPackageDb (Just (SpecificPackageDB db)) = getSymbolicPath db showProfDetailLevelFlag :: Flag ProfDetailLevel -> [String] showProfDetailLevelFlag NoFlag = [] showProfDetailLevelFlag (Flag dl) = [showProfDetailLevel dl] +parsecPromisedComponent :: ParsecParser PromisedComponent+parsecPromisedComponent = do+ pn <- parsec+ ln <- P.option LMainLibName $ do+ _ <- P.char ':'+ ucn <- parsec+ return $+ if unUnqualComponentName ucn == unPackageName (pkgName pn)+ then LMainLibName+ else LSubLibName ucn+ _ <- P.char '='+ cid <- parsec+ return $ PromisedComponent pn ln cid++prettyPromisedComponent :: PromisedComponent -> String+prettyPromisedComponent (PromisedComponent pn cn cid) =+ prettyShow pn+ ++ case cn of+ LMainLibName -> ""+ LSubLibName n -> ":" ++ prettyShow n+ ++ "="+ ++ prettyShow cid+ parsecGivenComponent :: ParsecParser GivenComponent parsecGivenComponent = do pn <- parsec@@ -955,6 +1000,13 @@ installDirArg , option ""+ ["bytecodelibdir"]+ "installation directory for bytecode libraries"+ bytecodelibdir+ (\v flags -> flags{bytecodelibdir = v})+ installDirArg+ , option+ "" ["libexecdir"] "installation directory for program executables" libexecdir@@ -1049,7 +1101,7 @@ (Flag hc, NoFlag) -> [hc_flag_name ++ prettyShow hc] (NoFlag, NoFlag) -> [] hc_flag_name- -- TODO kill off thic bc hack when defaultUserHooks is removed.+ -- TODO kill off this bc hack when defaultUserHooks is removed. | bcHack = "--with-hc=" | otherwise = "--with-compiler=" optFlag name config_field = case config_field flags of
src/Distribution/Simple/Setup/Copy.hs view
@@ -1,10 +1,10 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-}-------------------------------------------------------------------------------+{-# LANGUAGE ViewPatterns #-} -- | -- Module : Distribution.Simple.Setup.Copy@@ -18,7 +18,15 @@ -- Definition of the copy command-line options. -- See: @Distribution.Simple.Setup@ module Distribution.Simple.Setup.Copy- ( CopyFlags (..)+ ( CopyFlags+ ( CopyCommonFlags+ , copyVerbosity+ , copyDistPref+ , copyCabalFilePath+ , copyWorkingDir+ , copyTargets+ , ..+ ) , emptyCopyFlags , defaultCopyFlags , copyCommand@@ -31,11 +39,11 @@ import Distribution.Simple.Command hiding (boolOpt, boolOpt') import Distribution.Simple.Flag import Distribution.Simple.InstallDirs+import Distribution.Simple.Setup.Common import Distribution.Simple.Utils+import Distribution.Utils.Path import Distribution.Verbosity -import Distribution.Simple.Setup.Common- -- ------------------------------------------------------------ -- * Copy flags@@ -44,28 +52,43 @@ -- | 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- -- 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+ { copyCommonFlags :: !CommonSetupFlags+ , copyDest :: Flag CopyDest } deriving (Show, Generic) +pattern CopyCommonFlags+ :: Flag VerbosityFlags+ -> Flag (SymbolicPath Pkg (Dir Dist))+ -> Flag (SymbolicPath CWD (Dir Pkg))+ -> Flag (SymbolicPath Pkg File)+ -> [String]+ -> CopyFlags+pattern CopyCommonFlags+ { copyVerbosity+ , copyDistPref+ , copyWorkingDir+ , copyCabalFilePath+ , copyTargets+ } <-+ ( copyCommonFlags ->+ CommonSetupFlags+ { setupVerbosity = copyVerbosity+ , setupDistPref = copyDistPref+ , setupWorkingDir = copyWorkingDir+ , setupCabalFilePath = copyCabalFilePath+ , setupTargets = copyTargets+ }+ )+ instance Binary CopyFlags instance Structured CopyFlags defaultCopyFlags :: CopyFlags defaultCopyFlags = CopyFlags- { copyDest = Flag NoCopyDest- , copyDistPref = NoFlag- , copyVerbosity = Flag normal- , copyArgs = []- , copyCabalFilePath = mempty+ { copyCommonFlags = defaultCommonSetupFlags+ , copyDest = Flag NoCopyDest } copyCommand :: CommandUI CopyFlags@@ -89,12 +112,13 @@ ++ " copy foo " ++ " A component (i.e. lib, exe, test suite)" , commandUsage =- usageAlternatives "copy" $+ usageAlternatives+ "copy" [ "[FLAGS]" , "COMPONENTS [FLAGS]" ] , commandDefaultFlags = defaultCopyFlags- , commandOptions = \showOrParseArgs -> case showOrParseArgs of+ , commandOptions = \case ShowArgs -> filter ( (`notElem` ["target-package-db"])@@ -106,41 +130,40 @@ 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]; _ -> [])- )- ]+ withCommonSetupOptions+ copyCommonFlags+ (\c f -> f{copyCommonFlags = c})+ 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))+ (\case 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))+ (\case Flag (CopyToDb p) -> [p]; _ -> [])+ )+ ] emptyCopyFlags :: CopyFlags emptyCopyFlags = mempty
src/Distribution/Simple/Setup/Global.hs view
@@ -1,11 +1,8 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} ------------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Setup.Global -- Copyright : Isaac Jones 2003-2004@@ -30,6 +27,7 @@ import Distribution.Simple.Command hiding (boolOpt, boolOpt') import Distribution.Simple.Flag import Distribution.Simple.Setup.Common+import Distribution.Utils.Path -- ------------------------------------------------------------ @@ -46,15 +44,19 @@ -- | Flags that apply at the top level, not to any sub-command. data GlobalFlags = GlobalFlags { globalVersion :: Flag Bool+ , globalFullVersion :: Flag Bool , globalNumericVersion :: Flag Bool+ , globalWorkingDir :: Flag (SymbolicPath CWD (Dir Pkg)) }- deriving (Generic, Typeable)+ deriving (Generic) defaultGlobalFlags :: GlobalFlags defaultGlobalFlags = GlobalFlags { globalVersion = Flag False+ , globalFullVersion = Flag False , globalNumericVersion = Flag False+ , globalWorkingDir = NoFlag } globalCommand :: [Command action] -> CommandUI GlobalFlags@@ -103,11 +105,25 @@ trueArg , option []+ ["full-version"]+ "Print the version, Git revision if available, and compiler information"+ globalFullVersion+ (\v flags -> flags{globalFullVersion = v})+ trueArg+ , option+ [] ["numeric-version"] "Print just the version number" globalNumericVersion (\v flags -> flags{globalNumericVersion = v}) trueArg+ , option+ ""+ ["working-dir"]+ "Set working directory"+ globalWorkingDir+ (\v flags -> flags{globalWorkingDir = v})+ (reqSymbolicPathArgFlag "DIR") ] }
src/Distribution/Simple/Setup/Haddock.hs view
@@ -1,10 +1,9 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-}-------------------------------------------------------------------------------+{-# LANGUAGE ViewPatterns #-} -- | -- Module : Distribution.Simple.Setup.Haddock@@ -19,7 +18,15 @@ -- See: @Distribution.Simple.Setup@ module Distribution.Simple.Setup.Haddock ( HaddockTarget (..)- , HaddockFlags (..)+ , HaddockFlags+ ( HaddockCommonFlags+ , haddockVerbosity+ , haddockDistPref+ , haddockCabalFilePath+ , haddockWorkingDir+ , haddockTargets+ , ..+ ) , emptyHaddockFlags , defaultHaddockFlags , haddockCommand@@ -42,10 +49,11 @@ import Distribution.Simple.Flag import Distribution.Simple.InstallDirs import Distribution.Simple.Program+import Distribution.Simple.Setup.Common+import Distribution.Utils.Path import Distribution.Verbosity-import qualified Text.PrettyPrint as Disp -import Distribution.Simple.Setup.Common+import qualified Text.PrettyPrint as Disp -- ------------------------------------------------------------ @@ -64,9 +72,10 @@ -- from documentation tarballs, and we might also want to use different -- flags than for development builds, so in this case we store the generated -- documentation in @<dist>/doc/html/<package id>-docs@.-data HaddockTarget = ForHackage | ForDevelopment deriving (Eq, Show, Generic, Typeable)+data HaddockTarget = ForHackage | ForDevelopment deriving (Eq, Show, Generic) instance Binary HaddockTarget+instance NFData HaddockTarget instance Structured HaddockTarget instance Pretty HaddockTarget where@@ -81,7 +90,8 @@ ] data HaddockFlags = HaddockFlags- { haddockProgramPaths :: [(String, FilePath)]+ { haddockCommonFlags :: !CommonSetupFlags+ , haddockProgramPaths :: [(String, FilePath)] , haddockProgramArgs :: [(String, [String])] , haddockHoogle :: Flag Bool , haddockHtml :: Flag Bool@@ -98,24 +108,45 @@ , 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+ , haddockResourcesDir :: Flag String , haddockOutputDir :: Flag FilePath- , haddockArgs :: [String]+ , haddockUseUnicode :: Flag Bool }- deriving (Show, Generic, Typeable)+ deriving (Show, Generic) +pattern HaddockCommonFlags+ :: Flag VerbosityFlags+ -> Flag (SymbolicPath Pkg (Dir Dist))+ -> Flag (SymbolicPath CWD (Dir Pkg))+ -> Flag (SymbolicPath Pkg File)+ -> [String]+ -> HaddockFlags+pattern HaddockCommonFlags+ { haddockVerbosity+ , haddockDistPref+ , haddockWorkingDir+ , haddockCabalFilePath+ , haddockTargets+ } <-+ ( haddockCommonFlags ->+ CommonSetupFlags+ { setupVerbosity = haddockVerbosity+ , setupDistPref = haddockDistPref+ , setupWorkingDir = haddockWorkingDir+ , setupCabalFilePath = haddockCabalFilePath+ , setupTargets = haddockTargets+ }+ )+ instance Binary HaddockFlags instance Structured HaddockFlags defaultHaddockFlags :: HaddockFlags defaultHaddockFlags = HaddockFlags- { haddockProgramPaths = mempty+ { haddockCommonFlags = defaultCommonSetupFlags+ , haddockProgramPaths = mempty , haddockProgramArgs = [] , haddockHoogle = Flag False , haddockHtml = Flag False@@ -131,15 +162,11 @@ , haddockQuickJump = Flag False , haddockHscolourCss = NoFlag , haddockContents = NoFlag- , haddockDistPref = NoFlag- , haddockKeepTempFiles = Flag False- , haddockVerbosity = Flag normal- , haddockCabalFilePath = mempty , haddockIndex = NoFlag , haddockBaseUrl = NoFlag- , haddockLib = NoFlag+ , haddockResourcesDir = NoFlag , haddockOutputDir = NoFlag- , haddockArgs = mempty+ , haddockUseUnicode = Flag False } haddockCommand :: CommandUI HaddockFlags@@ -151,7 +178,8 @@ "Requires the program haddock, version 2.x.\n" , commandNotes = Nothing , commandUsage =- usageAlternatives "haddock" $+ usageAlternatives+ "haddock" [ "[FLAGS]" , "COMPONENTS [FLAGS]" ]@@ -177,181 +205,177 @@ where progDb = addKnownProgram haddockProgram $- addKnownProgram ghcProgram $- emptyProgramDb+ 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")- ]+ withCommonSetupOptions+ haddockCommonFlags+ (\c f -> f{haddockCommonFlags = c})+ showOrParseArgs+ [ 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+ ""+ ["resources-dir"]+ "location of Haddocks static / auxiliary files"+ haddockResourcesDir+ (\v flags -> flags{haddockResourcesDir = 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")+ , option+ ""+ ["use-unicode"]+ "Pass --use-unicode option to haddock"+ haddockUseUnicode+ (\v flags -> flags{haddockUseUnicode = v})+ trueArg+ ] emptyHaddockFlags :: HaddockFlags emptyHaddockFlags = mempty@@ -377,7 +401,8 @@ deriving (Eq, Show) data HaddockProjectFlags = HaddockProjectFlags- { haddockProjectHackage :: Flag Bool+ { haddockProjectCommonFlags :: !CommonSetupFlags+ , 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`@@ -410,18 +435,17 @@ , -- 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+ -- haddockBaseUrl is not supported, a fixed value is provided+ haddockProjectResourcesDir :: Flag String+ , haddockProjectUseUnicode :: Flag Bool }- deriving (Show, Generic, Typeable)+ deriving (Show, Generic) defaultHaddockProjectFlags :: HaddockProjectFlags defaultHaddockProjectFlags = HaddockProjectFlags- { haddockProjectHackage = Flag False+ { haddockProjectCommonFlags = defaultCommonSetupFlags+ , haddockProjectHackage = Flag False , haddockProjectDir = Flag "./haddocks" , haddockProjectPrologue = NoFlag , haddockProjectTestSuites = Flag False@@ -435,11 +459,9 @@ , haddockProjectInternal = Flag False , haddockProjectCss = NoFlag , haddockProjectHscolourCss = NoFlag- , haddockProjectKeepTempFiles = Flag False- , haddockProjectVerbosity = Flag normal- , haddockProjectLib = NoFlag- , haddockProjectOutputDir = NoFlag+ , haddockProjectResourcesDir = NoFlag , haddockProjectInterfaces = NoFlag+ , haddockProjectUseUnicode = NoFlag } haddockProjectCommand :: CommandUI HaddockProjectFlags@@ -451,7 +473,8 @@ "Requires the program haddock, version 2.26.\n" , commandNotes = Nothing , commandUsage =- usageAlternatives "haddock-project" $+ usageAlternatives+ "haddock-project" [ "[FLAGS]" , "COMPONENTS [FLAGS]" ]@@ -477,123 +500,134 @@ where progDb = addKnownProgram haddockProgram $- addKnownProgram ghcProgram $- emptyProgramDb+ addKnownProgram ghcProgram emptyProgramDb haddockProjectOptions :: ShowOrParseArgs -> [OptionField HaddockProjectFlags]-haddockProjectOptions _showOrParseArgs =- [ option- ""- ["hackage"]- ( concat- [ "A short-cut option to build documentation linked to hackage."- ]- )- haddockProjectHackage- (\v flags -> flags{haddockProjectHackage = v})- trueArg- , option- ""- ["output"]- "Output directory"- 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- ""- ["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- ""- ["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")- ]+haddockProjectOptions showOrParseArgs =+ withCommonSetupOptions+ haddockProjectCommonFlags+ (\c f -> f{haddockProjectCommonFlags = c})+ showOrParseArgs+ [ option+ ""+ ["hackage"]+ "A short-cut option to build documentation linked to hackage."+ haddockProjectHackage+ (\v flags -> flags{haddockProjectHackage = v})+ trueArg+ , option+ ""+ ["output"]+ "Output directory"+ 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+ ""+ ["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+ ""+ ["all", "haddock-all"]+ "Run haddock for all targets"+ ( \f ->+ allFlags+ [ haddockProjectExecutables f+ , haddockProjectTestSuites f+ , haddockProjectBenchmarks f+ , haddockProjectForeignLibs f+ ]+ )+ ( \v flags ->+ flags+ { haddockProjectExecutables = v+ , haddockProjectTestSuites = v+ , haddockProjectBenchmarks = v+ , 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+ ""+ ["hscolour-css"]+ "Use PATH as the HsColour stylesheet"+ haddockProjectHscolourCss+ (\v flags -> flags{haddockProjectHscolourCss = v})+ (reqArgFlag "PATH")+ , option+ ""+ ["resources-dir"]+ "location of Haddocks static / auxiliary files"+ haddockProjectResourcesDir+ (\v flags -> flags{haddockProjectResourcesDir = v})+ (reqArgFlag "DIR")+ , option+ ""+ ["use-unicode"]+ "Pass --use-unicode option to haddock"+ haddockProjectUseUnicode+ (\v flags -> flags{haddockProjectUseUnicode = v})+ trueArg+ ] emptyHaddockProjectFlags :: HaddockProjectFlags emptyHaddockProjectFlags = mempty
src/Distribution/Simple/Setup/Hscolour.hs view
@@ -1,10 +1,9 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-}-------------------------------------------------------------------------------+{-# LANGUAGE ViewPatterns #-} -- | -- Module : Distribution.Simple.Setup.Hscolour@@ -18,7 +17,15 @@ -- Definition of the hscolour command-line options. -- See: @Distribution.Simple.Setup@ module Distribution.Simple.Setup.Hscolour- ( HscolourFlags (..)+ ( HscolourFlags+ ( HscolourCommonFlags+ , hscolourVerbosity+ , hscolourDistPref+ , hscolourCabalFilePath+ , hscolourWorkingDir+ , hscolourTargets+ , ..+ ) , emptyHscolourFlags , defaultHscolourFlags , hscolourCommand@@ -29,9 +36,9 @@ import Distribution.Simple.Command hiding (boolOpt, boolOpt') import Distribution.Simple.Flag-import Distribution.Verbosity- import Distribution.Simple.Setup.Common+import Distribution.Utils.Path+import Distribution.Verbosity -- ------------------------------------------------------------ @@ -40,17 +47,39 @@ -- ------------------------------------------------------------ data HscolourFlags = HscolourFlags- { hscolourCSS :: Flag FilePath+ { hscolourCommonFlags :: !CommonSetupFlags+ , 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)+ deriving (Show, Generic) +pattern HscolourCommonFlags+ :: Flag VerbosityFlags+ -> Flag (SymbolicPath Pkg (Dir Dist))+ -> Flag (SymbolicPath CWD (Dir Pkg))+ -> Flag (SymbolicPath Pkg File)+ -> [String]+ -> HscolourFlags+pattern HscolourCommonFlags+ { hscolourVerbosity+ , hscolourDistPref+ , hscolourWorkingDir+ , hscolourCabalFilePath+ , hscolourTargets+ } <-+ ( hscolourCommonFlags ->+ CommonSetupFlags+ { setupVerbosity = hscolourVerbosity+ , setupDistPref = hscolourDistPref+ , setupWorkingDir = hscolourWorkingDir+ , setupCabalFilePath = hscolourCabalFilePath+ , setupTargets = hscolourTargets+ }+ )+ instance Binary HscolourFlags instance Structured HscolourFlags @@ -60,14 +89,12 @@ defaultHscolourFlags :: HscolourFlags defaultHscolourFlags = HscolourFlags- { hscolourCSS = NoFlag+ { hscolourCommonFlags = defaultCommonSetupFlags+ , 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@@ -85,73 +112,70 @@ "Generate HsColour colourised code, in HTML format." , commandDescription = Just (\_ -> "Requires the hscolour program.\n") , commandNotes = Just $ \_ ->- "Deprecated in favour of 'cabal haddock --hyperlink-source'."+ "Deprecated in favour of 'cabal haddock --hyperlink-source'.\n" , 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")- ]+ withCommonSetupOptions+ hscolourCommonFlags+ (\c f -> f{hscolourCommonFlags = c})+ 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")+ ] }
src/Distribution/Simple/Setup/Install.hs view
@@ -1,10 +1,10 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-}-------------------------------------------------------------------------------+{-# LANGUAGE ViewPatterns #-} -- | -- Module : Distribution.Simple.Setup.Install@@ -18,7 +18,15 @@ -- Definition of the install command-line options. -- See: @Distribution.Simple.Setup@ module Distribution.Simple.Setup.Install- ( InstallFlags (..)+ ( InstallFlags+ ( InstallCommonFlags+ , installVerbosity+ , installDistPref+ , installCabalFilePath+ , installWorkingDir+ , installTargets+ , ..+ ) , emptyInstallFlags , defaultInstallFlags , installCommand@@ -32,11 +40,11 @@ import Distribution.Simple.Compiler import Distribution.Simple.Flag import Distribution.Simple.InstallDirs+import Distribution.Simple.Setup.Common import Distribution.Simple.Utils+import Distribution.Utils.Path import Distribution.Verbosity -import Distribution.Simple.Setup.Common- -- ------------------------------------------------------------ -- * Install flags@@ -45,28 +53,46 @@ -- | Flags to @install@: (package db, verbosity) data InstallFlags = InstallFlags- { installPackageDB :: Flag PackageDB+ { installCommonFlags :: !CommonSetupFlags+ , 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) +pattern InstallCommonFlags+ :: Flag VerbosityFlags+ -> Flag (SymbolicPath Pkg (Dir Dist))+ -> Flag (SymbolicPath CWD (Dir Pkg))+ -> Flag (SymbolicPath Pkg File)+ -> [String]+ -> InstallFlags+pattern InstallCommonFlags+ { installVerbosity+ , installDistPref+ , installWorkingDir+ , installCabalFilePath+ , installTargets+ } <-+ ( installCommonFlags ->+ CommonSetupFlags+ { setupVerbosity = installVerbosity+ , setupDistPref = installDistPref+ , setupWorkingDir = installWorkingDir+ , setupCabalFilePath = installCabalFilePath+ , setupTargets = installTargets+ }+ )+ defaultInstallFlags :: InstallFlags defaultInstallFlags = InstallFlags- { installPackageDB = NoFlag+ { installCommonFlags = defaultCommonSetupFlags+ , installPackageDB = NoFlag , installDest = Flag NoCopyDest- , installDistPref = NoFlag , installUseWrapper = Flag False , installInPlace = Flag False- , installVerbosity = Flag normal- , installCabalFilePath = mempty } installCommand :: CommandUI InstallFlags@@ -84,24 +110,24 @@ , 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+ , commandOptions = \showOrParseArgs ->+ withCommonSetupOptions+ installCommonFlags+ (\c f -> f{installCommonFlags = c})+ showOrParseArgs+ $ case showOrParseArgs of+ ShowArgs ->+ filter+ ( (`notElem` ["target-package-db"])+ . optionName+ )+ installOptions+ ParseArgs -> installOptions } -installOptions :: ShowOrParseArgs -> [OptionField InstallFlags]-installOptions showOrParseArgs =- [ optionVerbosity installVerbosity (\v flags -> flags{installVerbosity = v})- , optionDistPref- installDistPref- (\d flags -> flags{installDistPref = d})- showOrParseArgs- , option+installOptions :: [OptionField InstallFlags]+installOptions =+ [ option "" ["inplace"] "install the package in the install subdirectory of the dist prefix, so it can be used without being installed"@@ -143,7 +169,7 @@ ( reqArg "DATABASE" (succeedReadE (Flag . CopyToDb))- (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> [])+ (\case Flag (CopyToDb p) -> [p]; _ -> []) ) ]
src/Distribution/Simple/Setup/Register.hs view
@@ -1,10 +1,9 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-}-------------------------------------------------------------------------------+{-# LANGUAGE ViewPatterns #-} -- | -- Module : Distribution.Simple.Setup.Register@@ -18,7 +17,15 @@ -- Definition of the register command-line options. -- See: @Distribution.Simple.Setup@ module Distribution.Simple.Setup.Register- ( RegisterFlags (..)+ ( RegisterFlags+ ( RegisterCommonFlags+ , registerVerbosity+ , registerDistPref+ , registerCabalFilePath+ , registerWorkingDir+ , registerTargets+ , ..+ ) , emptyRegisterFlags , defaultRegisterFlags , registerCommand@@ -31,9 +38,9 @@ import Distribution.Simple.Command hiding (boolOpt, boolOpt') import Distribution.Simple.Compiler import Distribution.Simple.Flag-import Distribution.Verbosity- import Distribution.Simple.Setup.Common+import Distribution.Utils.Path+import Distribution.Verbosity -- ------------------------------------------------------------ @@ -44,31 +51,48 @@ -- | Flags to @register@ and @unregister@: (user package, gen-script, -- in-place, verbosity) data RegisterFlags = RegisterFlags- { regPackageDB :: Flag PackageDB+ { registerCommonFlags :: !CommonSetupFlags+ , regPackageDB :: Flag PackageDB , regGenScript :: Flag Bool- , regGenPkgConf :: Flag (Maybe FilePath)+ , regGenPkgConf :: Flag (Maybe (SymbolicPath Pkg (Dir PkgConf))) , 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)+ deriving (Show, Generic) +pattern RegisterCommonFlags+ :: Flag VerbosityFlags+ -> Flag (SymbolicPath Pkg (Dir Dist))+ -> Flag (SymbolicPath CWD (Dir Pkg))+ -> Flag (SymbolicPath Pkg File)+ -> [String]+ -> RegisterFlags+pattern RegisterCommonFlags+ { registerVerbosity+ , registerDistPref+ , registerWorkingDir+ , registerCabalFilePath+ , registerTargets+ } <-+ ( registerCommonFlags ->+ CommonSetupFlags+ { setupVerbosity = registerVerbosity+ , setupDistPref = registerDistPref+ , setupWorkingDir = registerWorkingDir+ , setupCabalFilePath = registerCabalFilePath+ , setupTargets = registerTargets+ }+ )+ defaultRegisterFlags :: RegisterFlags defaultRegisterFlags = RegisterFlags- { regPackageDB = NoFlag+ { registerCommonFlags = defaultCommonSetupFlags+ , regPackageDB = NoFlag , regGenScript = Flag False , regGenPkgConf = NoFlag , regInPlace = Flag False- , regDistPref = NoFlag , regPrintId = Flag False- , regArgs = []- , regCabalFilePath = mempty- , regVerbosity = Flag normal } registerCommand :: CommandUI RegisterFlags@@ -83,59 +107,58 @@ "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- ]+ withCommonSetupOptions+ registerCommonFlags+ (\c f -> f{registerCommonFlags = c})+ 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 . fmap makeSymbolicPath) (flagToList . fmap (fmap getSymbolicPath)))+ , option+ ""+ ["print-ipid"]+ "print the installed package ID calculated for this package"+ regPrintId+ (\v flags -> flags{regPrintId = v})+ trueArg+ ] } unregisterCommand :: CommandUI RegisterFlags@@ -150,38 +173,37 @@ "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- ]+ withCommonSetupOptions+ registerCommonFlags+ (\c f -> f{registerCommonFlags = c})+ 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
src/Distribution/Simple/Setup/Repl.hs view
@@ -1,10 +1,9 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-}-------------------------------------------------------------------------------+{-# LANGUAGE ViewPatterns #-} -- | -- Module : Distribution.Simple.Setup.Repl@@ -18,7 +17,15 @@ -- Definition of the repl command-line options. -- See: @Distribution.Simple.Setup@ module Distribution.Simple.Setup.Repl- ( ReplFlags (..)+ ( ReplFlags+ ( ReplCommonFlags+ , replVerbosity+ , replDistPref+ , replCabalFilePath+ , replWorkingDir+ , replTargets+ , ..+ ) , defaultReplFlags , replCommand , ReplOptions (..)@@ -32,11 +39,11 @@ import Distribution.Simple.Command hiding (boolOpt, boolOpt') import Distribution.Simple.Flag import Distribution.Simple.Program+import Distribution.Simple.Setup.Common import Distribution.Simple.Utils+import Distribution.Utils.Path import Distribution.Verbosity -import Distribution.Simple.Setup.Common- -- ------------------------------------------------------------ -- * REPL Flags@@ -47,28 +54,52 @@ { replOptionsFlags :: [String] , replOptionsNoLoad :: Flag Bool , replOptionsFlagOutput :: Flag FilePath+ , replWithRepl :: Flag FilePath }- deriving (Show, Generic, Typeable)+ deriving (Show, Generic) +pattern ReplCommonFlags+ :: Flag VerbosityFlags+ -> Flag (SymbolicPath Pkg (Dir Dist))+ -> Flag (SymbolicPath CWD (Dir Pkg))+ -> Flag (SymbolicPath Pkg File)+ -> [String]+ -> ReplFlags+pattern ReplCommonFlags+ { replVerbosity+ , replDistPref+ , replWorkingDir+ , replCabalFilePath+ , replTargets+ } <-+ ( replCommonFlags ->+ CommonSetupFlags+ { setupVerbosity = replVerbosity+ , setupDistPref = replDistPref+ , setupWorkingDir = replWorkingDir+ , setupCabalFilePath = replCabalFilePath+ , setupTargets = replTargets+ }+ )+ instance Binary ReplOptions instance Structured ReplOptions instance Monoid ReplOptions where- mempty = ReplOptions mempty (Flag False) NoFlag+ mempty = ReplOptions mempty (Flag False) NoFlag NoFlag mappend = (<>) instance Semigroup ReplOptions where (<>) = gmappend data ReplFlags = ReplFlags- { replProgramPaths :: [(String, FilePath)]+ { replCommonFlags :: !CommonSetupFlags+ , replProgramPaths :: [(String, FilePath)] , replProgramArgs :: [(String, [String])]- , replDistPref :: Flag FilePath- , replVerbosity :: Flag Verbosity , replReload :: Flag Bool , replReplOptions :: ReplOptions }- deriving (Show, Generic, Typeable)+ deriving (Show, Generic) instance Binary ReplFlags instance Structured ReplFlags@@ -76,10 +107,9 @@ defaultReplFlags :: ReplFlags defaultReplFlags = ReplFlags- { replProgramPaths = mempty+ { replCommonFlags = defaultCommonSetupFlags+ , replProgramPaths = mempty , replProgramArgs = []- , replDistPref = NoFlag- , replVerbosity = Flag normal , replReload = Flag False , replReplOptions = mempty }@@ -100,8 +130,7 @@ , 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"+ ++ "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, "@@ -143,38 +172,37 @@ 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+ withCommonSetupOptions+ replCommonFlags+ (\c f -> f{replCommonFlags = c})+ 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)+ ++ 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})@@ -202,4 +230,11 @@ replOptionsFlagOutput (\p flags -> flags{replOptionsFlagOutput = p}) (reqArg "DIR" (succeedReadE Flag) flagToList)+ , option+ []+ ["with-repl"]+ "Give the path to a program to use for REPL"+ replWithRepl+ (\v flags -> flags{replWithRepl = v})+ (reqArgFlag "PATH") ]
src/Distribution/Simple/Setup/SDist.hs view
@@ -1,10 +1,9 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-}-------------------------------------------------------------------------------+{-# LANGUAGE ViewPatterns #-} -- | -- Module : Distribution.Simple.Setup.SDist@@ -18,7 +17,15 @@ -- Definition of the sdist command-line options. -- See: @Distribution.Simple.Setup@ module Distribution.Simple.Setup.SDist- ( SDistFlags (..)+ ( SDistFlags+ ( SDistCommonFlags+ , sDistVerbosity+ , sDistDistPref+ , sDistCabalFilePath+ , sDistWorkingDir+ , sDistTargets+ , ..+ ) , emptySDistFlags , defaultSDistFlags , sdistCommand@@ -29,9 +36,9 @@ import Distribution.Simple.Command hiding (boolOpt, boolOpt') import Distribution.Simple.Flag-import Distribution.Verbosity- import Distribution.Simple.Setup.Common+import Distribution.Utils.Path+import Distribution.Verbosity -- ------------------------------------------------------------ @@ -41,22 +48,44 @@ -- | Flags to @sdist@: (snapshot, verbosity) data SDistFlags = SDistFlags- { sDistSnapshot :: Flag Bool+ { sDistCommonFlags :: !CommonSetupFlags+ , sDistSnapshot :: Flag Bool , sDistDirectory :: Flag FilePath- , sDistDistPref :: Flag FilePath , sDistListSources :: Flag FilePath- , sDistVerbosity :: Flag Verbosity }- deriving (Show, Generic, Typeable)+ deriving (Show, Generic) +pattern SDistCommonFlags+ :: Flag VerbosityFlags+ -> Flag (SymbolicPath Pkg (Dir Dist))+ -> Flag (SymbolicPath CWD (Dir Pkg))+ -> Flag (SymbolicPath Pkg File)+ -> [String]+ -> SDistFlags+pattern SDistCommonFlags+ { sDistVerbosity+ , sDistDistPref+ , sDistWorkingDir+ , sDistCabalFilePath+ , sDistTargets+ } <-+ ( sDistCommonFlags ->+ CommonSetupFlags+ { setupVerbosity = sDistVerbosity+ , setupDistPref = sDistDistPref+ , setupWorkingDir = sDistWorkingDir+ , setupCabalFilePath = sDistCabalFilePath+ , setupTargets = sDistTargets+ }+ )+ defaultSDistFlags :: SDistFlags defaultSDistFlags = SDistFlags- { sDistSnapshot = Flag False+ { sDistCommonFlags = defaultCommonSetupFlags+ , sDistSnapshot = Flag False , sDistDirectory = mempty- , sDistDistPref = NoFlag , sDistListSources = mempty- , sDistVerbosity = Flag normal } sdistCommand :: CommandUI SDistFlags@@ -71,35 +100,34 @@ "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")- ]+ withCommonSetupOptions+ sDistCommonFlags+ (\c f -> f{sDistCommonFlags = c})+ 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
src/Distribution/Simple/Setup/Test.hs view
@@ -1,10 +1,9 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-}-------------------------------------------------------------------------------+{-# LANGUAGE ViewPatterns #-} -- | -- Module : Distribution.Simple.Test@@ -18,7 +17,15 @@ -- Definition of the testing command-line options. -- See: @Distribution.Simple.Setup@ module Distribution.Simple.Setup.Test- ( TestFlags (..)+ ( TestFlags+ ( TestCommonFlags+ , testVerbosity+ , testDistPref+ , testCabalFilePath+ , testWorkingDir+ , testTargets+ , ..+ ) , emptyTestFlags , defaultTestFlags , testCommand@@ -36,11 +43,12 @@ import Distribution.Simple.Command hiding (boolOpt, boolOpt') import Distribution.Simple.Flag import Distribution.Simple.InstallDirs+import Distribution.Simple.Setup.Common import Distribution.Simple.Utils+import Distribution.Utils.Path import Distribution.Verbosity-import qualified Text.PrettyPrint as Disp -import Distribution.Simple.Setup.Common+import qualified Text.PrettyPrint as Disp -- ------------------------------------------------------------ @@ -49,9 +57,10 @@ -- ------------------------------------------------------------ data TestShowDetails = Never | Failures | Always | Streaming | Direct- deriving (Eq, Ord, Enum, Bounded, Generic, Show, Typeable)+ deriving (Eq, Ord, Enum, Bounded, Generic, Show) instance Binary TestShowDetails+instance NFData TestShowDetails instance Structured TestShowDetails knownTestShowDetails :: [TestShowDetails]@@ -77,11 +86,10 @@ mappend = (<>) instance Semigroup TestShowDetails where- a <> b = if a < b then b else a+ a <> b = max a b data TestFlags = TestFlags- { testDistPref :: Flag FilePath- , testVerbosity :: Flag Verbosity+ { testCommonFlags :: !CommonSetupFlags , testHumanLog :: Flag PathTemplate , testMachineLog :: Flag PathTemplate , testShowDetails :: Flag TestShowDetails@@ -91,18 +99,41 @@ , -- TODO: think about if/how options are passed to test exes testOptions :: [PathTemplate] }- deriving (Show, Generic, Typeable)+ deriving (Show, Generic) +pattern TestCommonFlags+ :: Flag VerbosityFlags+ -> Flag (SymbolicPath Pkg (Dir Dist))+ -> Flag (SymbolicPath CWD (Dir Pkg))+ -> Flag (SymbolicPath Pkg File)+ -> [String]+ -> TestFlags+pattern TestCommonFlags+ { testVerbosity+ , testDistPref+ , testWorkingDir+ , testCabalFilePath+ , testTargets+ } <-+ ( testCommonFlags ->+ CommonSetupFlags+ { setupVerbosity = testVerbosity+ , setupDistPref = testDistPref+ , setupWorkingDir = testWorkingDir+ , setupCabalFilePath = testCabalFilePath+ , setupTargets = testTargets+ }+ )+ instance Binary TestFlags instance Structured TestFlags defaultTestFlags :: TestFlags defaultTestFlags = TestFlags- { testDistPref = NoFlag- , testVerbosity = Flag normal- , testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log"- , testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log"+ { testCommonFlags = defaultCommonSetupFlags+ , testHumanLog = toFlag $ toPathTemplate "$pkgid-$test-suite.log"+ , testMachineLog = toFlag $ toPathTemplate "$pkgid.log" , testShowDetails = toFlag Direct , testKeepTix = toFlag False , testWrapper = NoFlag@@ -132,116 +163,116 @@ testOptions' :: ShowOrParseArgs -> [OptionField TestFlags] testOptions' showOrParseArgs =- [ 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)- )- ]+ withCommonSetupOptions+ testCommonFlags+ (\c f -> f{testCommonFlags = c})+ 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 "+ ++ "(split on spaces, use \"\" to prevent splitting; "+ ++ "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 "+ ++ "(passed directly as a single argument; "+ ++ "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
+ src/Distribution/Simple/SetupHooks/Errors.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE StandaloneDeriving #-}++-----------------------------------------------------------------------------++-- Module : Distribution.Simple.SetupHooks.Errors+-- Copyright :+-- License :+--+-- Maintainer :+-- Portability :+--+-- Exceptions for the Hooks build-type.++module Distribution.Simple.SetupHooks.Errors+ ( SetupHooksException (..)+ , CannotApplyComponentDiffReason (..)+ , IllegalComponentDiffReason (..)+ , RulesException (..)+ , setupHooksExceptionCode+ , setupHooksExceptionMessage+ ) where++import Distribution.PackageDescription+import Distribution.Simple.SetupHooks.Rule+import qualified Distribution.Simple.SetupHooks.Rule as Rule+import Distribution.Types.Component++import qualified Data.Graph as Graph+import qualified Data.List.NonEmpty as NE+import qualified Data.Tree as Tree++--------------------------------------------------------------------------------++-- | An error involving the @SetupHooks@ module of a package with+-- Hooks build-type.+data SetupHooksException+ = -- | Cannot apply a diff to a component in a per-component configure hook.+ CannotApplyComponentDiff CannotApplyComponentDiffReason+ | -- | An error with pre-build rules.+ RulesException RulesException+ deriving (Show)++-- | AN error involving the @Rules@ in the @SetupHooks@ module of a+-- package with the Hooks build-type.+data RulesException+ = -- | There are cycles in the dependency graph of fine-grained rules.+ CyclicRuleDependencies+ (NE.NonEmpty (RuleBinary, [Graph.Tree RuleBinary]))+ | -- | When executing fine-grained rules compiled into the external hooks+ -- executable, we failed to find dependencies of a rule.+ CantFindSourceForRuleDependencies+ RuleBinary+ (NE.NonEmpty Rule.Location)+ -- ^ missing dependencies+ | -- | When executing fine-grained rules compiled into the external hooks+ -- executable, a rule failed to generate the outputs it claimed it would.+ MissingRuleOutputs+ RuleBinary+ (NE.NonEmpty Rule.Location)+ -- ^ missing outputs+ | -- | An invalid reference to a rule output, e.g. an out-of-range+ -- index.+ InvalidRuleOutputIndex+ RuleId+ -- ^ rule+ RuleId+ -- ^ dependency+ (NE.NonEmpty Rule.Location)+ -- ^ outputs of dependency+ Word+ -- ^ the invalid index+ | -- | A duplicate 'RuleId' in the construction of pre-build rules.+ DuplicateRuleId !RuleId !Rule !Rule++deriving instance Show RulesException++data CannotApplyComponentDiffReason+ = MismatchedComponentTypes Component Component+ | IllegalComponentDiff Component (NE.NonEmpty IllegalComponentDiffReason)+ deriving (Show)++data IllegalComponentDiffReason+ = CannotChangeName+ | CannotChangeComponentField String+ | CannotChangeBuildInfoField String+ deriving (Show)++setupHooksExceptionCode :: SetupHooksException -> Int+setupHooksExceptionCode = \case+ CannotApplyComponentDiff rea ->+ cannotApplyComponentDiffCode rea+ RulesException rea ->+ rulesExceptionCode rea++rulesExceptionCode :: RulesException -> Int+rulesExceptionCode = \case+ CyclicRuleDependencies{} -> 9077+ CantFindSourceForRuleDependencies{} -> 1071+ MissingRuleOutputs{} -> 3498+ InvalidRuleOutputIndex{} -> 1173+ DuplicateRuleId{} -> 7717++setupHooksExceptionMessage :: SetupHooksException -> String+setupHooksExceptionMessage = \case+ CannotApplyComponentDiff reason ->+ cannotApplyComponentDiffMessage reason+ RulesException reason ->+ rulesExceptionMessage reason++rulesExceptionMessage :: RulesException -> String+rulesExceptionMessage = \case+ CyclicRuleDependencies cycles ->+ unlines $+ ("Hooks: cycle" ++ plural ++ " in dependency structure of rules:")+ : map showCycle (NE.toList cycles)+ where+ plural :: String+ plural+ | NE.length cycles >= 2 =+ "s"+ | otherwise =+ ""+ showCycle :: (RuleBinary, [Graph.Tree RuleBinary]) -> String+ showCycle (r, rs) =+ unlines . map (" " ++) . lines $+ Tree.drawTree $+ fmap show $+ Tree.Node r rs+ CantFindSourceForRuleDependencies _r deps ->+ unlines $+ ("Pre-build rules: can't find source for rule " ++ what ++ ":")+ : map (\d -> " - " <> show d) depsL+ where+ depsL = NE.toList deps+ what+ | length depsL == 1 =+ "dependency"+ | otherwise =+ "dependencies"+ MissingRuleOutputs _r reslts ->+ unlines $+ ("Pre-build rule did not generate expected result" <> plural <> ":")+ : map (\res -> " - " <> show res) resultsL+ where+ resultsL = NE.toList reslts+ plural+ | length resultsL == 1 =+ ""+ | otherwise =+ "s"+ InvalidRuleOutputIndex rId depRuleId outputs i -> unlines [header, body]+ where+ header = "Invalid index '" ++ show i ++ "' in dependency of " ++ show rId ++ "."+ nbOutputs = NE.length outputs+ body+ | (fromIntegral i :: Int) >= 0 =+ unwords+ [ "The dependency"+ , show depRuleId+ , "only has"+ , show nbOutputs+ , "output" ++ plural ++ "."+ ]+ | otherwise =+ "The index is too large."+ plural = if nbOutputs == 1 then "" else "s"+ DuplicateRuleId rId r1 r2 ->+ unlines+ [ "Duplicate pre-build rule (" <> show rId <> ")"+ , " - " <> show (ruleBinary r1)+ , " - " <> show (ruleBinary r2)+ ]++cannotApplyComponentDiffCode :: CannotApplyComponentDiffReason -> Int+cannotApplyComponentDiffCode = \case+ MismatchedComponentTypes{} -> 9491+ IllegalComponentDiff{} -> 7634++cannotApplyComponentDiffMessage :: CannotApplyComponentDiffReason -> String+cannotApplyComponentDiffMessage = \case+ MismatchedComponentTypes comp diff ->+ unlines+ [ "Hooks: mismatched component types in per-component configure hook."+ , "Trying to apply " ++ what ++ " diff to " ++ to ++ "."+ ]+ where+ what = case diff of+ CLib{} -> "a library"+ CFLib{} -> "a foreign library"+ CExe{} -> "an executable"+ CTest{} -> "a testsuite"+ CBench{} -> "a benchmark"+ to = case componentName comp of+ nm@(CExeName{}) -> "an " ++ showComponentName nm+ nm -> "a " ++ showComponentName nm+ IllegalComponentDiff comp reasons ->+ unlines $+ ("Hooks: illegal component diff in per-component pre-configure hook for " ++ what ++ ":")+ : map mk_rea (NE.toList reasons)+ where+ mk_rea err = " - " ++ illegalComponentDiffMessage err ++ "."+ what = case componentName comp of+ CLibName LMainLibName -> "main library"+ nm -> showComponentName nm++illegalComponentDiffMessage :: IllegalComponentDiffReason -> String+illegalComponentDiffMessage = \case+ CannotChangeName ->+ "cannot change the name of a component"+ CannotChangeComponentField fld ->+ "cannot change component field '" ++ fld ++ "'"+ CannotChangeBuildInfoField fld ->+ "cannot change BuildInfo field '" ++ fld ++ "'"
+ src/Distribution/Simple/SetupHooks/HooksMain.hs view
@@ -0,0 +1,407 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}++-- | Implementation of hooks executables for @build-type: Hooks@ packages.+--+-- A hooks executable is a small program compiled from the @SetupHooks.hs@+-- module of a package with @build-type: Hooks@. Its @main@ function is:+--+-- > import Distribution.Simple.SetupHooks.HooksMain (hooksMain)+-- > import SetupHooks (setupHooks)+-- > main = hooksMain setupHooks+--+-- @cabal-install@ communicates with the external hooks executable to implement+-- the hooks in a package with @build-type: Hooks@.+module Distribution.Simple.SetupHooks.HooksMain+ ( -- * Main entry point for hooks executables+ hooksMain++ -- * Hooks version handshake+ , HooksVersion (..)+ , hooksVersion+ , CabalABI (..)+ , HooksABI (..)+ ) where++-- base+import Control.Monad+ ( (>=>)+ )+import Control.Monad.IO.Class+ ( liftIO+ )+import GHC.Exception+import System.Environment+ ( getArgs+ )+import System.IO+ ( Handle+ , hClose+ , hFlush+ )++-- bytestring+import Data.ByteString.Lazy as LBS+ ( ByteString+ , hGetContents+ , hPutStr+ , null+ )++-- containers+import qualified Data.Map as Map++-- process+import System.Process.CommunicationHandle+ ( openCommunicationHandleRead+ , openCommunicationHandleWrite+ )++-- transformers+import Control.Monad.Trans.Except+ ( ExceptT+ , runExceptT+ , throwE+ )++-- Cabal-syntax+import qualified Distribution.Compat.Binary as Binary+ ( decodeOrFail+ , encode+ )+import Distribution.Types.Version+ ( Version+ )+import Distribution.Utils.Structured+ ( MD5+ , structureHash+ )++-- Cabal+import Distribution.Compat.Prelude+import Distribution.Simple.SetupHooks.Internal+import Distribution.Simple.SetupHooks.Rule+import Distribution.Simple.Utils+ ( VerboseException (..)+ , cabalVersion+ , dieWithException+ , exceptionWithMetadata+ , withOutputMarker+ )+import Distribution.Types.Component+ ( componentName+ )+import qualified Distribution.Types.LocalBuildConfig as LBC+import Distribution.Types.LocalBuildInfo+ ( LocalBuildInfo+ )+import Distribution.Verbosity+ ( Verbosity+ , defaultVerbosityHandles+ , mkVerbosity+ )+import qualified Distribution.Verbosity as Verbosity+ ( normal+ )++--------------------------------------------------------------------------------+-- Hooks version++-- | The version of the Hooks API in use.+--+-- Used for handshake before beginning inter-process communication.+data HooksVersion = HooksVersion+ { hooksAPIVersion :: !Version+ , cabalABIHash :: !MD5+ , hooksABIHash :: !MD5+ }+ deriving stock (Eq, Ord, Show, Generic)+ deriving anyclass (Binary)++-- | The version of the Hooks API built into this version of the Cabal library.+--+-- Used for handshake before beginning inter-process communication.+hooksVersion :: HooksVersion+hooksVersion =+ HooksVersion+ { hooksAPIVersion = cabalVersion+ , cabalABIHash = structureHash $ Proxy @CabalABI+ , hooksABIHash = structureHash $ Proxy @HooksABI+ }++-- | Tracks the parts of the Cabal API relevant to its binary interface.+data CabalABI = CabalABI+ { cabalLocalBuildInfo :: LocalBuildInfo+ }+ deriving stock (Generic)++deriving anyclass instance Structured CabalABI++-- | Tracks the parts of the Hooks API relevant to its binary interface.+data HooksABI = HooksABI+ { confHooks+ :: ( (PreConfPackageInputs, PreConfPackageOutputs)+ , PostConfPackageInputs+ , (PreConfComponentInputs, PreConfComponentOutputs)+ )+ , buildHooks+ :: ( PreBuildComponentInputs+ , (RuleId, Rule, RuleBinary)+ , PostBuildComponentInputs+ )+ , installHooks :: InstallComponentInputs+ }+ deriving stock (Generic)++deriving anyclass instance Structured HooksABI++--------------------------------------------------------------------------------+-- Error types (internal)++data SetupHooksExeException+ = -- | Missing hook type argument.+ NoHookType+ | -- | Could not parse a communication handle argument.+ NoHandle (Maybe String)+ | -- | Incorrect arguments passed to the hooks executable.+ BadHooksExeArgs+ String+ -- ^ hook name+ BadHooksExecutableArgs+ deriving (Show)++-- | An error describing an invalid argument passed to a hooks executable.+data BadHooksExecutableArgs+ = -- | Unknown hook type was requested.+ UnknownHookType+ {knownHookTypes :: [String]}+ | -- | Failed to decode the binary input to a hook.+ CouldNotDecodeInput+ ByteString+ -- ^ hook input that failed to decode+ Int64+ -- ^ byte offset at which decoding failed+ String+ -- ^ decoding error message+ | -- | The rule does not have a dynamic dependency computation.+ NoDynDepsCmd RuleId+ deriving (Show)++setupHooksExeExceptionCode :: SetupHooksExeException -> Int+setupHooksExeExceptionCode = \case+ NoHookType -> 7982+ NoHandle{} -> 8811+ BadHooksExeArgs _ rea -> badHooksExeArgsCode rea++setupHooksExeExceptionMessage :: SetupHooksExeException -> String+setupHooksExeExceptionMessage = \case+ NoHookType ->+ "Missing argument to Hooks executable.\n\+ \Expected two arguments: communication handle and hook type."+ NoHandle Nothing ->+ "Missing argument to Hooks executable.\n\+ \Expected two arguments: communication handle and hook type."+ NoHandle (Just h) ->+ "Invalid handle reference passed to Hooks executable: '" ++ h ++ "'."+ BadHooksExeArgs hookName reason ->+ badHooksExeArgsMessage hookName reason++badHooksExeArgsCode :: BadHooksExecutableArgs -> Int+badHooksExeArgsCode = \case+ UnknownHookType{} -> 4229+ CouldNotDecodeInput{} -> 9121+ NoDynDepsCmd{} -> 3231++badHooksExeArgsMessage :: String -> BadHooksExecutableArgs -> String+badHooksExeArgsMessage hookName = \case+ UnknownHookType knownHookNames ->+ "Unknown hook type "+ ++ hookName+ ++ ".\n\+ \Known hook types are: "+ ++ show knownHookNames+ ++ "."+ CouldNotDecodeInput _bytes offset err ->+ "Failed to decode the input to the "+ ++ hookName+ ++ " hook.\n\+ \Decoding failed at position "+ ++ show offset+ ++ " with error: "+ ++ err+ ++ ".\n\+ \This could be due to a mismatch between the Cabal version of cabal-install\+ \ and of the hooks executable."+ NoDynDepsCmd rId ->+ unlines+ [ "Unexpected rule " <> show rId <> " in the " <> hookName <> " hook."+ , "The rule does not have an associated dynamic dependency computation."+ ]++instance Exception (VerboseException SetupHooksExeException) where+ displayException :: VerboseException SetupHooksExeException -> String+ displayException (VerboseException stack timestamp verb err) =+ withOutputMarker+ verb+ ( concat+ [ "Error: [Cabal-"+ , show (setupHooksExeExceptionCode err)+ , "]\n"+ ]+ )+ ++ exceptionWithMetadata stack timestamp verb (setupHooksExeExceptionMessage err)++-- | The verbosity used inside the hooks executable.+--+-- The hooks executable is always invoked as a separate process, so stdout+-- and stderr are available for verbosity output and can be redirected via+-- the @System.Process@ API.+hooksExeVerbosity :: Verbosity+hooksExeVerbosity = mkVerbosity defaultVerbosityHandles Verbosity.normal++--------------------------------------------------------------------------------+-- Main entry point++-- | Create a hooks executable @main@ given the package's 'SetupHooks'.+--+-- The executable expects three command-line arguments:+--+-- 1. A reference to an input communication handle (to read hook inputs from).+-- 2. A reference to an output communication handle (to write hook outputs to).+-- 3. The hook type to run.+--+-- The hook reads binary-encoded data from the input handle, runs the+-- requested hook, and writes the binary-encoded result to the output handle.+hooksMain :: SetupHooks -> IO ()+hooksMain setupHooks = runHooksM $ do+ ((hRead, hWrite), hookName) <- getHooksMainArgs+ case lookup hookName allHookHandlers of+ Just handleAction ->+ handleAction (hRead, hWrite) setupHooks+ Nothing ->+ throwE $+ BadHooksExeArgs hookName $+ UnknownHookType+ { knownHookTypes = map fst allHookHandlers+ }+ where+ allHookHandlers = [(hookName h, hookHandler h) | h <- hookHandlers]++ -- Get the communication handles and the name of the hook to run+ getHooksMainArgs :: HooksM ((Handle, Handle), String)+ getHooksMainArgs =+ liftIO getArgs >>= \case+ inputFdRef : outputFdRef : hookNm : _ ->+ case (readMaybe inputFdRef, readMaybe outputFdRef) of+ (Just readNm, Just writeNm) -> do+ hRead <- liftIO $ openCommunicationHandleRead readNm+ hWrite <- liftIO $ openCommunicationHandleWrite writeNm+ return ((hRead, hWrite), hookNm)+ (Nothing, _) ->+ throwE $ NoHandle (Just $ "hook input communication handle '" ++ inputFdRef ++ "'")+ (_, Nothing) ->+ throwE $ NoHandle (Just $ "hook output communication handle '" ++ outputFdRef ++ "'")+ _ -> throwE $ NoHandle Nothing++type HooksM = ExceptT SetupHooksExeException IO++runHooksM :: HooksM a -> IO a+runHooksM = runExceptT >=> either (dieWithException hooksExeVerbosity) pure++-- | Run a hook by reading its input from a handle, invoking it, and writing+-- its output to another handle.+runHookHandle+ :: forall inputs outputs+ . (Binary inputs, Binary outputs)+ => (Handle, Handle)+ -- ^ Input and output communication handles+ -> String+ -- ^ Hook name (used in error messages)+ -> (inputs -> HooksM outputs)+ -- ^ The hook to run+ -> HooksM ()+runHookHandle (hRead, hWrite) hookName hook = do+ inputsData <- liftIO $ LBS.hGetContents hRead+ let mb_inputs = Binary.decodeOrFail inputsData+ case mb_inputs of+ Left (_, offset, err) ->+ throwE $+ BadHooksExeArgs hookName $+ CouldNotDecodeInput inputsData offset err+ Right (_, _, inputs) ->+ hook inputs >>= \output -> liftIO $ do+ let outputData = Binary.encode output+ unless (LBS.null outputData) $+ LBS.hPutStr hWrite outputData+ hFlush hWrite+ hClose hWrite++data HookHandler = HookHandler+ { hookName :: !String+ , hookHandler :: (Handle, Handle) -> SetupHooks -> HooksM ()+ }++hookHandlers :: [HookHandler]+hookHandlers =+ [ let hookName = "version"+ in HookHandler hookName $ \h _ ->+ runHookHandle h hookName $ \() ->+ return hooksVersion+ , let hookName = "preConfPackage"+ noHook (PreConfPackageInputs{localBuildConfig = lbc}) =+ return $+ PreConfPackageOutputs+ { buildOptions = LBC.withBuildOptions lbc+ , extraConfiguredProgs = Map.empty+ }+ in HookHandler hookName $ \h (SetupHooks{configureHooks = ConfigureHooks{..}}) ->+ runHookHandle h hookName $ maybe noHook (liftIO .) preConfPackageHook+ , let hookName = "postConfPackage"+ noHook _ = return ()+ in HookHandler hookName $ \h (SetupHooks{configureHooks = ConfigureHooks{..}}) ->+ runHookHandle h hookName $ maybe noHook (liftIO .) postConfPackageHook+ , let hookName = "preConfComponent"+ noHook (PreConfComponentInputs{component = c}) =+ return $ PreConfComponentOutputs{componentDiff = emptyComponentDiff $ componentName c}+ in HookHandler hookName $ \h (SetupHooks{configureHooks = ConfigureHooks{..}}) ->+ runHookHandle h hookName $ maybe noHook (liftIO .) preConfComponentHook+ , let hookName = "preBuildRules"+ in HookHandler hookName $ \h (SetupHooks{buildHooks = BuildHooks{..}}) ->+ runHookHandle h hookName $ \preBuildInputs ->+ case preBuildComponentRules of+ Nothing -> return (Map.empty, [])+ Just pbcRules ->+ liftIO $+ computeRules hooksExeVerbosity preBuildInputs pbcRules+ , let hookName = "runPreBuildRuleDeps"+ in HookHandler hookName $ \h _ ->+ runHookHandle h hookName $ \(ruleId, ruleDeps) ->+ case runRuleDynDepsCmd ruleDeps of+ Nothing ->+ throwE $+ BadHooksExeArgs hookName $+ NoDynDepsCmd ruleId+ Just getDeps -> liftIO getDeps+ , let hookName = "runPreBuildRule"+ in HookHandler hookName $ \h _ ->+ runHookHandle h hookName $ \(_ruleId :: RuleId, rExecCmd) ->+ liftIO $ runRuleExecCmd rExecCmd+ , let hookName = "postBuildComponent"+ noHook _ = return ()+ in HookHandler hookName $ \h (SetupHooks{buildHooks = BuildHooks{..}}) ->+ runHookHandle h hookName $ maybe noHook (liftIO .) postBuildComponentHook+ , let hookName = "installComponent"+ noHook _ = return ()+ in HookHandler hookName $ \h (SetupHooks{installHooks = InstallHooks{..}}) ->+ runHookHandle h hookName $ maybe noHook (liftIO .) installComponentHook+ ]
+ src/Distribution/Simple/SetupHooks/Internal.hs view
@@ -0,0 +1,1299 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module: Distribution.Simple.SetupHooks.Internal+--+-- Internal implementation module for 'SetupHooks'.+--+-- Users of @build-type: Hooks@ should import "Distribution.Simple.SetupHooks"+-- instead.+module Distribution.Simple.SetupHooks.Internal+ ( -- * The setup hooks datatype+ SetupHooks (..)+ , noSetupHooks++ -- * Configure hooks+ , ConfigureHooks (..)+ , noConfigureHooks++ -- ** Per-package configure hooks+ , PreConfPackageInputs (..)+ , PreConfPackageOutputs (..)+ , noPreConfPackageOutputs+ , PreConfPackageHook+ , PostConfPackageInputs (..)+ , PostConfPackageHook++ -- ** Per-component configure hooks+ , PreConfComponentInputs (..)+ , PreConfComponentOutputs (..)+ , noPreConfComponentOutputs+ , PreConfComponentHook+ , ComponentDiff (..)+ , emptyComponentDiff+ , buildInfoComponentDiff+ , LibraryDiff+ , ForeignLibDiff+ , ExecutableDiff+ , TestSuiteDiff+ , BenchmarkDiff+ , BuildInfoDiff++ -- * Build hooks+ , BuildHooks (..)+ , noBuildHooks+ , BuildingWhat (..)+ , buildingWhatVerbosity+ , buildingWhatWorkingDir+ , buildingWhatDistPref++ -- ** Pre-build rules+ , PreBuildComponentInputs (..)+ , PreBuildComponentRules++ -- ** Post-build hook+ , PostBuildComponentInputs (..)+ , PostBuildComponentHook++ -- * Install hooks+ , InstallHooks (..)+ , noInstallHooks+ , InstallComponentInputs (..)+ , InstallComponentHook++ -- * Internals++ -- ** Per-component hook utilities+ , applyComponentDiffs+ , forComponents_++ -- ** Executing build rules+ , executeRules+ , executeRulesUserOrSystem++ -- ** HookedBuildInfo compatibility code+ , hookedBuildInfoComponents+ , hookedBuildInfoComponentDiff_maybe+ )+where++import Distribution.Compat.Prelude+import Prelude ()++import Distribution.Compat.Lens ((.~))+import Distribution.ModuleName (ModuleName)+import Distribution.PackageDescription+import Distribution.Pretty (prettyShow)+import Distribution.Simple.BuildPaths+import Distribution.Simple.Compiler (Compiler (..))+import Distribution.Simple.Errors+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Program.Db+import Distribution.Simple.Setup+ ( BuildingWhat (..)+ , buildingWhatDistPref+ , buildingWhatVerbosity+ , buildingWhatWorkingDir+ )+import Distribution.Simple.Setup.Build (BuildFlags (..))+import Distribution.Simple.Setup.Config (ConfigFlags (..))+import Distribution.Simple.Setup.Copy (CopyFlags (..))+import Distribution.Simple.SetupHooks.Errors+import Distribution.Simple.SetupHooks.Rule+import qualified Distribution.Simple.SetupHooks.Rule as Rule+import Distribution.Simple.Utils+import Distribution.System (Platform (..))+import Distribution.Utils.Path+import Distribution.Utils.Structured+ ( structuredDecodeOrFailIO+ , structuredEncodeFile+ )++import qualified Distribution.Types.BuildInfo.Lens as BI (buildInfo)+import Distribution.Types.LocalBuildConfig as LBC+import Distribution.Types.TargetInfo+import Distribution.Verbosity++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Data.Coerce (coerce)+import Data.Either (fromRight)+import qualified Data.Graph as Graph+import Data.IORef (IORef, modifyIORef', newIORef, readIORef)+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as Map+import Data.Monoid (Ap (..))+import qualified Data.Set as Set++import System.Directory (doesFileExist, getModificationTime)+import qualified System.FilePath as FilePath++--------------------------------------------------------------------------------+-- SetupHooks++-- | Hooks into the @cabal@ build phases.+--+-- Usage:+--+-- - In your @.cabal@ file, declare @build-type: Hooks@+-- (with a @cabal-version@ greater than or equal to @3.14@),+-- - In your @.cabal@ file, include a @custom-setup@ stanza+-- which declares the dependencies of your @SetupHooks@ module;+-- this will usually contain a dependency on the @Cabal-hooks@ package.+-- - Provide a @SetupHooks.hs@ module next to your @.cabal@ file;+-- it must export @setupHooks :: SetupHooks@.+data SetupHooks = SetupHooks+ { configureHooks :: ConfigureHooks+ -- ^ Hooks into the configure phase.+ , buildHooks :: BuildHooks+ -- ^ Hooks into the build phase.+ --+ -- These hooks are relevant to any build-like phase,+ -- such as repl or haddock.+ , installHooks :: InstallHooks+ -- ^ Hooks into the copy/install phase.+ }++-- | 'SetupHooks' can be combined monoidally. This is useful to combine+-- setup hooks defined by another package with your own package-specific+-- hooks.+--+-- __Warning__: this 'Semigroup' instance is not commutative.+instance Semigroup SetupHooks where+ SetupHooks+ { configureHooks = conf1+ , buildHooks = build1+ , installHooks = inst1+ }+ <> SetupHooks+ { configureHooks = conf2+ , buildHooks = build2+ , installHooks = inst2+ } =+ SetupHooks+ { configureHooks = conf1 <> conf2+ , buildHooks = build1 <> build2+ , installHooks = inst1 <> inst2+ }++instance Monoid SetupHooks where+ mempty = noSetupHooks++-- | Empty hooks.+noSetupHooks :: SetupHooks+noSetupHooks =+ SetupHooks+ { configureHooks = noConfigureHooks+ , buildHooks = noBuildHooks+ , installHooks = noInstallHooks+ }++--------------------------------------------------------------------------------+-- Configure hooks.++type PreConfPackageHook = PreConfPackageInputs -> IO PreConfPackageOutputs++-- | Inputs to the package-wide pre-configure step.+data PreConfPackageInputs = PreConfPackageInputs+ { configFlags :: ConfigFlags+ , localBuildConfig :: LocalBuildConfig+ -- ^ Warning: the 'ProgramDb' in the 'withPrograms' field+ -- will not contain any unconfigured programs.+ , compiler :: Compiler+ , platform :: Platform+ }+ deriving (Generic, Show)++-- | Outputs of the package-wide pre-configure step.+--+-- Prefer using 'noPreConfPackageOutputs' and overriding the fields+-- you care about, to avoid depending on implementation details+-- of this datatype.+data PreConfPackageOutputs = PreConfPackageOutputs+ { buildOptions :: BuildOptions+ , extraConfiguredProgs :: ConfiguredProgs+ }+ deriving (Generic, Show)++-- | Use this smart constructor to declare an empty set of changes+-- by the package-wide pre-configure hook, and override the fields you+-- care about.+--+-- Use this rather than v'PreConfPackageOutputs' to avoid relying on+-- internal implementation details of the latter.+noPreConfPackageOutputs :: PreConfPackageInputs -> PreConfPackageOutputs+noPreConfPackageOutputs (PreConfPackageInputs{localBuildConfig = lbc}) =+ PreConfPackageOutputs+ { buildOptions = LBC.withBuildOptions lbc+ , extraConfiguredProgs = Map.empty+ }++-- | Package-wide post-configure step.+--+-- Perform side effects. Last opportunity for any package-wide logic;+-- any subsequent hooks work per-component.+type PostConfPackageHook = PostConfPackageInputs -> IO ()++-- | Inputs to the package-wide post-configure step.+data PostConfPackageInputs = PostConfPackageInputs+ { localBuildConfig :: LocalBuildConfig+ , packageBuildDescr :: PackageBuildDescr+ }+ deriving (Generic, Show)++-- | Per-component pre-configure step.+--+-- For each component of the package, this hook can perform side effects,+-- and return a diff to the passed in component, e.g. to declare additional+-- autogenerated modules.+type PreConfComponentHook = PreConfComponentInputs -> IO PreConfComponentOutputs++-- | Inputs to the per-component pre-configure step.+data PreConfComponentInputs = PreConfComponentInputs+ { localBuildConfig :: LocalBuildConfig+ , packageBuildDescr :: PackageBuildDescr+ , component :: Component+ }+ deriving (Generic, Show)++-- | Outputs of the per-component pre-configure step.+--+-- Prefer using 'noPreComponentOutputs' and overriding the fields+-- you care about, to avoid depending on implementation details+-- of this datatype.+data PreConfComponentOutputs = PreConfComponentOutputs+ { componentDiff :: ComponentDiff+ }+ deriving (Generic, Show)++-- | Use this smart constructor to declare an empty set of changes+-- by a per-component pre-configure hook, and override the fields you+-- care about.+--+-- Use this rather than v'PreConfComponentOutputs' to avoid relying on+-- internal implementation details of the latter.+noPreConfComponentOutputs :: PreConfComponentInputs -> PreConfComponentOutputs+noPreConfComponentOutputs (PreConfComponentInputs{component = comp}) =+ PreConfComponentOutputs+ { componentDiff = emptyComponentDiff (componentName comp)+ }++-- | Configure-time hooks.+--+-- Order of execution:+--+-- - 'preConfPackageHook',+-- - configure the package,+-- - 'postConfPackageHook',+-- - 'preConfComponentHook',+-- - configure the components.+data ConfigureHooks = ConfigureHooks+ { preConfPackageHook :: Maybe PreConfPackageHook+ -- ^ Package-wide pre-configure hook. See 'PreConfPackageHook'.+ , postConfPackageHook :: Maybe PostConfPackageHook+ -- ^ Package-wide post-configure hook. See 'PostConfPackageHook'.+ , preConfComponentHook :: Maybe PreConfComponentHook+ -- ^ Per-component pre-configure hook. See 'PreConfComponentHook'.+ }++-- Note: these configure hooks don't track any kind of dependency information,+-- so we won't know when the configuration is out of date and should be re-done.+-- This seems okay: it should only matter while developing the package, in which+-- case it seems acceptable to rely on the user re-configuring.++instance Semigroup ConfigureHooks where+ ConfigureHooks+ { preConfPackageHook = prePkg1+ , postConfPackageHook = postPkg1+ , preConfComponentHook = preComp1+ }+ <> ConfigureHooks+ { preConfPackageHook = prePkg2+ , postConfPackageHook = postPkg2+ , preConfComponentHook = preComp2+ } =+ ConfigureHooks+ { preConfPackageHook =+ coerce+ ((<>) @(Maybe PreConfPkgSemigroup))+ prePkg1+ prePkg2+ , postConfPackageHook =+ postPkg1 <> postPkg2+ , preConfComponentHook =+ coerce+ ((<>) @(Maybe PreConfComponentSemigroup))+ preComp1+ preComp2+ }++instance Monoid ConfigureHooks where+ mempty = noConfigureHooks++-- | Empty configure phase hooks.+noConfigureHooks :: ConfigureHooks+noConfigureHooks =+ ConfigureHooks+ { preConfPackageHook = Nothing+ , postConfPackageHook = Nothing+ , preConfComponentHook = Nothing+ }++-- | A newtype to hang off the @Semigroup PreConfPackageHook@ instance.+newtype PreConfPkgSemigroup = PreConfPkgSemigroup PreConfPackageHook++instance Semigroup PreConfPkgSemigroup where+ PreConfPkgSemigroup f1 <> PreConfPkgSemigroup f2 =+ PreConfPkgSemigroup $+ \inputs@( PreConfPackageInputs+ { configFlags = cfg+ , compiler = comp+ , platform = plat+ , localBuildConfig = lbc0+ }+ ) ->+ do+ PreConfPackageOutputs+ { buildOptions = opts1+ , extraConfiguredProgs = progs1+ } <-+ f1 inputs+ PreConfPackageOutputs+ { buildOptions = opts2+ , extraConfiguredProgs = progs2+ } <-+ f2 $+ PreConfPackageInputs+ { configFlags = cfg+ , compiler = comp+ , platform = plat+ , localBuildConfig =+ lbc0+ { LBC.withPrograms =+ updateConfiguredProgs (`Map.union` progs1) $+ LBC.withPrograms lbc0+ , LBC.withBuildOptions = opts1+ }+ }+ return $+ PreConfPackageOutputs+ { buildOptions = opts2+ , extraConfiguredProgs = progs1 <> progs2+ }++-- | A newtype to hang off the @Semigroup PreConfComponentHook@ instance.+newtype PreConfComponentSemigroup = PreConfComponentSemigroup PreConfComponentHook++instance Semigroup PreConfComponentSemigroup where+ PreConfComponentSemigroup f1 <> PreConfComponentSemigroup f2 =+ PreConfComponentSemigroup $ \inputs ->+ do+ PreConfComponentOutputs+ { componentDiff = diff1+ } <-+ f1 inputs+ PreConfComponentOutputs+ { componentDiff = diff2+ } <-+ f2 inputs+ return $+ PreConfComponentOutputs+ { componentDiff = diff1 <> diff2+ }++--------------------------------------------------------------------------------+-- Build setup hooks.++data PreBuildComponentInputs = PreBuildComponentInputs+ { buildingWhat :: BuildingWhat+ -- ^ what kind of build phase are we hooking into?+ , localBuildInfo :: LocalBuildInfo+ -- ^ information about the package+ , targetInfo :: TargetInfo+ -- ^ information about an individual component+ }+ deriving (Generic, Show)++type PreBuildComponentRules = Rules PreBuildComponentInputs++data PostBuildComponentInputs = PostBuildComponentInputs+ { buildFlags :: BuildFlags+ , localBuildInfo :: LocalBuildInfo+ , targetInfo :: TargetInfo+ }+ deriving (Generic, Show)++type PostBuildComponentHook = PostBuildComponentInputs -> IO ()++-- | Build-time hooks.+data BuildHooks = BuildHooks+ { preBuildComponentRules :: Maybe PreBuildComponentRules+ -- ^ Per-component fine-grained pre-build rules.+ , postBuildComponentHook :: Maybe PostBuildComponentHook+ -- ^ Per-component post-build hook.+ }++-- Note that the pre-build hook consists of a function which takes a component+-- as an argument (as part of the targetInfo field) and returns a collection of+-- pre-build rules.+--+-- One might wonder why it isn't instead a collection of pre-build rules, one+-- for each component. The reason is that Backpack creates components on-the-fly+-- through instantiation, which means e.g. that a single component name can+-- resolve to multiple components. This means we really need to pass in the+-- components to the function, as we don't know the full details (e.g. their+-- unit ids) ahead of time.++instance Semigroup BuildHooks where+ BuildHooks+ { preBuildComponentRules = rs1+ , postBuildComponentHook = post1+ }+ <> BuildHooks+ { preBuildComponentRules = rs2+ , postBuildComponentHook = post2+ } =+ BuildHooks+ { preBuildComponentRules = rs1 <> rs2+ , postBuildComponentHook = post1 <> post2+ }++instance Monoid BuildHooks where+ mempty = noBuildHooks++-- | Empty build hooks.+noBuildHooks :: BuildHooks+noBuildHooks =+ BuildHooks+ { preBuildComponentRules = Nothing+ , postBuildComponentHook = Nothing+ }++--------------------------------------------------------------------------------+-- Install setup hooks.++data InstallComponentInputs = InstallComponentInputs+ { copyFlags :: CopyFlags+ , localBuildInfo :: LocalBuildInfo+ , targetInfo :: TargetInfo+ }+ deriving (Generic, Show)++-- | A per-component install hook,+-- which can only perform side effects (e.g. copying files).+type InstallComponentHook = InstallComponentInputs -> IO ()++-- | Copy/install hooks.+data InstallHooks = InstallHooks+ { installComponentHook :: Maybe InstallComponentHook+ -- ^ Per-component install hook.+ }++instance Semigroup InstallHooks where+ InstallHooks+ { installComponentHook = inst1+ }+ <> InstallHooks+ { installComponentHook = inst2+ } =+ InstallHooks+ { installComponentHook = inst1 <> inst2+ }++instance Monoid InstallHooks where+ mempty = noInstallHooks++-- | Empty copy/install hooks.+noInstallHooks :: InstallHooks+noInstallHooks =+ InstallHooks+ { installComponentHook = Nothing+ }++--------------------------------------------------------------------------------+-- Per-component configure hook implementation details.++type LibraryDiff = Library+type ForeignLibDiff = ForeignLib+type ExecutableDiff = Executable+type TestSuiteDiff = TestSuite+type BenchmarkDiff = Benchmark+type BuildInfoDiff = BuildInfo++-- | A diff to a Cabal 'Component', that gets combined monoidally into+-- an existing 'Component'.+newtype ComponentDiff = ComponentDiff {componentDiff :: Component}+ deriving (Semigroup, Show)++emptyComponentDiff :: ComponentName -> ComponentDiff+emptyComponentDiff name = ComponentDiff $+ case name of+ CLibName{} -> CLib emptyLibrary+ CFLibName{} -> CFLib emptyForeignLib+ CExeName{} -> CExe emptyExecutable+ CTestName{} -> CTest emptyTestSuite+ CBenchName{} -> CBench emptyBenchmark++buildInfoComponentDiff :: ComponentName -> BuildInfo -> ComponentDiff+buildInfoComponentDiff name bi = ComponentDiff $+ BI.buildInfo .~ bi $+ case name of+ CLibName{} -> CLib emptyLibrary+ CFLibName{} -> CFLib emptyForeignLib+ CExeName{} -> CExe emptyExecutable+ CTestName{} -> CTest emptyTestSuite+ CBenchName{} -> CBench emptyBenchmark++applyLibraryDiff :: Verbosity -> Library -> LibraryDiff -> IO Library+applyLibraryDiff verbosity lib diff =+ case illegalLibraryDiffReasons lib diff of+ [] -> return $ lib <> diff+ (r : rs) ->+ dieWithException verbosity $+ SetupHooksException $+ CannotApplyComponentDiff $+ IllegalComponentDiff (CLib lib) (r NE.:| rs)++illegalLibraryDiffReasons :: Library -> LibraryDiff -> [IllegalComponentDiffReason]+illegalLibraryDiffReasons+ lib+ Library+ { libName = nm+ , libExposed = e+ , libVisibility = vis+ , libBuildInfo = bi+ } =+ [ CannotChangeName+ | not $ nm == libName emptyLibrary || nm == libName lib+ ]+ ++ [ CannotChangeComponentField "libExposed"+ | not $ e == libExposed emptyLibrary || e == libExposed lib+ ]+ ++ [ CannotChangeComponentField "libVisibility"+ | not $ vis == libVisibility emptyLibrary || vis == libVisibility lib+ ]+ ++ illegalBuildInfoDiffReasons (libBuildInfo lib) bi++applyForeignLibDiff :: Verbosity -> ForeignLib -> ForeignLibDiff -> IO ForeignLib+applyForeignLibDiff verbosity flib diff =+ case illegalForeignLibDiffReasons flib diff of+ [] -> return $ flib <> diff+ (r : rs) ->+ dieWithException verbosity $+ SetupHooksException $+ CannotApplyComponentDiff $+ IllegalComponentDiff (CFLib flib) (r NE.:| rs)++illegalForeignLibDiffReasons :: ForeignLib -> ForeignLibDiff -> [IllegalComponentDiffReason]+illegalForeignLibDiffReasons+ flib+ ForeignLib+ { foreignLibName = nm+ , foreignLibType = ty+ , foreignLibOptions = opts+ , foreignLibVersionInfo = vi+ , foreignLibVersionLinux = linux+ , foreignLibModDefFile = defs+ , foreignLibBuildInfo = bi+ } =+ [ CannotChangeName+ | not $ nm == foreignLibName emptyForeignLib || nm == foreignLibName flib+ ]+ ++ [ CannotChangeComponentField "foreignLibType"+ | not $ ty == foreignLibType emptyForeignLib || ty == foreignLibType flib+ ]+ ++ [ CannotChangeComponentField "foreignLibOptions"+ | not $ opts == foreignLibOptions emptyForeignLib || opts == foreignLibOptions flib+ ]+ ++ [ CannotChangeComponentField "foreignLibVersionInfo"+ | not $ vi == foreignLibVersionInfo emptyForeignLib || vi == foreignLibVersionInfo flib+ ]+ ++ [ CannotChangeComponentField "foreignLibVersionLinux"+ | not $ linux == foreignLibVersionLinux emptyForeignLib || linux == foreignLibVersionLinux flib+ ]+ ++ [ CannotChangeComponentField "foreignLibModDefFile"+ | not $ defs == foreignLibModDefFile emptyForeignLib || defs == foreignLibModDefFile flib+ ]+ ++ illegalBuildInfoDiffReasons (foreignLibBuildInfo flib) bi++applyExecutableDiff :: Verbosity -> Executable -> ExecutableDiff -> IO Executable+applyExecutableDiff verbosity exe diff =+ case illegalExecutableDiffReasons exe diff of+ [] -> return $ exe <> diff+ (r : rs) ->+ dieWithException verbosity $+ SetupHooksException $+ CannotApplyComponentDiff $+ IllegalComponentDiff (CExe exe) (r NE.:| rs)++illegalExecutableDiffReasons :: Executable -> ExecutableDiff -> [IllegalComponentDiffReason]+illegalExecutableDiffReasons+ exe+ Executable+ { exeName = nm+ , modulePath = path+ , exeScope = scope+ , buildInfo = bi+ } =+ [ CannotChangeName+ | not $ nm == exeName emptyExecutable || nm == exeName exe+ ]+ ++ [ CannotChangeComponentField "modulePath"+ | not $ path == modulePath emptyExecutable || path == modulePath exe+ ]+ ++ [ CannotChangeComponentField "exeScope"+ | not $ scope == exeScope emptyExecutable || scope == exeScope exe+ ]+ ++ illegalBuildInfoDiffReasons (buildInfo exe) bi++applyTestSuiteDiff :: Verbosity -> TestSuite -> TestSuiteDiff -> IO TestSuite+applyTestSuiteDiff verbosity test diff =+ case illegalTestSuiteDiffReasons test diff of+ [] -> return $ test <> diff+ (r : rs) ->+ dieWithException verbosity $+ SetupHooksException $+ CannotApplyComponentDiff $+ IllegalComponentDiff (CTest test) (r NE.:| rs)++illegalTestSuiteDiffReasons :: TestSuite -> TestSuiteDiff -> [IllegalComponentDiffReason]+illegalTestSuiteDiffReasons+ test+ TestSuite+ { testName = nm+ , testInterface = iface+ , testCodeGenerators = gens+ , testBuildInfo = bi+ } =+ [ CannotChangeName+ | not $ nm == testName emptyTestSuite || nm == testName test+ ]+ ++ [ CannotChangeComponentField "testInterface"+ | not $ iface == testInterface emptyTestSuite || iface == testInterface test+ ]+ ++ [ CannotChangeComponentField "testCodeGenerators"+ | not $ gens == testCodeGenerators emptyTestSuite || gens == testCodeGenerators test+ ]+ ++ illegalBuildInfoDiffReasons (testBuildInfo test) bi++applyBenchmarkDiff :: Verbosity -> Benchmark -> BenchmarkDiff -> IO Benchmark+applyBenchmarkDiff verbosity bench diff =+ case illegalBenchmarkDiffReasons bench diff of+ [] -> return $ bench <> diff+ (r : rs) ->+ dieWithException verbosity $+ SetupHooksException $+ CannotApplyComponentDiff $+ IllegalComponentDiff (CBench bench) (r NE.:| rs)++illegalBenchmarkDiffReasons :: Benchmark -> BenchmarkDiff -> [IllegalComponentDiffReason]+illegalBenchmarkDiffReasons+ bench+ Benchmark+ { benchmarkName = nm+ , benchmarkInterface = iface+ , benchmarkBuildInfo = bi+ } =+ [ CannotChangeName+ | not $ nm == benchmarkName emptyBenchmark || nm == benchmarkName bench+ ]+ ++ [ CannotChangeComponentField "benchmarkInterface"+ | not $ iface == benchmarkInterface emptyBenchmark || iface == benchmarkInterface bench+ ]+ ++ illegalBuildInfoDiffReasons (benchmarkBuildInfo bench) bi++illegalBuildInfoDiffReasons :: BuildInfo -> BuildInfoDiff -> [IllegalComponentDiffReason]+illegalBuildInfoDiffReasons+ bi+ BuildInfo+ { buildable = can_build+ , buildTools = build_tools+ , buildToolDepends = build_tools_depends+ , pkgconfigDepends = pkgconfig_depends+ , frameworks = fworks+ , targetBuildDepends = target_build_depends+ } =+ map CannotChangeBuildInfoField $+ [ "buildable"+ | not $ can_build == buildable bi || can_build == buildable emptyBuildInfo+ ]+ ++ [ "buildTools"+ | not $ build_tools == buildTools bi || build_tools == buildTools emptyBuildInfo+ ]+ ++ [ "buildToolsDepends"+ | not $ build_tools_depends == buildToolDepends bi || build_tools_depends == buildToolDepends emptyBuildInfo+ ]+ ++ [ "pkgconfigDepends"+ | not $ pkgconfig_depends == pkgconfigDepends bi || pkgconfig_depends == pkgconfigDepends emptyBuildInfo+ ]+ ++ [ "frameworks"+ | not $ fworks == frameworks bi || fworks == frameworks emptyBuildInfo+ ]+ ++ [ "targetBuildDepends"+ | not $ target_build_depends == targetBuildDepends bi || target_build_depends == targetBuildDepends emptyBuildInfo+ ]++-- | Traverse the components of a 'PackageDescription'.+--+-- The function must preserve the component type, i.e. map a 'CLib' to a 'CLib',+-- a 'CExe' to a 'CExe', etc.+traverseComponents+ :: Applicative m+ => (Component -> m Component)+ -> PackageDescription+ -> m PackageDescription+traverseComponents f pd =+ upd_pd+ <$> traverse f_lib (library pd)+ <*> traverse f_lib (subLibraries pd)+ <*> traverse f_flib (foreignLibs pd)+ <*> traverse f_exe (executables pd)+ <*> traverse f_test (testSuites pd)+ <*> traverse f_bench (benchmarks pd)+ where+ f_lib lib = \case { CLib lib' -> lib'; c -> mismatch (CLib lib) c } <$> f (CLib lib)+ f_flib flib = \case { CFLib flib' -> flib'; c -> mismatch (CFLib flib) c } <$> f (CFLib flib)+ f_exe exe = \case { CExe exe' -> exe'; c -> mismatch (CExe exe) c } <$> f (CExe exe)+ f_test test = \case { CTest test' -> test'; c -> mismatch (CTest test) c } <$> f (CTest test)+ f_bench bench = \case { CBench bench' -> bench'; c -> mismatch (CBench bench) c } <$> f (CBench bench)++ upd_pd lib sublibs flibs exes tests benchs =+ pd+ { library = lib+ , subLibraries = sublibs+ , foreignLibs = flibs+ , executables = exes+ , testSuites = tests+ , benchmarks = benchs+ }++ -- This is a panic, because we maintain this invariant elsewhere:+ -- see 'componentDiffError' in 'applyComponentDiff', which catches an+ -- invalid per-component configure hook.+ mismatch c1 c2 =+ error $+ "Mismatched component types: "+ ++ showComponentName (componentName c1)+ ++ " "+ ++ showComponentName (componentName c2)+ ++ "."+{-# INLINEABLE traverseComponents #-}++applyComponentDiffs+ :: Verbosity+ -> (Component -> IO (Maybe ComponentDiff))+ -> PackageDescription+ -> IO PackageDescription+applyComponentDiffs verbosity f = traverseComponents apply_diff+ where+ apply_diff :: Component -> IO Component+ apply_diff c = do+ mbDiff <- f c+ case mbDiff of+ Just diff -> applyComponentDiff verbosity c diff+ Nothing -> return c++forComponents_ :: Applicative m => PackageDescription -> (Component -> m ()) -> m ()+forComponents_ pd f = getAp . getConst $ traverseComponents (Const . Ap . f) pd++applyComponentDiff+ :: Verbosity+ -> Component+ -> ComponentDiff+ -> IO Component+applyComponentDiff verbosity comp (ComponentDiff diff)+ | CLib lib <- comp+ , CLib lib_diff <- diff =+ CLib <$> applyLibraryDiff verbosity lib lib_diff+ | CFLib flib <- comp+ , CFLib flib_diff <- diff =+ CFLib <$> applyForeignLibDiff verbosity flib flib_diff+ | CExe exe <- comp+ , CExe exe_diff <- diff =+ CExe <$> applyExecutableDiff verbosity exe exe_diff+ | CTest test <- comp+ , CTest test_diff <- diff =+ CTest <$> applyTestSuiteDiff verbosity test test_diff+ | CBench bench <- comp+ , CBench bench_diff <- diff =+ CBench <$> applyBenchmarkDiff verbosity bench bench_diff+ | otherwise =+ componentDiffError $ MismatchedComponentTypes comp diff+ where+ -- The per-component configure hook specified a diff of the wrong type,+ -- e.g. tried to apply an executable diff to a library.+ componentDiffError err =+ dieWithException verbosity $+ SetupHooksException $+ CannotApplyComponentDiff err++--------------------------------------------------------------------------------+-- Running pre-build rules++-- | Run all pre-build rules.+--+-- This function should only be called internally within @Cabal@, as it is used+-- to implement the (legacy) Setup.hs interface. The build tool+-- (e.g. @cabal-install@ or @hls@) should instead go through the separate+-- hooks executable, which allows us to only rerun the out-of-date rules+-- (instead of running all of these rules at once).+executeRules+ :: Verbosity+ -> LocalBuildInfo+ -> TargetInfo+ -> Map RuleId Rule+ -> IO ()+executeRules =+ executeRulesUserOrSystem+ SUser+ (\_rId cmd -> sequenceA $ runRuleDynDepsCmd cmd)+ (\_rId cmd -> runRuleExecCmd cmd)++-- | Like 'executeRules', except it can be used when communicating with+-- an external hooks executable.+executeRulesUserOrSystem+ :: forall userOrSystem+ . ( Binary (RuleData userOrSystem)+ , Structured (RuleData userOrSystem)+ , Eq (RuleData userOrSystem)+ )+ => SScope userOrSystem+ -> (RuleId -> RuleDynDepsCmd userOrSystem -> IO (Maybe ([Rule.Dependency], LBS.ByteString)))+ -> (RuleId -> RuleExecCmd userOrSystem -> IO ())+ -> Verbosity+ -> LocalBuildInfo+ -> TargetInfo+ -> Map RuleId (RuleData userOrSystem)+ -> IO ()+executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo allRules = do+ -- Load the rule cache from the previous build.+ -- Used to detect when rule definitions have changed.+ oldRules <- handleDoesNotExist Map.empty $ do+ -- NB: do a strict read to avoid retaining the file handle.+ bs <- BS.readFile rulesCacheFile+ fromRight Map.empty <$> structuredDecodeOrFailIO (LBS.fromStrict bs)+ -- Compute all extra dynamic dependency edges.+ dynDepsEdges <-+ flip Map.traverseMaybeWithKey allRules $+ \rId (Rule{ruleCommands = cmds}) ->+ runDepsCmdData rId (ruleDepsCmd cmds)++ -- Create a build graph of all the rules, with static and dynamic dependencies+ -- as edges.+ let+ (ruleGraph, ruleFromVertex, vertexFromRuleId) =+ Graph.graphFromEdges+ [ (rule, rId, ordNub $ mapMaybe directRuleDependencyMaybe allDeps)+ | (rId, rule) <- Map.toList allRules+ , let dynDeps = maybe [] fst (Map.lookup rId dynDepsEdges)+ allDeps = staticDependencies rule ++ dynDeps+ ]++ -- Topologically sort the graph of rules.+ sccs = Graph.scc ruleGraph+ cycles = mapMaybe $ \(Graph.Node v0 subforest) ->+ case subforest of+ []+ | r@(_, rId, deps) <- ruleFromVertex v0 ->+ if rId `elem` deps+ then Just (r, [])+ else Nothing+ v : vs ->+ Just+ ( ruleFromVertex v0+ , map (fmap ruleFromVertex) (v : vs)+ )++ -- Compute demanded rules: anything reachable from the roots, which are:+ --+ -- - autogen modules+ -- - extra-c-sources, extra-asm-sources, ... that happen to be in the+ -- autogen directory (this is the workaround for there being no+ -- 'autogen' field for those)+ -- - extra-bundled-libs+ --+ -- This does not include autogen-includes, because .h files are required+ -- during configure time, so not relevant for pre-build rules which are run+ -- after configure.+ autogenModPaths :: [RelativePath Source File]+ autogenModPaths =+ map (\m -> moduleNameSymbolicPath m <.> "hs") $+ autogenModules compBuildInfo+ autogenExtraSourcesPaths :: [RelativePath Source File]+ autogenExtraSourcesPaths =+ concatMap+ (mapMaybe relativeToAutogen)+ [ cSources compBuildInfo+ , cxxSources compBuildInfo+ , cmmSources compBuildInfo+ , asmSources compBuildInfo+ , jsSources compBuildInfo+ ]+ extraBundledLibsPaths :: [RelativePath Source File]+ extraBundledLibsPaths =+ map makeRelativePathEx $+ extraBundledLibs compBuildInfo++ -- Is this rule directly demanded (e.g. it generates a Haskell module+ -- declared in the autogen-modules field)? If so, return the appropriate+ -- demand graph vertex (conceptually a leaf vertex).+ isLeafRule+ :: (RuleId, RuleData scope)+ -> Either (NotDemandedRuleReasons scope) Graph.Vertex+ isLeafRule (rId, r@Rule{results = ruleOutputLocs})+ | let+ normOuts = fmap normaliseLocation ruleOutputLocs+ anyOut f =+ any+ ( \demandedPath ->+ let normDemanded = normaliseLocation $ Location compAutogenDir demandedPath+ in any (f normDemanded) normOuts+ )+ , -- Autogen modules+ anyOut (==) autogenModPaths+ -- Extra source files+ || anyOut (==) autogenExtraSourcesPaths+ -- Extra bundled libraries+ -- They may have any extension (.dll, .so.1.2.3, etc)+ -- so simply allow all extensions.+ || anyOut (\dmdLoc outLoc -> dmdLoc == dropExtensionLocation outLoc) extraBundledLibsPaths =+ case vertexFromRuleId rId of+ Just v -> Right v+ Nothing ->+ error $+ unlines+ [ "internal error: no graph vertex for rule " ++ show rId+ , "Rule: " ++ show rId+ ]+ | otherwise =+ Left $+ NDRR+ { nonDemandedRules = Map.singleton rId r+ , nonAutogenHaskellModules =+ Map.singleton+ rId+ [ fromString $ intercalate "." $ FilePath.splitDirectories hsPath+ | Location _ outPath <- NE.toList (results r)+ , (hsPath, ".hs") <- [FilePath.splitExtension (getSymbolicPath outPath)]+ ]+ , filesNotInAutogenFolders =+ Map.singleton+ rId+ [ unsafeCoerceSymbolicPath fp+ | Location base fp <- NE.toList (results r)+ , Nothing <- [relativeToAutogen base]+ ]+ }+ (nonDmdReasons, leafRules) = partitionEithers $ map isLeafRule $ Map.toList allRules+ demandedRuleVerts = Set.fromList $ concatMap (Graph.reachable ruleGraph) leafRules+ nonDemandedRuleVerts = Set.fromList (Graph.vertices ruleGraph) Set.\\ demandedRuleVerts++ case cycles sccs of+ -- If there are cycles in the dependency structure, don't execute+ -- any rules at all; just throw an error right off the bat.+ r : rs ->+ let getRule ((ru, _, _), js) = (toRuleBinary ru, fmap (fmap (\(rv, _, _) -> toRuleBinary rv)) js)+ in errorOut $+ CyclicRuleDependencies $+ fmap getRule (r NE.:| rs)+ -- Otherwise, run all the demanded rules in dependency order (in one go).+ -- (Fine-grained running of rules should happen in cabal-install or HLS,+ -- not in the Cabal library.)+ [] -> do+ -- Emit a warning if there are non-demanded rules.+ unless (null nonDemandedRuleVerts) $+ warn verbosity $+ pprNotDemandedRuleReasons comp compAutogenDir (mconcat nonDmdReasons)++ -- Run all the demanded rules, in dependency order, propagating staleness.+ staleRulesRef <- newIORef Set.empty+ for_ sccs $ \(Graph.Node ruleVertex _) ->+ -- Don't run a rule unless it is demanded.+ unless (ruleVertex `Set.member` nonDemandedRuleVerts) $ do+ let (r, rId, _staticRuleDepIds) = ruleFromVertex ruleVertex+ Rule{ruleCommands, staticDependencies, results} = r+ mbDynDeps = Map.lookup rId dynDepsEdges+ allDeps = staticDependencies ++ maybe [] fst mbDynDeps+ -- Check that the dependencies the rule expects are indeed present.+ resolvedDeps <- traverse (resolveDependency verbosity rId allRules) allDeps+ missingRuleDeps <- filterM (missingDep mbWorkDir) resolvedDeps+ case NE.nonEmpty missingRuleDeps of+ Just missingDeps ->+ errorOut $ CantFindSourceForRuleDependencies (toRuleBinary r) missingDeps+ -- Dependencies OK: check whether the rule is up to date before+ -- deciding to run it.+ Nothing -> do+ let dynDeps = maybe [] fst mbDynDeps+ ruleUpToDate mbWorkDir oldRules staleRulesRef rId r dynDeps >>= \case+ True ->+ info verbosity $+ "Rule " ++ show rId ++ " is up to date; skipping."+ False -> do+ modifyIORef' staleRulesRef (Set.insert rId)+ runCmdData rId $ ruleExecCmd scope ruleCommands (snd <$> mbDynDeps)+ -- Throw an error if running the action did not result in+ -- the generation of outputs that we expected it to.+ missingRuleResults <- filterM (missingDep mbWorkDir) $ NE.toList results+ for_ (NE.nonEmpty missingRuleResults) $ \missingResults ->+ errorOut $ MissingRuleOutputs (toRuleBinary r) missingResults+ -- Save the current rules to the cache for use in the next build.+ structuredEncodeFile rulesCacheFile allRules+ where+ toRuleBinary :: RuleData userOrSystem -> RuleBinary+ toRuleBinary = case scope of+ SUser -> ruleBinary+ SSystem -> id+ clbi = targetCLBI tgtInfo+ mbWorkDir = mbWorkDirLBI lbi+ comp = targetComponent tgtInfo+ compAutogenDir = autogenComponentModulesDir lbi clbi+ rulesCacheFile = interpretSymbolicPath mbWorkDir (preBuildRulesCacheFile lbi clbi)+ compBuildInfo = componentBuildInfo comp+ errorOut e =+ dieWithException verbosity $+ SetupHooksException $+ RulesException e++ relativeToAutogen :: SymbolicPath Pkg to -> Maybe (RelativePath Source to)+ relativeToAutogen = relativePathMaybe compAutogenDir++-- | Collects why certain rules were not demanded (and thus not run), in order+-- to construct an error message to report to the user.+data NotDemandedRuleReasons scope = NDRR+ { nonDemandedRules :: Map RuleId (RuleData scope)+ -- ^ The rules that were not demanded+ , nonAutogenHaskellModules :: Map RuleId [ModuleName]+ -- ^ Rules that generate Haskell files that are not declared as+ -- autogenerated modules.+ , filesNotInAutogenFolders :: Map RuleId [RelativePath Pkg File]+ -- ^ Rules that generate files that aren't in the appropriate autogen+ -- directory.+ }++instance Semigroup (NotDemandedRuleReasons scope) where+ NDRR r1 m1 f1 <> NDRR r2 m2 f2 = NDRR (r1 <> r2) (m1 <> m2) (f1 <> f2)+instance Monoid (NotDemandedRuleReasons scope) where+ mempty = NDRR mempty mempty mempty++pprNotDemandedRuleReasons+ :: Component+ -> SymbolicPath Pkg (Dir Source)+ -> NotDemandedRuleReasons scope+ -> String+pprNotDemandedRuleReasons+ comp+ compAutogenDir+ (NDRR non_dmd_verts mods_map miss_files_map) =+ unlines $ header ++ mods_lines ++ files_lines+ where+ mods = tagByRuleId mods_map+ miss_files = tagByRuleId miss_files_map++ tagByRuleId xs = concatMap (\(rId, x) -> map (rId,) x) $ Map.toList xs+ ppr (rId, x) = " - " ++ prettyShow x ++ " (for rule " ++ show (ruleName rId) ++ ")"++ header :: [String]+ header =+ "The following rules are not demanded and will not be run:"+ : concat+ [ [ " - " ++ show rId ++ ","+ , " generating " ++ show (NE.toList $ results r)+ ]+ | (rId, r) <- Map.toList non_dmd_verts+ ]++ mods_lines, files_lines :: [String]+ mods_lines+ | null mods =+ []+ | otherwise =+ ("Perhaps add the following to the 'autogen-modules' field of the " ++ showComponentName (componentName comp) ++ " component.")+ : map ppr mods+ files_lines+ | null miss_files =+ []+ | otherwise =+ ("The following autogenerated file" ++ s ++ " for the " ++ showComponentName (componentName comp) ++ " component " ++ isOrAre ++ " misplaced.")+ : (itOrThey ++ " should go in " ++ show compAutogenDir ++ "'.")+ : map ppr miss_files+ where+ (s, isOrAre, itOrThey) =+ case miss_files of+ [_] -> ("", "is", "It")+ _ -> ("s", "are", "They")++directRuleDependencyMaybe :: Rule.Dependency -> Maybe RuleId+directRuleDependencyMaybe (RuleDependency dep) = Just $ outputOfRule dep+directRuleDependencyMaybe (FileDependency{}) = Nothing++-- | Is the rule up to date (so that we can skip re-running it)?+--+-- As per the SetupHooks documentation, a rule must be re-run if:+--+-- - [N] the rule is new, or+-- - [S] the rule matches with an old rule, and either:+-- - [S1] an input to the rule has changed (either a file or rule dependency)+-- - [S2] the rule itself has changed+ruleUpToDate+ :: Eq (RuleData userOrSystem)+ => Maybe (SymbolicPath CWD (Dir Pkg))+ -- ^ working directory+ -> Map RuleId (RuleData userOrSystem)+ -- ^ old rules from the previous build+ -> IORef (Set RuleId)+ -- ^ rules that have been re-run+ -> RuleId+ -> RuleData userOrSystem+ -> [Rule.Dependency]+ -- ^ dynamic dependencies of this rule+ -> IO Bool+ruleUpToDate mbWorkDir oldRules staleRulesRef rId rule dynDeps = do+ staleRules <- readIORef staleRulesRef+ if ruleChanged || any (`Set.member` staleRules) ruleDeps+ then return False+ else do+ let maybeModTime fp = handleDoesNotExist Nothing $ Just <$> getModificationTime fp+ outMtimes <- traverse maybeModTime outputPaths+ case sequenceA outMtimes of+ -- At least one output is missing: must run the rule.+ Nothing -> return False+ Just outs ->+ -- Re-run if an input is more recent than the oldest output.+ case inputPaths of+ [] -> return True+ _ -> do+ inMtimes <- traverse getModificationTime inputPaths+ return (minimum outs >= maximum inMtimes)+ where+ i (Location dir file) = interpretSymbolicPath mbWorkDir (dir </> file)+ allDeps = staticDependencies rule ++ dynDeps+ ruleDeps = [outputOfRule ro | RuleDependency ro <- allDeps]+ fileDeps = [loc | FileDependency loc <- allDeps]+ inputPaths = map i fileDeps+ outputPaths = fmap i (results rule)+ ruleChanged =+ case Map.lookup rId oldRules of+ Just oldRule ->+ -- Use the Eq instance to determine if the rule has changed+ -- (as documented in the API).+ oldRule /= rule+ Nothing -> True++resolveDependency :: Verbosity -> RuleId -> Map RuleId (RuleData scope) -> Rule.Dependency -> IO Location+resolveDependency verbosity rId allRules = \case+ FileDependency l -> return l+ RuleDependency (RuleOutput{outputOfRule = depId, outputIndex = i}) ->+ case Map.lookup depId allRules of+ Nothing ->+ error $+ unlines+ [ "Internal error: missing rule dependency."+ , "Rule: " ++ show rId+ , "Dependency: " ++ show depId+ ]+ Just (Rule{results = os}) ->+ let j :: Int+ j = fromIntegral i+ in case listToMaybe $ drop j $ NE.toList os of+ Just o+ | j >= 0 ->+ return o+ _ ->+ dieWithException verbosity $+ SetupHooksException $+ RulesException $+ InvalidRuleOutputIndex rId depId os i++normaliseLocation :: Location -> Location+normaliseLocation (Location base rel) =+ Location (normaliseSymbolicPath base) (normaliseSymbolicPath rel)++dropExtensionLocation :: Location -> Location+dropExtensionLocation (Location base rel) =+ Location base (makeRelativePathEx $ FilePath.dropExtensions $ getSymbolicPath rel)++-- | Is the file we depend on missing?+missingDep :: Maybe (SymbolicPath CWD (Dir Pkg)) -> Location -> IO Bool+missingDep mbWorkDir loc = not <$> doesFileExist fp+ where+ fp = interpretSymbolicPath mbWorkDir (location loc)++--------------------------------------------------------------------------------+-- Compatibility with HookedBuildInfo.+--+-- NB: assumes that the components in HookedBuildInfo are:+-- - an (optional) main library,+-- - executables.+--+-- No support for named sublibraries, foreign libraries, tests or benchmarks,+-- because the HookedBuildInfo datatype doesn't specify what type of component+-- each component name is (so we assume they are executables).++hookedBuildInfoComponents :: HookedBuildInfo -> Set ComponentName+hookedBuildInfoComponents (mb_mainlib, exes) =+ Set.fromList $+ (case mb_mainlib of Nothing -> id; Just{} -> (CLibName LMainLibName :))+ [CExeName exe_nm | (exe_nm, _) <- exes]++hookedBuildInfoComponentDiff_maybe :: HookedBuildInfo -> ComponentName -> Maybe (IO ComponentDiff)+hookedBuildInfoComponentDiff_maybe (mb_mainlib, exes) comp_nm =+ case comp_nm of+ CLibName lib_nm ->+ case lib_nm of+ LMainLibName -> return . ComponentDiff . CLib . buildInfoLibraryDiff <$> mb_mainlib+ LSubLibName{} -> Nothing+ CExeName exe_nm ->+ let mb_exe = lookup exe_nm exes+ in return . ComponentDiff . CExe . buildInfoExecutableDiff <$> mb_exe+ CFLibName{} -> Nothing+ CTestName{} -> Nothing+ CBenchName{} -> Nothing++buildInfoLibraryDiff :: BuildInfo -> LibraryDiff+buildInfoLibraryDiff bi = emptyLibrary{libBuildInfo = bi}++buildInfoExecutableDiff :: BuildInfo -> ExecutableDiff+buildInfoExecutableDiff bi = emptyExecutable{buildInfo = bi}++--------------------------------------------------------------------------------+-- Instances for serialisation++deriving newtype instance Binary ComponentDiff+deriving newtype instance Structured ComponentDiff++instance Binary PreConfPackageInputs+instance Structured PreConfPackageInputs+instance Binary PreConfPackageOutputs+instance Structured PreConfPackageOutputs++instance Binary PostConfPackageInputs+instance Structured PostConfPackageInputs++instance Binary PreConfComponentInputs+instance Structured PreConfComponentInputs+instance Binary PreConfComponentOutputs+instance Structured PreConfComponentOutputs++instance Binary PreBuildComponentInputs+instance Structured PreBuildComponentInputs++instance Binary PostBuildComponentInputs+instance Structured PostBuildComponentInputs++instance Binary InstallComponentInputs+instance Structured InstallComponentInputs++--------------------------------------------------------------------------------
+ src/Distribution/Simple/SetupHooks/Rule.hs view
@@ -0,0 +1,1193 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module: Distribution.Simple.SetupHooks.Rule+--+-- Internal module that defines fine-grained rules for setup hooks.+-- Users should import 'Distribution.Simple.SetupHooks' instead.+module Distribution.Simple.SetupHooks.Rule+ ( -- * Rules++ -- ** Rule+ Rule+ , RuleData (..)+ , RuleId (..)+ , staticRule+ , dynamicRule++ -- ** Commands+ , RuleCommands (..)+ , Command+ , CommandData (..)+ , runCommand+ , mkCommand+ , Dict (..)++ -- *** Helpers for executing commands+ , RuleCmds+ , RuleDynDepsCmd+ , RuleExecCmd+ , DynDepsCmd (..)+ , DepsRes (..)+ , ruleDepsCmd+ , runRuleDynDepsCmd+ , ruleExecCmd+ , runRuleExecCmd++ -- ** Collections of rules+ , Rules (..)+ , Dependency (..)+ , RuleOutput (..)+ , rules+ , noRules++ -- ** Rule inputs/outputs+ , Location (..)+ , location++ -- ** File/directory monitoring+ , MonitorFilePath (..)+ , MonitorKindFile (..)+ , MonitorKindDir (..)++ -- *** Monadic API for generation of 'ActionId'+ , RulesM+ , RulesT (..)+ , RulesEnv (..)+ , computeRules++ -- * Internals+ , Scope (..)+ , SScope (..)+ , Static (..)+ , RuleBinary+ , ruleBinary+ )+where++import qualified Distribution.Compat.Binary as Binary+import Distribution.Compat.Prelude++import Distribution.ModuleName+ ( ModuleName+ )+import Distribution.Simple.FileMonitor.Types+import Distribution.Types.UnitId+import Distribution.Utils.Path+ ( FileOrDir (..)+ , Pkg+ , RelativePath+ , SymbolicPath+ , getSymbolicPath+ , (</>)+ )+import Distribution.Utils.ShortText+ ( ShortText+ )+import Distribution.Utils.Structured+ ( Structure (..)+ , Structured (..)+ , nominalStructure+ )+import Distribution.Verbosity+ ( Verbosity+ )++import Control.Monad.Fix+ ( MonadFix+ )+import Control.Monad.Trans+ ( MonadIO+ , MonadTrans (..)+ )+import qualified Control.Monad.Trans.Reader as Reader+import qualified Control.Monad.Trans.State as State+import qualified Control.Monad.Trans.Writer.CPS as Writer+import qualified Data.ByteString.Lazy as LBS+import qualified Data.List.NonEmpty as NE+import qualified Data.Map.Strict as Map+ ( empty+ )++import qualified Data.Kind as Hs+import Data.Type.Bool+ ( If+ )+import Data.Type.Equality+ ( (:~~:) (HRefl)+ , type (==)+ )+import GHC.Show+ ( showCommaSpace+ )+import GHC.StaticPtr+import GHC.TypeLits+ ( Symbol+ )+import System.IO.Unsafe+ ( unsafePerformIO+ )+import qualified Type.Reflection as Typeable+ ( SomeTypeRep (..)+ , TypeRep+ , eqTypeRep+ , typeRep+ , typeRepKind+ , withTypeable+ , pattern App+ )++import System.FilePath+ ( normalise+ )++--------------------------------------------------------------------------------++{- Note [Fine-grained hooks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To best understand how the framework of fine-grained build rules+fits into Cabal and the greater Haskell ecosystem, it is helpful to think+that we want build tools (such as cabal-install or HLS) to be able to call+individual build rules on-demand, so that e.g. when a user modifies a .xyz file+the associated preprocessor is re-run.++To do this, we need to perform two different kinds of invocations:++ Query: query the package for the rules that it provides, with their+ dependency information. This allows one to determine when each+ rule should be rerun.++ (For example, if one rule preprocesses *.xyz into *.hs, we need to+ re-run the rule whenever *.xyz is modified.)++ Run: run the relevant action, once one has determined that the rule+ has gone stale.++To do this, any Cabal package with Hooks build-type provides a SetupHooks+module which supports these queries; for example it can be compiled into+a separate executable which can be invoked in the manner described above.+-}++---------+-- Rules++-- | A unique identifier for a t'Rule'.+data RuleId = RuleId+ { ruleNameSpace :: !RulesNameSpace+ , ruleName :: !ShortText+ }+ deriving stock (Show, Eq, Ord, Generic)+ deriving anyclass (Binary, Structured)++data RulesNameSpace = RulesNameSpace+ { rulesUnitId :: !UnitId+ , rulesModuleName :: !ModuleName+ , rulesSrcLoc :: !(Int, Int)+ }+ deriving stock (Show, Eq, Ord, Generic)+ deriving anyclass (Binary, Structured)++-- | Internal function: create a 'RulesNameSpace' from a 'StaticPtrInfo'.+staticPtrNameSpace :: StaticPtrInfo -> RulesNameSpace+staticPtrNameSpace+ StaticPtrInfo+ { spInfoUnitId = unitId+ , spInfoModuleName = modName+ , spInfoSrcLoc = srcLoc+ } =+ RulesNameSpace+ { rulesUnitId = mkUnitId unitId+ , rulesModuleName = fromString modName+ , rulesSrcLoc = srcLoc+ }++-- | 'Rule's are defined with rich types by the package.+--+-- The build system only has a limited view of these; most data consists of+-- opaque 'ByteString's.+--+-- The 'Scope' data-type describes which side of this divide we are on.+data Scope+ = -- | User space (with rich types).+ User+ | -- | Build-system space (manipulation of raw data).+ System++data SScope (scope :: Scope) where+ SUser :: SScope User+ SSystem :: SScope System++type Rule = RuleData User+type RuleBinary = RuleData System++-- | A rule consists of:+--+-- - an action to run to execute the rule,+-- - a description of the rule inputs and outputs.+--+-- Use 'staticRule' or 'dynamicRule' to construct a rule, overriding specific+-- fields, rather than directly using the 'Rule' constructor.+data RuleData (scope :: Scope)+ = -- | Please use the 'staticRule' or 'dynamicRule' smart constructors+ -- instead of this constructor, in order to avoid relying on internal+ -- implementation details.+ Rule+ { ruleCommands :: !(RuleCmds scope)+ -- ^ To run this rule, which t'Command's should we execute?+ , staticDependencies :: ![Dependency]+ -- ^ Static dependencies of this rule.+ , results :: !(NE.NonEmpty Location)+ -- ^ Results of this rule.+ }+ deriving stock (Generic)++deriving stock instance Show (RuleData User)+deriving stock instance Eq (RuleData User)+deriving stock instance Eq (RuleData System)+deriving anyclass instance Binary (RuleData User)+deriving anyclass instance Binary (RuleData System)+deriving anyclass instance Structured (RuleData User)+deriving anyclass instance Structured (RuleData System)++-- | Trimmed down 'Show' instance, mostly for error messages.+instance Show RuleBinary where+ show (Rule{staticDependencies = deps, results = reslts, ruleCommands = cmds}) =+ what ++ ": " ++ showDeps deps ++ " --> " ++ show (NE.toList reslts)+ where+ what = case cmds of+ StaticRuleCommand{} -> "Rule"+ DynamicRuleCommands{} -> "Rule (dyn-deps)"+ showDeps :: [Dependency] -> String+ showDeps ds = "[" ++ intercalate ", " (map showDep ds) ++ "]"+ showDep :: Dependency -> String+ showDep = \case+ RuleDependency (RuleOutput{outputOfRule = rId, outputIndex = i}) ->+ "(" ++ show rId ++ ")[" ++ show i ++ "]"+ FileDependency loc -> show loc++-- | A rule with static dependencies.+--+-- Prefer using this smart constructor instead of v'Rule' whenever possible.+--+-- See also 'dynamicRule' which adds support for dynamic dependencies.+staticRule+ :: forall arg+ . Typeable arg+ => Command arg (IO ())+ -- ^ command to execute the rule+ -> [Dependency]+ -- ^ static dependencies of the rule+ -> NE.NonEmpty Location+ -- ^ rule results+ -> Rule+staticRule cmd dep res =+ Rule+ { ruleCommands =+ StaticRuleCommand+ { staticRuleCommand = cmd+ , staticRuleArgRep = Typeable.typeRep @arg+ }+ , staticDependencies = dep+ , results = res+ }++-- | A rule with dynamic dependencies, which consists of two parts:+--+-- - a dynamic dependency computation, that returns additional edges to+-- be added to the build graph, together with an additional piece of data,+-- - the command to execute the rule itself, which receives the additional+-- piece of data returned by the dependency computation.+--+-- Prefer using this smart constructor instead of v'Rule' whenever possible.+--+-- Use 'staticRule' if you do not have any dynamic dependencies.+dynamicRule+ :: forall depsArg depsRes arg+ . (Typeable depsArg, Typeable depsRes, Typeable arg)+ => StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes))+ -- ^ evidence that the result of the dynamic dependency command+ -- is serialisable+ -> Command depsArg (IO ([Dependency], depsRes))+ -- ^ dynamic dependency computation, returning dynamic dependencies+ -- and an additional piece of data to be consumed by the main rule command+ -> Command arg (depsRes -> IO ())+ -- ^ main rule command; takes in the piece of data returned by the dyn-deps+ -- command+ -> [Dependency]+ -- ^ static dependencies of the rule+ -> NE.NonEmpty Location+ -- ^ rule results+ -> Rule+dynamicRule dict depsCmd action dep res =+ Rule+ { ruleCommands =+ DynamicRuleCommands+ { dynamicRuleInstances = UserStatic dict+ , dynamicDeps = DynDepsCmd{dynDepsCmd = depsCmd}+ , dynamicRuleCommand = action+ , dynamicRuleTypeRep = Typeable.typeRep @(depsArg, depsRes, arg)+ }+ , staticDependencies = dep+ , results = res+ }++-----------------------+-- Rule inputs/outputs++-- | A (fully resolved) location of a dependency or result of a rule,+-- consisting of a base directory and of a file path relative to that base+-- directory path.+--+-- In practice, this will be something like @'Location' dir ('moduleNameSymbolicPath' mod <.> "hs")@,+-- where:+--+-- - for a file dependency, @dir@ is one of the Cabal search directories,+-- - for an output, @dir@ is a directory such as @autogenComponentModulesDir@+-- or @componentBuildDir@.+data Location where+ Location+ :: { locationBaseDir :: !(SymbolicPath Pkg (Dir baseDir))+ -- ^ Base directory.+ , locationRelPath :: !(RelativePath baseDir File)+ -- ^ File path relative to base directory (including file extension).+ }+ -> Location++instance Eq Location where+ Location b1 l1 == Location b2 l2 =+ (getSymbolicPath b1 == getSymbolicPath b2)+ && (getSymbolicPath l1 == getSymbolicPath l2)+instance Ord Location where+ compare (Location b1 l1) (Location b2 l2) =+ compare+ (getSymbolicPath b1, getSymbolicPath l1)+ (getSymbolicPath b2, getSymbolicPath l2)+instance Binary Location where+ put (Location base loc) = put (base, loc)+ get = Location <$> get <*> get+instance Structured Location where+ structure _ =+ Structure+ tr+ 0+ (show tr)+ [+ ( "Location"+ ,+ [ nominalStructure $ Proxy @(SymbolicPath Pkg (Dir (Tok "baseDir")))+ , nominalStructure $ Proxy @(RelativePath (Tok "baseDir") File)+ ]+ )+ ]+ where+ tr = Typeable.SomeTypeRep $ Typeable.typeRep @Location++-- | Get a (relative or absolute) un-interpreted path to a 'Location'.+location :: Location -> SymbolicPath Pkg File+location (Location base rel) = base </> rel++instance Show Location where+ showsPrec p (Location base rel) =+ showParen (p > 5) $+ showString (normalise $ getSymbolicPath base)+ . showString " </> "+ . showString (normalise $ getSymbolicPath rel)++-- 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).++-- | A dependency of a rule.+data Dependency+ = -- | A dependency on an output of another rule.+ RuleDependency !RuleOutput+ | -- | A direct dependency on a file at a particular location on disk.+ --+ -- This should not be used for files that are generated by other rules;+ -- use 'RuleDependency' instead.+ FileDependency !Location+ deriving stock (Show, Eq, Ord, Generic)+ deriving anyclass (Binary, Structured)++-- | A reference to an output of another rule.+data RuleOutput = RuleOutput+ { outputOfRule :: !RuleId+ -- ^ which rule's outputs are we referring to?+ , outputIndex :: !Word+ -- ^ which particular output of that rule?+ }+ deriving stock (Show, Eq, Ord, Generic)+ deriving anyclass (Binary, Structured)++---------+-- Rules++-- | Monad for constructing rules.+type RulesM a = RulesT IO a++-- | The environment within the monadic API.+data RulesEnv = RulesEnv+ { rulesEnvVerbosity :: !Verbosity+ , rulesEnvNameSpace :: !RulesNameSpace+ }++-- | Monad transformer for defining rules. Usually wraps the 'IO' monad,+-- allowing @IO@ actions to be performed using @liftIO@.+newtype RulesT m a = RulesT+ { runRulesT+ :: Reader.ReaderT+ RulesEnv+ ( State.StateT+ (Map RuleId Rule)+ (Writer.WriterT [MonitorFilePath] m)+ )+ a+ }+ deriving newtype (Functor, Applicative, Monad, MonadIO, MonadFix)++instance MonadTrans RulesT where+ lift = RulesT . lift . lift . lift++-- | A collection of t'Rule's.+--+-- Use the 'rules' smart constructor instead of directly using the v'Rules'+-- constructor.+--+-- - Rules are registered using 'registerRule',+-- - Monitored files or directories are declared using 'addRuleMonitors';+-- a change in these will trigger the recomputation of all rules.+--+-- The @env@ type parameter represents an extra argument, which usually+-- consists of information known to Cabal such as 'LocalBuildInfo' and+-- 'ComponentLocalBuildInfo'.+newtype Rules env = Rules {runRules :: env -> RulesM ()}++-- | __Warning__: this 'Semigroup' instance is not commutative.+instance Semigroup (Rules env) where+ (Rules rs1) <> (Rules rs2) =+ Rules $ \inputs -> do+ y1 <- rs1 inputs+ y2 <- rs2 inputs+ return $ y1 <> y2++instance Monoid (Rules env) where+ mempty = Rules $ const noRules++-- | An empty collection of rules.+noRules :: RulesM ()+noRules = return ()++-- | Construct a collection of rules with a given label.+--+-- A label for the rules can be constructed using the @static@ keyword,+-- using the @StaticPointers@ extension.+-- NB: separate calls to 'rules' should have different labels.+--+-- Example usage:+--+-- > myRules :: Rules env+-- > myRules = rules (static ()) $ \ env -> do { .. } -- use the monadic API here+rules+ :: StaticPtr label+ -- ^ unique label for this collection of rules+ -> (env -> RulesM ())+ -- ^ the computation of rules+ -> Rules env+rules label = rulesInNameSpace (staticPtrNameSpace $ staticPtrInfo label)++-- | Internal function to create a collection of rules.+--+-- API users should go through the 'rules' function instead.+rulesInNameSpace+ :: RulesNameSpace+ -- ^ rule namespace+ -> (env -> RulesM ())+ -- ^ the computation of rules+ -> Rules env+rulesInNameSpace nameSpace f =+ Rules $ \env -> RulesT $ do+ Reader.withReaderT (\rulesEnv -> rulesEnv{rulesEnvNameSpace = nameSpace}) $+ runRulesT $+ f env++-- | Internal function: run the monadic 'Rules' computations in order+-- to obtain all the 'Rule's with their 'RuleId's.+computeRules+ :: Verbosity+ -> env+ -> Rules env+ -> IO (Map RuleId Rule, [MonitorFilePath])+computeRules verbosity inputs (Rules rs) = do+ -- Bogus namespace to start with. This will be the first thing+ -- to be set when users use the 'rules' smart constructor.+ let noNameSpace =+ RulesNameSpace+ { rulesUnitId = mkUnitId ""+ , rulesModuleName = fromString ""+ , rulesSrcLoc = (0, 0)+ }+ env0 =+ RulesEnv+ { rulesEnvVerbosity = verbosity+ , rulesEnvNameSpace = noNameSpace+ }+ Writer.runWriterT $+ (`State.execStateT` Map.empty) $+ (`Reader.runReaderT` env0) $+ runRulesT $+ rs inputs++------------+-- Commands++-- | A static pointer (in user scope) or its key (in system scope).+data family Static (scope :: Scope) :: Hs.Type -> Hs.Type++newtype instance Static User fnTy = UserStatic {userStaticPtr :: StaticPtr fnTy}+newtype instance Static System fnTy = SystemStatic {userStaticKey :: StaticKey}+ deriving newtype (Eq, Ord, Show, Binary)++systemStatic :: Static User fnTy -> Static System fnTy+systemStatic (UserStatic ptr) = SystemStatic (staticKey ptr)++instance Show (Static User fnTy) where+ showsPrec p ptr = showsPrec p (systemStatic ptr)+instance Eq (Static User fnTy) where+ (==) = (==) `on` systemStatic+instance Ord (Static User fnTy) where+ compare = compare `on` systemStatic+instance Binary (Static User fnTy) where+ put = put . systemStatic+ get = do+ ptrKey <- get @StaticKey+ case unsafePerformIO $ unsafeLookupStaticPtr ptrKey of+ Just ptr -> return $ UserStatic ptr+ Nothing ->+ fail $+ unlines+ [ "Failed to look up static pointer key for action."+ , "NB: Binary instances for 'User' types cannot be used in external executables."+ ]++-- | A command consists of a statically-known action together with a+-- (possibly dynamic) argument to that action.+--+-- For example, the action can consist of running an executable+-- (such as @happy@ or @c2hs@), while the argument consists of the variable+-- component of the command, e.g. the specific file to run @happy@ on.+type Command = CommandData User++-- | Internal datatype used for commands, both for the Hooks API ('Command')+-- and for the build system.+data CommandData (scope :: Scope) (arg :: Hs.Type) (res :: Hs.Type) = Command+ { actionPtr :: !(Static scope (arg -> res))+ -- ^ The (statically-known) action to execute.+ , actionArg :: !(ScopedArgument scope arg)+ -- ^ The (possibly dynamic) argument to pass to the action.+ , cmdInstances :: !(Static scope (Dict (Binary arg, Show arg)))+ -- ^ Static evidence that the argument can be serialised and deserialised.+ }++-- | Construct a command.+--+-- Prefer using this smart constructor instead of v'Command' whenever possible.+mkCommand+ :: forall arg res+ . StaticPtr (Dict (Binary arg, Show arg))+ -> StaticPtr (arg -> res)+ -> arg+ -> Command arg res+mkCommand dict action arg =+ Command+ { actionPtr = UserStatic action+ , actionArg = ScopedArgument arg+ , cmdInstances = UserStatic dict+ }++-- | Run a 'Command'.+runCommand :: Command args res -> res+runCommand (Command{actionPtr = UserStatic ptr, actionArg = ScopedArgument arg}) =+ deRefStaticPtr ptr arg++-- | Commands to execute a rule:+--+-- - for a rule with static dependencies, a single command,+-- - for a rule with dynamic dependencies, a command for computing dynamic+-- dependencies, and a command for executing the rule.+--+-- Prefer using 'staticRule' and 'dynamicRule' instead of the (internal)+-- constructors of 'RuleCommands'.+data+ RuleCommands+ (scope :: Scope)+ (deps :: Scope -> Hs.Type -> Hs.Type -> Hs.Type)+ (ruleCmd :: Scope -> Hs.Type -> Hs.Type -> Hs.Type)+ where+ -- | A rule with statically-known dependencies.+ StaticRuleCommand+ :: forall arg deps ruleCmd scope+ . If+ (scope == System)+ (arg ~ LBS.ByteString)+ (() :: Hs.Constraint)+ => { staticRuleCommand :: !(ruleCmd scope arg (IO ()))+ -- ^ The command to execute the rule.+ , staticRuleArgRep :: !(If (scope == System) Typeable.SomeTypeRep (Typeable.TypeRep arg))+ -- ^ A 'TypeRep' for 'arg'.+ }+ -> RuleCommands scope deps ruleCmd+ DynamicRuleCommands+ :: forall depsArg depsRes arg deps ruleCmd scope+ . If+ (scope == System)+ (depsArg ~ LBS.ByteString, depsRes ~ LBS.ByteString, arg ~ LBS.ByteString)+ (() :: Hs.Constraint)+ => { dynamicRuleInstances :: !(Static scope (Dict (Binary depsRes, Show depsRes, Eq depsRes)))+ -- ^ A rule with dynamic dependencies, which consists of two parts:+ --+ -- - a dynamic dependency computation, that returns additional edges to+ -- be added to the build graph together with an additional piece of data,+ -- - the command to execute the rule itself, which receives the additional+ -- piece of data returned by the dependency computation.+ , -- \^ Static evidence used for serialisation, in order to pass the result+ -- of the dependency computation to the main rule action.+ dynamicDeps :: !(deps scope depsArg depsRes)+ -- ^ A dynamic dependency computation. The resulting dependencies+ -- will be injected into the build graph, and the result of the computation+ -- will be passed on to the command that executes the rule.+ , dynamicRuleCommand :: !(ruleCmd scope arg (depsRes -> IO ()))+ -- ^ The command to execute the rule. It will receive the result+ -- of the dynamic dependency computation.+ , dynamicRuleTypeRep+ :: !( If+ (scope == System)+ Typeable.SomeTypeRep+ (Typeable.TypeRep (depsArg, depsRes, arg))+ )+ -- ^ A 'TypeRep' for the triple @(depsArg,depsRes,arg)@.+ }+ -> RuleCommands scope deps ruleCmd++-- NB: whenever you change this datatype, you **must** also update its+-- 'Structured' instance. The structure hash is used as a handshake when+-- communicating with an external hooks executable.++{- Note [Hooks Binary instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The Hooks API is strongly typed: users can declare rule commands with varying+types, e.g.++ staticRule+ :: forall arg+ . Typeable arg+ => Command arg (IO ())+ -> [Dependency]+ -> NE.NonEmpty Location+ -> Rule++allows a user to declare a 'Command' that receives an argument of type 'arg'+of their choosing.++This all makes sense within the Hooks API, but when communicating with an+external build system (such as cabal-install or HLS), these arguments are+treated as opaque blobs of data (in particular if the Hooks are compiled into+a separate executable, then the static pointers that contain the relevant+instances for these user-chosen types can only be dereferenced from within that+executable, and not on the side of the build system).++This means that, to enable Hooks to be communicated between the package and the+build system, we need:++ 1. Two representations of rules: one for the package author using the Hooks API,+ and one for the build system.+ 2. Compatibility in the 'Binary' instances for these two types. One needs to be+ able to serialise a 'User'-side 'Rule', and de-serialise it on the build system+ into a 'System'-side 'Rule' which contains some opaque bits of data, and+ vice-versa.++(1) is achieved using the 'Scope' parameter to the 'RuleData' datatype.+@Rule = RuleData User@ is the API-side representation, whereas+@RuleBinary = RuleData System@ is the build-system-side representation.++For (2), note that when we serialise a value of known type and known size, e.g.+an 'Int64', we are nevertheless required to also serialise its size. This is because,+on the build-system side, we don't have access to any of the types, and thus don't know+how much to read in order to reconstruct the associated opaque 'ByteString'.+To ensure we always serialise/deserialise including the length of the data,+the 'ScopedArgument' newtype is used, with a custom 'Binary' instance that always+includes the length. We use this newtype:++ - in the definition of 'CommandData', for arguments to rules,+ - in the definition of 'DepsRes', for the result of dynamic dependency computations.+-}++newtype ScopedArgument (scope :: Scope) arg = ScopedArgument {getArg :: arg}+ deriving newtype (Eq, Ord, Show)++-- | Serialise/deserialise, always including the length of the payload.+instance Binary arg => Binary (ScopedArgument User arg) where+ put (ScopedArgument arg) = put @LBS.ByteString (Binary.encode arg)+ get = do+ dat <- get @LBS.ByteString+ case Binary.decodeOrFail dat of+ Left (_, _, err) -> fail err+ Right (_, _, res) -> return $ ScopedArgument res++-- | Serialise and deserialise a raw ByteString, leaving it untouched.+instance arg ~ LBS.ByteString => Binary (ScopedArgument System arg) where+ put (ScopedArgument arg) = put arg+ get = ScopedArgument <$> get++-- | A placeholder for a command that has been omitted, e.g. when we don't+-- care about serialising/deserialising one particular command in a datatype.+data NoCmd (scope :: Scope) arg res = CmdOmitted+ deriving stock (Generic, Eq, Ord, Show)+ deriving anyclass (Binary)++-- | A dynamic dependency command.+newtype DynDepsCmd scope depsArg depsRes = DynDepsCmd+ { dynDepsCmd+ :: CommandData scope depsArg (IO ([Dependency], depsRes))+ }++deriving newtype instance Show (DynDepsCmd User depsArg depsRes)+deriving newtype instance Eq (DynDepsCmd User depsArg depsRes)+deriving newtype instance Binary (DynDepsCmd User depsArg depsRes)+deriving newtype instance+ (arg ~ LBS.ByteString, depsRes ~ LBS.ByteString)+ => Eq (DynDepsCmd System arg depsRes)+deriving newtype instance+ (arg ~ LBS.ByteString, depsRes ~ LBS.ByteString)+ => Binary (DynDepsCmd System arg depsRes)++-- | The result of a dynamic dependency computation.+newtype DepsRes (scope :: Scope) depsArg depsRes = DepsRes+ { depsRes+ :: ScopedArgument scope depsRes -- See Note [Hooks Binary instances]+ }+ deriving newtype (Show, Eq, Ord)++deriving newtype instance+ Binary (ScopedArgument scope depsRes)+ => Binary (DepsRes scope depsArg depsRes)++-- | Both the rule command and the (optional) dynamic dependency command.+type RuleCmds scope = RuleCommands scope DynDepsCmd CommandData++-- | Only the (optional) dynamic dependency command.+type RuleDynDepsCmd scope = RuleCommands scope DynDepsCmd NoCmd++-- | The rule command together with the result of the (optional) dynamic+-- dependency computation.+type RuleExecCmd scope = RuleCommands scope DepsRes CommandData++-- | Project out the (optional) dependency computation command, so that+-- it can be serialised without serialising anything else.+ruleDepsCmd :: RuleCmds scope -> RuleDynDepsCmd scope+ruleDepsCmd = \case+ StaticRuleCommand+ { staticRuleCommand = _ :: CommandData scope args (IO ())+ , staticRuleArgRep = tr+ } ->+ StaticRuleCommand+ { staticRuleCommand = CmdOmitted :: NoCmd scope args (IO ())+ , staticRuleArgRep = tr+ }+ DynamicRuleCommands+ { dynamicRuleCommand = _ :: CommandData scope args (depsRes -> IO ())+ , dynamicRuleInstances = instsPtr+ , dynamicDeps = deps+ , dynamicRuleTypeRep = tr+ } ->+ DynamicRuleCommands+ { dynamicRuleInstances = instsPtr+ , dynamicDeps = deps+ , dynamicRuleCommand = CmdOmitted :: NoCmd scope args (depsRes -> IO ())+ , dynamicRuleTypeRep = tr+ }++-- | Obtain the (optional) 'IO' action that computes dynamic dependencies.+runRuleDynDepsCmd :: RuleDynDepsCmd User -> Maybe (IO ([Dependency], LBS.ByteString))+runRuleDynDepsCmd = \case+ StaticRuleCommand{} -> Nothing+ DynamicRuleCommands+ { dynamicRuleInstances = UserStatic instsPtr+ , dynamicDeps = DynDepsCmd{dynDepsCmd = depsCmd}+ }+ | Dict <- deRefStaticPtr instsPtr ->+ Just $ do+ (deps, dynDeps) <- runCommand depsCmd+ -- See Note [Hooks Binary instances]+ return (deps, Binary.encode $ ScopedArgument @User dynDeps)++-- | Project out the command for running the rule, passing in the result of+-- the dependency computation if there was one.+ruleExecCmd :: SScope scope -> RuleCmds scope -> Maybe LBS.ByteString -> RuleExecCmd scope+ruleExecCmd+ _+ StaticRuleCommand{staticRuleCommand = cmd, staticRuleArgRep = tr}+ _ =+ StaticRuleCommand{staticRuleCommand = cmd, staticRuleArgRep = tr}+ruleExecCmd+ scope+ DynamicRuleCommands+ { dynamicRuleInstances = instsPtr+ , dynamicRuleCommand = cmd :: CommandData scope arg (depsRes -> IO ())+ , dynamicDeps = _ :: DynDepsCmd scope depsArg depsRes+ , dynamicRuleTypeRep = tr+ }+ mbDepsResBinary =+ case mbDepsResBinary of+ Nothing ->+ error $+ unlines+ [ "Missing ByteString argument in 'ruleExecCmd'."+ , "Run 'runRuleDynDepsCmd' on the rule to obtain this data."+ ]+ Just depsResBinary ->+ case scope of+ SUser+ | Dict <- deRefStaticPtr (userStaticPtr instsPtr) ->+ DynamicRuleCommands+ { dynamicRuleInstances = instsPtr+ , dynamicRuleCommand = cmd+ , dynamicDeps = Binary.decode depsResBinary :: DepsRes User depsArg depsRes+ , dynamicRuleTypeRep = tr+ }+ SSystem ->+ DynamicRuleCommands+ { dynamicRuleInstances = instsPtr+ , dynamicRuleCommand = cmd+ , dynamicDeps = DepsRes $ ScopedArgument depsResBinary+ , dynamicRuleTypeRep = tr+ }++-- | Obtain the 'IO' action that executes a rule.+runRuleExecCmd :: RuleExecCmd User -> IO ()+runRuleExecCmd = \case+ StaticRuleCommand{staticRuleCommand = cmd} -> runCommand cmd+ DynamicRuleCommands+ { dynamicDeps = DepsRes (ScopedArgument{getArg = res})+ , dynamicRuleCommand = cmd+ } ->+ runCommand cmd res++--------------------------------------------------------------------------------+-- Instances++-- | A wrapper used to pass evidence of a constraint as an explicit value.+data Dict c where+ Dict :: c => Dict c++instance Show (CommandData User arg res) where+ showsPrec prec (Command{actionPtr = cmdPtr, actionArg = arg, cmdInstances = insts})+ | Dict <- deRefStaticPtr (userStaticPtr insts) =+ showParen (prec >= 11) $+ showString "Command {"+ . showString "actionPtrKey = "+ . shows cmdPtr+ . showCommaSpace+ . showString "actionArg = "+ . shows arg+ . showString "}"++instance Eq (CommandData User arg res) where+ Command{actionPtr = cmdPtr1, actionArg = arg1, cmdInstances = insts1}+ == Command{actionPtr = cmdPtr2, actionArg = arg2, cmdInstances = insts2}+ | cmdPtr1 == cmdPtr2+ , insts1 == insts2+ , Dict <- deRefStaticPtr (userStaticPtr insts1) =+ Binary.encode arg1 == Binary.encode arg2+ | otherwise =+ False+instance arg ~ LBS.ByteString => Eq (CommandData System arg res) where+ Command a1 b1 c1 == Command a2 b2 c2 =+ a1 == a2 && b1 == b2 && c1 == c2++instance Binary (CommandData User arg res) where+ put (Command{actionPtr = cmdPtr, actionArg = arg, cmdInstances = insts})+ | Dict <- deRefStaticPtr (userStaticPtr insts) =+ do+ put cmdPtr+ put insts+ put arg+ get = do+ cmdPtr <- get+ instsPtr <- get+ case deRefStaticPtr @(Dict (Binary arg, Show arg)) $ userStaticPtr instsPtr of+ Dict -> do+ arg <- get+ return $+ Command+ { actionPtr = cmdPtr+ , actionArg = arg+ , cmdInstances = instsPtr+ }+instance arg ~ LBS.ByteString => Binary (CommandData System arg res) where+ put (Command{actionPtr = cmdPtr, actionArg = arg, cmdInstances = insts}) =+ do+ put cmdPtr+ put insts+ put arg+ get = do+ cmdKey <- get+ instsKey <- get+ arg <- get+ return $ Command{actionPtr = cmdKey, actionArg = arg, cmdInstances = instsKey}++instance+ ( forall arg res. Show (ruleCmd User arg res)+ , forall depsArg depsRes. Show depsRes => Show (deps User depsArg depsRes)+ )+ => Show (RuleCommands User deps ruleCmd)+ where+ showsPrec prec (StaticRuleCommand{staticRuleCommand = cmd}) =+ showParen (prec >= 11) $+ showString "StaticRuleCommand {"+ . showString "staticRuleCommand = "+ . shows cmd+ . showString "}"+ showsPrec+ prec+ ( DynamicRuleCommands+ { dynamicDeps = deps+ , dynamicRuleCommand = cmd+ , dynamicRuleInstances = UserStatic instsPtr+ }+ )+ | Dict <- deRefStaticPtr instsPtr =+ showParen (prec >= 11) $+ showString "DynamicRuleCommands {"+ . showString "dynamicDeps = "+ . shows deps+ . showCommaSpace+ . showString "dynamicRuleCommand = "+ . shows cmd+ . showString "}"++instance+ ( forall arg res. Eq (ruleCmd User arg res)+ , forall depsArg depsRes. Eq depsRes => Eq (deps User depsArg depsRes)+ )+ => Eq (RuleCommands User deps ruleCmd)+ where+ StaticRuleCommand{staticRuleCommand = ruleCmd1 :: ruleCmd User arg1 (IO ()), staticRuleArgRep = tr1}+ == StaticRuleCommand{staticRuleCommand = ruleCmd2 :: ruleCmd User arg2 (IO ()), staticRuleArgRep = tr2}+ | Just HRefl <- Typeable.eqTypeRep tr1 tr2 =+ ruleCmd1 == ruleCmd2+ DynamicRuleCommands+ { dynamicDeps = depsCmd1 :: deps User depsArg1 depsRes1+ , dynamicRuleCommand = ruleCmd1 :: ruleCmd User arg1 (depsRes1 -> IO ())+ , dynamicRuleInstances = UserStatic instsPtr1+ , dynamicRuleTypeRep = tr1+ }+ == DynamicRuleCommands+ { dynamicDeps = depsCmd2 :: deps User depsArg2 depsRes2+ , dynamicRuleCommand = ruleCmd2 :: ruleCmd User arg2 (depsRes2 -> IO ())+ , dynamicRuleInstances = UserStatic instsPtr2+ , dynamicRuleTypeRep = tr2+ }+ | Just HRefl <- Typeable.eqTypeRep tr1 tr2+ , Dict <- deRefStaticPtr instsPtr1 =+ depsCmd1 == depsCmd2+ && ruleCmd1 == ruleCmd2+ && staticKey instsPtr1 == staticKey instsPtr2+ _ == _ = False++instance+ ( forall res. Eq (ruleCmd System LBS.ByteString res)+ , Eq (deps System LBS.ByteString LBS.ByteString)+ )+ => Eq (RuleCommands System deps ruleCmd)+ where+ StaticRuleCommand c1 d1 == StaticRuleCommand c2 d2 = c1 == c2 && d1 == d2+ DynamicRuleCommands a1 b1 c1 d1 == DynamicRuleCommands a2 b2 c2 d2 =+ a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2+ _ == _ = False++instance+ ( forall arg res. Binary (ruleCmd User arg res)+ , forall depsArg depsRes. Binary depsRes => Binary (deps User depsArg depsRes)+ )+ => Binary (RuleCommands User deps ruleCmd)+ where+ put = \case+ StaticRuleCommand+ { staticRuleCommand = ruleCmd :: ruleCmd User arg (IO ())+ , staticRuleArgRep = tr+ } -> do+ put @Word 0+ put (Typeable.SomeTypeRep tr)+ put ruleCmd+ DynamicRuleCommands+ { dynamicDeps = deps :: deps User depsArg depsRes+ , dynamicRuleCommand = ruleCmd :: ruleCmd User arg (depsRes -> IO ())+ , dynamicRuleInstances = instsPtr+ , dynamicRuleTypeRep = tr+ } | Dict <- deRefStaticPtr (userStaticPtr instsPtr) ->+ do+ put @Word 1+ put (Typeable.SomeTypeRep tr)+ put instsPtr+ put ruleCmd+ put deps+ get = do+ tag <- get @Word+ case tag of+ 0 -> do+ Typeable.SomeTypeRep (trArg :: Typeable.TypeRep arg) <- get+ if+ | Just HRefl <- Typeable.eqTypeRep (Typeable.typeRepKind trArg) (Typeable.typeRep @Hs.Type) ->+ do+ ruleCmd <- get @(ruleCmd User arg (IO ()))+ return $+ Typeable.withTypeable trArg $+ StaticRuleCommand+ { staticRuleCommand = ruleCmd+ , staticRuleArgRep = trArg+ }+ | otherwise ->+ error "internal error when decoding static rule command"+ _ -> do+ Typeable.SomeTypeRep (tr :: Typeable.TypeRep ty) <- get+ case tr of+ Typeable.App+ ( Typeable.App+ (Typeable.App (tup3Tr :: Typeable.TypeRep tup3) (trDepsArg :: Typeable.TypeRep depsArg))+ (trDepsRes :: Typeable.TypeRep depsRes)+ )+ (trArg :: Typeable.TypeRep arg)+ | Just HRefl <- Typeable.eqTypeRep tup3Tr (Typeable.typeRep @(,,)) -> do+ instsPtr <- get+ case deRefStaticPtr $ userStaticPtr instsPtr of+ (Dict :: Dict (Binary depsRes, Show depsRes, Eq depsRes)) ->+ do+ ruleCmd <- get @(ruleCmd User arg (depsRes -> IO ()))+ deps <- get @(deps User depsArg depsRes)+ return $+ Typeable.withTypeable trDepsArg $+ Typeable.withTypeable trDepsRes $+ Typeable.withTypeable trArg $+ DynamicRuleCommands+ { dynamicDeps = deps+ , dynamicRuleCommand = ruleCmd+ , dynamicRuleInstances = instsPtr+ , dynamicRuleTypeRep = tr+ }+ _ -> error "internal error when decoding dynamic rule commands"++-- | A token constructor used to define 'Structured' instances on types+-- that involve existential quantification.+data family Tok (arg :: Symbol) :: k++instance+ (Typeable scope, Typeable ruleCmd, Typeable deps)+ => Structured (RuleCommands scope deps ruleCmd)+ where+ structure _ =+ Structure+ tr+ 0+ (show tr)+ [+ ( "StaticRuleCommand"+ ,+ [ nominalStructure $ Proxy @(ruleCmd scope (Tok "arg") (IO ()))+ , nominalStructure $ Proxy @(Typeable.TypeRep (Tok "arg" :: Hs.Type))+ ]+ )+ ,+ ( "DynamicRuleCommands"+ ,+ [ nominalStructure $ Proxy @(Static scope (Dict (Binary (Tok "depsRes"), Show (Tok "depsRes"), Eq (Tok "depsRes"))))+ , nominalStructure $ Proxy @(deps scope (Tok "depsArg") (Tok "depsRes"))+ , nominalStructure $ Proxy @(ruleCmd scope (Tok "arg") (Tok "depsRes" -> IO ()))+ , nominalStructure $ Proxy @(Typeable.TypeRep (Tok "depsArg", Tok "depsRes", Tok "arg"))+ ]+ )+ ]+ where+ tr = Typeable.SomeTypeRep $ Typeable.typeRep @(RuleCommands scope deps ruleCmd)++instance+ ( forall res. Binary (ruleCmd System LBS.ByteString res)+ , Binary (deps System LBS.ByteString LBS.ByteString)+ )+ => Binary (RuleCommands System deps ruleCmd)+ where+ put = \case+ StaticRuleCommand{staticRuleCommand = ruleCmd, staticRuleArgRep = sTr} -> do+ put @Word 0+ put sTr+ put ruleCmd+ DynamicRuleCommands+ { dynamicDeps = deps+ , dynamicRuleCommand = ruleCmd+ , dynamicRuleInstances = instsKey+ , dynamicRuleTypeRep = sTr+ } ->+ do+ put @Word 1+ put sTr+ put instsKey+ put ruleCmd+ put deps+ get = do+ tag <- get @Word+ case tag of+ 0 -> do+ sTr <- get @Typeable.SomeTypeRep+ ruleCmd <- get+ return $+ StaticRuleCommand+ { staticRuleCommand = ruleCmd+ , staticRuleArgRep = sTr+ }+ _ -> do+ sTr <- get @Typeable.SomeTypeRep+ instsKey <- get+ ruleCmd <- get+ deps <- get+ return $+ DynamicRuleCommands+ { dynamicDeps = deps+ , dynamicRuleCommand = ruleCmd+ , dynamicRuleInstances = instsKey+ , dynamicRuleTypeRep = sTr+ }++--------------------------------------------------------------------------------+-- Showing rules++ruleBinary :: Rule -> RuleBinary+ruleBinary = Binary.decode . Binary.encode
src/Distribution/Simple/ShowBuildInfo.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -- |@@ -76,21 +77,20 @@ import Distribution.PackageDescription import Distribution.Pretty import Distribution.Simple.Compiler (Compiler, compilerFlavor, showCompilerId)+import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program import Distribution.Simple.Setup.Build (BuildFlags) import Distribution.Simple.Utils (cabalVersion) import Distribution.Text-import Distribution.Types.Component-import Distribution.Types.ComponentLocalBuildInfo-import Distribution.Types.LocalBuildInfo import Distribution.Types.TargetInfo import Distribution.Utils.Json+import Distribution.Utils.Path import Distribution.Verbosity -- | Construct a JSON document describing the build information for a -- package. mkBuildInfo- :: FilePath+ :: AbsolutePath (Dir Pkg) -- ^ The source directory of the package -> PackageDescription -- ^ Mostly information from the .cabal file@@ -138,7 +138,7 @@ , "path" .= JsonString (programPath compilerProgram) ] -mkComponentInfo :: FilePath -> PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> ([String], Json)+mkComponentInfo :: AbsolutePath (Dir Pkg) -> PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> ([String], Json) mkComponentInfo wdir pkg_descr lbi clbi = ( warnings , JsonObject $@@ -147,9 +147,9 @@ , "unit-id" .= JsonString (prettyShow $ componentUnitId clbi) , "compiler-args" .= JsonArray (map JsonString compilerArgs) , "modules" .= JsonArray (map (JsonString . display) modules)- , "src-files" .= JsonArray (map JsonString sourceFiles)+ , "src-files" .= JsonArray (map (JsonString . getSymbolicPath) sourceFiles) , "hs-src-dirs" .= JsonArray (map (JsonString . prettyShow) $ hsSourceDirs bi)- , "src-dir" .= JsonString (addTrailingPathSeparator wdir)+ , "src-dir" .= JsonString (addTrailingPathSeparator (getAbsolutePath wdir)) ] <> cabalFile )@@ -188,7 +188,7 @@ BenchmarkUnsupported _ -> [] CFLib _ -> [] cabalFile- | Just fp <- pkgDescrFile lbi = [("cabal-file", JsonString fp)]+ | Just fp <- pkgDescrFile lbi = [("cabal-file", JsonString $ getSymbolicPath fp)] | otherwise = [] -- | Get the command-line arguments that would be passed@@ -200,8 +200,8 @@ -> ([String], [String]) getCompilerArgs bi lbi clbi = case compilerFlavor $ compiler lbi of- GHC -> ([], ghc)- GHCJS -> ([], ghc)+ GHC -> ([], ghcArgs)+ GHCJS -> ([], ghcArgs) c -> ( [ "ShowBuildInfo.getCompilerArgs: Don't know how to get build "@@ -212,6 +212,8 @@ ) where -- This is absolutely awful- ghc = GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts- where- baseOpts = GHC.componentGhcOptions normal lbi bi clbi (buildDir lbi)+ ghcArgs =+ GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts+ baseOpts =+ GHC.componentGhcOptions Normal lbi bi clbi $+ buildDir lbi
src/Distribution/Simple/SrcDist.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- @@ -47,17 +49,18 @@ import Prelude () import Distribution.ModuleName-import qualified Distribution.ModuleName as ModuleName 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.Errors import Distribution.Simple.Flag import Distribution.Simple.Glob (matchDirFileGlobWithDie) import Distribution.Simple.PreProcess import Distribution.Simple.Program+import Distribution.Simple.Setup.Common import Distribution.Simple.Setup.SDist import Distribution.Simple.Utils import Distribution.Utils.Path@@ -66,14 +69,13 @@ import qualified Data.Map as Map import Data.Time (UTCTime, getCurrentTime, toGregorian, utctDay)-import Distribution.Simple.Errors import System.Directory (doesFileExist)-import System.FilePath (dropExtension, isRelative, (<.>), (</>)) import System.IO (IOMode (WriteMode), hPutStrLn, withFile) -- | Create a source distribution. sdist- :: PackageDescription+ :: VerbosityHandles+ -> PackageDescription -- ^ information from the tarball -> SDistFlags -- ^ verbosity & snapshot@@ -82,16 +84,16 @@ -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) -> IO ()-sdist pkg flags mkTmpDir pps = do- distPref <- findDistPrefOrDefault $ sDistDistPref flags- let targetPref = distPref- tmpTargetDir = mkTmpDir distPref+sdist verbHandles pkg flags mkTmpDir pps = do+ distPref <- findDistPrefOrDefault $ setupDistPref common+ let targetPref = i distPref+ tmpTargetDir = mkTmpDir (i distPref) -- When given --list-sources, just output the list of sources to a file. case sDistListSources flags of Flag path -> withFile path WriteMode $ \outHandle -> do- ordinary <- listPackageSources verbosity "." pkg pps- traverse_ (hPutStrLn outHandle) ordinary+ ordinary <- listPackageSources verbosity mbWorkDir pkg pps+ traverse_ (hPutStrLn outHandle . getSymbolicPath) ordinary notice verbosity $ "List of package sources written to file '" ++ path ++ "'" NoFlag -> do -- do some QA@@ -108,7 +110,7 @@ info verbosity $ "Source directory created: " ++ targetDir Nothing -> do createDirectoryIfMissingVerbose verbosity True tmpTargetDir- withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do+ withTempDirectory tmpTargetDir "sdist." $ \tmpDir -> do let targetDir = tmpDir </> tarBallName pkg' generateSourceDir targetDir pkg' targzFile <- createArchive verbosity pkg' tmpDir targetPref@@ -117,11 +119,14 @@ generateSourceDir :: FilePath -> PackageDescription -> IO () generateSourceDir targetDir pkg' = do setupMessage verbosity "Building source dist for" (packageId pkg')- prepareTree verbosity pkg' targetDir pps+ prepareTree verbosity mbWorkDir pkg' targetDir pps when snapshot $ overwriteSnapshotPackageDesc verbosity pkg' targetDir - verbosity = fromFlag (sDistVerbosity flags)+ common = sDistCommonFlags flags+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ mbWorkDir = flagToMaybe $ setupWorkingDir common+ i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path snapshot = fromFlag (sDistSnapshot flags) -- | List all source files of a package.@@ -131,14 +136,13 @@ listPackageSources :: Verbosity -- ^ verbosity- -> FilePath+ -> Maybe (SymbolicPath CWD (Dir Pkg)) -- ^ directory with cabal file -> PackageDescription -- ^ info from the cabal file -> [PPSuffixHandler] -- ^ extra preprocessors (include suffixes)- -> IO [FilePath]- -- ^ relative paths+ -> IO [SymbolicPath Pkg File] listPackageSources verbosity cwd pkg_descr0 pps = do -- Call helpers that actually do all work. listPackageSources' verbosity dieWithException cwd pkg_descr pps@@ -153,19 +157,18 @@ listPackageSourcesWithDie :: Verbosity -- ^ verbosity- -> (Verbosity -> CabalException -> IO [FilePath])+ -> (forall res. Verbosity -> CabalException -> IO [res]) -- ^ '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+ -> Maybe (SymbolicPath CWD (Dir Pkg)) -- ^ directory with cabal file -> PackageDescription -- ^ info from the cabal file -> [PPSuffixHandler] -- ^ extra preprocessors (include suffixes)- -> IO [FilePath]- -- ^ relative paths+ -> IO [SymbolicPath Pkg File] listPackageSourcesWithDie verbosity rip cwd pkg_descr0 pps = do -- Call helpers that actually do all work. listPackageSources' verbosity rip cwd pkg_descr pps@@ -175,20 +178,19 @@ listPackageSources' :: Verbosity -- ^ verbosity- -> (Verbosity -> CabalException -> IO [FilePath])+ -> (forall res. Verbosity -> CabalException -> IO [res]) -- ^ '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+ -> Maybe (SymbolicPath CWD (Dir Pkg)) -- ^ directory with cabal file -> PackageDescription -- ^ info from the cabal file -> [PPSuffixHandler] -- ^ extra preprocessors (include suffixes)- -> IO [FilePath]- -- ^ relative paths-listPackageSources' verbosity rip cwd pkg_descr pps =+ -> IO [SymbolicPath Pkg File]+listPackageSources' verbosity rip mbWorkDir pkg_descr pps = fmap concat . sequenceA $ [ -- Library sources. fmap concat@@ -198,22 +200,22 @@ , signatures = sigs , libBuildInfo = libBi } ->- allSourcesBuildInfo verbosity rip cwd libBi pps (modules ++ sigs)+ allSourcesBuildInfo verbosity rip mbWorkDir 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+ biSrcs <- allSourcesBuildInfo verbosity rip mbWorkDir exeBi pps []+ mainSrc <- findMainExeFile verbosity mbWorkDir exeBi pps mainPath return (mainSrc : biSrcs) , -- Foreign library sources fmap concat . withAllFLib $ \flib@(ForeignLib{foreignLibBuildInfo = flibBi}) -> do- biSrcs <- allSourcesBuildInfo verbosity rip cwd flibBi pps []+ biSrcs <- allSourcesBuildInfo verbosity rip mbWorkDir flibBi pps [] defFiles <- traverse- (findModDefFile verbosity cwd flibBi pps)+ (findModDefFile verbosity mbWorkDir flibBi pps) (foreignLibModDefFile flib) return (defFiles ++ biSrcs) , -- Test suites sources.@@ -223,11 +225,11 @@ 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+ biSrcs <- allSourcesBuildInfo verbosity rip mbWorkDir bi pps []+ srcMainFile <- findMainExeFile verbosity mbWorkDir bi pps mainPath return (srcMainFile : biSrcs) TestSuiteLibV09 _ m ->- allSourcesBuildInfo verbosity rip cwd bi pps [m]+ allSourcesBuildInfo verbosity rip mbWorkDir bi pps [m] TestSuiteUnsupported tp -> rip verbosity $ UnsupportedTestSuite (show tp) , -- Benchmarks sources.@@ -237,8 +239,8 @@ 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+ biSrcs <- allSourcesBuildInfo verbosity rip mbWorkDir bi pps []+ srcMainFile <- findMainExeFile verbosity mbWorkDir bi pps mainPath return (srcMainFile : biSrcs) BenchmarkUnsupported tp -> rip verbosity $ UnsupportedBenchMark (show tp)@@ -248,34 +250,45 @@ $ \filename -> do let srcDataDirRaw = dataDir pkg_descr- srcDataDir- | null srcDataDirRaw = "."- | otherwise = srcDataDirRaw- matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd (srcDataDir </> filename)+ srcDataFile :: SymbolicPath Pkg File+ srcDataFile+ | null (getSymbolicPath srcDataDirRaw) = sameDirectory </> filename+ | otherwise = srcDataDirRaw </> filename+ fmap coerceSymbolicPath+ <$> matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) mbWorkDir srcDataFile , -- Extra source files. fmap concat . for (extraSrcFiles pkg_descr) $ \fpath ->- matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd fpath+ fmap relativeSymbolicPath+ <$> matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) mbWorkDir fpath , -- Extra doc files. fmap concat . for (extraDocFiles pkg_descr) $ \filename ->- matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd filename+ fmap (coerceSymbolicPath . relativeSymbolicPath)+ <$> matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) mbWorkDir filename+ , -- Extra files.+ fmap concat . for (extraFiles pkg_descr) $ \fpath ->+ fmap relativeSymbolicPath+ <$> matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) mbWorkDir fpath , -- License file(s).- return (map getSymbolicPath $ licenseFiles pkg_descr)+ return (map (relativeSymbolicPath . coerceSymbolicPath) $ 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+ incls = fmap getSymbolicPath $ filter (`notElem` autogenIncludes lbi) (installIncludes lbi)+ relincdirs = fmap getSymbolicPath $ sameDirectory : mapMaybe symbolicPathRelative_maybe (includeDirs lbi)+ traverse (fmap (makeSymbolicPath . snd) . findIncludeFile verbosity cwd relincdirs) incls , -- Setup script, if it exists.- fmap (maybe [] (\f -> [f])) $ findSetupFile cwd+ fmap (maybe [] (\f -> [makeSymbolicPath f])) $ findSetupFile cwd+ , -- SetupHooks script, if it exists.+ fmap (maybe [] (\f -> [makeSymbolicPath f])) $ findSetupHooksFile cwd , -- The .cabal file itself.- fmap (\d -> [d]) (tryFindPackageDescCwd verbosity cwd ".")+ fmap (\d -> [d]) (coerceSymbolicPath . relativeSymbolicPath <$> tryFindPackageDesc verbosity mbWorkDir) ] where+ cwd = maybe "." getSymbolicPath mbWorkDir -- 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)@@ -288,6 +301,8 @@ prepareTree :: Verbosity -- ^ verbosity+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -- ^ working directory -> PackageDescription -- ^ info from the cabal file -> FilePath@@ -295,11 +310,12 @@ -> [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)+prepareTree verbosity mbWorkDir pkg_descr0 targetDir pps = do+ ordinary <- listPackageSources verbosity mbWorkDir pkg_descr pps+ installOrdinaryFiles verbosity targetDir (map (([],) . i) ordinary) maybeCreateDefaultSetupScript targetDir where+ i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path pkg_descr = filterAutogenModules pkg_descr0 -- | Find the setup script file, if it exists.@@ -317,6 +333,21 @@ setupHs = "Setup.hs" setupLhs = "Setup.lhs" +-- | Find the setup hooks script file, if it exists.+findSetupHooksFile :: FilePath -> IO (Maybe FilePath)+findSetupHooksFile targetDir = do+ 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 = "SetupHooks.hs"+ setupLhs = "SetupHooks.lhs"+ -- | Create a default setup script in the target directory, if it doesn't exist. maybeCreateDefaultSetupScript :: FilePath -> IO () maybeCreateDefaultSetupScript targetDir = do@@ -333,41 +364,48 @@ -- | Find the main executable file. findMainExeFile :: Verbosity- -> FilePath- -- ^ cwd+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -- ^ working directory -> BuildInfo -> [PPSuffixHandler]- -> FilePath+ -> RelativePath Source File -- ^ main-is- -> IO FilePath+ -> IO (SymbolicPath Pkg File) findMainExeFile verbosity cwd exeBi pps mainPath = do ppFile <- findFileCwdWithExtension cwd (ppSuffixes pps)- (map getSymbolicPath (hsSourceDirs exeBi))- (dropExtension mainPath)+ (hsSourceDirs exeBi)+ (dropExtensionsSymbolicPath mainPath) case ppFile of- Nothing -> findFileCwd verbosity cwd (map getSymbolicPath (hsSourceDirs exeBi)) mainPath+ Nothing -> findFileCwd verbosity cwd (hsSourceDirs exeBi) mainPath Just pp -> return pp -- | Find a module definition file -- -- TODO: I don't know if this is right findModDefFile- :: Verbosity -> FilePath -> BuildInfo -> [PPSuffixHandler] -> FilePath -> IO FilePath+ :: Verbosity+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -> BuildInfo+ -> [PPSuffixHandler]+ -> RelativePath Source File+ -> IO (SymbolicPath Pkg File) findModDefFile verbosity cwd flibBi _pps modDefPath =- findFileCwd verbosity cwd ("." : map getSymbolicPath (hsSourceDirs flibBi)) modDefPath+ findFileCwd verbosity cwd (sameDirectory : 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 = dieWithException verbosity $ NoIncludeFileFound f-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+findIncludeFile verbosity cwd fs f = go fs+ where+ go [] = dieWithException verbosity $ NoIncludeFileFound f fs+ go (d : ds) = do+ let path = d </> f+ b <- doesFileExist (cwd </> path)+ if b then return (f, path) else go ds -- | Remove the auto-generated modules (like 'Paths_*') from 'exposed-modules' -- and 'other-modules'.@@ -394,7 +432,7 @@ filterFunction bi = \mn -> mn /= pathsModule && mn /= packageInfoModule- && not (mn `elem` autogenModules bi)+ && notElem mn (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@@ -402,6 +440,8 @@ prepareSnapshotTree :: Verbosity -- ^ verbosity+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -- ^ working directory -> PackageDescription -- ^ info from the cabal file -> FilePath@@ -409,8 +449,8 @@ -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) -> IO ()-prepareSnapshotTree verbosity pkg targetDir pps = do- prepareTree verbosity pkg targetDir pps+prepareSnapshotTree verbosity mbWorkDir pkg targetDir pps = do+ prepareTree verbosity mbWorkDir pkg targetDir pps overwriteSnapshotPackageDesc verbosity pkg targetDir overwriteSnapshotPackageDesc@@ -424,7 +464,7 @@ overwriteSnapshotPackageDesc verbosity pkg targetDir = do -- We could just writePackageDescription targetDescFile pkg_descr, -- but that would lose comments and formatting.- descFile <- defaultPackageDesc verbosity+ descFile <- getSymbolicPath <$> defaultPackageDescCwd verbosity withUTF8FileContents descFile $ writeUTF8File (targetDir </> descFile) . unlines@@ -476,10 +516,7 @@ let tarBallFilePath = targetPref </> tarBallName pkg_descr <.> "tar.gz" (tarProg, _) <- requireProgram verbosity tarProgram defaultProgramDb let formatOptSupported =- maybe False (== "YES") $- Map.lookup- "Supports --format"- (programProperties tarProg)+ Just "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@@ -493,37 +530,37 @@ -- | Given a buildinfo, return the names of all source files. allSourcesBuildInfo :: Verbosity- -> (Verbosity -> CabalException -> IO [FilePath])+ -> (Verbosity -> CabalException -> IO [SymbolicPath Pkg File]) -- ^ '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'+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -- ^ working directory -> BuildInfo -> [PPSuffixHandler] -- ^ Extra preprocessors -> [ModuleName] -- ^ Exposed modules- -> IO [FilePath]-allSourcesBuildInfo verbosity rip cwd bi pps modules = do- let searchDirs = map getSymbolicPath (hsSourceDirs bi)+ -> IO [SymbolicPath Pkg File]+allSourcesBuildInfo verbosity rip mbWorkDir bi pps modules = do+ let searchDirs = hsSourceDirs bi sources <- fmap concat $ sequenceA $- [ let file = ModuleName.toFilePath module_+ [ let file = moduleNameSymbolicPath 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+ findAllFilesCwdWithExtension mbWorkDir suffixes searchDirs file >>= nonEmpty' (notFound module_) return | module_ <- modules ++ otherModules bi ] bootFiles <- sequenceA- [ let file = ModuleName.toFilePath module_+ [ let file = moduleNameSymbolicPath module_ fileExts = builtinHaskellBootSuffixes- in findFileCwdWithExtension cwd fileExts (map getSymbolicPath (hsSourceDirs bi)) file+ in findFileCwdWithExtension mbWorkDir fileExts (hsSourceDirs bi) file | module_ <- modules ++ otherModules bi ] @@ -542,7 +579,7 @@ suffixes = ppSuffixes pps ++ builtinHaskellSuffixes - notFound :: ModuleName -> IO [FilePath]+ notFound :: ModuleName -> IO [SymbolicPath Pkg File] notFound m = rip verbosity $ NoModuleFound m suffixes
src/Distribution/Simple/Test.hs view
@@ -1,6 +1,9 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} -----------------------------------------------------------------------------@@ -25,8 +28,8 @@ import qualified Distribution.PackageDescription as PD import Distribution.Pretty+import Distribution.Simple.Build (addInternalBuildTools) import Distribution.Simple.Compiler-import Distribution.Simple.Flag (fromFlag) import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI@@ -39,28 +42,27 @@ import Distribution.TestSuite import qualified Distribution.Types.LocalBuildInfo as LBI import Distribution.Types.UnqualComponentName+import Distribution.Utils.Path+import Distribution.Verbosity import Distribution.Simple.Configure (getInstalledPackagesById) import Distribution.Simple.Errors-import Distribution.Simple.Register-import Distribution.Simple.Setup (fromFlagOrDefault)-import Distribution.Simple.Setup.Common (extraCompilationArtifacts)+import Distribution.Simple.Register (internalPackageDBPath)+import Distribution.Simple.Setup.Common import Distribution.Simple.Setup.Config import Distribution.Types.ExposedModule import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo (libraryDirs), exposedModules) import Distribution.Types.LocalBuildInfo (LocalBuildInfo (..)) import System.Directory ( createDirectoryIfMissing- , doesFileExist- , getDirectoryContents- , removeFile+ , listDirectory )-import System.FilePath ((</>)) -- | Perform the \"@.\/setup test@\" action. test :: Args -- ^ positional command-line arguments+ -> VerbosityHandles -> PD.PackageDescription -- ^ information from the .cabal file -> LBI.LocalBuildInfo@@ -68,18 +70,21 @@ -> TestFlags -- ^ flags sent to test -> IO ()-test args pkg_descr lbi0 flags = do- let verbosity = fromFlag $ testVerbosity flags+test args verbHandles pkg_descr lbi0 flags = do+ curDir <- LBI.absoluteWorkingDirLBI lbi0+ let common = testCommonFlags flags+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ distPref = fromFlag $ setupDistPref common+ i = LBI.interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path machineTemplate = fromFlag $ testMachineLog flags- distPref = fromFlag $ testDistPref flags- testLogDir = distPref </> "test"+ testLogDir = distPref </> makeRelativePathEx "test" testNames = args pkgTests = PD.testSuites pkg_descr enabledTests = LBI.enabledTestLBIs pkg_descr lbi -- We must add the internalPkgDB to the package database stack to lookup -- the path to HPC dirs of libraries local to this package- internalPkgDB = internalPackageDBPath lbi distPref- lbi = lbi0{withPackageDB = withPackageDB lbi0 ++ [SpecificPackageDB internalPkgDB]}+ internalPkgDb = internalPackageDBPath lbi0 distPref+ lbi = lbi0{withPackageDB = withPackageDB lbi0 ++ [SpecificPackageDB internalPkgDb]} doTest :: HPCMarkupInfo@@ -87,12 +92,23 @@ , Maybe TestSuiteLog ) -> IO TestSuiteLog- doTest hpcMarkupInfo ((suite, clbi), _) =+ doTest hpcMarkupInfo ((suite, clbi), _) = do+ let lbiForTest =+ lbi+ { withPrograms =+ -- Include any build-tool-depends on build tools internal to the current package.+ addInternalBuildTools+ curDir+ pkg_descr+ lbi+ (PD.testBuildInfo suite)+ (withPrograms lbi)+ } case PD.testInterface suite of PD.TestSuiteExeV10 _ _ ->- ExeV10.runTest pkg_descr lbi clbi hpcMarkupInfo flags suite+ ExeV10.runTest verbHandles pkg_descr lbiForTest clbi hpcMarkupInfo flags suite PD.TestSuiteLibV09 _ _ ->- LibV09.runTest pkg_descr lbi clbi hpcMarkupInfo flags suite+ LibV09.runTest verbHandles pkg_descr lbiForTest clbi hpcMarkupInfo flags suite _ -> return TestSuiteLog@@ -117,7 +133,7 @@ dieWithException verbosity NoTestSuitesEnabled testsToRun <- case testNames of- [] -> return $ zip enabledTests $ repeat Nothing+ [] -> return $ map (,Nothing) enabledTests names -> for names $ \tName -> let testMap = zip enabledNames enabledTests enabledNames = map (PD.testName . fst) enabledTests@@ -130,12 +146,11 @@ dieWithException verbosity $ TestNameDisabled tName | otherwise -> dieWithException verbosity $ NoSuchTest tName - createDirectoryIfMissing True testLogDir+ createDirectoryIfMissing True $ i testLogDir -- Delete ordinary files from test log directory.- getDirectoryContents testLogDir- >>= filterM doesFileExist . map (testLogDir </>)- >>= traverse_ removeFile+ listDirectory (i testLogDir)+ >>= traverse_ (removeFileForcibly . (i testLogDir </>)) -- We configured the unit-ids of libraries we should cover in our coverage -- report at configure time into the local build info. At build time, we built@@ -144,7 +159,7 @@ -- Now, we get the path to the HPC artifacts and exposed modules of each -- library by querying the package database keyed by unit-id: let coverageFor =- nub $+ ordNub $ fromFlagOrDefault [] (configCoverageFor (configFlags lbi)) <> extraCoverageFor lbi ipkginfos <- getInstalledPackagesById verbosity lbi MissingCoveredInstalledLibrary coverageFor@@ -154,7 +169,7 @@ unzip $ map ( \ip ->- ( map (</> extraCompilationArtifacts) $ libraryDirs ip+ ( map ((</> coerceSymbolicPath extraCompilationArtifacts) . makeSymbolicPath) $ libraryDirs ip , map exposedName $ exposedModules ip ) )@@ -166,8 +181,8 @@ suites <- traverse (doTest hpcMarkupInfo) testsToRun let packageLog = (localPackageLog pkg_descr lbi){testSuites = suites} packageLogFile =- (</>) testLogDir $- packageLogPath machineTemplate pkg_descr lbi+ i testLogDir+ </> packageLogPath machineTemplate pkg_descr lbi allOk <- summarizePackage verbosity packageLog writeFile packageLogFile $ show packageLog
src/Distribution/Simple/Test/ExeV10.hs view
@@ -8,11 +8,10 @@ import Distribution.Compat.Prelude import Prelude () -import Distribution.Compat.Environment import qualified Distribution.PackageDescription as PD-import Distribution.Simple.Build.PathsModule import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler+import Distribution.Simple.Errors import Distribution.Simple.Flag import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs@@ -21,10 +20,15 @@ , buildDir , depLibraryPaths )++import Distribution.Simple.Program.Db+import Distribution.Simple.Program.Find+import Distribution.Simple.Program.Run+import Distribution.Simple.Setup.Common import Distribution.Simple.Setup.Test import Distribution.Simple.Test.Log import Distribution.Simple.Utils-import Distribution.System+import Distribution.System (Platform (Platform)) import Distribution.TestSuite import qualified Distribution.Types.LocalBuildInfo as LBI ( LocalBuildInfo (..)@@ -34,38 +38,33 @@ import Distribution.Types.UnqualComponentName import Distribution.Verbosity +import Distribution.Utils.Path++import qualified Data.ByteString.Lazy as LBS+import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI, packageRoot) import System.Directory ( createDirectoryIfMissing- , doesDirectoryExist , doesFileExist- , getCurrentDirectory- , removeDirectoryRecursive+ , removePathForcibly )-import System.FilePath ((<.>), (</>))-import System.IO (stderr, stdout) import System.Process (createPipe) -import qualified Data.ByteString.Lazy as LBS-import Distribution.Simple.Errors- runTest- :: PD.PackageDescription+ :: VerbosityHandles+ -> PD.PackageDescription -> LBI.LocalBuildInfo -> LBI.ComponentLocalBuildInfo -> HPCMarkupInfo -> TestFlags -> PD.TestSuite -> IO TestSuiteLog-runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do+runTest verbHandles pkg_descr lbi clbi hpcMarkupInfo flags suite = do let isCoverageEnabled = LBI.testCoverage lbi way = guessWay lbi- tixDir_ = tixDir distPref way-- pwd <- getCurrentDirectory- existingEnv <- getEnvironment+ tixDir_ = i $ tixDir distPref way let cmd =- LBI.buildDir lbi+ i (LBI.buildDir lbi) </> testName' </> testName' <.> exeExtension (LBI.hostPlatform lbi) -- Check that the test executable exists.@@ -75,28 +74,33 @@ Couldn'tFindTestProgram cmd -- Remove old .tix files if appropriate.- unless (fromFlag $ testKeepTix flags) $ do- exists' <- doesDirectoryExist tixDir_- when exists' $ removeDirectoryRecursive tixDir_+ unless (fromFlag $ testKeepTix flags) $+ removePathForcibly tixDir_ -- Create directory for HPC files. createDirectoryIfMissing True tixDir_ -- Write summary notices indicating start of test suite- notice verbosity $ summarizeSuiteStart $ testName'+ notice verbosity $ summarizeSuiteStart testName' - -- Run the test executable+ -- Run the test executable (with the appropriate environment set)+ let progDb = LBI.withPrograms lbi+ pathVar = progSearchPath progDb+ envOverrides = progOverrideEnv progDb+ newPath <- programSearchPathAsPATHVar pathVar 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+ tixFile = packageRoot (testCommonFlags flags) </> getSymbolicPath (tixFilePath distPref way testName') + shellEnv <-+ getFullEnvironment+ ( [("PATH", Just newPath)]+ ++ [("HPCTIXFILE", Just tixFile) | isCoverageEnabled]+ ++ envOverrides+ )+ -- Add (DY)LD_LIBRARY_PATH if needed shellEnv' <- if LBI.withDynExe lbi@@ -108,45 +112,48 @@ -- Output logger (wOut, wErr, getLogText) <- case details of- Direct -> return (stdout, stderr, return LBS.empty)+ Direct -> return (Nothing, Nothing, return LBS.empty) _ -> do (rOut, wOut) <- createPipe - return $ (,,) wOut wOut $ do+ return $ (,,) (Just wOut) (Just 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+ when (details == Streaming) $+ LBS.hPutStr (verbosityChosenOutputHandle verbosity) logText -- drain the output. evaluate (force logText) + let mbWorkDir =+ interpretSymbolicPathCWD+ <$> flagToMaybe (setupWorkingDir (testCommonFlags flags))+ (exit, logText) <- case testWrapper flags of Flag path -> rawSystemIOWithEnvAndAction verbosity path (cmd : opts)- Nothing+ mbWorkDir (Just shellEnv')- getLogText- -- these handles are automatically closed+ (\_ _ _ -> getLogText) Nothing- (Just wOut)- (Just wErr)+ wOut+ wErr NoFlag -> rawSystemIOWithEnvAndAction verbosity cmd opts- Nothing+ mbWorkDir (Just shellEnv')- getLogText- -- these handles are automatically closed+ (\_ _ _ -> getLogText) Nothing- (Just wOut)- (Just wErr)+ wOut+ wErr -- Generate TestSuiteLog from executable exit code and a machine- -- readable test log.@@ -170,9 +177,9 @@ || details == Failures && not (suitePassed $ testLogs suiteLog) ) -- verbosity overrides show-details- && verbosity >= normal+ && verbosityLevel verbosity >= Normal whenPrinting $ do- LBS.putStr logText+ LBS.hPutStr (verbosityChosenOutputHandle verbosity) logText putChar '\n' -- Write summary notice to terminal indicating end of test suite@@ -191,12 +198,15 @@ return suiteLog where+ i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path+ commonFlags = testCommonFlags flags+ testName' = unUnqualComponentName $ PD.testName suite - distPref = fromFlag $ testDistPref flags- verbosity = fromFlag $ testVerbosity flags+ distPref = fromFlag $ setupDistPref commonFlags+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity commonFlags) details = fromFlag $ testShowDetails flags- testLogDir = distPref </> "test"+ testLogDir = distPref </> makeRelativePathEx "test" buildLog exit = let r = case exit of@@ -213,7 +223,7 @@ { testSuiteName = PD.testName suite , testLogs = l , logFile =- testLogDir+ i testLogDir </> testSuiteLogPath (fromFlag $ testHumanLog flags) pkg_descr
src/Distribution/Simple/Test/LibV09.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -16,63 +17,63 @@ import Distribution.Types.UnqualComponentName import Prelude () -import Distribution.Compat.Environment import Distribution.Compat.Internal.TempFile+import Distribution.Compat.Process (proc) 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.Errors import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI+import Distribution.Simple.Program.Db+import Distribution.Simple.Program.Find+import Distribution.Simple.Program.Run+import Distribution.Simple.Setup.Common import Distribution.Simple.Setup.Test import Distribution.Simple.Test.Log import Distribution.Simple.Utils import Distribution.System import Distribution.TestSuite import qualified Distribution.Types.LocalBuildInfo as LBI+import Distribution.Utils.Path import Distribution.Verbosity import qualified Control.Exception as CE import qualified Data.ByteString.Lazy as LBS-import Distribution.Compat.Process (proc)-import Distribution.Simple.Errors import System.Directory ( canonicalizePath , createDirectoryIfMissing- , doesDirectoryExist , doesFileExist , getCurrentDirectory- , removeDirectoryRecursive- , removeFile+ , removePathForcibly , setCurrentDirectory )-import System.FilePath ((<.>), (</>)) import System.IO (hClose, hPutStr) import qualified System.Process as Process runTest- :: PD.PackageDescription+ :: VerbosityHandles+ -> PD.PackageDescription -> LBI.LocalBuildInfo -> LBI.ComponentLocalBuildInfo -> HPCMarkupInfo -> TestFlags -> PD.TestSuite -> IO TestSuiteLog-runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do+runTest verbHandles pkg_descr lbi clbi hpcMarkupInfo flags suite = do let isCoverageEnabled = LBI.testCoverage lbi way = guessWay lbi - pwd <- getCurrentDirectory- existingEnv <- getEnvironment+ let mbWorkDir = LBI.mbWorkDirLBI lbi let cmd =- LBI.buildDir lbi+ interpretSymbolicPath mbWorkDir (LBI.buildDir lbi) </> stubName suite </> stubName suite <.> exeExtension (LBI.hostPlatform lbi)+ tDir = i $ tixDir distPref way -- Check that the test executable exists. exists <- doesFileExist cmd unless exists $@@ -80,35 +81,39 @@ Couldn'tFindTestProgLibV09 cmd -- Remove old .tix files if appropriate.- unless (fromFlag $ testKeepTix flags) $ do- let tDir = tixDir distPref way- exists' <- doesDirectoryExist tDir- when exists' $ removeDirectoryRecursive tDir+ unless (fromFlag $ testKeepTix flags) $+ removePathForcibly tDir -- Create directory for HPC files.- createDirectoryIfMissing True $ tixDir distPref way+ createDirectoryIfMissing True tDir -- Write summary notices indicating start of test suite notice verbosity $ summarizeSuiteStart testName' - suiteLog <- CE.bracket openCabalTemp deleteIfExists $ \tempLog -> do+ suiteLog <- CE.bracket openCabalTemp removeFileForcibly $ \tempLog -> do+ -- Compute the appropriate environment for running the test suite+ let progDb = LBI.withPrograms lbi+ pathVar = progSearchPath progDb+ envOverrides = progOverrideEnv progDb+ newPath <- programSearchPathAsPATHVar pathVar+ -- 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+ tixFile = i $ tixFilePath distPref way testName'++ shellEnv <-+ getFullEnvironment+ ( [("PATH", Just newPath)]+ ++ [("HPCTIXFILE", Just tixFile) | isCoverageEnabled]+ ++ envOverrides+ ) -- 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+ cpath <- canonicalizePath $ i $ LBI.componentBuildDir lbi clbi return (addLibraryPath os (cpath : paths) shellEnv) else return shellEnv let (cmd', opts') = case testWrapper flags of@@ -143,7 +148,7 @@ -- Generate final log file name let finalLogName l =- testLogDir+ interpretSymbolicPath mbWorkDir testLogDir </> testSuiteLogPath (fromFlag $ testHumanLog flags) pkg_descr@@ -176,9 +181,9 @@ when $ (details > Never) && (not (suitePassed $ testLogs suiteLog) || details == Always)- && verbosity >= normal+ && verbosityLevel verbosity >= Normal whenPrinting $ do- LBS.putStr logText+ LBS.hPutStr (verbosityChosenOutputHandle verbosity) logText putChar '\n' return suiteLog@@ -199,19 +204,17 @@ return suiteLog where+ i = LBI.interpretSymbolicPathLBI lbi+ common = testCommonFlags flags testName' = unUnqualComponentName $ PD.testName suite - deleteIfExists file = do- exists <- doesFileExist file- when exists $ removeFile file-- testLogDir = distPref </> "test"+ testLogDir = distPref </> makeRelativePathEx "test" openCabalTemp = do- (f, h) <- openTempFile testLogDir $ "cabal-test-" <.> "log"+ (f, h) <- openTempFile (i testLogDir) $ "cabal-test-" <.> "log" hClose h >> return f - distPref = fromFlag $ testDistPref flags- verbosity = fromFlag $ testVerbosity flags+ distPref = fromFlag $ setupDistPref common+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) -- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't -- necessarily a path.@@ -234,10 +237,6 @@ -- Test stub ---------- --- | The name of the stub executable associated with a library 'TestSuite'.-stubName :: PD.TestSuite -> FilePath-stubName t = unUnqualComponentName (PD.testName t) ++ "Stub"- -- | The filename of the source file for the stub executable associated with a -- library 'TestSuite'. stubFilePath :: PD.TestSuite -> FilePath@@ -307,7 +306,7 @@ where stubRunTests' (Test t) = do l <- run t >>= finish- summarizeTest normal Always l+ summarizeTest (mkVerbosity defaultVerbosityHandles normal) Always l return l where finish (Finished result) =@@ -323,7 +322,7 @@ return $ GroupLogs (groupName g) logs stubRunTests' (ExtraOptions _ t) = stubRunTests' t maybeDefaultOption opt =- maybe Nothing (\d -> Just (optionName opt, d)) $ optionDefault opt+ (\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
src/Distribution/Simple/UHC.hs view
@@ -1,4 +1,6 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} -----------------------------------------------------------------------------@@ -50,7 +52,7 @@ import qualified Data.Map as Map (empty) import System.Directory-import System.FilePath+import System.FilePath (pathSeparator) -- ----------------------------------------------------------------------------- -- Configuring@@ -58,10 +60,9 @@ configure :: Verbosity -> Maybe FilePath- -> Maybe FilePath -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb)-configure verbosity hcPath _hcPkgPath progdb = do+configure verbosity hcPath progdb = do (_uhcProg, uhcVersion, progdb') <- requireProgramVersion verbosity@@ -77,6 +78,7 @@ , compilerLanguages = uhcLanguages , compilerExtensions = uhcLanguageExtensions , compilerProperties = Map.empty+ , compilerWiredInUnitIds = Nothing } compPlatform = Nothing return (comp, compPlatform, progdb')@@ -112,25 +114,25 @@ getInstalledPackages :: Verbosity -> Compiler- -> PackageDBStack+ -> Maybe (SymbolicPath CWD (Dir from))+ -> PackageDBStackX (SymbolicPath from (Dir PkgDB)) -> ProgramDb -> IO InstalledPackageIndex-getInstalledPackages verbosity comp packagedbs progdb = do+getInstalledPackages verbosity comp mbWorkDir packagedbs progdb = do let compilerid = compilerId comp systemPkgDir <- getGlobalPackageDir verbosity progdb userPkgDir <- getUserPackageDir- let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs)+ let pkgDirs = ordNub (concatMap (packageDbPaths userPkgDir systemPkgDir mbWorkDir) packagedbs) -- putStrLn $ "pkgdirs: " ++ show pkgDirs pkgs <-- liftM (map addBuiltinVersions . concat) $- traverse- (\d -> getDirectoryContents d >>= filterM (isPkgDir (prettyShow compilerid) d))+ map addBuiltinVersions . concat+ <$> traverse+ (\d -> listDirectory 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) @@ -153,12 +155,17 @@ homeDir <- getHomeDirectory return $ homeDir </> ".cabal" </> "lib" -- TODO: determine in some other way -packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath]-packageDbPaths user system db =+packageDbPaths+ :: FilePath+ -> FilePath+ -> Maybe (SymbolicPath CWD (Dir from))+ -> PackageDBX (SymbolicPath from (Dir PkgDB))+ -> [FilePath]+packageDbPaths user system mbWorkDir db = case db of GlobalPackageDB -> [system] UserPackageDB -> [user]- SpecificPackageDB path -> [path]+ SpecificPackageDB path -> [interpretSymbolicPath mbWorkDir path] -- | Hack to add version numbers to UHC-built-in packages. This should sooner or -- later be fixed on the UHC side.@@ -208,7 +215,7 @@ buildLib verbosity pkg_descr lbi lib clbi = do systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi) userPkgDir <- getUserPackageDir- let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi)+ let runUhcProg = runDbProgramCwd verbosity (mbWorkDirLBI lbi) uhcProgram (withPrograms lbi) let uhcArgs = -- set package name ["--pkg-build=" ++ prettyShow (packageId pkg_descr)]@@ -224,9 +231,7 @@ -- 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))+ ++ map (map (\c -> if c == '.' then pathSeparator else c) . prettyShow) (allLibModules lib clbi) runUhcProg uhcArgs @@ -242,8 +247,11 @@ buildExe verbosity _pkg_descr lbi exe clbi = do systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi) userPkgDir <- getUserPackageDir- let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi)- let uhcArgs =+ let mbWorkDir = mbWorkDirLBI lbi+ srcMainPath <- findFileCwd verbosity mbWorkDir (hsSourceDirs $ buildInfo exe) (modulePath exe)+ let runUhcProg = runDbProgramCwd verbosity (mbWorkDirLBI lbi) uhcProgram (withPrograms lbi)+ u = interpretSymbolicPathCWD+ uhcArgs = -- common flags lib/exe constructUHCCmdLine userPkgDir@@ -254,9 +262,9 @@ (buildDir lbi) verbosity -- output file- ++ ["--output", buildDir lbi </> prettyShow (exeName exe)]+ ++ ["--output", u $ buildDir lbi </> makeRelativePathEx (prettyShow (exeName exe))] -- main source module- ++ [modulePath exe]+ ++ [u srcMainPath] runUhcProg uhcArgs constructUHCCmdLine@@ -265,18 +273,11 @@ -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo- -> FilePath+ -> SymbolicPath Pkg (Dir Build) -> Verbosity -> [String] constructUHCCmdLine user system lbi bi clbi odir verbosity =- -- verbosity- ( if verbosity >= deafening- then ["-v4"]- else- if verbosity >= normal- then []- else ["-v0"]- )+ vFlags ++ hcOptions UHC bi -- flags for language extensions ++ languageToFlags (compiler lbi) (defaultLanguage bi)@@ -287,26 +288,33 @@ ++ ["--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]+ ++ ["-i" ++ u odir]+ ++ ["-i" ++ u l | l <- ordNub (hsSourceDirs bi)]+ ++ ["-i" ++ u (autogenComponentModulesDir lbi clbi)]+ ++ ["-i" ++ u (autogenPackageModulesDir lbi)] -- cpp options ++ ["--optP=" ++ opt | opt <- cppOptions bi] -- output path- ++ ["--odir=" ++ odir]+ ++ ["--odir=" ++ u odir] -- optimization ++ ( case withOptimization lbi of NoOptimisation -> ["-O0"] NormalOptimisation -> ["-O1"] MaximumOptimisation -> ["-O2"] )+ where+ u = interpretSymbolicPathCWD -- See Note [Symbolic paths] in Distribution.Utils.Path+ vFlags =+ if+ | verbosityLevel verbosity >= Deafening -> ["-v4"]+ | verbosityLevel verbosity < Normal -> ["-v0"]+ | otherwise -> [] uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String] uhcPackageDbOptions user system db = map (\x -> "--pkg-searchpath=" ++ x)- (concatMap (packageDbPaths user system) db)+ (concatMap (packageDbPaths user system Nothing) db) -- ----------------------------------------------------------------------------- -- Installation@@ -317,11 +325,12 @@ -> FilePath -> FilePath -> FilePath+ -> FilePath -> PackageDescription -> Library -> ComponentLocalBuildInfo -> IO ()-installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library _clbi = do+installLib verbosity _lbi targetDir _dynlibTargetDir _bytecodeTargetDir builtDir pkg _library _clbi = do -- putStrLn $ "dest: " ++ targetDir -- putStrLn $ "built: " ++ builtDir installDirectoryContents verbosity (builtDir </> prettyShow (packageId pkg)) targetDir@@ -342,16 +351,17 @@ registerPackage :: Verbosity+ -> Maybe (SymbolicPath CWD (Dir from)) -> Compiler -> ProgramDb- -> PackageDBStack+ -> PackageDBStackS from -> InstalledPackageInfo -> IO ()-registerPackage verbosity comp progdb packageDbs installedPkgInfo = do+registerPackage verbosity mbWorkDir comp progdb packageDbs installedPkgInfo = do dbdir <- case registrationPackageDB packageDbs of GlobalPackageDB -> getGlobalPackageDir verbosity progdb UserPackageDB -> getUserPackageDir- SpecificPackageDB dir -> return dir+ SpecificPackageDB dir -> return (interpretSymbolicPath mbWorkDir dir) let pkgdir = dbdir </> uhcPackageDir (prettyShow pkgid) (prettyShow compilerid) createDirectoryIfMissingVerbose verbosity True pkgdir writeUTF8File@@ -361,5 +371,5 @@ pkgid = sourcePackageId installedPkgInfo compilerid = compilerId comp -inplacePackageDbPath :: LocalBuildInfo -> FilePath-inplacePackageDbPath lbi = buildDir lbi+inplacePackageDbPath :: LocalBuildInfo -> SymbolicPath Pkg (Dir PkgDB)+inplacePackageDbPath lbi = coerceSymbolicPath $ buildDir lbi
src/Distribution/Simple/UserHooks.hs view
@@ -13,7 +13,7 @@ -- -- This defines the API that @Setup.hs@ scripts can use to customise the way -- the build works. This module just defines the 'UserHooks' type. The--- predefined sets of hooks that implement the @Simple@, @Make@ and @Configure@+-- predefined sets of hooks that implement the @Simple@ and @Configure@ -- build systems are defined in "Distribution.Simple". The 'UserHooks' is a big -- record of functions. There are 3 for each action, a pre, post and the action -- itself. There are few other miscellaneous hooks, ones to extend the set of@@ -32,7 +32,7 @@ , emptyUserHooks ) where -import Distribution.Compat.Prelude+import Distribution.Compat.Prelude hiding (getContents, putStr) import Prelude () import Distribution.PackageDescription@@ -144,7 +144,7 @@ , hookedPreProcessors = [] , hookedPrograms = [] , preConf = rn'- , confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook."))+ , confHook = \_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.") , postConf = ru , preBuild = rn' , buildHook = ru
src/Distribution/Simple/Utils.hs view
@@ -1,13 +1,18 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+#if MIN_VERSION_base(4,21,0)+{-# LANGUAGE ImplicitParams #-}+#endif {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+#ifdef GIT_REV+{-# LANGUAGE TemplateHaskell #-}+#endif ----------------------------------------------------------------------------- @@ -27,6 +32,8 @@ -- various directory and file functions that do extra logging. module Distribution.Simple.Utils ( cabalVersion+ , cabalGitInfo+ , cabalCompilerInfo -- * logging and errors , dieNoVerbosity@@ -36,6 +43,7 @@ , dieNoWrap , topHandler , topHandlerWith+ , isUserException , warn , warnError , notice@@ -61,6 +69,7 @@ , rawSystemProc , rawSystemProcAction , rawSystemExitWithEnv+ , rawSystemExitWithEnvCwd , rawSystemStdout , rawSystemStdInOut , rawSystemIOWithEnv@@ -86,7 +95,11 @@ , copyFileVerbose , copyFiles , copyFileTo+ , copyFileToCwd + -- * removing files+ , removeFileForcibly+ -- * installing files , installOrdinaryFile , installExecutableFile@@ -103,7 +116,6 @@ , setFileExecutable -- * file names- , currentDir , shortRelativePath , dropExeExtension , exeExtensions@@ -112,13 +124,17 @@ , findFileEx , findFileCwd , findFirstFile+ , Suffix (..) , findFileWithExtension , findFileCwdWithExtension , findFileWithExtension'+ , findFileCwdWithExtension' , findAllFilesWithExtension , findAllFilesCwdWithExtension , findModuleFileEx+ , findModuleFileCwd , findModuleFilesEx+ , findModuleFilesCwd , getDirectoryContentsRecursive -- * environment variables@@ -133,17 +149,18 @@ , TempFileOptions (..) , defaultTempFileOptions , withTempFile+ , withTempFileCwd , withTempFileEx , withTempDirectory+ , withTempDirectoryCwd , withTempDirectoryEx+ , withTempDirectoryCwdEx , createTempDirectory -- * .cabal and .buildinfo files- , defaultPackageDesc+ , defaultPackageDescCwd , findPackageDesc- , findPackageDescCwd , tryFindPackageDesc- , tryFindPackageDescCwd , findHookedPackageDesc -- * reading and writing files safely@@ -176,6 +193,7 @@ , listUnion , listUnionRight , ordNub+ , sortNub , ordNubBy , ordNubRight , safeHead@@ -185,6 +203,7 @@ , unintersperse , wrapText , wrapLine+ , stripCommonPrefix -- * FilePath stuff , isAbsoluteOnAnyPlatform@@ -194,11 +213,11 @@ 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.Prelude import Distribution.Compat.Stack+import Distribution.Compat.SysInfo as SIC import Distribution.ModuleName as ModuleName import Distribution.Simple.Errors import Distribution.Simple.PreProcess.Types@@ -207,6 +226,7 @@ import Distribution.Utils.Generic import Distribution.Utils.IOData (IOData (..), IODataMode (..), KnownIODataMode (..)) import qualified Distribution.Utils.IOData as IOData+import Distribution.Utils.Path import Distribution.Verbosity import Distribution.Version import Prelude ()@@ -227,8 +247,10 @@ ( cast ) +import Control.Concurrent (threadDelay) import qualified Control.Exception as Exception import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)+import qualified Data.Version as DV import Distribution.Compat.Process (proc) import Foreign.C.Error (Errno (..), ePIPE) import qualified GHC.IO.Exception as GHC@@ -239,25 +261,27 @@ , createDirectory , doesDirectoryExist , doesFileExist- , getDirectoryContents , getModificationTime , getPermissions- , removeDirectoryRecursive+ , getTemporaryDirectory+ , listDirectory , removeFile+ , removePathForcibly ) import System.Environment ( getProgName )+import System.FilePath (takeFileName) import System.FilePath as FilePath ( getSearchPath+ , isExtensionOf , joinPath , normalise , searchPathSeparator , splitDirectories , splitExtension+ , stripExtension , takeDirectory- , (<.>)- , (</>) ) import System.IO ( BufferMode (..)@@ -270,15 +294,31 @@ , hSetBinaryMode , hSetBuffering , stderr+ , stdin , stdout ) import System.IO.Error import System.IO.Unsafe ( unsafeInterleaveIO )+import qualified System.Info as SI import qualified System.Process as Process import qualified Text.PrettyPrint as Disp +#ifdef GIT_REV+import Data.Either (isLeft)+import GitHash+ ( giHash+ , giBranch+ , giCommitDate+ , tGitInfoCwdTry+ )+#endif++#if MIN_VERSION_base(4,21,0)+import Control.Exception.Context+#endif+ -- We only get our own version number when we're building with ourselves cabalVersion :: Version #if defined(BOOTSTRAPPED_CABAL)@@ -289,6 +329,45 @@ cabalVersion = mkVersion [3,0] --used when bootstrapping #endif +-- |+-- `Cabal` Git information. Only filled in if built in a Git tree in+-- development mode and Template Haskell is available.+cabalGitInfo :: String+#ifdef GIT_REV+cabalGitInfo = if giHash' == ""+ then ""+ else concat [ "(commit "+ , giHash'+ , branchInfo+ , either (const "") ((", " ++) . giCommitDate) gi'+ , ")"+ ]+ where+ gi' = $$tGitInfoCwdTry+ giHash' = take 7 . either (const "") giHash $ gi'+ branch = either id giBranch gi'+ branchInfo | isLeft gi' = ""+ | branch == "master" = ""+ | otherwise = " on " <> branch+#else+cabalGitInfo = ""+#endif++-- |+-- `Cabal` compiler information, reported by `--version-full` but otherwise+-- unused.+cabalCompilerInfo :: String+cabalCompilerInfo =+ concat+ [ SI.compilerName+ , " "+ , intercalate "." (map show (DV.versionBranch SIC.fullCompilerVersion))+ , " on "+ , SI.os+ , " "+ , SI.arch+ ]+ -- ---------------------------------------------------------------------------- -- Exception and logging utils @@ -376,19 +455,19 @@ die' verbosity msg = withFrozenCallStack $ do ioError . verbatimUserError =<< annotateErrorString verbosity- =<< pure . wrapTextVerbosity verbosity+ =<< pure . wrapTextVerbosity (verbosityFlags verbosity) =<< pure . addErrorPrefix =<< prefixWithProgName msg --- Type which will be a wrapper for cabal -expections and cabal-install exceptions-data VerboseException a = VerboseException CallStack POSIXTime Verbosity a- deriving (Show, Typeable)+-- Type which will be a wrapper for cabal -exceptions and cabal-install exceptions+data VerboseException a = VerboseException CallStack POSIXTime VerbosityFlags a+ deriving (Show) -- Function which will replace the existing die' call sites-dieWithException :: (HasCallStack, Show a1, Typeable a1, Exception (VerboseException a1)) => Verbosity -> a1 -> IO a+dieWithException :: (HasCallStack, Exception (VerboseException a1)) => Verbosity -> a1 -> IO a dieWithException verbosity exception = do ts <- getPOSIXTime- throwIO $ VerboseException callStack ts verbosity exception+ throwIO $ VerboseException callStack ts (verbosityFlags verbosity) exception -- Instance for Cabal Exception which will display error code and error message with callStack info instance Exception (VerboseException CabalException) where@@ -437,7 +516,7 @@ annotateErrorString :: Verbosity -> String -> IO String annotateErrorString verbosity msg = do ts <- getPOSIXTime- return $ withMetadata ts AlwaysMark VerboseTrace verbosity msg+ return $ withMetadata ts AlwaysMark VerboseTrace (verbosityFlags 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@@ -449,7 +528,7 @@ ts <- getPOSIXTime flip modifyIOError act $ ioeModifyErrorString $- withMetadata ts NeverMark VerboseTrace verbosity+ withMetadata ts NeverMark VerboseTrace (verbosityFlags verbosity) -- | A semantic editor for the error message inside an 'IOError'. ioeModifyErrorString :: (String -> String) -> IOError -> IOError@@ -459,9 +538,22 @@ ioeErrorString :: Lens' IOError String ioeErrorString f ioe = ioeSetErrorString ioe <$> f (ioeGetErrorString ioe) +-- | Check that the type of the exception matches the given user error type.+isUserException :: forall user_err. Typeable user_err => Proxy user_err -> Exception.SomeException -> Bool+isUserException Proxy (SomeException se) =+ case cast se :: Maybe user_err of+ Just{} -> True+ Nothing -> False+ {-# NOINLINE topHandlerWith #-}-topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a-topHandlerWith cont prog = do+topHandlerWith+ :: forall a+ . (Exception.SomeException -> Bool)+ -- ^ Identify when the error is an exception to display to users.+ -> (Exception.SomeException -> IO a)+ -> IO a+ -> IO a+topHandlerWith is_user_exception cont prog = do -- By default, stderr to a terminal device is NoBuffering. But this -- is *really slow* hSetBuffering stderr LineBuffering@@ -489,7 +581,7 @@ cont se message :: String -> Exception.SomeException -> String- message pname (Exception.SomeException se) =+ message pname e@(Exception.SomeException se) = case cast se :: Maybe Exception.IOException of Just ioe | ioeGetVerbatim ioe ->@@ -504,21 +596,27 @@ _ -> "" detail = ioeGetErrorString ioe in wrapText $ addErrorPrefix $ pname ++ ": " ++ file ++ detail- _ ->- displaySomeException se ++ "\n"+ -- Don't print a call stack for a "user exception"+ _+ | is_user_exception e -> displayException e+ -- Other errors which have are not intended for user display, print with a callstack.+ | otherwise -> displaySomeExceptionWithContext e ++ "\n" -- | BC wrapper around 'Exception.displayException'.-displaySomeException :: Exception.Exception e => e -> String-displaySomeException se = Exception.displayException se--topHandler :: IO a -> IO a-topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog+displaySomeExceptionWithContext :: SomeException -> String+#if MIN_VERSION_base(4,21,0)+displaySomeExceptionWithContext (SomeException e) =+ case displayExceptionContext ?exceptionContext of+ "" -> msg+ dc -> msg ++ "\n\n" ++ dc+ where+ msg = displayException e+#else+displaySomeExceptionWithContext e = displayException e+#endif --- | Depending on 'isVerboseStderr', set the output handle to 'stderr' or 'stdout'.-verbosityHandle :: Verbosity -> Handle-verbosityHandle verbosity- | isVerboseStderr verbosity = stderr- | otherwise = stdout+topHandler :: (Exception.SomeException -> Bool) -> IO a -> IO a+topHandler is_user_exception prog = topHandlerWith is_user_exception (const $ exitWith (ExitFailure 1)) prog -- | Non fatal conditions that may be indicative of an error or problem. --@@ -526,7 +624,7 @@ warn :: Verbosity -> String -> IO () warn verbosity msg = warnMessage "Warning" verbosity msg --- | Like 'warn', but prepend @Error: …@ instead of @Waring: …@ before the+-- | Like 'warn', but prepend @Error: …@ instead of @Warning: …@ before the -- the message. Useful when you want to highlight the condition is an error -- but do not want to quit the program yet. warnError :: Verbosity -> String -> IO ()@@ -535,13 +633,17 @@ -- | Warning message, with a custom label. warnMessage :: String -> Verbosity -> String -> IO () warnMessage l verbosity msg = withFrozenCallStack $ do- when ((verbosity >= normal) && not (isVerboseNoWarn verbosity)) $ do+ when (verbosityLevel verbosity >= Normal && not (isVerboseNoWarn flags)) $ do ts <- getPOSIXTime- hFlush stdout- hPutStr stderr- . withMetadata ts NormalMark FlagTrace verbosity- . wrapTextVerbosity verbosity+ let outHandle = verbosityChosenOutputHandle verbosity+ errHandle = verbosityErrorHandle verbosity+ hFlush outHandle+ hPutStr errHandle+ . withMetadata ts NormalMark FlagTrace flags+ . wrapTextVerbosity flags $ l ++ ": " ++ msg+ where+ flags = verbosityFlags verbosity -- | Useful status messages. --@@ -551,34 +653,35 @@ -- 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+ when (verbosityLevel verbosity >= Normal) $ do+ let h = verbosityChosenOutputHandle verbosity+ flags = verbosityFlags verbosity ts <- getPOSIXTime hPutStr h $- withMetadata ts NormalMark FlagTrace verbosity $- wrapTextVerbosity verbosity $- msg+ withMetadata ts NormalMark FlagTrace flags $+ wrapTextVerbosity flags msg -- | Display a message at 'normal' verbosity level, but without -- wrapping. noticeNoWrap :: Verbosity -> String -> IO () noticeNoWrap verbosity msg = withFrozenCallStack $ do- when (verbosity >= normal) $ do- let h = verbosityHandle verbosity+ when (verbosityLevel verbosity >= Normal) $ do+ let h = verbosityChosenOutputHandle verbosity+ flags = verbosityFlags verbosity ts <- getPOSIXTime- hPutStr h . withMetadata ts NormalMark FlagTrace verbosity $ msg+ hPutStr h . withMetadata ts NormalMark FlagTrace flags $ msg -- | 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+ when (verbosityLevel verbosity >= Normal) $ do+ let h = verbosityChosenOutputHandle verbosity+ flags = verbosityFlags verbosity ts <- getPOSIXTime hPutStr h $- withMetadata ts NormalMark FlagTrace verbosity $- Disp.renderStyle defaultStyle $- msg+ withMetadata ts NormalMark FlagTrace flags $+ Disp.renderStyle defaultStyle msg -- | Display a "setup status message". Prefer using setupMessage' -- if possible.@@ -591,35 +694,35 @@ -- 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+ when (verbosityLevel verbosity >= Verbose) $ do+ let h = verbosityChosenOutputHandle verbosity+ flags = verbosityFlags verbosity ts <- getPOSIXTime hPutStr h $- withMetadata ts NeverMark FlagTrace verbosity $- wrapTextVerbosity verbosity $- msg+ withMetadata ts NeverMark FlagTrace flags $+ wrapTextVerbosity flags msg infoNoWrap :: Verbosity -> String -> IO () infoNoWrap verbosity msg = withFrozenCallStack $- when (verbosity >= verbose) $ do- let h = verbosityHandle verbosity+ when (verbosityLevel verbosity >= Verbose) $ do+ let h = verbosityChosenOutputHandle verbosity+ flags = verbosityFlags verbosity ts <- getPOSIXTime hPutStr h $- withMetadata ts NeverMark FlagTrace verbosity $- msg+ withMetadata ts NeverMark FlagTrace flags 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+ when (verbosityLevel verbosity >= Deafening) $ do+ let h = verbosityChosenOutputHandle verbosity+ flags = verbosityFlags verbosity ts <- getPOSIXTime hPutStr h $- withMetadata ts NeverMark FlagTrace verbosity $- wrapTextVerbosity verbosity $- msg+ withMetadata ts NeverMark FlagTrace flags $+ wrapTextVerbosity flags msg -- ensure that we don't lose output if we segfault/infinite loop hFlush stdout @@ -627,26 +730,27 @@ -- wrapping. Produces better output in some cases. debugNoWrap :: Verbosity -> String -> IO () debugNoWrap verbosity msg = withFrozenCallStack $- when (verbosity >= deafening) $ do- let h = verbosityHandle verbosity+ when (verbosityLevel verbosity >= Deafening) $ do+ let h = verbosityChosenOutputHandle verbosity ts <- getPOSIXTime hPutStr h $- withMetadata ts NeverMark FlagTrace verbosity $- msg+ withMetadata ts NeverMark FlagTrace (verbosityFlags 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+ :: Verbosity+ -> String -- ^ a description of the action we were attempting -> IO () -- ^ the action itself -> IO ()-chattyTry desc action =+chattyTry verbosity desc action = catchIO action $ \exception ->- hPutStrLn stderr $ "Error while " ++ desc ++ ": " ++ show exception+ hPutStrLn (verbosityErrorHandle verbosity) $+ "Error while " ++ desc ++ ": " ++ show exception -- | Run an IO computation, returning @e@ if it raises a "file -- does not exist" error.@@ -660,7 +764,7 @@ -- Helper functions -- | Wraps text unless the @+nowrap@ verbosity flag is active-wrapTextVerbosity :: Verbosity -> String -> String+wrapTextVerbosity :: VerbosityFlags -> String -> String wrapTextVerbosity verb | isVerboseNoWrap verb = withTrailingNewline | otherwise = withTrailingNewline . wrapText@@ -668,7 +772,7 @@ -- | Prepends a timestamp if @+timestamp@ verbosity flag is set -- -- This is used by 'withMetadata'-withTimestamp :: Verbosity -> POSIXTime -> String -> String+withTimestamp :: VerbosityFlags -> POSIXTime -> String -> String withTimestamp v ts msg | isVerboseTimestamp v = msg' | otherwise = msg -- no-op@@ -694,7 +798,7 @@ -- we don't have the ability to interpose on the output. -- -- This is used by 'withMetadata'-withOutputMarker :: Verbosity -> String -> String+withOutputMarker :: VerbosityFlags -> String -> String withOutputMarker v xs | not (isVerboseMarkOutput v) = xs withOutputMarker _ "" = "" -- Minor optimization, don't mark uselessly withOutputMarker _ xs =@@ -713,7 +817,7 @@ go _ "" = "\n" -- | Prepend a call-site and/or call-stack based on Verbosity-withCallStackPrefix :: WithCallStack (TraceWhen -> Verbosity -> String -> String)+withCallStackPrefix :: WithCallStack (TraceWhen -> VerbosityFlags -> String -> String) withCallStackPrefix tracer verbosity s = withFrozenCallStack $ ( if isVerboseCallSite verbosity@@ -745,9 +849,9 @@ -- | 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 :: VerbosityFlags -> TraceWhen -> Maybe String traceWhen _ AlwaysTrace = Just ""-traceWhen v VerboseTrace | v >= verbose = Just ""+traceWhen v VerboseTrace | vLevel v >= Verbose = Just "" traceWhen v FlagTrace | isVerboseCallStack v = Just "----\n" traceWhen _ _ = Nothing @@ -757,7 +861,7 @@ data MarkWhen = AlwaysMark | NormalMark | NeverMark -- | Add all necessary metadata to a logging message-withMetadata :: WithCallStack (POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String)+withMetadata :: WithCallStack (POSIXTime -> MarkWhen -> TraceWhen -> VerbosityFlags -> String -> String) withMetadata ts marker tracer verbosity x = withFrozenCallStack $@@ -780,7 +884,7 @@ $ x -- | Add all necessary metadata to a logging message-exceptionWithMetadata :: CallStack -> POSIXTime -> Verbosity -> String -> String+exceptionWithMetadata :: CallStack -> POSIXTime -> VerbosityFlags -> String -> String exceptionWithMetadata stack ts verbosity x = withTrailingNewline . exceptionWithCallStackPrefix stack verbosity@@ -797,7 +901,7 @@ isMarker _ = True -- | Append a call-site and/or call-stack based on Verbosity-exceptionWithCallStackPrefix :: CallStack -> Verbosity -> String -> String+exceptionWithCallStackPrefix :: CallStack -> VerbosityFlags -> String -> String exceptionWithCallStackPrefix stack verbosity s = s ++ withFrozenCallStack@@ -811,7 +915,7 @@ else "" else "" )- ++ ( if verbosity >= verbose+ ++ ( if vLevel verbosity >= Verbose then prettyCallStack stack ++ "\n" else "" )@@ -853,19 +957,34 @@ -- | 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 =+rawSystemExit :: Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> FilePath -> [String] -> IO ()+rawSystemExit verbosity mbWorkDir path args = withFrozenCallStack $ maybeExit $- rawSystemExitCode verbosity path args+ rawSystemExitCode verbosity mbWorkDir path args Nothing -- | Execute the given command with the given arguments, returning -- the command's exit code.-rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode-rawSystemExitCode verbosity path args =+rawSystemExitCode+ :: Verbosity+ -> Maybe (SymbolicPath CWD (Dir to))+ -> FilePath+ -> [String]+ -> Maybe [(String, String)]+ -> IO ExitCode+rawSystemExitCode verbosity mbWorkDir path args menv = withFrozenCallStack $- rawSystemProc verbosity $- proc path args+ fmap fst $+ rawSystemIOWithEnvAndAction+ verbosity+ path+ args+ (fmap getSymbolicPath mbWorkDir)+ menv+ (\_ _ _ -> return ())+ Nothing+ Nothing+ Nothing -- | Execute the given command with the given arguments, returning -- the command's exit code.@@ -893,7 +1012,7 @@ -> IO (ExitCode, a) rawSystemProcAction verbosity cp action = withFrozenCallStack $ do logCommand verbosity cp- (exitcode, a) <- Process.withCreateProcess cp $ \mStdin mStdout mStderr p -> do+ (exitcode, a) <- compatWithCreateProcess verbosity cp $ \mStdin mStdout mStderr p -> do a <- action mStdin mStdout mStderr exitcode <- Process.waitForProcess p return (exitcode, a)@@ -904,11 +1023,59 @@ debug verbosity $ cmd ++ " returned " ++ show exitcode return (exitcode, a) +-- | A version of 'Process.withCreateProcess' that is careful to not close+-- the handles stored in 'Verbosity'.+compatWithCreateProcess+ :: Verbosity+ -> Process.CreateProcess+ -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> Process.ProcessHandle -> IO a)+ -> IO a+compatWithCreateProcess verbosity cp action =+ Exception.bracket+ create+ Process.cleanupProcess+ (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph)+ where+ -- The 'process' documentation for 'createProcess'/'withCreateProcess'+ -- states:+ --+ -- Note that `Handle`s provided for `std_in`, `std_out`, or `std_err` via the+ -- `UseHandle` constructor will be closed by calling this function.+ --+ -- We don't want that, because we don't want the Verbosity handles being+ -- closed if they are passed to the subprocess, which would prevent+ -- us from continuing logging.+ --+ -- To avoid this, we copy the implementation of 'withCreateProcess' in terms+ -- of 'withCreateProcess_', but with special logic to avoid closing the+ -- verbosity handles.+ create =+ Process.createProcess_ "createProcess" cp+ `Exception.finally` do+ maybeClose (Process.std_in cp)+ maybeClose (Process.std_out cp)+ maybeClose (Process.std_err cp)++ maybeClose :: Process.StdStream -> IO ()+ maybeClose (Process.UseHandle hdl)+ | hdl+ `elem` [ stdin+ , stdout+ , stderr+ , vStdoutHandle (verbosityHandles verbosity)+ , vStderrHandle (verbosityHandles verbosity)+ ] -- Don't close the verbosity handles!+ =+ return ()+ | otherwise =+ hClose hdl+ maybeClose _ = return ()+ -- | 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+fromCreatePipe = fromMaybe (error "fromCreatePipe: Nothing") -- | Execute the given command with the given arguments and -- environment, exiting with the same exit code if the command fails.@@ -918,13 +1085,21 @@ -> [String] -> [(String, String)] -> IO ()-rawSystemExitWithEnv verbosity path args env =+rawSystemExitWithEnv verbosity =+ rawSystemExitWithEnvCwd verbosity Nothing++-- | Like 'rawSystemExitWithEnv', but setting a working directory.+rawSystemExitWithEnvCwd+ :: Verbosity+ -> Maybe (SymbolicPath CWD (Dir to))+ -> FilePath+ -> [String]+ -> [(String, String)]+ -> IO ()+rawSystemExitWithEnvCwd verbosity mbWorkDir path args env = withFrozenCallStack $ maybeExit $- rawSystemProc verbosity $- (proc path args)- { Process.env = Just env- }+ rawSystemExitCode verbosity mbWorkDir path args (Just env) -- | Execute the given command with the given arguments, returning -- the command's exit code.@@ -954,7 +1129,7 @@ args mcwd menv- action+ (\_ _ _ -> action) inp out err@@ -973,11 +1148,12 @@ :: Verbosity -> FilePath -> [String]+ -- ^ arguments -> Maybe FilePath -- ^ New working dir or inherit -> Maybe [(String, String)] -- ^ New environment or inherit- -> IO a+ -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a) -- ^ action to perform after process is created, but before 'waitForProcess'. -> Maybe Handle -- ^ stdin@@ -986,20 +1162,31 @@ -> 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- }- rawSystemProcAction verbosity cp (\_ _ _ -> action)- where- mbToStd :: Maybe Handle -> Process.StdStream- mbToStd = maybe Process.Inherit Process.UseHandle+rawSystemIOWithEnvAndAction verbosity path args mcwd menv action inp out err =+ withFrozenCallStack $ do+ -- If the output/error handle is Nothing, we need to use the corresponding+ -- logging handle stored in 'Verbosity'.+ let+ outHandle =+ case out of+ Just h -> h+ Nothing -> verbosityChosenOutputHandle verbosity+ errHandle =+ case err of+ Just h -> h+ Nothing -> verbosityErrorHandle verbosity + let cp =+ (proc path args)+ { Process.cwd = mcwd+ , Process.env = menv+ , Process.std_in = maybe Process.Inherit Process.UseHandle inp+ , Process.std_out = Process.UseHandle outHandle+ , Process.std_err = Process.UseHandle errHandle+ }++ rawSystemProcAction verbosity cp action+ -- | Execute the given command with the given arguments, returning -- the command's output. Exits if the command exits with error. --@@ -1187,83 +1374,75 @@ -- -- @since 3.4.0.0 findFileCwd- :: Verbosity- -> FilePath- -- ^ cwd- -> [FilePath]- -- ^ relative search location- -> FilePath+ :: forall searchDir allowAbsolute+ . Verbosity+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -- ^ working directory+ -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]+ -- ^ search directories+ -> RelativePath searchDir File -- ^ File Name- -> IO FilePath-findFileCwd verbosity cwd searchPath fileName =+ -> IO (SymbolicPathX allowAbsolute Pkg File)+findFileCwd verbosity mbWorkDir searchPath fileName = findFirstFile- (cwd </>)+ (interpretSymbolicPath mbWorkDir) [ path </> fileName | path <- ordNub searchPath ]- >>= maybe (dieWithException verbosity $ FindFileCwd fileName) return+ >>= maybe (dieWithException verbosity $ FindFile $ getSymbolicPath fileName) return -- | Find a file by looking in a search path. The file path must match exactly. findFileEx- :: Verbosity- -> [FilePath]- -- ^ search locations- -> FilePath+ :: forall searchDir allowAbsolute+ . Verbosity+ -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]+ -- ^ search directories+ -> RelativePath searchDir File -- ^ File Name- -> IO FilePath-findFileEx verbosity searchPath fileName =- findFirstFile- id- [ path </> fileName- | path <- ordNub searchPath- ]- >>= maybe (dieWithException verbosity $ FindFileEx fileName) return+ -> IO (SymbolicPathX allowAbsolute Pkg File)+findFileEx v = findFileCwd v Nothing -- | 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 :: [Suffix]- -> [FilePath]- -> FilePath- -> IO (Maybe FilePath)-findFileWithExtension extensions searchPath baseName =- findFirstFile- id- [ path </> baseName <.> ext- | path <- ordNub searchPath- , Suffix ext <- ordNub extensions- ]+ -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]+ -> RelativePath searchDir File+ -> IO (Maybe (SymbolicPathX allowAbsolute Pkg File))+findFileWithExtension =+ findFileCwdWithExtension Nothing --- | @since 3.4.0.0+-- | Find a file by looking in a search path with one of a list of possible+-- file extensions.+--+-- @since 3.4.0.0 findFileCwdWithExtension- :: FilePath+ :: forall searchDir allowAbsolute+ . Maybe (SymbolicPath CWD (Dir Pkg)) -> [Suffix]- -> [FilePath]- -> FilePath- -> IO (Maybe FilePath)+ -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]+ -> RelativePath searchDir File+ -> IO (Maybe (SymbolicPathX allowAbsolute Pkg File)) findFileCwdWithExtension cwd extensions searchPath baseName =- findFirstFile- (cwd </>)- [ path </> baseName <.> ext- | path <- ordNub searchPath- , Suffix ext <- ordNub extensions- ]+ fmap (uncurry (</>))+ <$> findFileCwdWithExtension' cwd extensions searchPath baseName -- | @since 3.4.0.0 findAllFilesCwdWithExtension- :: FilePath- -- ^ cwd+ :: forall searchDir allowAbsolute+ . Maybe (SymbolicPath CWD (Dir Pkg))+ -- ^ working directory -> [Suffix] -- ^ extensions- -> [FilePath]+ -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] -- ^ relative search locations- -> FilePath+ -> RelativePath searchDir File -- ^ basename- -> IO [FilePath]-findAllFilesCwdWithExtension cwd extensions searchPath basename =+ -> IO [SymbolicPathX allowAbsolute Pkg File]+findAllFilesCwdWithExtension mbWorkDir extensions searchPath basename = findAllFiles- (cwd </>)+ (interpretSymbolicPath mbWorkDir) [ path </> basename <.> ext | path <- ordNub searchPath , Suffix ext <- ordNub extensions@@ -1271,31 +1450,42 @@ findAllFilesWithExtension :: [Suffix]- -> [FilePath]- -> FilePath- -> IO [FilePath]-findAllFilesWithExtension extensions searchPath basename =- findAllFiles- id- [ path </> basename <.> ext- | path <- ordNub searchPath- , Suffix ext <- ordNub extensions- ]+ -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]+ -> RelativePath searchDir File+ -> IO [SymbolicPathX allowAbsolute Pkg File]+findAllFilesWithExtension =+ findAllFilesCwdWithExtension Nothing -- | 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' :: [Suffix]- -> [FilePath]- -> FilePath- -> IO (Maybe (FilePath, FilePath))-findFileWithExtension' extensions searchPath baseName =+ -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]+ -> RelativePath searchDir File+ -> IO (Maybe (SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File))+findFileWithExtension' =+ findFileCwdWithExtension' Nothing++-- | Like 'findFileCwdWithExtension' but returns which element of the search path+-- the file was found in, and the file path relative to that base directory.+findFileCwdWithExtension'+ :: forall searchDir allowAbsolute+ . Maybe (SymbolicPath CWD (Dir Pkg))+ -> [Suffix]+ -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]+ -> RelativePath searchDir File+ -> IO (Maybe (SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File))+findFileCwdWithExtension' cwd extensions searchPath baseName = findFirstFile- (uncurry (</>))+ (uncurry mkPath) [ (path, baseName <.> ext) | path <- ordNub searchPath , Suffix ext <- ordNub extensions ]+ where+ mkPath :: SymbolicPathX allowAbsolute Pkg (Dir searchDir) -> RelativePath searchDir File -> FilePath+ mkPath base file =+ interpretSymbolicPath cwd (base </> file) findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a) findFirstFile file = findFirst@@ -1314,39 +1504,79 @@ -- -- As 'findModuleFile' but for a list of module names. findModuleFilesEx- :: Verbosity- -> [FilePath]+ :: forall searchDir allowAbsolute+ . Verbosity+ -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] -- ^ build prefix (location of objects) -> [Suffix] -- ^ search suffixes -> [ModuleName] -- ^ modules- -> IO [(FilePath, FilePath)]+ -> IO [(SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File)] findModuleFilesEx verbosity searchPath extensions moduleNames = traverse (findModuleFileEx verbosity searchPath extensions) moduleNames +-- | Finds the files corresponding to a list of Haskell module names.+--+-- As 'findModuleFileCwd' but for a list of module names.+findModuleFilesCwd+ :: forall searchDir allowAbsolute+ . Verbosity+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]+ -- ^ build prefix (location of objects)+ -> [Suffix]+ -- ^ search suffixes+ -> [ModuleName]+ -- ^ modules+ -> IO [(SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File)]+findModuleFilesCwd verbosity cwd searchPath extensions moduleNames =+ traverse (findModuleFileCwd verbosity cwd searchPath extensions) moduleNames+ -- | Find the file corresponding to a Haskell module name. -- -- 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]+ :: forall searchDir allowAbsolute+ . Verbosity+ -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] -- ^ build prefix (location of objects) -> [Suffix] -- ^ search suffixes -> ModuleName -- ^ module- -> IO (FilePath, FilePath)-findModuleFileEx verbosity searchPath extensions mod_name =- maybe notFound return- =<< findFileWithExtension'+ -> IO (SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File)+findModuleFileEx verbosity =+ findModuleFileCwd verbosity Nothing++-- | Find the file corresponding to a Haskell module name.+--+-- This is similar to 'findFileCwdWithExtension'' but specialised to a module+-- name. The function fails if the file corresponding to the module is missing.+findModuleFileCwd+ :: forall searchDir allowAbsolute+ . Verbosity+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]+ -- ^ build prefix (location of objects)+ -> [Suffix]+ -- ^ search suffixes+ -> ModuleName+ -- ^ module+ -> IO (SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File)+findModuleFileCwd verbosity cwd searchPath extensions mod_name = do+ mbRes <-+ findFileCwdWithExtension'+ cwd extensions searchPath- (ModuleName.toFilePath mod_name)- where- notFound =- dieWithException verbosity $ FindModuleFileEx mod_name extensions searchPath+ (makeRelativePathEx $ ModuleName.toFilePath mod_name)+ case mbRes of+ Nothing ->+ dieWithException verbosity $+ FindModuleFileEx mod_name extensions (map getSymbolicPath searchPath)+ Just res -> return res -- | List all the files in a directory and all subdirectories. --@@ -1359,7 +1589,7 @@ recurseDirectories :: [FilePath] -> IO [FilePath] recurseDirectories [] = return [] recurseDirectories (dir : dirs) = unsafeInterleaveIO $ do- (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir </> dir)+ (files, dirs') <- collect [] [] =<< listDirectory (topdir </> dir) files' <- recurseDirectories (dirs' ++ dirs) return (files ++ files') where@@ -1368,9 +1598,6 @@ ( 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)@@ -1378,10 +1605,6 @@ then collect files (dirEntry : dirs') entries else collect (dirEntry : files) dirs' entries - ignore ['.'] = True- ignore ['.', '.'] = True- ignore _ = False- ------------------------ -- Environment variables @@ -1451,7 +1674,7 @@ parents = reverse . scanl1 (</>) . splitDirectories . normalise createDirs [] = return ()- createDirs (dir : []) = createDir dir throwIO+ createDirs [dir] = createDir dir throwIO createDirs (dir : dirs) = createDir dir $ \_ -> do createDirs dirs@@ -1514,17 +1737,40 @@ 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 -- | Given a relative path to a file, copy it to the given directory, preserving -- the relative path and creating the parent directories if needed.-copyFileTo :: Verbosity -> FilePath -> FilePath -> IO ()-copyFileTo verbosity dir file = withFrozenCallStack $ do- let targetFile = dir </> file+copyFileTo+ :: Verbosity+ -> FilePath+ -> FilePath+ -> IO ()+copyFileTo verbosity dir file =+ withFrozenCallStack $+ copyFileToCwd+ verbosity+ Nothing+ (makeSymbolicPath dir)+ (makeRelativePathEx file)++-- | Given a relative path to a file, copy it to the given directory, preserving+-- the relative path and creating the parent directories if needed.+copyFileToCwd+ :: Verbosity+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -> SymbolicPath Pkg (Dir target)+ -> RelativePath Pkg File+ -> IO ()+copyFileToCwd verbosity mbWorkDir dir file = withFrozenCallStack $ do+ let targetFile = i $ dir </> unsafeCoerceSymbolicPath file createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile)- installOrdinaryFile verbosity file targetFile+ installOrdinaryFile verbosity (i file) targetFile+ where+ i :: SymbolicPathX allowAbs Pkg to -> FilePath+ i = interpretSymbolicPath mbWorkDir -- | Common implementation of 'copyFiles', 'installOrdinaryFiles', -- 'installExecutableFiles' and 'installMaybeExecutableFiles'.@@ -1570,6 +1816,26 @@ copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () copyFiles v fp fs = withFrozenCallStack (copyFilesWith copyFileVerbose v fp fs) +-- | A robust helper to remove an existing file, which does not throw+-- an exception if such file never existed, thus akin to removePathForcibly.+removeFileForcibly :: FilePath -> IO ()+removeFileForcibly fp = catch (removeFile fp) $ \case+ e+ -- If the file never existed in the first place, we are golden.+ | isDoesNotExistError e -> pure ()+ -- If we got a permission error, chances are that it's a read-only+ -- file on Windows. Removing read-only attribute ourselves requires+ -- reaching out for internal API, so instead of it we call 'removePathForcibly',+ -- which is a bit of overkill for a single file, but well.+ | isPermissionError e -> removePathForcibly fp+ -- If device is busy, wait 1ms and give it another go.+ -- EBUSY from unlink(2) is mapped to UnsatisfiedConstraints.+ | ioeGetErrorType e == GHC.UnsatisfiedConstraints -> do+ threadDelay 1000+ removeFile fp+ -- Else we give up.+ | otherwise -> throwIO e+ -- | This is like 'copyFiles' but uses 'installOrdinaryFile'. installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () installOrdinaryFiles v fp fs = withFrozenCallStack (copyFilesWith installOrdinaryFile v fp fs)@@ -1637,53 +1903,99 @@ defaultTempFileOptions :: TempFileOptions defaultTempFileOptions = TempFileOptions{optKeepTempFiles = False} --- | Use a temporary filename that doesn't already exist.+-- | Use a temporary filename that doesn't already exist withTempFile- :: FilePath- -- ^ Temp dir to create the file in- -> String+ :: String -- ^ File name template. See 'openTempFile'. -> (FilePath -> Handle -> IO a) -> IO a-withTempFile tmpDir template action =- withTempFileEx defaultTempFileOptions tmpDir template action+withTempFile template f = withFrozenCallStack $+ withTempFileCwd template $+ \fp h -> f (getSymbolicPath fp) h +-- | Use a temporary filename that doesn't already exist.+withTempFileCwd+ :: String+ -- ^ File name template. See 'openTempFile'.+ -> (SymbolicPath Pkg File -> Handle -> IO a)+ -> IO a+withTempFileCwd = withFrozenCallStack $ withTempFileEx defaultTempFileOptions+ -- | A version of 'withTempFile' that additionally takes a 'TempFileOptions' -- argument. withTempFileEx- :: TempFileOptions- -> FilePath- -- ^ Temp dir to create the file in+ :: forall a+ . TempFileOptions -> String -- ^ File name template. See 'openTempFile'.- -> (FilePath -> Handle -> IO a)+ -> (SymbolicPath Pkg File -> 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- )- (withLexicalCallStack (\x -> uncurry action x))+withTempFileEx opts template action = do+ tmp <- getTemporaryDirectory+ withFrozenCallStack $+ Exception.bracket+ (openTempFile tmp template)+ ( \(name, handle) -> do+ hClose handle+ unless (optKeepTempFiles opts) $+ handleDoesNotExist () $+ removeFile name+ )+ (withLexicalCallStack (\(fn, h) -> action (mkRelToPkg tmp fn) h))+ where+ mkRelToPkg :: FilePath -> FilePath -> SymbolicPath Pkg File+ mkRelToPkg tmp fp =+ makeSymbolicPath tmp </> makeRelativePathEx (takeFileName fp) +-- 'openTempFile' returns a path of the form @i tmpDir </> fn@, but we+-- want 'withTempFileEx' to return @tmpDir </> fn@. So we split off+-- the filename and add back the (un-interpreted) directory.+-- This assumes 'openTempFile' returns a filepath of the form+-- @inputDir </> fn@, where @fn@ does not contain any path separators.+ -- | Create and use a temporary directory. -- -- Creates a new temporary directory inside the given directory, making use -- of the template. The temp directory is deleted after use. For example: ----- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ...+-- > withTempDirectory "src" "sdist." $ \tmpDir -> do ... -- -- 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 =+withTempDirectory+ :: FilePath+ -> String+ -> (FilePath -> IO a)+ -> IO a+withTempDirectory targetDir template f = withFrozenCallStack $- withTempDirectoryEx- verbosity+ withTempDirectoryCwd+ Nothing+ (makeSymbolicPath targetDir)+ template+ (f . getSymbolicPath)++-- | Create and use a temporary directory.+--+-- Creates a new temporary directory inside the given directory, making use+-- of the template. The temp directory is deleted after use. For example:+--+-- > withTempDirectory "src" "sdist." $ \tmpDir -> do ...+--+-- The @tmpDir@ will be a new subdirectory of the given directory, e.g.+-- @src/sdist.342@.+withTempDirectoryCwd+ :: Maybe (SymbolicPath CWD (Dir Pkg))+ -- ^ Working directory+ -> SymbolicPath Pkg (Dir tmpDir1)+ -> String+ -> (SymbolicPath Pkg (Dir tmpDir2) -> IO a)+ -> IO a+withTempDirectoryCwd mbWorkDir targetDir template f =+ withFrozenCallStack $+ withTempDirectoryCwdEx defaultTempFileOptions+ mbWorkDir targetDir template (withLexicalCallStack (\x -> f x))@@ -1691,21 +2003,38 @@ -- | A version of 'withTempDirectory' that additionally takes a -- 'TempFileOptions' argument. withTempDirectoryEx- :: Verbosity- -> TempFileOptions+ :: TempFileOptions -> FilePath -> String -> (FilePath -> IO a) -> IO a-withTempDirectoryEx _verbosity opts targetDir template f =+withTempDirectoryEx opts targetDir template f = withFrozenCallStack $+ withTempDirectoryCwdEx opts Nothing (makeSymbolicPath targetDir) template $+ \fp -> f (getSymbolicPath fp)++-- | A version of 'withTempDirectoryCwd' that additionally takes a+-- 'TempFileOptions' argument.+withTempDirectoryCwdEx+ :: forall a tmpDir1 tmpDir2+ . TempFileOptions+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -- ^ Working directory+ -> SymbolicPath Pkg (Dir tmpDir1)+ -> String+ -> (SymbolicPath Pkg (Dir tmpDir2) -> IO a)+ -> IO a+withTempDirectoryCwdEx opts mbWorkDir targetDir template f =+ withFrozenCallStack $ Exception.bracket- (createTempDirectory targetDir template)- ( unless (optKeepTempFiles opts)- . handleDoesNotExist ()- . removeDirectoryRecursive+ (createTempDirectory (i targetDir) template)+ ( \tmpDirRelPath ->+ unless (optKeepTempFiles opts) $+ removePathForcibly (i targetDir </> tmpDirRelPath) )- (withLexicalCallStack (\x -> f x))+ (withLexicalCallStack (\tmpDirRelPath -> f $ targetDir </> makeRelativePathEx tmpDirRelPath))+ where+ i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path ----------------------------------- -- Safely reading and writing files@@ -1737,12 +2066,6 @@ | otherwise = ioError e --- | The path name that represents the current directory.--- In Unix, it's @\".\"@, but this is system-specific.--- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.)-currentDir :: FilePath-currentDir = "."- shortRelativePath :: FilePath -> FilePath -> FilePath shortRelativePath from to = case dropCommonPrefix (splitDirectories from) (splitDirectories to) of@@ -1781,6 +2104,13 @@ -- Possible improvement: on Windows, read the list of extensions from the -- PATHEXT environment variable. By default PATHEXT is ".com; .exe; .bat; -- .cmd".+ --+ -- See also #10179.+ --+ -- Also we cannot actually run @.bat@ files as we do now, because of+ -- https://github.com/haskell/process/issues/140. If we detect one of those,+ -- we should record that the program is a script and run a @Process.shell@ instead+ -- of a @Process.proc@. (_, Windows) -> ["", "exe"] (_, Ghcjs) -> ["", "exe"] (Wasm32, _) -> ["", "wasm"]@@ -1792,71 +2122,61 @@ -- ------------------------------------------------------------ --- | Package description file (/pkgname/@.cabal@)-defaultPackageDesc :: Verbosity -> IO FilePath-defaultPackageDesc verbosity = tryFindPackageDesc verbosity currentDir+-- | Package description file (/pkgname/@.cabal@) in the current+-- working directory.+defaultPackageDescCwd :: Verbosity -> IO (RelativePath Pkg File)+defaultPackageDescCwd verbosity = tryFindPackageDesc verbosity Nothing -- | Find a package description file in the given directory. Looks for -- @.cabal@ files. findPackageDesc- :: FilePath- -- ^ Where to look- -> IO (Either CabalException FilePath)- -- ^ <pkgname>.cabal-findPackageDesc = findPackageDescCwd "."---- | @since 3.4.0.0-findPackageDescCwd- :: FilePath- -- ^ project root- -> FilePath- -- ^ relative directory- -> IO (Either CabalException FilePath)- -- ^ <pkgname>.cabal relative to the project root-findPackageDescCwd cwd dir =+ :: Maybe (SymbolicPath CWD (Dir Pkg))+ -- ^ package directory+ -> IO (Either CabalException (RelativePath Pkg File))+findPackageDesc mbPkgDir = do- files <- getDirectoryContents (cwd </> dir)+ let pkgDir = maybe "." getSymbolicPath mbPkgDir+ files <- listDirectory pkgDir -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal -- file we filter to exclude dirs and null base file names: cabalFiles <- filterM- (doesFileExist . snd)- [ (dir </> file, cwd </> dir </> file)+ (doesFileExist . uncurry (</>))+ [ (pkgDir, file) | file <- files , let (name, ext) = splitExtension file , not (null name) && ext == ".cabal" ]- case map fst cabalFiles of+ case map snd cabalFiles of [] -> return (Left NoDesc)- [cabalFile] -> return (Right cabalFile)+ [cabalFile] -> return (Right $ makeRelativePathEx cabalFile) multiple -> return (Left $ MultiDesc multiple) -- | Like 'findPackageDesc', but calls 'die' in case of error.-tryFindPackageDesc :: Verbosity -> FilePath -> IO FilePath+tryFindPackageDesc+ :: Verbosity+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -- ^ directory in which to look+ -> IO (RelativePath Pkg File) tryFindPackageDesc verbosity dir = either (dieWithException verbosity) return =<< findPackageDesc dir --- | Like 'findPackageDescCwd', but calls 'die' in case of error.------ @since 3.4.0.0-tryFindPackageDescCwd :: Verbosity -> FilePath -> FilePath -> IO FilePath-tryFindPackageDescCwd verbosity cwd dir =- either (dieWithException verbosity) return =<< findPackageDescCwd cwd dir- -- | Find auxiliary package information in the given directory. -- Looks for @.buildinfo@ files. findHookedPackageDesc :: Verbosity- -> FilePath+ -> Maybe (SymbolicPath CWD (Dir Pkg))+ -- ^ Working directory+ -> SymbolicPath Pkg (Dir Build) -- ^ Directory to search- -> IO (Maybe FilePath)+ -> IO (Maybe (SymbolicPath Pkg File)) -- ^ /dir/@\/@/pkgname/@.buildinfo@, if present-findHookedPackageDesc verbosity dir = do- files <- getDirectoryContents dir+findHookedPackageDesc verbosity mbWorkDir dir = do+ files <- listDirectory $ interpretSymbolicPath mbWorkDir dir buildInfoFiles <- filterM- doesFileExist- [ dir </> file+ (doesFileExist . interpretSymbolicPath mbWorkDir)+ [ dir </> makeRelativePathEx file | file <- files , let (name, ext) = splitExtension file , not (null name) && ext == buildInfoExt@@ -1868,3 +2188,10 @@ buildInfoExt :: String buildInfoExt = ".buildinfo"++-- | @stripCommonPrefix xs ys@ gives you @ys@ without the common prefix with @xs@.+stripCommonPrefix :: String -> String -> String+stripCommonPrefix (x : xs) (y : ys)+ | x == y = stripCommonPrefix xs ys+ | otherwise = y : ys+stripCommonPrefix _ ys = ys
src/Distribution/Types/ComponentLocalBuildInfo.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} @@ -6,6 +5,8 @@ ( ComponentLocalBuildInfo (..) , componentIsIndefinite , maybeComponentInstantiatedWith+ , maybeComponentCompatPackageKey+ , maybeComponentExposedModules ) where import Distribution.Compat.Prelude@@ -108,7 +109,7 @@ , componentExeDeps :: [UnitId] , componentInternalDeps :: [UnitId] }- deriving (Generic, Read, Show, Typeable)+ deriving (Generic, Read, Show) instance Binary ComponentLocalBuildInfo instance Structured ComponentLocalBuildInfo@@ -126,3 +127,13 @@ maybeComponentInstantiatedWith LibComponentLocalBuildInfo{componentInstantiatedWith = insts} = Just insts maybeComponentInstantiatedWith _ = Nothing++maybeComponentCompatPackageKey :: ComponentLocalBuildInfo -> Maybe String+maybeComponentCompatPackageKey+ LibComponentLocalBuildInfo{componentCompatPackageKey = key} = Just key+maybeComponentCompatPackageKey _ = Nothing++maybeComponentExposedModules :: ComponentLocalBuildInfo -> Maybe [Installed.ExposedModule]+maybeComponentExposedModules+ LibComponentLocalBuildInfo{componentExposedModules = exposed} = Just exposed+maybeComponentExposedModules _ = Nothing
src/Distribution/Types/DumpBuildInfo.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module Distribution.Types.DumpBuildInfo@@ -6,11 +5,22 @@ ) where import Distribution.Compat.Prelude+import Distribution.Parsec data DumpBuildInfo = NoDumpBuildInfo | DumpBuildInfo- deriving (Read, Show, Eq, Ord, Enum, Bounded, Generic, Typeable)+ deriving (Read, Show, Eq, Ord, Enum, Bounded, Generic) instance Binary DumpBuildInfo+instance NFData DumpBuildInfo instance Structured DumpBuildInfo++instance Parsec DumpBuildInfo where+ parsec = parsecDumpBuildInfo++parsecDumpBuildInfo :: CabalParsing m => m DumpBuildInfo+parsecDumpBuildInfo = boolToDumpBuildInfo <$> parsec++boolToDumpBuildInfo :: Bool -> DumpBuildInfo+boolToDumpBuildInfo bool = if bool then DumpBuildInfo else NoDumpBuildInfo
src/Distribution/Types/GivenComponent.hs view
@@ -1,14 +1,15 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module Distribution.Types.GivenComponent ( GivenComponent (..)+ , PromisedComponent (..) ) where import Distribution.Compat.Prelude import Distribution.Types.ComponentId import Distribution.Types.LibraryName+import Distribution.Types.PackageId import Distribution.Types.PackageName -- | A 'GivenComponent' represents a library depended on and explicitly@@ -23,7 +24,24 @@ -- only, not for any component , givenComponentId :: ComponentId }- deriving (Generic, Read, Show, Eq, Typeable)+ deriving (Generic, Read, Show, Eq) instance Binary GivenComponent instance Structured GivenComponent++-- | A 'PromisedComponent' represents a promised library depended on and explicitly+-- specified by the user/client with @--promised-dependency@+--+-- It enables Cabal to know which 'ComponentId' to associate with a library+--+-- @since 3.14.0.0+data PromisedComponent = PromisedComponent+ { promisedComponentPackage :: PackageId+ , promisedComponentName :: LibraryName -- --dependency is for libraries+ -- only, not for any component+ , promisedComponentId :: ComponentId+ }+ deriving (Generic, Read, Show, Eq)++instance Binary PromisedComponent+instance Structured PromisedComponent
src/Distribution/Types/LocalBuildConfig.hs view
@@ -1,8 +1,7 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -21,9 +20,9 @@ import Distribution.Compat.Prelude import Prelude () -import Distribution.Types.ComponentId import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.ComponentRequestedSpec+import Distribution.Types.GivenComponent import Distribution.Types.PackageDescription import Distribution.Types.UnitId @@ -36,9 +35,10 @@ , substPathTemplate ) import Distribution.Simple.PackageIndex-import Distribution.Simple.Program+import Distribution.Simple.Program.Db (ProgramDb) import Distribution.Simple.Setup.Config import Distribution.System+import Distribution.Utils.Path import Distribution.Compat.Graph (Graph) @@ -57,7 +57,7 @@ -- ^ The compiler we're building with , hostPlatform :: Platform -- ^ The platform we're building for- , pkgDescrFile :: Maybe FilePath+ , pkgDescrFile :: Maybe (SymbolicPath Pkg File) -- ^ the filename containing the .cabal file, if available , localPkgDescr :: PackageDescription -- ^ WARNING WARNING WARNING Be VERY careful about using@@ -99,7 +99,7 @@ -- ^ A map from component name to all matching -- components. These coincide with 'componentGraph' -- There may be more than one matching component because of backpack instantiations- , promisedPkgs :: Map (PackageName, ComponentName) ComponentId+ , promisedPkgs :: Map (PackageName, ComponentName) PromisedComponent -- ^ 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@@ -149,11 +149,15 @@ { withVanillaLib :: Bool -- ^ Whether to build normal libs. , withProfLib :: Bool+ -- ^ Whether to build normal libs.+ , withProfLibShared :: 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)+ , withBytecodeLib :: Bool+ -- ^ Whether to build bytecode versions of libs , withDynExe :: Bool -- ^ Whether to link executables dynamically , withFullyStaticExe :: Bool@@ -201,26 +205,28 @@ buildOptionsConfigFlags :: BuildOptions -> ConfigFlags buildOptionsConfigFlags (BuildOptions{..}) = mempty- { configVanillaLib = toFlag $ withVanillaLib- , configSharedLib = toFlag $ withSharedLib- , configStaticLib = toFlag $ withStaticLib- , configDynExe = toFlag $ withDynExe- , configFullyStaticExe = toFlag $ withFullyStaticExe- , configGHCiLib = toFlag $ withGHCiLib- , configProfExe = toFlag $ withProfExe- , configProfLib = toFlag $ withProfLib+ { configVanillaLib = toFlag withVanillaLib+ , configSharedLib = toFlag withSharedLib+ , configStaticLib = toFlag withStaticLib+ , configBytecodeLib = toFlag withBytecodeLib+ , configDynExe = toFlag withDynExe+ , configFullyStaticExe = toFlag withFullyStaticExe+ , configGHCiLib = toFlag withGHCiLib+ , configProfExe = toFlag withProfExe+ , configProfLib = toFlag withProfLib+ , configProfShared = toFlag withProfLibShared , configProf = mempty , -- configProfDetail is for exe+lib, but overridden by configProfLibDetail -- so we specify both so we can specify independently- configProfDetail = toFlag $ withProfExeDetail- , configProfLibDetail = toFlag $ withProfLibDetail- , configCoverage = toFlag $ exeCoverage+ configProfDetail = toFlag withProfExeDetail+ , configProfLibDetail = toFlag withProfLibDetail+ , configCoverage = toFlag exeCoverage , configLibCoverage = mempty- , configRelocatable = toFlag $ relocatable- , configOptimization = toFlag $ withOptimization- , configSplitSections = toFlag $ splitSections- , configSplitObjs = toFlag $ splitObjs- , configStripExes = toFlag $ stripExes- , configStripLibs = toFlag $ stripLibs- , configDebugInfo = toFlag $ withDebugInfo+ , configRelocatable = toFlag relocatable+ , configOptimization = toFlag withOptimization+ , configSplitSections = toFlag splitSections+ , configSplitObjs = toFlag splitObjs+ , configStripExes = toFlag stripExes+ , configStripLibs = toFlag stripLibs+ , configDebugInfo = toFlag withDebugInfo }
src/Distribution/Types/LocalBuildInfo.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-}@@ -27,11 +27,13 @@ , withPackageDB , withVanillaLib , withProfLib- , withSharedLib- , withStaticLib+ , withProfLibShared , withDynExe , withFullyStaticExe , withProfExe+ , withSharedLib+ , withStaticLib+ , withBytecodeLib , withProfLibDetail , withProfExeDetail , withOptimization@@ -55,8 +57,9 @@ , localPackage , buildDir , buildDirPBD- , configFlagsBuildDir- , cabalFilePath+ , setupFlagsBuildDir+ , distPrefLBI+ , packageRoot , progPrefix , progSuffix @@ -80,6 +83,7 @@ , neededTargetsInBuildOrder' , withNeededTargetsInBuildOrder' , testCoverage+ , buildWays -- * Functions you SHOULD NOT USE (yet), but are defined here to @@ -99,14 +103,18 @@ import Distribution.Types.ComponentId import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.ComponentRequestedSpec+import Distribution.Types.GivenComponent import qualified Distribution.Types.LocalBuildConfig as LBC import Distribution.Types.PackageDescription import Distribution.Types.PackageId import Distribution.Types.TargetInfo import Distribution.Types.UnitId +import Distribution.Utils.Path+ import Distribution.PackageDescription import Distribution.Pretty+import Distribution.Simple.BuildWay import Distribution.Simple.Compiler import Distribution.Simple.Flag import Distribution.Simple.InstallDirs hiding@@ -116,14 +124,16 @@ ) import Distribution.Simple.PackageIndex import Distribution.Simple.Program+import Distribution.Simple.Setup.Common import Distribution.Simple.Setup.Config import Distribution.System import qualified Data.Map as Map import Distribution.Compat.Graph (Graph) import qualified Distribution.Compat.Graph as Graph-import System.FilePath ((</>)) +import qualified System.FilePath as FilePath (takeDirectory)+ -- | Data cached after configuration step. See also -- 'Distribution.Simple.Setup.ConfigFlags'. data LocalBuildInfo = NewLocalBuildInfo@@ -134,7 +144,7 @@ -- ^ Information about a package configuration -- that can be modified by the user at configuration time. }- deriving (Generic, Read, Show, Typeable)+ deriving (Generic, Read, Show) {-# COMPLETE LocalBuildInfo #-} @@ -148,10 +158,10 @@ -> InstallDirTemplates -> Compiler -> Platform- -> Maybe FilePath+ -> Maybe (SymbolicPath Pkg File) -> Graph ComponentLocalBuildInfo -> Map ComponentName [ComponentLocalBuildInfo]- -> Map (PackageName, ComponentName) ComponentId+ -> Map (PackageName, ComponentName) PromisedComponent -> InstalledPackageIndex -> PackageDescription -> ProgramDb@@ -163,6 +173,8 @@ -> Bool -> Bool -> Bool+ -> Bool+ -> Bool -> ProfDetailLevel -> ProfDetailLevel -> OptimisationLevel@@ -195,8 +207,10 @@ , withPackageDB , withVanillaLib , withProfLib+ , withProfLibShared , withSharedLib , withStaticLib+ , withBytecodeLib , withDynExe , withFullyStaticExe , withProfExe@@ -246,8 +260,10 @@ LBC.BuildOptions { withVanillaLib , withProfLib+ , withProfLibShared , withSharedLib , withStaticLib+ , withBytecodeLib , withDynExe , withFullyStaticExe , withProfExe@@ -273,21 +289,32 @@ ------------------------------------------------------------------------------- -- Accessor functions -buildDir :: LocalBuildInfo -> FilePath+buildDir :: LocalBuildInfo -> SymbolicPath Pkg (Dir Build) buildDir lbi = buildDirPBD $ LBC.packageBuildDescr $ localBuildDescr lbi -buildDirPBD :: LBC.PackageBuildDescr -> FilePath+buildDirPBD :: LBC.PackageBuildDescr -> SymbolicPath Pkg (Dir Build) buildDirPBD (LBC.PackageBuildDescr{configFlags = cfg}) =- configFlagsBuildDir cfg+ setupFlagsBuildDir $ configCommonFlags cfg -configFlagsBuildDir :: ConfigFlags -> FilePath-configFlagsBuildDir cfg = fromFlag (configDistPref cfg) </> "build"+setupFlagsBuildDir :: CommonSetupFlags -> SymbolicPath Pkg (Dir Build)+setupFlagsBuildDir cfg = fromFlag (setupDistPref cfg) </> makeRelativePathEx "build" -cabalFilePath :: LocalBuildInfo -> Maybe FilePath-cabalFilePath (LocalBuildInfo{configFlags = cfg}) =- flagToMaybe (configCabalFilePath cfg)+distPrefLBI :: LocalBuildInfo -> SymbolicPath Pkg (Dir Dist)+distPrefLBI = fromFlag . setupDistPref . configCommonFlags . LBC.configFlags . LBC.packageBuildDescr . localBuildDescr +-- | The (relative or absolute) path to the package root, based on+--+-- - the working directory flag+-- - the @.cabal@ path+packageRoot :: CommonSetupFlags -> FilePath+packageRoot cfg =+ case flagToMaybe (setupCabalFilePath cfg) of+ Just cabalPath -> FilePath.takeDirectory $ interpretSymbolicPath mbWorkDir cabalPath+ Nothing -> maybe "." getSymbolicPath mbWorkDir+ where+ mbWorkDir = flagToMaybe $ setupWorkingDir cfg+ progPrefix, progSuffix :: LocalBuildInfo -> PathTemplate progPrefix (LocalBuildInfo{configFlags = cfg}) = fromFlag $ configProgPrefix cfg@@ -366,9 +393,7 @@ -- In the presence of Backpack there may be more than one! componentNameCLBIs :: LocalBuildInfo -> ComponentName -> [ComponentLocalBuildInfo] componentNameCLBIs (LocalBuildInfo{componentNameMap = comps}) cname =- case Map.lookup cname comps of- Just clbis -> clbis- Nothing -> []+ Map.findWithDefault [] cname comps -- TODO: Maybe cache topsort (Graph can do this) @@ -411,6 +436,49 @@ testCoverage :: LocalBuildInfo -> Bool testCoverage (LocalBuildInfo{exeCoverage = exes, libCoverage = libs}) = exes && libs++-- | Returns a list of ways, in the order which they should be built, and the+-- way we build executable and foreign library components.+--+-- Ideally all this info should be fixed at configure time and not dependent on+-- additional info but `LocalBuildInfo` is per package (not per component) so it's+-- currently not possible to configure components to be built in certain ways.+buildWays :: LocalBuildInfo -> (Bool -> [BuildWay], Bool -> BuildWay, BuildWay)+buildWays lbi =+ let+ -- enable-library-profiling (enable (static profiling way)) .p_o+ -- enable-shared (enabled dynamic way) .dyn_o+ -- enable-profiling-shared (enable dynamic profilng way) .p_dyn_o+ -- enable-library-vanilla (enable vanilla way) .o+ --+ -- enable-executable-dynamic => build dynamic executables+ -- => --enable-profiling + --enable-executable-dynamic => build dynamic profiled executables+ -- => --enable-profiling => build vanilla profiled executables++ wantedLibWays is_indef =+ [ProfDynWay | withProfLibShared lbi && not is_indef]+ <> [ProfWay | withProfLib lbi]+ -- I don't see why we shouldn't build with dynamic-- indefinite components.+ <> [DynWay | withSharedLib lbi && not is_indef]+ -- MP: Ideally we should have `BuildOptions` on a per component basis, in+ -- which case this `is_indef` check could be moved to configure time.+ <> [StaticWay | withVanillaLib lbi || withStaticLib lbi]++ wantedFLibWay is_dyn_flib =+ case (is_dyn_flib, withProfExe lbi) of+ (True, True) -> ProfDynWay+ (False, True) -> ProfWay+ (True, False) -> DynWay+ (False, False) -> StaticWay++ wantedExeWay =+ case (withDynExe lbi, withProfExe lbi) of+ (True, True) -> ProfDynWay+ (True, False) -> DynWay+ (False, True) -> ProfWay+ (False, False) -> StaticWay+ in+ (wantedLibWays, wantedFLibWay, wantedExeWay) ------------------------------------------------------------------------------- -- Stub functions to prevent someone from accidentally defining them
src/Distribution/Types/ParStrat.hs view
@@ -1,5 +1,7 @@ module Distribution.Types.ParStrat where +import Distribution.Compat.Prelude+ -- | How to control parallelism, e.g. a fixed number of jobs or by using a system semaphore. data ParStratX sem = -- | Compile in parallel with the given number of jobs (`-jN` or `-j`).@@ -9,6 +11,11 @@ | -- | No parallelism (neither `-jN` nor `--semaphore`, but could be `-j1`). Serial deriving (Show)++instance NFData sem => NFData (ParStratX sem) where+ rnf (NumJobs m) = rnf m+ rnf (UseSem s) = rnf s+ rnf Serial = () -- | Used by Cabal to indicate that we want to use this specific semaphore (created by cabal-install) type ParStrat = ParStratX String
src/Distribution/Utils/IOData.hs view
@@ -80,7 +80,7 @@ -- | 'IOData' Wrapper for 'System.IO.hPutStr' and 'System.IO.hClose' ----- This is the dual operation ot 'hGetIODataContents',+-- This is the dual operation to 'hGetIODataContents', -- and consequently the handle is closed with `hClose`. -- -- /Note:/ this performs lazy-IO.
src/Distribution/Utils/LogProgress.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE Rank2Types #-} module Distribution.Utils.LogProgress@@ -17,10 +16,11 @@ import Distribution.Simple.Utils import Distribution.Utils.Progress import Distribution.Verbosity+import System.IO (hFlush, hPutStr, hPutStrLn) import Text.PrettyPrint type CtxMsg = Doc-type LogMsg = Doc+data LogMsg = WarnMsg Doc | InfoMsg Doc type ErrMsg = Doc data LogEnv = LogEnv@@ -55,25 +55,36 @@ , le_context = [] } step_fn :: LogMsg -> IO a -> IO a- step_fn doc go = do- putStrLn (render doc)+ step_fn (WarnMsg doc) go = do+ -- Log the warning to the stderr handle, but flush the stdout handle first,+ -- to prevent interleaving (see Distribution.Simple.Utils.warnMessage).+ let h = verbosityErrorHandle verbosity+ flags = verbosityFlags verbosity+ hFlush (verbosityChosenOutputHandle verbosity)+ hPutStr h $ withOutputMarker flags (render doc ++ "\n") go- fail_fn :: Doc -> IO a+ step_fn (InfoMsg doc) go = do+ -- Don't mark 'infoProgress' messages (mostly Backpack internals)+ hPutStrLn (verbosityChosenOutputHandle verbosity) (render doc)+ go+ fail_fn :: ErrMsg -> IO a fail_fn doc = do dieNoWrap verbosity (render doc) -- | Output a warning trace message in 'LogProgress'. warnProgress :: Doc -> LogProgress () warnProgress s = LogProgress $ \env ->- when (le_verbosity env >= normal) $+ when (verbosityLevel (le_verbosity env) >= Normal) $ stepProgress $- hang (text "Warning:") 4 (formatMsg (le_context env) s)+ WarnMsg $+ 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 (verbosityLevel (le_verbosity env) >= Verbose) $+ stepProgress $+ InfoMsg s -- | Fail the computation with an error message. dieProgress :: Doc -> LogProgress a
src/Distribution/Utils/MapAccum.hs view
@@ -1,7 +1,6 @@-{-# LANGUAGE CPP #-}- module Distribution.Utils.MapAccum (mapAccumM) where +import Data.Bifunctor (second) import Distribution.Compat.Prelude import Prelude () @@ -9,7 +8,7 @@ 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 (second f) (x s) instance Monad m => Applicative (StateM s m) where pure x = StateM $ \s -> return (s, x)@@ -25,4 +24,4 @@ -> a -> t b -> m (a, t c)-mapAccumM f s t = runStateM (traverse (\x -> StateM (\s' -> f s' x)) t) s+mapAccumM f s t = runStateM (traverse (\x -> StateM (`f` x)) t) s
src/Distribution/Utils/NubList.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -22,7 +21,7 @@ -- | NubList : A de-duplicated list that maintains the original order. newtype NubList a = NubList {fromNubList :: [a]}- deriving (Eq, Generic, Typeable)+ deriving (Eq, Generic) -- NubList assumes that nub retains the list order while removing duplicate -- elements (keeping the first occurrence). Documentation for "Data.List.nub"@@ -75,6 +74,9 @@ get = fmap toNubList get instance Structured a => Structured (NubList a)++instance NFData a => NFData (NubList a) where+ rnf (NubList xs) = rnf xs -- | NubListR : A right-biased version of 'NubList'. That is @toNubListR -- ["-XNoFoo", "-XFoo", "-XNoFoo"]@ will result in @["-XFoo", "-XNoFoo"]@,
src/Distribution/Utils/Progress.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} -- Note: This module was copied from cabal-install.@@ -63,7 +62,7 @@ instance Applicative (Progress step fail) where pure a = Done a- p <*> x = foldProgress Step Fail (flip fmap x) p+ p <*> x = foldProgress Step Fail (`fmap` x) p instance Monoid fail => Alternative (Progress step fail) where empty = Fail Mon.mempty
src/Distribution/Utils/UnionFind.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NondecreasingIndentation #-} -- | A simple mutable union-find data structure.@@ -50,14 +51,13 @@ -- 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- point'' <- repr point'- when (point'' /= point') $ do- writePoint point =<< readPoint point'- return point''- Info _ _ -> return point+ readPoint point >>= \case+ Link point' -> do+ point'' <- repr point'+ when (point'' /= point') $ do+ writePoint point =<< readPoint point'+ return point''+ Info _ _ -> return point -- | Return the canonical element of an equivalence -- class 'Point'.@@ -65,14 +65,12 @@ 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' ->- case r' of- Info _ d_ref -> readSTRef d_ref- Link _ -> repr point >>= find+ readPoint point >>= \case+ Info _ d_ref -> readSTRef d_ref+ Link point' ->+ readPoint point' >>= \case+ Info _ d_ref -> readSTRef d_ref+ Link _ -> repr point >>= find -- | Unify two equivalence classes, so that they share -- a canonical element. Keeps the descriptor of point2.
src/Distribution/Verbosity.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- @@ -25,8 +25,22 @@ -- are interested in.) It's important to note that the instances -- for 'Verbosity' assume that this does not exist. module Distribution.Verbosity- ( -- * Verbosity- Verbosity+ ( -- * Rich verbosity+ Verbosity (..)+ , VerbosityHandles (..)+ , defaultVerbosityHandles+ , VerbosityLevel (..)+ , verbosityLevel+ , verbosityChosenOutputHandle+ , verbosityErrorHandle+ , modifyVerbosityFlags+ , mkVerbosity+ , setVerbosityHandles++ -- * Verbosity flags+ , VerbosityFlags (vLevel)+ , mkVerbosityFlags+ , makeVerbose , silent , normal , verbose@@ -40,7 +54,6 @@ , showForGHC , verboseNoFlags , verboseHasFlags- , modifyVerbosity -- * Call stacks , verboseCallSite@@ -48,7 +61,7 @@ , isVerboseCallSite , isVerboseCallStack - -- * Output markets+ -- * Output markers , verboseMarkOutput , isVerboseMarkOutput , verboseUnmarkOutput@@ -85,54 +98,121 @@ import qualified Data.Set as Set import qualified Distribution.Compat.CharParsing as P+import Distribution.Utils.Structured+import System.IO (Handle, stderr, stdout) import qualified Text.PrettyPrint as PP+import qualified Type.Reflection as Typeable +-- | Rich verbosity, used for the Cabal library interface. data Verbosity = Verbosity+ { verbosityFlags :: VerbosityFlags+ , verbosityHandles :: VerbosityHandles+ }+ deriving (Generic)++-- | Handles to use for logging (e.g. log to stdout, or log to a file).+data VerbosityHandles = VerbosityHandles+ { vStdoutHandle :: Handle+ , vStderrHandle :: Handle+ }++defaultVerbosityHandles :: VerbosityHandles+defaultVerbosityHandles =+ VerbosityHandles+ { vStdoutHandle = stdout+ , vStderrHandle = stderr+ }++-- | Verbosity information which can be passed by the CLI.+data VerbosityFlags = VerbosityFlags { vLevel :: VerbosityLevel , vFlags :: Set VerbosityFlag , vQuiet :: Bool }- deriving (Generic, Show, Read, Typeable)+ deriving (Generic, Show, Read, Eq) -mkVerbosity :: VerbosityLevel -> Verbosity-mkVerbosity l = Verbosity{vLevel = l, vFlags = Set.empty, vQuiet = False}+verbosityLevel :: Verbosity -> VerbosityLevel+verbosityLevel = vLevel . verbosityFlags -instance Eq Verbosity where- x == y = vLevel x == vLevel y+-- | The handle used for normal output.+--+-- With the @+stderr@ verbosity flag, this is the error handle.+verbosityChosenOutputHandle :: Verbosity -> Handle+verbosityChosenOutputHandle verb =+ if isVerboseStderr (verbosityFlags verb)+ then vStderrHandle $ verbosityHandles verb+ else vStdoutHandle $ verbosityHandles verb -instance Ord Verbosity where- compare x y = compare (vLevel x) (vLevel y)+-- | The verbosity handle used for error output.+verbosityErrorHandle :: Verbosity -> Handle+verbosityErrorHandle = vStderrHandle . verbosityHandles -instance Enum Verbosity where- toEnum = mkVerbosity . toEnum- fromEnum = fromEnum . vLevel+setVerbosityHandles :: Maybe Handle -> Verbosity -> Verbosity+setVerbosityHandles Nothing v = v+setVerbosityHandles (Just h) v =+ v{verbosityHandles = VerbosityHandles{vStdoutHandle = h, vStderrHandle = h}} -instance Bounded Verbosity where- minBound = mkVerbosity minBound- maxBound = mkVerbosity maxBound+mkVerbosity :: VerbosityHandles -> VerbosityFlags -> Verbosity+mkVerbosity handles flags =+ Verbosity+ { verbosityFlags = flags+ , verbosityHandles = handles+ } -instance Binary Verbosity+modifyVerbosityFlags :: (VerbosityFlags -> VerbosityFlags) -> Verbosity -> Verbosity+modifyVerbosityFlags f v@(Verbosity{verbosityFlags = flags}) =+ v{verbosityFlags = f flags}++mkVerbosityFlags :: VerbosityLevel -> VerbosityFlags+mkVerbosityFlags l = VerbosityFlags{vLevel = l, vFlags = Set.empty, vQuiet = False}++instance Binary VerbosityFlags+instance NFData VerbosityFlags+instance Structured VerbosityFlags++-- Hand-written instances, because there are no NFData/Structured instances+-- for Handle.+instance NFData VerbosityHandles where+ rnf (VerbosityHandles o e) = o `seq` e `seq` ()+instance Structured VerbosityHandles where+ structure _ =+ Structure+ tr+ 0+ (show tr)+ [+ ( "VerbosityHandles"+ ,+ [ nominalStructure $ Proxy @Handle+ , nominalStructure $ Proxy @Handle+ ]+ )+ ]+ where+ tr = Typeable.SomeTypeRep $ Typeable.typeRep @VerbosityHandles++instance NFData Verbosity instance Structured Verbosity -- | In 'silent' mode, we should not print /anything/ unless an error occurs.-silent :: Verbosity-silent = mkVerbosity Silent+silent :: VerbosityFlags+silent = mkVerbosityFlags Silent -- | Print stuff we want to see by default.-normal :: Verbosity-normal = mkVerbosity Normal+normal :: VerbosityFlags+normal = mkVerbosityFlags Normal -- | Be more verbose about what's going on.-verbose :: Verbosity-verbose = mkVerbosity Verbose+verbose :: VerbosityFlags+verbose = mkVerbosityFlags Verbose -- | Not only are we verbose ourselves (perhaps even noisier than when -- being 'verbose'), but we tell everything we run to be verbose too.-deafening :: Verbosity-deafening = mkVerbosity Deafening+deafening :: VerbosityFlags+deafening = mkVerbosityFlags Deafening -- | Increase verbosity level, but stay 'silent' if we are.-moreVerbose :: Verbosity -> Verbosity+moreVerbose :: VerbosityFlags -> VerbosityFlags moreVerbose v = case vLevel v of Silent -> v -- silent should stay silent@@ -140,8 +220,18 @@ Verbose -> v{vLevel = Deafening} Deafening -> v +-- | Make sure the verbosity level is at least 'verbose',+-- but stay 'silent' if we are.+makeVerbose :: VerbosityFlags -> VerbosityFlags+makeVerbose v =+ case vLevel v of+ Silent -> v -- silent should stay silent+ Normal -> v{vLevel = Verbose}+ Verbose -> v+ Deafening -> v+ -- | Decrease verbosity level, but stay 'deafening' if we are.-lessVerbose :: Verbosity -> Verbosity+lessVerbose :: VerbosityFlags -> VerbosityFlags lessVerbose v = verboseQuiet $ case vLevel v of@@ -150,56 +240,42 @@ Normal -> v{vLevel = Silent} Silent -> v --- | Combinator for transforming verbosity level while retaining the--- original hidden state.------ For instance, the following property holds------ prop> isVerboseNoWrap (modifyVerbosity (max verbose) v) == isVerboseNoWrap v------ __Note__: you can use @modifyVerbosity (const v1) v0@ to overwrite--- @v1@'s flags with @v0@'s flags.------ @since 2.0.1.0-modifyVerbosity :: (Verbosity -> Verbosity) -> Verbosity -> Verbosity-modifyVerbosity f v = v{vLevel = vLevel (f v)}- -- | Numeric verbosity level @0..3@: @0@ is 'silent', @3@ is 'deafening'.-intToVerbosity :: Int -> Maybe Verbosity-intToVerbosity 0 = Just (mkVerbosity Silent)-intToVerbosity 1 = Just (mkVerbosity Normal)-intToVerbosity 2 = Just (mkVerbosity Verbose)-intToVerbosity 3 = Just (mkVerbosity Deafening)+intToVerbosity :: Int -> Maybe VerbosityFlags+intToVerbosity 0 = Just (mkVerbosityFlags Silent)+intToVerbosity 1 = Just (mkVerbosityFlags Normal)+intToVerbosity 2 = Just (mkVerbosityFlags Verbose)+intToVerbosity 3 = Just (mkVerbosityFlags Deafening) intToVerbosity _ = Nothing -- | Parser verbosity -- -- >>> explicitEitherParsec parsecVerbosity "normal"--- Right (Verbosity {vLevel = Normal, vFlags = fromList [], vQuiet = False})+-- Right (VerbosityFlags {vLevel = Normal, vFlags = fromList [], vQuiet = False}) -- -- >>> explicitEitherParsec parsecVerbosity "normal+nowrap "--- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap], vQuiet = False})+-- Right (VerbosityFlags {vLevel = Normal, vFlags = fromList [VNoWrap], vQuiet = False}) -- -- >>> explicitEitherParsec parsecVerbosity "normal+nowrap +markoutput"--- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False})+-- Right (VerbosityFlags {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}) -- -- >>> explicitEitherParsec parsecVerbosity "normal +nowrap +markoutput"--- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False})+-- Right (VerbosityFlags {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}) -- -- >>> explicitEitherParsec parsecVerbosity "normal+nowrap+markoutput"--- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False})+-- Right (VerbosityFlags {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}) -- -- >>> explicitEitherParsec parsecVerbosity "deafening+nowrap+stdout+stderr+callsite+callstack"--- Right (Verbosity {vLevel = Deafening, vFlags = fromList [VCallStack,VCallSite,VNoWrap,VStderr], vQuiet = False})+-- Right (VerbosityFlags {vLevel = Deafening, vFlags = fromList [VCallStack,VCallSite,VNoWrap,VStderr], vQuiet = False}) -- -- /Note:/ this parser will eat trailing spaces.-instance Parsec Verbosity where+instance Parsec VerbosityFlags where parsec = parsecVerbosity -instance Pretty Verbosity where+instance Pretty VerbosityFlags where pretty = PP.text . showForCabal -parsecVerbosity :: CabalParsing m => m Verbosity+parsecVerbosity :: CabalParsing m => m VerbosityFlags parsecVerbosity = parseIntVerbosity <|> parseStringVerbosity where parseIntVerbosity = do@@ -212,7 +288,7 @@ level <- parseVerbosityLevel _ <- P.spaces flags <- many (parseFlag <* P.spaces)- return $ foldl' (flip ($)) (mkVerbosity level) flags+ return $ foldl' (flip ($)) (mkVerbosityFlags level) flags parseVerbosityLevel = do token <- P.munch1 isAsciiAlpha@@ -237,18 +313,18 @@ "nowarn" -> return verboseNoWarn _ -> P.unexpected $ "Bad verbosity flag: " ++ token -flagToVerbosity :: ReadE Verbosity+flagToVerbosity :: ReadE VerbosityFlags flagToVerbosity = parsecToReadE id parsecVerbosity -showForCabal :: Verbosity -> String-showForCabal v- | Set.null (vFlags v) =+showForCabal :: VerbosityFlags -> String+showForCabal (VerbosityFlags{vLevel = lvl, vFlags = flags})+ | Set.null flags = maybe (error "unknown verbosity") show $- elemIndex v [silent, normal, verbose, deafening]+ elemIndex lvl [Silent, Normal, Verbose, Deafening] | otherwise = unwords $- showLevel (vLevel v)- : concatMap showFlag (Set.toList (vFlags v))+ showLevel lvl+ : concatMap showFlag (Set.toList flags) where showLevel Silent = "silent" showLevel Normal = "normal"@@ -263,116 +339,116 @@ showFlag VStderr = ["+stderr"] showFlag VNoWarn = ["+nowarn"] -showForGHC :: Verbosity -> String+showForGHC :: VerbosityFlags -> String showForGHC v = maybe (error "unknown verbosity") show $- elemIndex v [silent, normal, __, verbose, deafening]+ elemIndex (vLevel v) [Silent, Normal, __, Verbose, Deafening] where- __ = silent -- this will be always ignored by elemIndex+ __ = Silent -- this will be always ignored by elemIndex -- | Turn on verbose call-site printing when we log.-verboseCallSite :: Verbosity -> Verbosity+verboseCallSite :: VerbosityFlags -> VerbosityFlags verboseCallSite = verboseFlag VCallSite -- | Turn on verbose call-stack printing when we log.-verboseCallStack :: Verbosity -> Verbosity+verboseCallStack :: VerbosityFlags -> VerbosityFlags verboseCallStack = verboseFlag VCallStack -- | Turn on @-----BEGIN CABAL OUTPUT-----@ markers for output -- from Cabal (as opposed to GHC, or system dependent).-verboseMarkOutput :: Verbosity -> Verbosity+verboseMarkOutput :: VerbosityFlags -> VerbosityFlags verboseMarkOutput = verboseFlag VMarkOutput -- | Turn off marking; useful for suppressing nondeterministic output.-verboseUnmarkOutput :: Verbosity -> Verbosity+verboseUnmarkOutput :: VerbosityFlags -> VerbosityFlags verboseUnmarkOutput = verboseNoFlag VMarkOutput -- | Disable line-wrapping for log messages.-verboseNoWrap :: Verbosity -> Verbosity+verboseNoWrap :: VerbosityFlags -> VerbosityFlags verboseNoWrap = verboseFlag VNoWrap -- | Mark the verbosity as quiet.-verboseQuiet :: Verbosity -> Verbosity+verboseQuiet :: VerbosityFlags -> VerbosityFlags verboseQuiet v = v{vQuiet = True} -- | Turn on timestamps for log messages.-verboseTimestamp :: Verbosity -> Verbosity+verboseTimestamp :: VerbosityFlags -> VerbosityFlags verboseTimestamp = verboseFlag VTimestamp -- | Turn off timestamps for log messages.-verboseNoTimestamp :: Verbosity -> Verbosity+verboseNoTimestamp :: VerbosityFlags -> VerbosityFlags verboseNoTimestamp = verboseNoFlag VTimestamp -- | Switch logging to 'stderr'. -- -- @since 3.4.0.0-verboseStderr :: Verbosity -> Verbosity+verboseStderr :: VerbosityFlags -> VerbosityFlags verboseStderr = verboseFlag VStderr -- | Switch logging to 'stdout'. -- -- @since 3.4.0.0-verboseNoStderr :: Verbosity -> Verbosity+verboseNoStderr :: VerbosityFlags -> VerbosityFlags verboseNoStderr = verboseNoFlag VStderr -- | Turn off warnings for log messages.-verboseNoWarn :: Verbosity -> Verbosity+verboseNoWarn :: VerbosityFlags -> VerbosityFlags verboseNoWarn = verboseFlag VNoWarn -- | Helper function for flag enabling functions.-verboseFlag :: VerbosityFlag -> (Verbosity -> Verbosity)-verboseFlag flag v = v{vFlags = Set.insert flag (vFlags v)}+verboseFlag :: VerbosityFlag -> (VerbosityFlags -> VerbosityFlags)+verboseFlag flag v@(VerbosityFlags{vFlags = flags}) = v{vFlags = Set.insert flag flags} -- | Helper function for flag disabling functions.-verboseNoFlag :: VerbosityFlag -> (Verbosity -> Verbosity)-verboseNoFlag flag v = v{vFlags = Set.delete flag (vFlags v)}+verboseNoFlag :: VerbosityFlag -> (VerbosityFlags -> VerbosityFlags)+verboseNoFlag flag v@(VerbosityFlags{vFlags = flags}) = v{vFlags = Set.delete flag flags} -- | Turn off all flags.-verboseNoFlags :: Verbosity -> Verbosity+verboseNoFlags :: VerbosityFlags -> VerbosityFlags verboseNoFlags v = v{vFlags = Set.empty} -verboseHasFlags :: Verbosity -> Bool-verboseHasFlags = not . Set.null . vFlags+verboseHasFlags :: VerbosityFlags -> Bool+verboseHasFlags (VerbosityFlags{vFlags = flags}) = not $ Set.null flags -- | Test if we should output call sites when we log.-isVerboseCallSite :: Verbosity -> Bool+isVerboseCallSite :: VerbosityFlags -> Bool isVerboseCallSite = isVerboseFlag VCallSite -- | Test if we should output call stacks when we log.-isVerboseCallStack :: Verbosity -> Bool+isVerboseCallStack :: VerbosityFlags -> Bool isVerboseCallStack = isVerboseFlag VCallStack --- | Test if we should output markets.-isVerboseMarkOutput :: Verbosity -> Bool+-- | Test if we should output markers.+isVerboseMarkOutput :: VerbosityFlags -> Bool isVerboseMarkOutput = isVerboseFlag VMarkOutput -- | Test if line-wrapping is disabled for log messages.-isVerboseNoWrap :: Verbosity -> Bool+isVerboseNoWrap :: VerbosityFlags -> Bool isVerboseNoWrap = isVerboseFlag VNoWrap -- | Test if we had called 'lessVerbose' on the verbosity.-isVerboseQuiet :: Verbosity -> Bool+isVerboseQuiet :: VerbosityFlags -> Bool isVerboseQuiet = vQuiet -- | Test if we should output timestamps when we log.-isVerboseTimestamp :: Verbosity -> Bool+isVerboseTimestamp :: VerbosityFlags -> Bool isVerboseTimestamp = isVerboseFlag VTimestamp -- | Test if we should output to 'stderr' when we log. -- -- @since 3.4.0.0-isVerboseStderr :: Verbosity -> Bool+isVerboseStderr :: VerbosityFlags -> Bool isVerboseStderr = isVerboseFlag VStderr -- | Test if we should output warnings when we log.-isVerboseNoWarn :: Verbosity -> Bool+isVerboseNoWarn :: VerbosityFlags -> Bool isVerboseNoWarn = isVerboseFlag VNoWarn -- | Helper function for flag testing functions.-isVerboseFlag :: VerbosityFlag -> Verbosity -> Bool-isVerboseFlag flag = (Set.member flag) . vFlags+isVerboseFlag :: VerbosityFlag -> VerbosityFlags -> Bool+isVerboseFlag flag v = flag `Set.member` vFlags v -- $setup -- >>> import Test.QuickCheck (Arbitrary (..), arbitraryBoundedEnum) -- >>> instance Arbitrary VerbosityLevel where arbitrary = arbitraryBoundedEnum--- >>> instance Arbitrary Verbosity where arbitrary = fmap mkVerbosity arbitrary+-- >>> instance Arbitrary VerbosityFlags where arbitrary = fmap mkVerbosityFlags arbitrary
src/Distribution/Verbosity/Internal.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module Distribution.Verbosity.Internal@@ -10,9 +9,10 @@ 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) instance Binary VerbosityLevel+instance NFData VerbosityLevel instance Structured VerbosityLevel data VerbosityFlag@@ -24,7 +24,8 @@ | -- | @since 3.4.0.0 VStderr | VNoWarn- deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable)+ deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded) instance Binary VerbosityFlag+instance NFData VerbosityFlag instance Structured VerbosityFlag
src/Distribution/ZinzaPrelude.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE TupleSections #-}+ -- | A small prelude used in @zinza@ generated -- template modules. module Distribution.ZinzaPrelude@@ -27,7 +29,7 @@ fmap = liftM instance Applicative Writer where- pure x = W $ \ss -> (ss, x)+ pure x = W (,x) (<*>) = ap instance Monad Writer where