Cabal 3.14.2.0 → 3.18.1.0
raw patch · 130 files changed
Files
- Cabal.cabal +48/−32
- ChangeLog.md +11/−2
- LICENSE +1/−1
- src/Distribution/Backpack/Configure.hs +85/−24
- 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/PreModuleShape.hs +0/−1
- src/Distribution/Backpack/ReadyComponent.hs +5/−6
- src/Distribution/Backpack/UnifyM.hs +2/−4
- 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 +20/−110
- src/Distribution/Compat/ResponseFile.hs +8/−14
- src/Distribution/Compat/SnocList.hs +0/−34
- src/Distribution/Compat/Stack.hs +1/−19
- src/Distribution/Compat/SysInfo.hs +15/−0
- src/Distribution/Compat/Time.hs +6/−139
- src/Distribution/GetOpt.hs +5/−5
- src/Distribution/Make.hs +0/−201
- src/Distribution/PackageDescription/Check.hs +74/−36
- src/Distribution/PackageDescription/Check/Common.hs +4/−3
- 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 +39/−16
- src/Distribution/PackageDescription/Check/Warning.hs +33/−17
- src/Distribution/Simple.hs +272/−186
- src/Distribution/Simple/Bench.hs +7/−6
- src/Distribution/Simple/Build.hs +172/−148
- src/Distribution/Simple/Build/Inputs.hs +1/−5
- 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 +17/−2
- src/Distribution/Simple/BuildTarget.hs +28/−22
- src/Distribution/Simple/BuildToolDepends.hs +1/−2
- src/Distribution/Simple/BuildWay.hs +15/−8
- src/Distribution/Simple/Command.hs +7/−6
- src/Distribution/Simple/Compiler.hs +103/−29
- src/Distribution/Simple/Configure.hs +3087/−2849
- src/Distribution/Simple/ConfigureScript.hs +31/−15
- src/Distribution/Simple/Errors.hs +29/−23
- src/Distribution/Simple/FileMonitor/Types.hs +2/−1
- src/Distribution/Simple/Flag.hs +16/−48
- src/Distribution/Simple/GHC.hs +200/−146
- src/Distribution/Simple/GHC/Build.hs +42/−10
- src/Distribution/Simple/GHC/Build/ExtraSources.hs +37/−19
- src/Distribution/Simple/GHC/Build/Link.hs +141/−152
- src/Distribution/Simple/GHC/Build/Modules.hs +62/−31
- src/Distribution/Simple/GHC/Build/Utils.hs +37/−7
- src/Distribution/Simple/GHC/EnvironmentParser.hs +4/−6
- src/Distribution/Simple/GHC/ImplInfo.hs +11/−37
- src/Distribution/Simple/GHC/Internal.hs +228/−220
- src/Distribution/Simple/GHCJS.hs +83/−109
- src/Distribution/Simple/Glob.hs +29/−12
- src/Distribution/Simple/Glob/Internal.hs +15/−10
- src/Distribution/Simple/Haddock.hs +135/−114
- src/Distribution/Simple/HaskellSuite.hs +0/−270
- src/Distribution/Simple/Install.hs +16/−23
- src/Distribution/Simple/InstallDirs.hs +106/−10
- src/Distribution/Simple/InstallDirs/Internal.hs +6/−0
- src/Distribution/Simple/LocalBuildInfo.hs +3/−5
- src/Distribution/Simple/PackageDescription.hs +27/−22
- src/Distribution/Simple/PackageIndex.hs +60/−25
- src/Distribution/Simple/PreProcess.hs +113/−131
- src/Distribution/Simple/PreProcess/Types.hs +2/−1
- src/Distribution/Simple/Program.hs +1/−2
- src/Distribution/Simple/Program/Ar.hs +7/−7
- src/Distribution/Simple/Program/Builtin.hs +34/−74
- src/Distribution/Simple/Program/Db.hs +63/−7
- src/Distribution/Simple/Program/Find.hs +1/−26
- src/Distribution/Simple/Program/GHC.hs +164/−74
- src/Distribution/Simple/Program/HcPkg.hs +155/−200
- src/Distribution/Simple/Program/Internal.hs +13/−6
- src/Distribution/Simple/Program/Ld.hs +1/−3
- src/Distribution/Simple/Program/ResponseFile.hs +3/−9
- src/Distribution/Simple/Program/Run.hs +4/−6
- src/Distribution/Simple/Program/Script.hs +1/−1
- src/Distribution/Simple/Program/Strip.hs +2/−2
- src/Distribution/Simple/Program/Types.hs +1/−1
- src/Distribution/Simple/Register.hs +61/−47
- src/Distribution/Simple/Setup.hs +7/−4
- src/Distribution/Simple/Setup/Benchmark.hs +4/−3
- src/Distribution/Simple/Setup/Build.hs +14/−14
- src/Distribution/Simple/Setup/Clean.hs +1/−1
- src/Distribution/Simple/Setup/Common.hs +38/−8
- src/Distribution/Simple/Setup/Config.hs +27/−27
- src/Distribution/Simple/Setup/Copy.hs +7/−6
- src/Distribution/Simple/Setup/Global.hs +9/−0
- src/Distribution/Simple/Setup/Haddock.hs +138/−157
- src/Distribution/Simple/Setup/Hscolour.hs +2/−2
- src/Distribution/Simple/Setup/Install.hs +3/−3
- src/Distribution/Simple/Setup/Register.hs +76/−76
- src/Distribution/Simple/Setup/Repl.hs +10/−2
- src/Distribution/Simple/Setup/SDist.hs +1/−1
- src/Distribution/Simple/Setup/Test.hs +9/−7
- src/Distribution/Simple/SetupHooks/Errors.hs +4/−20
- src/Distribution/Simple/SetupHooks/HooksMain.hs +407/−0
- src/Distribution/Simple/SetupHooks/Internal.hs +264/−61
- src/Distribution/Simple/SetupHooks/Rule.hs +64/−13
- src/Distribution/Simple/ShowBuildInfo.hs +1/−2
- src/Distribution/Simple/SrcDist.hs +16/−15
- src/Distribution/Simple/Test.hs +15/−15
- src/Distribution/Simple/Test/ExeV10.hs +23/−25
- src/Distribution/Simple/Test/LibV09.hs +12/−18
- src/Distribution/Simple/UHC.hs +19/−22
- src/Distribution/Simple/UserHooks.hs +2/−2
- src/Distribution/Simple/Utils.hs +322/−161
- src/Distribution/Types/ComponentLocalBuildInfo.hs +12/−0
- src/Distribution/Types/DumpBuildInfo.hs +11/−0
- src/Distribution/Types/LocalBuildConfig.hs +22/−21
- src/Distribution/Types/LocalBuildInfo.hs +6/−4
- 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/−2
- src/Distribution/Utils/NubList.hs +3/−0
- src/Distribution/Utils/Progress.hs +1/−1
- src/Distribution/Utils/UnionFind.hs +14/−16
- src/Distribution/Verbosity.hs +174/−97
- src/Distribution/Verbosity/Internal.hs +2/−0
- 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.14.2.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,35 +29,51 @@ 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.14,- array >= 0.4.0.1 && < 0.6,- base >= 4.13 && < 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.8.6.0 && < 2.9+ build-depends:+ , unix >= 2.8.6.0 && < 2.9 + 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- -fwarn-tabs- -fwarn-incomplete-uni-patterns- -fwarn-incomplete-record-updates- -fno-warn-unticked-promoted-constructors+ -Wtabs+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wno-unticked-promoted-constructors if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances@@ -65,6 +81,9 @@ if impl(ghc >= 8.0) && impl(ghc < 8.8) ghc-options: -Wnoncanonical-monadfail-instances + if impl(ghc >= 9.14)+ ghc-options: -Wno-pattern-namespace-specifier -Wno-incomplete-record-selectors+ exposed-modules: Distribution.Backpack.Configure Distribution.Backpack.ComponentsGraph@@ -79,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@@ -114,7 +131,6 @@ Distribution.Simple.Haddock Distribution.Simple.Glob Distribution.Simple.Glob.Internal- Distribution.Simple.HaskellSuite Distribution.Simple.Hpc Distribution.Simple.Install Distribution.Simple.InstallDirs@@ -151,6 +167,7 @@ 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@@ -183,7 +200,6 @@ Distribution.Compat.Exception, Distribution.Compat.Graph, Distribution.Compat.Lens,- Distribution.Compat.MonadFail, Distribution.Compat.Newtype, Distribution.Compat.NonEmptySet, Distribution.Compat.Parsing,@@ -248,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,@@ -271,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,@@ -314,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@@ -331,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,12 @@+# 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 @@ -583,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@@ -776,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@@ -263,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@@ -272,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@@ -340,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. --@@ -355,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/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/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,22 +10,12 @@ 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)-import System.Posix.Internals (c_getpid)-#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_getpid, 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) import System.Directory ( createDirectory )@@ -33,107 +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 relpath = template ++ "-" ++ show x- dirpath = dir </> relpath- r <- tryIO $ mkPrivateDir dirpath- case r of- Right _ -> return relpath- 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,9 +1,3 @@-{-# 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@@ -16,12 +10,12 @@ import System.IO (hPutStrLn, stderr) import System.IO.Error --- | 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@@ -33,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
@@ -4,7 +4,6 @@ module Distribution.Compat.Stack ( WithCallStack , CallStack- , annotateCallStackIO , withFrozenCallStack , withLexicalCallStack , callStack@@ -13,15 +12,13 @@ ) where import GHC.Stack-import System.IO.Error type WithCallStack a = HasCallStack => a -- | 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 parentSrcLocPrefix = case getCallStack callStack of@@ -37,18 +34,3 @@ withLexicalCallStack f = let stk = ?callStack in \x -> let ?callStack = stk in f x---- | 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
+ 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,17 +1,11 @@-{-# LANGUAGE CPP #-} {-# 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 @@ -20,39 +14,10 @@ import System.Directory (getModificationTime) -import Distribution.Simple.Utils (withTempDirectoryCwd)-import Distribution.Utils.Path (getSymbolicPath, sameDirectory)-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)-import Data.Bits (finiteBitSize)--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)- , modificationTimeHiRes-#else- , 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)@@ -65,83 +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- let qwTime =- (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` finiteBitSize dwHigh)- .|. (fromIntegral (dwLow :: DWORD))- 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 =@@ -158,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 =- withTempDirectoryCwd silent Nothing sameDirectory "calibration-" $ \dir -> do- let fileName = getSymbolicPath 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,201 +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.License-import Distribution.Package-import Distribution.Pretty-import Distribution.Simple.Command-import Distribution.Simple.Program-import Distribution.Simple.Setup-import Distribution.Simple.Utils-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- mbWorkDir = flagToMaybe $ configWorkingDir flags- rawSystemExit verbosity mbWorkDir "sh" $- "configure"- : configureArgs backwardsCompatHack flags- where- backwardsCompatHack = True--copyAction :: CopyFlags -> [String] -> IO ()-copyAction flags args = do- noExtraFlags args- let verbosity = fromFlag $ copyVerbosity flags- mbWorkDir = flagToMaybe $ copyWorkingDir flags- destArgs = case fromFlag $ copyDest flags of- NoCopyDest -> ["install"]- CopyTo path -> ["copy", "destdir=" ++ path]- CopyToDb _ -> error "CopyToDb not supported via Make"-- rawSystemExit verbosity mbWorkDir "make" destArgs--installAction :: InstallFlags -> [String] -> IO ()-installAction flags args = do- noExtraFlags args- let verbosity = fromFlag $ installVerbosity flags- mbWorkDir = flagToMaybe $ installWorkingDir flags- rawSystemExit verbosity mbWorkDir "make" ["install"]- rawSystemExit verbosity mbWorkDir "make" ["register"]--haddockAction :: HaddockFlags -> [String] -> IO ()-haddockAction flags args = do- noExtraFlags args- let verbosity = fromFlag $ haddockVerbosity flags- mbWorkDir = flagToMaybe $ haddockWorkingDir flags- rawSystemExit verbosity mbWorkDir "make" ["docs"]- `catchIO` \_ ->- rawSystemExit verbosity mbWorkDir "make" ["doc"]--buildAction :: BuildFlags -> [String] -> IO ()-buildAction flags args = do- noExtraFlags args- let verbosity = fromFlag $ buildVerbosity flags- mbWorkDir = flagToMaybe $ buildWorkingDir flags- rawSystemExit verbosity mbWorkDir "make" []--cleanAction :: CleanFlags -> [String] -> IO ()-cleanAction flags args = do- noExtraFlags args- let verbosity = fromFlag $ cleanVerbosity flags- mbWorkDir = flagToMaybe $ cleanWorkingDir flags- rawSystemExit verbosity mbWorkDir "make" ["clean"]--sdistAction :: SDistFlags -> [String] -> IO ()-sdistAction flags args = do- noExtraFlags args- let verbosity = fromFlag $ sDistVerbosity flags- mbWorkDir = flagToMaybe $ sDistWorkingDir flags- rawSystemExit verbosity mbWorkDir "make" ["dist"]--registerAction :: RegisterFlags -> [String] -> IO ()-registerAction flags args = do- noExtraFlags args- let verbosity = fromFlag $ registerVerbosity flags- mbWorkDir = flagToMaybe $ registerWorkingDir flags- rawSystemExit verbosity mbWorkDir "make" ["register"]--unregisterAction :: RegisterFlags -> [String] -> IO ()-unregisterAction flags args = do- noExtraFlags args- let verbosity = fromFlag $ registerVerbosity flags- mbWorkDir = flagToMaybe $ registerWorkingDir flags- rawSystemExit verbosity mbWorkDir "make" ["unregister"]
src/Distribution/PackageDescription/Check.hs view
@@ -47,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@@ -79,12 +82,15 @@ 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@@ -171,14 +177,14 @@ 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@@ -239,7 +245,7 @@ -- Targets should be present... let condAllLibraries = maybeToList condLibrary_- ++ (map snd condSubLibraries_)+ ++ map snd condSubLibraries_ checkP ( and [ null condExecutables_@@ -268,8 +274,6 @@ checkP (not . null $ dups names) (PackageBuildImpossible $ DuplicateSections dupes)- -- PackageDescription checks.- checkPackageDescription packageDescription_ -- Flag names. mapM_ checkFlagName genPackageFlags_ @@ -350,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 ()@@ -425,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.@@ -453,6 +469,20 @@ ) (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 . getSymbolicPath) extraSrcFiles_ mapM_ (checkPath False "extra-tmp-files" PathKindFile . getSymbolicPath) extraTmpFiles_@@ -509,7 +539,7 @@ ( isNothing setupBuildInfo_ && buildTypeRaw_ == Just Custom )- (PackageDistSuspiciousWarn CVExpliticDepsCustomSetup)+ (PackageDistSuspiciousWarn CVExplicitDepsCustomSetup) checkP (isNothing buildTypeRaw_ && specVersion_ < CabalSpecV2_2) (PackageBuildWarning NoBuildType)@@ -559,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@@ -588,8 +631,7 @@ 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@@ -631,7 +673,7 @@ -- licenses so don't need license files. nullLicFiles )- $ (PackageDistSuspicious NoLicenseFile)+ (PackageDistSuspicious NoLicenseFile) case unknownLicenseVersion lic of Just knownVersions -> tellP@@ -708,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)@@ -756,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 <-@@ -835,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) @@ -884,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 =@@ -938,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@@ -981,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@@ -992,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@@ -1024,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.@@ -1062,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?@@ -1077,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
@@ -26,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 @@ -61,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). --@@ -80,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] @@ -97,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)
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)@@ -89,7 +91,7 @@ (flip elem (allExplicitIncludes lib) . getSymbolicPath) (view L.autogenIncludes lib) )- $ (PackageBuildImpossible AutogenIncludesNotIncluded)+ (PackageBuildImpossible AutogenIncludesNotIncluded) -- § Build infos. checkBuildInfo@@ -153,7 +155,7 @@ checkP ( pid /= fakePackageId && not (null modulePath_)- && not (fileExtensionSupportedLanguage $ modulePath_)+ && not (fileExtensionSupportedLanguage modulePath_) ) (PackageBuildImpossible NoHsLhsMain) @@ -168,7 +170,7 @@ -- 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 $@@ -211,7 +213,7 @@ checkP ( not $ all- (flip elem (testModules ts))+ (`elem` testModules ts) (testModulesAutogen ts) ) (PackageBuildImpossible $ AutogenNoOther cet)@@ -271,7 +273,7 @@ checkP ( not $ all- (flip elem (benchmarkModules bm))+ (`elem` benchmarkModules bm) (benchmarkModulesAutogen bm) ) (PackageBuildImpossible $ AutogenNoOther cet)@@ -381,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 ()@@ -526,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@@ -558,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@@ -641,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@@ -678,7 +677,7 @@ -- PackageBuildImpossible and not merely PackageDistInexcusable. checkSpecVer CabalSpecV3_12- (elem autoInfoModuleName allModsForAuto)+ (autoInfoModuleName `elem` allModsForAuto) (PackageBuildImpossible CVAutogenPackageInfoGuard) where allModsForAuto :: [ModuleName]@@ -800,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@@ -892,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@@ -949,7 +955,7 @@ ) (PackageDistInexcusable . DynamicUnneeded) checkFlagsP- ( \opt -> case opt of+ ( \case "-j" -> True ('-' : 'j' : d : _) -> isDigit d _ -> False@@ -1077,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,5 +1,4 @@ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -25,7 +24,7 @@ , ppPackageCheck , ppCheckExplanationId , isHackageDistError- , extractCheckExplantion+ , extractCheckExplanation , filterPackageChecksById , filterPackageChecksByIdString ) where@@ -124,7 +123,7 @@ ff c = flip notElem is . checkExplanationId- . extractCheckExplantion+ . extractCheckExplanation $ c -- | Filter Package Check by Check explanation /string/.@@ -171,6 +170,7 @@ | UnknownExtensions [String] | LanguagesAsExtension [String] | DeprecatedExtensions [(Extension, Maybe Extension)]+ | FreeTextDotline String | MissingFieldCategory | MissingFieldMaintainer | MissingFieldSynopsis@@ -215,6 +215,7 @@ | OptWithRts String | COptONumber String WarnLang | COptCPP String+ | OptJSPP String | OptAlternatives String String [(String, String)] | RelativeOutside String FilePath | AbsolutePath String FilePath@@ -244,7 +245,7 @@ | CVSourceRepository | CVExtensions CabalSpecVersion [Extension] | CVCustomSetup- | CVExpliticDepsCustomSetup+ | CVExplicitDepsCustomSetup | CVAutogenPaths | CVAutogenPackageInfo | CVAutogenPackageInfoGuard@@ -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@@ -381,6 +383,7 @@ | CIOptWithRts | CICOptONumber | CICOptCPP+ | CIOptJSPP | CIOptAlternatives | CIRelativeOutside | CIAbsolutePath@@ -410,7 +413,7 @@ | CICVSourceRepository | CICVExtensions | CICVCustomSetup- | CICVExpliticDepsCustomSetup+ | CICVExplicitDepsCustomSetup | CICVAutogenPaths | CICVAutogenPackageInfo | CICVAutogenPackageInfoGuard@@ -482,6 +485,7 @@ checkExplanationId (UnknownExtensions{}) = CIUnknownExtensions checkExplanationId (LanguagesAsExtension{}) = CILanguagesAsExtension checkExplanationId (DeprecatedExtensions{}) = CIDeprecatedExtensions+checkExplanationId (FreeTextDotline{}) = CIFreeTextDotline checkExplanationId (MissingFieldCategory{}) = CIMissingFieldCategory checkExplanationId (MissingFieldMaintainer{}) = CIMissingFieldMaintainer checkExplanationId (MissingFieldSynopsis{}) = CIMissingFieldSynopsis@@ -526,6 +530,7 @@ checkExplanationId (OptWithRts{}) = CIOptWithRts checkExplanationId (COptONumber{}) = CICOptONumber checkExplanationId (COptCPP{}) = CICOptCPP+checkExplanationId (OptJSPP{}) = CIOptJSPP checkExplanationId (OptAlternatives{}) = CIOptAlternatives checkExplanationId (RelativeOutside{}) = CIRelativeOutside checkExplanationId (AbsolutePath{}) = CIAbsolutePath@@ -555,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@@ -634,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"@@ -678,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"@@ -707,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"@@ -907,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."@@ -923,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)@@ -1087,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)@@ -1243,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' "@@ -1458,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."
src/Distribution/Simple.hs view
@@ -1,12 +1,10 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- {- Work around this warning:@@ -15,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@@ -40,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@@ -53,6 +50,7 @@ , defaultMain , defaultMainNoRead , defaultMainArgs+ , defaultMainArgsWithHandles -- * Customization , UserHooks (..)@@ -66,9 +64,25 @@ -- ** 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)@@ -119,13 +133,9 @@ -- Base import Data.List (unionBy, (\\))-import System.Directory- ( doesDirectoryExist- , doesFileExist- , removeDirectoryRecursive- , removeFile- )+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@@ -138,12 +148,17 @@ 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 setup_hooks =- getArgs >>= defaultMainWithSetupHooksArgs setup_hooks+defaultMainWithSetupHooks setupHooks =+ getArgs >>= defaultMainWithSetupHooksArgs setupHooks defaultVerbosityHandles -defaultMainWithSetupHooksArgs :: SetupHooks -> [String] -> IO ()-defaultMainWithSetupHooksArgs setupHooks =+defaultMainWithSetupHooksArgs :: SetupHooks -> VerbosityHandles -> [String] -> IO ()+defaultMainWithSetupHooksArgs setupHooks verbHandles = defaultMainHelper $ simpleUserHooks { confHook = setup_confHook@@ -155,13 +170,24 @@ , 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 =+ setup_confHook p = configure_setupHooks (SetupHooks.configureHooks setupHooks)+ p+ verbHandles setup_buildHook :: PackageDescription@@ -170,12 +196,14 @@ -> BuildFlags -> IO () setup_buildHook pkg_descr lbi hooks flags =- build_setupHooks- (SetupHooks.buildHooks setupHooks)- pkg_descr- lbi- flags- (allSuffixHandlers hooks)+ void $+ build_setupHooks+ (preBuildHook, postBuildHook)+ verbHandles+ pkg_descr+ lbi+ flags+ (allSuffixHandlers hooks) setup_copyHook :: PackageDescription@@ -186,6 +214,7 @@ setup_copyHook pkg_descr lbi _hooks flags = install_setupHooks (SetupHooks.installHooks setupHooks)+ verbHandles pkg_descr lbi flags@@ -199,6 +228,7 @@ setup_installHook = defaultInstallHook_setupHooks (SetupHooks.installHooks setupHooks)+ verbHandles setup_replHook :: PackageDescription@@ -208,13 +238,15 @@ -> [String] -> IO () setup_replHook pkg_descr lbi hooks flags args =- repl_setupHooks- (SetupHooks.buildHooks setupHooks)- pkg_descr- lbi- flags- (allSuffixHandlers hooks)- args+ void $+ repl_setupHooks+ preBuildHook+ verbHandles+ pkg_descr+ lbi+ flags+ (allSuffixHandlers hooks)+ args setup_haddockHook :: PackageDescription@@ -223,12 +255,14 @@ -> HaddockFlags -> IO () setup_haddockHook pkg_descr lbi hooks flags =- haddock_setupHooks- (SetupHooks.buildHooks setupHooks)- pkg_descr- lbi- (allSuffixHandlers hooks)- flags+ void $+ haddock_setupHooks+ preBuildHook+ verbHandles+ pkg_descr+ lbi+ (allSuffixHandlers hooks)+ flags setup_hscolourHook :: PackageDescription@@ -237,12 +271,14 @@ -> HscolourFlags -> IO () setup_hscolourHook pkg_descr lbi hooks flags =- hscolour_setupHooks- (SetupHooks.buildHooks setupHooks)- pkg_descr- lbi- (allSuffixHandlers hooks)- flags+ void $+ hscolour_setupHooks+ preBuildHook+ verbHandles+ pkg_descr+ lbi+ (allSuffixHandlers hooks)+ flags -- | A customizable version of 'defaultMain'. defaultMainWithHooks :: UserHooks -> IO ()@@ -283,38 +319,59 @@ -- 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 (globalFlags, commandParse) ->- case commandParse of- _- | fromFlag (globalVersion globalFlags) -> printVersion- | fromFlag (globalNumericVersion globalFlags) -> printNumericVersion- CommandHelp help -> printHelp help- CommandList opts -> printOptionsList opts- CommandErrors errs -> printErrors errs- CommandReadyToGo action -> action globalFlags+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 -> (GlobalFlags -> UserHooks -> flags -> [String] -> IO res) -> Command (GlobalFlags -> IO ())+ addAction+ :: CommandUI flags+ -> (VerbosityHandles -> GlobalFlags -> UserHooks -> flags -> [String] -> IO res)+ -> Command (GlobalFlags -> IO ()) addAction cmd action =- cmd `commandAddAction` \flags as globalFlags -> void $ action globalFlags hooks flags as+ cmd `commandAddAction` \flags as globalFlags ->+ void $ action verbHandles globalFlags hooks flags as commands :: [Command (GlobalFlags -> IO ())] commands = [ configureCommand progs `addAction` configureAction@@ -343,8 +400,8 @@ overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] overridesPP = unionBy (\x y -> fst x == fst y) -configureAction :: GlobalFlags -> UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo-configureAction globalFlags hooks flags args = do+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' =@@ -358,7 +415,7 @@ { configCommonFlags = commonFlags' } mbWorkDir = flagToMaybe $ setupWorkingDir commonFlags'- verbosity = fromFlag $ setupVerbosity commonFlags'+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity commonFlags') -- See docs for 'HookedBuildInfo' pbi <- preConf hooks args flags'@@ -406,17 +463,18 @@ return (Just pdfile, descr) getCommonFlags- :: GlobalFlags+ :: VerbosityHandles+ -> GlobalFlags -> UserHooks -> CommonSetupFlags -> Args -> IO (LocalBuildInfo, CommonSetupFlags)-getCommonFlags globalFlags hooks commonFlags args = do+getCommonFlags verbHandles globalFlags hooks commonFlags args = do distPref <- findDistPrefOrDefault (setupDistPref commonFlags)- let verbosity = fromFlag $ setupVerbosity commonFlags+ let verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity commonFlags) lbi <- getBuildConfig globalFlags hooks verbosity distPref let common' = configCommonFlags $ configFlags lbi- return $+ return ( lbi , commonFlags { setupDistPref = toFlag distPref@@ -429,11 +487,11 @@ } ) -buildAction :: GlobalFlags -> UserHooks -> BuildFlags -> Args -> IO ()-buildAction globalFlags hooks flags args = do+buildAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> BuildFlags -> Args -> IO ()+buildAction verbHandles globalFlags hooks flags args = do let common = buildCommonFlags flags- verbosity = fromFlag $ setupVerbosity common- (lbi, common') <- getCommonFlags globalFlags hooks common args+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ (lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{buildCommonFlags = common'} progs <-@@ -453,11 +511,11 @@ flags' args -replAction :: GlobalFlags -> UserHooks -> ReplFlags -> Args -> IO ()-replAction globalFlags hooks flags args = do+replAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> ReplFlags -> Args -> IO ()+replAction verbHandles globalFlags hooks flags args = do let common = replCommonFlags flags- verbosity = fromFlag $ setupVerbosity common- (lbi, common') <- getCommonFlags globalFlags hooks common args+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ (lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{replCommonFlags = common'} progs <- reconfigurePrograms@@ -481,11 +539,11 @@ replHook hooks pkg_descr lbi' hooks flags' args postRepl hooks args flags' pkg_descr lbi' -hscolourAction :: GlobalFlags -> UserHooks -> HscolourFlags -> Args -> IO ()-hscolourAction globalFlags hooks flags args = do+hscolourAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> HscolourFlags -> Args -> IO ()+hscolourAction verbHandles globalFlags hooks flags args = do let common = hscolourCommonFlags flags- verbosity = fromFlag $ setupVerbosity common- (_lbi, common') <- getCommonFlags globalFlags hooks common args+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{hscolourCommonFlags = common'} distPref = fromFlag $ setupDistPref common' @@ -499,11 +557,11 @@ flags' args -haddockAction :: GlobalFlags -> UserHooks -> HaddockFlags -> Args -> IO ()-haddockAction globalFlags hooks flags args = do+haddockAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> HaddockFlags -> Args -> IO ()+haddockAction verbHandles globalFlags hooks flags args = do let common = haddockCommonFlags flags- verbosity = fromFlag $ setupVerbosity common- (lbi, common') <- getCommonFlags globalFlags hooks common args+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ (lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{haddockCommonFlags = common'} progs <-@@ -523,10 +581,10 @@ flags' args -cleanAction :: GlobalFlags -> UserHooks -> CleanFlags -> Args -> IO ()-cleanAction globalFlags hooks flags args = do+cleanAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> CleanFlags -> Args -> IO ()+cleanAction verbHandles globalFlags hooks flags args = do let common = cleanCommonFlags flags- verbosity = fromFlag $ setupVerbosity common+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) distPref <- findDistPrefOrDefault (setupDistPref common) elbi <- tryGetBuildConfig globalFlags hooks verbosity distPref let common' =@@ -571,11 +629,11 @@ cleanHook hooks pkg_descr () hooks flags' postClean hooks args flags' pkg_descr () -copyAction :: GlobalFlags -> UserHooks -> CopyFlags -> Args -> IO ()-copyAction globalFlags hooks flags args = do+copyAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> CopyFlags -> Args -> IO ()+copyAction verbHandles globalFlags hooks flags args = do let common = copyCommonFlags flags- verbosity = fromFlag $ setupVerbosity common- (_lbi, common') <- getCommonFlags globalFlags hooks common args+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{copyCommonFlags = common'} distPref = fromFlag $ setupDistPref common' hookedAction@@ -588,11 +646,11 @@ flags' args -installAction :: GlobalFlags -> UserHooks -> InstallFlags -> Args -> IO ()-installAction globalFlags hooks flags args = do+installAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> InstallFlags -> Args -> IO ()+installAction verbHandles globalFlags hooks flags args = do let common = installCommonFlags flags- verbosity = fromFlag $ setupVerbosity common- (_lbi, common') <- getCommonFlags globalFlags hooks common args+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{installCommonFlags = common'} distPref = fromFlag $ setupDistPref common' hookedAction@@ -606,20 +664,20 @@ args -- Since Cabal-3.4 UserHooks are completely ignored-sdistAction :: GlobalFlags -> UserHooks -> SDistFlags -> Args -> IO ()-sdistAction _globalFlags _hooks flags _args = do+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 (setupVerbosity $ sDistCommonFlags flags)+ verbosity = mkVerbosity verbHandles $ fromFlag (setupVerbosity $ sDistCommonFlags flags) -testAction :: GlobalFlags -> UserHooks -> TestFlags -> Args -> IO ()-testAction globalFlags hooks flags args = do+testAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> TestFlags -> Args -> IO ()+testAction verbHandles globalFlags hooks flags args = do let common = testCommonFlags flags- verbosity = fromFlag $ setupVerbosity common- (_lbi, common') <- getCommonFlags globalFlags hooks common args+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{testCommonFlags = common'} distPref = fromFlag $ setupDistPref common' hookedActionWithArgs@@ -632,11 +690,11 @@ flags' args -benchAction :: GlobalFlags -> UserHooks -> BenchmarkFlags -> Args -> IO ()-benchAction globalFlags hooks flags args = do+benchAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> BenchmarkFlags -> Args -> IO ()+benchAction verbHandles globalFlags hooks flags args = do let common = benchmarkCommonFlags flags- verbosity = fromFlag $ setupVerbosity common- (_lbi, common') <- getCommonFlags globalFlags hooks common args+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{benchmarkCommonFlags = common'} distPref = fromFlag $ setupDistPref common' hookedActionWithArgs@@ -649,11 +707,11 @@ flags' args -registerAction :: GlobalFlags -> UserHooks -> RegisterFlags -> Args -> IO ()-registerAction globalFlags hooks flags args = do+registerAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> RegisterFlags -> Args -> IO ()+registerAction verbHandles globalFlags hooks flags args = do let common = registerCommonFlags flags- verbosity = fromFlag $ setupVerbosity common- (_lbi, common') <- getCommonFlags globalFlags hooks common args+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{registerCommonFlags = common'} distPref = fromFlag $ setupDistPref common' hookedAction@@ -666,11 +724,11 @@ flags' args -unregisterAction :: GlobalFlags -> UserHooks -> RegisterFlags -> Args -> IO ()-unregisterAction globalFlags hooks flags args = do+unregisterAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> RegisterFlags -> Args -> IO ()+unregisterAction verbHandles globalFlags hooks flags args = do let common = registerCommonFlags flags- verbosity = fromFlag $ setupVerbosity common- (_lbi, common') <- getCommonFlags globalFlags hooks common args+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{registerCommonFlags = common'} distPref = fromFlag $ setupDistPref common' hookedAction@@ -760,14 +818,14 @@ 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'@@ -828,18 +886,18 @@ , configCommonFlags = (configCommonFlags cFlags) { -- Use the current, not saved verbosity level:- setupVerbosity = Flag verbosity+ setupVerbosity = Flag $ verbosityFlags verbosity } }- configureAction globalFlags hooks cFlags' (extraConfigArgs lbi)+ configureAction (verbosityHandles verbosity) globalFlags hooks cFlags' (extraConfigArgs lbi) -- -------------------------------------------------------------------------- -- Cleaning -clean :: PackageDescription -> CleanFlags -> IO ()-clean pkg_descr flags = do+clean :: VerbosityHandles -> PackageDescription -> CleanFlags -> IO ()+clean verbHandles pkg_descr flags = do let common = cleanCommonFlags flags- verbosity = fromFlag (setupVerbosity common)+ 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@@ -853,23 +911,14 @@ -- remove the whole dist/ directory rather than tracking exactly what files -- we created in there.- chattyTry "removing dist/" $ do- exists <- doesDirectoryExist distPath- when exists (removeDirectoryRecursive distPath)+ chattyTry verbosity "removing dist/" $ do+ removePathForcibly distPath -- Any extra files the user wants to remove- traverse_ (removeFileOrDirectory . i) (extraTmpFiles pkg_descr)+ traverse_ (removePathForcibly . i) (extraTmpFiles pkg_descr) -- If the user wanted to save the config, write it back traverse_ (writePersistBuildConfig mbWorkDir 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 -- -------------------------------------------------------------------------- -- Default hooks@@ -877,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- instHook = defaultInstallHook- , testHook = defaultTestHook- , benchHook = defaultBenchHook- , 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 (setupVerbosity $ configCommonFlags flags)+ verbosity =+ mkVerbosity verbHandles $+ fromFlag (setupVerbosity $ configCommonFlags flags) -- | Basic autoconf 'UserHooks': --@@ -935,9 +994,10 @@ defaultPostConf args flags pkg_descr lbi = do let common = configCommonFlags flags- verbosity = fromFlag $ setupVerbosity common+ verbosity = mkVerbosity defaultVerbosityHandles (fromFlag $ setupVerbosity common) mbWorkDir = flagToMaybe $ setupWorkingDir common runConfigureScript+ defaultVerbosityHandles flags (flagAssignment lbi) (withPrograms lbi)@@ -955,7 +1015,7 @@ -> IO HookedBuildInfo readHookWithArgs get_common_flags _args flags = do let common = get_common_flags flags- verbosity = fromFlag (setupVerbosity common)+ verbosity = mkVerbosity defaultVerbosityHandles (fromFlag (setupVerbosity common)) mbWorkDir = flagToMaybe $ setupWorkingDir common distPref = setupDistPref common dist_dir <- findDistPrefOrDefault distPref@@ -968,7 +1028,7 @@ -> IO HookedBuildInfo readHook get_common_flags args flags = do let common = get_common_flags flags- verbosity = fromFlag (setupVerbosity common)+ verbosity = mkVerbosity defaultVerbosityHandles (fromFlag (setupVerbosity common)) mbWorkDir = flagToMaybe $ setupWorkingDir common distPref = setupDistPref common noExtraFlags args@@ -1012,7 +1072,7 @@ , LBC.hostPlatform = plat } }- ) = runConfigureScript cfg flags progs plat+ ) = runConfigureScript defaultVerbosityHandles cfg flags progs plat pre_conf_comp :: SetupHooks.PreConfComponentInputs@@ -1027,7 +1087,7 @@ , SetupHooks.component = component } ) = do- let verbosity = fromFlag $ configVerbosity cfg+ let verbosity = mkVerbosity defaultVerbosityHandles (fromFlag $ configVerbosity cfg) mbWorkDir = flagToMaybe $ configWorkingDir cfg distPref = configDistPref cfg dist_dir <- findDistPrefOrDefault distPref@@ -1048,48 +1108,52 @@ } 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 =- defaultInstallHook_setupHooks SetupHooks.noInstallHooks+defaultInstallHook verbHandles =+ defaultInstallHook_setupHooks SetupHooks.noInstallHooks verbHandles defaultInstallHook_setupHooks :: SetupHooks.InstallHooks+ -> VerbosityHandles -> PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO ()-defaultInstallHook_setupHooks inst_hooks pkg_descr localbuildinfo _ flags = do+defaultInstallHook_setupHooks inst_hooks verbHandles pkg_descr localbuildinfo _ flags = do let copyFlags = defaultCopyFlags { copyDest = installDest flags , copyCommonFlags = installCommonFlags flags }- install_setupHooks inst_hooks pkg_descr localbuildinfo copyFlags+ install_setupHooks inst_hooks verbHandles pkg_descr localbuildinfo copyFlags let registerFlags = defaultRegisterFlags { regInPlace = installInPlace flags@@ -1097,38 +1161,60 @@ , registerCommonFlags = installCommonFlags flags } when (hasLibs pkg_descr) $- register pkg_descr localbuildinfo registerFlags+ 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 (setupVerbosity $ registerCommonFlags 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,6 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} -----------------------------------------------------------------------------@@ -25,7 +24,7 @@ import qualified Distribution.PackageDescription as PD import Distribution.Pretty-import Distribution.Simple.Build (addInternalBuildToolsFixed)+import Distribution.Simple.Build (addInternalBuildTools) import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler import Distribution.Simple.Errors@@ -42,6 +41,7 @@ import Distribution.Types.Benchmark (Benchmark (benchmarkBuildInfo)) import Distribution.Types.UnqualComponentName import Distribution.Utils.Path+import Distribution.Verbosity import System.Directory (doesFileExist) @@ -49,6 +49,7 @@ bench :: Args -- ^ positional command-line arguments+ -> VerbosityHandles -> PD.PackageDescription -- ^ information from the .cabal file -> LBI.LocalBuildInfo@@ -56,9 +57,9 @@ -> BenchmarkFlags -- ^ flags sent to benchmark -> IO ()-bench args pkg_descr lbi flags = do+bench args verbHandles pkg_descr lbi flags = do curDir <- LBI.absoluteWorkingDirLBI lbi- let verbosity = fromFlag $ benchmarkVerbosity flags+ let verbosity = mkVerbosity verbHandles (fromFlag $ benchmarkVerbosity flags) benchmarkNames = args pkgBenchmarks = PD.benchmarks pkg_descr enabledBenchmarks = LBI.enabledBenchLBIs pkg_descr lbi@@ -72,8 +73,8 @@ lbi { -- Include any build-tool-depends on build tools internal to the current package. LBI.withPrograms =- addInternalBuildToolsFixed- (Just curDir)+ addInternalBuildTools+ curDir pkg_descr lbi (benchmarkBuildInfo bm)
src/Distribution/Simple/Build.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} @@ -26,6 +26,7 @@ ( -- * Build build , build_setupHooks+ , buildComponent -- * Repl , repl@@ -34,6 +35,8 @@ -- * Build preparation , preBuildComponent+ , runPreBuildHooks+ , builtinPreBuildHooks , AutogenFile (..) , AutogenFileContents , writeBuiltinAutogenFiles@@ -48,7 +51,6 @@ -- * Handling of internal build tools , addInternalBuildTools- , addInternalBuildToolsFixed ) where import Distribution.Compat.Prelude@@ -74,7 +76,6 @@ 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 @@ -94,11 +95,11 @@ 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@@ -108,9 +109,8 @@ import Distribution.Simple.Setup.Config import Distribution.Simple.Setup.Repl import Distribution.Simple.SetupHooks.Internal- ( BuildHooks (..)- , BuildingWhat (..)- , noBuildHooks+ ( BuildingWhat (..)+ , buildingWhatVerbosity ) import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks import qualified Distribution.Simple.SetupHooks.Rule as SetupHooks@@ -130,8 +130,7 @@ import Control.Monad import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as Map-import Distribution.Simple.Errors-import System.Directory (doesFileExist, removeFile)+ import System.FilePath (takeDirectory) -- -----------------------------------------------------------------------------@@ -147,10 +146,17 @@ -> [PPSuffixHandler] -- ^ preprocessors to run before compiling -> IO ()-build = build_setupHooks noBuildHooks+build pkg lbi flags pps =+ void $ build_setupHooks noHooks defaultVerbosityHandles pkg lbi flags pps+ where+ noHooks = (const $ return [], const $ return ()) build_setupHooks- :: BuildHooks+ :: ( SetupHooks.PreBuildComponentInputs -> IO [SetupHooks.MonitorFilePath]+ , SetupHooks.PostBuildComponentInputs -> IO ()+ )+ -- ^ build hooks+ -> VerbosityHandles -> PackageDescription -- ^ Mostly information from the .cabal file -> LocalBuildInfo@@ -159,15 +165,20 @@ -- ^ Flags that the user passed to build -> [PPSuffixHandler] -- ^ preprocessors to run before compiling- -> IO ()+ -> IO [SetupHooks.MonitorFilePath] build_setupHooks- (BuildHooks{preBuildComponentRules = mbPbcRules, postBuildComponentHook = mbPostBuild})+ (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+ targets <- readTargetInfos verbosity pkg_descr lbi (buildTargets flags)+ let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) info verbosity $ "Component build order: "@@ -192,36 +203,26 @@ curDir <- absoluteWorkingDirLBI lbi -- Now do the actual building- (\f -> foldM_ f (installedPkgs lbi) componentsToBuild) $ \index target -> do+ (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' = addInternalBuildToolsFixed (Just curDir) pkg_descr lbi bi (withPrograms lbi)+ progs' = addInternalBuildTools curDir pkg_descr lbi bi (withPrograms lbi) lbi' = lbi { withPrograms = progs' , withPackageDB = withPackageDB lbi ++ [internalPackageDB] , installedPkgs = index }- runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO ()- runPreBuildHooks lbi2 tgt =- let inputs =- SetupHooks.PreBuildComponentInputs- { SetupHooks.buildingWhat = BuildNormal flags- , SetupHooks.localBuildInfo = lbi2- , SetupHooks.targetInfo = tgt- }- in for_ mbPbcRules $ \pbcRules -> do- (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules- SetupHooks.executeRules verbosity lbi2 tgt ruleFromId- preBuildComponent runPreBuildHooks verbosity lbi' target+ 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"+ warn verbosity "Ignoring -j due to --semaphore" return $ UseSem sem_name NoFlag -> return $ UseSem sem_name NoFlag -> return $ case numJobs of@@ -229,6 +230,7 @@ NoFlag -> Serial mb_ipi <- buildComponent+ verbHandles flags par_strat pkg_descr@@ -243,19 +245,16 @@ , SetupHooks.localBuildInfo = lbi' , SetupHooks.targetInfo = target }- for_ mbPostBuild ($ postBuildInputs)- return (maybe index (Index.insert `flip` index) mb_ipi)+ postBuildHook postBuildInputs+ return (monsAcc <> mons, maybe index (`Index.insert` index) mb_ipi) - return ()- where- distPref = fromFlag (buildDistPref flags)- verbosity = fromFlag (buildVerbosity flags)+ 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.@@ -305,10 +304,9 @@ ++ unlines warns LBS.writeFile buildInfoFile buildInfoText - when (not shouldDumpBuildInfo) $ do+ unless shouldDumpBuildInfo $ -- Remove existing build-info.json as it might be outdated now.- exists <- doesFileExist buildInfoFile- when exists $ removeFile buildInfoFile+ removeFileForcibly buildInfoFile where buildInfoFile = interpretSymbolicPathLBI lbi $ buildInfoPref distPref shouldDumpBuildInfo = fromFlagOrDefault NoDumpBuildInfo dumpBuildInfoFlag == DumpBuildInfo@@ -320,7 +318,6 @@ flavorToProgram GHCJS = Just ghcjsProgram flavorToProgram UHC = Just uhcProgram flavorToProgram JHC = Just jhcProgram- flavorToProgram HaskellSuite{} = Just haskellSuiteProgram flavorToProgram _ = Nothing repl@@ -334,11 +331,21 @@ -- ^ preprocessors to run before compiling -> [String] -> IO ()-repl = repl_setupHooks noBuildHooks+repl pkg lbi flags pps args =+ void $+ repl_setupHooks+ (const $ return [])+ defaultVerbosityHandles+ pkg+ lbi+ flags+ pps+ args repl_setupHooks- :: BuildHooks- -- ^ build hook+ :: (SetupHooks.PreBuildComponentInputs -> IO [SetupHooks.MonitorFilePath])+ -- ^ pre-build hook+ -> VerbosityHandles -> PackageDescription -- ^ Mostly information from the .cabal file -> LocalBuildInfo@@ -348,25 +355,26 @@ -> [PPSuffixHandler] -- ^ preprocessors to run before compiling -> [String]- -> IO ()+ -> IO [SetupHooks.MonitorFilePath] repl_setupHooks- (BuildHooks{preBuildComponentRules = mbPbcRules})+ preBuildHook+ verbHandles pkg_descr lbi flags suffixHandlers args = do let distPref = fromFlag (replDistPref flags)- verbosity = fromFlag (replVerbosity flags)+ verbosity = mkVerbosity verbHandles $ fromFlag (replVerbosity flags) target <-- readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of+ readTargetInfos verbosity pkg_descr lbi args >>= \case -- This seems DEEPLY questionable. [] -> case allTargetsInBuildOrder' pkg_descr lbi of (target : _) -> return target- [] -> dieWithException verbosity $ FailedToDetermineTarget+ [] -> dieWithException verbosity FailedToDetermineTarget [target] -> return target- _ -> dieWithException verbosity $ NoMultipleTargets+ _ -> dieWithException verbosity NoMultipleTargets let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target] debug verbosity $ "Component build order: "@@ -386,34 +394,26 @@ { withPackageDB = withPackageDB lbi' ++ [internalPackageDB] , withPrograms = -- Include any build-tool-depends on build tools internal to the current package.- addInternalBuildToolsFixed- (Just curDir)+ addInternalBuildTools+ curDir pkg_descr lbi' (componentBuildInfo comp) (withPrograms lbi') }- runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO ()- runPreBuildHooks lbi2 tgt =- let inputs =- SetupHooks.PreBuildComponentInputs- { SetupHooks.buildingWhat = BuildRepl flags- , SetupHooks.localBuildInfo = lbi2- , SetupHooks.targetInfo = tgt- }- in for_ mbPbcRules $ \pbcRules -> do- (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules- SetupHooks.executeRules verbosity lbi2 tgt ruleFromId+ pbci lbi' tgt = SetupHooks.PreBuildComponentInputs (BuildRepl flags) lbi' tgt - -- build any dependent components- sequence_- [ do- let clbi = targetCLBI subtarget- comp = targetComponent subtarget- lbi' <- lbiForComponent comp lbi- preBuildComponent runPreBuildHooks verbosity lbi' subtarget+ -- 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+ monitors <- preBuildComponent (preBuildHook (pbci lbi' subtarget)) verbosity lbi' subtarget++ _mb_ipi <- buildComponent- (mempty{buildCommonFlags = mempty{setupVerbosity = toFlag verbosity}})+ verbHandles+ (mempty{buildCommonFlags = mempty{setupVerbosity = toFlag $ verbosityFlags verbosity}}) NoFlag pkg_descr lbi'@@ -421,16 +421,21 @@ comp clbi distPref- | subtarget <- safeInit componentsToBuild- ] + return monitors+ -- REPL for target components let clbi = targetCLBI target comp = targetComponent target lbi' <- lbiForComponent comp lbi- preBuildComponent runPreBuildHooks verbosity lbi' target++ 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@@ -446,7 +451,8 @@ _ -> dieWithException verbosity REPLNotSupported buildComponent- :: BuildFlags+ :: VerbosityHandles+ -> BuildFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo@@ -455,13 +461,14 @@ -> ComponentLocalBuildInfo -> SymbolicPath Pkg (Dir Dist) -> IO (Maybe InstalledPackageInfo)-buildComponent flags _ _ _ _ (CTest TestSuite{testInterface = TestSuiteUnsupported tt}) _ _ =- dieWithException (fromFlag $ buildVerbosity flags) $+buildComponent verbHandles flags _ _ _ _ (CTest TestSuite{testInterface = TestSuiteUnsupported tt}) _ _ =+ dieWithException (mkVerbosity verbHandles $ fromFlag $ buildVerbosity flags) $ NoSupportBuildingTestSuite tt-buildComponent flags _ _ _ _ (CBench Benchmark{benchmarkInterface = BenchmarkUnsupported tt}) _ _ =- dieWithException (fromFlag $ buildVerbosity flags) $+buildComponent verbHandles flags _ _ _ _ (CBench Benchmark{benchmarkInterface = BenchmarkUnsupported tt}) _ _ =+ dieWithException (mkVerbosity verbHandles $ fromFlag $ buildVerbosity flags) $ NoSupportBuildingBenchMark tt buildComponent+ verbHandles flags numJobs pkg_descr@@ -478,7 +485,7 @@ distPref = do inplaceDir <- absoluteWorkingDirLBI lbi0- let verbosity = fromFlag $ buildVerbosity flags+ let verbosity = mkVerbosity verbHandles $ fromFlag $ buildVerbosity flags let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) = testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 inplaceDir distPref preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers@@ -492,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.@@ -514,6 +521,7 @@ buildExe verbosity numJobs pkg_descr lbi exe' exeClbi return Nothing -- Can't depend on test suite buildComponent+ verbHandles flags numJobs pkg_descr@@ -523,7 +531,7 @@ clbi distPref = do- let verbosity = fromFlag $ buildVerbosity flags+ let verbosity = mkVerbosity verbHandles $ fromFlag $ buildVerbosity flags preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers extras <- preprocessExtras verbosity comp lbi setupMessage'@@ -542,18 +550,17 @@ 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.@@ -571,7 +578,7 @@ lib' lbi clbi- debug verbosity $ "Registering inplace:\n" ++ (IPI.showInstalledPackageInfo installedPkgInfo)+ debug verbosity $ "Registering inplace:\n" ++ IPI.showInstalledPackageInfo installedPkgInfo registerPackage verbosity (compiler lbi)@@ -620,8 +627,8 @@ -> Verbosity -> IO (SymbolicPath Pkg (Dir Source), [ModuleName.ModuleName]) generateCode codeGens nm pdesc bi lbi clbi verbosity = do- when (not . null $ codeGens) $ createDirectoryIfMissingVerbose verbosity True $ i 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@@ -630,6 +637,7 @@ 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@@ -640,7 +648,7 @@ (withPrograms lbi) ( 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) ) ) @@ -724,7 +732,7 @@ 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@@ -735,29 +743,30 @@ clbi _ = do+ 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"@@ -879,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@@ -914,7 +922,7 @@ createInternalPackageDB verbosity lbi distPref = do existsAlready <- doesPackageDBExist dbPath when existsAlready $ deletePackageDB dbPath- createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath+ createPackageDB verbosity (compiler lbi) (withPrograms lbi) dbPath return (SpecificPackageDB dbRelPath) where dbRelPath = internalPackageDBPath lbi distPref@@ -931,18 +939,14 @@ -- 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.------ NB: This function will be removed in the next Cabal major version--- (use addInternalBuildTools instead). This function is introduced solely for--- backporting in a PVP compliant way.-addInternalBuildToolsFixed- :: Maybe (AbsolutePath (Dir Pkg))+addInternalBuildTools+ :: AbsolutePath (Dir Pkg) -> PackageDescription -> LocalBuildInfo -> BuildInfo -> ProgramDb -> ProgramDb-addInternalBuildToolsFixed mpwd pkg lbi bi progs =+addInternalBuildTools pwd pkg lbi bi progs = prependProgramSearchPathNoLogging internalToolPaths [pkgDataDirVar]@@ -962,44 +966,28 @@ </> 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 =- case mpwd of- -- This is an absolute path, so if a process changes directory, it can still- -- find the datadir (#10717)- Just pwd -> interpretSymbolicPathAbsolute pwd (dataDir pkg)- -- This is just wrong, but implemented for PVP compliance..- Nothing -> interpretSymbolicPathCWD (dataDir pkg)--{-# WARNING addInternalBuildTools "This function is broken, use addInternalBuildToolsFixed instead" #-}---- | A backwards compatible (broken) version of `addInternalBuildTools`, do not--- use this function. Use 'addInternalBuildToolsFixed' instead.-addInternalBuildTools- :: PackageDescription- -> LocalBuildInfo- -> BuildInfo- -> ProgramDb- -> ProgramDb-addInternalBuildTools = addInternalBuildToolsFixed Nothing+ 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@@ -1035,33 +1023,35 @@ _ -> 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+ GHC -> GHC.replExe verbHandles flags NoFlag pkg_descr lbi exe clbi GHCJS -> GHCJS.replExe (replOptionsFlags $ replReplOptions flags)@@ -1074,16 +1064,17 @@ _ -> 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.@@ -1144,21 +1135,54 @@ -- | Creates the autogenerated files for a particular configured component, -- and runs the pre-build hook. preBuildComponent- :: (LocalBuildInfo -> TargetInfo -> IO ())+ :: IO r -- ^ pre-build hook -> Verbosity -> LocalBuildInfo -- ^ Configuration information -> TargetInfo- -> IO ()+ -> IO r preBuildComponent preBuildHook verbosity lbi tgt = do let pkg_descr = localPkgDescr lbi clbi = targetCLBI tgt compBuildDir = interpretSymbolicPathLBI lbi $ componentBuildDir lbi clbi createDirectoryIfMissingVerbose verbosity True compBuildDir writeBuiltinAutogenFiles verbosity pkg_descr lbi clbi- preBuildHook lbi tgt+ 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@@ -1199,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
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 (..)@@ -48,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,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- @@ -26,6 +27,7 @@ , haddockPref , autogenPackageModulesDir , autogenComponentModulesDir+ , preBuildRulesCacheFile , autogenPathsModuleName , autogenPackageInfoModuleName , cppHeaderName@@ -41,6 +43,7 @@ , mkSharedLibName , mkProfSharedLibName , mkStaticLibName+ , mkBytecodeLibName , mkGenericSharedBundledLibName , exeExtension , objExtension@@ -158,6 +161,15 @@ 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. @@ -320,8 +332,8 @@ -> [SymbolicPathX allowAbsolute Pkg (Dir Source)] -> [ModuleName.ModuleName] -> IO [(ModuleName.ModuleName, SymbolicPathX allowAbsolute Pkg File)]-getSourceFiles verbosity mbWorkDir dirs modules = flip traverse modules $ \m ->- fmap ((,) m) $+getSourceFiles verbosity mbWorkDir dirs modules = for modules $ \m ->+ fmap (m,) $ findFileCwdWithExtension mbWorkDir builtinHaskellSuffixes@@ -407,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
@@ -2,8 +2,9 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- @@ -41,6 +42,7 @@ , reportBuildTargetProblems ) where +import Data.Bifunctor (second) import Distribution.Compat.Prelude import Prelude () @@ -131,6 +133,9 @@ BuildTargetFile ComponentName FilePath deriving (Eq, Show, Generic) +-- | @since 3.18+deriving instance Ord BuildTarget+ instance Binary BuildTarget buildTargetComponentName :: BuildTarget -> ComponentName@@ -229,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@@ -327,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]@@ -354,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@@ -408,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 ()@@ -418,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@@ -653,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) @@ -854,6 +859,9 @@ | MatchErrorNoSuch String String deriving (Show, Eq) +-- | @since 3.18+deriving instance Ord MatchError+ instance Alternative Match where empty = mzero (<|>) = mplus@@ -906,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@@ -942,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 @@ -969,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' @@ -1017,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
@@ -1,14 +1,21 @@ {-# LANGUAGE LambdaCase #-} -module Distribution.Simple.BuildWay where+module Distribution.Simple.BuildWay+ ( BuildWay (..)+ , buildWayObjectExtension+ , buildWayInterfaceExtension+ ) where data BuildWay = StaticWay | DynWay | ProfWay | ProfDynWay deriving (Eq, Ord, Show, Read, 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_"- ProfDynWay -> "p_dyn_"+-- | 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
@@ -91,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@@ -394,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) =@@ -589,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@@ -624,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@@ -719,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,6 +1,4 @@ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} @@ -52,6 +50,7 @@ , interpretPackageDBStack , coercePackageDB , coercePackageDBStack+ , readPackageDb -- * Support for optimisation levels , OptimisationLevel (..)@@ -80,12 +79,15 @@ , profilingVanillaSupported , profilingVanillaSupportedOrUnknown , dynamicSupported+ , bytecodeArtifactsSupported , backpackSupported , arResponseFilesSupported , arDashLSupported , libraryDynDirSupported , libraryVisibilitySupported , jsemSupported+ , jsemVersion+ , reexportedAsSupported -- * Support for profiling detail levels , ProfDetailLevel (..)@@ -94,17 +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) @@ -121,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, Show, Read) instance Binary Compiler+instance NFData Compiler instance Structured Compiler showCompilerId :: Compiler -> String@@ -179,6 +193,7 @@ (Just . compilerCompat $ c) (Just . map fst . compilerLanguages $ c) (Just . map fst . compilerExtensions $ c)+ (compilerWiredInUnitIds c) -- ------------------------------------------------------------ @@ -202,8 +217,18 @@ deriving (Eq, Generic, Ord, Show, Read, Functor, Foldable, Traversable) 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:@@ -293,22 +318,39 @@ 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@@ -326,8 +368,15 @@ 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@@ -356,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@@ -376,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.@@ -434,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).@@ -481,7 +538,7 @@ waySupported way comp = case compilerFlavor comp of GHC ->- -- Infomation about compiler ways is only accurately reported after+ -- 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]@@ -502,11 +559,13 @@ -- | Is the compiler distributed with profiling dynamic libraries profilingDynamicSupported :: Compiler -> Maybe Bool-profilingDynamicSupported comp =- -- Certainly not before this version, as it was not implemented yet.- if compilerVersion comp <= mkVersion [9, 11, 0]- then Just False- else waySupported "p_dyn" comp+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)@@ -518,6 +577,14 @@ 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@@ -563,7 +630,14 @@ 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
@@ -5,2855 +5,3093 @@ {-# 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- , configure_setupHooks- , 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.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.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.Simple.Errors-import Distribution.Types.AnnotatedId-import Distribution.Utils.Path-import Distribution.Utils.Structured (structuredDecodeOrFailIO, structuredEncode)-import System.Directory- ( canonicalizePath- , createDirectoryIfMissing- , doesFileExist- , getTemporaryDirectory- , removeFile- )-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 =- liftM (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 <- liftM 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 @.setup-config@ file.-configure- :: (GenericPackageDescription, HookedBuildInfo)- -> ConfigFlags- -> IO LocalBuildInfo-configure = configure_setupHooks noConfigureHooks--configure_setupHooks- :: ConfigureHooks- -> (GenericPackageDescription, HookedBuildInfo)- -> ConfigFlags- -> IO LocalBuildInfo-configure_setupHooks- (ConfigureHooks{preConfPackageHook, postConfPackageHook, preConfComponentHook})- (g_pkg_descr, hookedBuildInfo)- cfg = do- -- Cabal pre-configure- let verbosity = fromFlag (configVerbosity cfg)- distPref = fromFlag $ configDistPref cfg- mbWorkDir = flagToMaybe $ configWorkingDir cfg- (lbc0, comp, platform, enabledComps) <- preConfigurePackage cfg g_pkg_descr-- -- Package-wide pre-configure hook- lbc1 <-- case preConfPackageHook of- Nothing -> return lbc0- Just 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 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- }-- -- Cabal package-wide configure- (lbc2, pbd2, pkg_info) <-- finalizeAndConfigurePackage cfg lbc1 g_pkg_descr comp platform enabledComps-- -- Package-wide post-configure hook- for_ postConfPackageHook $ \postConfPkg -> do- let input =- SetupHooks.PostConfPackageInputs- { SetupHooks.localBuildConfig = lbc2- , SetupHooks.packageBuildDescr = pbd2- }- postConfPkg input-- -- Per-component pre-configure hook- pkg_descr <- do- let pkg_descr2 = LBC.localPkgDescr pbd2- applyComponentDiffs- verbosity- ( \c -> for preConfComponentHook $ \computeDiff -> do- let input =- SetupHooks.PreConfComponentInputs- { SetupHooks.localBuildConfig = lbc2- , SetupHooks.packageBuildDescr = pbd2- , SetupHooks.component = c- }- SetupHooks.PreConfComponentOutputs- { SetupHooks.componentDiff = diff- } <-- computeDiff input- return diff- )- pkg_descr2- let pbd3 = pbd2{LBC.localPkgDescr = pkg_descr}-- -- Cabal per-component configure- externalPkgDeps <- finalCheckPackage g_pkg_descr pbd3 hookedBuildInfo pkg_info- lbi <- configureComponents lbc2 pbd3 pkg_info externalPkgDeps-- writePersistBuildConfig mbWorkDir distPref lbi-- return lbi--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- 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 = 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 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 (lessVerbose verbosity) True $- interpretSymbolicPath mbWorkDir builddir-- lbc <- computeLocalBuildConfig cfg comp programDb00- return (lbc, comp, compPlatform, enabled)--computeLocalBuildConfig- :: ConfigFlags- -> Compiler- -> ProgramDb- -> IO LBC.LocalBuildConfig-computeLocalBuildConfig cfg comp programDb = do- let common = configCommonFlags cfg- verbosity = fromFlag $ setupVerbosity common- -- 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.compilerBuildWay comp `elem` [DynWay, ProfDynWay])- 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.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-- 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-- let buildOptions =- setCoverage . setProfiling $- LBC.BuildOptions- { withVanillaLib = fromFlag $ configVanillaLib cfg- , withSharedLib = withSharedLib_- , withStaticLib = withStaticLib_- , withDynExe = withDynExe_- , withFullyStaticExe = withFullyStaticExe_- , withProfLib = False- , withProfLibShared = 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- }-- -- Dynamic executable, but no shared vanilla libraries- when (LBC.withDynExe buildOptions && not (LBC.withProfExe buildOptions) && not (LBC.withSharedLib buildOptions)) $- 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."-- -- Profiled dynamic executable, but no shared profiling libraries- when (LBC.withDynExe buildOptions && LBC.withProfExe buildOptions && not (LBC.withProfLibShared buildOptions)) $- 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 $- 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) PromisedComponent- , 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 common = configCommonFlags cfg- verbosity = fromFlag $ setupVerbosity common-- -- 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- , 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 common = configCommonFlags cfg- verbosity = fromFlag $ setupVerbosity common- mbWorkDir = flagToMaybe $ setupWorkingDir common-- 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- mbWorkDir- 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], [ConfiguredPromisedComponent])-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 common = configCommonFlags cfg- verbosity = fromFlag $ setupVerbosity common- cabalFileDir = packageRoot common- use_external_internal_deps =- case enabled of- OneComponentRequestedSpec{} -> True- ComponentRequestedSpec{} -> False-- 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], [ConfiguredPromisedComponent])- -> 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 common = configCommonFlags cfg- verbosity = 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 "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 :: 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) PromisedComponent- -> 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) PromisedComponent- -> InstalledPackageIndex- -- ^ installed packages- -> Map (PackageName, ComponentName) InstalledPackageInfo- -- ^ required deps- -> PackageDescription- -> ComponentRequestedSpec- -> IO ([PreExistingComponent], [ConfiguredPromisedComponent])-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 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- -> Set LibraryName- -- ^ package libraries- -> Map (PackageName, ComponentName) PromisedComponent- -- ^ 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 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 comp mbWorkDir packageDBs' progdb- GHCJS -> GHCJS.getInstalledPackages verbosity mbWorkDir packageDBs' progdb- UHC -> UHC.getInstalledPackages verbosity comp mbWorkDir packageDBs' progdb- HaskellSuite{} ->- HaskellSuite.getInstalledPackages verbosity 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), 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 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- 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 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- (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 (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- :: ConfigFlags- -> IO (Compiler, Platform, ProgramDb)-configCompilerAuxEx cfg = do- programDb <- mkProgramDb cfg defaultProgramDb- let common = configCommonFlags cfg- verbosity = fromFlag $ setupVerbosity common- configCompilerEx- (flagToMaybe $ configHcFlavor cfg)- (flagToMaybe $ configHcPath cfg)- (flagToMaybe $ configHcPkg cfg)- programDb- verbosity--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 (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, 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 (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)- ++ "; removing "- ++ (baseDir </> hdr)- removeFile (baseDir </> 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])-- 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 =- do- tempDir <- makeSymbolicPath <$> getTemporaryDirectory- withTempFileCwd mbWorkDir tempDir ".c" $ \cName cHnd ->- withTempFileCwd mbWorkDir tempDir "" $ \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) (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---- | 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]) $- dieWithException verbosity $- NoOSSupport os "relocatable builds"- 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 $ getSymbolicPath 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 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
@@ -5,7 +5,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------{-# OPTIONS_GHC -fno-warn-deprecations #-}+{-# OPTIONS_GHC -Wno-deprecations #-} -- | -- Module : Distribution.Simple.ConfigureScript@@ -35,14 +35,14 @@ import Distribution.System (Platform, buildPlatform) import Distribution.Utils.NubList import Distribution.Utils.Path+import Distribution.Verbosity -- Base-import System.Directory (createDirectoryIfMissing, doesFileExist)+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) @@ -50,15 +50,16 @@ import qualified Data.Map as Map runConfigureScript- :: ConfigFlags+ :: VerbosityHandles+ -> ConfigFlags -> FlagAssignment -> ProgramDb -> Platform -- ^ host platform -> IO ()-runConfigureScript cfg flags programDb hp = do+runConfigureScript verbHandles cfg flags programDb hp = do let commonCfg = configCommonFlags cfg- verbosity = fromFlag $ setupVerbosity commonCfg+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity commonCfg) dist_dir <- findDistPrefOrDefault $ setupDistPref commonCfg let build_dir = dist_dir </> makeRelativePathEx "build" mbWorkDir = flagToMaybe $ setupWorkingDir commonCfg@@ -66,8 +67,7 @@ confExists <- doesFileExist configureScriptPath unless confExists $ dieWithException verbosity (ConfigureScriptNotFound configureScriptPath)- configureFile <-- makeAbsolute $ configureScriptPath+ configureFile <- makeAbsolute configureScriptPath env <- getEnvironment (ccProg, ccFlags) <- configureCCompiler verbosity programDb ccProgShort <- getShortPathName ccProg@@ -78,6 +78,18 @@ -- We don't try and tell configure which ld to use, as we don't have -- a way to pass its flags too + -- 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:@@ -159,9 +171,7 @@ ) ] let extraPath = fromNubList $ configProgramPathExtra cfg- let cflagsEnv =- maybe (unwords ccFlags) (++ (" " ++ unwords ccFlags)) $- lookup "CFLAGS" env+ let mkFlagsEnv fs var = maybe (unwords fs) (++ (" " ++ unwords fs)) (lookup var env) spSep = [FilePath.searchPathSeparator] pathEnv = maybe@@ -169,11 +179,17 @@ ((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- 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 shConfiguredProg <-
src/Distribution/Simple/Errors.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE LambdaCase #-}- ----------------------------------------------------------------------------- -- Module : Distribution.Simple.Errors@@ -31,6 +29,7 @@ import Distribution.Simple.PreProcess.Types (Suffix) import Distribution.Simple.SetupHooks.Errors import Distribution.System (OS)+import Distribution.Types.MissingDependency (MissingDependency) import Distribution.Types.VersionRange.Internal () import Distribution.Version import Text.PrettyPrint@@ -50,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@@ -79,8 +78,6 @@ | NoSupportBuildingTestSuite TestType | NoSupportBuildingBenchMark BenchmarkType | BuildingNotSupportedWithCompiler- | ProvideHaskellSuiteTool String- | CannotDetermineCompilerVersion | PkgDumpFailed | FailedToParseOutput | CantFindSourceModule ModuleName@@ -99,8 +96,7 @@ | AmbiguousBuildTarget [(String, [(String, String)])] | CheckBuildTargets String | VersionMismatchGHC FilePath Version FilePath Version- | CheckPackageDbStackPost76- | CheckPackageDbStackPre76+ | CheckPackageDbStack | GlobalPackageDbSpecifiedFirst | CantInstallForeignLib | NoSupportForPreProcessingTest TestType@@ -126,7 +122,7 @@ | CantFindForeignLibraries [String] | ExpectedAbsoluteDirectory FilePath | FlagsNotSpecified [FlagName]- | EncounteredMissingDependency [Dependency]+ | EncounteredMissingDependency [MissingDependency] | CompilerDoesn'tSupportThinning | CompilerDoesn'tSupportReexports | CompilerDoesn'tSupportBackpack@@ -172,6 +168,8 @@ | UnknownVersionDb String VersionRange FilePath | MissingCoveredInstalledLibrary UnitId | SetupHooksException SetupHooksException+ | MultiReplDoesNotSupportComplexReexportedModules PackageName ComponentName+ | StandaloneBytecodeNotSupportedYet deriving (Show) exceptionCode :: CabalException -> Int@@ -211,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@@ -231,8 +229,8 @@ AmbiguousBuildTarget{} -> 7865 CheckBuildTargets{} -> 4733 VersionMismatchGHC{} -> 4000- CheckPackageDbStackPost76{} -> 3000- CheckPackageDbStackPre76{} -> 5640+ CheckPackageDbStack{} -> 3000+ -- Retired: CheckPackageDbStackPre76{} -> 5640 GlobalPackageDbSpecifiedFirst{} -> 2345 CantInstallForeignLib{} -> 8221 NoSupportForPreProcessingTest{} -> 3008@@ -305,6 +303,8 @@ MissingCoveredInstalledLibrary{} -> 9341 SetupHooksException err -> setupHooksExceptionCode err+ MultiReplDoesNotSupportComplexReexportedModules{} -> 9355+ StandaloneBytecodeNotSupportedYet -> 9356 versionRequirement :: VersionRange -> String versionRequirement range@@ -319,10 +319,10 @@ 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+ 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@@ -365,8 +365,6 @@ 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@@ -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"@@ -552,7 +546,7 @@ . nest 4 . sep . punctuate comma- . map (pretty . simplifyDependency)+ . map pretty $ missing ) CompilerDoesn'tSupportThinning ->@@ -800,3 +794,15 @@ ++ "' 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
@@ -39,6 +39,7 @@ import qualified Distribution.Compat.CharParsing as P import Distribution.Parsec import Distribution.Pretty+import Distribution.Utils.Generic (isAsciiAlpha) import qualified Text.PrettyPrint as Disp --------------------------------------------------------------------------------@@ -211,7 +212,7 @@ root = FilePathRoot "/" <$ P.char '/' home = FilePathHomeDir <$ P.string "~/" drive = do- dr <- P.satisfy $ \c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')+ 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, 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,11 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- @@ -42,6 +42,8 @@ module Distribution.Simple.GHC ( getGhcInfo , configure+ , configureCompiler+ , compilerProgramDb , getInstalledPackages , getInstalledPackagesMonitorFiles , getPackageDBContents@@ -59,7 +61,6 @@ , hcPkgInfo , registerPackage , Internal.componentGhcOptions- , Internal.componentCcGhcOptions , getGhcAppDir , getLibDir , compilerBuildWay@@ -86,11 +87,10 @@ 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@@ -98,6 +98,7 @@ import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler import Distribution.Simple.Errors+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@@ -141,7 +142,7 @@ , doesDirectoryExist , doesFileExist , getAppUserDataDirectory- , getDirectoryContents+ , listDirectory #ifndef mingw32_HOST_OS , renameFile #endif@@ -154,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.14- -- ... and the following odd development version- unless (ghcVersion < mkVersion [9, 14]) $- 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.14): "+ ++ " 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.@@ -247,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@@ -258,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:@@ -411,14 +493,13 @@ -- | Given a package DB stack, return all installed packages. getInstalledPackages :: Verbosity- -> Compiler -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBStackX (SymbolicPath from (Dir PkgDB)) -> ProgramDb -> IO InstalledPackageIndex-getInstalledPackages verbosity comp mbWorkDir packagedbs progdb = do+getInstalledPackages verbosity mbWorkDir packagedbs progdb = do checkPackageDbEnvVar verbosity- checkPackageDbStack verbosity comp packagedbs+ checkPackageDbStack verbosity packagedbs pkgss <- getInstalledPackages' verbosity mbWorkDir packagedbs progdb index <- toPackageIndex verbosity pkgss progdb return $! hackRtsPackage index@@ -426,7 +507,7 @@ 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. @@ -498,39 +579,13 @@ checkPackageDbEnvVar verbosity = Internal.checkPackageDbEnvVar verbosity "GHC" "GHC_PACKAGE_PATH" -checkPackageDbStack :: Eq fp => Verbosity -> Compiler -> PackageDBStackX fp -> IO ()-checkPackageDbStack verbosity comp =- if flagPackageConf implInfo- then checkPackageDbStackPre76 verbosity- else checkPackageDbStackPost76 verbosity- where- implInfo = ghcVersionImplInfo (compilerVersion comp)--checkPackageDbStackPost76 :: Eq fp => Verbosity -> PackageDBStackX fp -> 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 :: Eq fp => Verbosity -> PackageDBStackX fp -> 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'@@ -585,15 +640,16 @@ -- 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 $+buildLib verbHandles flags numJobs pkg lbi lib clbi =+ GHC.build numJobs verbHandles pkg $ PreBuildComponentInputs { buildingWhat = BuildNormal flags , localBuildInfo = lbi@@ -601,15 +657,16 @@ } replLib- :: ReplFlags+ :: VerbosityHandles+ -> ReplFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO ()-replLib flags numJobs pkg lbi lib clbi =- GHC.build numJobs pkg $+replLib verbHandles flags numJobs pkg lbi lib clbi =+ GHC.build numJobs verbHandles pkg $ PreBuildComponentInputs { buildingWhat = BuildRepl flags , localBuildInfo = lbi@@ -630,8 +687,10 @@ { ghcOptMode = toFlag GhcModeInteractive , ghcOptPackageDBs = packageDBs }- checkPackageDbStack verbosity comp packageDBs+ checkPackageDbStack verbosity packageDBs (ghcProg, _) <- requireProgram verbosity ghcProgram progdb+ -- 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 -- -----------------------------------------------------------------------------@@ -647,28 +706,29 @@ -> ComponentLocalBuildInfo -> IO () buildFLib v numJobs pkg lbi flib clbi =- GHC.build numJobs pkg $+ GHC.build numJobs (verbosityHandles v) pkg $ PreBuildComponentInputs { buildingWhat = BuildNormal $ mempty { buildCommonFlags =- mempty{setupVerbosity = toFlag v}+ 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 $+replFLib verbHandles replFlags njobs pkg lbi flib clbi =+ GHC.build njobs verbHandles pkg $ PreBuildComponentInputs { buildingWhat = BuildRepl replFlags , localBuildInfo = lbi@@ -685,28 +745,29 @@ -> ComponentLocalBuildInfo -> IO () buildExe v njobs pkg lbi exe clbi =- GHC.build njobs pkg $+ GHC.build njobs (verbosityHandles v) pkg $ PreBuildComponentInputs { buildingWhat = BuildNormal $ mempty { buildCommonFlags =- mempty{setupVerbosity = toFlag v}+ 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 $+replExe verbHandles replFlags njobs pkg lbi exe clbi =+ GHC.build njobs verbHandles pkg $ PreBuildComponentInputs { buildingWhat = BuildRepl replFlags , localBuildInfo = lbi@@ -729,7 +790,7 @@ 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@@ -741,7 +802,7 @@ , ghcOptFPic = toFlag True , ghcOptHiSuffix = toFlag "dyn_hi" , ghcOptObjSuffix = toFlag "dyn_o"- , ghcOptExtra = hcOptions GHC libBi ++ hcSharedOptions GHC libBi+ , ghcOptExtra = hcSharedOptions GHC libBi } profArgs = vanillaArgs@@ -753,7 +814,7 @@ (withProfLibDetail lbi) , ghcOptHiSuffix = toFlag "p_hi" , ghcOptObjSuffix = toFlag "p_o"- , ghcOptExtra = hcOptions GHC libBi ++ hcProfOptions GHC libBi+ , ghcOptExtra = hcProfOptions GHC libBi } profDynArgs = vanillaArgs@@ -767,7 +828,7 @@ , ghcOptFPic = toFlag True , ghcOptHiSuffix = toFlag "p_dyn_hi" , ghcOptObjSuffix = toFlag "p_dyn_o"- , ghcOptExtra = hcOptions GHC libBi ++ hcProfSharedOptions GHC libBi+ , ghcOptExtra = hcProfSharedOptions GHC libBi } ghcArgs = let (libWays, _, _) = buildWays lbi@@ -856,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'.@@ -868,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)@@ -880,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@@ -889,12 +948,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 let (wantedLibWays, _, _) = buildWays lbi isIndef = componentIsIndefinite clbi@@ -903,7 +964,7 @@ info verbosity ("Wanted install ways: " ++ show libWays) -- copy .hi files over:- forM_ (wantedLibWays isIndef) $ \w -> case w of+ forM_ (wantedLibWays isIndef) $ \case StaticWay -> copyModuleFiles (Suffix "hi") DynWay -> copyModuleFiles (Suffix "dyn_hi") ProfWay -> copyModuleFiles (Suffix "p_hi")@@ -914,7 +975,11 @@ -- copy the built library files over: when (has_code && hasLib) $ do- forM_ libWays $ \w -> case w of+ -- 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@@ -924,7 +989,7 @@ | l <- getHSLibraryName (componentUnitId clbi)- : (extraBundledLibs (libBuildInfo lib))+ : extraBundledLibs (libBuildInfo lib) , f <- "" : extraLibFlavours (libBuildInfo lib) ] whenGHCi $ installOrdinary builtDir targetDir ghciLibName@@ -963,7 +1028,7 @@ ] sequence_ [ do- files <- getDirectoryContents (i builtDir)+ files <- listDirectory (i builtDir) let l' = mkGenericSharedBundledLibName platform@@ -987,7 +1052,7 @@ builtDir = componentBuildDir lbi clbi mbWorkDir = mbWorkDirLBI lbi - install isShared srcDir dstDir name = do+ install isShared shouldStrip srcDir dstDir name = do let src = i $ srcDir </> makeRelativePathEx name dst = dstDir </> name @@ -997,15 +1062,16 @@ 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 = do files <- findModuleFilesCwd verbosity mbWorkDir [builtDir] [ext] (allLibModules lib clbi)@@ -1023,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 @@ -1039,27 +1106,14 @@ _ -> False has_code = not (componentIsIndefinite clbi) whenGHCi = when (hasLib && withGHCiLib 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
src/Distribution/Simple/GHC/Build.hs view
@@ -5,7 +5,8 @@ import Distribution.Compat.Prelude import Prelude () -import Control.Monad.IO.Class+import qualified Distribution.Compat.Graph as Graph+ import Distribution.PackageDescription as PD hiding (buildInfo) import Distribution.Simple.Build.Inputs import Distribution.Simple.Flag (Flag)@@ -24,6 +25,9 @@ import Distribution.Utils.NubList (fromNubListR) import Distribution.Utils.Path +import Distribution.Verbosity (VerbosityHandles, mkVerbosity, verbosityHandles)++import Control.Monad.IO.Class import System.FilePath (splitDirectories) {- Note [Build Target Dir vs Target Dir]@@ -64,16 +68,17 @@ -- 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+ verbosity = mkVerbosity verbHandles $ buildVerbosity pbci isLib = buildIsLib pbci lbi = localBuildInfo pbci- bi = buildBI pbci+ comp = buildComponent pbci clbi = buildCLBI pbci isIndef = componentIsIndefinite clbi mbWorkDir = mbWorkDirLBI lbi@@ -116,9 +121,35 @@ let wantedWays@(wantedLibWays, wantedFLibWay, wantedExeWay) = buildWays lbi -- Ways which are needed due to the compiler configuration- let doingTH = usesTemplateHaskellOrQQ bi+ 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++ -- 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 buildComponent pbci of+ wantedModBuildWays = case comp of CLib _ -> wantedLibWays isIndef CFLib fl -> [wantedFLibWay (withDynFLib fl)] CExe _ -> [wantedExeWay]@@ -127,14 +158,14 @@ finalModBuildWays = wantedModBuildWays ++ [defaultGhcWay | doingTH && defaultGhcWay `notElem` wantedModBuildWays]- compNameStr = showComponentName $ componentName $ buildComponent pbci+ 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).- (mbMainFile, inputModules) <- componentInputs buildTargetDir pkg_descr pbci+ (mbMainFile, inputModules) <- componentInputs buildTargetDir verbHandles pkg_descr pbci let (hsMainFile, nonHsMainFile) = case mbMainFile of Just mainFile@@ -144,10 +175,11 @@ | otherwise -> (Nothing, Just mainFile) Nothing -> (Nothing, Nothing)- buildOpts <- buildHaskellModules numJobs ghcProg hsMainFile inputModules buildTargetDir finalModBuildWays pbci- extraSources <- buildAllExtraSources nonHsMainFile ghcProg buildTargetDir wantedWays pbci+ 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)
src/Distribution/Simple/GHC/Build/ExtraSources.hs view
@@ -10,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@@ -19,14 +20,14 @@ import Distribution.Types.TargetInfo import Distribution.Simple.Build.Inputs-import Distribution.Simple.GHC.Build.Modules+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.Utils.Path-import Distribution.Verbosity (Verbosity)+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.@@ -39,6 +40,8 @@ -- ^ 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 (SymbolicPath Pkg File))@@ -65,6 +68,8 @@ -- ^ 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 (SymbolicPath Pkg File))@@ -72,7 +77,7 @@ buildCSources mbMainFile = buildExtraSources "C Sources"- Internal.componentCcGhcOptions+ (Internal.splitCandCxxOptions Internal.CcProgram) ( \c -> do let cFiles = cSources (componentBuildInfo c) case c of@@ -85,7 +90,7 @@ buildCxxSources mbMainFile = buildExtraSources "C++ Sources"- Internal.componentCxxGhcOptions+ (Internal.splitCandCxxOptions Internal.CxxProgram) ( \c -> do let cxxFiles = cxxSources (componentBuildInfo c) case c of@@ -95,12 +100,12 @@ cxxFiles ++ [main] _otherwise -> cxxFiles )-buildJsSources _mbMainFile ghcProg buildTargetDir neededWays = do+buildJsSources _mbMainFile ghcProg buildTargetDir neededWays verbHandles = do Platform hostArch _ <- hostPlatform <$> localBuildInfo let hasJsSupport = hostArch == JavaScript buildExtraSources "JS Sources"- Internal.componentJsGhcOptions+ Internal.sourcesGhcOptions ( \c -> if hasJsSupport then -- JS files are C-like with GHC's JS backend: they are@@ -113,15 +118,16 @@ ghcProg buildTargetDir neededWays+ verbHandles buildAsmSources _mbMainFile = buildExtraSources "Assembler Sources"- Internal.componentAsmGhcOptions+ Internal.sourcesGhcOptions (asmSources . componentBuildInfo) buildCmmSources _mbMainFile = buildExtraSources "C-- Sources"- Internal.componentCmmGhcOptions+ Internal.sourcesGhcOptions (cmmSources . componentBuildInfo) -- | Create 'PreBuildComponentRules' for a given type of extra build sources@@ -130,7 +136,7 @@ buildExtraSources :: String -- ^ String describing the extra sources being built, for printing.- -> ( Verbosity+ -> ( VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo@@ -139,9 +145,7 @@ -> GhcOptions ) -- ^ Function to determine the @'GhcOptions'@ for the- -- invocation of GHC when compiling these extra sources (e.g.- -- @'Internal.componentCxxGhcOptions'@,- -- @'Internal.componentCmmGhcOptions'@)+ -- 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'@).@@ -154,6 +158,8 @@ -- ^ 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 (SymbolicPath Pkg File))@@ -164,11 +170,12 @@ viewSources ghcProg buildTargetDir- (neededLibWays, neededFLibWay, neededExeWay) =+ (neededLibWays, neededFLibWay, neededExeWay)+ verbHandles = \PreBuildComponentInputs{buildingWhat, localBuildInfo = lbi, targetInfo} -> do let bi = componentBuildInfo (targetComponent targetInfo)- verbosity = buildingWhatVerbosity buildingWhat+ verbosity = mkVerbosity verbHandles $ buildingWhatVerbosity buildingWhat clbi = targetCLBI targetInfo isIndef = componentIsIndefinite clbi mbWorkDir = mbWorkDirLBI lbi@@ -176,13 +183,23 @@ sources = viewSources (targetComponent targetInfo) comp = compiler lbi platform = hostPlatform lbi- runGhcProg = runGHC verbosity ghcProg comp platform+ tempFileOptions = commonSetupTempFileOptions $ buildingWhatCommonFlags buildingWhat+ runGhcProg =+ runGHCWithResponseFile+ "ghc.rsp"+ Nothing+ tempFileOptions+ verbosity+ ghcProg+ comp+ platform+ mbWorkDir buildAction :: SymbolicPath Pkg File -> IO () buildAction sourceFile = do let baseSrcOpts = componentSourceGhcOptions- verbosity+ (verbosityLevel verbosity) lbi bi clbi@@ -219,7 +236,7 @@ compileIfNeeded :: GhcOptions -> IO () compileIfNeeded opts = do needsRecomp <- checkNeedsRecompilation mbWorkDir sourceFile opts- when needsRecomp $ runGhcProg mbWorkDir opts+ when needsRecomp $ runGhcProg opts createDirectoryIfMissingVerbose verbosity True (i odir) case targetComponent targetInfo of@@ -251,8 +268,9 @@ DynWay -> compileIfNeeded sharedSrcOpts ProfWay -> compileIfNeeded profSrcOpts ProfDynWay -> compileIfNeeded profSharedSrcOpts+ -- 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,22 +1,22 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeApplications #-} module Distribution.Simple.GHC.Build.Link where import Distribution.Compat.Prelude import Prelude () +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)@@ -24,13 +24,19 @@ 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@@ -49,13 +55,10 @@ import System.Directory ( createDirectoryIfMissing , doesDirectoryExist- , doesFileExist- , removeFile , renameFile ) import System.FilePath ( isRelative- , replaceExtension ) -- | Links together the object files of the Haskell modules and extra sources@@ -65,6 +68,8 @@ 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 -> [SymbolicPath Pkg File]@@ -83,13 +88,14 @@ -> IO () linkOrLoadComponent ghcProg+ verbHandles pkg_descr extraSources (buildTargetDir, targetDir) ((wantedLibWays, wantedFLibWay, wantedExeWay), buildOpts) pbci = do let- verbosity = buildVerbosity pbci+ verbosity = mkVerbosity verbHandles $ buildVerbosity pbci target = targetInfo pbci component = buildComponent pbci what = buildingWhat pbci@@ -98,6 +104,7 @@ clbi = buildCLBI pbci isIndef = componentIsIndefinite clbi mbWorkDir = mbWorkDirLBI lbi+ tempFileOptions = commonSetupTempFileOptions $ buildingWhatCommonFlags what -- See Note [Symbolic paths] in Distribution.Utils.Path i = interpretSymbolicPathLBI lbi@@ -107,9 +114,9 @@ cleanedExtraLibDirsStatic <- liftIO $ filterM (doesDirectoryExist . i) (extraLibDirsStatic bi) let- extraSourcesObjs :: [RelativePath Artifacts File]+ extraSourcesObjs :: [SymbolicPath Pkg File] extraSourcesObjs =- [ makeRelativePathEx $ getSymbolicPath src `replaceExtension` objExtension+ [ objectFilePath buildTargetDir objExtension src | src <- extraSources ] @@ -118,10 +125,9 @@ linkerOpts rpaths = mempty { ghcOptLinkOptions =- PD.ldOptions bi- ++ [ "-static"- | withFullyStaticExe lbi- ]+ [ "-static"+ | withFullyStaticExe lbi+ ] -- Pass extra `ld-options` given -- through to GHC's linker. ++ maybe@@ -139,11 +145,7 @@ else cleanedExtraLibDirs , ghcOptLinkFrameworks = toNubListR $ map getSymbolicPath $ PD.frameworks bi , ghcOptLinkFrameworkDirs = toNubListR $ PD.extraFrameworkDirs bi- , ghcOptInputFiles =- toNubListR- [ coerceSymbolicPath $ buildTargetDir </> obj- | obj <- extraSourcesObjs- ]+ , ghcOptInputFiles = toNubListR extraSourcesObjs , ghcOptNoLink = Flag False , ghcOptRPaths = rpaths }@@ -188,16 +190,32 @@ -- exports. when (case component of CLib lib -> null (allLibModules lib clbi); _ -> False) $ warn verbosity "No exposed modules"- runReplOrWriteFlags ghcProg lbi replFlags replOpts_final (pkgName (PD.package pkg_descr)) target+ runReplOrWriteFlags+ ghcProg+ verbHandles+ lbi+ replFlags+ replOpts_final+ (pkgName (PD.package pkg_descr))+ target _otherwise -> let- runGhcProg = runGHC verbosity ghcProg comp platform mbWorkDir+ 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- when (not $ componentIsIndefinite clbi) $ do+ unless (componentIsIndefinite clbi) $ do -- If not building dynamically, we don't pass any runtime paths. liftIO $ do info verbosity "Linking..."@@ -208,7 +226,7 @@ CLib lib -> do let libWays = wantedLibWays isIndef rpaths <- get_rpaths (Set.fromList libWays)- linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg lib lbi clbi extraSources rpaths 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)@@ -223,8 +241,6 @@ -- ^ The library target build directory -> [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@@ -238,18 +254,13 @@ -> [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- common = configCommonFlags $ configFlags lbi- mbWorkDir = flagToMaybe $ setupWorkingDir common- 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 </> makeRelativePathEx (mkLibName uid) profileLibFilePath = buildTargetDir </> makeRelativePathEx (mkProfLibName uid) sharedLibFilePath =@@ -261,24 +272,20 @@ staticLibFilePath = buildTargetDir </> 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)- libInstallPath =- libdir $- absoluteComponentInstallDirs- pkg_descr- lbi- uid- NoCopyDest- sharedLibInstallPath =- libInstallPath- </> mkSharedLibName (hostPlatform lbi) compiler_id uid- profSharedLibInstallPath =- libInstallPath- </> mkProfSharedLibName (hostPlatform lbi) compiler_id uid - getObjFiles :: BuildWay -> IO [SymbolicPath Pkg File]- 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@@ -286,36 +293,11 @@ lbi clbi buildTargetDir- (buildWayPrefix way ++ objExtension)+ hs_ext True- , pure $ map (srcObjPath way) extraSources- , catMaybes- <$> sequenceA- [ findFileCwdWithExtension- mbWorkDir- [Suffix $ buildWayPrefix way ++ objExtension]- [buildTargetDir]- xPath- | ghcVersion < mkVersion [7, 2] -- ghc-7.2+ does not make _stub.o files- , x <- allLibModules lib clbi- , let xPath :: RelativePath Artifacts File- xPath = makeRelativePathEx $ ModuleName.toFilePath x ++ "_stub"- ]+ , pure $ map (objectFilePath buildTargetDir obj_ext) extraSources ] - -- Get the @.o@ path from a source path (e.g. @.hs@),- -- in the library target build directory.- srcObjPath :: BuildWay -> SymbolicPath Pkg File -> SymbolicPath Pkg File- srcObjPath way srcPath =- case symbolicPathRelative_maybe objPath of- -- Absolute path: should already be in the target build directory- -- (e.g. a preprocessed file)- -- TODO: assert this?- Nothing -> objPath- Just objRelPath -> coerceSymbolicPath buildTargetDir </> objRelPath- where- objPath = srcPath `replaceExtensionSymbolicPath` (buildWayPrefix way ++ objExtension)- -- I'm fairly certain that, just like the executable, we can keep just the -- module input list, and point to the right sources dir (as is already -- done), and GHC will pick up the right suffix (p_ for profile, dyn_ when@@ -325,37 +307,13 @@ -- 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@@ -367,16 +325,9 @@ , ghcOptDynLinkMode = toFlag GhcDynamicOnly , 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+ , ghcOptLinkLibPath = toNubListR cleanedExtraLibDirs , ghcOptLinkFrameworks = toNubListR $ map getSymbolicPath $ PD.frameworks libBi , ghcOptLinkFrameworkDirs = toNubListR $ PD.extraFrameworkDirs libBi@@ -393,16 +344,9 @@ , ghcOptDynLinkMode = toFlag GhcDynamicOnly , ghcOptInputFiles = toNubListR pdynObjectFiles , ghcOptOutputFile = toFlag profSharedLibFilePath- , -- 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 profSharedLibInstallPath- else mempty+ , ghcOptDylibName = mempty , ghcOptLinkLibs = extraLibs libBi- , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs+ , ghcOptLinkLibPath = toNubListR cleanedExtraLibDirs , ghcOptLinkFrameworks = toNubListR $ map getSymbolicPath $ PD.frameworks libBi , ghcOptLinkFrameworkDirs = toNubListR $ PD.extraFrameworkDirs libBi@@ -415,14 +359,22 @@ , 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- profDynamicObjectFiles <- getObjFiles ProfDynWay+ 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@@ -439,6 +391,10 @@ 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@@ -452,19 +408,32 @@ 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 -> (BuildWay, BuildWay -> GhcOptions) -- ^ The wanted build ways and corresponding GhcOptions that were@@ -488,16 +457,11 @@ -- assume there is a main function in another non-haskell object ghcOptLinkNoHsMain = toFlag (ghcOptInputFiles baseOpts == mempty && ghcOptInputScripts baseOpts == mempty) }- comp = compiler lbi -- Work around old GHCs not relinking in this -- situation, see #3294 let target = targetDir </> makeRelativePathEx (exeTargetName (hostPlatform lbi) targetName)- when (compilerVersion comp < mkVersion [7, 7]) $ do- let targetPath = interpretSymbolicPathLBI lbi target- e <- doesFileExist targetPath- when e (removeFile targetPath) runGhcProg linkOpts{ghcOptOutputFile = toFlag target} -- | Link a foreign library component@@ -505,7 +469,7 @@ :: ForeignLib -> BuildInfo -> LocalBuildInfo- -> (GhcOptions)+ -> GhcOptions -- ^ The linker-specific GHC options -> (BuildWay, BuildWay -> GhcOptions) -- ^ The wanted build ways and corresponding GhcOptions that were@@ -551,7 +515,7 @@ linkOpts :: GhcOptions linkOpts = case foreignLibType flib of ForeignLibNativeShared ->- (buildOpts way)+ buildOpts way `mappend` linkerOpts `mappend` rtsLinkOpts `mappend` mempty@@ -604,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@@ -708,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 @@ -716,40 +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 = fromFlag $ setupVerbosity common+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)+ tempFileOptions = commonSetupTempFileOptions common in case replOptionsFlagOutput (replReplOptions rflags) of- NoFlag -> runGHC verbosity ghcProg comp platform mbWorkDir 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 let uid = componentUnitId clbi this_unit = prettyShow uid+ getOpenModName (OpenModule _ mn) = Just mn+ getOpenModName (OpenModuleVar{}) = Nothing reexported_modules =- [ mn | LibComponentLocalBuildInfo{componentExposedModules = exposed_mods} <- [clbi], IPI.ExposedModule mn (Just{}) <- exposed_mods+ [ (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]- , case mbWorkDir of- Nothing -> []- Just wd -> ["-working-dir", getSymbolicPath wd]- ]- ++ [ ["-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")@@ -757,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,14 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TupleSections #-} module Distribution.Simple.GHC.Build.Modules ( buildHaskellModules , BuildWay (..)- , buildWayPrefix+ , buildWayObjectExtension , componentInputs ) where @@ -24,6 +22,7 @@ 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@@ -43,6 +42,7 @@ import Distribution.Types.TestSuiteInterface import Distribution.Utils.NubList import Distribution.Utils.Path+import Distribution.Verbosity (VerbosityHandles, mkVerbosity, verbosityLevel) import System.FilePath () {-@@ -54,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.@@ -112,6 +112,8 @@ -- has already been created. -> [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)@@ -119,11 +121,11 @@ -- 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 mbMainFile inputModules buildTargetDir neededLibWays 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@@ -131,26 +133,38 @@ 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?+ -- 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 (coerceSymbolicPath $ coerceSymbolicPath buildTargetDir </> extraCompilationArtifacts) way- | otherwise = mempty+ -- 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 mbWorkDir = mbWorkDirLBI lbi- runGhcProg = runGHC verbosity ghcProg comp platform mbWorkDir+ tempFileOptions = commonSetupTempFileOptions $ buildingWhatCommonFlags what+ runGhcProg =+ runGHCWithResponseFile+ "ghc.rsp"+ Nothing+ tempFileOptions+ verbosity+ ghcProg+ comp+ platform+ mbWorkDir platform = hostPlatform lbi (hsMains, scriptMains) =@@ -159,7 +173,7 @@ -- 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,@@ -172,23 +186,33 @@ , 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)@@ -215,9 +239,10 @@ 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) }@@ -232,8 +257,8 @@ Internal.profDetailLevelFlag (if isLib then True else False) ((if isLib then withProfLibDetail else withProfExeDetail) lbi)- , ghcOptDynHiSuffix = toFlag (buildWayPrefix ProfDynWay ++ "hi")- , ghcOptDynObjSuffix = toFlag (buildWayPrefix ProfDynWay ++ "o")+ , 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)@@ -247,12 +272,16 @@ ProfWay -> profOpts ProfDynWay -> profDynOpts + 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 || (isNothing mbMainFile && null inputModules)) $ liftIO $ do -- See Note [Building Haskell Modules accounting for TH] let- neededLibWaysSet = Set.fromList neededLibWays- -- If we need both static and dynamic, use dynamic-too instead of -- compiling twice (if we support it) useDynamicToo =@@ -357,12 +386,14 @@ componentInputs :: SymbolicPath Pkg (Dir Artifacts) -- ^ Target build dir+ -> VerbosityHandles+ -- ^ Logging handles -> PD.PackageDescription -> PreBuildComponentInputs -- ^ The context and component being built in it. -> IO (Maybe (SymbolicPath Pkg File), [ModuleName]) -- ^ The main input file, and the Haskell modules-componentInputs buildTargetDir pkg_descr pbci =+componentInputs buildTargetDir verbHandles pkg_descr pbci = case component of CLib lib -> pure (Nothing, allLibModules lib clbi)@@ -377,7 +408,7 @@ CTest TestSuite{} -> error "testSuiteExeV10AsExe: wrong kind" CBench Benchmark{} -> error "benchmarkExeV10asExe: wrong kind" where- verbosity = buildVerbosity pbci+ verbosity = mkVerbosity verbHandles $ buildVerbosity pbci component = buildComponent pbci clbi = buildCLBI pbci mbWorkDir = mbWorkDirLBI $ localBuildInfo pbci
src/Distribution/Simple/GHC/Build/Utils.hs view
@@ -26,8 +26,7 @@ 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@@ -74,17 +73,21 @@ 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.@@ -102,17 +105,44 @@ -- | Finds the object file name of the given source file 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 = i $ fromFlag (ghcOptObjDir opts)+ odir = fromFlag (ghcOptObjDir opts) oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts) -- NB: the filepath might be absolute, e.g. if it is the path to -- an autogenerated .hs file.- oname = odir </> replaceExtension (getSymbolicPath filename) oext+ 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,11 +1,9 @@ {-# 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 () @@ -28,7 +26,7 @@ GhcEnvFileComment <$> comment <|> GhcEnvFilePackageId <$> unitId <|> GhcEnvFilePackageDb <$> packageDb- <|> pure GhcEnvFileClearPackageDbStack <* clearDb+ <|> GhcEnvFileClearPackageDbStack <$ clearDb where comment = P.string "--" *> P.many (P.noneOf "\r\n") unitId =@@ -37,8 +35,8 @@ *> 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"
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
@@ -19,12 +19,8 @@ , getExtensions , targetPlatform , getGhcInfo- , componentCcGhcOptions- , componentCmmGhcOptions- , componentCxxGhcOptions- , componentAsmGhcOptions- , componentJsGhcOptions , componentGhcOptions+ , sourcesGhcOptions , mkGHCiLibName , mkGHCiProfLibName , filterGhciFlags@@ -34,6 +30,11 @@ , substTopDir , checkPackageDbEnvVar , profDetailLevelFlag+ , ghcOptionsSince+ , linkGhcOptions+ , optimizationCFlags+ , splitCandCxxOptions+ , SplitSource (..) -- * GHC platform and version strings , ghcArchString@@ -58,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@@ -75,17 +74,22 @@ import Distribution.Simple.Setup.Common (extraCompilationArtifacts) import Distribution.Simple.Utils import Distribution.System+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.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@@ -111,6 +115,11 @@ , programPostConf = configureGcc } . addKnownProgram+ gppProgram+ { programFindLocation = findProg gppProgramName extraGppPath+ , programPostConf = configureGpp+ }+ . addKnownProgram ldProgram { programFindLocation = findProg ldProgramName extraLdPath , programPostConf = \v cp ->@@ -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,45 +315,18 @@ 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+ ] includePaths :: LocalBuildInfo@@ -358,153 +348,199 @@ | dir <- mapMaybe (symbolicPathRelative_maybe . unsafeCoerceSymbolicPath) $ includeDirs bi ] -componentCcGhcOptions- :: Verbosity- -> LocalBuildInfo- -> BuildInfo- -> ComponentLocalBuildInfo- -> SymbolicPath Pkg (Dir Artifacts)- -> SymbolicPath Pkg File- -> 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 = includePaths lbi bi clbi odir- , 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- }+data SplitSource = CcProgram | CxxProgram -componentCxxGhcOptions- :: Verbosity+splitCandCxxOptions+ :: SplitSource+ -> VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> 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 = includePaths lbi bi clbi odir- , 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 -> 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 = includePaths lbi bi clbi odir- , 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- -> SymbolicPath Pkg (Dir Artifacts)- -> SymbolicPath Pkg File+ -> 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 = includePaths lbi bi clbi odir- , 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- -> SymbolicPath Pkg (Dir build) -> 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} ->@@ -539,31 +575,32 @@ , ghcOptSplitSections = toFlag (splitSections lbi) , ghcOptSplitObjs = toFlag (splitObjs lbi) , ghcOptSourcePathClear = toFlag True- , ghcOptSourcePath =- toNubListR $- (hsSourceDirs bi)- ++ [coerceSymbolicPath odir]- ++ [autogenComponentModulesDir lbi clbi]- ++ [autogenPackageModulesDir lbi]- , ghcOptCppIncludePath = includePaths lbi bi clbi odir- , ghcOptCppOptions = cppOptions bi , ghcOptCppIncludes =- toNubListR $- [coerceSymbolicPath (autogenComponentModulesDir lbi clbi </> makeRelativePathEx cppHeaderName)]+ toNubListR [coerceSymbolicPath (autogenComponentModulesDir lbi clbi </> makeRelativePathEx cppHeaderName)] , ghcOptFfiIncludes = toNubListR $ map getSymbolicPath $ includes bi- , 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 , ghcOptOptimisation = toGhcOptimisation (withOptimization lbi) , ghcOptDebugInfo = toFlag (withDebugInfo lbi)- , ghcOptExtra = hcOptions GHC bi , ghcOptExtraPath = toNubListR exe_paths , ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi)) , -- Unsupported extensions have already been checked by configure ghcOptExtensions = toNubListR $ usedExtensions bi- , ghcOptExtensionMap = Map.fromList . compilerExtensions $ (compiler lbi)+ , 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 =@@ -578,35 +615,6 @@ toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation -componentCmmGhcOptions- :: Verbosity- -> LocalBuildInfo- -> BuildInfo- -> ComponentLocalBuildInfo- -> SymbolicPath Pkg (Dir Artifacts)- -> SymbolicPath Pkg File- -> 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 = includePaths lbi bi clbi odir- , ghcOptCppOptions = cppOptions bi- , ghcOptCppIncludes =- toNubListR $- [autogenComponentModulesDir lbi clbi </> makeRelativePathEx 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@@ -650,7 +658,7 @@ [ pref </> makeRelativePathEx (ModuleName.toFilePath x ++ splitSuffix) | x <- allLibModules lib clbi ]- objss <- traverse (getDirectoryContents . i) dirs+ objss <- traverse (listDirectory . i) dirs let objs = [ dir </> makeRelativePathEx obj | (objs', dir) <- zip objss dirs
src/Distribution/Simple/GHCJS.hs view
@@ -1,11 +1,12 @@ {-# 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,19 +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@@ -107,13 +109,29 @@ -- ----------------------------------------------------------------------------- -- 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@@ -134,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:@@ -185,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@@ -348,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 @@ -500,7 +537,7 @@ 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@@ -539,8 +576,8 @@ -- modules? let cLikeFiles = fromNubListR $ toNubListR (cSources libBi) <> toNubListR (cxxSources libBi) jsSrcs = jsSources libBi- cObjs = map ((`replaceExtensionSymbolicPath` 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 =@@ -703,7 +740,7 @@ info verbosity "Linking..." let cSharedObjs = map- ((`replaceExtensionSymbolicPath` ("dyn_" ++ objExtension)))+ (`replaceExtensionSymbolicPath` ("dyn_" ++ objExtension)) (cSources libBi ++ cxxSources libBi) compiler_id = compilerId (compiler lbi) sharedLibFilePath = libTargetDir </> makeRelativePathEx (mkSharedLibName (hostPlatform lbi) compiler_id uid)@@ -712,23 +749,6 @@ 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@@ -772,15 +792,7 @@ , ghcOptInputFiles = toNubListR dynamicObjectFiles , ghcOptOutputFile = toFlag sharedLibFilePath , ghcOptExtra = hcOptions GHC libBi ++ 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+ , ghcOptHideAllPackages = toFlag True , ghcOptNoAutoLinkPackages = toFlag True , ghcOptPackageDBs = withPackageDB lbi , ghcOptThisUnitId = case clbi of@@ -1205,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@@ -1268,8 +1273,8 @@ inputModules = inputSourceModules buildSources isGhcDynamic = isDynamic comp dynamicTooSupported = supportsDynamicToo comp- cObjs = map ((`replaceExtensionSymbolicPath` objExtension)) cSrcs- cxxObjs = map ((`replaceExtensionSymbolicPath` objExtension)) cxxSrcs+ cObjs = map (`replaceExtensionSymbolicPath` objExtension) cSrcs+ cxxObjs = map (`replaceExtensionSymbolicPath` objExtension) cxxSrcs needDynamic = gbuildNeedDynamic lbi bm needProfiling = withProfExe lbi @@ -1281,7 +1286,7 @@ TestComponentLocalBuildInfo{} -> True BenchComponentLocalBuildInfo{} -> True baseOpts =- (componentGhcOptions verbosity lbi bnfo clbi tmpDir)+ componentGhcOptions (verbosityLevel verbosity) lbi bnfo clbi tmpDir `mappend` mempty { ghcOptMode = toFlag GhcModeMake , ghcOptInputFiles =@@ -1437,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@@ -1483,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@@ -1538,10 +1531,6 @@ -- Work around old GHCs not relinking in this -- situation, see #3294 let target = targetDir </> makeRelativePathEx targetName- when (compilerVersion comp < mkVersion [7, 7]) $ do- let targetPath = i target- e <- doesFileExist targetPath- when e (removeFile targetPath) runGhcProg linkOpts{ghcOptOutputFile = toFlag target} GBuildFLib flib -> do let rtsInfo = extractRtsInfo lbi@@ -1710,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@@ -1739,7 +1728,7 @@ popThreadedFlag :: BuildInfo -> (BuildInfo, Bool) popThreadedFlag bi = ( bi{options = filterHcOptions (/= "-threaded") (options bi)}- , hasThreaded (options bi)+ , hasThreaded bi ) where filterHcOptions@@ -1749,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@@ -1768,7 +1754,7 @@ 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@@ -1808,7 +1794,7 @@ return (takeWhile (not . isSpace) hash) componentGhcOptions- :: Verbosity+ :: VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo@@ -1893,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"@@ -1911,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)@@ -2004,23 +1992,9 @@ -- ----------------------------------------------------------------------------- -- 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
src/Distribution/Simple/Glob.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} @@ -60,6 +59,8 @@ import Distribution.Utils.Path import Distribution.Verbosity ( Verbosity+ , defaultVerbosityHandles+ , mkVerbosity , silent ) @@ -89,7 +90,7 @@ GlobMatchesDirectory a -> Just a GlobMissingDirectory{} -> Nothing )- <$> runDirFileGlob silent Nothing root glob+ <$> runDirFileGlob (mkVerbosity defaultVerbosityHandles silent) Nothing root glob -- | Match a globbing pattern against a file path component matchGlobPieces :: GlobPieces -> String -> Bool@@ -370,7 +371,6 @@ "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@@ -379,7 +379,7 @@ -- the whole directory if *, and just the specific file if it's a -- literal. let- (prefixSegments, variablePattern) = splitConstantPrefix pat+ (prefixSegments, pathOrVariablePattern) = splitConstantPrefix pat joinedPrefix = joinPath prefixSegments -- The glob matching function depends on whether we care about the cabal version or not@@ -389,7 +389,7 @@ Nothing -> if matchGlobPieces glob str then Just (GlobMatch ()) else Nothing go (GlobFile glob) dir = do- entries <- getDirectoryContents (root </> dir)+ entries <- listDirectory (root </> dir) catMaybes <$> mapM ( \s -> do@@ -420,7 +420,7 @@ ) entries go (GlobDir glob globPath) dir = do- entries <- getDirectoryContents (root </> dir)+ entries <- listDirectory (root </> dir) subdirs <- filterM ( \subdir ->@@ -431,17 +431,34 @@ 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]+ 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], Glob)- splitConstantPrefix = unfoldr' step+ 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'
src/Distribution/Simple/Glob/Internal.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- @@ -33,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@@ -76,22 +77,26 @@ 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 '\\' -- check this isn't an escape code 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
src/Distribution/Simple/Haddock.hs view
@@ -2,10 +2,10 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- @@ -41,9 +41,9 @@ -- local +import Data.Semigroup (All (..), Any (..)) import Distribution.Backpack (OpenModule) import Distribution.Backpack.DescribeUnitId-import Distribution.Compat.Semigroup (All (..), Any (..)) import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo import qualified Distribution.ModuleName as ModuleName@@ -56,6 +56,9 @@ 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@@ -67,16 +70,10 @@ import qualified Distribution.Simple.Program.HcPkg as HcPkg import Distribution.Simple.Program.ResponseFile import Distribution.Simple.Register-import Distribution.Simple.Setup.Common-import Distribution.Simple.Setup.Haddock-import Distribution.Simple.Setup.Hscolour-import Distribution.Simple.SetupHooks.Internal- ( BuildHooks (..)- , BuildingWhat (..)- , noBuildHooks- )+import Distribution.Simple.Setup import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks-import qualified Distribution.Simple.SetupHooks.Rule as SetupHooks+ ( PreBuildComponentInputs (..)+ ) import Distribution.Simple.Utils import Distribution.System import Distribution.Types.ComponentLocalBuildInfo@@ -91,9 +88,8 @@ import Distribution.Verbosity import Distribution.Version -import Control.Monad import Data.Bool (bool)-import Data.Either (rights)+import Data.Either (lefts, rights) import System.Directory (doesDirectoryExist, doesFileExist) import System.FilePath (isAbsolute, normalise) import System.IO (hClose, hPutStrLn, hSetEncoding, utf8)@@ -231,17 +227,28 @@ -> [PPSuffixHandler] -> HaddockFlags -> IO ()-haddock = haddock_setupHooks noBuildHooks+haddock pkg lbi suffixHandlers flags =+ void $+ haddock_setupHooks+ (const $ return [])+ defaultVerbosityHandles+ pkg+ lbi+ suffixHandlers+ flags haddock_setupHooks- :: BuildHooks+ :: (SetupHooks.PreBuildComponentInputs -> IO [MonitorFilePath])+ -- ^ pre-build hook+ -> VerbosityHandles -> PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags- -> IO ()+ -> IO [MonitorFilePath] haddock_setupHooks _+ verbHandles pkg_descr _ _@@ -250,21 +257,26 @@ && not (fromFlag $ haddockExecutables haddockFlags) && not (fromFlag $ haddockTestSuites haddockFlags) && not (fromFlag $ haddockBenchmarks haddockFlags)- && not (fromFlag $ haddockForeignLibs haddockFlags) =- warn (fromFlag $ setupVerbosity $ haddockCommonFlags 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- (BuildHooks{preBuildComponentRules = mbPbcRules})+ preBuildHook+ verbHandles pkg_descr lbi suffixes flags' = do- let verbosity = fromFlag $ haddockVerbosity flags+ 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@@ -282,9 +294,7 @@ flag f = fromFlag $ f flags tmpFileOpts =- defaultTempFileOptions- { optKeepTempFiles = flag haddockKeepTempFiles- }+ commonSetupTempFileOptions $ configCommonFlags config htmlTemplate = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ flags@@ -312,17 +322,19 @@ -- support '--hyperlinked-sources'. let using_hscolour = flag haddockLinkedSource && version < mkVersion [2, 17] when using_hscolour $- hscolour'- noBuildHooks- -- NB: we are not passing the user BuildHooks here,- -- because we are already running the pre/post build hooks- -- for Haddock.- (warn verbosity)- haddockTarget- pkg_descr- lbi- suffixes- (defaultHscolourFlags `mappend` haddockToHscolour flags)+ 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) @@ -335,14 +347,14 @@ internalPackageDB <- createInternalPackageDB verbosity lbi (flag $ setupDistPref . haddockCommonFlags) - (\f -> foldM_ f (installedPkgs lbi) targets') $ \index target -> do+ (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' = addInternalBuildToolsFixed (Just curDir) pkg_descr lbi bi (withPrograms lbi)+ progs' = addInternalBuildTools curDir pkg_descr lbi bi (withPrograms lbi) lbi' = lbi { withPrograms = progs'@@ -350,24 +362,14 @@ , installedPkgs = index } - runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO ()- runPreBuildHooks lbi2 tgt =- let inputs =- SetupHooks.PreBuildComponentInputs- { SetupHooks.buildingWhat = BuildHaddock flags- , SetupHooks.localBuildInfo = lbi2- , SetupHooks.targetInfo = tgt- }- in for_ mbPbcRules $ \pbcRules -> do- (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules- SetupHooks.executeRules verbosity lbi2 tgt ruleFromId+ pbci = SetupHooks.PreBuildComponentInputs (BuildHaddock flags) lbi' target -- See Note [Hi Haddock Recompilation Avoidance] reusingGHCCompilationArtifacts verbosity tmpFileOpts mbWorkDir lbi bi clbi version $ \haddockArtifactsDirs -> do- preBuildComponent runPreBuildHooks verbosity lbi' target+ mons <- preBuildComponent (preBuildHook pbci) verbosity lbi' target preprocessComponent pkg_descr component lbi' clbi False verbosity suffixes let- doExe com = case (compToExe com) of+ doExe com = case compToExe com of Just exe -> do exeArgs <- fromExecutable@@ -443,7 +445,7 @@ debug verbosity $ "Registering inplace:\n"- ++ (InstalledPackageInfo.showInstalledPackageInfo ipi)+ ++ InstalledPackageInfo.showInstalledPackageInfo ipi registerPackage verbosity@@ -534,7 +536,7 @@ benchArgs return index - return ipi+ return (monsAcc ++ mons, ipi) for_ (extraDocFiles pkg_descr) $ \fpath -> do files <- matchDirFileGlob verbosity (specVersion pkg_descr) mbWorkDir fpath@@ -542,6 +544,8 @@ 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@@ -554,9 +558,11 @@ -> 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 defaultTempFileOptions comp platform haddockProg False args+ runHaddock verbosity mbWorkDir tmpFileOpts comp platform haddockProg False args -- ------------------------------------------------------------------------------ -- Contributions to HaddockArgs (see also Doctest.hs for very similar code).@@ -594,7 +600,7 @@ , argBaseUrl = haddockBaseUrl flags , argResourcesDir = haddockResourcesDir flags , argVerbose =- maybe mempty (Any . (>= deafening))+ maybe mempty (Any . (>= Deafening) . vLevel) . flagToMaybe $ setupVerbosity commonFlags , argOutput =@@ -621,13 +627,14 @@ , 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+ , argPackageName = Flag $ packageId pkg_descr , argOutputDir = Dir $ "doc" </> "html" , argPrologue = Flag $@@ -645,7 +652,7 @@ | otherwise = ": " ++ ShortText.fromShortText (synopsis pkg_descr) componentGhcOptions- :: Verbosity+ :: VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo@@ -708,7 +715,7 @@ mkHaddockArgs verbosity (tmpObjDir, tmpHiDir, tmpStubDir) lbi clbi htmlTemplate inFiles bi = do let vanillaOpts' =- componentGhcOptions normal lbi bi clbi (buildDir lbi)+ componentGhcOptions Normal lbi bi clbi (buildDir lbi) vanillaOpts = vanillaOpts' { -- See Note [Hi Haddock Recompilation Avoidance]@@ -1020,7 +1027,7 @@ -> IO HaddockArgs getInterfaces verbosity lbi clbi htmlTemplate = do (packageFlags, warnings) <- haddockPackageFlags verbosity lbi clbi htmlTemplate- traverse_ (warn (verboseUnmarkOutput verbosity)) warnings+ traverse_ (warn (modifyVerbosityFlags verboseUnmarkOutput verbosity)) warnings return $ mempty { argInterfaces = packageFlags@@ -1066,21 +1073,27 @@ -> IO r reusingGHCCompilationArtifacts verbosity tmpFileOpts mbWorkDir lbi bi clbi version act | version >= mkVersion [2, 28, 0] = do- withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (distPrefLBI lbi) "haddock-objs" $ \tmpObjDir ->- withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (distPrefLBI lbi) "haddock-his" $ \tmpHiDir -> 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)+ vanillaOpts = componentGhcOptions Normal lbi bi clbi (buildDir lbi) i = interpretSymbolicPath mbWorkDir- copyDir ghcDir tmpDir = copyDirectoryRecursive verbosity (i $ fromFlag $ ghcDir vanillaOpts) (i tmpDir)+ 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 verbosity tmpFileOpts mbWorkDir (distPrefLBI lbi) "tmp" $+ withTempDirectoryCwdEx tmpFileOpts mbWorkDir (distPrefLBI lbi) "tmp" $ \tmpFallback -> act (tmpFallback, tmpFallback, tmpFallback) -- ------------------------------------------------------------------------------@@ -1134,8 +1147,6 @@ withResponseFile verbosity tmpFileOpts- mbWorkDir- outputDir "haddock-response.txt" (if haddockSupportsUTF8 then Just utf8 else Nothing) renderedArgs@@ -1145,7 +1156,7 @@ (Flag pfile, _) -> withPrologueArgs ["--prologue=" ++ pfile] (_, Flag prologueText) ->- withTempFileEx tmpFileOpts mbWorkDir outputDir "haddock-prologue.txt" $+ withTempFileEx tmpFileOpts "haddock-prologue.txt" $ \prologueFileName h -> do when haddockSupportsUTF8 (hSetEncoding h utf8) hPutStrLn h prologueText@@ -1234,9 +1245,7 @@ [ "--source-module=" ++ m , "--source-entity=" ++ e ]- ++ if isVersion 2 14- then ["--source-entity-line=" ++ l]- else []+ ++ ["--source-entity-line=" ++ l | isVersion 2 14] ) . flagToMaybe . argLinkSource@@ -1248,7 +1257,7 @@ , 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")+ , map (\case Hoogle -> "--hoogle"; Html -> "--html") . fromFlagOrDefault [] . argOutput $ args@@ -1258,11 +1267,10 @@ [] ( (: []) . ("--title=" ++)- . ( bool- id- (++ " (internal documentation)")- (getAny $ argIgnoreExports args)- )+ . bool+ id+ (++ " (internal documentation)")+ (getAny $ argIgnoreExports args) ) . flagToMaybe . argTitle@@ -1273,10 +1281,10 @@ flagToMaybe (argGhcLibDir args) -- error if Nothing? , -- https://github.com/haskell/haddock/pull/547 [ "--reexport=" ++ prettyShow r- | r <- argReexports args- , isVersion 2 19+ | isVersion 2 19+ , r <- argReexports args ]- , argTargets $ 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@@ -1310,13 +1318,7 @@ | otherwise -> "" ]- , if haddockSupportsVisibility- then- [ case visibility of- Visible -> "visible"- Hidden -> "hidden"- ]- else []+ , [case visibility of Visible -> "visible"; Hidden -> "hidden" | haddockSupportsVisibility] , [i] ] )@@ -1367,7 +1369,7 @@ Just htmlPath -> do let hypSrcPath = htmlPath </> defaultHyperlinkedSourceDirectory hypSrcExists <- doesDirectoryExist hypSrcPath- return $+ return ( Just (fixFileUrl htmlPath) , if hypSrcExists then Just (fixFileUrl hypSrcPath)@@ -1384,9 +1386,9 @@ , pkgName pkgid `notElem` noHaddockWhitelist ] - let missing = [pkgid | Left pkgid <- interfaces]+ let missing = lefts interfaces warning =- "The documentation for the following packages are not "+ "The following packages have no Haddock documentation " ++ "installed. No links will be generated to these packages: " ++ intercalate ", " (map prettyShow missing) flags = rights interfaces@@ -1394,7 +1396,7 @@ return (flags, if null missing then Nothing else Just warning) where -- Don't warn about missing documentation for these packages. See #1231.- noHaddockWhitelist = map mkPackageName ["rts"]+ noHaddockWhitelist = [mkPackageName "rts"] -- Actually extract interface and HTML paths from an 'InstalledPackageInfo'. interfaceAndHtmlPath@@ -1473,20 +1475,32 @@ -> [PPSuffixHandler] -> HscolourFlags -> IO ()-hscolour = hscolour_setupHooks noBuildHooks+hscolour pkg lbi pps flags =+ void $+ hscolour_setupHooks+ (const $ return [])+ defaultVerbosityHandles+ pkg+ lbi+ pps+ flags hscolour_setupHooks- :: BuildHooks+ :: (SetupHooks.PreBuildComponentInputs -> IO [MonitorFilePath])+ -- ^ pre-build hook+ -> VerbosityHandles -> PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags- -> IO ()-hscolour_setupHooks setupHooks =- hscolour' setupHooks dieNoVerbosity ForDevelopment+ -> IO [MonitorFilePath]+hscolour_setupHooks preBuildHook verbHandles =+ hscolour' preBuildHook verbHandles dieNoVerbosity ForDevelopment hscolour'- :: BuildHooks+ :: (SetupHooks.PreBuildComponentInputs -> IO [MonitorFilePath])+ -- ^ pre-build hook+ -> VerbosityHandles -> (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found. -> HaddockTarget@@ -1494,31 +1508,35 @@ -> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags- -> IO ()+ -> IO [MonitorFilePath] hscolour'- (BuildHooks{preBuildComponentRules = mbPbcRules})+ preBuildHook+ verbHandles onNoHsColour haddockTarget pkg_descr lbi suffixes flags =- either (\excep -> onNoHsColour $ exceptionMessage excep) (\(hscolourProg, _, _) -> go hscolourProg)+ 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 = fromFlag $ setupVerbosity common+ 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 ()+ go :: ConfiguredProgram -> IO [MonitorFilePath] go hscolourProg = do warn verbosity $ "the 'cabal hscolour' command is deprecated in favour of 'cabal "@@ -1530,23 +1548,22 @@ i $ hscolourPref haddockTarget distPref pkg_descr - withAllComponentsInBuildOrder pkg_descr lbi $ \comp clbi -> do- let tgt = TargetInfo clbi comp- runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO ()- runPreBuildHooks lbi2 target =- let inputs =- SetupHooks.PreBuildComponentInputs- { SetupHooks.buildingWhat = BuildHscolour flags- , SetupHooks.localBuildInfo = lbi2- , SetupHooks.targetInfo = target- }- in for_ mbPbcRules $ \pbcRules -> do- (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules- SetupHooks.executeRules verbosity lbi2 tgt ruleFromId- preBuildComponent runPreBuildHooks verbosity lbi tgt+ 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+ doExe com = case compToExe com of Just exe -> do let outputDir = hscolourPref haddockTarget distPref pkg_descr@@ -1555,6 +1572,8 @@ 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"@@ -1570,6 +1589,8 @@ 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)
− src/Distribution/Simple/HaskellSuite.hs
@@ -1,270 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# 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- -- Not migrated to work with --working-dir but this is legacy dead code- -> PackageDBStackX (SymbolicPath from (Dir PkgDB))- -> 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 u (hsSourceDirs bi) ++ [u odir]- dbStack = withPackageDB lbi- language = fromMaybe Haskell98 (defaultLanguage bi)- progdb = withPrograms lbi- pkgid = packageId pkg_descr- u = interpretSymbolicPathCWD -- See Note [Symbolic paths] in Distribution.Utils.Path- runDbProgramCwd verbosity (mbWorkDirLBI lbi) haskellSuiteProgram progdb $- ["compile", "--build-dir", u odir]- ++ concat [["-i", d] | d <- srcDirs]- ++ concat- [ ["-I", d]- | d <-- [ u $ autogenComponentModulesDir lbi clbi- , u $ autogenPackageModulesDir lbi- , u odir- ]- ++ map u (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- wdir = mbWorkDirLBI lbi- runDbProgramCwd verbosity wdir 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- -> PackageDBStackS from- -> 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 :: PackageDBX (SymbolicPath from (Dir PkgDB)) -> String-packageDbOpt GlobalPackageDB = "--global"-packageDbOpt UserPackageDB = "--user"-packageDbOpt (SpecificPackageDB db) = "--package-db=" ++ interpretSymbolicPathCWD db
src/Distribution/Simple/Install.hs view
@@ -74,7 +74,6 @@ 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 @@ -105,10 +104,11 @@ -> CopyFlags -- ^ flags sent to copy or install -> IO ()-install = install_setupHooks SetupHooks.noInstallHooks+install = install_setupHooks SetupHooks.noInstallHooks defaultVerbosityHandles install_setupHooks :: InstallHooks+ -> VerbosityHandles -> PackageDescription -- ^ information from the .cabal file -> LocalBuildInfo@@ -118,6 +118,7 @@ -> IO () install_setupHooks (InstallHooks{installComponentHook})+ verbHandles pkg_descr lbi flags = do@@ -142,7 +143,7 @@ where common = copyCommonFlags flags distPref = fromFlag $ setupDistPref common- verbosity = fromFlag $ setupVerbosity common+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) copydest = fromFlag (copyDest flags) checkHasLibsOrExes =@@ -233,6 +234,7 @@ let InstallDirs { libdir = libPref , dynlibdir = dynlibPref+ , bytecodelibdir = bytecodeLibPref , includedir = incPref } = absoluteInstallCommandDirs pkg_descr lbi (componentUnitId clbi) copydest buildPref = interpretSymbolicPathLBI lbi $ componentBuildDir lbi clbi@@ -246,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@@ -296,7 +288,7 @@ ++ binPref ) inPath <- isInSearchPath binPref- when (not inPath) $+ unless inPath $ warn verbosity ( "The directory "@@ -307,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)) @@ -377,8 +368,10 @@ ] where baseDir lbi' = packageRoot $ configCommonFlags $ configFlags 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+ 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,7 +1,9 @@+{-# LANGUAGE CApiFFI #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -----------------------------------------------------------------------------@@ -44,6 +46,7 @@ , compilerTemplateEnv , packageTemplateEnv , abiTemplateEnv+ , installDirsGrammar , installDirsTemplateEnv ) where @@ -51,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 @@ -87,6 +94,7 @@ , libdir :: dir , libsubdir :: dir , dynlibdir :: dir+ , bytecodelibdir :: dir , flibdir :: dir -- ^ foreign libraries , libexecdir :: dir@@ -103,9 +111,10 @@ 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 = (<>) @@ -124,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@@ -222,6 +232,7 @@ "$libdir" </> case comp of UHC -> "$pkgid" _other -> "$abi"+ , bytecodelibdir = "$libdir" </> "$libsubdir" , libexecsubdir = "$abi" </> "$pkgid" , flibdir = "$libdir" , libexecdir = case buildOS of@@ -277,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 []@@ -391,6 +404,7 @@ deriving (Eq, Ord, Generic) instance Binary PathTemplate+instance NFData PathTemplate instance Structured PathTemplate type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)]@@ -481,6 +495,7 @@ , (LibdirVar, libdir dirs) , (LibsubdirVar, libsubdir dirs) , (DynlibdirVar, dynlibdir dirs)+ , (BytecodelibdirVar, bytecodelibdir dirs) , (DatadirVar, datadir dirs) , (DatasubdirVar, datasubdir dirs) , (DocdirVar, docdir dirs)@@ -506,6 +521,12 @@ , (template, "") <- reads path ] +instance Parsec PathTemplate where+ parsec = parsecPathTemplate++parsecPathTemplate :: CabalParsing m => m PathTemplate+parsecPathTemplate = toPathTemplate <$> parsecFilePath+ -- --------------------------------------------------------------------------- -- Internal utilities @@ -536,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 ()@@ -551,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
@@ -14,6 +14,7 @@ deriving (Eq, Ord, Generic) instance Binary PathComponent+instance NFData PathComponent instance Structured PathComponent data PathTemplateVariable@@ -27,6 +28,8 @@ LibsubdirVar | -- | The @$dynlibdir@ path variable DynlibdirVar+ | -- | The @$bytecodelibdir@ path variable+ BytecodelibdirVar | -- | The @$datadir@ path variable DatadirVar | -- | The @$datasubdir@ path variable@@ -67,6 +70,7 @@ deriving (Eq, Ord, Generic) instance Binary PathTemplateVariable+instance NFData PathTemplateVariable instance Structured PathTemplateVariable instance Show PathTemplateVariable where@@ -76,6 +80,7 @@ show LibdirVar = "libdir" show LibsubdirVar = "libsubdir" show DynlibdirVar = "dynlibdir"+ show BytecodelibdirVar = "bytecodelibdir" show DatadirVar = "datadir" show DatasubdirVar = "datasubdir" show DocdirVar = "docdir"@@ -109,6 +114,7 @@ , ("libdir", LibdirVar) , ("libsubdir", LibsubdirVar) , ("dynlibdir", DynlibdirVar)+ , ("bytecodelibdir", BytecodelibdirVar) , ("datadir", DatadirVar) , ("datasubdir", DatasubdirVar) , ("docdir", DocdirVar)
src/Distribution/Simple/LocalBuildInfo.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} -----------------------------------------------------------------------------@@ -288,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)@@ -322,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@@ -475,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
@@ -18,6 +18,8 @@ -- * Utility Parsing function , parseString+ , readAndParseFile+ , flattenDups ) where import Distribution.Compat.Prelude@@ -31,23 +33,23 @@ ( 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.Utils.Path-import Distribution.Verbosity (Verbosity, normal)-import GHC.Stack+import Distribution.Verbosity (Verbosity, VerbosityLevel (..), verbosityLevel) import System.Directory (doesFileExist) import Text.Printf (printf) readGenericPackageDescription- :: HasCallStack- => Verbosity+ :: Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> SymbolicPath Pkg File -> IO GenericPackageDescription@@ -70,7 +72,7 @@ -- -- 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@@ -90,7 +92,7 @@ parseString parser verbosity upath bs parseString- :: (BS.ByteString -> ParseResult a)+ :: (BS.ByteString -> ParseResult CabalFileSource a) -- ^ File contents to final value parser -> Verbosity -- ^ Verbosity level@@ -99,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
@@ -67,6 +67,7 @@ , lookupSourcePackageId , lookupPackageId , lookupPackageName+ , lookupInternalPackageName , lookupDependency , lookupInternalDependency @@ -92,6 +93,10 @@ , dependencyCycles , dependencyGraph , moduleNameIndex++ -- ** Filters on lookup results+ , eligibleDependencies+ , matchingDependencies ) where import qualified Data.Map.Strict as Map@@ -179,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@@ -364,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) -} --@@ -454,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.@@ -473,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@@ -508,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 --@@ -628,7 +663,7 @@ :: InstalledPackageIndex -> [UnitId] -> Either- (InstalledPackageIndex)+ InstalledPackageIndex [(IPI.InstalledPackageInfo, [UnitId])] dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of (completed, []) -> Left completed@@ -695,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,7 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- @@ -36,7 +35,6 @@ , runSimplePreProcessor , ppCpp , ppCpp'- , ppGreenCard , ppC2hs , ppHsc2hs , ppHappy@@ -259,7 +257,7 @@ (coerceSymbolicPath outputDir : hsSourceDirs bi) outputDir isSrcDist- (dropExtensionsSymbolicPath $ exePath)+ (dropExtensionsSymbolicPath exePath) verbosity builtinSuffixes biHandlers@@ -347,8 +345,8 @@ createDirectoryIfMissingVerbose verbosity True destDir runPreProcessorWithHsBootHack pp- (getSymbolicPath $ psrcLoc, getSymbolicPath $ psrcRelFile)- (getSymbolicPath $ buildLoc, srcStem <.> "hs")+ (psrcLoc, getSymbolicPath psrcRelFile)+ (buildLoc, srcStem <.> "hs") where i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path buildAsSrcLoc :: SymbolicPath Pkg (Dir Source)@@ -363,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 -- ------------------------------------------------------------ @@ -384,20 +387,6 @@ -- ------------------------------------------------------------ -ppGreenCard :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor-ppGreenCard _ lbi _ =- PreProcessor- { platformIndependent = False- , ppOrdering = unsorted- , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->- runDbProgramCwd- verbosity- (mbWorkDirLBI lbi)- 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@@ -476,10 +465,7 @@ : inFile : "--noline" : "--strip"- : ( if cpphsVersion >= mkVersion [1, 6]- then ["--include=" ++ u (autogenComponentModulesDir lbi clbi </> makeRelativePathEx cppHeaderName)]- else []- )+ : ["--include=" ++ u (autogenComponentModulesDir lbi clbi </> makeRelativePathEx cppHeaderName) | cpphsVersion >= mkVersion [1, 6]] ++ extraArgs } where@@ -511,8 +497,6 @@ withResponseFile verbosity defaultTempFileOptions- mbWorkDir- (makeSymbolicPath $ takeDirectory outFile) "hsc2hs-response.txt" Nothing pureArgs@@ -531,101 +515,104 @@ -- 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 <- 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.-- ++ ["--cflag=" ++ opt | opt <- platformDefines lbi]- -- Options from the current package:- ++ ["--cflag=-I" ++ u dir | dir <- PD.includeDirs bi]- ++ [ "--cflag=-I" ++ u (buildDir lbi </> unsafeCoerceSymbolicPath relDir)- | relDir <- mapMaybe symbolicPathRelative_maybe $ 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" ++ u (autogenComponentModulesDir lbi clbi)- , "-I" ++ u (autogenPackageModulesDir lbi)- , "-include"- , u $ autogenComponentModulesDir lbi clbi </> makeRelativePathEx cppHeaderName- ]- ]- ++ [ "--lflag=-L" ++ u opt- | opt <-- if withFullyStaticExe lbi- then PD.extraLibDirsStatic bi- else PD.extraLibDirs bi- ]- ++ [ "--lflag=-Wl,-R," ++ u 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,@@ -763,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@@ -811,7 +794,7 @@ Android -> ["android"] Ghcjs -> ["ghcjs"] Wasi -> ["wasi"]- Hurd -> ["hurd"]+ Hurd -> ["gnu"] Haiku -> ["haiku"] OtherOS _ -> [] archStr = case hostArch of@@ -876,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)
src/Distribution/Simple/PreProcess/Types.hs view
@@ -44,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
src/Distribution/Simple/Program.hs view
@@ -111,10 +111,10 @@ , ghcPkgProgram , ghcjsProgram , ghcjsPkgProgram- , hmakeProgram , jhcProgram , uhcProgram , gccProgram+ , gppProgram , arProgram , stripProgram , happyProgram@@ -125,7 +125,6 @@ , hscolourProgram , doctestProgram , haddockProgram- , greencardProgram , ldProgram , tarProgram , cppProgram
src/Distribution/Simple/Program/Ar.hs view
@@ -57,8 +57,8 @@ import Distribution.Utils.Path import Distribution.Verbosity ( Verbosity- , deafening- , verbose+ , VerbosityLevel (..)+ , verbosityLevel ) import System.Directory (doesFileExist, renameFile)@@ -90,7 +90,7 @@ i = interpretSymbolicPath mbWorkDir u :: SymbolicPath Pkg to -> FilePath u = interpretSymbolicPathCWD- withTempDirectoryCwd verbosity mbWorkDir targetDir "objs" $ \tmpDir -> do+ withTempDirectoryCwd mbWorkDir targetDir "objs" $ \tmpDir -> do let tmpPath = tmpDir </> targetName -- The args to use with "ar" are actually rather subtle and system-dependent.@@ -142,7 +142,7 @@ invokeWithResponseFile :: FilePath -> ProgramInvocation invokeWithResponseFile atFile =- (ar $ simpleArgs ++ extraArgs ++ ['@' : atFile])+ ar $ simpleArgs ++ extraArgs ++ ['@' : atFile] if oldVersionManualOverride || responseArgumentsNotSupported then@@ -154,7 +154,7 @@ (initial, middle, final) (map getSymbolicPath files) ]- else withResponseFile verbosity defaultTempFileOptions mbWorkDir tmpDir "ar.rsp" Nothing (map getSymbolicPath files) $+ else withResponseFile verbosity defaultTempFileOptions "ar.rsp" Nothing (map getSymbolicPath files) $ \path -> runProgramInvocation verbosity $ invokeWithResponseFile path unless@@ -168,8 +168,8 @@ 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,32 +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"---- This represent a haskell-suite package manager. See the comments for--- haskellSuiteProgram.-haskellSuitePkgProgram :: Program-haskellSuitePkgProgram =- simpleProgram "haskell-suite-pkg"- happyProgram :: Program happyProgram = (simpleProgram "happy")@@ -262,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" @@ -269,7 +229,10 @@ stripProgram = (simpleProgram "strip") { programFindVersion = \verbosity ->- findProgramVersion "--version" stripExtractVersion (lessVerbose verbosity)+ findProgramVersion+ "--version"+ stripExtractVersion+ (modifyVerbosityFlags lessVerbose verbosity) } hsc2hsProgram :: Program@@ -335,9 +298,6 @@ , programNormaliseArgs = \_ _ args -> args } -greencardProgram :: Program-greencardProgram = simpleProgram "greencard"- ldProgram :: Program ldProgram = (simpleProgram "ld")@@ -392,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
@@ -33,6 +33,7 @@ -- ** Query and manipulate the program db , addKnownProgram , addKnownPrograms+ , clearUnconfiguredPrograms , prependProgramSearchPath , prependProgramSearchPathNoLogging , lookupKnownProgram@@ -67,8 +68,11 @@ , ConfiguredProgs , updateUnconfiguredProgs , updateConfiguredProgs+ , updatePathProgDb ) where +import Control.Monad ((<=<))+import Data.Functor ((<&>)) import Distribution.Compat.Prelude import Prelude () @@ -200,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@@ -257,8 +269,14 @@ -> ProgramDb -> ProgramDb prependProgramSearchPathNoLogging extraPaths extraEnv db =- let db' = modifyProgramSearchPath (nub . (map ProgramSearchPathDir extraPaths ++)) db- db'' = db'{progOverrideEnv = extraEnv ++ progOverrideEnv 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@@ -328,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]@@ -406,7 +424,7 @@ 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@@ -483,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@@ -561,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 #-} @@ -48,7 +46,7 @@ import Distribution.System import Distribution.Verbosity -import qualified System.Directory as Directory+import System.Directory ( findExecutable ) import System.FilePath as FilePath@@ -206,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,21 +1,24 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} module Distribution.Simple.Program.GHC ( GhcOptions (..) , GhcMode (..) , GhcOptimisation (..) , GhcDynLinkMode (..)+ , GhcObjectMode (..) , GhcProfAuto (..) , ghcInvocation , renderGhcOptions , runGHC+ , runGHCWithResponseFile+ , runReplProgram , packageDbArgsDb , normaliseGhcArgs ) where@@ -23,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@@ -32,8 +35,10 @@ 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@@ -42,17 +47,19 @@ 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 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])@@ -141,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 [] = []@@ -157,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@@ -185,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"@@ -368,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 =@@ -442,6 +453,8 @@ -- the @ghc -i@ flag (@-i@ on its own with no path argument). , 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 @@ -510,6 +523,8 @@ -- ^ Options to pass through to the Assembler. , ghcOptCppOptions :: [String] -- ^ Options to pass through to CPP; the @ghc -optP@ flag.+ , 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 (SymbolicPath Pkg File)@@ -517,7 +532,9 @@ , 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 @@ -566,19 +583,22 @@ , 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 (SymbolicPath Pkg (Dir Build)) -- ^ Put the extra folders in the PATH environment variable we invoke@@ -624,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@@ -647,6 +676,69 @@ 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@@ -720,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@@ -744,10 +830,7 @@ 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 [] , --------------------@@ -755,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] , ------------------------@@ -773,6 +862,7 @@ , 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@@ -786,18 +876,21 @@ ["-I" ++ u dir | dir <- flags ghcOptCppIncludePath] , ["-optP" ++ opt | opt <- ghcOptCppOptions opts]+ , ["-optJSP" ++ opt | opt <- ghcOptJSppOptions opts] , concat [ ["-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 @@ -841,8 +934,8 @@ , if null (ghcOptInstantiatedWith opts) then [] else- "-instantiated-with"- : intercalate+ [ "-instantiated-with"+ , intercalate "," ( map ( \(n, m) ->@@ -852,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 (interpretPackageDBStack Nothing (ghcOptPackageDBs opts))+ , packageDbArgsDb (interpretPackageDBStack Nothing (ghcOptPackageDBs opts)) , concat $ let space "" = "" space xs = ' ' : xs@@ -867,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@@ -885,7 +976,7 @@ -- GHCi concat- [ ["-ghci-script", script] | script <- ghcOptGHCiScripts opts, flagGhciScript implInfo+ [ ["-ghci-script", script] | script <- ghcOptGHCiScripts opts ] , --------------- -- Inputs@@ -897,6 +988,8 @@ , [prettyShow modu | modu <- flags ghcOptInputModules] , concat [["-o", u out] | out <- flag ghcOptOutputFile] , concat [["-dyno", out] | out <- flag ghcOptOutputDynFile]+ , -- unit files+ concat [["-unit", "@" ++ unit] | unit <- ghcOptUnitFiles opts] , --------------- -- Extra @@ -912,33 +1005,15 @@ 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 :: PackageDBStackCWD -> [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 :: 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)@@ -955,10 +1030,25 @@ isSpecific (SpecificPackageDB _) = True isSpecific _ = False -packageDbArgs :: GhcImplInfo -> PackageDBStackCWD -> [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,11 +1,8 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} ------------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Program.HcPkg -- Copyright : Duncan Coutts 2009, 2013@@ -17,7 +14,7 @@ -- Currently only GHC and GHCJS have hc-pkg programs. module Distribution.Simple.Program.HcPkg ( -- * Types- HcPkgInfo (..)+ ConfiguredProgram (..) , RegisterOptions (..) , defaultRegisterOptions @@ -48,19 +45,44 @@ 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+ ( 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-import Distribution.Verbosity+ ( 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@@ -75,53 +97,27 @@ 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+ :: ConfiguredProgram -> Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDBStack -> [String] -> IO ()-invoke hpi verbosity mbWorkDir dbStack extraArgs =+invoke ghcProg verbosity mbWorkDir dbStack extraArgs = runProgramInvocation verbosity invocation where- args = packageDbStackOpts hpi dbStack ++ extraArgs- invocation = programInvocationCwd mbWorkDir (hcPkgProgram hpi) args+ args = packageDbStackOpts dbStack ++ extraArgs+ invocation = programInvocationCwd mbWorkDir ghcProg args -- | Additional variations in the behaviour for 'register'. data RegisterOptions = RegisterOptions@@ -129,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@@ -152,7 +146,7 @@ -- -- > hc-pkg register {filename | -} [--user | --global | --package-db] register- :: HcPkgInfo+ :: ConfiguredProgram -> Verbosity -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBStackS from@@ -160,74 +154,55 @@ -> RegisterOptions -> IO () register hpi verbosity mbWorkDir 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 =+ | registerMultiInstance registerOptions = do let pkgdb = registrationPackageDB packagedbs- writeRegistrationFileDirectly verbosity hpi mbWorkDir pkgdb pkgInfo+ writeRegistrationFileDirectly verbosity mbWorkDir pkgdb pkgInfo recache hpi verbosity mbWorkDir pkgdb | otherwise = runProgramInvocation verbosity- (registerInvocation hpi verbosity mbWorkDir packagedbs pkgInfo registerOptions)+ (registerInvocation hpi (verbosityLevel verbosity) mbWorkDir packagedbs pkgInfo registerOptions) writeRegistrationFileDirectly :: Verbosity- -> HcPkgInfo -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBS from -> InstalledPackageInfo -> IO ()-writeRegistrationFileDirectly verbosity hpi mbWorkDir (SpecificPackageDB dir) pkgInfo- | supportsDirDbs hpi =- do- let pkgfile = interpretSymbolicPath mbWorkDir 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 -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageId -> IO ()+unregister :: ConfiguredProgram -> Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageId -> IO () unregister hpi verbosity mbWorkDir packagedb pkgid = runProgramInvocation verbosity- (unregisterInvocation hpi verbosity mbWorkDir 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 -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBS from -> IO ()+recache :: ConfiguredProgram -> Verbosity -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBS from -> IO () recache hpi verbosity mbWorkDir packagedb = runProgramInvocation verbosity- (recacheInvocation hpi verbosity mbWorkDir packagedb)+ (recacheInvocation hpi (verbosityLevel verbosity) mbWorkDir packagedb) -- | Call @hc-pkg@ to expose a package. -- -- > hc-pkg expose [pkgid] [--user | --global | --package-db] expose- :: HcPkgInfo+ :: ConfiguredProgram -> Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB@@ -236,34 +211,34 @@ expose hpi verbosity mbWorkDir packagedb pkgid = runProgramInvocation verbosity- (exposeInvocation hpi verbosity mbWorkDir 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+ :: ConfiguredProgram -> Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDBStack -> PackageId -> IO [InstalledPackageInfo]-describe hpi verbosity mbWorkDir packagedb pid = do+describe ghcProg verbosity mbWorkDir packagedb pid = do output <- getProgramInvocationLBS verbosity- (describeInvocation hpi verbosity mbWorkDir 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+ :: ConfiguredProgram -> Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB@@ -272,27 +247,27 @@ hide hpi verbosity mbWorkDir packagedb pkgid = runProgramInvocation verbosity- (hideInvocation hpi verbosity mbWorkDir 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+ :: ConfiguredProgram -> Verbosity -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBX (SymbolicPath from (Dir PkgDB)) -> IO [InstalledPackageInfo]-dump hpi verbosity mbWorkDir packagedb = do+dump ghcProg verbosity mbWorkDir packagedb = do output <- getProgramInvocationLBS verbosity- (dumpInvocation hpi verbosity mbWorkDir 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 =@@ -321,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)@@ -351,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@@ -400,21 +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 mbWorkDir packagedb = do+list ghcProg verbosity mbWorkDir packagedb = do output <- getProgramInvocationOutput verbosity- (listInvocation hpi verbosity mbWorkDir 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 @@ -422,24 +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+ :: ConfiguredProgram+ -> VerbosityLevel -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBStackS from -> InstalledPackageInfo -> RegisterOptions -> ProgramInvocation-registerInvocation hpi verbosity mbWorkDir packagedbs pkgInfo registerOptions =- (programInvocationCwd mbWorkDir (hcPkgProgram hpi) (args "-"))+registerInvocation ghcProg verbosity mbWorkDir packagedbs pkgInfo registerOptions =+ (programInvocationCwd mbWorkDir ghcProg (args "-")) { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo pkgInfo , progInvokeInputEncoding = IOEncodingUTF8 }@@ -451,146 +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 mbWorkDir packagedb pkgid =- programInvocationCwd mbWorkDir (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+ :: ConfiguredProgram+ -> VerbosityLevel -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBS from -> ProgramInvocation-recacheInvocation hpi verbosity mbWorkDir packagedb =- programInvocationCwd mbWorkDir (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 mbWorkDir packagedb pkgid =- programInvocationCwd mbWorkDir (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 mbWorkDir packagedbs pkgid =- programInvocationCwd mbWorkDir (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 mbWorkDir packagedb pkgid =- programInvocationCwd mbWorkDir (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+ :: ConfiguredProgram+ -> VerbosityLevel -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBX (SymbolicPath from (Dir PkgDB)) -> ProgramInvocation-dumpInvocation hpi _verbosity mbWorkDir packagedb =- (programInvocationCwd mbWorkDir (hcPkgProgram hpi) args)+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+ :: ConfiguredProgram+ -> VerbosityLevel -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> ProgramInvocation-listInvocation hpi _verbosity mbWorkDir packagedb =- (programInvocationCwd mbWorkDir (hcPkgProgram hpi) args)+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 -> PackageDBStackS from -> [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 ++ "=" ++ interpretSymbolicPathCWD 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 -> PackageDBX (SymbolicPath from (Dir PkgDB)) -> String-packageDbOpts _ GlobalPackageDB = "--global"-packageDbOpts _ UserPackageDB = "--user"-packageDbOpts hpi (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ interpretSymbolicPathCWD 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/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
@@ -83,8 +83,6 @@ middle = ld middleArgs final = ld finalArgs - targetDir = takeDirectorySymbolicPath target- invokeWithResponseFile :: FilePath -> ProgramInvocation invokeWithResponseFile atFile = ld $ simpleArgs ++ ['@' : atFile]@@ -106,7 +104,7 @@ if oldVersionManualOverride || responseArgumentsNotSupported then run $ multiStageProgramInvocation simple (initial, middle, final) (map getSymbolicPath files)- else withResponseFile verbosity defaultTempFileOptions mbWorkDir targetDir "ld.rsp" Nothing (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,7 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeApplications #-} ---------------------------------------------------------------------------- @@ -27,10 +26,6 @@ withResponseFile :: Verbosity -> TempFileOptions- -> Maybe (SymbolicPath CWD (Dir Pkg))- -- ^ Working directory- -> SymbolicPath Pkg (Dir Response)- -- ^ Directory to create response file in. -> String -- ^ Template for response file name. -> Maybe TextEncoding@@ -39,14 +34,13 @@ -- ^ Arguments to put into response file. -> (FilePath -> IO a) -> IO a-withResponseFile verbosity tmpFileOpts mbWorkDir responseDir fileNameTemplate encoding arguments f =- withTempFileEx tmpFileOpts mbWorkDir responseDir fileNameTemplate $ \responsePath 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+ map escapeResponseFileArg arguments hPutStr hf responseContents hClose hf debug verbosity $ responseFileName ++ " contents: <<<"
src/Distribution/Simple/Program/Run.hs view
@@ -3,7 +3,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- @@ -62,6 +61,7 @@ , progInvokeInputEncoding :: IOEncoding -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'. , progInvokeOutputEncoding :: IOEncoding+ , progInvokeWhen :: IO Bool } data IOEncoding@@ -83,6 +83,7 @@ , progInvokeInput = Nothing , progInvokeInputEncoding = IOEncodingText , progInvokeOutputEncoding = IOEncodingText+ , progInvokeWhen = pure True } simpleProgramInvocation@@ -129,8 +130,7 @@ , progInvokeEnv = [] , progInvokeCwd = Nothing , progInvokeInput = Nothing- } =- rawSystemExit verbosity Nothing path args+ } = rawSystemExit verbosity Nothing path args runProgramInvocation verbosity ProgramInvocation@@ -261,9 +261,7 @@ -> IO [(String, String)] getFullEnvironment overrides = do menv <- getEffectiveEnvironment overrides- case menv of- Just env -> return env- Nothing -> getEnvironment+ 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 ()@@ -79,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
@@ -142,7 +142,7 @@ , 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). }
src/Distribution/Simple/Register.hs view
@@ -29,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@@ -59,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 @@ -78,6 +79,7 @@ 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@@ -99,12 +101,21 @@ -> RegisterFlags -- ^ Install in the user's database?; verbose -> IO ()-register pkg_descr lbi0 flags = do+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.- let verbosity = fromFlag $ registerVerbosity 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@@ -118,20 +129,21 @@ CLib lib -> do let clbi = targetCLBI tgt lbi = lbi0{installedPkgs = index}- ipi <- generateOne pkg_descr lib lbi clbi flags+ 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)+ 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 mbWorkDir packageDbs installedPkgInfo <-@@ -155,29 +167,31 @@ -- 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 $ setupDistPref common- verbosity = fromFlag $ setupVerbosity 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@@ -214,11 +228,11 @@ -- registering into a totally different db stack can -- fail if dependencies cannot be satisfied. packageDbs =- nub $+ ordNub $ withPackageDB lbi ++ maybeToList (flagToMaybe (regPackageDB regFlags)) common = registerCommonFlags regFlags- verbosity = fromFlag (setupVerbosity common)+ verbosity = mkVerbosity verbHandles (fromFlag (setupVerbosity common)) mbWorkDir = mbWorkDirLBI lbi writeRegistrationFileOrDirectory = do@@ -340,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@@ -356,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@@ -383,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.@@ -415,7 +422,7 @@ -> String -> Compiler -> ProgramDb- -> (HcPkg.HcPkgInfo -> IO a)+ -> (HcPkg.ConfiguredProgram -> IO a) -> IO a withHcPkg verbosity name comp progdb f = case compilerFlavor comp of@@ -436,8 +443,6 @@ case compilerFlavor comp of GHC -> GHC.registerPackage verbosity progdb mbWorkDir packageDbs installedPkgInfo registerOptions GHCJS -> GHCJS.registerPackage verbosity progdb mbWorkDir packageDbs installedPkgInfo registerOptions- HaskellSuite{} ->- HaskellSuite.registerPackage verbosity progdb packageDbs installedPkgInfo _ | HcPkg.registerMultiInstance registerOptions -> dieWithException verbosity RegisMultiplePkgNotSupported@@ -449,14 +454,14 @@ -> Maybe (SymbolicPath CWD (Dir Pkg)) -> [InstalledPackageInfo] -> PackageDBStack- -> HcPkg.HcPkgInfo+ -> HcPkg.ConfiguredProgram -> IO () writeHcPkgRegisterScript verbosity mbWorkDir ipis packageDbs hpi = do let genScript installedPkgInfo = let invocation = HcPkg.registerInvocation hpi- Verbosity.normal+ Verbosity.Normal mbWorkDir packageDbs installedPkgInfo@@ -497,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@@ -518,22 +523,21 @@ , 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@@ -549,7 +553,8 @@ , IPI.ldOptions = ldOptions bi , IPI.frameworks = map getSymbolicPath $ frameworks bi , IPI.frameworkDirs = map getSymbolicPath $ extraFrameworkDirs bi- , IPI.haddockInterfaces = [haddockdir installDirs </> haddockLibraryPath pkg lib | hasModules]+ , IPI.haddockInterfaces =+ [haddockdir installDirs </> haddockLibraryPath pkg lib | hasModules] , IPI.haddockHTMLs = [htmldir installDirs | hasModules] , IPI.pkgRoot = Nothing , IPI.libVisibility = libVisibility lib@@ -601,6 +606,8 @@ ) | otherwise = (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@@ -639,6 +646,7 @@ (absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest) { libdir = i libTargetDir , dynlibdir = i libTargetDir+ , bytecodelibdir = i libTargetDir , datadir = let rawDataDir = dataDir pkg in if null $ getSymbolicPath rawDataDir@@ -649,7 +657,10 @@ , haddockdir = inplaceHtmldir } inplaceDocdir = distPref </> makeRelativePathEx "doc"- inplaceHtmldir = i $ inplaceDocdir </> makeRelativePathEx ("html" </> prettyShow (packageName pkg))+ inplaceHtmldir =+ i $+ (inplaceDocdir </> makeRelativePathEx "html")+ </> makeRelativePathEx (haddockLibraryDirPath ForDevelopment pkg lib) -- | Construct 'InstalledPackageInfo' for the final install location of a -- library package.@@ -713,11 +724,14 @@ -- 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 (setupVerbosity common)+ verbosity = mkVerbosity verbHandles (fromFlag (setupVerbosity common)) packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi))@@ -727,7 +741,7 @@ let invocation = HcPkg.unregisterInvocation hpi- Verbosity.normal+ Verbosity.Normal mbWorkDir packageDb pkgid
src/Distribution/Simple/Setup.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} -- |@@ -38,6 +38,7 @@ , globalCommand , CommonSetupFlags (..) , defaultCommonSetupFlags+ , commonSetupTempFileOptions , ConfigFlags (..) , emptyConfigFlags , defaultConfigFlags@@ -118,7 +119,9 @@ , splitArgs , defaultDistPref , optionDistPref- , Flag (..)+ , Flag+ , pattern Flag+ , pattern NoFlag , toFlag , fromFlag , fromFlagOrDefault@@ -167,7 +170,7 @@ import Distribution.Simple.Setup.Test import Distribution.Utils.Path -import Distribution.Verbosity (Verbosity)+import Distribution.Verbosity (VerbosityFlags) -- | What kind of build phase are we doing/hooking into? --@@ -191,7 +194,7 @@ BuildHaddock flags -> haddockCommonFlags flags BuildHscolour flags -> hscolourCommonFlags flags -buildingWhatVerbosity :: BuildingWhat -> Verbosity+buildingWhatVerbosity :: BuildingWhat -> VerbosityFlags buildingWhatVerbosity = fromFlag . setupVerbosity . buildingWhatCommonFlags buildingWhatWorkingDir :: BuildingWhat -> Maybe (SymbolicPath CWD (Dir Pkg))
src/Distribution/Simple/Setup/Benchmark.hs view
@@ -55,7 +55,7 @@ deriving (Show, Generic) pattern BenchmarkCommonFlags- :: Flag Verbosity+ :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File)@@ -118,7 +118,8 @@ [] ["benchmark-options"] ( "give extra options to benchmark executables "- ++ "(name templates can use $pkgid, $compiler, "+ ++ "(split on spaces, use \"\" to prevent splitting; "+ ++ "name templates can use $pkgid, $compiler, " ++ "$os, $arch, $benchmark)" ) benchmarkOptions@@ -132,7 +133,7 @@ [] ["benchmark-option"] ( "give extra option to benchmark executables "- ++ "(no need to quote options containing spaces, "+ ++ "(passed directly as a single argument; " ++ "name template can use $pkgid, $compiler, " ++ "$os, $arch, $benchmark)" )
src/Distribution/Simple/Setup/Build.hs view
@@ -61,7 +61,7 @@ deriving (Read, Show, Generic) pattern BuildCommonFlags- :: Flag Verbosity+ :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File)@@ -128,7 +128,8 @@ -- ++ " " ++ pname ++ " build foo:Foo.Bar\n" -- ++ " " ++ pname ++ " build testsuite1:Foo/Bar.hs\n" commandUsage =- usageAlternatives "build" $+ usageAlternatives+ "build" [ "[FLAGS]" , "COMPONENTS [FLAGS]" ]@@ -145,18 +146,17 @@ buildCommonFlags (\c f -> f{buildCommonFlags = c}) showOrParseArgs- ( [ optionNumJobs- buildNumJobs- (\v flags -> flags{buildNumJobs = v})- , option- []- ["semaphore"]- "semaphore"- buildUseSemaphore- (\v flags -> flags{buildUseSemaphore = v})- (reqArg' "SEMAPHORE" Flag flagToList)- ]- )+ [ 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
@@ -53,7 +53,7 @@ deriving (Show, Generic) pattern CleanCommonFlags- :: Flag Verbosity+ :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File)
src/Distribution/Simple/Setup/Common.hs view
@@ -1,8 +1,7 @@ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} -- |@@ -20,6 +19,7 @@ ( CommonSetupFlags (..) , defaultCommonSetupFlags , withCommonSetupOptions+ , commonSetupTempFileOptions , CopyDest (..) , configureCCompiler , configureLinker@@ -33,7 +33,9 @@ , defaultDistPref , extraCompilationArtifacts , optionDistPref- , Flag (..)+ , Flag+ , pattern Flag+ , pattern NoFlag , toFlag , fromFlag , fromFlagOrDefault@@ -69,7 +71,7 @@ -- | A datatype that stores common flags for different invocations -- of a @Setup@ executable, e.g. configure, build, install. data CommonSetupFlags = CommonSetupFlags- { setupVerbosity :: !(Flag Verbosity)+ { setupVerbosity :: !(Flag VerbosityFlags) -- ^ Verbosity , setupWorkingDir :: !(Flag (SymbolicPath CWD (Dir Pkg))) -- ^ Working directory (optional)@@ -82,6 +84,13 @@ -- -- 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) @@ -103,8 +112,17 @@ , 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@@ -121,6 +139,13 @@ 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). ]@@ -252,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@@ -289,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 []))@@ -365,8 +395,8 @@ (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
@@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-}@@ -45,8 +46,8 @@ import Distribution.Compat.Prelude hiding (get) import Prelude () +import Data.Semigroup (Last (..)) import qualified Distribution.Compat.CharParsing as P-import Distribution.Compat.Semigroup (Last' (..), Option' (..)) import Distribution.Compat.Stack import Distribution.Compiler import Distribution.ModuleName@@ -90,7 +91,7 @@ -- 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)]@@ -114,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.@@ -237,7 +240,7 @@ deriving (Generic, Read, Show) pattern ConfigCommonFlags- :: Flag Verbosity+ :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File)@@ -267,10 +270,7 @@ -- '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 =@@ -286,6 +286,7 @@ && equal configProfLib && equal configSharedLib && equal configStaticLib+ && equal configBytecodeLib && equal configDynExe && equal configFullyStaticExe && equal configProfExe@@ -336,12 +337,13 @@ defaultConfigFlags progDb = emptyConfigFlags { configCommonFlags = defaultCommonSetupFlags- , configPrograms_ = Option' (Just (Last' progDb))+ , 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@@ -438,13 +440,6 @@ [ (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@@ -507,6 +502,13 @@ (boolOpt [] []) , option ""+ ["library-bytecode"]+ "Bytecode library"+ configBytecodeLib+ (\v flags -> flags{configBytecodeLib = v})+ (boolOpt [] [])+ , option+ "" ["executable-dynamic"] "Executable dynamic linking" configDynExe@@ -571,7 +573,7 @@ [ optArgDef' "n" (show NoOptimisation, Flag . flagToOptimisationLevel)- ( \f -> case f of+ ( \case Flag NoOptimisation -> [] Flag NormalOptimisation -> [Nothing] Flag MaximumOptimisation -> [Just "2"]@@ -593,7 +595,7 @@ [ optArg' "n" (Flag . flagToDebugInfoLevel)- ( \f -> case f of+ ( \case Flag NoDebugInfo -> [] Flag MinimalDebugInfo -> [Just "1"] Flag NormalDebugInfo -> [Nothing]@@ -897,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 (makeSymbolicPath other))- showPackageDbList :: [Maybe PackageDB] -> [String] showPackageDbList = map showPackageDb @@ -1007,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@@ -1101,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,7 +1,7 @@ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-}@@ -58,7 +58,7 @@ deriving (Show, Generic) pattern CopyCommonFlags- :: Flag Verbosity+ :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File)@@ -112,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"])@@ -145,7 +146,7 @@ ( reqArg "DIR" (succeedReadE (Flag . CopyTo))- (\f -> case f of Flag (CopyTo p) -> [p]; _ -> [])+ (\case Flag (CopyTo p) -> [p]; _ -> []) ) , option ""@@ -160,7 +161,7 @@ ( reqArg "DATABASE" (succeedReadE (Flag . CopyToDb))- (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> [])+ (\case Flag (CopyToDb p) -> [p]; _ -> []) ) ]
src/Distribution/Simple/Setup/Global.hs view
@@ -44,6 +44,7 @@ -- | Flags that apply at the top level, not to any sub-command. data GlobalFlags = GlobalFlags { globalVersion :: Flag Bool+ , globalFullVersion :: Flag Bool , globalNumericVersion :: Flag Bool , globalWorkingDir :: Flag (SymbolicPath CWD (Dir Pkg)) }@@ -53,6 +54,7 @@ defaultGlobalFlags = GlobalFlags { globalVersion = Flag False+ , globalFullVersion = Flag False , globalNumericVersion = Flag False , globalWorkingDir = NoFlag }@@ -100,6 +102,13 @@ "Print version information" globalVersion (\v flags -> flags{globalVersion = v})+ trueArg+ , option+ []+ ["full-version"]+ "Print the version, Git revision if available, and compiler information"+ globalFullVersion+ (\v flags -> flags{globalFullVersion = v}) trueArg , option []
src/Distribution/Simple/Setup/Haddock.hs view
@@ -75,6 +75,7 @@ data HaddockTarget = ForHackage | ForDevelopment deriving (Eq, Show, Generic) instance Binary HaddockTarget+instance NFData HaddockTarget instance Structured HaddockTarget instance Pretty HaddockTarget where@@ -107,7 +108,6 @@ , haddockHscolourCss :: Flag FilePath , haddockContents :: Flag PathTemplate , haddockIndex :: Flag PathTemplate- , haddockKeepTempFiles :: Flag Bool , haddockBaseUrl :: Flag String , haddockResourcesDir :: Flag String , haddockOutputDir :: Flag FilePath@@ -116,7 +116,7 @@ deriving (Show, Generic) pattern HaddockCommonFlags- :: Flag Verbosity+ :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File)@@ -162,7 +162,6 @@ , haddockQuickJump = Flag False , haddockHscolourCss = NoFlag , haddockContents = NoFlag- , haddockKeepTempFiles = Flag False , haddockIndex = NoFlag , haddockBaseUrl = NoFlag , haddockResourcesDir = NoFlag@@ -179,7 +178,8 @@ "Requires the program haddock, version 2.x.\n" , commandNotes = Nothing , commandUsage =- usageAlternatives "haddock" $+ usageAlternatives+ "haddock" [ "[FLAGS]" , "COMPONENTS [FLAGS]" ]@@ -205,8 +205,7 @@ where progDb = addKnownProgram haddockProgram $- addKnownProgram ghcProgram $- emptyProgramDb+ addKnownProgram ghcProgram emptyProgramDb haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags] haddockOptions showOrParseArgs =@@ -216,13 +215,6 @@ showOrParseArgs [ option ""- ["keep-temp-files"]- "Keep temporary files"- haddockKeepTempFiles- (\b flags -> flags{haddockKeepTempFiles = b})- trueArg- , option- "" ["hoogle"] "Generate a hoogle database" haddockHoogle@@ -409,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`@@ -442,9 +435,7 @@ , -- 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+ -- haddockBaseUrl is not supported, a fixed value is provided haddockProjectResourcesDir :: Flag String , haddockProjectUseUnicode :: Flag Bool }@@ -453,7 +444,8 @@ defaultHaddockProjectFlags :: HaddockProjectFlags defaultHaddockProjectFlags = HaddockProjectFlags- { haddockProjectHackage = Flag False+ { haddockProjectCommonFlags = defaultCommonSetupFlags+ , haddockProjectHackage = Flag False , haddockProjectDir = Flag "./haddocks" , haddockProjectPrologue = NoFlag , haddockProjectTestSuites = Flag False@@ -467,8 +459,6 @@ , haddockProjectInternal = Flag False , haddockProjectCss = NoFlag , haddockProjectHscolourCss = NoFlag- , haddockProjectKeepTempFiles = Flag False- , haddockProjectVerbosity = Flag normal , haddockProjectResourcesDir = NoFlag , haddockProjectInterfaces = NoFlag , haddockProjectUseUnicode = NoFlag@@ -483,7 +473,8 @@ "Requires the program haddock, version 2.26.\n" , commandNotes = Nothing , commandUsage =- usageAlternatives "haddock-project" $+ usageAlternatives+ "haddock-project" [ "[FLAGS]" , "COMPONENTS [FLAGS]" ]@@ -509,144 +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- ""- ["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- ""- ["keep-temp-files"]- "Keep temporary files"- haddockProjectKeepTempFiles- (\b flags -> flags{haddockProjectKeepTempFiles = b})- trueArg- , optionVerbosity- haddockProjectVerbosity- (\v flags -> flags{haddockProjectVerbosity = v})- , 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- ]+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
@@ -57,7 +57,7 @@ deriving (Show, Generic) pattern HscolourCommonFlags- :: Flag Verbosity+ :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File)@@ -112,7 +112,7 @@ "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
src/Distribution/Simple/Setup/Install.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-}@@ -62,7 +62,7 @@ deriving (Show, Generic) pattern InstallCommonFlags- :: Flag Verbosity+ :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File)@@ -169,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
@@ -61,7 +61,7 @@ deriving (Show, Generic) pattern RegisterCommonFlags- :: Flag Verbosity+ :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File)@@ -111,54 +111,54 @@ 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- ]+ [ 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@@ -177,33 +177,33 @@ 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- ]+ [ 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
@@ -54,11 +54,12 @@ { replOptionsFlags :: [String] , replOptionsNoLoad :: Flag Bool , replOptionsFlagOutput :: Flag FilePath+ , replWithRepl :: Flag FilePath } deriving (Show, Generic) pattern ReplCommonFlags- :: Flag Verbosity+ :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File)@@ -85,7 +86,7 @@ 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@@ -229,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
@@ -56,7 +56,7 @@ deriving (Show, Generic) pattern SDistCommonFlags- :: Flag Verbosity+ :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File)
src/Distribution/Simple/Setup/Test.hs view
@@ -60,6 +60,7 @@ deriving (Eq, Ord, Enum, Bounded, Generic, Show) instance Binary TestShowDetails+instance NFData TestShowDetails instance Structured TestShowDetails knownTestShowDetails :: [TestShowDetails]@@ -85,7 +86,7 @@ mappend = (<>) instance Semigroup TestShowDetails where- a <> b = if a < b then b else a+ a <> b = max a b data TestFlags = TestFlags { testCommonFlags :: !CommonSetupFlags@@ -101,7 +102,7 @@ deriving (Show, Generic) pattern TestCommonFlags- :: Flag Verbosity+ :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File)@@ -131,8 +132,8 @@ defaultTestFlags = TestFlags { testCommonFlags = defaultCommonSetupFlags- , testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log"- , testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log"+ , testHumanLog = toFlag $ toPathTemplate "$pkgid-$test-suite.log"+ , testMachineLog = toFlag $ toPathTemplate "$pkgid.log" , testShowDetails = toFlag Direct , testKeepTix = toFlag False , testWrapper = NoFlag@@ -237,7 +238,7 @@ , option [] ["fail-when-no-test-suites"]- ("Exit with failure when no test suites are found.")+ "Exit with failure when no test suites are found." testFailWhenNoTestSuites (\v flags -> flags{testFailWhenNoTestSuites = v}) trueArg@@ -245,7 +246,8 @@ [] ["test-options"] ( "give extra options to test executables "- ++ "(name templates can use $pkgid, $compiler, "+ ++ "(split on spaces, use \"\" to prevent splitting; "+ ++ "name templates can use $pkgid, $compiler, " ++ "$os, $arch, $test-suite)" ) testOptions@@ -259,7 +261,7 @@ [] ["test-option"] ( "give extra option to test executables "- ++ "(no need to quote options containing spaces, "+ ++ "(passed directly as a single argument; " ++ "name template can use $pkgid, $compiler, " ++ "$os, $arch, $test-suite)" )
src/Distribution/Simple/SetupHooks/Errors.hs view
@@ -28,9 +28,6 @@ import Distribution.Types.Component import qualified Data.Graph as Graph-import Data.List- ( intercalate- ) import qualified Data.List.NonEmpty as NE import qualified Data.Tree as Tree @@ -129,7 +126,7 @@ showCycle (r, rs) = unlines . map (" " ++) . lines $ Tree.drawTree $- fmap showRule $+ fmap show $ Tree.Node r rs CantFindSourceForRuleDependencies _r deps -> unlines $@@ -170,24 +167,11 @@ "The index is too large." plural = if nbOutputs == 1 then "" else "s" DuplicateRuleId rId r1 r2 ->- unlines $+ unlines [ "Duplicate pre-build rule (" <> show rId <> ")"- , " - " <> showRule (ruleBinary r1)- , " - " <> showRule (ruleBinary r2)+ , " - " <> show (ruleBinary r1)+ , " - " <> show (ruleBinary r2) ]- where- showRule :: RuleBinary -> String- showRule (Rule{staticDependencies = deps, results = reslts}) =- "Rule: " ++ showDeps deps ++ " --> " ++ show (NE.toList reslts)--showDeps :: [Rule.Dependency] -> String-showDeps deps = "[" ++ intercalate ", " (map showDep deps) ++ "]"--showDep :: Rule.Dependency -> String-showDep = \case- RuleDependency (RuleOutput{outputOfRule = rId, outputIndex = i}) ->- "(" ++ show rId ++ ")[" ++ show i ++ "]"- FileDependency loc -> show loc cannotApplyComponentDiffCode :: CannotApplyComponentDiffReason -> Int cannotApplyComponentDiffCode = \case
+ 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
@@ -2,9 +2,12 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-}@@ -13,7 +16,8 @@ -- | -- Module: Distribution.Simple.SetupHooks.Internal ----- Internal implementation module.+-- Internal implementation module for 'SetupHooks'.+-- -- Users of @build-type: Hooks@ should import "Distribution.Simple.SetupHooks" -- instead. module Distribution.Simple.SetupHooks.Internal@@ -78,6 +82,7 @@ -- ** Executing build rules , executeRules+ , executeRulesUserOrSystem -- ** HookedBuildInfo compatibility code , hookedBuildInfoComponents@@ -89,7 +94,9 @@ 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@@ -110,20 +117,29 @@ 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)+import System.Directory (doesFileExist, getModificationTime)+import qualified System.FilePath as FilePath -------------------------------------------------------------------------------- -- SetupHooks@@ -790,8 +806,8 @@ Just diff -> applyComponentDiff verbosity c diff Nothing -> return c -forComponents_ :: PackageDescription -> (Component -> IO ()) -> IO ()-forComponents_ pd f = getConst $ traverseComponents (Const . f) pd+forComponents_ :: Applicative m => PackageDescription -> (Component -> m ()) -> m ()+forComponents_ pd f = getAp . getConst $ traverseComponents (Const . Ap . f) pd applyComponentDiff :: Verbosity@@ -850,7 +866,11 @@ -- an external hooks executable. executeRulesUserOrSystem :: forall userOrSystem- . SScope 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@@ -859,6 +879,12 @@ -> 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 $@@ -870,9 +896,9 @@ let (ruleGraph, ruleFromVertex, vertexFromRuleId) = Graph.graphFromEdges- [ (rule, rId, nub $ mapMaybe directRuleDependencyMaybe allDeps)+ [ (rule, rId, ordNub $ mapMaybe directRuleDependencyMaybe allDeps) | (rId, rule) <- Map.toList allRules- , let dynDeps = fromMaybe [] (fst <$> Map.lookup rId dynDepsEdges)+ , let dynDeps = maybe [] fst (Map.lookup rId dynDepsEdges) allDeps = staticDependencies rule ++ dynDeps ] @@ -891,20 +917,87 @@ , map (fmap ruleFromVertex) (v : vs) ) - -- Compute demanded rules.+ -- Compute demanded rules: anything reachable from the roots, which are: --- -- SetupHooks TODO: maybe requiring all generated modules to appear- -- in autogen-modules is excessive; we can look through all modules instead.+ -- - 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 $- componentBuildInfo $- targetComponent tgtInfo- leafRule_maybe (rId, r) =- if any ((r `ruleOutputsLocation`) . (Location compAutogenDir)) autogenModPaths- then vertexFromRuleId rId- else Nothing- leafRules = mapMaybe leafRule_maybe $ Map.toList allRules+ 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 @@ -923,54 +1016,41 @@ -- Emit a warning if there are non-demanded rules. unless (null nonDemandedRuleVerts) $ warn verbosity $- unlines $- "The following rules are not demanded and will not be run:"- : concat- [ [ " - " ++ show rId ++ ","- , " generating " ++ show (NE.toList $ results r)- ]- | v <- Set.toList nonDemandedRuleVerts- , let (r, rId, _) = ruleFromVertex v- ]- ++ [ "Possible reasons for this error:"- , " - Some autogenerated modules were not declared"- , " (in the package description or in the pre-configure hooks)"- , " - The output location for an autogenerated module is incorrect,"- , " (e.g. the file extension is incorrect, or"- , " it is not in the appropriate 'autogenComponentModules' directory)"- ]+ pprNotDemandedRuleReasons comp compAutogenDir (mconcat nonDmdReasons) - -- Run all the demanded rules, in dependency order.+ -- 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@Rule- { ruleCommands = cmds- , staticDependencies = staticDeps- , results = reslts- }- , rId- , _staticRuleDepIds- ) =- ruleFromVertex ruleVertex- mbDyn = Map.lookup rId dynDepsEdges- allDeps = staticDeps ++ fromMaybe [] (fst <$> mbDyn)+ 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: run the associated action.+ -- Dependencies OK: check whether the rule is up to date before+ -- deciding to run it. Nothing -> do- let execCmd = ruleExecCmd scope cmds (snd <$> mbDyn)- runCmdData rId execCmd- -- 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 reslts- for_ (NE.nonEmpty missingRuleResults) $ \missingResults ->- errorOut $ MissingRuleOutputs (toRuleBinary r) missingResults- return ()+ 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@@ -978,16 +1058,140 @@ 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@@ -995,7 +1199,7 @@ case Map.lookup depId allRules of Nothing -> error $- unlines $+ unlines [ "Internal error: missing rule dependency." , "Rule: " ++ show rId , "Dependency: " ++ show depId@@ -1013,14 +1217,13 @@ RulesException $ InvalidRuleOutputIndex rId depId os i --- | Does the rule output the given location?-ruleOutputsLocation :: RuleData scope -> Location -> Bool-ruleOutputsLocation (Rule{results = rs}) fp =- any (\out -> normaliseLocation out == normaliseLocation fp) rs- 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
src/Distribution/Simple/SetupHooks/Rule.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-}@@ -9,10 +8,8 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-}@@ -126,11 +123,7 @@ ) import qualified Control.Monad.Trans.Reader as Reader import qualified Control.Monad.Trans.State as State-#if MIN_VERSION_transformers(0,5,6) import qualified Control.Monad.Trans.Writer.CPS as Writer-#else-import qualified Control.Monad.Trans.Writer.Strict as Writer-#endif import qualified Data.ByteString.Lazy as LBS import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map@@ -274,6 +267,8 @@ 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@@ -294,12 +289,17 @@ -- | 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@@ -312,17 +312,32 @@ , results = res } --- | A rule with dynamic dependencies.+-- | 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@@ -612,9 +627,9 @@ -> StaticPtr (arg -> res) -> arg -> Command arg res-mkCommand dict actionPtr arg =+mkCommand dict action arg = Command- { actionPtr = UserStatic actionPtr+ { actionPtr = UserStatic action , actionArg = ScopedArgument arg , cmdInstances = UserStatic dict }@@ -629,6 +644,9 @@ -- - 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)@@ -680,6 +698,10 @@ } -> 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@@ -723,7 +745,7 @@ 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-incldues the length. We use this newtype:+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.@@ -824,9 +846,9 @@ } | Dict <- deRefStaticPtr instsPtr -> Just $ do- (deps, depsRes) <- runCommand depsCmd+ (deps, dynDeps) <- runCommand depsCmd -- See Note [Hooks Binary instances]- return $ (deps, Binary.encode $ ScopedArgument @User depsRes)+ 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.@@ -1087,6 +1109,35 @@ -- | 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)
src/Distribution/Simple/ShowBuildInfo.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications #-} -- | -- This module defines a simple JSON-based format for exporting basic@@ -216,5 +215,5 @@ ghcArgs = GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts baseOpts =- GHC.componentGhcOptions normal lbi bi clbi $+ GHC.componentGhcOptions Normal lbi bi clbi $ buildDir lbi
src/Distribution/Simple/SrcDist.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- @@ -73,7 +74,8 @@ -- | Create a source distribution. sdist- :: PackageDescription+ :: VerbosityHandles+ -> PackageDescription -- ^ information from the tarball -> SDistFlags -- ^ verbosity & snapshot@@ -82,7 +84,7 @@ -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) -> IO ()-sdist pkg flags mkTmpDir pps = do+sdist verbHandles pkg flags mkTmpDir pps = do distPref <- findDistPrefOrDefault $ setupDistPref common let targetPref = i distPref tmpTargetDir = mkTmpDir (i distPref)@@ -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@@ -122,7 +124,7 @@ overwriteSnapshotPackageDesc verbosity pkg' targetDir common = sDistCommonFlags flags- verbosity = fromFlag $ setupVerbosity common+ 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)@@ -310,7 +312,7 @@ -> IO () prepareTree verbosity mbWorkDir pkg_descr0 targetDir pps = do ordinary <- listPackageSources verbosity mbWorkDir pkg_descr pps- installOrdinaryFiles verbosity targetDir (zip (repeat []) $ map i ordinary)+ installOrdinaryFiles verbosity targetDir (map (([],) . i) ordinary) maybeCreateDefaultSetupScript targetDir where i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path@@ -397,11 +399,13 @@ -- @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'.@@ -428,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@@ -512,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
src/Distribution/Simple/Test.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} -----------------------------------------------------------------------------@@ -27,7 +28,7 @@ import qualified Distribution.PackageDescription as PD import Distribution.Pretty-import Distribution.Simple.Build (addInternalBuildToolsFixed)+import Distribution.Simple.Build (addInternalBuildTools) import Distribution.Simple.Compiler import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs@@ -42,6 +43,7 @@ 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@@ -53,15 +55,14 @@ import Distribution.Types.LocalBuildInfo (LocalBuildInfo (..)) import System.Directory ( createDirectoryIfMissing- , doesFileExist- , getDirectoryContents- , removeFile+ , listDirectory ) -- | Perform the \"@.\/setup test@\" action. test :: Args -- ^ positional command-line arguments+ -> VerbosityHandles -> PD.PackageDescription -- ^ information from the .cabal file -> LBI.LocalBuildInfo@@ -69,10 +70,10 @@ -> TestFlags -- ^ flags sent to test -> IO ()-test args pkg_descr lbi0 flags = do+test args verbHandles pkg_descr lbi0 flags = do curDir <- LBI.absoluteWorkingDirLBI lbi0 let common = testCommonFlags flags- verbosity = fromFlag $ setupVerbosity common+ 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@@ -96,8 +97,8 @@ lbi { withPrograms = -- Include any build-tool-depends on build tools internal to the current package.- addInternalBuildToolsFixed- (Just curDir)+ addInternalBuildTools+ curDir pkg_descr lbi (PD.testBuildInfo suite)@@ -105,9 +106,9 @@ } case PD.testInterface suite of PD.TestSuiteExeV10 _ _ ->- ExeV10.runTest pkg_descr lbiForTest clbi hpcMarkupInfo flags suite+ ExeV10.runTest verbHandles pkg_descr lbiForTest clbi hpcMarkupInfo flags suite PD.TestSuiteLibV09 _ _ ->- LibV09.runTest pkg_descr lbiForTest clbi hpcMarkupInfo flags suite+ LibV09.runTest verbHandles pkg_descr lbiForTest clbi hpcMarkupInfo flags suite _ -> return TestSuiteLog@@ -132,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@@ -148,9 +149,8 @@ createDirectoryIfMissing True $ i testLogDir -- Delete ordinary files from test log directory.- getDirectoryContents (i testLogDir)- >>= filterM doesFileExist . map (i 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@@ -159,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
src/Distribution/Simple/Test/ExeV10.hs view
@@ -20,6 +20,7 @@ , buildDir , depLibraryPaths )+ import Distribution.Simple.Program.Db import Distribution.Simple.Program.Find import Distribution.Simple.Program.Run@@ -27,7 +28,7 @@ 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 (..)@@ -43,22 +44,21 @@ import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI, packageRoot) import System.Directory ( createDirectoryIfMissing- , doesDirectoryExist , doesFileExist- , removeDirectoryRecursive+ , removePathForcibly )-import System.IO (stderr, stdout) import System.Process (createPipe) 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_ = i $ tixDir distPref way@@ -74,15 +74,14 @@ 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 (with the appropriate environment set) let progDb = LBI.withPrograms lbi@@ -93,7 +92,7 @@ map (testOption pkg_descr lbi suite) (testOptions flags)- tixFile = packageRoot (testCommonFlags flags) </> getSymbolicPath (tixFilePath distPref way (testName'))+ tixFile = packageRoot (testCommonFlags flags) </> getSymbolicPath (tixFilePath distPref way testName') shellEnv <- getFullEnvironment@@ -113,16 +112,17 @@ -- 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)@@ -139,11 +139,10 @@ (cmd : opts) mbWorkDir (Just shellEnv')- getLogText- -- these handles are automatically closed+ (\_ _ _ -> getLogText) Nothing- (Just wOut)- (Just wErr)+ wOut+ wErr NoFlag -> rawSystemIOWithEnvAndAction verbosity@@ -151,11 +150,10 @@ opts 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.@@ -179,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@@ -206,7 +204,7 @@ testName' = unUnqualComponentName $ PD.testName suite distPref = fromFlag $ setupDistPref commonFlags- verbosity = fromFlag $ setupVerbosity commonFlags+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity commonFlags) details = fromFlag $ testShowDetails flags testLogDir = distPref </> makeRelativePathEx "test"
src/Distribution/Simple/Test/LibV09.hs view
@@ -46,25 +46,24 @@ import System.Directory ( canonicalizePath , createDirectoryIfMissing- , doesDirectoryExist , doesFileExist , getCurrentDirectory- , removeDirectoryRecursive- , removeFile+ , removePathForcibly , setCurrentDirectory ) 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 @@ -82,9 +81,8 @@ Couldn'tFindTestProgLibV09 cmd -- Remove old .tix files if appropriate.- unless (fromFlag $ testKeepTix flags) $ do- exists' <- doesDirectoryExist tDir- when exists' $ removeDirectoryRecursive tDir+ unless (fromFlag $ testKeepTix flags) $+ removePathForcibly tDir -- Create directory for HPC files. createDirectoryIfMissing True tDir@@ -92,7 +90,7 @@ -- 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@@ -183,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@@ -210,17 +208,13 @@ common = testCommonFlags flags testName' = unUnqualComponentName $ PD.testName suite - deleteIfExists file = do- exists <- doesFileExist file- when exists $ removeFile file- testLogDir = distPref </> makeRelativePathEx "test" openCabalTemp = do (f, h) <- openTempFile (i testLogDir) $ "cabal-test-" <.> "log" hClose h >> return f distPref = fromFlag $ setupDistPref common- verbosity = fromFlag $ setupVerbosity common+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) -- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't -- necessarily a path.@@ -312,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) =@@ -328,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,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} -----------------------------------------------------------------------------@@ -59,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@@ -78,6 +78,7 @@ , compilerLanguages = uhcLanguages , compilerExtensions = uhcLanguageExtensions , compilerProperties = Map.empty+ , compilerWiredInUnitIds = Nothing } compPlatform = Nothing return (comp, compPlatform, progdb')@@ -121,18 +122,17 @@ let compilerid = compilerId comp systemPkgDir <- getGlobalPackageDir verbosity progdb userPkgDir <- getUserPackageDir- let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir mbWorkDir) 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) @@ -231,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 @@ -266,7 +264,7 @@ -- output file ++ ["--output", u $ buildDir lbi </> makeRelativePathEx (prettyShow (exeName exe))] -- main source module- ++ [u $ srcMainPath]+ ++ [u srcMainPath] runUhcProg uhcArgs constructUHCCmdLine@@ -279,14 +277,7 @@ -> 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)@@ -298,7 +289,7 @@ ++ ["--package=" ++ prettyShow (mungedName pkgid) | (_, pkgid) <- componentPackageDeps clbi] -- search paths ++ ["-i" ++ u odir]- ++ ["-i" ++ u l | l <- nub (hsSourceDirs bi)]+ ++ ["-i" ++ u l | l <- ordNub (hsSourceDirs bi)] ++ ["-i" ++ u (autogenComponentModulesDir lbi clbi)] ++ ["-i" ++ u (autogenPackageModulesDir lbi)] -- cpp options@@ -313,6 +304,11 @@ ) 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 =@@ -329,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
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@@ -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,14 +1,18 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-} {-# 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 ----------------------------------------------------------------------------- @@ -28,6 +32,8 @@ -- various directory and file functions that do extra logging. module Distribution.Simple.Utils ( cabalVersion+ , cabalGitInfo+ , cabalCompilerInfo -- * logging and errors , dieNoVerbosity@@ -37,6 +43,7 @@ , dieNoWrap , topHandler , topHandlerWith+ , isUserException , warn , warnError , notice@@ -90,6 +97,9 @@ , copyFileTo , copyFileToCwd + -- * removing files+ , removeFileForcibly+ -- * installing files , installOrdinaryFile , installExecutableFile@@ -183,6 +193,7 @@ , listUnion , listUnionRight , ordNub+ , sortNub , ordNubBy , ordNubRight , safeHead@@ -192,6 +203,7 @@ , unintersperse , wrapText , wrapLine+ , stripCommonPrefix -- * FilePath stuff , isAbsoluteOnAnyPlatform@@ -201,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@@ -235,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@@ -247,11 +261,12 @@ , createDirectory , doesDirectoryExist , doesFileExist- , getDirectoryContents , getModificationTime , getPermissions- , removeDirectoryRecursive+ , getTemporaryDirectory+ , listDirectory , removeFile+ , removePathForcibly ) import System.Environment ( getProgName@@ -259,11 +274,13 @@ import System.FilePath (takeFileName) import System.FilePath as FilePath ( getSearchPath+ , isExtensionOf , joinPath , normalise , searchPathSeparator , splitDirectories , splitExtension+ , stripExtension , takeDirectory ) import System.IO@@ -277,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)@@ -296,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 @@ -383,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+-- 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@@ -444,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@@ -456,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@@ -466,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@@ -496,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 ->@@ -511,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. --@@ -533,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 ()@@ -542,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. --@@ -558,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.@@ -598,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 @@ -634,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.@@ -667,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@@ -675,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@@ -701,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 =@@ -720,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@@ -752,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 @@ -764,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 $@@ -787,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@@ -804,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@@ -818,7 +915,7 @@ else "" else "" )- ++ ( if verbosity >= verbose+ ++ ( if vLevel verbosity >= Verbose then prettyCallStack stack ++ "\n" else "" )@@ -870,18 +967,24 @@ -- the command's exit code. rawSystemExitCode :: Verbosity- -> Maybe (SymbolicPath CWD (Dir Pkg))+ -> Maybe (SymbolicPath CWD (Dir to)) -> FilePath -> [String] -> Maybe [(String, String)] -> IO ExitCode rawSystemExitCode verbosity mbWorkDir path args menv = withFrozenCallStack $- rawSystemProc verbosity $- (proc path args)- { Process.cwd = fmap getSymbolicPath mbWorkDir- , Process.env = menv- }+ 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.@@ -909,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)@@ -920,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.@@ -940,7 +1091,7 @@ -- | Like 'rawSystemExitWithEnv', but setting a working directory. rawSystemExitWithEnvCwd :: Verbosity- -> Maybe (SymbolicPath CWD to)+ -> Maybe (SymbolicPath CWD (Dir to)) -> FilePath -> [String] -> [(String, String)]@@ -948,11 +1099,7 @@ rawSystemExitWithEnvCwd verbosity mbWorkDir path args env = withFrozenCallStack $ maybeExit $- rawSystemProc verbosity $- (proc path args)- { Process.env = Just env- , Process.cwd = getSymbolicPath <$> mbWorkDir- }+ rawSystemExitCode verbosity mbWorkDir path args (Just env) -- | Execute the given command with the given arguments, returning -- the command's exit code.@@ -982,7 +1129,7 @@ args mcwd menv- action+ (\_ _ _ -> action) inp out err@@ -1001,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@@ -1014,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. --@@ -1430,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@@ -1439,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)@@ -1449,10 +1605,6 @@ then collect files (dirEntry : dirs') entries else collect (dirEntry : files) dirs' entries - ignore ['.'] = True- ignore ['.', '.'] = True- ignore _ = False- ------------------------ -- Environment variables @@ -1522,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@@ -1585,7 +1737,7 @@ 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 @@ -1664,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)@@ -1733,23 +1905,17 @@ -- | 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 f = withFrozenCallStack $- withTempFileCwd Nothing (makeSymbolicPath tmpDir) template $+withTempFile template f = withFrozenCallStack $+ withTempFileCwd template $ \fp h -> f (getSymbolicPath fp) h -- | Use a temporary filename that doesn't already exist. withTempFileCwd- :: Maybe (SymbolicPath CWD (Dir Pkg))- -- ^ Working directory- -> SymbolicPath Pkg (Dir tmpDir)- -- ^ Temp dir to create the file in- -> String+ :: String -- ^ File name template. See 'openTempFile'. -> (SymbolicPath Pkg File -> Handle -> IO a) -> IO a@@ -1758,33 +1924,28 @@ -- | A version of 'withTempFile' that additionally takes a 'TempFileOptions' -- argument. withTempFileEx- :: forall a tmpDir+ :: forall a . TempFileOptions- -> Maybe (SymbolicPath CWD (Dir Pkg))- -- ^ Working directory- -> SymbolicPath Pkg (Dir tmpDir)- -- ^ Temp dir to create the file in -> String -- ^ File name template. See 'openTempFile'. -> (SymbolicPath Pkg File -> Handle -> IO a) -> IO a-withTempFileEx opts mbWorkDir tmpDir template action =+withTempFileEx opts template action = do+ tmp <- getTemporaryDirectory withFrozenCallStack $ Exception.bracket- (openTempFile (i tmpDir) template)+ (openTempFile tmp template) ( \(name, handle) -> do hClose handle unless (optKeepTempFiles opts) $ handleDoesNotExist () $- removeFile $- name+ removeFile name )- (withLexicalCallStack (\(fn, h) -> action (mkRelToPkg fn) h))+ (withLexicalCallStack (\(fn, h) -> action (mkRelToPkg tmp fn) h)) where- i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path- mkRelToPkg :: FilePath -> SymbolicPath Pkg File- mkRelToPkg fp =- tmpDir </> makeRelativePathEx (takeFileName fp)+ 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@@ -1797,20 +1958,18 @@ -- 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+ :: FilePath -> String -> (FilePath -> IO a) -> IO a-withTempDirectory verb targetDir template f =+withTempDirectory targetDir template f = withFrozenCallStack $ withTempDirectoryCwd- verb Nothing (makeSymbolicPath targetDir) template@@ -1821,22 +1980,20 @@ -- 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@. withTempDirectoryCwd- :: Verbosity- -> Maybe (SymbolicPath CWD (Dir Pkg))+ :: Maybe (SymbolicPath CWD (Dir Pkg)) -- ^ Working directory -> SymbolicPath Pkg (Dir tmpDir1) -> String -> (SymbolicPath Pkg (Dir tmpDir2) -> IO a) -> IO a-withTempDirectoryCwd verbosity mbWorkDir targetDir template f =+withTempDirectoryCwd mbWorkDir targetDir template f = withFrozenCallStack $ withTempDirectoryCwdEx- verbosity defaultTempFileOptions mbWorkDir targetDir@@ -1846,37 +2003,34 @@ -- | 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 verbosity opts Nothing (makeSymbolicPath targetDir) template $+ 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- . Verbosity- -> TempFileOptions+ . TempFileOptions -> Maybe (SymbolicPath CWD (Dir Pkg)) -- ^ Working directory -> SymbolicPath Pkg (Dir tmpDir1) -> String -> (SymbolicPath Pkg (Dir tmpDir2) -> IO a) -> IO a-withTempDirectoryCwdEx _verbosity opts mbWorkDir targetDir template f =+withTempDirectoryCwdEx opts mbWorkDir targetDir template f = withFrozenCallStack $ Exception.bracket (createTempDirectory (i targetDir) template) ( \tmpDirRelPath -> unless (optKeepTempFiles opts) $- handleDoesNotExist () $- removeDirectoryRecursive (i targetDir </> tmpDirRelPath)+ removePathForcibly (i targetDir </> tmpDirRelPath) ) (withLexicalCallStack (\tmpDirRelPath -> f $ targetDir </> makeRelativePathEx tmpDirRelPath)) where@@ -1982,7 +2136,7 @@ findPackageDesc mbPkgDir = do let pkgDir = maybe "." getSymbolicPath mbPkgDir- files <- getDirectoryContents pkgDir+ 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 <-@@ -2018,7 +2172,7 @@ -> IO (Maybe (SymbolicPath Pkg File)) -- ^ /dir/@\/@/pkgname/@.buildinfo@, if present findHookedPackageDesc verbosity mbWorkDir dir = do- files <- getDirectoryContents $ interpretSymbolicPath mbWorkDir dir+ files <- listDirectory $ interpretSymbolicPath mbWorkDir dir buildInfoFiles <- filterM (doesFileExist . interpretSymbolicPath mbWorkDir)@@ -2034,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
@@ -5,6 +5,8 @@ ( ComponentLocalBuildInfo (..) , componentIsIndefinite , maybeComponentInstantiatedWith+ , maybeComponentCompatPackageKey+ , maybeComponentExposedModules ) where import Distribution.Compat.Prelude@@ -125,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
@@ -5,6 +5,7 @@ ) where import Distribution.Compat.Prelude+import Distribution.Parsec data DumpBuildInfo = NoDumpBuildInfo@@ -12,4 +13,14 @@ 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/LocalBuildConfig.hs view
@@ -2,8 +2,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -158,6 +156,8 @@ -- ^ 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@@ -205,27 +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- , configProfShared = toFlag $ withProfLibShared+ { 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
@@ -33,6 +33,7 @@ , withProfExe , withSharedLib , withStaticLib+ , withBytecodeLib , withProfLibDetail , withProfExeDetail , withOptimization@@ -173,6 +174,7 @@ -> Bool -> Bool -> Bool+ -> Bool -> ProfDetailLevel -> ProfDetailLevel -> OptimisationLevel@@ -208,6 +210,7 @@ , withProfLibShared , withSharedLib , withStaticLib+ , withBytecodeLib , withDynExe , withFullyStaticExe , withProfExe@@ -260,6 +263,7 @@ , withProfLibShared , withSharedLib , withStaticLib+ , withBytecodeLib , withDynExe , withFullyStaticExe , withProfExe@@ -389,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) @@ -446,7 +448,7 @@ let -- enable-library-profiling (enable (static profiling way)) .p_o -- enable-shared (enabled dynamic way) .dyn_o- -- enable-profiling-shared (enable dyanmic profilng way) .p_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
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,5 +1,6 @@ module Distribution.Utils.MapAccum (mapAccumM) where +import Data.Bifunctor (second) import Distribution.Compat.Prelude import Prelude () @@ -7,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)@@ -23,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
@@ -75,6 +75,9 @@ 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"]@, -- unlike the normal 'NubList', which is left-biased. Built on top of
src/Distribution/Utils/Progress.hs view
@@ -62,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,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- @@ -24,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@@ -39,7 +54,6 @@ , showForGHC , verboseNoFlags , verboseHasFlags- , modifyVerbosity -- * Call stacks , verboseCallSite@@ -47,7 +61,7 @@ , isVerboseCallSite , isVerboseCallStack - -- * Output markets+ -- * Output markers , verboseMarkOutput , isVerboseMarkOutput , verboseUnmarkOutput@@ -84,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)+ 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@@ -139,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@@ -149,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@@ -211,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@@ -236,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"@@ -262,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
@@ -12,6 +12,7 @@ deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded) instance Binary VerbosityLevel+instance NFData VerbosityLevel instance Structured VerbosityLevel data VerbosityFlag@@ -26,4 +27,5 @@ 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